UCW Source
(defclass generic-widget-component ()
((css-class :accessor widget-component.css-class
:initform nil
:initarg :css-class
:type (or null string))
(css-id :accessor widget-component.css-id
:initform nil
:initarg :css-id
:type (or null string))
(css-style :accessor widget-component.css-style
:initform nil
:initarg :css-style
:type (or null string)))
(:metaclass standard-component-class)
(:documentation "A web widget.
Widget components manage the state and the graphical presentation
for one element of the user interface. Widget components are
embedded in other widgets or in a window-component.
If the css-class, css-id or css-style slots are true then the
component will be wrapped (when rendering) in a <div> tag with
the corresponding attributes set."))
(defclass widget-component (generic-widget-component)
()
(:metaclass standard-component-class)
(:documentation "A widget which should be wrapped in a <div>."))
(defclass inline-widget-component (generic-widget-component)
()
(:metaclass standard-component-class)
(:documentation "A widget which should be wrapped in <span> and not <div>"))
(defmacro widget-render-on-helper (widget div-or-span)
`(with-slots (css-class css-id css-style)
,widget
(if (or css-class css-id css-style)
(,div-or-span :class css-class
:id css-id
:style css-style
(call-next-method))
(call-next-method))))
(defmethod render-on :wrapping ((res response) (widget widget-component))
"Wrap WIDGET in a <div> tag."
(widget-render-on-helper widget <:div))
(defmethod render-on :wrapping ((res response) (widget inline-widget-component))
"Wrap widget in a <span> tag."
(widget-render-on-helper widget <:span))
(defclass window-component ()
()
(:metaclass standard-component-class)
(:documentation "One browser window."))
(defmethod/cc call-component ((from null) (to window-component))
(let/cc k
(setf (component.place to) (make-place (context.window-component *context*))
(component.continuation to) k
(context.window-component *context*) to)
to))
(defmethod answer-component ((window window-component) value)
"Answering for window-components.
The idea is very similar to regular components except for the
fact that window-components may not have a calling component."
(when (and (slot-boundp window 'calling-component)
(component.calling-component window))
(setf (place (component.place window)) (component.calling-component window)))
(funcall (component.continuation window) value))
(defmethod parent ((w window-component)) nil)
(defmethod (setf parent) (parent (w window-component))
(declare (ignore w))
;;;;; setting the parent of a window-component is a noop.
parent)
(defclass simple-window-component (window-component)
((title :accessor window-component.title
:initarg :title
:initform nil )
(stylesheet :accessor window-component.stylesheet
:initarg :stylesheet
:initform nil
:documentation "The URL of the css file to use as a stylesheet for this window.")
(content-type :accessor window-component.content-type
:initarg :content-type
:initform "text/html"
:documentation "The Content-Type header for the
http response (also used in the meta tag)")
(javascript :accessor window-component.javascript
:initarg :javascript
:initform nil
:documentation "The URL of the javascript file to include in this window.")
(inline-javascript :accessor window-component.inline-javascript
:initarg :inline-javascript
:initform nil))
(:metaclass standard-component-class)
(:documentation "A convience class for writing window components.
Subclass of simple-window-component should implement the
render-body method, not render-on."))
(defmethod render-on :wrapping ((res response) (window simple-window-component))
"This convience method assumes: 1) the stylesheet is
external (as opposed to inlined) or is not used; 2) the script
file is javascript and is external or is no script is used and 3)
the title is simply the value of the title slot in the WINDOW (no
dynamic titles)."
(setf (get-header res "Content-Type") (window-component.content-type window))
(<:as-is "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/transitional.dtd\">"
#\Newline)
(<:html
(<:head
(<:meta :http-equiv "Content-Type" :content (window-component.content-type window))
(<:title (<:as-html (window-component.title window)))
(when (window-component.stylesheet window)
(<:link :rel "stylesheet"
:href (window-component.stylesheet window)
:type "text/css"))
(when (window-component.javascript window)
(dolist (js (ensure-list (window-component.javascript window)))
;; most browsers (firefox, safari and ie at least) really,
;; really, really don't like empty script tags. The "" forces
;; yaclml to generate a seperate closing tag.
(<:script :type "text/javascript" :src js "")))
(when (window-component.inline-javascript window)
(<:script :type "text/javascript"
(<:as-html (window-component.inline-javascript window)))))
(<:body (call-next-method))))
(defclass template-component (standard-component)
((template-name :accessor template-component.template-name
:initarg :template-name
:initform nil))
(:metaclass standard-component-class)
(:documentation "Component which is rendered via a TAL template."))
(defgeneric template-component-environment (component)
(:documentation "Create the TAL environment for rendering COMPONENT's template.
Methods defined on this generic function must return a TAL
environment: a list of TAL binding sets (see the documentation
for YACLML:MAKE-STANDARD-ENVIROMENT for details on TAL
environments.)")
(:method-combination nconc))
(defmethod template-component-environment nconc ((component template-component))
"Create the basic TAL environment.
Binds the symbol ucw:component to the component object itself,
also puts the object COMPONENT on the environment (after the
binding of ucw:component) so that slots are, by default,
visable."
(make-standard-environment `((component . ,component)) component))
(defmethod render-on ((response response) (component template-component))
"Render a template based component.
Calls the component's template. The name of the template is the
value returned by the generic function
template-component.template-name, the template will be rendered
in the environment returned by the generic function
template-component-environment."
(render-template *context*
(template-component.template-name component)
(template-component-environment component)))
(defclass simple-template-component (template-component)
((environment :initarg :environment :initform nil))
(:metaclass standard-component-class))
(defmethod template-component-environment nconc ((component simple-template-component))
(slot-value component 'environment))
(defclass container ()
((contents :accessor container.contents :initform '()
:initarg :contents
:documentation "An alist of (label . component) holding the controlled components.")
(current-component-name :accessor container.current-component-name
:initarg :current-component-name
:backtrack t
:documentation "The label of the current component."
:initform nil)
(label-test :accessor container.label-test
:documentation "Function used to compare two labels."
:initarg :label-test
:initform #'eql))
(:metaclass standard-component-class)
(:documentation "Allow multiple components to share the same place.
The container component serves to manage a set of components
which share the same place in the UI. Of the components under the
containers control only one (the current-component) is generally
rendered.
The container component class is generally used as the super
class for navigatation components and tabbed-pane like
components.
Each contained component has a \"label\" associated with it which
is used to retrieve a particular component and switch
components. Labels are compared with container.label-test.
The :contents inintarg, if provided, must be a list (tag .
component)."))
(defmethod shared-initialize :after ((c container) slot-names
&rest initargs
&key contents)
"This method sets up any initial contenst for backtacking. If
the contents are created via (setf find-component) then the
backtracking is done there."
(declare (ignore initargs slot-names))
(setf (container.contents c) nil)
(dolist* ((label . comp) contents)
(setf (find-component c label) comp)))
(defmethod find-component ((c container) label)
"Returns the component object in C associated with LABEL."
(if-bind comp (cdr (assoc label (container.contents c)
:test (container.label-test c)))
(values comp t)
(values nil nil)))
(defmethod (setf find-component) ((component component)
(container container)
label)
"Associates LABEL with COMPONENT in the container CONTAINER."
(with-slots (contents label-test)
container
(setf (parent component) container)
(if-bind comp-cons (assoc label contents :test label-test)
(setf (parent (cdr comp-cons)) nil
(cdr comp-cons) component
(component.place component) (make-place (cdr comp-cons)))
(let* ((container-cons (cons label component))
(place (make-place (cdr container-cons))))
(setf (component.place component) place
contents (cons container-cons contents))
(backtrack (context.current-frame *context*) place))))
component)
(defmacro initialize-container ((container &key label-test current-component)
&body contents)
(rebinding (container label-test current-component)
`(setf ,@(iterate
(for (label component-type . initargs) in contents)
(collect `(find-component ,container ,label))
(collect `(make-instance ',component-type ,@initargs)))
(container.label-test ,container) (or ,label-test (container.label-test ,container))
(container.current-component-name ,container) (or ,current-component
',(first (car (last contents)))))))
(defmethod container.current-component ((container container))
(find-component container (container.current-component-name container)))
(defmethod ensure-valid-component-label ((container container) label)
"Returns T is LABEL names one of the component in CONTAINER.
Otherwise a restartable error is signaled."
(if (find-component container label)
t
(restart-case
(error "No component named ~S in container ~S [~S]."
label container (container.contents container))
(use-first ()
:report (lambda (stream)
(format stream "Use the first component in the container (~S)"
(cdr (first (container.contents container)))))
(cdr (first (container.contents container)))))))
(defaction switch-component ((container container) label)
(ensure-valid-component-label container label)
(setf (container.current-component-name container) label))
(defmethod map-contents (func (container container))
(mapcar (lambda (comp-spec)
(funcall func (car comp-spec) (cdr comp-spec)))
(container.contents container)))
(defclass simple-container (container)
()
(:metaclass standard-component-class)
(:documentation "A simple renderable container component.
This component is exactly like the regular CONTAINER but provides
an implementation of RENDER-ON which simply renders its current
component."))
(defmethod render-on ((res response) (container simple-container))
(render-on res (container.current-component container)))