[Initial commit
clinton@unknownlamer.org**20081126041306
 Imported form.lisp and portions of ucw-tags.lisp from a mixture of
 ucw_ajax and ucw_dev. Most of the code is from ucw_ajax, but none of
 this relies upon javascript and so some portions were easier to fetch
 from ucw_dev and update to work with ucw-core instead.
] adddir ./src
addfile ./src/form.lisp
hunk ./src/form.lisp 1
+;; -*- lisp -*-
+
+(in-package :ucw-forms)
+
+;;;; * UCW Web Form Library
+
+;;;; ** FORM-FIELDS
+
+;;;; Every input (or a set of inputs which correspond to one "value")
+;;;; are represented by a form-field instance.
+
+(defclass form-field ()
+  ((client-value :accessor client-value :initarg :client-value
+                 :initform ""
+                 :documentation "The string the client submitted along with this field.")
+   (validators :accessor validators :initform '() :initarg :validators
+               :documentation "List of validators which will be
+               applied to this field.")
+   (initially-validate :accessor initially-validate :initform t
+		       :initarg :initially-validate
+                       :documentation "When non-NIL the
+                       validotars will be run as soon as the page
+                       is rendered.")))
+
+(defmethod shared-initialize :after ((field form-field)
+                                     slot-names
+                                     &key (value nil value-p) &allow-other-keys)
+  (declare (ignore slot-names))
+  (when value-p
+    (setf (value field) value)))
+
+(defprint-object (field form-field)
+  (format *standard-output* "~S" (value field)))
+
+(defgeneric form-field-p (object)
+  (:method ((object form-field)) t)
+  (:method ((object t)) nil))
+
+(defgeneric value (form-field)
+  (:documentation "The lispish translated value that represents the form-field."))
+
+(defgeneric (setf value) (new-value form-field)
+  (:documentation "Set the value of a form-field with translation to client."))
+
+(defmethod value ((field form-field))
+  (let ((client-value (client-value field)))
+    (if (string= client-value "")
+        nil
+        client-value)))
+
+(defmethod (setf value) (new-value (form-field form-field))
+  (setf (client-value form-field) new-value))
+
+(defclass html-input (form-field html-element-mixin)
+  ((name :accessor name :initarg :name :initform nil)
+   (accesskey :accessor accesskey :initarg :accesskey :initform nil)
+   (tooltip :accessor tooltip :initarg :tooltip :initform nil)
+   (tabindex :accessor tabindex :initarg :tabindex :initform nil)))
+
+;;;; ** Validators
+
+(defclass validator ()
+  ((message :accessor message :initarg :message :initform nil)))
+
+(defgeneric validate (field validator)
+  (:documentation "Validate a form-field with a validator."))
+
+;;;; *** validp Top-level function to determine the validity of a form field
+(defgeneric validp (form-field)
+  (:documentation "Is a form-field valid?"))
+
+(defmethod validp ((field form-field))
+  (loop
+     for validator in (validators field)
+     when (null (validate field validator))
+       collect validator into failed-validators
+     finally (return (values (null failed-validators)
+                             failed-validators))))
+
+(defmethod validp ((component standard-component))
+  "Loops over COMPONENT's slots, checks whethere all slots which
+  contain form-field objects are valid.
+
+As second value returns list of conses (invalid-field . failed-validator)."
+  ;;summary are we valid? 
+  (flet ((do-validate-field (field)
+           "Run validators on FIELD, return list of (FIELD . VALIDATOR) conses."
+           (multiple-value-bind (validp failed) (validp field)
+             (declare (ignore validp))
+             (mapcar #'(lambda (failed) (cons field failed))
+                     failed)))
+
+         (form-fields-of (component)
+           "Return slot values of COMPONENT which are FORM-FIELDs"
+           (remove-if-not #'form-field-p
+                          (mapcar (curry #'slot-value component)
+                                  (remove-if-not #'(lambda (name) (slot-boundp component name))
+                                                 (mapcar #'mopp:slot-definition-name
+                                                         (mopp:class-slots (class-of component))))))))
+    (let ((failed (apply #'nconc
+                         (mapcar #'do-validate-field
+                                 (form-fields-of component)))))
+      (values (null failed) failed))))
+
+;;;; ** Standard Form Validators
+
+;;;; *** not empty
+
+(defclass not-empty-validator (validator)
+  ())
+
+(defmethod validate ((field form-field) (validator not-empty-validator))
+  (and (client-value field)
+       (not (string= "" (client-value field)))))
+
+;;;; *** Value-validators
+
+;;;; These are validators that should only be run if there is actually
+;;;; a value to test.
+
+(defclass value-validator (validator)
+  ()
+  (:documentation "Validators that should only be applied if there is a value.
+That is, they always succeed on nil."))
+
+(defmethod validate :around ((field form-field) (validator value-validator))
+  "Value validators should only be checked if they are not null or empty-strings."
+  (or (null (client-value field))
+      (= 0 (length (string-trim '(#\Space #\Tab) (client-value field))))
+      (call-next-method)))
+
+;;;; *** length
+
+(defclass length-validator (value-validator)
+  ((min-length :accessor min-length :initarg :min-length
+               :initform nil)
+   (max-length :accessor max-length :initarg :max-length
+               :initform nil)))
+
+(defmethod initialize-instance :after ((self length-validator) &key length min-length max-length)
+  (assert (or (null length)
+              (and (null min-length)
+                   (null max-length))))
+  (setf (min-length self) length)
+  (setf (max-length self) length))
+
+(defmethod validate ((field form-field) (validator length-validator))
+  (with-slots (min-length max-length)
+      validator
+    (let ((length (length (client-value field))))
+      (cond
+        ((and min-length max-length)
+         (<= min-length length max-length))
+        (min-length
+         (<= min-length length))
+        (max-length
+         (<= length max-length))
+        (t t)))))
+
+;;;; *** same (string=) value
+
+(defclass string=-validator (validator)
+  ((other-field :accessor other-field :initarg :other-field))
+  (:documentation "Ensures that a field is string= to another one."))
+
+(defmethod validate ((field form-field) (validator string=-validator))
+  (let ((value (value field))
+        (other-value (value (other-field validator))))
+    (string= value other-value)))
+
+;;;; Regular expression validator.
+
+(defclass regex-validator (value-validator)
+  ((regex :accessor regex :initarg :regex :initform nil)))
+
+(defmethod validate ((field form-field) (validator regex-validator))
+  (let ((val (string-trim '(#\Space #\Tab) (value field)))
+        (regex (regex validator)))
+    (or (null regex)
+        (cl-ppcre:scan regex val))))
+
+;;;; *** simple e-mail address check.
+
+(defclass e-mail-address-validator (regex-validator)
+  ()
+  (:default-initargs
+   :regex "^([a-zA-Z0-9_\\.\\-\\%])+\\@([a-zA-Z0-9][a-zA-Z0-9\\-]*\\.)+([a-zA-Z0-9]{2,4})\\.?$"))
+
+(defclass hostname-validator (regex-validator)
+  ()
+  (:default-initargs
+   :regex "^([a-zA-Z0-9][a-zA-Z0-9\\-]*\\.)+([a-zA-Z0-9]{2,4})\\.?$"))
+
+(defclass phone-number-validator (regex-validator)
+  ()
+  (:default-initargs
+   :regex "^((\\+\\d{1,3}(-| |\\.)?\\(?\\d\\)?(-| |\\.)?\\d{1,3})|(\\(?\\d{2,3}\\)?))(-| |\\.)?(\\d{3,4})(-| |\\.)?(\\d{4})(( x| ext)\\d{1,5}){0,1}$" ))
+
+;;;; ** Form Inputs
+
+;;;; *** Textarea inputs
+
+(defclass textarea-field (html-input)
+  ((rows :accessor rows :initarg :rows :initform nil)
+   (cols :accessor cols :initarg :cols :initform nil)
+   (wrap :accessor wrap :initarg :wrap :initform nil)))
+
+(defmethod render ((field textarea-field))
+  (<ucw:textarea :id (html-element.dom-id field)
+                 :name (name field)
+                 :accessor (client-value field)
+                 :rows (rows field)
+                 :cols (cols field)
+                 :title (tooltip field)
+                 :tabindex (tabindex field)
+                 :class (html-element.css-class field)
+                 :style (html-element.css-style field)
+                 :wrap (wrap field)))
+
+;;;; *** Strings
+
+(defclass string-field (html-input)
+  ((input-size :accessor input-size
+               :initarg :input-size
+               :initform nil)
+   (maxlength :accessor maxlength
+              :initarg :maxlength
+              :initform nil)))
+
+(defmethod render ((field string-field))
+  (<ucw:text :name (name field)
+             :id (html-element.dom-id field)
+             :accesskey (accesskey field)
+             :accessor (client-value field)
+             :title (tooltip field)
+             :tabindex (tabindex field)
+             :size (input-size field)
+             :maxlength (maxlength field)
+             :class (html-element.css-class field)
+             :style (html-element.css-style field)))
+
+;;;; **** Hidden Strings (passwords)
+
+(defclass password-field (string-field)
+  ())
+
+(defmethod render ((field password-field))
+  (<ucw:password :name (name field)
+                 :id (html-element.dom-id field)
+                 :accesskey (accesskey field)
+                 :accessor (client-value field)
+                 :size (input-size field)
+                 :title (tooltip field)
+                 :tabindex (tabindex field)
+                 :class (html-element.css-class field)
+                 :style (html-element.css-style field)))
+
+;;;; *** Hidden field
+
+(defclass hidden-field (html-input)
+  ()
+  (:documentation "A widget representing a hidden input field."))
+
+(defmethod render ((field hidden-field))
+  (<ucw:input :id (html-element.dom-id field)
+              :type "hidden"
+              :name (name field)
+              :accessor (client-value field)
+              :title (tooltip field)
+              :tabindex (tabindex field)
+              :class (html-element.css-class field)
+              :style (html-element.css-style field)))
+
+;;;; *** Numbers
+
+(defclass number-field (string-field)
+  ())
+
+(defmethod (setf value) (new-value (field number-field))
+  (let ((*print-radix* nil)
+        (*print-base* 10))
+    (setf (client-value field) (when new-value
+                                 (format nil (if (integerp new-value) "~d" "~f") new-value)))))
+
+(defmethod initialize-instance :after ((field number-field) &key)
+  (push (make-instance 'is-a-number-validator)
+        (validators field)))
+
+;; KLUDGE this is, well, ...
+(defun read-number (str)
+  "Read a string from an untrusted source (don't eval anything)."
+  (let ((*read-eval* nil)
+        ;; avoid interning into random packages
+        (*package* (make-package (gensym))))
+    (unwind-protect
+         (multiple-value-bind (value position)
+             (read-from-string str)
+           (when (numberp value)
+             (values value position)))
+      (delete-package *package*))))
+
+(defmethod value ((field number-field) )
+  (if (= 0 (length (client-value field)))
+      nil
+      (read-number (client-value field))))
+
+(defclass is-a-number-validator (value-validator)
+  ())
+
+(defmethod validate ((field number-field) (validator is-a-number-validator))
+  (let ((in-len (length (client-value field))))
+    (multiple-value-bind (num len)
+        (read-number (client-value field))
+      (declare (ignore num))
+      (= len in-len))))
+
+(defclass value-range-validator (value-validator)
+  ((min-value :accessor min-value :initarg :min-value :initform nil)
+   (max-value :accessor max-value :initarg :max-value :initform nil)))
+
+(defclass number-range-validator (value-range-validator is-a-number-validator)
+  ())
+
+(defmethod validate ((field number-field) (validator number-range-validator))
+  (with-slots (min-value max-value)
+      validator
+    ;; we shouldn't try to see if it is in a numerical range if it
+    ;; isn't a number.
+    (and (call-next-method) ;; should be is-a-number-validator
+         (<= (or min-value (1- (value field)))
+             (value field)
+             (or max-value (1+ (value field)))))))
+
+;;;; *** Integers
+
+(defclass integer-field (number-field)
+  ())
+
+(defmethod initialize-instance :after ((field integer-field) &key validators)
+  (setf (validators field) (cons (make-instance 'is-an-integer-validator) validators)))
+
+(defmethod value ((field integer-field))
+  (parse-integer (client-value field) :junk-allowed t))
+
+(defclass is-an-integer-validator (is-a-number-validator)
+  ())
+
+(defmethod validate ((field integer-field) (validator is-an-integer-validator))
+  (let ((in-len (length (client-value field))))
+    (multiple-value-bind (num len)
+        (parse-integer (client-value field) :junk-allowed t)
+      (and (= len in-len)
+           (integerp num)))))
+
+;;;; *** Ranges
+
+(defclass range-field (html-input)
+  ((min-field :accessor min-field-of)
+   (max-field :accessor max-field-of)
+   (separator :accessor separator-of :initarg :separator :initform " ... ")))
+
+(defmethod render ((self range-field))
+  (<:table
+      (<:tr (<:td (render (min-field-of self)))
+            (<:td (etypecase (separator-of self)
+                    (string (<:as-html (separator-of self)))
+                    (component (render (separator-of self)))))
+            (<:td (render (max-field-of self))))))
+
+(defmethod initialize-instance :after ((self range-field) &key field-type)
+  (setf (min-field-of self) (make-instance field-type))
+  (setf (max-field-of self) (make-instance field-type)))
+
+(defmethod value ((self range-field))
+  (cons (value (min-field-of self)) (value (max-field-of self))))
+
+;;;; *** Dates
+
+(defclass universal-time-based-date-field ()
+  ()
+  (:documentation "A date field that communicates with universal time (as in CLHS) through the value and (setf value) methods."))
+
+;; (defclass local-time-based-date-field (form-field)
+;;   ()
+;;   (:documentation "A date field that accepts/provides local-time objects through the value and (setf value) methods."))
+
+;; (defmethod (setf value) ((utime integer) (self local-time-based-date-field))
+;;   (setf (value self) (local-time :universal utime)))
+
+(defclass date-field (universal-time-based-date-field form-field
+		     html-block-element-mixin)
+  ((year :accessor year :initform (make-instance 'integer-field
+                                                 :input-size 4
+                                                 :validators (list
+                                                              (make-instance 'number-range-validator
+                                                                             :min-value 0
+                                                                             :max-value nil))))
+   (month :accessor month :initform (make-instance 'integer-field
+                                                   :input-size 2
+                                                   :validators (list (make-instance 'number-range-validator
+                                                                                    :min-value 0
+                                                                                    :max-value 12))))
+   (day :accessor day :initform (make-instance 'integer-field
+                                               :input-size 2
+                                               :validators (list (make-instance 'number-range-validator
+                                                                                :min-value 0
+                                                                                :max-value 31)))))
+  (:default-initargs :dom-id (unique-dom-id :prefix "_dfld")))
+
+(defmethod date-ymd ((field date-field))
+  (values (value (year field))
+          (value (month field))
+          (value (day field))))
+
+(defmethod value ((field date-field))
+  (multiple-value-bind (year month day)
+      (date-ymd field)
+    (if (and year month day)
+        (encode-universal-time 0 0 0 day month year)
+        nil)))
+
+(defmethod (setf value) ((utime integer) (field date-field))
+  (multiple-value-bind (second minute hour date month year day-of-week daylight-p zone)
+      (decode-universal-time utime 0)
+    (declare (ignore second minute hour day-of-week daylight-p zone))
+    (setf (year field) year)
+    (setf (month field) month)
+    (setf (day field) date)))
+
+(defclass dmy-date-field (date-field)
+  ()
+  (:documentation "Date fields which orders the inputs day/month/year"))
+
+(defmethod render ((field dmy-date-field))
+  (render (day field))
+  (<:as-html "/")
+  (render (month field))
+  (<:as-html "/")
+  (render (year field)))
+
+(defclass mdy-date-field (date-field)
+  ()
+  (:documentation "Date field which orders the inputs month/day/year"))
+
+(defmethod render ((field mdy-date-field))
+  (render (month field))
+  (<:as-html "/")
+  (render (day field))
+  (<:as-html "/")
+  (render (year field)))
+
+(defclass is-a-date-validator (value-validator)
+  ())
+
+(defmethod validate ((field universal-time-based-date-field) (validator is-a-date-validator))
+  (integerp (value field)))
+
+;; (defmethod validate ((field local-time-based-date-field) (validator is-a-date-validator))
+;;   (typep (value field) 'local-time))
+
+(defclass is-a-date-time-validator (is-a-date-validator)
+  ())
+
+(defclass time-range-validator (is-a-date-time-validator value-range-validator)
+  ())
+
+(defmethod validate ((field universal-time-based-date-field) (validator time-range-validator))
+  (let ((min-value (min-value validator))
+        (max-value (max-value validator)))
+    (and (call-next-method)
+         (<= (or min-value (1- (value field)))
+             (value field)
+             (or max-value (1+ (value field)))))))
+
+;; (defmethod validate ((field local-time-based-date-field) (validator time-range-validator))
+;;   (let ((min-value (min-value validator))
+;;         (max-value (max-value validator))
+;;         (value (value field)))
+;;     (and (call-next-method)
+;;          (or (not min-value) (local-time<= min-value value))
+;;          (or (not max-value) (local-time<= value max-value)))))
+
+;;;; *** Select input fields
+
+;;;; We generate lots of strings which are used as the values in
+;;;; option tags, this variable, and the integer-to-string function,
+;;;; prevent generating large amounts of throw away strings.
+
+#+allegro ;; TODO: Fixes a bug in allegro, remove later when Franz has sorted this out
+(excl:without-package-locks 
+  (defun common-lisp:map-into (result-sequence function &rest sequences)
+   (loop for index below (apply #'min 
+                                (length result-sequence)
+                                (mapcar #'length sequences))
+         do (setf (elt result-sequence index)
+                  (apply function
+                         (mapcar #'(lambda (seq) (elt seq index))
+                                 sequences))))
+   result-sequence))
+
+(defvar +string-index-cache+
+  (map-into (make-array 50
+                        :element-type 'string
+                        :adjustable t)
+            (let ((i -1))
+              (lambda ()
+                (princ-to-string (incf i))))))
+
+(defun integer-to-string (i)
+  (cond
+    ((<= (length +string-index-cache+) i)
+     (adjust-array +string-index-cache+ (1+ i))
+     (setf (aref +string-index-cache+ i) (princ-to-string i)))
+    ((null (aref +string-index-cache+ i))
+     (setf (aref +string-index-cache+ i) (princ-to-string i)))
+    (t
+     (aref +string-index-cache+ i))))
+
+(defclass select-field (html-input)
+  ((data-set :accessor data-set :initarg :data-set
+             :documentation "The values this select chooses
+             from.")
+   (test-fn :accessor test-fn :initarg :test-fn)
+   (data-map :accessor data-map :initform '()
+             :documentation "An alist mapping strings, used in
+   the <:select's options, to field specific values in the data-set.
+   This is an internal field which should only be accessed by render
+   and value methods."))
+  (:default-initargs :test-fn #'string=)
+  (:documentation "Form field used for selecting one value from a
+  list of available options."))
+
+(defmethod value ((field select-field))
+  (cdr (assoc (client-value field) (data-map field) :test #'string=)))
+
+(defmethod (setf value) (new-value (field select-field))
+  (unless (data-map field)
+    (setf (data-map field) (build-data-map field)))
+  (dolist* ((client-key . value) (data-map field))
+    (when (test-select-field-value field new-value value)
+      (setf (client-value field) client-key)
+      (return-from value new-value)))
+  new-value)
+
+(defgeneric test-select-field-value (field new-value value)
+  (:method ((field select-field) new-value value)
+           (funcall (test-fn field) new-value value)))
+
+(defgeneric build-data-map (field)
+  (:documentation "Given FIELD's data-set returns an alist
+  mapping strings to the values in FIELD's data-set. Each key in
+  the returned alist must be unique."))
+
+(defmethod build-data-map ((field select-field))
+  (loop
+     for value in (data-set field)
+     for index upfrom 0
+     collect (cons (integer-to-string index) value)))
+
+(defmethod render ((field select-field))
+  (<ucw:simple-select
+   :accessor (client-value field)
+   :title (tooltip field)
+   :id (html-element.dom-id field)
+   :accesskey (accesskey field)
+   :tabindex (tabindex field)
+   :class (html-element.css-class field)
+   :style (html-element.css-style field)
+   (setf (data-map field) (build-data-map field))
+   (render-options field)))
+
+(defgeneric render-options (select-field)
+  (:documentation "Function used to render the list of options of
+  a select field. Methods are always called AFTER the data-map
+  has been setup."))
+
+(defmethod render-options ((field select-field))
+  (dolist* ((key-string . value) (data-map field))
+    (<:option :value key-string
+              :selected  (string= (client-value field) key-string)
+      (render-value field value))))
+
+(defgeneric render-value (select-field value)
+  (:documentation "This function will be passed each value in the field's
+   data-set and must produce the body of the corresponding
+   <:option tag."))
+
+(defmethod render-value ((field select-field) (value null))
+  ;; often you need a select-field that has a "nothing selected" element.
+  ;; for convenience nil values are rendered as an empty element
+  )
+
+(defmethod render-value ((field select-field) (value t))
+  "This default method just wraps princ-to-string in a <:as-html."
+  (<:as-html value))
+
+;;;; **** selecting from mappings
+
+;;;; It often happens that you want to select a value based on the
+;;;; corresponding key.
+
+(defclass mapping-select-field (select-field)
+  ()
+  (:documentation "Class used when we want to chose the values of
+  a certain mapping based on the keys. We render the keys in the
+  select and return the corresponding value from the VALUE
+  method."))
+
+(defmethod render-options ((field mapping-select-field))
+  (dolist* ((key-string . key) (data-map field))
+    (<:option :value key-string
+              :selected  (string= (client-value field) key-string)
+              (render-key field key))))
+
+(defgeneric render-key (field key)
+  (:method ((field mapping-select-field) (key t))
+    (<:as-html key)))
+
+(defclass hash-table-select-field (mapping-select-field)
+  ())
+
+(defmethod build-data-map ((field hash-table-select-field))
+  (loop
+     for key being the hash-keys of (data-set field)
+     for index upfrom 0
+     collect (cons (integer-to-string index) key)))
+
+(defmethod value ((field hash-table-select-field))
+  (gethash (call-next-method) (data-set field)))
+
+(defclass alist-select-field (mapping-select-field)
+  ()
+  (:default-initargs :test-fn #'eql)
+  (:documentation "Renders an alist of (key . value)'s so that
+VALUE's are displayed <:as-html and KEY's are returned by the VALUE accessor."))
+
+(defmethod build-data-map ((field alist-select-field))
+  (iter (for entry in (data-set field))
+        (for index upfrom 0)
+        (collect (cons (integer-to-string index) entry))))
+
+(defmethod test-select-field-value ((field alist-select-field) new-value value)
+  (funcall (test-fn field) new-value (car value)))
+
+(defmethod render-key ((field alist-select-field) entry)
+  (<:as-html (cdr entry)))
+
+(defmethod value ((field alist-select-field))
+  (car (call-next-method)))
+
+(defclass plist-select-field (mapping-select-field)
+  ()
+  (:default-initargs :test-fn #'eql)
+  (:documentation "Renders a plist of (indicator1 value1 ...) so that
+VALUE's are displayed <:as-html and INDICATOR's are returned by the value accessor."))
+
+(defmethod build-data-map ((field plist-select-field))
+  (loop
+     for (key value) on (data-set field) by #'cddr
+     for index upfrom 0
+     collect (cons (integer-to-string index) (cons key value))))
+
+(defmethod test-select-field-value ((field plist-select-field) new-value value)
+  (funcall (test-fn field) new-value (car value)))
+
+(defmethod render-key ((field plist-select-field) entry)
+  (<:as-html (cdr entry)))
+
+(defmethod value ((field plist-select-field))
+  (car (call-next-method)))
+
+;;;; *** Radio Buttons 
+
+(defclass radio-group (html-input)
+  ((value-widgets :accessor value-widgets :initform '()))
+  (:default-initargs  
+   ;; XXX: this is really really bad. there's no guarntee that we
+   ;; don't already have a callback with this name :(
+   :name (strcat "_r_" (random-string 10))))
+
+(defmethod value ((group radio-group))
+  (let ((index (parse-integer (client-value group) :junk-allowed t)))    
+    (when index
+      (value (nth index (value-widgets group))))))
+
+(defmethod (setf value) (value (group radio-group))
+  (setf (client-value group)
+        (format nil "~D" (position value (value-widgets group) :key #'value :test #'eq))))
+
+(defmethod shared-initialize :after ((group radio-group)
+                                     slot-names
+                                     &key (values nil values-p)
+                                          (value nil value-p)
+                                     &allow-other-keys)
+  (declare (ignore slot-names))
+  (when values-p
+    (setf (value-widgets group) '())
+    (map nil (curry #'add-value group) values)
+    (when value-p
+      (setf (value group) value))))
+
+(defmethod add-value ((group radio-group) value)
+  (push (make-instance 'radio-button
+                       :value value
+                       :group group)
+        (value-widgets group))
+  value)
+
+(defmethod value-widget ((group radio-group) value)
+  "Returns the widget associated with the value VALUE in GROUP."
+  (find value (value-widgets group) :test #'eq :key #'value))
+
+(defclass radio-button (html-input)
+  ((value :accessor value :initarg :value)
+   (group :accessor group :initarg :group
+          :documentation "The RADIO-GROUP this button is a part
+          of."))
+  (:documentation "A widget representing a single radio
+  button. Should be used in conjunction with a RADIO-GROUP."))
+
+(defmethod render ((button radio-button))
+  (register-callback (lambda (value)
+                       (setf (client-value (group button)) value))
+                     :id (name (group button)))
+  (<:input :id (html-element.dom-id button)
+           :accesskey (accesskey button)
+           :title (tooltip button)
+           :tabindex (tabindex button)
+           :type "radio"
+           :name (name (group button))
+           :value (format nil "~D" (position button (value-widgets (group button))))
+           :checked (eq (value (group button)) (value button))
+           :class (html-element.css-class button)
+           :style (html-element.css-style button)))
+
+(defprint-object (button radio-button)
+  (format *standard-output* "VALUE: ~S GROUP: ~S" (value button) (group button)))
+
+;;;; *** Check box
+
+(defclass checkbox-field (html-input)
+  (
+   (enabled-tooltip :initform nil :accessor enabled-tooltip-of :initarg :enabled-tooltip)
+   (disabled-tooltip :initform nil :accessor disabled-tooltip-of :initarg :disabled-tooltip))
+  (:default-initargs :client-value nil))
+
+(defmethod initialize-instance :after ((self checkbox-field) &key)
+  (setf (html-element.css-class self) (strcat (html-element.css-class self) " ucw-checkbox")))
+
+(defgeneric hidden-id (checkbox-field)
+  (:method ((self checkbox-field))
+           (strcat (html-element.dom-id self) "-hidden")))
+
+(defmethod rendered-form-fields ((self checkbox-field))
+  (list (hidden-id self)))
+
+(defmethod render ((field checkbox-field))
+  (let* ((value (value field))
+	 (dom-id (html-element.dom-id field))
+         (hidden-id (hidden-id field)))
+    (<ucw:input
+     :id hidden-id
+     :reader (when value
+               "on")
+     :writer (lambda (v)
+               (setf (value field) (and (not (null v))
+                                        (not (string= "" v)))))
+     :type "hidden")
+    (<:input
+     :id dom-id
+     :checked (if value t nil)
+     :name (name field)
+     :accesskey (accesskey field)
+     :title (or (tooltip field) (if value
+				    (enabled-tooltip-of field)
+				    (disabled-tooltip-of field)))
+     :tabindex (tabindex field)
+     :class (html-element.css-class field)
+     :style (html-element.css-style field)
+     :type "checkbox")))
+
+(defmethod value ((field checkbox-field))
+  (if (and (client-value field)
+           (not (string= "" (client-value field))))
+      t
+      nil))
+
+(defmethod (setf value) (new-value (field checkbox-field))
+  (setf (client-value field) (if new-value
+                                 t
+                                 nil)))
+
+;;;; *** Upload
+
+(defclass file-upload-field (html-input)
+  ())
+
+(defmethod render ((field file-upload-field))
+  (<ucw:input :id (html-element.dom-id field)
+              :name (name field)
+              :accesskey (accesskey field)
+              :type "file"
+              :title (tooltip field)
+              :tabindex (tabindex field)
+              :accessor (client-value field)
+              :class (html-element.css-class field)
+              :style (html-element.css-style field)))
+
+(defmethod value ((field file-upload-field))
+  (client-value field))
+
+;;;; *** Submit Button
+
+(defclass submit-button (html-input)
+  ((label :accessor label :initform nil :initarg :label)))
+
+(defmethod render ((field submit-button))
+  (<:submit :id (html-element.dom-id field)
+	    :accesskey (accesskey field)
+	    :title (tooltip field)
+	    :tabindex (tabindex field)
+	    :value (label field)
+	    :class (html-element.css-class field)
+	    :style (html-element.css-style field)))
+
+(defcomponent form-component-mixin (html-element-mixin)
+  ((submit-method :initform "post"
+                  :accessor submit-method-of
+                  :initarg :submit-method)
+   (encoding-type :initform nil
+                  :accessor encoding-type-of
+                  :initarg :encoding-type))
+  (:default-initargs :dom-id (unique-dom-id :prefix "form"))
+  (:documentation "A component mixin that makes sure its body is
+  rendered inside a HTML form tag."))
+
+(defmethod render :wrap-around ((self form-component-mixin))
+  (<ucw:simple-form
+   :class (html-element.css-class self)
+   :style (html-element.css-style self)
+   :method (submit-method-of self)
+   :enctype (encoding-type-of self)
+   :action (refresh-component self)
+   (call-next-method)))
+
+;; Copyright (c) 2003-2005 Edward Marco Baringer
+;; Copyright (c) 2008 Clinton Ebadi
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;; 
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
addfile ./src/js.lisp
hunk ./src/js.lisp 1
-
+;; input classes had dom-ids
+(defgeneric rendered-form-fields (field)
+  (:method ((self generic-html-input))
+           (list (dom-id self))))
+
+(defmethod render :after ((field generic-html-input))
+  (<ucw:script :toplevelp t
+               `(on-load
+                 (ucw.field.register ,(current-form-id)
+                                     (array ,@(rendered-form-fields field))
+                                     ,(dirty-p-checker field)
+                                     ,(when (validators field)
+                                            `(macrolet ((fail ()
+                                                          `(return false)))
+                                               (lambda (value)
+                                                 ,@(iter (for validator in (validators field))
+                                                         (collect (javascript-check field validator)))
+                                                 (return true))))
+                                     ,(initially-validate field))
+                 ,@(iter (for validator :in (validators field))
+                         (awhen (javascript-init field validator)
+                           ;; seal them just to be sure that they don't capture each other's variables
+                           (collect `((lambda ()
+                                        ,it))))))))
+
+;;;; *** javascript-check
+
+;;;; This pair of generic functions generate the javascript code for
+;;;; checking whether the current value of a field is valid or
+;;;; not. The top-level function is generate-javascript-check, 
+
+(defgeneric javascript-check (field validator)
+  (:documentation "Generate javascript code for checking FIELD against VALIDATOR.
+
+This is the convenience entry point to generate-javascript-check,
+methods defined on this generic funcition should return a list of
+javascript code (as per parenscript) which tests against the
+bound javascript variable VALUE. When something is not valid
+(fail) should be called (which is bound by a local macrolet)"))
+
+(defmethod javascript-check ((field form-field) (validator validator))
+  (values))
+
+(defgeneric javascript-init (field validator)
+  (:documentation "Validators may return some initialization code here.")
+  (:method ((field form-field) (validator validator))
+           nil))
+
+(defmethod javascript-check ((field form-field) (validator not-empty-validator))
+  `(unless value ; this is true for both null and "" in js
+    (fail)))
+
+(defmethod javascript-check :around ((field form-field) (validator value-validator))
+  "Value validators should only be checked if they are not null or empty-strings,
+javascript if's should take care of that."
+  `(when value
+    ,(call-next-method)))
+
+(defmethod javascript-check ((field form-field) (validator length-validator))
+  (with-slots (min-length max-length)
+      validator
+    (cond
+      ((and min-length max-length)
+       `(unless (and (<= ,min-length value.length)
+                     (<= value.length ,max-length))
+         (fail)))
+      (min-length
+       `(unless (<= ,min-length value.length)
+         (fail)))
+      (max-length
+       `(unless (<= value.length ,max-length)
+         (fail)))
+      (t t))))
+
+(defmethod javascript-init ((field form-field) (validator string=-validator))
+  `(let ((field ($ ,(dom-id field)))
+         (other-field ($ ,(dom-id (other-field validator)))))
+      (ucw.event.connect other-field (list "onchange" "onkeyup")
+                         (lambda ()
+                           (.ucw-validate field)))))
+
+(defmethod javascript-check ((field form-field) (validator string=-validator))
+  `(unless (= (slot-value ($ ,(dom-id field)) 'value)
+              (slot-value ($ ,(dom-id (other-field validator))) 'value))
+    (fail)))
+
+(defmethod javascript-check ((field form-field) (validator regex-validator))
+  `(unless (.match value (regex ,(regex validator)))
+    (fail)))
+
+(defmethod javascript-check ((field number-field) (validator is-a-number-validator))
+  `(unless (ucw.field.is-number value)
+    (fail)))
+
+(defmethod javascript-check ((field number-field) (validator number-range-validator))
+  (with-slots (min-value max-value) validator
+    `(progn
+      ,(call-next-method)
+      (unless ,(cond
+                ((and min-value max-value)
+                 `(and (<= ,min-value value) (<= value ,max-value)))
+                (min-value `(<= ,min-value value))
+                (max-value `(<= ,max-value value))
+                (t t))
+        (fail)))))
+
+
+(defmethod javascript-check ((field integer-field) (validator is-an-integer-validator))
+  `(unless (and (not (is-na-n value))
+                (>= 1 (slot-value (.split value ".") 'length)))
+    (fail)))
+
+(defmethod render :after ((field date-field))
+  (<ucw:script
+   `(on-load
+     ;; this is not essential, because the subfields have their own
+     ;; dirty chackers but may come handy as an API for other scripts
+     (setf (slot-value ($ ,(dom-id field)) 'ucw-dirty-p)
+           (lambda ()
+             (log.debug "Checking dirtyness of date-field " ,(dom-id field))
+             (dolist (subnode (map dojo.by-id (array ,@(mapcar #'dom-id (list (day field) (month field) (year field))))))
+               (when subnode
+                 (log.debug "Checking subnode " subnode.id)
+                 (when (.ucw-dirty-p subnode)
+                   (return true))))
+             (return false))))))
+
+
+(defmethod rendered-form-fields ((self range-field))
+  (append (rendered-form-fields (min-field-of self))
+          (rendered-form-fields (max-field-of self))))
addfile ./src/package.lisp
hunk ./src/package.lisp 1
-
+(defpackage :ucw-forms
+  (:use :cl :arnesi :ucw-core :ucw :iterate)
+  (:shadowing-import-from :ucw-core :parent)
+  (:export
+      ;; forms
+   #:form-field
+   #:value
+   #:client-value
+   #:tabindex
+
+   #:form-component-mixin
+
+   #:string-field
+   #:textarea-field
+   #:number-field
+   #:integer-field
+   #:range-field
+   #:password-field
+   #:checkbox-field
+   #:file-upload-field
+   #:select-field
+   #:mapping-select-field
+   #:alist-select-field
+   #:hash-table-select-field
+   #:plist-select-field
+   #:submit-button
+   #:radio-group
+   #:value-widget
+   #:date-field
+   #:date-ymd
+   #:is-a-date-validator
+   #:is-a-date-time-validator
+   #:time-range-validator
+   #:dmy-date-field
+   #:mdy-date-field
+   #:hidden-field
+
+   #:validator
+   #:validators
+   #:validate
+   #:message
+   #:validp
+   #:is-an-integer-validator
+   #:number-range-validator  
+   #:length-validator
+   #:min-length
+   #:max-length
+   #:not-empty-validator
+   #:string=-validator
+   #:integer-range-validator
+   #:regex-validator
+   #:regex
+   #:hostname-validator
+   #:e-mail-address-validator
+   #:phone-number-validator))
+
+(defpackage :ucw-forms-tags
+  (:use :cl :ucw-core :ucw-standard :yaclml)
+  (:import-from :arnesi :rebinding :when-bind :with-call/cc :with-unique-names))
addfile ./src/tags.lisp
hunk ./src/tags.lisp 1
+(in-package :ucw-forms-tags)
+
+(deftag-macro <ucw::textarea (&attribute accessor reader writer name
+			      &allow-other-attributes others
+			      &body body)
+  "TEXTAREA input tag which accepts the ACCESSOR attribute. The
+  semantics of the ACCESSOR are the same as the accessor
+  attribute of the <ucw:input tag."
+  (if (or accessor reader writer)
+      (let ((reader (or reader accessor))
+	    (writer (or writer (with-unique-names (v)
+				 `(lambda (,v) (setf ,accessor ,v))))))
+	(with-unique-names (read-value)
+	  `(<:textarea :name (register-callback ,writer :id ,name)
+		       (@ ,@others)
+		       (when-bind ,read-value ,reader
+			 (<:as-html ,read-value)))))
+      (error "Must specify :ACCESSOR (or use a regular <:textarea tag)")))
+
+(deftag-macro <ucw::input (&attribute accessor reader writer name
+			  &allow-other-attributes others)
+  "Generic INPUT tag replacement.
+
+If the ACCESSOR attribute is specified then it must be a PLACE
+and it's value will be used to fill the input, when the form is
+submitted it will be set to the new value."
+  (when (and accessor (or reader writer))
+    (error "Can not specify both :ACCESSOR and :READER or :WRITER."))
+  (cond
+    ((or reader accessor writer)
+     (with-unique-names (v)
+       (let ((type (getf others :type))
+	     (value (gensym "INPUT-"))
+	     (reader (or reader accessor))
+	     (writer (or writer `(lambda (,v)
+				   (setf ,accessor ,v)))))
+	 `(let ((,value ,reader))
+	    (<:input :name (register-callback ,writer :id ,name)
+		     :value ,value
+		     ,@(when (string= "checkbox" type)
+                             `(:checked ,value))
+		     (@ ,@others))))))
+    (t
+     (error "Must specify :ACCESSOR (or use a regular <:input tag)"))))
+
+(macrolet ((defform-input-tag-shortcut (tag-name input-type)
+	     `(deftag-macro ,tag-name (&allow-other-attributes others)
+		`(<ucw::input :type ,,input-type ,@others))))
+  ;; should there be a <ucw:hidden tag?
+  (defform-input-tag-shortcut <ucw::text "text")
+  (defform-input-tag-shortcut <ucw::password "password"))
+
+(deftag-macro <ucw:submit (&attribute action &allow-other-attributes others &body body)
+  "Presents an button tag which executes ACTION when clicked."  
+  `(<:button :type "submit"
+	     :name +action-parameter-name+
+	     :value (register-action (:with-call/cc t)
+		      ,action)
+	     ,@others ,@body))
+
+(deftag-macro <ucw::simple-select (&attribute writer accessor name 
+					      &allow-other-attributes others
+					      &body body)
+  "<:select with callback support. Use <:option to render the options."
+  (assert (or accessor writer)
+	  (others)
+	  "You need to supply either an accessor or a writer to <ucw:simple-select")
+  (with-unique-names (v)
+    (let ((writer (or writer `(lambda (,v) (setf ,accessor ,v)))))
+      `(<:select :name (register-callback (lambda (,v) (funcall ,writer ,v))
+					  :id ,name)
+		 (@ ,@others)
+		 ,@body))))
+
+(deftag-macro <ucw::simple-form (&attribute action
+                                           &allow-other-attributes others
+                                           &body body)
+  "A Simple form tag, made for use with SIMPLE-SUBMIT. Does not require javascript."
+  (with-unique-names (url query action-object)
+    `(let* ((,action-object (register-action ()
+			      (with-call/cc ,action)))
+	    (,url (compute-url ,action-object *current-component*)))
+       (<:form :action (print-uri-to-string-sans-query ,url)
+	       (@ ,@others)
+	       (dolist (,query (uri.query ,url))
+		 (if (string= ,+action-parameter-name+ (car ,query))
+		     (<:input :type "hidden" :name ,+action-parameter-name+
+			      :value (when ,action (cdr ,query))
+			      :id (ucw-core::action-id ,action-object))
+		     (<:input :type "hidden" :name (car ,query) :value (cdr ,query))))
+	       ,@body))))
+
+;;; setup a <ucw-form: nickname for this package instead?
+(export '(<ucw::textarea <ucw::input <ucw::text <ucw::password <ucw::sumbit
+	  <ucw::simple-select <ucw::simple-form)
+	:ucw-tags)
+
+;; Copyright (c) 2003-2005 Edward Marco Baringer
+;; Copyright (c) 2008 Clinton Ebadi
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;; 
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
addfile ./ucw-forms.asd
hunk ./ucw-forms.asd 1
-
+(defpackage :ucw-forms.system
+  (:use :asdf :cl))
+
+(in-package :ucw-forms.system)
+
+(defsystem :ucw-forms
+  :description "UnCommon Web: Forms Library"
+  :long-description "A very basic form handling library for UCW. This
+  was formerly part of UCW, but is no longer included in
+  ucw-standard."
+  :author "Marco Baringer <mb@bese.it>"
+  :maintainer "Clinton Ebadi <clinton@unknownlamer.org>"
+  :licence "BSD (sans advertising clause)"
+  :components ((:module :src
+			:components ((:file "package")
+				     (:file "tags")
+				     (:file "form"))
+			:serial t))
+  :depends-on (:ucw :cl-ppcre :arnesi :yaclml))