[Initial file import
Marco Baringer <mb@bese.it>**20060219212004] {
adddir ./examples
adddir ./src
addfile ./examples/presentations.lisp
hunk ./examples/presentations.lisp 1
+
+(in-package :it.bese.ucw-user)
+
+;;;; The simple person "database"
+
+(defclass person ()
+  ((first-name :accessor first-name :initarg :first-name)
+   (last-name  :accessor last-name  :initarg :last-name)
+   (dob :accessor dob :initarg :dob)
+   (friends :accessor friends :initarg :friends :initform '())
+   (best-friend :accessor best-friend :initform nil)
+   (children :accessor children :initform nil)
+   (address :accessor address :initform nil)))
+
+(defparameter *people*
+  (flet ((person (first-name last-name dob)
+	   (make-instance 'person :first-name first-name
+			          :last-name last-name
+				  :dob dob)))
+    (list (person "Alice" "Almond" (make-time :year 1900))
+	  (person "Bob" "Billy" (make-time :year 1950))
+	  (person "Carol" "Clive" (make-time :year 1970)))))
+
+(defmethod age ((p person))
+  (if (and (slot-boundp p 'dob) (dob p))
+      (- (nth-value 0 (time-ymd (time+ (make-time :year 1900 :day 1 :month 1)
+				       (time-difference (get-time) (dob p)))))
+	 1900)
+      "n/a"))
+
+(defclass address ()
+  ((street :initform "")
+   (city :initform "")
+   (state :initform "")
+   (country :initform "")
+   (postal-code :initform "")))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; finally, here are our presentations:
+
+;;;; The first presentation, and the one we almost always have, is for
+;;;; editing all the details regarding a person. Most of the slots of
+;;;; the presentation are tied to acutal slots in person instances,
+;;;; the only exception here is age, which is a derived slot.
+
+(defpresentation person-editor (object-presentation)
+  ((string :label "First Name" :slot-name 'first-name :max-length 30)
+   (string :label "Last Name" :slot-name 'last-name :max-length 30)
+   (integer :label "Age" :getter #'age :editablep nil)
+   (date :label "Date of Birth" :slot-name 'dob)
+   (some-of :label "Friends" :slot-name 'friends
+	    :presentation 'person-friend-select)
+   (one-of :label "Best Friend" :slot-name 'best-friend
+	   :presentation 'person-best-friend-select)
+   (an-object :label "Address" :slot-name 'address
+	      :presentation 'address-editor)
+   (some-objects :label "Children" :slot-name 'children
+		 :presentation 'person-editor)))
+
+(defmethod/cc make-new-instance ((e person-editor) instance)
+  (let ((p (make-instance 'person :last-name (last-name instance))))
+    (push p *people*)
+    p))
+
+(defpresentation address-editor (inline-object-presentation)
+  ((string :label "Street" :slot-name 'street)
+   (string :label "City" :slot-name 'city)
+   (string :label "State" :slot-name 'state)
+   (string :label "Country" :slot-name 'country)
+   (string :label "Postal Code" :slot-name 'postal-code)))
+
+(defaction create-an-object ((address-editor address-editor) instance)
+  (declare (ignore instance))
+  (make-instance 'address))
+
+;;;; since we have some relations whose target is a person we also
+;;;; need a way to present people inside a drop down box:
+
+(defpresentation person-select (one-line-presentation)
+  ((string :slot-name 'first-name :editablep nil :label "First Name")
+   (string :slot-name 'last-name :editablep nil :label "Last Name")))
+
+(defmethod get-foreign-instances :around ((p person-select) instance)
+  (declare (ignore instance))
+  (sort (copy-list (call-next-method)) #'string< :key #'last-name))
+
+(defmethod get-foreign-instances ((p person-select) instance)
+  (declare (ignore instance))
+  *people*)
+
+;;;; the person-friend-select is just like person-select but excludes
+;;;; the current person.
+
+(defpresentation person-friend-select (person-select)
+  ())
+
+(defmethod get-foreign-instances ((p person-friend-select) instance)
+  (set-difference *people* (cons instance (friends instance))))
+
+;;;; the best-friend relation only shows a sub set of the people
+;;;; (those who are already firends). It's slots are the same, only
+;;;; the get-all-instances method is different.
+
+(defpresentation person-best-friend-select (person-select)
+  ())
+
+(defmethod get-foreign-instances ((p person-best-friend-select) instance)
+  (friends instance))
+
+;;;; this presentation is used when generically listing people and
+;;;; when listing the results of people searches
+
+(defpresentation person-listing (list-presentation)
+  ((string :label "First Name" :slot-name 'first-name  :editablep nil)
+   (string :label "Last Name"  :slot-name 'last-name :editablep nil)
+   (integer :label "Age"       :getter #'age :editablep nil))
+  :editablep t
+  :deleteablep t)
+
+(defmethod get-all-instances ((person-listing person-listing))
+  (sort (copy-list *people*) #'string< :key #'last-name))
+
+(defaction edit-from-listing ((person-listing person-listing) (person person) index)
+  (declare (ignore index))
+  (present-object person :using person-editor))
+
+;;;; we allow people to be deleted from the listing:
+
+(defaction delete-from-listing ((listing person-listing) object index)
+  ;;;; since we can't have duplicates in *people* we can safely ignore
+  ;;;; the ITEM orgument
+  (declare (ignore index))
+  (setf *people* (delete object *people*)))
+
+;;;; we use this action, which uses the person-editor presentation, to
+;;;; create new people.
+
+(defaction create-person ((c component) &key (last-name "") (first-name ""))
+  (let ((new-person (present-object (make-instance 'person :last-name last-name
+						   :first-name first-name)
+				    :using person-editor)))
+    (when new-person
+      (push new-person *people*))
+    new-person))
+
+;;;; we use this action whenever we want to edit and existing person
+
+(defaction edit-person ((c component) last-name)
+  (let ((target (find last-name *people* :test #'string= :key #'last-name)))
+    (if target
+	(present-object target :using person-editor)
+        (when (option-dialog ("No person named ~S found." last-name)
+		(cons t (format nil "Create a new person named ~S." last-name))
+		(cons nil "Ok, never mind."))
+	  (create-person c :last-name last-name)))
+    target))
+
+;;;; this action, which simply calls our person-listing presentation,
+;;;; could just as well be inlined into the various places where it's
+;;;; used.
+
+(defaction list-people ((c component))
+  (present-collection person-listing))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+
+(defcomponent person-search (ucw::presentation-search)
+  ()
+  (:default-initargs
+   :search-presentation (make-instance 'person-editor)
+   :list-presentation (make-instance 'person-listing)))
+
+(defaction person-search ((c component))
+  (call 'person-search))
+
+(defaction edit-from-search ((person-search person-search) (person person) index)
+  (declare (ignore index))
+  (present-object person :using person-editor))
+
+(defmethod get-all-instances ((s person-search)) *people*)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; the ucw components and classes for a minimal web app
+
+(defcomponent presentations-example ()
+  ((body :accessor body :component presentations-index)))
+
+(defmethod render ((e presentations-example))
+  (<ucw:form :action (refresh-component (body e))
+    (render (body e))
+    (<ucw:input :type "submit" :value "Ok." :action (ok (body e)))))
+
+(defcomponent presentations-index ()
+  ())
+
+(defmethod render ((e presentations-index))
+  (<:p "Welcome to the octane demo application.")
+  (<:ul
+   (<:li (<ucw:a :action (list-people e) "List") " all the people.")
+   (<:li (<ucw:a :action (create-person e) "Create") " a new person.")
+   (let ((last-name ""))
+     (<:li "Edit the person with last name "
+	   (<ucw:form :style "display: inline" :action (edit-person e last-name)
+	     (<ucw:input :type "text" :accessor last-name)
+	     (<:input :type "submit" :value "Ok."))))
+   (<:li (<ucw:a :action (person-search e) "Search") " for a particular person.")))
+
+(defaction ok ((index presentations-index) &optional value)
+  (declare (ignore value))
+  t)
addfile ./src/aux-slots-mixin.lisp
hunk ./src/aux-slots-mixin.lisp 1
+(in-package :ucw)
+
+(defclass aux-slots-mixin ()
+   ((%aux-slots
+     :initform (make-hash-table :test #'eq))
+    (%aux-slots-order :reader aux-slots
+                      :initform nil)))
+
+(defmethod slot-missing
+            ((class t)
+             (obj aux-slots-mixin)
+             slot-name operation &optional new-value)
+  (with-slots (%aux-slots %aux-slots-order)
+      obj
+   (ecase operation
+     (slot-value
+      (multiple-value-bind (value present-p)
+                          (gethash slot-name %aux-slots)
+        (if present-p value
+            (slot-unbound class obj slot-name))))
+
+     (setf
+      (unless (nth-value 1 (gethash slot-name %aux-slots))
+        (setf %aux-slots-order (nconc %aux-slots-order (list slot-name))))
+      (setf (gethash slot-name %aux-slots) new-value))
+
+     (slot-boundp
+      (nth-value 1 (gethash slot-name %aux-slots)))
+
+     (slot-makunbound
+      (setf %aux-slots-order (delete slot-name %aux-slots-order))
+      (remhash slot-name %aux-slots)))))
addfile ./src/form.lisp
hunk ./src/form.lisp 1
-
+;;;; -*- lisp -*-
+
+(in-package :ucw)
+
+;; we need this pair to delay execution of functions which contain yacml macros
+;; before the right place
+
+(defun force (value)
+  "Pseudo lazy-evaluation FORCE. Complementary to DELAY."
+  (if (consp value)
+      (case (car value)
+        (:%delayed% (let ((vs (multiple-value-list (funcall (cdr value)))))
+                      (setf (car value) :%force-done%
+                            (cdr value) vs)
+                      (apply #'values vs)))
+        (:%force-done% (values-list (cdr value)))
+        (otherwise value))
+      value))
+
+(defmacro delay (&rest forms)
+  "Pseudo lazy-evaluation DELAY. Complementary to FORCE."
+  `(cons :%delayed% #'(lambda () (progn ,@forms))))
+
+(defmacro with-simple-restore (places &body forms)
+  "Preserve values of setfable PLACES before execution of the FORMS
+and restore them after. Returns the result of the FORMS."
+  (let ((keepers (mapcar #'(lambda (p) (declare (ignore p)) (gensym))
+                         places)))
+    `(let ,keepers
+       (setf (values ,@keepers) (values ,@places))
+       (prog1
+           (progn ,@forms)
+         (setf (values ,@places) (values ,@keepers))))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defclass interface-element-class (standard-component-class
+                                     indirect-value-mixin-class)
+    ()
+    (:documentation "Metaclass for interface elements.")))
+
+(define-ie-type (t t-element) (widget-component)
+  ((view :accessor view
+         :initarg :view
+         :initform (make-instance 'ieview)
+         :documentation "Element presentation control.")
+   (label :accessor label 
+          :initarg :label 
+          :initform nil)
+   (label-plural :accessor label-plural 
+                 :initarg :label-plural 
+                 :initform nil)
+   (editablep :accessor editablep
+              :initarg :editablep
+              :initform t
+              :documentation
+              "T - render element with ACCEPT method
+NIL - render element with PRESENT method")
+   (enabledp :accessor enabledp
+             :initarg :enabledp
+             :initform t
+             :documentation
+             "Has element be shown to a client.
+T - present element,
+NIL - don't present element."))
+  (:metaclass standard-component-class)
+  (:documentation "Just a basic interface element"))
+
+(defmethod render ((e t-element))
+  (when (enabledp e)
+    (render-element (view e) e)))
+
+(defmethod render-box ((view ieview) (e t-element) value)
+  (declare (ignore view e))
+  (force value))
+
+(defmethod render-value-box ((view ieview) (e t-element) value)
+  (declare (ignore view e))
+  (force value))
+
+(defgeneric render-element (view element)
+  (:method-combination wrapping-standard))
+
+(defmethod render-element :wrapping ((view ieview) (e t-element))
+  (render-box view e (delay (call-next-method))))
+
+(defmethod render-element ((view ieview) (e t-element))
+  (when (labelp view)
+    (render-label view e))
+  (render-value-box view e (delay (funcall (if (editablep e) #'accept #'present)
+                                           view
+                                           e))))
+
+(defmethod render-label ((view ieview) (e t-element))
+  (awhen (ecase (labelp view)
+           (:plural (or (label-plural e) ""))
+           ((:singular t) (or (label e) ""))
+           ((nil) nil))
+    (<:as-html (if (functionp it) (funcall it e) it))))
+
+(defgeneric slot-elements (element &key ie-type test)
+  (:documentation "Returns all the slots names of ELEMENT
+which are interface elements  and optionally satisfied the TEST.
+TEST -- function of one argument (slot value).")
+  (:method-combination nconc))
+
+(defmethod slot-elements nconc ((e t-element) &key (ie-type 't) (test (constantly t)))
+  (iterate
+    (with interface-element-class = (ie-type-class ie-type))
+    (for slot in (mopp:class-slots (class-of e)))
+    (for slot-name = (mopp:slot-definition-name slot))
+    (for element = (and (slot-boundp e slot-name)
+                        (slot-value e slot-name)))
+    (when (and element
+               (not (eq element (parent e)))
+               (not (and (slot-boundp e 'calling-component)
+                         (eq element (slot-value e 'calling-component))))
+               (subtypep (class-of element) interface-element-class)
+               (funcall test element))
+      (collect slot-name))))
+
+(defgeneric clone-element (obj &rest initargs)
+  (:documentation "Clone interface element."))
+
+(defmethod clone-element ((obj t-element) &rest initargs)
+  (let ((class (class-of obj))
+        copy-initargs)
+    (setf copy-initargs
+          (iterate
+            (with ses = (slot-elements obj))
+            (for slot in (mopp:class-slots class))
+            (for slot-name = (mopp:slot-definition-name slot))
+            (for slot-initarg = (car (mopp:slot-definition-initargs slot)))
+
+            (when (and slot-initarg     ; skip slots without initarg
+                       (slot-indirect-boundp obj slot-name))
+              (let ((sv (slot-indirect-value obj slot-name)))
+                (appending
+                 (list slot-initarg
+                       (cond ((member slot-name ses) (clone-element sv))
+                             ((indirect-value-p sv) (copy-indirect-value sv))
+                             (t sv)     ; haven't other ideas
+                             )))))))
+    (apply #'make-instance class (append initargs copy-initargs))))
+
+(define-ie-type (interface-element interface-element) ((ie-type t))
+  ((client-value :accessor client-value :initform ""
+		 :initarg :client-value
+                 :documentation "Whetever the client's browse sent for this interface element."
+                 :backtrack t)
+   (direct-value :accessor direct-value :initform nil
+                 :initarg :direct-value
+                 :documentation "The current lisp object in this interface element."
+                 :backtrack t)
+   (default-value :accessor default-value
+     :initarg :default-value
+     :initform nil
+     :documentation
+     "Default LISP-VALUE.
+If it is a function it is called with ELEMENT as argument.")
+   (input-filter :accessor input-filter
+                 :initarg :input-filter
+                 :initform (lambda (value &optional element)
+                             (declare (ignore element))
+                             value)
+                 :documentation
+                 "Function/symbol of two arguments.
+ (input-filter client-value interface-element) => LISP-VALUE.
+
+Function can signal an uninterrupted error with
+SIGNAL-IE-BAD-INPUT CLIENT-VALUE REQUIRED-TYPE &optional CONDITION-TYPE
+CONDITION-TYPE -- :format | :type | nil.")
+   (output-format :accessor output-format
+                  :initarg :output-format
+                  :initform #'(lambda (v &optional e) (declare (ignore e)) v)
+                  :documentation
+                  "Function/symbol of two arguments.
+OUTPUT-FORMAT LISP-VALUE INTERFACE-ELEMENT => CLIENT-VALUE.")
+   (constraints :accessor constraints
+                :initarg :constraints
+                :initform nil
+                :documentation
+                "List of constraints => CONSTRAINT*.
+CONSTRAINT -- CONSTRAINT-FUNCTION | CONSTRAINT-KEYWORD.
+CONSTRAINT-FUNCTION -- function LISP-VALUE INTERFACE-ELEMENT => T | NIL
+CONSTRAINT-KEYWORD -- key for predefined constraint
+CONSTRAINT-FUNCTION can signal an uninterrupted error with
+SIGNAL-IE-CONSTRAINT-VIOLATION FORMAT-CONTROL &rest FORMAT-ARGS.")
+   (initial-focus :accessor initial-focus
+                  :initarg :initial-focus
+                  :initform nil)
+   (element-id :accessor element-id
+               :initarg :element-id
+               :initform (random-string 32)))
+  (:metaclass interface-element-class)
+  (:documentation "A single value in a form.
+
+A interface-element is, simply put, a wrapper for a value in an html
+form."))
+
+(defgeneric coerce-client-value (element value)
+  (:method ((e interface-element) (value string))
+    (if (= (length value) 0)
+        nil
+        value))
+  (:documentation "Coerce CLIENT-VALUE to LISP-VALUE type."))
+
+(defgeneric validate-value (element value &key &allow-other-keys)
+  (:method ((e interface-element) value &key &allow-other-keys)
+    (every #'(lambda (c)
+               (etypecase c
+                 (function (funcall c value e))
+                 (keyword  (funcall (ie-constraint c) value e))))
+           (constraints e)))
+  (:documentation "Validate value with ELEMENT constraints. 
+VALIDATE-VALUE ELEMENT VALUE => VALID
+VALID        -- boolean."))
+
+(defmethod present ((view ieview) (e interface-element))
+  "Render interface element fore viewing."
+  (declare (ignore view))
+  (when (lisp-value e)
+    (<:as-html (format-lisp-value e (lisp-value e)))))
+
+(defmethod accept ((view ieview) (e interface-element))
+  "Render interface element fore editing."
+  (declare (ignore view))
+  (<ucw:input :type "text" :accessor (slot-value e 'client-value)))
+
+(defmethod filter-client-value ((e interface-element) value)
+  (when value
+    (funcall (input-filter e) value e)))
+
+(defmethod output-format ((e interface-element))
+  (with-slots ((fmt-ctrl output-format))
+      e
+    (if (stringp fmt-ctrl)
+        #'(lambda (v e)
+            (declare (ignore e))
+            (format nil fmt-ctrl v))
+        fmt-ctrl)))
+
+(defmethod format-lisp-value ((e interface-element) value)
+  (when value
+    (funcall (output-format e) value e)))
+
+(defmethod default-value ((e interface-element))
+  (with-slots (default-value)
+      e
+    (if (functionp default-value)
+        (funcall default-value e)
+        default-value)))
+
+(defmethod read-client-value :around ((e interface-element))
+  (if (editablep e)
+      (call-next-method)
+      (lisp-value e)))
+
+(defmethod read-client-value ((e interface-element))
+  (if (client-value e)
+    (reduce #'(lambda (val fun) (funcall fun e val))
+            (list #'filter-client-value #'coerce-client-value)
+            :initial-value (client-value e))))
+
+(defmethod (setf client-value) :around (new (e interface-element))
+  (call-next-method (format-lisp-value e (or new (default-value e))) e))
+
+(defmethod (setf lisp-value) (new (e interface-element))
+  ;; force using indirect-value
+  (setf (slot-value e 'direct-value) new))
+
+(defmethod (setf lisp-value) :after (new (e interface-element))
+  (declare (ignore new))
+  (setf (client-value e) (lisp-value e)))
+
+(defmethod lisp-value ((e interface-element))
+  ;; force using indirect-value
+  (slot-value e 'direct-value))
+
+(defmethod shared-initialize :after ((e interface-element) slot-names
+                                     &rest initargs)
+  (declare (ignore slot-names initargs))
+  (setf (client-value e) (default-value e)))
+
+(defmethod render :after ((e interface-element))
+  (when (initial-focus e)
+    (<ucw:script
+     `(.focus (document.get-element-by-id ,(element-id e))))))
+
+
+(defclass composite-view (ieview)
+  ((rownum :accessor rownum
+           :initarg :rownum
+           :initform 0
+           :documentation
+           "Counter of rendered composite rows."))
+  (:documentation "Composite presentation."))
+
+(define-ie-type (composite composite-element) ((ie-type t))
+  ((slot-view :accessor slot-view
+              :initarg :slot-view
+              :initform (make-instance 'composite-view)
+              :documentation
+              "View for slots rendering.")
+   (invalid-slots :accessor invalid-slots
+                  :initarg :invalid-slots
+                  :initform nil
+                  :documentation
+                  "List of invalid slots."))
+  (:metaclass standard-component-class))
+
+(defun symbol-to-label (symbol &optional pluralp)
+  (let ((label (string-capitalize
+                (substitute #\space #\-
+                            (symbol-name symbol)))))
+    (if pluralp
+        (format nil "~a~p" label 2)
+        label)))
+
+(defmethod shared-initialize :after ((c composite-element) slot-names &key lisp-value &allow-other-keys)
+  (declare (ignore slot-names initargs))
+  (iterate
+    (for sn in (slot-elements c))
+    (for se = (slot-value c sn))
+    (unless (label se)
+      (setf (label se) (symbol-to-label sn)))
+    (unless (label-plural se)
+      (setf (label-plural se) (symbol-to-label sn t)))
+    (setf (view se) (slot-view c)))
+  (when lisp-value (setf (lisp-value c) lisp-value)))
+
+(defmethod render :before ((c composite-element))
+  (dolist (sn (slot-elements c))
+    (setf (widget-component.css-class (slot-value c sn))
+          (and (editablep c)
+               (when (member sn (invalid-slots c) :key #'car)
+                 "ucw-invalid-slot")))))
+
+(defmethod render-value-box ((view ieview) (c composite-element) value)
+  (declare (ignore view c value))
+  (<:div :class "ucw-composite"
+     (<:table :cellspacing 0 :cellpadding 0 :width "100%"
+              (call-next-method))))
+
+(defmethod render-row ((view composite-view) (value t) &key row-class)
+  (<:tr :class (or row-class
+                   (if (= 0 (mod (rownum view) 2)) "even-row" "odd-row"))
+        (force value)))
+
+(defmethod render-slot-value-box ((view composite-view) (c composite-element) slot)
+  (declare (ignore view c))
+  (<:td :class "ucw-composite-slot-value" (render slot)))
+
+(defmethod render-slot ((view composite-view) (c composite-element) (slot-name symbol))
+  (when slot-name
+    (let ((slot (slot-value c slot-name)) )
+      (render-slot view c slot))))
+
+(defmethod render-slot ((view composite-view) (c composite-element) (slot t-element))
+  (let ((slot-view (slot-view c)))
+    (with-simple-restore ((editablep slot) (view slot) (labelp slot-view))
+      (setf (view slot) slot-view)
+      (unless (editablep c)
+        (setf (editablep slot) nil))
+      (when (labelp slot-view)
+        (<:td :class "ucw-composite-slot-label"
+              (render-label slot-view slot))
+        (setf (labelp slot-view) nil))
+      (render-slot-value-box view c slot))))
+
+(defmethod render-slot ((view composite-view)(c composite-element) (slot-list sequence))
+  (<:td
+   (<:table
+    (mapc #'(lambda (x)
+              (<:tr
+               (render-slot view c x)))
+          slot-list))))
+
+(defmethod render-slot ((view composite-view) (c composite-element) slot-name)
+  (let ((slot (slot-value c slot-name))
+        (slot-view (slot-view c)))
+    (with-simple-restore ((editablep slot) (view slot) (labelp slot-view))
+      (setf (view slot) slot-view)
+      (unless (editablep c)
+        (setf (editablep slot) nil))
+      (when (labelp slot-view)
+        (<:td :class "ucw-composite-slot-label"
+              (render-label slot-view slot))
+        (setf (labelp slot-view) nil))
+      (render-slot-value-box view c slot))))
+
+(defmethod render-slots ((view t) (c composite-element) slot-names)
+  (setf (rownum (slot-view c)) 0)
+  (mapc #'(lambda (slot-name)
+            (incf (rownum (slot-view c)))
+            (render-row (slot-view c)
+                        (delay (render-slot (slot-view c) c slot-name))))
+        slot-names))
+
+(defmethod accept ((view t) (c composite-element))
+  "Render interface element fore editing."
+  (render-slots view c (slot-elements c :test #'enabledp)))
+
+(defmethod present ((view t) (c composite-element))
+  "Render interface element fore viewing."
+  (render-slots view c (slot-elements c :test #'enabledp)))
+
+(defmethod validp ((c composite-element))
+  (not (invalid-slots c)))
+
+(defmethod report-error ((c composite-element) slot-name condition)
+  (declare (ignore c))
+  (ucw.component.info "~a - ~a~%" slot-name condition))
+
+(defmethod collect-error ((c composite-element) slot-name condition)
+  (report-error c slot-name condition)
+  (push (cons slot-name condition) (invalid-slots c)))
+
+(defmacro with-collect-error ((composite) &body body)
+  (with-unique-names (error-collector collect-error)
+    `(labels ((,error-collector (slot-name condition)
+                (funcall #'collect-error ,composite slot-name condition))
+              (,collect-error (condition)
+                (let ((restart (find-restart 'collect-error)))
+                  (when restart (invoke-restart restart
+                                                #',error-collector
+                                                condition)))))
+       (handler-bind ((ie-condition #',collect-error))
+         ,@body))))
+
+(defmethod client-value :before ((c composite-element))
+  (setf (invalid-slots c) nil))
+
+(defmethod client-value ((c composite-element))
+  (prog1
+      (with-collect-error (c)
+        (mapcar
+         #'(lambda (slot-name)
+             (cons slot-name
+                   (restart-case (read-client-value 
+                                  (slot-value c slot-name))
+                     (collect-error (handler condition)
+                       (funcall handler slot-name condition)
+                       nil))))
+         (slot-elements c)))
+    (unless (validp c)                  ; propogate error
+      (signal-ie-bad-input (invalid-slots c) 'input))))
+
+(defmethod lisp-value ((c composite-element))
+  (mapcar #'(lambda (slot-name)
+              (cons slot-name (lisp-value (slot-value c slot-name))))
+          (slot-elements c)))
+
+(defmethod (setf lisp-value) (slot-alist (c composite-element))
+  (mapc #'(lambda (slot-acons)
+            (setf (lisp-value (slot-value c (car slot-acons)))
+                  (cdr slot-acons)))
+        slot-alist))
+
+(defmethod (setf lisp-value) :after (slot-alist (c composite-element))
+  (declare (ignore slot-alist))
+  (setf (invalid-slots c) nil))
+
+(defmethod validate-value :before ((c composite-element) value &key (clearp t))
+  (declare (ignore value))
+  (when clearp
+    (setf (invalid-slots c) nil)))
+
+(defmethod validate-value ((c composite-element) slot-alist &key (clearp t))
+  (prog1
+      (with-collect-error (c)
+        (notany
+         #'null (mapcar
+                 #'(lambda (slot-acons)
+                     (destructuring-bind (slot-name . value)
+                         slot-acons
+                       (restart-case 
+                           (validate-value (slot-value c slot-name)
+                                           value
+                                           :clearp clearp)
+                         (collect-error (handler condition)
+                           (funcall handler slot-name condition)
+                           nil))))
+                 slot-alist)))
+    (unless (validp c)                  ; propogate error
+      (signal-ie-bad-input (invalid-slots c) 'input))))
+
+(defmethod read-client-value ((c composite-element))
+  (client-value c))
+
+(defclass auxslots-composite-mixin (aux-slots-mixin)
+  ())
+
+(defmethod slot-elements nconc ((c auxslots-composite-mixin) &key (ie-type 't) (test #'identity))
+  (iterate
+    (with composite-element-class = (ie-type-class ie-type))
+    (for slot-name in (aux-slots c))
+    (for element = (slot-value c slot-name))
+    (when (and element
+               (subtypep (class-of element) composite-element-class)
+               (funcall test element))
+      (collect slot-name))))
+
+(define-ie-type (auxslots-composite auxslots-composite-element) (auxslots-composite-mixin (ie-type composite))
+  ()
+  (:metaclass standard-component-class))
+
+;;; Form Element
+
+(defclass form-view (composite-view)
+  ()
+  (:documentation "Form presentation."))
+
+(define-ie-type (form form-element) ((ie-type composite))
+  ()
+  (:metaclass standard-component-class))
+
+(defmethod render-box ((view ieview) (f form-element) value)
+  (declare (ignore view f value))
+  (<:div :class "ucw-form-box" (call-next-method)))
+
+(defmethod render-value-box ((view ieview) (f form-element) value)
+  (declare (ignore value))
+  (<:div :class "ucw-form"
+         (<ucw:form :action (submit f) :method "post" (call-next-method))))
+
+(defmethod render-label ((view ieview) (f form-element))
+  (declare (ignore view f))
+  (<:div :class "ucw-form-label" (call-next-method)))
+
+(defmethod read-client-value ((f form-element))
+  (let ((value (client-value f)))
+    (validate-value f
+                    (remove-if #'(lambda (sn) (member sn (invalid-slots f) :key #'car))
+                               value
+                               :key #'car)
+                    :clearp nil)
+    value))
+
+;; remember that actions are just methods
+(defgeneric/cc submit (form))
+
+(defaction submit :before ((f form-element))
+  (let ((value (read-client-value f)))
+    (when (validp f)
+      (setf (lisp-value f) value))))
+
+(defaction submit ((f form-element))
+  t)
+
+(define-ie-type (auxslots-form auxslots-form-element) ((ie-type form) auxslots-composite-mixin)
+  ()
+  (:metaclass standard-component-class))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Various standard form element types
+
+;;;; Generic Text 
+
+(define-ie-type (text text-element) ((ie-type interface-element))
+  ((size :accessor size :initarg :size :initform 0)
+   (minlength :accessor minlength :initarg :minlength :initform 0) 
+   (maxlength :accessor maxlength :initarg :maxlength :initform 32))
+  (:metaclass interface-element-class)
+  (:default-initargs
+    :input-filter #'(lambda (str e) (declare (ignore e)) (trim-string str))))
+
+(define-ie-constraint-method :length-range ((value string) (e (ie-type text))
+                                            &key (min (minlength e))
+                                            (max (maxlength e)))
+  (call-next-method value e :min min :max max))
+
+(defmethod accept ((view ieview) (e text-element))
+  (declare (ignore view))
+  (<ucw:input :id (element-id e)
+              :type "text" :class "ucw-text-element" :accessor (slot-value e 'client-value)
+              :size (size e)
+              :maxlength (maxlength e)))
+
+(defvar *completing-text-element-prefix-counter* 0)
+
+(define-ie-type (completing-text completing-text-element) ((ie-type text))
+  ((completions :accessor completions :initarg :completions :initform nil)
+   (prefix :accessor prefix :initarg :prefix :initform "completing-text-element")
+   (completer.js-path :accessor completer.js-path
+		      :initarg :completer.js-path
+		      :initform "/ucw/js/UCWInputCompleter.js")
+   (completer-class :accessor completer-class
+		    :initarg :completer-class
+		    :initform "UCWInputCompleter"))
+  (:metaclass interface-element-class)
+  (:documentation "A text input element with javascript based completion.
+
+This component requires, over and above the component object
+itself, the UCWInputCompleter.js java script file and a
+stylesheet.
+
+The stylesheet, though not not strictly required, is STONGLY
+suggested. The following styles are used:
+
+div#<PREFIX>-results - Used for the div which wraps all the
+available completions.
+
+div#<PREFIX>-results ul - Used for the UL which wraps the list of
+completions.
+
+div#<PREFIX>-results ul li - Every completions is placed in the body
+of an LI tag, use this style to change the formatting of the
+single completions.
+
+li#<PREFIX>-highlight - Use this style to change the formatting
+of a selected completions.
+
+In the above css selectors <PREFIX> is the value of component's
+prefix slot.
+
+Customizing the UCWInputCompleter object (setting auto
+completion, minimum number of chars, etc.) is, unfortunetly, done
+by creating a new javascript class (in a new javascript file) and
+using that instead of UCWInputCompleter.js. In the near future
+this situation will improve."))
+
+(defmethod accept ((view ieview) (e completing-text-element))
+  (declare (ignore view))
+  (<ucw:input :id (element-id e)
+              :type "text" :accessor (slot-value e 'client-value)
+	      :size (size e) :id (concatenate 'string (prefix e) "-input"))
+  (<:div :id (concatenate 'string (prefix e) "-results"))
+  (<:script :type "text/javascript" :src (completer.js-path e)
+	    ;; for some weird reason firefox doesn't like empty script
+	    ;; tags. this empty string is neccessary to force yaclml
+	    ;; to produce a <script ..></script> as opposed to <script
+	    ;; .../>
+	    "")
+  (<ucw:script
+   `(let ((cloader
+           (lambda ()
+             (let ((completer (js:new (,(make-symbol (strcat ":" (completer-class e))) ,(prefix e)))))
+               (setf completer.table (js:array ,@(completions e)))
+               (completer.load)))))
+      (cloader))))
+
+;;;; text areas
+
+(define-ie-type (text-area text-area-element) ((ie-type text))
+  ((rows :accessor rows :initform nil :initarg :rows)
+   (cols :accessor cols :initform nil :initarg :cols))
+  (:metaclass interface-element-class))
+
+(defmethod accept ((view ieview) (e text-area-element))
+  (declare (ignore view))
+  (<ucw:textarea :id (element-id e)
+                 :accessor (slot-value e 'client-value) :rows (rows e) :cols (cols e)))
+
+;;;; SELECT/OPTION
+
+(define-ie-type (selector select-element) ((ie-type interface-element))
+  ((options :accessor options :initform '() :initarg :options)
+   (key :accessor key :initform #'identity :initarg :key)
+   (test :accessor test :initform #'eql :initarg :test)
+   (multiple :accessor multiple :initarg :multiple :initform nil))
+  (:metaclass interface-element-class)
+  (:default-initargs :output-format "~a"))
+
+;;;; The lisp-value is a single value if multiple is nil otherwise a list.
+;;;; the lisp-value is related to the options in that (for non-multiple)
+;;;;   (funcall (test select-element) (funcall (key select-element) an-option) lisp-value) =>T
+;;;; The client-value is always either an option or a list of options.
+
+(defmethod coerce-client-value ((e select-element) value)
+  ;;Apply the key to preserve the relationship between the lisp-value and the client-value
+  (if (multiple e)
+      (mapcar (key e) value)
+      (funcall (key e) value)))
+
+(defmethod format-lisp-value ((e select-element) value)
+  ;;get the option or list of options that correspond to the selected value(s)
+  (when value
+    (flet ((find-v (v)
+             (find v (options e) :key (key e) :test (test e))))
+      (if (multiple e)
+          (mapcar #'find-v value)
+          (funcall #'find-v value)))))
+
+(defmethod render-option ((e select-element) (object t))
+  (<:as-html (funcall (output-format e) object e)))
+
+(defmethod accept ((view ieview) (e select-element))
+  (declare (ignore view))
+  (<ucw:select :accessor (slot-value e 'client-value)
+               :multiple (multiple e)
+               :key #'identity ;we have already done the keying, so underneath just use ID
+               :test (test e)
+               ;;the <:ucw:option macro will take care of adding the selected property
+               ;;properly based upon the value of the accessor above.
+     (iterate
+       (for o in (options e))
+       (<ucw:option :value o
+          (render-option e o)))))
+
+(defmethod present ((view ieview) (e select-element))
+  (declare (ignore view))
+  (iterate
+    (with os = (format-lisp-value e (lisp-value e)))
+    (for o in (if (multiple e) os (when os (list os))))
+    (render-option e o)))
+
+;;;; Numbers from text inputs
+
+(define-ie-type (number number-element) ((ie-type interface-element))
+  ((min-value :accessor min-value :initform nil :initarg :min-value)
+   (max-value :accessor max-value :initform nil :initarg :max-value)
+   (size :accessor size :initform 20 :initarg :size))
+  (:metaclass interface-element-class)
+  (:default-initargs
+    :input-filter #'(lambda (v e) (declare (ignore e)) (trim-string v))
+    :output-format "~a"))
+
+(define-ie-constraint-method :number-range (value (e number-element)
+                                                  &key (min (min-value e))
+                                                  (max (max-value e)))
+  (call-next-method value e :min min :max max))
+
+(defmethod coerce-client-value ((number number-element) value)
+  (declare (ignore value))
+  (let ((*read-eval* nil))
+    (when-bind str (call-next-method)
+      (multiple-value-bind (value value-end)
+          (handler-case
+              (read-from-string str)
+            (end-of-file ()
+              (signal-ie-bad-input str 'number :type)))
+        (if (and (numberp value) (>= value-end (length str)))
+            value
+            (signal-ie-bad-input str 'number :type))))))
+
+(defmethod accept ((view ieview) (n number-element))
+  (declare (ignore view))
+  (<ucw:input :id (element-id n)
+              :type "text" :size (size n)
+	      :accessor (slot-value n 'client-value)))
+
+(define-ie-type (decimal decimal-element) ((ie-type number))
+  ((precision :accessor precision :initarg :precision :initform nil
+              :documentation "Number of significant digits."))
+  (:metaclass interface-element-class))
+
+(defmethod coerce-client-value ((decimal decimal-element) value)
+  (declare (ignore value))
+  (when-bind num (call-next-method)
+    (if-bind prec (precision decimal)
+      (let ((div (expt 10 (- prec))))
+        (float (/ (rationalize (floor (+ (rationalize num) (/ div 2)) div))
+                  (expt 10 prec))))
+      (float num))))
+
+(define-ie-type (integer integer-element) ((ie-type number))
+  ()
+  (:metaclass interface-element-class))
+
+(defmethod coerce-client-value ((integer integer-element) value)
+  (declare (ignore value))
+  (when-bind num (call-next-method)
+    (truncate num)))
+
+(define-ie-type (integer-range integer-range-element) ((ie-type integer))
+  ()
+  (:metaclass interface-element-class)
+  (:default-initargs :min-value 1 :max-value 5))
+
+(defmethod shared-initialize :after ((e integer-range-element) slot-names
+                                     &key &allow-other-keys)
+  (declare (ignore slot-names))
+  (with-slots (default-value) e
+    (unless default-value
+      (setf default-value (min-value e)))))
+
+(defmethod accept ((view ieview) (range integer-range-element))
+  (declare (ignore view))
+  (<:select :name (make-new-callback (lambda (v) (setf (slot-value  range 'client-value) v)))
+    (iterate
+      (for value from (min-value range) to (max-value range))
+      (<:option :value value
+                :selected (eq value (read-client-value range))
+                (<:as-html (format-lisp-value range value))))))
+
+;;;; Password field
+
+(define-ie-type (password password-element) ((ie-type interface-element))
+  ((size :accessor size :initarg :size :initform 0)
+   (minlength :accessor minlength :initarg :minlength :initform 0) 
+   (maxlength :accessor maxlength :initarg :maxlength :initform 20))
+  (:metaclass ucw::interface-element-class)
+  (:default-initargs
+    :input-filter #'(lambda (str e) (declare (ignore e)) (trim-string str))))
+
+(defmethod accept ((view ieview) (e password-element))
+  (declare (ignore view))
+  (<ucw:input :id (element-id e)
+              :type "password" :class "ucw-password-element" :accessor (slot-value e 'client-value)
+              :size (size e)
+              :maxlength (maxlength e)))
+
+;;;; Boolean checkbox
+
+(define-ie-type (checkbox checkbox-element) ((ie-type interface-element))
+  ()
+  (:metaclass interface-element-class)
+  (:default-initargs
+    :input-filter #'(lambda (str e) (declare (ignore e)) (if (stringp str)
+                                                             (trim-string str)))))
+
+(defmethod accept ((view ieview) (e checkbox-element))
+  (<ucw:input :id (element-id e)
+              :type "checkbox" :class "ucw-checkbox-element" :accessor (slot-value e 'client-value)))
+
+(defmethod coerce-client-value ((checkbox checkbox-element) value)
+  (if value
+      t
+      nil))
+
+;;;; Sets
+(defclass set-view (form-view)
+  ()
+  (:documentation "Sets presentation."))
+
+(define-ie-type (set set-element) ((ie-type t))
+  ((item-viewer :accessor item-viewer
+                :initarg :item-viewer
+                :initform nil
+                :documentation
+                "Interface element for viewing single item.")
+   (current-item :accessor current-item
+                 :initarg :current-item
+                 :initform nil
+                 :documentation
+                 "Currently viewed item.")
+   (items :accessor items
+          :initarg :items
+          :initform nil
+          :documentation
+          "List of items."))
+  (:metaclass interface-element-class)
+  (:default-initargs
+    :view (make-instance 'set-view)
+    :editablep nil))
+
+(defmethod render-box ((view ieview) (set set-element) value)
+  (render-box view (item-viewer set) value))
+
+(defmethod render-value-box ((view ieview) (set set-element) value)
+  (render-value-box view (item-viewer set) value))
+
+(defmethod render-element ((view ieview) (set set-element))
+  (with-slots (item-viewer editablep view)
+      set
+    (with-simple-restore ((editablep item-viewer) (view item-viewer))
+      (setf (editablep item-viewer) editablep
+            (view item-viewer) view)
+      (call-next-method))))
+
+(defmethod render-label ((view ieview) (set set-element))
+  (render-label view (item-viewer set)))
+
+(defmethod render-slot-labels ((view set-view) (set set-element) slots)
+  (dolist (slot slots)
+    (<:th (render-label view (slot-value (item-viewer set) slot)))))
+
+(defmethod render-slot ((view set-view) (set set-element) slot-name)
+  (let ((slot (slot-value (item-viewer set) slot-name)))
+    (with-simple-restore ((editablep slot))
+      (setf (editablep slot) nil)
+      (<:td :class "ucw-composite-slot-value"
+            (render slot)))))
+
+(defmethod render-item ((view set-view) (set set-element) item slot-names)
+  (setf (lisp-value (item-viewer set)) item)
+  (iterate
+    (for slot-name in slot-names)
+    (render-slot view set slot-name)))
+
+(defmethod render-items ((view set-view) (set set-element) slot-names)
+  (with-slots ((iv item-viewer)) set
+    (render-row view
+                (delay (render-slot-labels view set slot-names))
+                :row-class "label-row")
+    (setf (rownum view) 0)
+    (with-slots (slot-view) iv
+      (with-simple-restore ((labelp slot-view))
+        (setf (labelp slot-view) nil)
+        (mapc #'(lambda (item)
+                  (setf (lisp-value iv) item)
+                  (incf (rownum view))
+                  (render-row view
+                              (delay (render-item view set item slot-names))))
+              (items set))))))
+
+(defmethod accept ((view t) (set set-element))
+  (error "sorry, not yet implemented."))
+
+(defmethod present ((view t) (set set-element))
+  (render-items view set (slot-elements (item-viewer set) :test #'enabledp))
+
+  ;; prevent last item from been damaged by backtracking
+  ;; we only want to do this if the slot is using indirect-value
+  (mapc #'(lambda (slot-name)
+            (let ((slot (slot-value (item-viewer set) slot-name)))
+              (when (slot-indirect-p slot 'direct-value)
+                (slot-makunbound slot 'direct-value))))
+        (slot-elements (item-viewer set) :ie-type 'interface-element :test #'enabledp)))
addfile ./src/ie.lisp
hunk ./src/ie.lisp 1
+(in-package :ucw)
+
+(defvar *interface-element-type-table* (make-hash-table :test #'eql)
+  "Interface element types stored by type name (symbol).")
+
+(defclass interface-element-type ()
+  ((name :accessor type-name
+         :initarg :name
+         :initform nil
+         :documentation
+         "User visible interface element type name.")
+   (supertypes :accessor supertypes
+               :initarg :supertypes
+               :initform nil
+               :documentation
+               "Superior interface element types.")
+   (class :accessor type-class
+          :initarg :class
+          :initform nil
+          :documentation
+          "Interface element real class.")
+   (attributes :accessor attributes
+               :initarg :attributes
+               :initform nil
+               :documentation
+               "Interface element type attributes.")))
+
+(defparameter +ie-type-class-name-prefix+
+  "%")
+(defparameter +ie-type-class-name-suffix+
+  "-INTERFACE-ELEMENT-TYPE")
+
+(defun %ie-type-class-name (name &optional (package :ucw))
+  (intern (strcat +ie-type-class-name-prefix+
+                  (symbol-name name) 
+                  +ie-type-class-name-suffix+)
+          package))
+
+(defun %register-ie-type (name supertypes type-class attributes)
+  (setf (gethash name *interface-element-type-table*)
+        (make-instance 'interface-element-type
+                       :name name
+                       :supertypes supertypes
+                       :class type-class
+                       :attributes attributes)))
+
+(defmethod ie-type ((type symbol) &optional (errorp t))
+  "Get interface element type."
+  (aif (gethash type *interface-element-type-table*)
+       it
+       (when errorp
+         (error "Couldn't find interface element type ~s" type))))
+
+(defun ie-type-class (type)
+  "Return real class corresponding to interface element TYPE."
+  (type-class (ie-type type)))
+
+(defun ie-type-of (obj &optional (errorp t))
+  "Return TYPE-NAME, INTERFACE-ELEMENT-TYPE for OBJ or signal an error."
+  (let ((cpl (mapcar #'class-name (mopp:class-precedence-list (class-of obj)))))
+    (mapc #'(lambda (type-name)
+              (when-bind pt (ie-type type-name nil)
+                (return-from ie-type-of (values type-name pt))))
+          cpl)
+    (when errorp
+      ;; provoke an error
+      (ie-type (car cpl)))))
+
+(defun make-ie (type &rest args)
+  "Make instance of interface element."
+  (apply #'make-instance (ie-type-class type) args))
+
+(defmethod ie-type-precedence-list ((type symbol) &optional (errorp t))
+  (ie-type-precedence-list (ie-type type) errorp))
+
+(defmethod ie-type-precedence-list ((type interface-element-type) &optional (errorp t))
+  (declare (ignore errorp))
+  (labels ((all-supers (et &optional acc)
+             (if (not (member et acc))
+                 (reduce #'all-supers
+                         (mapcar #'ie-type (supertypes et))
+                         :from-end t
+                         :initial-value (cons et acc))
+                 acc)))
+    (let ((supers (all-supers type)))
+      (reduce #'(lambda (acc class)
+                  (aif (member-if #'(lambda (et) (eq (type-class et) class))
+                                  supers)
+                       (nconc acc (list (type-name (car it))))
+                       acc))
+              (mopp:class-precedence-list (type-class type))
+              :initial-value '()))))
+
+(defmethod ie-type-attributes ((type symbol) &optional (errorp t))
+  (ie-type-attributes (ie-type type) errorp))
+ 
+(defmethod ie-type-attributes ((type interface-element-type) &optional (errorp t))
+  (declare (ignore errorp))
+  (remove-duplicates
+   (apply #'append
+          (mapcar #'(lambda (tn) (attributes (ie-type tn)))
+                  (ie-type-precedence-list type)))
+   :from-end t
+   :key #'car))
+
+(defun %ie-type-decl-p (decl)
+  (and (consp decl) (eq 'ie-type (car decl))))
+
+(defun %convert-ie-type-decl (decl)
+  (if (%ie-type-decl-p decl)
+      (class-name (apply #'ie-type-class (cdr decl)))
+      decl))
+
+(defun %convert-ie-var-decl (decl)
+  (if (consp decl)
+      `(,(car decl) ,(%convert-ie-type-decl (cadr decl)))
+      decl))
+
+(defun %filter-ie-types (decls)
+  (reduce #'(lambda (acc decl)
+              (when (%ie-type-decl-p decl)
+                (push (cadr decl) acc))
+              acc)
+          decls
+          :initial-value '()))
+
+(defun %convert-ie-method-description (forms)
+  (let ((qualifiers (do (qs) (nil)
+                      (if (not (listp (car forms)))
+                          (push (pop forms) qs)
+                          (return qs))))
+        (ll (do*
+             ((fs (car forms) (cdr fs))
+              (var-decl (car fs) (car fs))
+              (acc '()))
+             ((or (endp fs) (keywordp (car fs))) (append (nreverse acc) fs))
+              (push (%convert-ie-var-decl var-decl) acc))))
+    `(,@qualifiers ,ll ,@(cdr forms))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun %convert-ie-definition-name (name real-name-fun)
+    (if (consp name)
+        (apply #'values name)
+        (values name (funcall real-name-fun name)))))
+
+(defmacro define-ie-type (name supers slots &rest class-options)
+  "Define interface element type NAME and corresponding class.
+NAME -- TYPE-NAME | (TYPE-NAME CLASS-NAME)."
+  (labels ((expand-attribute (attr &optional (original-attr attr))
+             (cond ((not (consp attr))
+                    (expand-attribute (list attr nil) original-attr))
+                   ((and (<= 1 (length attr) 2)
+                         (eq (type-of (car attr)) 'symbol))
+                    (cons (intern (symbol-name (car attr)) :keyword)
+                          (or (cdr attr) '(nil))))
+                   (t (error "~a is not of type (SYMBOL VALUE) or SYMBOL."
+                             original-attr)))))
+
+    (multiple-value-bind (type-name class-name)
+        (%convert-ie-definition-name name #'%ie-type-class-name)
+      `(eval-when (:compile-toplevel :load-toplevel :execute)
+        (eval
+        `(progn
+           (defclass ,',class-name
+               ,(mapcar #'%convert-ie-type-decl ',supers)
+             ,',slots
+             ,@(remove :attributes ',class-options :key #'car))
+           (%register-ie-type ',',type-name
+                            ',(%filter-ie-types ',supers)
+                            (find-class ',',class-name)
+                            ',',(mapcar #'expand-attribute
+                                        (cdr (assoc :attributes class-options))))))))))
+
+(defmacro define-ie-generic (name ll &rest decls)
+  "Define interface element generic function."
+  `(eval
+    `(defgeneric ,',name ,',ll
+       ,@(mapcar
+          #'(lambda (decl)
+              (if (eq (car decl) :method)
+                  `(,(car decl) ,@(%convert-ie-method-description (cdr decl)))
+                  decl))
+          ',decls))))
+
+(defmacro define-ie-method (name &body forms)
+  "Define interface element method.
+Method parameter declarations in the form of (VAR (IE-TYPE TYPE-NAME)) are
+substituted with (VAR CLASS-NAME).
+TYPE-NAME - a symbol
+CLASS-NAME - name of real class corresponding TYPE-NAME."
+  `(eval
+    `(defmethod ,',name ,@(%convert-ie-method-description ',forms))))
+
+(defmacro define-ie-action (name &body forms)
+  "Define interface element action.
+Action parameter declarations in the form of (VAR (IE-TYPE TYPE-NAME)) are
+substituted with (VAR CLASS-NAME).
+TYPE-NAME - a symbol
+CLASS-NAME - name of real class corresponding TYPE-NAME."
+  `(eval
+    `(defaction ,',name ,@(%convert-ie-method-description ',forms))))
+;;
+;; User input conditions
+;;
+(define-condition ie-condition (simple-condition)
+  ())
+
+(define-condition ie-bad-input (ie-condition)
+  ((value :reader ie-bad-input-value :initarg :value)
+   (type :reader ie-bad-input-type :initarg :type))
+  (:report (lambda (condition stream)
+             (format stream
+                     (simple-condition-format-control condition)
+                     (ie-bad-input-value condition)
+                     (ie-bad-input-type condition))))
+  (:default-initargs :format-control "~a doesn't satisfy condition ~s"))
+
+(define-condition ie-bad-input-format (ie-bad-input)
+  ()
+  (:default-initargs :format-control "~a doesn't satisfy format ~s"))
+
+(define-condition ie-bad-input-type (ie-bad-input)
+  ()
+  (:default-initargs :format-control "~a doesn't satisfy type ~s"))
+
+(defun signal-ie-bad-input (value required-type &optional condition-type)
+  (let ((condition (ecase condition-type
+                     (:format 'ie-bad-input-format)
+                     (:type 'ie-bad-input-type)
+                     ((nil) 'ie-bad-input))))
+    (signal condition :value value :type required-type)))
+;;
+;; Constraint conditions
+;;
+
+(define-condition ie-constraint-violation (ie-condition)
+  ())
+
+(defun signal-ie-constraint-violation (format-control &rest format-args)
+  (signal 'ie-constraint-violation
+                   :format-control format-control
+                   :format-arguments format-args))
+
+(defvar *interface-element-constraint-table* (make-hash-table :test #'eql)
+  "Interface element constraints stored by name (symbol).
+Constraint -- function VALUE ELEMENT => T | NIL.")
+;;
+;; Constraints
+;;
+(defparameter +ie-constraint-name-prefix+
+  "%")
+(defparameter +ie-constraint-name-suffix+
+  "-INTERFACE-ELEMENT-CONSTRAINT")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun %ie-constraint-method-name (name &optional (package :ucw))
+    (intern (strcat +ie-constraint-name-prefix+
+                    (symbol-name name) 
+                    +ie-constraint-name-suffix+)
+            package)))
+
+(defun ie-constraint (key &optional (errorp t))
+  "Get interface element constraint."
+  (aif (gethash key *interface-element-constraint-table*)
+       it
+       (when errorp
+         (error "Couldn't find interface element constraint ~s" key))))
+
+(defmacro define-ie-constraint-generic (name &rest generic-decl)
+  "Create and register generic function for interface element constraint.
+NAME          -- SIMPLE-NAME | (SIMPLE-NAME FUNCTION-NAME)
+SIMPLE-NAME   -- KEYWORD | SYMBOL
+FUNCTION-NAME -- SYMBOL."
+
+  (multiple-value-bind (key fun-name)
+      (%convert-ie-definition-name name #'%ie-constraint-method-name)
+  `(progn
+     (define-ie-generic ,fun-name ,@generic-decl)
+     (setf (gethash ,key *interface-element-constraint-table*) ',fun-name))))
+
+(defmacro define-ie-constraint-method (name &rest method-decl)
+"Define constraint method by constraint NAME.
+Constraint must be defined before with DEFINE-IE-CONSTRAINT-GENERIC."
+  `(define-ie-method ,(ie-constraint name) ,@method-decl))
+
+(define-ie-constraint-generic (:not-null validate-not-null) (value element &key &allow-other-keys)
+  (:method (value element &key &allow-other-keys)
+    (declare (ignore element))
+    (cond ((not value)
+           (signal-ie-constraint-violation "value required")
+           nil)
+          (t t)))
+  (:documentation "Check that VALUE is not NULL."))
+
+(define-ie-constraint-generic (:number-range validate-number-range) (value element &key min max)
+  (:method ((value null) element &key min max)
+    (declare (ignore element min max))
+    t)
+  (:method (value element &key min max)
+    (declare (ignore element))
+    (cond ((not value) t)
+          ((<= (or min value) value (or max value)) t)
+          (t (let ((format-ctrl
+                  (cond
+                    ((and min max) "value ~a is out of range ~a-~a")
+                    (min "value ~a is less than ~a~*")
+                    (max "value ~a  is greater than ~*~a"))))
+               (signal-ie-constraint-violation format-ctrl value min max))
+             nil)))
+  (:documentation "Check that VALUE is in the range MIN - MAX."))
+
+(define-ie-constraint-generic (:length-range validate-length-range) (value element &key min max)
+  (:method ((value null) element &key min max)
+    (declare (ignore element min max))
+    t)
+  (:method (value element &key min max)
+    (declare (ignore element))
+    (let ((vlength (length value)))
+      (cond  ((not value) t)
+             ((<= (or min vlength) vlength (or max vlength)) t)
+             (t (let ((format-ctrl 
+                       (cond
+                         ((and min max) "length of value ~a is out of range ~a-~a")
+                         (min "length of value ~a is less than ~a~*")
+                         (max "length of value ~a  is greater than ~*~a"))))
+                  (signal-ie-constraint-violation format-ctrl value min max))
+                nil))))
+  (:documentation "Check that VALUE length is in the range MIN - MAX."))
+
+;;
+;; Presentation
+;;
+(defclass ieview ()
+  ((labelp :accessor labelp
+           :initarg :labelp
+           :initform t
+           :documentation
+           "How to present a label. 
+T | :SYNGULAR - show label
+:PLURAL - show plural label
+NIL - don't show label."))
+  (:documentation "Describe an appearence of interface element to a client."))
+
+(define-ie-generic present (element view)
+  (:method-combination wrapping-standard)
+  (:documentation "Render interface element fore viewing."))
+
+(define-ie-generic accept (element view)
+  (:method-combination wrapping-standard)
+  (:documentation "Render interface element fore editing."))
+
+;;
+;; Search
+;;
+
+(define-ie-generic applicable-criteria (interface-element)
+  (:method-combination nconc)
+  (:documentation "Search criteria applicable to INTERFACE-ELEMENT."))
+
addfile ./src/indirect-value-class.lisp
hunk ./src/indirect-value-class.lisp 1
+(in-package :ucw)
+
+(defstruct (indirect-value :named
+                           (:constructor make-indirect-value)
+                           (:conc-name indirect-))
+  object
+  reader
+  writer)
+
+(defmacro indirect-value (object accessor/reader/slot-name &optional writer)
+  "Create instance of indirect-value structure.
+OBJECT -- value for object slot of structure.
+
+If WRITER defined then second and third arguments are treated as
+READER/WRITER and must evaluate to funcallable objects.
+
+Otherwise if second argument is a symbol it is treated as accessor name.
+If it is not a symbol it must evaluate to slot name of OBJECT.
+\(INDIRECT-VALUE object #'reader #'writer)
+\(INDIRECT-VALUE object slot-accessor)
+\(INDIRECT-VALUE object 'slot-name)."
+  (with-unique-names (r w sn)
+  `(let ((,r)
+         (,w)
+         (,sn))
+     (setf
+      ,@(if writer
+            `(,r ,accessor/reader/slot-name
+                 ,w ,writer)
+            (typecase  accessor/reader/slot-name
+              (symbol `(,r #',accessor/reader/slot-name
+                           ,w #'(lambda (o v)
+                                  (setf (,accessor/reader/slot-name o) v))))
+             (t `(,sn ,accessor/reader/slot-name
+                      ,r #'(lambda (o) (slot-value o ,sn))
+                      ,w #'(lambda (o v) (setf (slot-value o ,sn) v)))))))
+     (make-indirect-value
+      :object ,object
+      :reader ,r
+      :writer ,w))))
+                           
+(defclass indirect-value-mixin-class (standard-class)
+  ()
+  (:documentation "Metaclass for INDIRECT-VALUE-CLASS-MIXIN."))
+
+(defmethod mopp:validate-superclass ((class indirect-value-mixin-class) (superclass mopp:standard-class))
+  t)
+
+(defclass indirect-value-standard-component-class (standard-component-class indirect-value-mixin-class)
+  ())
+
+(defmethod mopp:slot-boundp-using-class ((class indirect-value-mixin-class) obj slotd)
+  (declare (special %indirect-value-access%))
+  (when (call-next-method)
+    (let ((value (mopp:slot-value-using-class (find-class 'standard-class)
+                                              obj
+                                              slotd)))
+      (if (and (indirect-value-p value)
+               (not (and (boundp '%indirect-value-access%)
+                         %indirect-value-access%)))
+          (not (null (indirect-object value)))
+          t))))
+
+(defmethod mopp:slot-makunbound-using-class ((class indirect-value-mixin-class) obj slotd)
+  (when (mopp:slot-boundp-using-class (find-class 'standard-class) obj slotd)
+    (let ((value (mopp:slot-value-using-class (find-class 'standard-class)
+                                              obj
+                                              slotd)))
+      (if (indirect-value-p value)
+          (setf (indirect-object value) nil)
+          (call-next-method)))))
+
+(defmethod mopp:slot-value-using-class ((class indirect-value-mixin-class) obj slotd)
+  (declare (ignore obj))
+  (let ((value (call-next-method)))
+    (if (indirect-value-p value)
+        (with-slots (object reader)
+            value
+          (if reader
+              (funcall reader object)
+              (slot-value object (mopp:slot-definition-name slotd))))
+        value)))
+
+(defmethod (setf mopp:slot-value-using-class) (new (class indirect-value-mixin-class) obj slotd)
+  (let ((value (when (mopp:slot-boundp-using-class (find-class 'standard-class)
+                                                   obj
+                                                   slotd)
+                 (mopp:slot-value-using-class (find-class 'standard-class)
+                                              obj
+                                              slotd))))
+    (if (indirect-value-p value)
+        (with-slots (object writer)
+            value
+          (if writer
+              (funcall writer object new)
+              (setf (slot-value object (mopp:slot-definition-name slotd)) new)))
+        (call-next-method))))
+
+(defgeneric  slot-indirect-value (object slot-name)
+  (:documentation "Get real value of indirect slot not one of indirect object."))
+
+(defgeneric  (setf slot-indirect-value) (new object slot-name)
+  (:documentation "Set real value of indirect slot not one of indirect object."))
+
+(defun find-slot-definition (class slot-name)
+  (dolist (slot (mopp:class-slots class) nil)
+    (when (eql slot-name (mopp:slot-definition-name slot))
+      (return slot))))
+
+(defmethod slot-indirect-value ((obj t) (slot-name symbol))
+  (if-bind slot-def (find-slot-definition (class-of obj) slot-name)
+	 (slot-indirect-value obj slot-def)
+	 (error "When attempting to read the slot's indirect value (slot-indirect-value), the slot ~a is missing from obj ~a" slot-name obj)))
+
+(defmethod slot-indirect-value ((obj t)
+                                (slotd mopp:standard-effective-slot-definition))
+  (let ((%indirect-value-access% t))
+    (declare (special %indirect-value-access%))
+    (mopp:slot-value-using-class (find-class 'standard-class) obj slotd)))
+
+(defmethod (setf slot-indirect-value) (new (obj t) (slot-name symbol))
+  (setf (slot-indirect-value obj (find-slot-definition (class-of obj) slot-name))
+        new))
+
+(defmethod (setf slot-indirect-value) (new
+                                       (obj t)
+                                       (slotd mopp:standard-effective-slot-definition))
+  (let ((%indirect-value-access% t))
+    (declare (special %indirect-value-access%))
+    (setf (mopp:slot-value-using-class (find-class 'standard-class) obj slotd)
+          new)))
+
+(defmethod slot-indirect-boundp ((obj t) slot)
+  (let ((%indirect-value-access% t)) ; we want actual state of the slot
+    (declare (special %indirect-value-access%)) 
+
+    (slot-boundp obj slot)))
+
+(defmethod slot-indirect-makunbound ((obj t) slot)
+  (let ((%indirect-value-access% t)) ; we want actual state of the slot
+    (declare (special %indirect-value-access%)) 
+    
+    (when (slot-boundp obj slot)
+      (setf (slot-indirect-value obj slot) nil) ; delete indirect-value
+      (slot-makunbound obj slot)                ; now ordinary method will work
+      )))
+
+(defmethod slot-indirect-object ((obj t) (slot t))
+  (indirect-object (slot-indirect-value obj slot)))
+
+(defmethod (setf slot-indirect-object) (new (obj t) (slot t))
+  (setf (indirect-object (slot-indirect-value obj slot)) new))
+
+(defmethod slot-indirect-p ((obj t) (slot-name symbol))
+  (indirect-value-p (slot-indirect-value obj slot-name)))
addfile ./src/packages.lisp
hunk ./src/packages.lisp 1
+;; -*- lisp -*-
+
+(defpackage :it.bese.ucw.presentations
+  (:use :common-lisp
+        :ucw
+        :arnesi)
+  (:export
+   #:presentation
+   #:slots
+   #:css-class
+   #:render-options
+   #:present-slot
+   #:present-object
+   #:present-collection
+   #:object-presentation
+   #:instance
+   #:inline-object-presentation
+   #:one-line-presentation
+   #:list-presentation
+   #:get-all-instances
+   #:render-list-heading
+   #:render-list-row
+   #:create-from-listing
+   #:delete-from-listing
+   #:edit-from-listing
+   #:edit-from-search
+   #:edit-from-listing
+   #:slot-presentation
+   #:presentation-slot-value
+   #:currency
+   #:timestamp
+   #:date
+   #:get-foreign-instances
+   #:one-of
+   #:some-of
+   #:add-element
+   #:delete-element
+   #:an-object
+   #:delete-an-object
+   #:create-an-object
+   #:some-objects
+   #:make-new-instance
+   #:add-an-object
+   #:slot-presentations
+   #:defpresentation
+
+   ;; the time utility stolen from clsql
+   #:make-time
+   #:get-time
+   #:time+
+   #:time-ymd
+   #:time-difference))
addfile ./src/presentations.lisp
hunk ./src/presentations.lisp 1
+;;;; -*- lisp -*-
+
+(in-package :it.bese.ucw)
+
+(defcomponent presentation ()
+  ((css-class :accessor css-class :initarg :css-class :initform nil))
+  (:documentation "The super class of all UCW presentations.
+
+A presentation object is a UCW component which knows how to
+read/write different kinds of data types.
+
+There are three major kinds of presentations:
+
+1) object-presentation - Managing a single object.
+
+2) slot-presentation - Managing the single parts (slots) which
+   make up an object.
+
+3) collection-presentation - Managing multiple objects.
+
+Presentations are independant of the underlying application
+specific lisp objects they manage. A presentation can be created
+once and reused or modified before and aftre it has been used.
+
+Presentations fulfill two distinct roles: on the one hand they
+create, given a lisp object, a grahpical (html) rendering of that
+object, they also deal with whatever operations the user might
+wish to perform on that object.
+
+* Creating Presentation Objects
+
+Presentation objects are created by making an instance of either
+an object-presentation or a collection-presentation and then
+filling the slots property of this object."))
+
+(defmacro present-object (object &key using presentation)
+  (assert (xor using presentation)
+	  (using presentation)
+	  "Must specify exactly one of :USING and :PRESENTATION.")
+  (if using
+      (destructuring-bind (type &rest args)
+	  (ensure-list using)
+	`(call ',type ,@args :instance ,object))
+      (rebinding (presentation)
+	`(progn
+	   (setf (slot-value ,presentation 'instance) ,object)
+	   (call-component self ,presentation)))))
+
+(defmacro present-collection (presentation-type &rest initargs)
+  `(call ',presentation-type ,@initargs))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; object-presentation
+
+(defcomponent object-presentation (presentation)
+  ((slots :accessor slots :initarg :slots :initform nil)
+   (instance :initform nil :initarg :instance :accessor instance))
+  (:documentation "Presentations for single objects."))
+
+(defmethod render ((o object-presentation))
+  (unless (slot-value o 'instance)
+    (error "Attempting to render the presentation ~S, but it has no instance object to present."
+	   o))
+  (present t o))
+
+(defmethod present ((view t) (pres object-presentation))
+  (declare (ignore view))
+  (<:table :class (css-class pres)
+    (dolist (slot (slots pres))
+      (<:tr :class "presentation-slot-row"
+        (<:td :class "presentation-slot-label" (<:as-html (label slot)))
+	(<:td :class "presentation-slot-value" (present-slot slot (instance pres)))))
+    (render-options pres (instance pres))))
+
+(defmethod render-options ((pres object-presentation) instance)
+  (declare (ignore instance pres))
+  #| (<:tr
+    (<:td :colspan 2 :align "center"
+      (<ucw:input :type "submit" :action (ok pres) :value "Ok."))) |# )
+
+(defaction ok ((o object-presentation) &optional (value (slot-value o 'instance)))
+  (answer value))
+
+(defmethod find-slot ((o object-presentation) slot-label)
+  (find slot-label (slots o) :test #'string= :key #'label))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; inline objects are extremly similar to object-presentations
+;;;; except that we assume they're being edited within the context of
+;;;; some other and so don't get their own edit/delete/confirm
+;;;; whatever buttons.
+
+(defcomponent inline-object-presentation (object-presentation)
+  ())
+
+(defmethod render-options ((pres inline-object-presentation) instance)
+  (declare (ignore instance))
+  nil)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; 'one line' objects
+
+(defcomponent one-line-presentation (object-presentation)
+  ((before :accessor before :initform "" :initarg :before
+	   :documentation "Text to render before rendirng the slots.")
+   (between :accessor between :initform " " :initarg :between
+	    :documentation "Text to render between each slot.")
+   (after :accessor after :initform "" :initarg :after
+	  :documentation "Text to render after all the slots have been rendered.")))
+
+(defmethod present ((view t) (pres one-line-presentation))
+  (declare (ignore view))
+  (<:as-is (before pres))
+  (when (slots pres)
+    (present-slot (first (slots pres)) (instance pres)))
+  (dolist (slot (cdr (slots pres)))
+    (<:as-is (between pres))
+    (present-slot slot (instance pres)))
+  (<:as-is (after pres)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; List
+
+(defcomponent list-presentation (presentation)
+  ((slots :accessor slots :initarg :slots)
+   (editablep :accessor editablep :initform t :initarg :editablep)
+   (edit-label :accessor edit-label :initform "Edit")
+   (deleteablep :accessor deleteablep :initform t :initarg :deleteablep)
+   (delete-label :accessor delete-label :initform "Delete")
+   (instances :accessor instances)))
+
+(defmethod initialize-instance :after ((l list-presentation) &rest initargs)
+  (declare (ignore initargs))
+  (setf (instances l) (get-all-instances l)))
+
+(defmethod render ((l list-presentation))
+  (present t l))
+
+(defgeneric get-all-instances (listing)
+  (:documentation "Returns all the instances which should be viewable with LISTING.
+
+This method is also used by relation-slot-presentations for the same reason."))
+
+(defmethod present ((view t) (listing list-presentation))
+  (declare (ignore view))
+  (<:table :class (css-class listing)
+    (render-list-heading listing)
+    (iterate
+      (for element in (instances listing))
+      (for index upfrom 0)
+      (render-list-row listing element index))))
+
+(defmethod render-list-heading ((listing list-presentation))
+  (<:tr :class "presentation-list-heading-row"
+    (<:th "")
+    (dolist (slot (slots listing))
+      (<:th :class "presentation-list-heading-cell"
+        (<:as-html (label slot))))
+    (<:th "")))
+  
+(defmethod render-list-row ((listing list-presentation) object index)
+  (<:tr :class "item-row"
+    (<:td :class "index-number-cell"
+      (<:i (<:as-html index)))
+    (dolist (slot (slots listing))
+      (<:td :class "data-cell" (present-slot slot object)))
+    (<:td :align "center" :valign "top"
+      (when (editablep listing)
+	(let ((object object))
+	  (<ucw:input :type "submit"
+		      :action (edit-from-listing listing object index)
+		      :value (edit-label listing))))
+      (<:as-is " ")
+      (when (deleteablep listing)
+	(let ((index index))
+	  (<ucw:input :type "submit"
+		      :action (delete-from-listing listing object index)
+		      :value (delete-label listing)))))))
+
+(defgeneric/cc create-from-listing (listing))
+
+(defmethod/cc create-from-listing :after ((l list-presentation))
+  (setf (instances l) (get-all-instances l)))
+
+(defgeneric/cc delete-from-listing (listing item index))
+
+(defmethod/cc delete-from-listing :after ((l list-presentation) item index)
+  (declare (ignore item index))
+  (setf (instances l) (get-all-instances l)))
+
+(defgeneric/cc edit-from-listing (listing item index))
+
+(defmethod/cc edit-from-listing :after ((l list-presentation) item index)
+  (declare (ignore item index))
+  (setf (instances l) (get-all-instances l)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Searching/Filtering
+
+(defcomponent presentation-search (presentation)
+  ((criteria :accessor criteria :initform '())
+   (search-presentation :accessor search-presentation :initarg :search-presentation
+			:documentation "The presentation object
+			used in determining what the possible
+			search options are.")
+   (list-presentation :accessor list-presentation :initarg :list-presentation
+		      :documentation "The presentation object used when showing the results.")))
+
+(defgeneric applicable-criteria (presentation)
+  (:method-combination nconc))
+
+(defmethod applicable-criteria nconc ((search presentation-search))
+  (let ((criteria '()))
+    (dolist (slot (slots (search-presentation search)))
+      (setf criteria (append criteria (applicable-criteria slot))))
+    (cons (make-instance 'negated-criteria :presentation search)
+	  criteria)))
+
+(defcomponent criteria ()
+  ((presentation :accessor presentation :initarg :presentation)))
+
+(defaction add-criteria ((search presentation-search) (criteria criteria))
+  (push criteria (criteria search)))
+
+(defaction drop-criteria ((search presentation-search) (criteria criteria))
+  (setf (criteria search) (delete criteria (criteria search))))
+
+(defgeneric apply-criteria (criteria instance)
+  (:method-combination and))
+
+(defmethod valid-instances ((search presentation-search))
+  (let ((valid '()))
+    (dolist (i (get-all-instances search))
+      (block apply-criteria
+	(dolist (criteria (criteria search))
+	  (unless (apply-criteria criteria i)
+	    (return-from apply-criteria nil)))
+	(push i valid)))
+    valid))
+
+(defcomponent search-results-list (list-presentation)
+  ((search-presentation :accessor search-presentation)))
+
+(defmethod render ((s presentation-search))
+  (<:p "Results:")
+  (let ((listing (list-presentation s)))
+    (<:table
+      (<:tr :class "presentation-list-heading-row"
+        (<:th "")
+	(dolist (slot (slots (list-presentation s)))
+	  (<:th :class "presentation-list-heading-cell"
+	    (<:as-html (label slot))))
+	(<:th ""))
+      (loop
+         for object in (valid-instances s)
+         for index upfrom 0
+         do (<:tr :class "item-row"
+              (<:td :class "index-number-cell" (<:i (<:as-html index)))
+              (dolist (slot (slots (list-presentation s)))
+                (<:td :class "data-cell" (present-slot slot object)))
+              (<:td :align "center" :valign "top"
+                (when (editablep listing)
+                  (let ((object object))
+                    (<ucw:input :type "submit"
+                                :action (edit-from-search s object index)
+                                :value (edit-label listing))))
+                (<:as-is " ")
+                (when (deleteablep listing)
+                  (let ((index index))
+                    (<ucw:input :type "submit"
+                                :action (delete-from-search s object index)
+                                :value (delete-label listing)))))))))
+  (<:p "Search Criteria:")
+  (<:ul
+   (render-criteria s)
+   (<:li (<ucw:input :type "submit" :action (refresh-component s)
+		     :value "update"))))
+
+(defmethod render-criteria ((s presentation-search))
+  (<:ul
+   (dolist (c (criteria s))
+     (<:li (render c)
+	   (let ((c c))
+	     (<ucw:input :action (drop-criteria s c) :type "submit" :value "eliminate"))))
+   (let ((new-criteria nil))
+     (<:li "Add Criteria: "
+       (<ucw:select :accessor new-criteria
+         (dolist (criteria (applicable-criteria s))
+	   (<ucw:option :value criteria (<:as-html (label criteria)))))
+       (<ucw:input :type "submit" :action (add-criteria s new-criteria)
+		   :value "add")))))
+
+(defgeneric/cc edit-from-search (search object index))
+
+(defgeneric/cc delete-from-search (search object index))
+
+;;;; meta criteria
+
+(defcomponent negated-criteria (criteria)
+  ((criteria :accessor criteria :initform nil)))
+
+(defmethod label ((n negated-criteria)) "Not:")
+
+(defmethod render ((n negated-criteria))
+  (<:p "Not: "
+       (when (criteria n)
+	 (render (criteria n))))
+  (let ((new-criteria nil))
+    (<:p "Set Criteria: "
+      (<ucw:select :accessor new-criteria
+        (dolist (criteria (applicable-criteria (presentation n)))
+	  (<ucw:option :value criteria (<:as-html (label criteria)))))
+      (<ucw:input :type "submit" :action (setf (criteria n) new-criteria)
+		  :value "add"))))
+
+(defmethod apply-criteria and ((n negated-criteria) instance)
+  (if (criteria n)
+      (not (apply-criteria (criteria n) instance))
+      t))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Slot presentations
+
+(defcomponent slot-presentation (presentation)
+  ((label :accessor label :initarg :label)
+   (label-plural :accessor label-plural :initarg :label-plural)
+   (getter :accessor getter :initarg :getter
+	   :documentation "A function used for getting the
+	   current value of the object. It will be passed the
+	   object and must return the current value.")
+   (setter :accessor setter :initarg :setter
+	   :documentation "A function used for updatig the value of
+	   the underlying object. It will be passed the new
+	   value and the object (in that order).")
+   (editablep :accessor editablep :initarg :editablep :initform t)
+   (print-object-label)))
+
+(defmethod print-object ((s slot-presentation) stream)
+  (if *print-readably*
+      (call-next-method)
+      (print-unreadable-object (s stream :type t :identity t)
+        (princ (label s) stream)
+        (princ " (" stream)
+        (princ (slot-value s 'print-object-label) stream)
+        (princ ")" stream))))
+
+(defgeneric present-slot (slot instance))
+
+(defmethod initialize-instance :after ((presentation slot-presentation)
+				       &key slot-name getter setter &allow-other-keys)
+  (if slot-name
+      (setf (slot-value presentation 'print-object-label) slot-name)
+      (setf (slot-value presentation 'print-object-label) getter))
+  (when slot-name
+    (assert (not (or getter setter))
+	    (slot-name getter setter)
+	    "Can't specify :GETTER and/or :SETTER along with :SLOT-NAME.")
+    (setf (getter presentation) (lambda (object)
+				  (when (slot-boundp object slot-name)
+				    (slot-value object slot-name)))
+	  (setter presentation) (lambda (value object)
+				  (setf (slot-value object slot-name) value)))))
+
+(defvar *slot-type-mapping* (make-hash-table :test 'eql))
+
+(defun register-slot-type-mapping (name class-name)
+  (setf (gethash name *slot-type-mapping*) class-name))
+
+(defmacro defslot-presentation (name supers slots &rest options)
+  `(progn
+     (defcomponent ,name ,(or supers `(slot-presentation))
+       ,slots
+       ,@(remove :type-name options :key #'car))
+     ,(let ((type-name (assoc :type-name options)))
+	(when type-name
+	`(register-slot-type-mapping ',(second type-name) ',name)))
+     ',name))
+
+(defgeneric presentation-slot-value (slot instance)
+  (:method ((slot slot-presentation) instance)
+    (funcall (getter slot) instance)))
+
+(defgeneric (setf presentation-slot-value) (value slot instance)
+  (:method (value (slot slot-presentation) instance)
+    (funcall (setter slot) value instance)))
+
+(defmethod applicable-criteria nconc ((s slot-presentation))
+  nil)
+
+(defmacro criteria-for-slot-presentation (slot &body criteria-clauses)
+  (rebinding (slot)
+    `(list
+      ,@(mapcar (lambda (criteria-clause)
+		  (let ((criteria-clause (ensure-list criteria-clause)))
+		    `(make-instance ',(first criteria-clause)
+				    ,@(cdr criteria-clause)
+				    :presentation ,slot)))
+		criteria-clauses))))
+
+(defmacro defslot-critera (class-name supers slots &key label apply-criteria)
+  (with-unique-names (obj instance)
+    (list
+     'progn
+     `(defcomponent ,class-name ,supers ,slots)
+     (when label
+       `(defmethod label ((,obj ,class-name))
+          (format nil ,label (label (presentation ,obj)))))
+
+     (when apply-criteria
+       `(defmethod apply-criteria and ((,obj ,class-name) ,instance)
+          (funcall ,apply-criteria
+                   ,obj
+                   ,instance
+                   (presentation-slot-value (presentation ,obj) ,instance))))
+     `(quote ,class-name))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Boolean
+
+(defslot-presentation boolean-slot-presentation ()
+  ()
+  (:type-name boolean))
+
+(defmethod present-slot ((slot boolean-slot-presentation) instance)
+  (let ((bool (presentation-slot-value slot instance)))
+    (if (editablep slot)
+	(<ucw:input :type "checkbox" :checked bool :accessor bool)
+	(<:as-html (if bool "Yes" "No")))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; strings
+
+(defslot-presentation string-slot-presentation ()
+  ((max-length :accessor max-length :initarg :max-length :initform nil)
+   (size :accessor size :initarg :size :initform nil))
+  (:type-name string))
+
+(defmethod present-slot ((slot string-slot-presentation) instance)
+  (if (editablep slot)
+      (<ucw:input :type "text"
+		  :accessor (presentation-slot-value slot instance)
+		  :size (or (size slot)
+			    (if (string= "" (presentation-slot-value slot instance))
+				(size slot)
+				(+ 3 (length (presentation-slot-value slot instance)))))
+		  :maxlength (max-length slot))
+      (<:as-html (presentation-slot-value slot instance))))
+
+;;;; Critera
+
+(defmethod applicable-criteria nconc ((s string-slot-presentation))
+  (criteria-for-slot-presentation s
+    string-starts-with
+    string-contains
+    string-ends-with))
+
+(defcomponent string-criteria (criteria)
+  ((search-text :accessor search-text :initform nil)))
+
+(defmethod render ((criteria string-criteria))
+  (<:as-html (label criteria) " ")
+  (<ucw:input :type "text" :accessor (search-text criteria) :size 10))
+
+(defslot-critera string-contains (string-criteria)
+  ()
+  :label "~A contains:"
+  :apply-criteria (lambda (criteria instance slot-value)
+		    (declare (ignore instance))
+		    (and (<= (length (search-text criteria)) (length slot-value))
+			 (search (search-text criteria) slot-value :test #'char-equal))))
+
+(defslot-critera string-starts-with (string-contains)
+  ()
+  :label "~A starts with:"
+  :apply-criteria (lambda (criteria instance slot-value)
+                    (declare (ignore instance))
+		    (and (<= (length (search-text criteria)) (length slot-value))
+			 (= 0 (or (search (search-text criteria) slot-value
+					  :test #'char-equal)
+				  -1)))))
+
+(defslot-critera string-ends-with (string-contains)
+  ()
+  :label "~A ends with:"
+  :apply-criteria (lambda (criteria instance slot-value)
+		    (declare (ignore instance))
+		    (and  (<= (length (search-text criteria)) (length slot-value))
+			  (= (- (length slot-value) (length (search-text criteria)))
+			     (or (search (search-text criteria) slot-value
+					 :from-end t
+					 :test #'char-equal)
+				 -1)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; numbers
+
+(defslot-presentation number-slot-presentation ()
+  ((min-value :accessor min-value :initarg :min-value :initform nil)
+   (max-value :accessor max-value :initarg :max-value :initform nil)))
+
+(defcomponent number-criteria (criteria)
+  ((number-input :accessor number-input :initform nil)))
+
+(defmethod applicable-criteria nconc ((s number-slot-presentation))
+  (criteria-for-slot-presentation s
+    number-less-than
+    number-greater-than
+    number-equal-to))
+
+(defmacro defnumber-criteria (name &key label render-prefix apply-criteria)
+  `(progn
+     (defslot-critera ,name (number-criteria)
+       ()
+       :label ,label
+       :apply-criteria (lambda (criteria instance slot-value)
+			 (declare (ignore instance))
+			 (if (numberp slot-value)
+			     (if (number-input criteria)
+				 (funcall ,apply-criteria slot-value (number-input criteria))
+				 t)
+			     nil)))
+
+     (defmethod render ((obj ,name))
+       (<:as-html (format nil ,render-prefix (label (presentation obj))))
+       (<ucw:input :type "text"
+		   :reader (or (number-input obj) "")
+		   :writer (lambda (v)
+			     (unless (string= "" v)
+			       (let ((n (parse-float v)))
+				 (when n
+				   (setf (number-input obj) n)))))))))
+
+(defnumber-criteria number-equal-to
+  :apply-criteria (lambda (slot-value number-input)
+		    (= slot-value number-input))
+  :label "~A is equal to:"
+  :render-prefix "~A = ")
+
+(defnumber-criteria number-less-than
+  :apply-criteria (lambda (slot-value number-input)
+		    (< slot-value number-input))
+  :label "~A is less than:"
+  :render-prefix "~A < ")
+
+(defnumber-criteria number-greater-than
+  :apply-criteria (lambda (slot-value number-input)
+		    (> slot-value number-input))
+  :label "~A is greater than:"
+  :render-prefix "~A > ")
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Integers
+
+(defslot-presentation integer-slot-presentation (number-slot-presentation)
+  ()
+  (:type-name integer))
+
+(defmethod presentation-slot-value ((slot integer-slot-presentation) instance)
+  (declare (ignore instance))
+  (or (call-next-method) ""))
+
+(defmethod (setf presentation-slot-value) ((value string) (slot integer-slot-presentation) instance)
+  (unless (string= "" value)
+    (let ((i (parse-integer value :junk-allowed t)))
+      (when i
+	(setf (presentation-slot-value slot instance) i)))))
+
+(defmethod present-slot ((slot integer-slot-presentation) instance)
+  (if (editablep slot)
+      (<ucw:input :type "text"
+		  :accessor (presentation-slot-value slot instance))
+      (<:as-html (presentation-slot-value slot instance))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Reals
+
+(defcomponent real-slot-presentation (number-slot-presentation)
+  ())
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Currency (double precision reals)
+
+(defslot-presentation currency-slot-presentation (real-slot-presentation)
+  ()
+  (:type-name currency))
+
+(defmethod (setf presentation-slot-value) ((value string) (c currency-slot-presentation) instance)
+  (let ((*read-eval* nil))
+    (unless (string= "" value)
+      (let ((value (read-from-string value)))
+	(when (numberp value)
+	  (setf (presentation-slot-value c instance) value))))))
+
+(defmethod present-slot ((currency currency-slot-presentation) instance)
+  (if (editablep currency)
+      (<ucw:input :type "text" :size 10
+		  :accessor (presentation-slot-value currency instance))
+      (<:as-html (presentation-slot-value currency instance))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; dates and times
+
+(defslot-presentation timestamp-slot-presentation (slot-presentation)
+  ()
+  (:type-name timestamp))
+
+(defmacro deftimestamp-slot-accessor (accessor time-accessor nth-value make-time-arg)
+  (let ((accessor-name (intern (strcat '#:timestamp-slot- accessor))))
+    `(progn
+       (defgeneric ,accessor-name (slot instance))
+       (defgeneric (setf ,accessor-name) (value slot instance))
+       (defmethod ,accessor-name ((slot timestamp-slot-presentation) instance)
+	 (when (presentation-slot-value slot instance)
+	   (nth-value ,nth-value (,time-accessor (presentation-slot-value slot instance)))))
+       (defmethod (setf ,accessor-name) ((value integer) (slot timestamp-slot-presentation) instance)
+	 (if (presentation-slot-value slot instance)
+	     (setf (presentation-slot-value slot instance)
+		   (make-time ,make-time-arg value :defaults (presentation-slot-value slot instance)))
+	     (setf (presentation-slot-value slot instance) (make-time ,make-time-arg value))))
+       (defmethod (setf ,accessor-name) ((value string) (slot timestamp-slot-presentation) instance)
+         (let ((i (parse-integer value :junk-allowed t)))
+           (when i
+             (setf (,accessor-name slot instance) i))))
+       (defmethod (setf ,accessor-name) ((value null) (slot timestamp-slot-presentation) instance)
+         (setf (presentation-slot-value slot instance) nil)))))
+
+(deftimestamp-slot-accessor second time-hms 2 :second)
+(deftimestamp-slot-accessor minute time-hms 1 :minute)
+(deftimestamp-slot-accessor hour time-hms 0 :hour)
+(deftimestamp-slot-accessor year time-ymd 0 :year)
+(deftimestamp-slot-accessor month time-ymd 1 :month)
+(deftimestamp-slot-accessor day time-ymd 2 :day)
+
+(defslot-presentation ymd-slot-presentation (timestamp-slot-presentation)
+  ()
+  (:type-name date))
+
+(defmethod present-slot ((slot ymd-slot-presentation) instance)
+  (if (editablep slot)
+      (<:progn
+        (<ucw:input :class (css-class slot) :type "text" :size 2
+                    :accessor (timestamp-slot-day slot instance))
+        "/"
+        (<ucw:input :class (css-class slot) :type "text" :size 2
+                    :accessor (timestamp-slot-month slot instance))
+        "/"
+        (<ucw:input :class (css-class slot) :type "text" :size 4
+                    :accessor (timestamp-slot-year slot instance)))
+      (if (presentation-slot-value slot instance)
+	  (<:progn
+	    (<:as-html (timestamp-slot-day slot instance))
+	    "/"
+	    (<:as-html (timestamp-slot-month slot instance))
+	    "/"
+	    (<:as-html (timestamp-slot-year slot instance)))
+	  (<:as-html "---"))))
+
+(defmethod applicable-criteria nconc ((slot ymd-slot-presentation))
+  (criteria-for-slot-presentation slot
+    date-before-criteria))
+
+(defslot-critera date-before-criteria (criteria)
+  ((target :accessor target))
+  :label "Date Before:")
+
+(defmethod render ((dbc date-before-criteria))
+  (<:as-html "Date Before: "))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Relations
+
+(defcomponent relation-slot-presentation (slot-presentation)
+  ((presentation :accessor presentation
+		 :initarg :presentation
+		 :documentation "The class of presentation
+		 objects used to fill the options of a select
+		 tag.")
+   (search-presentation :accessor search-presentation
+			:initarg :search-presentation
+			:initform nil)
+   (allow-nil-p :accessor allow-nil-p
+		:initarg :allow-nil-p
+		:initform t
+		:documentation "Can this relation not exist.")))
+
+(defmethod presentation ((slot relation-slot-presentation))
+  (with-slots (presentation)
+      slot
+    (if (or (symbolp presentation)
+	    (consp presentation))
+	(setf presentation (apply #'make-instance (ensure-list presentation)))
+	presentation)))
+
+(defgeneric get-foreign-instances (pres instance))
+
+(defcomponent relation-criteria (criteria presentation-search)
+  ((criteria :accessor criteria :initform '())))
+
+(defmethod search-presentation ((criteria relation-criteria))
+  (or (search-presentation (presentation criteria))
+      (presentation (presentation criteria))))
+
+;;;; One-Of
+
+(defslot-presentation one-of-presentation (relation-slot-presentation)
+  ((none-label :initarg :none-label :accessor none-label
+	       :initform "none"))
+  (:type-name one-of))
+
+(defmethod present-slot ((slot one-of-presentation) instance)
+  (if (editablep slot)
+      (<ucw:select :accessor (presentation-slot-value slot instance)
+        (when (allow-nil-p slot)
+	  (<ucw:option :value nil (<:as-html (none-label slot))))
+	(dolist (option (get-foreign-instances (presentation slot) instance))
+	  (setf (instance (presentation slot)) option)
+	  (<ucw:option :value option (present t (presentation slot)))))
+      (if (presentation-slot-value slot instance)
+	  (progn
+	    (setf (instance (presentation slot)) (presentation-slot-value slot instance))
+	    (present t (presentation slot)))
+	  (<:as-html "--"))))
+
+(defmethod applicable-criteria nconc ((slot one-of-presentation))
+  (criteria-for-slot-presentation slot
+    one-of-criteria
+    one-of-not-null))
+
+(defslot-critera one-of-criteria (relation-criteria)
+  ())
+
+(defmethod label ((ooc one-of-criteria))
+  (strcat (label (presentation ooc)) " with:"))
+
+(defmethod render ((ooc one-of-criteria))
+  (<:as-html (label (presentation ooc)) " with:")
+  (render-criteria ooc))
+
+(defmethod apply-criteria and ((ooc one-of-criteria) instance)
+  (let ((nested-instance (presentation-slot-value (presentation ooc) instance))
+	(criteria (criteria ooc)))
+    (if criteria
+	(if nested-instance
+	    (dolist (c (criteria ooc) t)
+	      (unless (apply-criteria c nested-instance)
+		(return-from apply-criteria nil)))
+	    nil)
+	t)))
+
+(defslot-critera one-of-not-null (criteria)
+  ())
+
+(defmethod label ((oonn one-of-not-null))
+  (strcat (label (presentation oonn)) " exists."))
+
+(defmethod apply-criteria and ((oonn one-of-not-null) instance)
+  (not (null (presentation-slot-value (presentation oonn) instance))))
+
+(defmethod render ((oonn one-of-not-null))
+  (<:as-html (label (presentation oonn)) " exists."))
+
+;;;; Some-Of
+
+(defslot-presentation some-of-presentation (relation-slot-presentation)
+  ()
+  (:type-name some-of))
+
+(defmethod present-slot ((slot some-of-presentation) instance)
+  (<:ul
+   (if (presentation-slot-value slot instance)
+       (loop
+          for option in (presentation-slot-value slot instance)
+          for index upfrom 0
+          do (let ((option option) ;; loop changes the values, it does
+                                   ;; not create fresh bindings
+                   (index index))
+               (<:li
+                 (<:table
+                   (<:tr
+                     (<:td (setf (instance (presentation slot)) option)
+                           (present t (presentation slot)))
+                     (when (editablep slot)
+                       (<:td :align "left" :valign "top"
+                         (<ucw:input :type "submit"
+                                     :action (delete-element slot instance option index)
+                                     :value (concatenate 'string "Delete " (label slot))))))))))
+       (<:li "None."))
+   (render-add-new-item slot instance)))
+
+(defmethod render-add-new-item ((slot some-of-presentation) instance)
+  (let ((new-object nil)
+	(foreign-instances (get-foreign-instances (presentation slot) instance)))
+    (when (and foreign-instances (editablep slot))
+      (<:li "Add: "
+        (<ucw:select :accessor new-object
+	  (dolist (option foreign-instances)
+	    (setf (instance (presentation slot)) option)
+	    (<ucw:option :value option (present t (presentation slot)))))
+	(<ucw:input :type "submit"
+		    :action (add-element slot instance new-object)
+		    :value "Add")))))
+
+(defaction add-element ((some-of some-of-presentation) instance item)
+  (push item (presentation-slot-value some-of instance)))
+
+(defaction delete-element ((some-of some-of-presentation) instance item index)
+  (let ((nth (nth index (presentation-slot-value some-of instance))))
+    (unless (eq nth item)
+      (error "Attempting to delete the ~Dth item, which should be ~S, but the ~Dth item is actually ~S."
+	     index item index nth))
+    (setf (presentation-slot-value some-of instance)
+	  (iterate
+	    (for element in (presentation-slot-value some-of instance))
+	    (for i upfrom 0)
+	    (unless (= index i)
+	      (collect element))))))
+
+(defmethod applicable-criteria nconc ((slot some-of-presentation))
+  (criteria-for-slot-presentation slot
+    some-of-any
+    some-of-all))
+
+(defslot-critera some-of-criteria (relation-criteria)
+  ())
+
+(defmethod render ((soa some-of-criteria))
+  (<:as-html (label soa))
+  (render-criteria soa))
+
+(defmacro defsome-of-criteria (name supers slots &key label apply-criteria)
+  (with-unique-names (obj)
+    `(progn
+       (defslot-critera ,name ,supers ,slots)
+       (defmethod label ((,obj ,name))
+	 (format nil ,label (label (presentation ,obj))))
+       (defmethod apply-criteria and ((,obj ,name) instance)
+	 (let ((nested-instances (presentation-slot-value (presentation ,obj) instance))
+	       (criteria (criteria ,obj)))
+	   (if criteria
+	       (if nested-instances
+		   (funcall ,apply-criteria (criteria ,obj) nested-instances)
+		   nil)
+	       t))))))
+
+(defsome-of-criteria some-of-any (some-of-criteria)
+  ()
+  :label "Any ~A with:"
+  :apply-criteria (lambda (criteria nested-instances)
+		    ;; return T if any nested-instance meets all of criteria
+		    (some (lambda (instance)
+			    (every (lambda (criteria)
+				     (apply-criteria criteria instance))
+				   criteria))
+			  nested-instances)))
+
+(defsome-of-criteria some-of-all (some-of-criteria)
+  ()
+  :label "All ~A with:"
+  :apply-criteria (lambda (criteria nested-instances)
+		    ;; return T only if every nested-instances meets
+		    ;; all of our criteria
+		    (every (lambda (instance)
+			     (every (lambda (criteria)
+				      (apply-criteria criteria instance))
+				    criteria))
+			   nested-instances)))
+
+;;;; An-Object
+
+(defslot-presentation an-object-presentation (one-of-presentation)
+  ()
+  (:type-name an-object))
+
+(defmethod present-slot ((slot an-object-presentation) instance)
+  (if (presentation-slot-value slot instance)
+      (progn
+	(setf (instance (presentation slot)) (presentation-slot-value slot instance))
+	(present t (presentation slot))
+	(<ucw:input :type "submit" :action (delete-an-object slot instance)
+                    :value (concatenate 'string "Delete " (label slot))))
+      (<ucw:input :type "submit" :action (create-an-object slot instance) :value "Create")))
+
+(defaction delete-an-object ((slot an-object-presentation) instance)
+  (setf (presentation-slot-value slot instance) nil))
+
+(defaction create-an-object ((slot an-object-presentation) instance)
+  (let ((obj (make-new-instance (presentation slot) instance)))
+    (format t "Setting (presentation-slot-value ~S ~S) to ~S.~%" slot instance obj)
+    (setf (presentation-slot-value slot instance) obj)))
+
+;;;; Some-Objects
+
+(defslot-presentation some-objects-presentation (some-of-presentation)
+  ()
+  (:type-name some-objects))
+
+(defmethod render-add-new-item ((slot some-objects-presentation) instance)
+  (when (editablep slot)
+    (<:li (<ucw:input :type "submit"
+		      :action (add-an-object slot instance)
+		      :value "Add new object."))))
+
+(defgeneric make-new-instance (presentation instance)
+  (:documentation "Create an new instance suitable for
+  PRESENTATION which will be added to INSTANCE (according to
+  PRESENTATION)."))
+
+(defaction add-an-object ((slot some-objects-presentation) instance)
+  (push (make-new-instance (presentation slot) instance) (presentation-slot-value slot instance)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Convience macros/functions
+
+(defmacro slot-presentations (&rest slot-specs)
+  `(list ,@(mapcar (lambda (slot)
+		     (let ((class-name (gethash (car slot) *slot-type-mapping*)))
+		       (if class-name
+			   `(make-instance ',class-name ,@(cdr slot))
+			   (error "Unknown slot type ~S." (car slot)))))
+		   slot-specs)))
+
+(defmacro defpresentation (name supers slots &rest default-initargs)
+  `(defcomponent ,name ,supers
+     ()
+     (:default-initargs
+       ,@(when slots `(:slots (slot-presentations ,@slots)))
+       ,@default-initargs)))
+
addfile ./src/range-set.lisp
hunk ./src/range-set.lisp 1
+(in-package :ucw)
+
+(defclass range-cursor ()
+  ((data :accessor range-cursor.data
+                 :initarg :data
+                 :documentation
+                 "Data to range.")
+   (chunk-size :accessor range-cursor.chunk-size
+               :initarg :chunk-size
+               :type integer
+               :initform 20
+               :documentation
+               "Maximum number of elements in one chunk.")
+   (offset :accessor range-cursor.offset
+           :type integer
+           :initarg :offset
+           :initform 0
+           :documentation
+           "Current offset in chunks.")
+   (recent-fetch-size :reader range-cursor.recent-fetch-size
+                     :initform nil
+                     :documentation
+                     "Number of recently retrieved data elements."))
+  (:documentation "Read chunks of elements from data at arbitrary offset."))
+
+(defgeneric range-cursor.data-size (range-cursor data)
+  (:method ((rc range-cursor) (rd sequence))
+    (length rd))
+  (:documentation "Return total number of elements in the DATA."))
+
+(defgeneric range-cursor.fetch-data-chunk (range-cursor data offset length)
+  (:method ((rc range-cursor) (data sequence) (offset integer) (length integer))
+    (subseq data offset (+ offset length)))
+  (:documentation "Read LENGTH elements from DATA starting from
+OFFSET(excluding OFFSET element).
+Return a list of elements."))
+
+(defgeneric range-cursor.delete-data-item (range-cursor data item index)
+  (:method ((rc range-cursor) (data sequence) item (index integer))
+    (declare (ignore item))
+    (when (<= index (length data))
+      (setf (range-cursor.data rc)
+            (delete-if (constantly t) data :start (1- index) :count 1))
+      t))
+  (:documentation "Delete ITEM with INDEX from cursor related DATA."))
+
+(defgeneric range-cursor.add-data-item (range-cursor data item)
+  (:method ((rc range-cursor) (data sequence) item)
+    (push item (range-cursor.data rc))
+    t)
+  (:documentation "Add ITEM with INDEX to cursor related DATA."))
+
+(defgeneric range-cursor.range-size (range-cursor)
+  (:documentation "Return the size of the set in chunks."))
+
+(defmethod range-cursor.range-size ((rc range-cursor))
+  (with-slots (data chunk-size) rc
+    (multiple-value-bind (q rem)
+        (floor (range-cursor.data-size rc data) chunk-size)
+      (if (zerop rem) q (1+ q)))))
+
+(defmethod range-cursor.have-previous-p ((rc range-cursor))
+  (> (range-cursor.offset rc) 0))
+
+(defmethod range-cursor.have-next-p ((rc range-cursor))
+  (aif (range-cursor.recent-fetch-size rc)
+       (> it (range-cursor.chunk-size rc))
+       t ; no reads yet
+       ))
+
+(defgeneric range-cursor.fetch-chunk (range-cursor op)
+  (:documentation "Retrieve chunk from the data.
+Returns a list of elements."))
+
+(defmethod range-cursor.fetch-chunk :before ((rc range-cursor) op)
+  (with-slots (offset recent-fetch-size) rc
+    (setf offset
+          (ecase op
+            (:first 0)
+            (:last (max (1- (range-cursor.range-size rc)) 0))
+            (:next (if (and recent-fetch-size (range-cursor.have-next-p rc))
+                       (1+ offset)
+                       offset))
+            (:previous (if (range-cursor.have-previous-p rc)
+                           (1- offset)
+                           offset))
+            (:current (max 0 offset))))))
+
+(defmethod range-cursor.fetch-chunk ((rc range-cursor) op)
+  (declare (ignore op))
+  (with-slots (chunk-size recent-fetch-size offset data) rc
+    (let ((items (range-cursor.fetch-data-chunk rc data (* offset chunk-size) (1+ chunk-size))))
+      (setf recent-fetch-size (length items))
+      (if (> recent-fetch-size chunk-size)
+          (butlast items)
+          items))))
+
+(defmethod range-cursor.delete-item ((rc range-cursor) item (index integer))
+  "Delete ITEM with INDEX from cursor related DATA."
+  (range-cursor.delete-data-item rc (range-cursor.data rc) item index))
+
+(defmethod range-cursor.add-item ((rc range-cursor) item)
+  "Add ITEM to cursor related DATA."
+  (range-cursor.add-data-item rc (range-cursor.data rc) item))
+
addfile ./src/search-criteria.lisp
hunk ./src/search-criteria.lisp 1
+(in-package :ucw)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (define-ie-method applicable-criteria nconc ((e (ie-type t)))
+                    '())
+
+  (define-ie-method negative-criteria ((e (ie-type t)))
+                    nil)
+
+  (define-ie-generic criteria-label (criteria interface-element)
+    (:method ((c (eql :not)) (e (ie-type t)))
+      "not")
+    (:method ((c (eql :=)) (e (ie-type t)))
+      "equal to")
+    (:method ((c (eql :>)) (e (ie-type t)))
+      "greater than")
+    (:method ((c (eql :<)) (e (ie-type t)))
+      "less than")
+    (:method ((c (eql :contains)) (e (ie-type t)))
+      "contains")
+    (:method ((c (eql :starts-with)) (e (ie-type t)))
+      "starts with")
+    (:method ((c (eql :ends-with)) (e (ie-type t)))
+      "ends with")
+    (:method ((c (eql :>)) (e (ie-type time)))
+      "after")
+    (:method ((c (eql :<)) (e (ie-type time)))
+      "before"))
+
+  (define-ie-generic make-criteria-attribute-value (element)
+    (:method ((e (ie-type t)))
+      (let ((ce (clone-element e :constraints nil :direct-value nil)))
+        (setf (editablep ce) t)
+        ce)))
+
+  (define-ie-method negative-criteria ((e (ie-type interface-element)))
+                    :not)
+
+  (define-ie-method applicable-criteria nconc ((e (ie-type text)))
+                    '(:= :contains :starts-with :ends-with))
+
+  (define-ie-method applicable-criteria nconc ((e (ie-type number)))
+                    '(:= :> :<))
+
+  (define-ie-method applicable-criteria nconc ((e (ie-type time)))
+                    '(:= :> :<))
+
+  (define-ie-method applicable-criteria nconc ((e (ie-type selector)))
+                    '(:=))
+
+  (define-ie-method applicable-criteria nconc ((e (ie-type checkbox)))
+                    '(:=))
+
+  (define-ie-method negative-criteria ((e (ie-type checkbox)))
+                    nil)
+  )
+
+(defclass alist-selector (select-element)
+  ()
+  (:metaclass standard-component-class)
+  (:default-initargs
+    :key #'car
+    :output-format #'(lambda (&rest args) (cdr (car args)))))
+
+(defclass search-criteria (composite-element)
+  ((attribute :accessor attribute
+              :initarg :attribute
+              :documentation "Attribute name criteria is applied to.")
+   (negativep :accessor negativep
+              :component (alist-selector)
+              :documentation
+              "Is criteria negative.")
+   (criteria :accessor criteria
+             :component (alist-selector)
+             :documentation
+             "Criteria to add into a query.")
+   (attribute-value :accessor attribute-value
+                   :initarg :attribute-value
+                   :documentation
+                   "Value of attribute."))
+  (:metaclass standard-component-class)
+  (:default-initargs    :slot-view (make-instance 'ieview :labelp nil))
+  (:documentation "Search criteria."))
+
+(defmethod shared-initialize :after ((sc search-criteria) slot-names
+                                     &key &allow-other-keys)
+  (declare (ignore slot-names))
+  (with-slots (attribute-value criteria negativep label slot-view) sc
+    (setf label (label attribute-value))
+
+    (let ((ac (applicable-criteria attribute-value)))
+      (setf (options criteria)
+          (mapcar #'(lambda (c) (cons c (criteria-label c attribute-value)))
+                  ac))
+      (case (length ac)
+        (0 (setf (enabledp sc) nil))            ; no criteria, disable it
+        (1 (setf (lisp-value criteria) (car ac) ; single criteria
+                 (editablep criteria) nil))     ; fix value
+        (otherwise t)))
+
+    (aif (negative-criteria attribute-value)
+         (setf (options negativep)
+               (acons nil "---"
+                      (acons it (criteria-label it attribute-value) nil)))
+         (setf (enabledp negativep) nil))))
+
+(defmethod query-value ((sc search-criteria))
+  (let ((lv (lisp-value sc))
+        negative
+        criteria
+        attr-value)
+    (setf (values negative criteria attr-value)
+          (values-list (mapcar #'(lambda (sn) (cdr (assoc sn lv)))
+                               '(negativep criteria attribute-value))))
+    (when criteria
+      (if (and (enabledp (negativep sc)) negative)
+          (list negative (list criteria attr-value))
+          (list criteria attr-value)))))
+
+(defmethod (setf query-value) (new (sc search-criteria))
+  (when new
+    (let (negative criteria attr-value)
+      (destructuring-bind (op op-value) new
+        (awhen (eq op (negative-criteria (attribute-value sc)))
+          (setf negative (negative-criteria (attribute-value sc))
+                (values op op-value) (values-list op-value)))
+        (setf criteria op
+              attr-value op-value))
+      (setf (lisp-value sc)
+            (pairlis '(negativep criteria attribute-value)
+                     (list negative criteria attr-value))))))
+
+(defmethod accept ((view composite-view) (sc search-criteria))
+  (with-slots (attribute-value) sc
+    (setf (view attribute-value) view)
+    (render attribute-value)))
+
+(defclass search-attribute-selector (select-element)
+  ()
+  (:metaclass standard-component-class)
+  (:default-initargs
+     :label "Add to query"
+     :output-format #'(lambda (v e)
+                        (declare (ignore e))
+                        (label (cdr v)))))
+
+(defmethod render-element ((view composite-view) (e search-attribute-selector))
+  (accept view e)
+  (<ucw:input :type "submit"
+              :value (label e)
+              :action (submit e)))
+
+(defmethod attribute-value-element ((e search-attribute-selector) attr
+                                    &key (errorp t))
+  (aif (find-if #'(lambda (v) (eql v attr)) (options e) :key #'car)
+     (cdr it)
+     (when errorp
+       (error "couldn't find query attribute ~a" attr))))
+
+(defaction submit ((e search-attribute-selector))
+  (setf (lisp-value e) (read-client-value e))
+  (aif (lisp-value e)
+       (add-search-attribute (parent e) (car it) (cdr it)))
+  t)
+ 
+(define-ie-type (search search-element) ((ie-type auxslots-form))
+  ((attribute-selector :accessor attribute-selector
+                       :component (search-attribute-selector)))
+  (:metaclass standard-component-class)
+  (:documentation "Accepts as ATTRIBUTES initarg
+alist of search attributes (ATTRIBUTE-NAME . INTERFACE-ELEMENT)
+or interface element to copy slots from as attributes.
+Initial query can be supplied as QUERY-VALUE initarg.
+Accessor  QUERY-VALUE method accepts/return query in the following format:
+(ATTRIBUTE-NAME ATTRIBUTE-QUERY)*
+ATTRIBUTE-NAME -- symbol
+ATTRIBUTE-QUERY -- NEGATIVE-EXPR | EXPR
+NEGATIVE-EXPR -- (:not EXPR)
+EXPR -- (OP VALUE)
+OP -- keyword from (APPLICABLE-CRITERIA interface-element)
+VALUE -- term acceptable by interface-element."))
+
+(defmethod shared-initialize :after ((se search-element) slot-names
+                                     &key attributes query-value
+                                     &allow-other-keys)
+  (declare (ignore slot-names))
+  (init-attribute-selector se attributes)
+  (setf (query-value se) query-value))
+
+(defmethod init-attribute-selector ((se search-element) (attributes list))
+  (setf (options (attribute-selector se)) attributes))
+
+(defmethod init-attribute-selector ((se search-element) (e composite-element))
+  (init-attribute-selector se
+                           (mapcar #'(lambda (sn) (cons sn (slot-value e sn)))
+                                   (slot-elements e :test #'enabledp))))
+
+(defmethod search-criteria-slots ((se search-element))
+  (let ((criteria-class (find-class 'search-criteria)))
+    (slot-elements se :test #'(lambda (s)
+                                (and (enabledp s)
+                                     (subtypep (class-of s) criteria-class))))))
+
+(defmethod add-search-attribute ((se search-element) attr attr-value)
+  (let ((slot-name (gensym)))
+    (setf (slot-value se slot-name)
+          (make-instance 
+           'search-criteria
+           :attribute attr
+           :attribute-value (make-criteria-attribute-value attr-value)))
+    slot-name))
+
+(defmethod query-value ((se search-element))
+  (mapcar #'(lambda (sn)
+              (let ((slot (slot-value se sn)))
+                (list (attribute slot) (query-value slot))))
+          (search-criteria-slots se)))
+
+(defmethod (setf query-value) (new (se search-element))
+  (dolist (slot (search-criteria-slots se))
+    (slot-makunbound se slot))
+  (iterate
+    (with as = (attribute-selector se))
+    (for (attr attr-query) in new)
+    (for ave = (attribute-value-element as attr))
+    (for slot-name = (add-search-attribute se attr ave))
+    (setf (query-value (slot-value se slot-name)) attr-query)))
+
+(defaction delete-search-attribute ((se search-element) slot-name)
+  (slot-makunbound se slot-name)
+  t)
+
+(defmethod render-slot ((view composite-view) (sc search-element) (slot-name (eql 'attribute-selector)))
+  (<:td :colspan 5 :align "center"
+        (render (slot-value sc slot-name))))
+
+(defmethod render-slot ((view composite-view) (sc search-element) (slot-name symbol))
+  (call-next-method)
+  (<:td :class "ucw-composite-slot-value"
+        (<ucw:a :action (delete-search-attribute sc slot-name)
+                (<:as-html "Eliminate"))))
+
+(defmethod render-slot-value-box ((view composite-view) (sc search-element) (slot search-criteria))
+  (declare (ignore view sc))
+  (<:td (render (negativep slot)))
+  (<:td (render (criteria slot)))
+  (<:td (render slot)))
addfile ./src/time-element.lisp
hunk ./src/time-element.lisp 1
+(in-package :ucw)
+
+(defvar *time-months*
+  '(("January" "Jan")
+    ("February" "Feb")
+    ("March" "Mar")
+    ("April" "Apr")
+    ("May" "May")
+    ("June" "Jun")
+    ("July" "Jul")
+    ("August" "Aug")
+    ("September" "Sep")
+    ("October" "Oct")
+    ("November" "Nov")
+    ("December" "Dec")))
+
+(defvar *time-zones*
+  (iter
+    (for i from -12 to 12 by 1/2)
+    (collect i)))
+
+(defvar *time-ampm*
+  '(am pm))
+
+(defun time-months (&optional abbrevp)
+  (let ((idx 0))
+    (mapcar #'(lambda (m)
+                (cons (incf idx) (funcall (if abbrevp #'second #'first) m)))
+            *time-months*)))
+
+(defvar *time-element-fns*
+  (flet ((init-year (time
+                     &key (year-min 1960) (year-max 2010) &allow-other-keys)
+           (setf (min-value (slot-value time 'year)) year-min
+                 (max-value (slot-value time 'year)) year-max))
+         (init-zone (time &key (zone 0) &allow-other-keys)
+           (setf (lisp-value (slot-value time 'zone)) zone))
+         (mkinit-hour (part)
+           #'(lambda (time &rest args)
+               (declare (ignore args))
+               (destructuring-bind (h24 minv maxv)
+                   (if (= 24 part) '(t 0 23) '(nil 0 12))
+                 (let ((hour (lisp-value (slot-value time 'hour)))) 
+                   (setf (slot-value time 'hour24p) h24
+                         (max-value (slot-value time 'hour)) maxv
+                         (min-value (slot-value time 'hour)) minv)
+                   (if (not h24)
+                     (setf (lisp-value (slot-value time 'hour)) (mod hour 12) ))))))
+         (set-component (slot-name &rest component-decl)
+           #'(lambda (time &rest args)
+               (let ((month (lisp-value (slot-value time 'month))))
+                 (setf (slot-value time slot-name)
+                       (apply #'make-instance (append component-decl args))
+                       (lisp-value (slot-value time 'month)) month)))))
+    (let ((ht (make-hash-table :test #'equal)))
+      ;; four-digit year
+      (setf (gethash "%Y" ht) (cons 'year #'init-year)
+            ;; full month name
+            (gethash "%b"ht)  (cons 'month (set-component 'month
+                                                          'select-element
+                                                          :options (time-months)
+                                                          :key #'car
+                                                          :output-format #'(lambda (v e) (declare (ignore e)) (cdr v))
+                                                          :default-value 1))
+            ;; abbreviated month name
+            (gethash "%B" ht) (cons 'month (set-component 'month
+                                                          'select-element
+                                                          :options (time-months t)
+                                                          :key #'car
+                                                          :output-format #'(lambda (v e) (declare (ignore e)) (cdr v))
+                                                          :default-value 1))
+            ;; two-digit month number
+            (gethash "%m" ht) (cons 'month (constantly t))
+            ;; two-digit day of the month
+            (gethash "%d" ht) (cons 'day (constantly t))
+            ;; two-digit 24-hour
+            (gethash "%H" ht) (cons 'hour (mkinit-hour 24))
+            ;; two-digit 12-hour
+            (gethash "%I" ht) (cons 'hour (mkinit-hour 12))
+            ;; two-digit minute
+            (gethash "%M" ht) (cons 'minute (constantly t))
+            ;; two-digit seconds
+            (gethash "%S" ht) (cons 'second (constantly t))
+            ;; AM or PM
+            (gethash "%p" ht) (cons 'ampm (constantly t))
+            ;; numeric time zone
+            (gethash "%Z" ht) (cons 'zone #'init-zone))
+      ht)))
+
+(defun parse-time-format (fmt)
+  (with-input-from-string (strm fmt)
+      (labels ((next-char () (read-char strm nil nil))
+               (la-char () (peek-char nil strm nil nil))
+               (next-token (chr acc)
+                 (unless chr
+                   (return-from next-token (nreverse acc)))
+                 (push
+                  (case chr
+                    (#\% (funcall
+                          (case (la-char)
+                            ((nil) (error "badly ending time format ~s" fmt))
+                            (#\% #'read-literal)
+                            (otherwise #'read-term))
+                          (next-char)))
+                    (otherwise (read-literal chr)))
+                  acc)
+                 (next-token (next-char) acc))
+               (read-term (chr)
+                 (let ((term (coerce (list #\% chr) 'string)))
+                   (if (gethash term *time-element-fns*)
+                       term
+                       (error "bad time format option ~s in ~s" term fmt))))
+               (read-literal (chr &optional acc)
+                 (push chr acc)
+                 (case (la-char)
+                   ((nil #\%) (coerce (nreverse acc) 'string))
+                   (otherwise (read-literal (next-char) acc)))))
+        (next-token (next-char) '()))))
+
+(define-ie-type (time time-element) ((ie-type interface-element))
+  ((second :component (integer-range-element
+                       :min-value 0
+                       :max-value 59
+                       :default-value 0
+                       :output-format "~2,'0d")
+           :documentation "Time seconds.")
+   (minute :component (integer-range-element
+                       :min-value 0
+                       :max-value 59
+                       :default-value 0
+                       :output-format "~2,'0d")
+           :documentation "Time minutes.")
+   (hour :component (integer-range-element
+                     :min-value 0
+                     :max-value 23
+                     :default-value 0
+                     :output-format "~2,'0d")
+         :documentation "Time hours.")
+   (day :component (integer-range-element
+                    :min-value 1
+                    :max-value 31
+                    :default-value 1
+                    :output-format "~2,'0d")
+        :documentation "Time day of the month.")
+   (month :component (integer-range-element
+                      :min-value 1
+                      :max-value 12
+                      :default-value 1
+                      :output-format "~2,'0d")
+          :documentation "Time month.")
+   (year :component (integer-range-element
+                     :min-value 1960
+                     :max-value 2010
+                     :default-value 1900
+                     :output-format "~4d")
+         :documentation "Time year.")
+   (zone :component (select-element
+                     :options *time-zones*
+                     :default-value 0
+                     :output-format
+                     #'(lambda (v e)
+                         (declare (ignore e))
+                         (multiple-value-bind (q r)
+                             (truncate v)
+                           (format nil "~3@d:~2,'0d" q (abs (* r 60))))))
+         :documentation "Time zone.")
+   (ampm :component (select-element
+                     :options *time-ampm*
+                     :default-value nil
+                     :output-format "~a")
+         :documentation "AM/PM flag.")
+   (active-slots :accessor active-slots
+                 :initarg :active-slots
+                 :initform nil
+                 :documentation "List of active slot names.")
+   (render-format :reader render-format
+                  :initform nil
+                  :documentation
+                  "List of slots and boilerplate strings for presentation.")
+   (hour24p :reader hour24p
+            :initform t
+            :documentation "Is hour in literal format."))
+  (:default-initargs
+      :output-format "%Y-%m-%d T %H:%M:%S %Z")
+  (:metaclass interface-element-class)
+  (:documentation "Time representation element.
+It accepts POSIX-style format control string as OUTPUT-FORMAT.
+Supported options:
+%Y - 4-digit year
+%B - abbreviated month name
+%b - full month name
+%m - two-digit month number
+%d -two-digit day of the month
+%H - two-digit 24-hour
+%I - two-digit 12-hour
+%M - two-digit minute
+%S - two-digit second
+%Z - time zone
+%p - AM/PM indicator."))
+
+(defmethod shared-initialize :after ((e time-element) slot-names
+                                     &key
+                                     (year-min 1960)
+                                     (year-max 2010)
+                                     (zone 0))
+  (declare (ignore slot-names))
+  (init-from-format e (slot-value e 'output-format) :year-max year-max :year-min year-min :zone zone))
+
+(defmethod init-from-format ((e time-element) (fmt string) &rest args)
+  (apply #'init-from-format e (parse-time-format fmt) args))
+
+(defmethod init-from-format ((e time-element) (fmt list) &rest args)
+  (with-slots (active-slots render-format)
+      e
+    (setf active-slots nil
+          render-format nil)
+    (iter
+      (for part in fmt)
+      (aif (gethash part *time-element-fns*)
+           (destructuring-bind (slot-name . init-fun)
+               it
+             (when (member slot-name (active-slots e))
+               (error "format part ~s for ~a doubled by one of previous parts" part slot-name))
+             (progn (apply init-fun e args)
+                    (push slot-name active-slots)
+                    (push (slot-value e slot-name) render-format)))
+           (push part render-format)))
+    (setf render-format (nreverse render-format))))
+
+(defmethod accept ((view ieview) (e time-element))
+  (render-time-parts view e))
+
+(defmethod present ((view ieview) (e time-element))
+  (when (lisp-value e)
+    (render-time-parts view e)))
+
+(defmethod render-time-parts ((view ieview) (e time-element))
+  (iter
+    (with element-class = (find-class 'interface-element))
+    (for part in (render-format e))
+    (if (subtypep (class-of part) element-class)
+        (progn
+          (setf (editablep part) (editablep e))
+          (render part))
+        (<:as-html part))))
+
+(defvar *time-element-slots*
+  '(ampm second minute hour day month year zone))
+
+(defun normalize-hour (value time ampm dir)
+
+  (when (hour24p time)
+    (return-from normalize-hour value))
+
+  (ecase dir
+    (:to-lisp
+     (ecase ampm
+       ((nil am) value)
+       (pm (mod (+ value 12) 24))))
+    (:to-client (mod value 12))))
+
+(defmethod client-value ((e time-element))
+  (mapcar #'(lambda (sn) (read-client-value (slot-value e sn)))
+          *time-element-slots*))
+
+(defmethod coerce-client-value ((e time-element) (value list))
+  (setf (nth 2 value) (normalize-hour (nth 2 value) e (car value) :to-lisp))
+  (apply #'encode-universal-time (cdr value)))
+
+(defmethod format-lisp-value ((e time-element) value)
+  (multiple-value-bind (second minute hour day month year d dlp zone)
+      (decode-universal-time (or value 0)
+                             (or (lisp-value (slot-value e 'zone))
+                                 (default-value (slot-value e 'zone))))
+    (declare (ignore d dlp))
+    (let ((ampm (if (> hour 12) 'pm 'am)))
+      (list ampm second minute hour day month year zone))))
+
+(defmethod (setf client-value) (new (e time-element))
+  (mapc #'(lambda (sn v)
+            (setf (lisp-value (slot-value e sn)) v))
+        *time-element-slots*
+        new))
addfile ./src/wall-time.lisp
hunk ./src/wall-time.lisp 1
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;;
+;;;; $Id: time.lisp 9403 2004-05-19 23:46:45Z kevin $
+;;;;
+;;;; A variety of structures and function for creating and
+;;;; manipulating dates, times, durations and intervals for
+;;;; CLSQL.
+;;;;
+;;;; This file was originally part of ODCL and is Copyright (c) 2002 -
+;;;; 2003 onShore Development, Inc.
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :it.bese.ucw)
+
+;; ------------------------------------------------------------
+;; Months
+
+(defvar *month-keywords*
+  '(:january :february :march :april :may :june :july :august :september
+    :october :november :december))
+
+(defvar *month-names*
+  '("" "January" "February" "March" "April" "May" "June" "July" "August"
+    "September" "October" "November" "December"))
+
+(defun month-name (month-index)
+  (nth month-index *month-names*))
+
+(defun ordinal-month (month-keyword)
+  "Return the zero-based month number for the given MONTH keyword."
+  (position month-keyword *month-keywords*))
+
+
+;; ------------------------------------------------------------
+;; Days
+
+(defvar *day-keywords*
+  '(:sunday :monday :tuesday :wednesday :thursday :friday :saturday))
+
+(defvar *day-names*
+  '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
+
+(defun day-name (day-index)
+  (nth day-index *day-names*))
+
+(defun ordinal-day (day-keyword)
+  "Return the zero-based day number for the given DAY keyword."
+  (position day-keyword *day-keywords*))
+
+
+;; ------------------------------------------------------------
+;; time classes: wall-time, duration
+
+(eval-when (:compile-toplevel :load-toplevel)
+
+(defstruct (wall-time (:conc-name time-)
+                      (:constructor %make-wall-time)
+                      (:print-function %print-wall-time))
+  (mjd 0 :type fixnum)
+  (second 0 :type fixnum))
+
+(defun %print-wall-time (time stream depth)
+  (declare (ignore depth))
+  (format stream "#<WALL-TIME: ~a>" (format-time nil time)))
+
+(defstruct (duration (:constructor %make-duration)
+                     (:print-function %print-duration))
+  (year 0 :type fixnum)
+  (month 0 :type fixnum)
+  (day 0 :type fixnum)
+  (hour 0 :type fixnum)
+  (second 0 :type fixnum)
+  (minute 0 :type fixnum))
+
+(defun %print-duration (duration stream depth)
+  (declare (ignore depth))
+  (format stream "#<DURATION: ~a>"
+          (format-duration nil duration :precision :second)))
+
+);eval-when
+
+(defun duration-timestring (duration)
+  (let ((second (duration-second duration))
+        (minute (duration-minute duration))
+        (hour (duration-hour duration))
+        (day (duration-day duration)))
+    (format nil "P~dD~dH~dM~dS" day hour minute second)))
+
+
+;; ------------------------------------------------------------
+;; Constructors
+
+(defun make-time (&key (year 2000 yearp) (month 1 monthp)
+		       (day 1 dayp) (hour 0 hourp)
+		       (minute 0 minutep) (second 0 secondp)
+		       (offset 0) defaults)
+  (when defaults
+    (multiple-value-bind (h min s)
+	(time-hms defaults)
+      (multiple-value-bind (y mon d)
+	  (time-ymd defaults)
+	(unless yearp (setf year y))
+	(unless monthp (setf month mon))
+	(unless dayp (setf day d))
+	(unless hourp (setf hour h))
+	(unless minutep (setf minute min))
+	(unless secondp (setf secondp s)))))
+  (let ((mjd (gregorian-to-mjd month day year))
+        (sec (+ (* hour 60 60)
+                (* minute 60)
+                second (- offset))))
+    (multiple-value-bind (day-add raw-sec)
+        (floor sec (* 60 60 24))
+      (%make-wall-time :mjd (+ mjd day-add) :second raw-sec))))
+
+(defun copy-time (time)
+  (%make-wall-time :mjd (time-mjd time)
+                   :second (time-second time)))
+
+(defun utime->time (utime)
+  "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
+  (multiple-value-bind (second minute hour day mon year)
+      (decode-universal-time utime)
+    (make-time :year year :month mon :day day :hour hour :minute minute
+               :second second)))
+
+(defun get-time ()
+  "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
+  (utime->time (get-universal-time)))
+
+(defun make-duration (&key (year 0) (month 0) (day 0) (hour 0) (minute 0)
+                           (second 0))
+  (multiple-value-bind (minute-add second-60)
+      (floor second 60)
+    (multiple-value-bind (hour-add minute-60)
+        (floor (+ minute minute-add) 60)
+      (multiple-value-bind (day-add hour-24)
+          (floor (+ hour hour-add) 24)
+        (%make-duration :year year :month month :day (+ day day-add)
+                        :hour hour-24
+                        :minute minute-60
+                        :second second-60)))))
+
+
+;; ------------------------------------------------------------
+;; Accessors
+
+(defun time-hms (time)
+  (multiple-value-bind (hourminute second)
+      (floor (time-second time) 60)
+    (multiple-value-bind (hour minute)
+        (floor hourminute 60)
+      (values hour minute second))))
+
+(defun time-ymd (time)
+  (destructuring-bind (month day year)
+      (mjd-to-gregorian (time-mjd time))
+    (values year month day)))
+
+(defun time-dow (time)
+  "Return the 0 indexed Day of the week starting with Sunday"
+  (mod (+ 3 (time-mjd time)) 7))
+
+(defun decode-time (time)
+  "returns the decoded time as multiple values: second, minute, hour, day,
+month, year, integer day-of-week"
+  (multiple-value-bind (year month day)
+      (time-ymd time)
+    (multiple-value-bind (hour minute second)
+        (time-hms time)
+      (values second minute hour day month year (mod (+ (time-mjd time) 3) 7)))))
+
+;; duration specific
+(defun duration-reduce (duration precision &optional round)
+  (ecase precision
+    (:second
+     (+ (duration-second duration)
+	(* (duration-reduce duration :minute) 60)))
+    (:minute
+     (+ (if round
+	    (floor (duration-second duration) 30)
+	    0)
+	(duration-minute duration)
+	(* (duration-reduce duration :hour) 60)))
+    (:hour
+     (+ (if round
+	    (floor (duration-minute duration) 30)
+	    0)
+	(duration-hour duration)
+	(* (duration-reduce duration :day) 24)))
+    (:day
+     (+ (if round
+	    (floor (duration-hour duration) 12)
+	    0)
+	(duration-day duration)))))
+
+
+;; ------------------------------------------------------------
+;; Arithemetic and comparators
+
+(defun duration= (duration-a duration-b)
+  (= (duration-reduce duration-a :second)
+     (duration-reduce duration-b :second)))
+
+(defun duration< (duration-a duration-b)
+  (< (duration-reduce duration-a :second)
+     (duration-reduce duration-b :second)))
+
+(defun duration<= (duration-a duration-b)
+  (<= (duration-reduce duration-a :second)
+     (duration-reduce duration-b :second)))
+							      
+(defun duration>= (x y)
+  (duration<= y x))
+
+(defun duration> (x y)
+  (duration< y x))
+
+(defun %time< (x y)
+  (let ((mjd-x (time-mjd x))
+        (mjd-y (time-mjd y)))
+    (if (/= mjd-x mjd-y)
+        (< mjd-x mjd-y)
+        (< (time-second x) (time-second y)))))
+  
+(defun %time>= (x y)
+  (if (/= (time-mjd x) (time-mjd y))
+      (>= (time-mjd x) (time-mjd y))
+      (>= (time-second x) (time-second y))))
+
+(defun %time<= (x y)
+  (if (/= (time-mjd x) (time-mjd y))
+      (<= (time-mjd x) (time-mjd y))
+      (<= (time-second x) (time-second y))))
+
+(defun %time> (x y)
+  (if (/= (time-mjd x) (time-mjd y))
+      (> (time-mjd x) (time-mjd y))
+      (> (time-second x) (time-second y))))
+
+(defun %time= (x y)
+  (and (= (time-mjd x) (time-mjd y))
+       (= (time-second x) (time-second y))))
+
+(defun time= (number &rest more-numbers)
+  "Returns T if all of its arguments are numerically equal, NIL otherwise."
+  (do ((nlist more-numbers (cdr nlist)))
+      ((atom nlist) t)
+     (declare (list nlist))
+     (if (not (%time= (car nlist) number)) (return nil))))
+
+(defun time/= (number &rest more-numbers)
+  "Returns T if no two of its arguments are numerically equal, NIL otherwise."
+  (do* ((head number (car nlist))
+	(nlist more-numbers (cdr nlist)))
+       ((atom nlist) t)
+     (declare (list nlist))
+     (unless (do* ((nl nlist (cdr nl)))
+		  ((atom nl) t)
+	       (declare (list nl))
+	       (if (%time= head (car nl)) (return nil)))
+       (return nil))))
+
+(defun time< (number &rest more-numbers)
+  "Returns T if its arguments are in strictly increasing order, NIL otherwise."
+  (do* ((n number (car nlist))
+	(nlist more-numbers (cdr nlist)))
+       ((atom nlist) t)
+     (declare (list nlist))
+     (if (not (%time< n (car nlist))) (return nil))))
+
+(defun time> (number &rest more-numbers)
+  "Returns T if its arguments are in strictly decreasing order, NIL otherwise."
+  (do* ((n number (car nlist))
+	(nlist more-numbers (cdr nlist)))
+       ((atom nlist) t)
+     (declare (list nlist))
+     (if (not (%time> n (car nlist))) (return nil))))
+
+(defun time<= (number &rest more-numbers)
+  "Returns T if arguments are in strictly non-decreasing order, NIL otherwise."
+  (do* ((n number (car nlist))
+	(nlist more-numbers (cdr nlist)))
+       ((atom nlist) t)
+     (declare (list nlist))
+     (if (not (%time<= n (car nlist))) (return nil))))
+
+(defun time>= (number &rest more-numbers)
+  "Returns T if arguments are in strictly non-increasing order, NIL otherwise."
+  (do* ((n number (car nlist))
+	(nlist more-numbers (cdr nlist)))
+       ((atom nlist) t)
+     (declare (list nlist))
+     (if (not (%time>= n (car nlist))) (return nil))))
+
+(defun time-max (number &rest more-numbers)
+  "Returns the greatest of its arguments."
+  (do ((nlist more-numbers (cdr nlist))
+       (result number))
+      ((null nlist) (return result))
+     (declare (list nlist))
+     (if (%time> (car nlist) result) (setf result (car nlist)))))
+
+(defun time-min (number &rest more-numbers)
+  "Returns the least of its arguments."
+  (do ((nlist more-numbers (cdr nlist))
+       (result number))
+      ((null nlist) (return result))
+     (declare (list nlist))
+     (if (%time< (car nlist) result) (setf result (car nlist)))))
+
+(defun time-compare (time-a time-b)
+  (let ((mjd-a (time-mjd time-a))
+        (mjd-b (time-mjd time-b))
+        (sec-a (time-second time-a))
+        (sec-b (time-second time-b)))
+    (if (= mjd-a mjd-b)
+        (if (= sec-a sec-b)
+            :equal
+            (if (< sec-a sec-b)
+                :less-than
+                :greater-than))
+        (if (< mjd-a mjd-b)
+            :less-than
+            :greater-than))))
+
+
+;; ------------------------------------------------------------
+;; Formatting and output
+
+(defvar +decimal-printer+ #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+
+(defun db-timestring (time)
+  "return the string to store the given time in the database"
+  (declare (optimize (speed 3)))
+  (let ((output (copy-seq "'XXXX-XX-XX XX:XX:XX'")))
+    (flet ((inscribe-base-10 (output offset size decimal)
+             (declare (type fixnum offset size decimal)
+                      (type (simple-vector 10) +decimal-printer+))
+             (dotimes (x size)
+               (declare (type fixnum x)
+                        (optimize (safety 0)))
+               (multiple-value-bind (next this)
+                   (floor decimal 10)
+                 (setf (aref output (+ (- size x 1) offset))
+                       (aref +decimal-printer+ this))
+                 (setf decimal next)))))
+      (multiple-value-bind (second minute hour day month year)
+          (decode-time time)
+        (inscribe-base-10 output 1 4 year)
+        (inscribe-base-10 output 6 2 month)
+        (inscribe-base-10 output 9 2 day)
+        (inscribe-base-10 output 12 2 hour)
+        (inscribe-base-10 output 15 2 minute)
+        (inscribe-base-10 output 18 2 second)
+        output))))
+
+(defun iso-timestring (time)
+  "return the string to store the given time in the database"
+  (declare (optimize (speed 3)))
+  (let ((output (copy-seq "XXXX-XX-XX XX:XX:XX")))
+    (flet ((inscribe-base-10 (output offset size decimal)
+             (declare (type fixnum offset size decimal)
+                      (type (simple-vector 10) +decimal-printer+))
+             (dotimes (x size)
+               (declare (type fixnum x)
+                        (optimize (safety 0)))
+               (multiple-value-bind (next this)
+                   (floor decimal 10)
+                 (setf (aref output (+ (- size x 1) offset))
+                       (aref +decimal-printer+ this))
+                 (setf decimal next)))))
+      (multiple-value-bind (second minute hour day month year)
+          (decode-time time)
+        (inscribe-base-10 output 0 4 year)
+        (inscribe-base-10 output 5 2 month)
+        (inscribe-base-10 output 8 2 day)
+        (inscribe-base-10 output 11 2 hour)
+        (inscribe-base-10 output 14 2 minute)
+        (inscribe-base-10 output 17 2 second)
+        output))))
+
+
+;; ------------------------------------------------------------
+;; Intervals
+
+(defstruct interval
+  (start nil)
+  (end nil)
+  (name nil) 
+  (contained nil)
+  (type nil)
+  (data nil))
+
+;; fix : should also return :contains / :contained
+
+(defun interval-relation (x y)
+  "Compare the relationship of node x to node y. Returns either
+:contained :contains :follows :overlaps or :precedes."
+  (let ((xst  (interval-start x))
+        (xend (interval-end x))
+        (yst  (interval-start y))
+        (yend (interval-end y)))
+    (case (time-compare xst yst)
+      (:equal
+       (case (time-compare xend yend)
+         (:less-than
+          :contained)
+         ((:equal :greater-than)
+          :contains)))
+      (:greater-than
+       (case (time-compare xst yend)
+         ((:equal :greater-than)
+          :follows)
+         (:less-than
+          (case (time-compare xend yend)
+            ((:less-than :equal)
+             :contained)
+            ((:greater-than)
+             :overlaps)))))
+      (:less-than
+       (case (time-compare xend yst)
+         ((:equal :less-than)
+          :precedes)
+         (:greater-than
+          (case (time-compare xend yend)
+            (:less-than
+             :overlaps)
+            ((:equal :greater-than)
+             :contains))))))))
+
+;; ------------------------------------------------------------
+;; interval lists
+
+(defun sort-interval-list (list)
+  (sort list (lambda (x y)
+	       (case (interval-relation x y)
+		 ((:precedes :contains) t)
+		 ((:follows :overlaps :contained) nil)))))
+
+;; interval push will return its list of intervals in strict order.
+(defun interval-push (interval-list interval &optional container-rule)
+  (declare (ignore container-rule))
+  (let ((sorted-list (sort-interval-list interval-list)))
+    (dotimes (x (length sorted-list))
+      (let ((elt (nth x sorted-list)))
+	(case (interval-relation elt interval)
+	  (:follows
+	   (return-from interval-push (insert-at-index x sorted-list interval)))
+	  (:contains
+	   (return-from interval-push
+	     (replace-at-index x sorted-list
+			       (make-interval :start (interval-start elt)
+					      :end (interval-end elt)
+					      :type (interval-type elt)
+					      :contained (interval-push (interval-contained elt) interval)
+					      :data (interval-data elt)))))
+	  ((:overlaps :contained)
+	   (error "Overlap")))))
+    (append sorted-list (list interval))))
+
+;; interval lists
+		  
+(defun interval-match (list time)
+  "Return the index of the first interval in list containing time"
+  ;; this depends on ordering of intervals!
+  (let ((list (sort-interval-list list))) 
+    (dotimes (x (length list))
+      (let ((elt (nth x list)))
+	(when (and (time<= (interval-start elt) time)
+		   (time< time (interval-end elt)))
+	  (return-from interval-match x))))))
+  
+(defun interval-clear (list time)
+  (dotimes (x (length list))
+    (let ((elt (nth x list)))
+      (when (and (time<= (interval-start elt) time)
+                 (time< time (interval-end elt)))
+        (if (interval-match (interval-contained elt) time)
+            (return-from interval-clear
+              (replace-at-index x list
+				(make-interval :start (interval-start elt)
+                                               :end (interval-end elt)
+                                               :type (interval-type elt)
+                                               :contained (interval-clear (interval-contained elt) time)
+                                               :data (interval-data elt))))
+            (return-from interval-clear
+              (delete-at-index x list)))))))
+
+(defun interval-edit (list time start end &optional tag)
+  "Attempts to modify the most deeply nested interval in list which
+begins at time.  If no changes are made, returns nil."
+  ;; function required sorted interval list
+  (let ((list (sort-interval-list list))) 
+    (if (null list) nil
+      (dotimes (x (length list))
+	(let ((elt (nth x list)))
+	  (when (and (time<= (interval-start elt) time)
+		     (time< time (interval-end elt)))
+	    (or (interval-edit (interval-contained elt) time start end tag)
+		(cond ((and (< 0 x)
+			    (time< start (interval-end (nth (1- x) list))))
+		       (error "Overlap of previous interval"))
+		      ((and (< x (1- (length list)))
+			    (time< (interval-start (nth (1+ x) list)) end))
+		       (error "~S ~S ~S ~S Overlap of next interval" x (length list) (interval-start (nth (1+ x) list)) end ))
+		      ((time= (interval-start elt) time)
+		       (return-from interval-edit
+			 (replace-at-index x list
+					   (make-interval :start start
+							  :end end
+							  :type (interval-type elt)
+							  :contained (restrict-intervals (interval-contained elt) start end)
+							  :data (or tag (interval-data elt))))))))))))))
+
+(defun restrict-intervals (list start end &aux newlist)
+  (let ((test-interval (make-interval :start start :end end)))
+    (dolist (elt list)
+      (when (equal :contained
+                   (interval-relation elt test-interval))
+        (push elt newlist)))
+    (nreverse newlist)))
+
+;;; utils from odcl/list.lisp
+
+(defun replace-at-index (idx list elt)
+  (cond ((= idx 0)
+         (cons elt (cdr list)))
+        ((= idx (1- (length list)))
+         (append (butlast list) (list elt)))
+        (t
+         (append (subseq list 0 idx)
+                 (list elt)
+                 (subseq list (1+ idx))))))
+
+(defun insert-at-index (idx list elt)
+  (cond ((= idx 0)
+         (cons elt list))
+        ((= idx (1- (length list)))
+         (append list (list elt)))
+        (t
+         (append (subseq list 0 idx)
+                 (list elt)
+                 (subseq list idx)))))
+
+(defun delete-at-index (idx list)
+  (cond ((= idx 0)
+         (cdr list))
+        ((= idx (1- (length list)))
+         (butlast list))
+        (t
+         (append (subseq list 0 idx)
+                 (subseq list (1+ idx))))))
+
+
+;; ------------------------------------------------------------
+;; return MJD for Gregorian date
+
+(defun gregorian-to-mjd (month day year)
+  (let ((b 0)
+        (month-adj month)
+        (year-adj (if (< year 0)
+                      (+ year 1)
+                      year))
+        d
+        c)
+    (when (< month 3)
+      (incf month-adj 12)
+      (decf year-adj))
+    (unless (or (< year 1582)
+                (and (= year 1582)
+                     (or (< month 10)
+                         (and (= month 10)
+                              (< day 15)))))
+      (let ((a (floor (/ year-adj 100))))
+        (setf b (+ (- 2 a) (floor (/ a 4))))))
+    (if (< year-adj 0)
+        (setf c (floor (- (* 365.25d0 year-adj) 679006.75d0)))
+        (setf c (floor (- (* 365.25d0 year-adj) 679006d0))))
+    (setf d (floor (* 30.6001 (+ 1 month-adj))))
+    ;; (cmsg "b ~s c ~s d ~s day ~s" b c d day)
+    (+ b c d day)))
+
+;; convert MJD to Gregorian date
+
+(defun mjd-to-gregorian (mjd)
+  (let (z r g a b c year month day)
+    (setf z (floor (+ mjd 678882)))
+    (setf r (- (+ mjd 678882) z))
+    (setf g (- z .25))
+    (setf a (floor (/ g 36524.25)))
+    (setf b (- a (floor (/ a 4))))
+    (setf year (floor (/ (+ b g) 365.25)))
+    (setf c (- (+ b z) (floor (* 365.25 year))))
+    (setf month (truncate (/ (+ (* 5 c) 456) 153)))
+    (setf day (+ (- c (truncate (/ (- (* 153 month) 457) 5))) r))
+    (when (> month 12)
+      (incf year)
+      (decf month 12))
+    (list month day year)))
+
+(defun duration+ (time &rest durations)
+  "Add each DURATION to TIME, returning a new wall-time value."
+  (let ((year   (duration-year time))
+        (month  (duration-month time))
+        (day    (duration-day time))
+        (hour   (duration-hour time))
+        (minute (duration-minute time))
+        (second (duration-second time)))
+    (dolist (duration durations)
+      (incf year    (duration-year duration))
+      (incf month   (duration-month duration))
+      (incf day     (duration-day duration))
+      (incf hour    (duration-hour duration))
+      (incf minute  (duration-minute duration))
+      (incf second  (duration-second duration)))
+    (make-duration :year year :month month :day day :hour hour :minute minute
+                   :second second)))
+
+(defun duration- (duration &rest durations)
+    "Subtract each DURATION from TIME, returning a new duration value."
+  (let ((year   (duration-year duration))
+        (month  (duration-month duration))
+        (day    (duration-day duration))
+        (hour   (duration-hour duration))
+        (minute (duration-minute duration))
+        (second (duration-second duration)))
+    (dolist (duration durations)
+      (decf year    (duration-year duration))
+      (decf month   (duration-month duration))
+      (decf day     (duration-day duration))
+      (decf hour    (duration-hour duration))
+      (decf minute  (duration-minute duration))
+      (decf second  (duration-second duration)))
+    (make-duration :year year :month month :day day :hour hour :minute minute
+                   :second second)))
+
+;; Date + Duration
+
+(defun time+ (time &rest durations)
+  "Add each DURATION to TIME, returning a new wall-time value."
+  (let ((new-time (copy-time time)))
+    (dolist (duration durations)
+      (roll new-time
+            :year (duration-year duration)
+            :month (duration-month duration)
+            :day (duration-day duration)
+            :hour (duration-hour duration)
+            :minute (duration-minute duration)
+            :second (duration-second duration)
+            :destructive t))
+    new-time))
+
+(defun time- (time &rest durations)
+  "Subtract each DURATION from TIME, returning a new wall-time value."
+  (let ((new-time (copy-time time)))
+    (dolist (duration durations)
+      (roll new-time
+            :year (- (duration-year duration))
+            :month (- (duration-month duration))
+            :day (- (duration-day duration))
+            :hour (- (duration-hour duration))
+            :minute (- (duration-minute duration))
+            :second (- (duration-second duration))
+            :destructive t))
+    new-time))
+
+(defun time-difference (time1 time2)
+  "Returns a DURATION representing the difference between TIME1 and
+TIME2."
+  (flet ((do-diff (time1 time2)
+	   
+  (let (day-diff sec-diff)
+    (setf day-diff (- (time-mjd time2)
+		      (time-mjd time1)))
+    (if (> day-diff 0)
+	(progn (decf day-diff)
+	       (setf sec-diff (+ (time-second time2)
+				 (- (* 60 60 24)
+				    (time-second time1)))))
+      (setf sec-diff (- (time-second time2)
+			(time-second time1))))
+     (make-duration :day day-diff
+                   :second sec-diff))))
+    (if (time< time1 time2)
+	(do-diff time1 time2)
+      (do-diff time2 time1))))
+
+(defun format-time (stream time &key format
+                    (date-separator "-")
+                    (time-separator ":")
+                    (internal-separator " "))
+  "produces on stream the timestring corresponding to the wall-time
+with the given options"
+  (let ((*print-circle* nil))
+    (multiple-value-bind (second minute hour day month year dow)
+	(decode-time time)
+      (case format
+	(:pretty
+	 (format stream "~A ~A, ~A ~D, ~D"
+		 (pretty-time hour minute)
+		 (day-name dow)
+		 (month-name month)
+		 day
+		 year))
+	(:short-pretty
+	 (format stream "~A, ~D/~D/~D"
+		 (pretty-time hour minute)
+		 month day year))
+	(:iso
+	 (let ((string (iso-timestring time)))
+	   (if stream
+	       (write-string string stream)
+             string)))
+        (:ymd
+         (format stream "~4,'0D-~2,'0D-~2,'0D" year month day))
+	(t
+	 (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D"
+		 year date-separator month date-separator day
+		 internal-separator hour time-separator minute time-separator
+		 second))))))
+  
+(defun pretty-time (hour minute)
+  (cond
+   ((eq hour 0)
+    (format nil "12:~2,'0D AM" minute))
+   ((eq hour 12)
+    (format nil "12:~2,'0D PM" minute))
+   ((< hour 12)
+    (format nil "~D:~2,'0D AM" hour minute))
+   ((and (> hour 12) (< hour 24))
+    (format nil "~D:~2,'0D PM" (- hour 12) minute))
+   (t
+    (error "pretty-time got bad hour"))))
+
+(defun leap-days-in-days (days)
+  ;; return the number of leap days between Mar 1 2000 and
+  ;; (Mar 1 2000) + days, where days can be negative
+  (if (< days 0)
+      (ceiling (/ (- days) (* 365 4)))
+      (floor (/ days (* 365 4)))))
+
+(defun current-year ()
+  (third (mjd-to-gregorian (time-mjd (get-time)))))
+
+(defun current-month ()
+  (second (mjd-to-gregorian (time-mjd (get-time)))))
+
+(defun current-day ()
+  (first (mjd-to-gregorian (time-mjd (get-time)))))
+
+(defun parse-date-time (string)
+  "parses date like 08/08/01, 8.8.2001, eg"
+  (when (> (length string) 1)
+    (let ((m (current-month))
+          (d (current-day))
+          (y (current-year)))
+      (let ((integers (mapcar #'parse-integer (hork-integers string))))
+        (case (length integers)
+          (1
+           (setf y (car integers)))
+          (2
+           (setf m (car integers))
+           (setf y (cadr integers)))
+          (3
+           (setf m (car integers))
+           (setf d (cadr integers))
+           (setf y (caddr integers)))
+          (t
+           (return-from parse-date-time))))
+      (when (< y 100)
+        (incf y 2000))
+      (make-time :year y :month m :day d))))
+
+(defun hork-integers (input)
+  (let ((output '())
+        (start 0))
+    (dotimes (x (length input))
+      (unless (<= 48 (char-code (aref input x)) 57)
+        (push (subseq input start x) output)
+        (setf start (1+ x))))
+    (nreverse (push (subseq input start) output))))
+    
+(defun merged-time (day time-of-day)
+  (%make-wall-time :mjd (time-mjd day)
+                   :second (time-second time-of-day)))
+
+(defun time-meridian (hours)
+  (cond ((= hours 0)
+         (values 12 "AM"))
+        ((= hours 12)
+         (values 12 "PM"))
+        ((< 12 hours)
+         (values (- hours 12) "PM"))
+        (t
+         (values hours "AM"))))
+
+(defgeneric to-string (val &rest keys)
+  )
+
+(defmethod to-string ((time wall-time) &rest keys)
+  (destructuring-bind (&key (style :daytime) &allow-other-keys)
+      keys
+    (print-date time style)))
+
+(defun print-date (time &optional (style :daytime))
+  (multiple-value-bind (second minute hour day month year dow)
+      (decode-time time)
+    (declare (ignore second))
+    (multiple-value-bind (hours meridian)
+        (time-meridian hour)
+      (ecase style
+        (:time-of-day
+         ;; 2:00 PM
+         (format nil "~d:~2,'0d ~a" hours minute meridian))
+        (:long-day
+         ;; October 11th, 2000
+         (format nil "~a ~d, ~d" (month-name month) day year))
+        (:month
+         ;; October
+         (month-name month))
+        (:month-year
+         ;; October 2000
+         (format nil "~a ~d" (month-name month) year))
+        (:full
+         ;; 11:08 AM, November 22, 2002
+         (format nil "~d:~2,'0d ~a, ~a ~d, ~d"
+                 hours minute meridian (month-name month) day year))
+        (:full+weekday
+         ;; 11:09 AM Friday, November 22, 2002
+         (format nil "~d:~2,'0d ~a ~a, ~a ~d, ~d"
+                 hours minute meridian (nth dow *day-names*)
+                 (month-name month) day year))
+        (:daytime
+         ;; 11:09 AM, 11/22/2002
+         (format-time nil time :format :short-pretty))
+        (:day
+         ;; 11/22/2002
+         (format nil "~d/~d/~d" month day year))))))
+
+(defun time-element (time element)
+  (multiple-value-bind (second minute hour day month year dow)
+      (decode-time time)
+    (ecase element
+      (:seconds
+       second)
+      (:minutes
+       minute)
+      (:hours
+       hour)
+      (:day-of-month
+       day)
+      (:integer-day-of-week
+       dow)
+      (:day-of-week
+       (nth dow *day-keywords*))
+      (:month
+       month)
+      (:year
+       year))))
+
+(defun format-duration (stream duration &key (precision :minute))
+  (let ((second (duration-second duration))
+        (minute (duration-minute duration))
+        (hour (duration-hour duration))
+        (day (duration-day duration))
+        (return (null stream))
+        (stream (or stream (make-string-output-stream))))
+    (ecase precision
+      (:day
+       (setf hour 0 second 0 minute 0))
+      (:hour
+       (setf second 0 minute 0))
+      (:minute
+       (setf second 0))
+      (:second
+       t))
+    (if (= 0 day hour minute)
+        (format stream "0 minutes")
+        (let ((sent? nil))
+          (when (< 0 day)
+            (format stream "~d day~p" day day)
+            (setf sent? t))
+          (when (< 0 hour)
+            (when sent?
+              (write-char #\Space stream))
+            (format stream "~d hour~p" hour hour)
+            (setf sent? t))
+          (when (< 0 minute)
+            (when sent?
+              (write-char #\Space stream))
+            (format stream "~d min~p" minute minute)
+            (setf sent? t))
+          (when (< 0 second)
+            (when sent?
+              (write-char #\Space stream))
+            (format stream "~d sec~p" second second))))
+    (when return
+      (get-output-stream-string stream))))
+
+(defgeneric midnight (self))
+(defmethod midnight ((self wall-time))
+  "truncate hours, minutes and seconds"
+  (%make-wall-time :mjd (time-mjd self)))
+
+(defun roll (date &key (year 0) (month 0) (day 0) (second 0) (hour 0)
+                  (minute 0) (destructive nil))
+  (unless (= 0 year month)
+    (multiple-value-bind (year-orig month-orig day-orig)
+        (time-ymd date)
+      (setf date (make-time :year (+ year year-orig)
+                            :month (+ month month-orig)
+                            :day day-orig
+                            :second (time-second date)))))
+  (let ((mjd (time-mjd date))
+        (sec (time-second date)))
+    (multiple-value-bind (mjd-new sec-new)
+        (floor (+ sec second
+                  (* 60 minute)
+                  (* 60 60 hour)) (* 60 60 24))
+      (if destructive
+          (progn
+            (setf (time-mjd date) (+ mjd mjd-new day)
+                  (time-second date) sec-new)
+            date)
+          (%make-wall-time :mjd (+ mjd mjd-new day)
+                           :second sec-new)))))
+
+(defun roll-to (date size position)
+  (ecase size
+    (:month
+     (ecase position
+       (:beginning
+        (roll date :day (+ 1
+                           (- (time-element date :day-of-month)))))
+       (:end
+        (roll date :day (+ (days-in-month (time-element date :month)
+                                          (time-element date :year))
+                           (- (time-element date :day-of-month)))))))))
+
+(defun week-containing (time)
+  (let* ((midn (midnight time))
+         (dow (time-element midn :integer-day-of-week)))
+    (list (roll midn :day (- dow))
+          (roll midn :day (- 7 dow)))))
+
+(defun leap-year? (year)
+  "t if YEAR is a leap yeap in the Gregorian calendar"
+  (and (= 0 (mod year 4))
+       (or (not (= 0 (mod year 100)))
+           (= 0 (mod year 400)))))
+
+(defun valid-month-p (month)
+  "t if MONTH exists in the Gregorian calendar"
+  (<= 1 month 12))
+
+(defun valid-gregorian-date-p (date)
+  "t if DATE (year month day) exists in the Gregorian calendar"
+  (let ((max-day (days-in-month (nth 1 date) (nth 0 date))))
+    (<= 1 (nth 2 date) max-day)))
+
+(defun days-in-month (month year &key (careful t))
+  "the number of days in MONTH of YEAR, observing Gregorian leap year
+rules"
+  (declare (type fixnum month year))
+  (when careful
+    (check-type month (satisfies valid-month-p)
+                "between 1 (January) and 12 (December)"))
+  (if (eql month 2)                     ; feb
+      (if (leap-year? year)
+          29 28)
+      (let ((even (mod (1- month) 2)))
+        (if (< month 8)                 ; aug
+            (- 31 even)
+            (+ 30 even)))))
+
+(defun day-of-year (year month day &key (careful t))
+  "the day number within the year of the date DATE.  For example,
+1987 1 1 returns 1"
+  (declare (type fixnum year month day))
+  (when careful
+    (let ((date (list year month day)))
+    (check-type date (satisfies valid-gregorian-date-p)
+                "a valid Gregorian date")))
+  (let ((doy (+ day (* 31 (1- month)))))
+    (declare (type fixnum doy))
+    (when (< 2 month)
+      (setf doy (- doy (floor (+ 23 (* 4 month)) 10)))
+      (when (leap-year? year)
+        (incf doy)))
+    doy))
+
+(defun parse-yearstring (string)
+  (let ((year (or (parse-integer-insensitively string) 
+		  (extract-roman string))))
+    (when (and year (< 1500 year 2500))
+      (make-time :year year))))
+
+(defun parse-integer-insensitively (string)
+  (let ((start (position-if #'digit-char-p string))
+        (end   (position-if #'digit-char-p string :from-end t)))
+    (when (and start end)
+      (parse-integer (subseq string start (1+ end)) :junk-allowed t))))
+
+(defvar *roman-digits*
+  '((#\M . 1000)
+    (#\D . 500)
+    (#\C . 100)
+    (#\L . 50)
+    (#\X . 10)
+    (#\V . 5)
+    (#\I . 1)))
+
+(defun extract-roman (string &aux parse)
+  (dotimes (x (length string))
+    (let ((val (cdr (assoc (aref string x) *roman-digits*))))
+      (when (and val parse (< (car parse) val))
+        (push (- (pop parse)) parse))
+      (push val parse)))
+  (apply #'+ parse))
+
+
+;; ------------------------------------------------------------
+;; Parsing iso-8601 timestrings 
+
+(define-condition iso-8601-syntax-error (error)
+  ((bad-component;; year, month whatever
+    :initarg :bad-component
+    :reader bad-component))
+  (:report (lambda (c stream)
+	     (format stream "Bad component: ~A " (bad-component c)))))
+
+(defun parse-timestring (timestring &key (start 0) end junk-allowed)
+  "parse a timestring and return the corresponding wall-time.  If the
+timestring starts with P, read a duration; otherwise read an ISO 8601
+formatted date string."
+  (declare (ignore junk-allowed))  
+  (let ((string (subseq timestring start end)))
+    (if (char= (aref string 0) #\P)
+	(parse-iso-8601-duration string)
+      (parse-iso-8601-time string))))
+
+(defvar *iso-8601-duration-delimiters*
+  '((#\D . :days)
+    (#\H . :hours)
+    (#\M . :minutes)
+    (#\S . :seconds)))
+
+(defun iso-8601-delimiter (elt)
+  (cdr (assoc elt *iso-8601-duration-delimiters*)))
+
+(defun iso-8601-duration-subseq (string start)
+  (let* ((pos (position-if #'iso-8601-delimiter string :start start))
+	 (number (when pos (parse-integer (subseq string start pos)
+                                          :junk-allowed t))))
+    (when number
+      (values number
+	      (1+ pos)
+	      (iso-8601-delimiter (aref string pos))))))
+
+(defun parse-iso-8601-duration (string)
+  "return a wall-time from a duration string"
+  (block parse
+    (let ((days 0) (secs 0) (hours 0) (minutes 0) (index 1))
+      (loop
+       (multiple-value-bind (duration next-index duration-type)
+           (iso-8601-duration-subseq string index)
+         (case duration-type
+           (:hours
+            (incf hours duration))
+           (:minutes
+            (incf minutes duration))
+           (:seconds
+            (incf secs duration))
+           (:days
+            (incf days duration))
+           (t
+            (return-from parse (make-duration :day days :hour hours
+                                              :minute minutes :second secs))))
+         (setf index next-index))))))
+
+;; e.g. 2000-11-11 00:00:00-06
+
+(defun parse-iso-8601-time (string)
+  "return the wall-time corresponding to the given ISO 8601 datestring"
+  (multiple-value-bind (year month day hour minute second offset)
+      (syntax-parse-iso-8601 string)
+    (make-time :year year
+               :month month
+               :day day
+               :hour hour
+               :minute minute
+               :second second
+               :offset offset)))
+
+
+(defun syntax-parse-iso-8601 (string)
+  (let (year month day hour minute second gmt-sec-offset)
+    (handler-case
+        (progn
+          (setf year   (parse-integer (subseq string 0 4))
+                month  (parse-integer (subseq string 5 7))
+                day    (parse-integer (subseq string 8 10))
+                hour   (if (<= 13 (length string))
+                           (parse-integer (subseq string 11 13))
+                           0)
+                minute (if (<= 16 (length string))
+                           (parse-integer (subseq string 14 16))
+                           0)
+                second (if (<= 19 (length string))
+                           (parse-integer (subseq string 17 19))
+                           0)
+                gmt-sec-offset (if (<= 22 (length string))
+                                   (* 60 60
+                                      (parse-integer (subseq string 19 22)))
+                                   0))
+          (unless (< 0 year)
+            (error 'iso-8601-syntax-error
+                   :bad-component '(year . 0)))
+          (unless (< 0 month)
+            (error 'iso-8601-syntax-error
+                   :bad-component '(month . 0)))
+          (unless (< 0 day)
+            (error 'iso-8601-syntax-error
+                   :bad-component '(month . 0)))
+          (values year month day hour minute second gmt-sec-offset))
+      (simple-error ()
+        (error 'iso-8601-syntax-error
+               :bad-component
+               (car (find-if (lambda (pair) (null (cdr pair)))
+                             `((year . ,year) (month . ,month)
+                               (day . ,day) (hour ,hour)
+                               (minute ,minute) (second ,second)
+                               (timezone ,gmt-sec-offset)))))))))
addfile ./ucw-presentations.asd
hunk ./ucw-presentations.asd 1
+;; -*- lisp -*-
+
+(defpackage :it.bese.ucw.presentations.system
+  (:use :common-lisp :asdf))
+
+(in-package :it.bese.ucw.presentations.system)
+
+(defsystem :ucw-presentations
+  :description "UCW Presentations - An advanced CRUD library for UCW"
+  :licence "BSD (sans advertising clause)"
+  :components
+  ((:module :src
+    :components ((:file "aux-slots-mixin")
+                 (:file "form" :depends-on ("widget" "ie" "indirect-value-class" "aux-slots-mixin"))
+                 (:file "ie")
+                 (:file "indirect-value-class")
+                 (:file "packages")
+                 (:file "presentations")
+                 (:file "search-criteria" :depends-on ("form" "time-element"))
+                 (:file "time-element" :depends-on ("form"))
+                 (:file "wall-time" :depends-on ("packages")))))
+  :depends-on (:ucw :iterate :parenscript :cl-ppcre))
}