[Move simple-form code into its own file
clinton@unknownlamer.org**20080227190927] {
addfile ./src/simple-form.lisp
hunk ./src/simple-form.lisp 1
-
+(in-package :com.tee-it-up-golf.web)
+
+(defcomponent simple-form (form-component-mixin)
+  ((%invalid :initform nil :accessor form-invalid-p)
+   (validators :initform nil :initarg :validators :accessor validators)
+   (%failed-validators :initform nil)
+   (%field-failed-validators :initform nil)))
+
+(defcomponent file-upload-form (simple-form)
+  ()
+  (:default-initargs :encoding-type "multipart/form-data"))
+
+(defmethod (setf form-invalid-p) :around (new-value (form simple-form))
+  (if (not new-value)
+      (setf (slot-value form '%failed-validators) nil
+	    (slot-value form '%field-failed-validators) nil))
+  (call-next-method))
+
+(defmethod form-field-validp ((form simple-form) field)
+  (multiple-value-bind (validp failed) (validp field)
+    (declare (ignore validp))
+    (let ((all-failed (append
+		       failed
+		       (cdr (assoc field
+				   (slot-value form '%field-failed-validators))))))
+      (values (null all-failed) all-failed))))
+
+(defclass form-validator (ucw::validator)
+  ((field :initarg :field :initform nil :accessor field)))
+
+(defmethod ucw::validate :around ((form simple-form) (validator form-validator))
+  (if (call-next-method)
+      t
+      (with-slots (field) validator
+	(if field
+	    (if-bind error-list-entry
+		(assoc (slot-value form field)
+		       (slot-value form '%field-failed-validators))
+	      (push validator (cdr error-list-entry))
+	      (push (list (slot-value form field) validator)
+		    (slot-value form '%field-failed-validators))))
+	nil)))
+
+(defmacro define-html-form (name (&rest supers)
+			    (&rest fields) (&rest slots)
+			    &rest options)
+  (flet ((massage-field-name (field-name)
+	   (if (listp field-name)
+	       (cons `(quote ,(car field-name)) (cdr field-name))
+	       (list `(quote ,field-name))))
+	 (massage-options (options)
+	   (if-bind validators (find :validators options :key #'car)
+	     `(,@(remove-if (lambda (k) (or (eq k :validators)
+				       (eq k :default-initargs)))
+			    options :key #'car)
+		 (:default-initargs
+		     ,@(cdr (find :default-initargs options :key #'car))
+		     :validators (list ,@(mapcar (lambda (v)
+						   `(make-instance ',(car v)
+								   ,@(cdr v)))
+						 (cdr validators)))))
+	     
+	     options)))
+    `(defcomponent ,name ,(or supers '(simple-form))
+       ,(append (mapcar (lambda (f)
+			  `(,(car f) :initform (make-instance
+						,@(massage-field-name (cadr f)))
+			     ,@(cddr f)))
+			fields)
+		slots)
+       ;; Need to yank out :validators and merge it with
+       ;; :default-initargs
+       ,@(massage-options options))))
+
+
+(defun make-validators (&rest validator-names)
+  "Create validator instances. validator-names should be a list of
+class names or sublists of class names and initargs"
+  (mapcar (lambda (name) (apply #'make-instance
+			   (if (listp name) name (list name))))
+	  validator-names))
+
+(defgeneric form-fields (form))
+
+(defgeneric/cc process-form (form))
+(defgeneric/cc cancel-form (form))
+
+(defmethod/cc cancel-form ((form simple-form))
+  (ok form))
+
+(defmethod/cc process-form :around ((form simple-form))
+  (multiple-value-bind (validp failed) (validp form)
+    (cond ((not validp)
+	   (setf (form-invalid-p form) t)
+	   (refresh-component form))
+	  (t (setf (form-invalid-p form) nil)
+	     (call-next-method form)))))
+
+(defmethod form-fields ((component simple-form))
+  (remove-if-not (arnesi:compose #'ucw::form-field-p #'cdr)
+		 (mapcar (lambda (name) (cons name (slot-value component name)))
+			 (remove-if-not #'(lambda (name) (slot-boundp component name))
+					(mapcar #'mopp:slot-definition-name
+						(mopp:class-slots (class-of component)))))))
+
+(defmethod render ((form simple-form))
+  (<:div
+   :class "simple-form"
+   (if (form-invalid-p form)
+       (<:p :class "error"
+	    (<:h1 "Form Failed Validation")
+	    (if-bind failed-messages (mapcan (lambda (f)
+					       (if-bind msg (ucw::message f)
+						 (list msg)))
+					     (slot-value form '%failed-validators))
+	      (mapc (lambda (m) (<:h2 (<:as-html m)))
+		    failed-messages))))
+   (mapc
+    (lambda (c)
+      (<:div
+       :class "field-box"		; composite field-box (car c)?
+       (<:div :class "label"
+	      (<:as-html (symbol->string  (car c)))
+	      (if (form-invalid-p form)
+		  (multiple-value-bind (validp failed)
+		      (form-field-validp form (cdr c))
+		    (if (not validp)
+			(<:p :class "error"
+			     (<:format "Invalid ~@[(~{~A~^, ~})~]"
+				       (mapcan (lambda (v)
+						 (if-bind msg (ucw::message v)
+						   (list msg)
+						   msg))
+					       failed)))))))
+       (<:div :class "widget" (render (cdr c)))))
+    (form-fields form))))
+
+(defmethod render :after ((form simple-form))
+  (<:div 
+   (<ucw:submit :value "Ok" :action-body (process-form form))
+   (<ucw:submit :value "Cancel" :action-body (cancel-form form))))
+
+(defgeneric form-fields-of (component))
+
+(defmethod form-fields-of ((form simple-form))
+  (mapcar #'cdr (form-fields form)))
+
+(defmethod form-fields-of ((component standard-component))
+  "Return slot values of COMPONENT which are FORM-FIELDs"
+  (remove-if-not #'ucw::form-field-p
+		 (mapcar (arnesi:curry #'slot-value component)
+			 (remove-if-not #'(lambda (name) (slot-boundp component name))
+					(mapcar #'mopp:slot-definition-name
+						(mopp:class-slots (class-of component)))))))
+
+(defmethod form-fields-of ((field form-field))
+  (list field))
+
+(defun default-validp (form)
+  ;; Mostly yanked from ucw update (C) notices
+  (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))))
+    (let ((failed (apply #'nconc
+                         (mapcar #'do-validate-field
+                                 (form-fields-of form)))))
+      (values (null failed) failed))))
+
+(defmethod validp ((form standard-component))
+  (default-validp form))
+
+(defmethod validp ((form simple-form))
+  (setf (slot-value form '%failed-validators) nil
+	(slot-value form '%field-failed-validators) nil)
+  (multiple-value-bind (validp field-failed) (call-next-method)
+    (declare (ignore validp))
+    (let* ((form-failed
+	    (if-bind validators (validators form)
+	     (mapcan  (lambda (v)
+			(if (not (ucw::validate form v))
+			    (list v)))
+		      validators)))
+	   (failed
+	    (nconc
+	     field-failed
+	     (mapcar (lambda (v) (cons form v))
+		     (setf (slot-value form '%failed-validators) form-failed))
+	     (mapcar (lambda (e) (cons (car e) (cdr e)))
+		     (slot-value form '%field-failed-validators)))))
+      (values (null failed) failed))))
+
+(defmethod validp ((form-field date-field))
+  (default-validp form-field))
+
+(defmethod form-fields-of ((field date-field))
+  (list (ucw::year field) (ucw::month field) (ucw::day field)))
hunk ./src/web-admin.lisp 68
-(defcomponent simple-form (form-component-mixin)
-  ((%invalid :initform nil :accessor form-invalid-p)))
-
-(defcomponent file-upload-form (simple-form)
-  ()
-  (:default-initargs :encoding-type "multipart/form-data"))
-
-(defmacro define-html-form (name (&rest supers)
-			    (&rest fields) (&rest slots)
-			    &rest options)
-  (flet ((massage-field-name (field-name)
-	   (if (listp field-name)
-	       (cons `(quote ,(car field-name)) (cdr field-name))
-	       (list `(quote ,field-name)))))
-    `(defcomponent ,name ,(or supers '(simple-form))
-       ,(append (mapcar (lambda (f)
-			  `(,(car f) :initform (make-instance
-						,@(massage-field-name (cadr f)))
-			     ,@(cddr f)))
-			fields)
-		slots)
-       ,@options)))
-
-(defun make-validators (&rest validator-names)
-  "Create validator instances. validator-names should be a list of
-class names or sublists of class names and initargs"
-  (mapcar (lambda (name) (apply #'make-instance
-			   (if (listp name) name (list name))))
-	  validator-names))
-
-(defgeneric form-fields (form))
-
-(defgeneric/cc process-form (form))
-(defgeneric/cc cancel-form (form))
-
-(defmethod/cc cancel-form ((form simple-form))
-  (ok form))
-
-(defmethod/cc process-form :around ((form simple-form))
-  (multiple-value-bind (validp failed) (validp form)
-    (cond ((not validp)
-	   (setf (form-invalid-p form) t)
-	   (refresh-component form))
-	  (t (setf (form-invalid-p form) nil)
-	     (call-next-method form)))))
-
-(defmethod form-fields ((component simple-form))
-  (remove-if-not (arnesi:compose #'ucw::form-field-p #'cdr)
-		 (mapcar (lambda (name) (cons name (slot-value component name)))
-			 (remove-if-not #'(lambda (name) (slot-boundp component name))
-					(mapcar #'mopp:slot-definition-name
-						(mopp:class-slots (class-of component)))))))
-
-(defmethod render ((form simple-form))
-  (<:div :class "golf-form"
-   (mapc
-    (lambda (c)
-      (<:div
-       :class "field-box"		; composite field-box (car c)?
-       (<:div :class "label"
-	      (<:as-html (symbol->string  (car c)))
-	      (if (form-invalid-p form)
-		  (multiple-value-bind (validp failed) (validp (cdr c))
-		    (if (not validp)
-			(<:div :class "error"
-			       (<:format "Invalid ~@[(~{~A~^, ~})~]"
-					 (mapcan (lambda (v)
-						   (if-bind msg (ucw::message v)
-						     (list msg)
-						     msg))
-						 failed)))))))
-       (<:div :class "widget" (render (cdr c)))))
-    (form-fields form))))
-
-
-(defmethod render :after ((form simple-form))
-  (<:div 
-   (<ucw:submit :value "Ok" :action-body (process-form form))
-   (<ucw:submit :value "Cancel" :action-body (cancel-form form))))
-
-(defgeneric form-fields-of (component))
-
-(defmethod form-fields-of ((form simple-form))
-  (mapcar #'cdr (form-fields form)))
-
-(defmethod form-fields-of ((component standard-component))
-  "Return slot values of COMPONENT which are FORM-FIELDs"
-  (remove-if-not #'ucw::form-field-p
-		 (mapcar (arnesi:curry #'slot-value component)
-			 (remove-if-not #'(lambda (name) (slot-boundp component name))
-					(mapcar #'mopp:slot-definition-name
-						(mopp:class-slots (class-of component)))))))
-
-(defmethod form-fields-of ((field form-field))
-  (list field))
-
-(defmethod form-fields-of ((field date-field))
-  (list (ucw::year field) (ucw::month field) (ucw::day field)))
-
-(defun default-validp (form)
-    ;; Mostly yanked from ucw update (C) notices
-  (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))))
-    (let ((failed (apply #'nconc
-                         (mapcar #'do-validate-field
-                                 (form-fields-of form)))))
-      (values (null failed) failed))))
-
-(defmethod validp ((form standard-component))
-  (default-validp form))
-
-(defmethod validp ((form-field date-field))
-  (default-validp form-field))
-
hunk ./tee-it-up.asd 17
-
hunk ./tee-it-up.asd 22
-     (:file "web-admin" :depends-on ("web-common"))
+     (:file "simple-form" :depends-on ("packages"))
+     (:file "web-admin" :depends-on ("web-common" "simple-form"))
}