Stephen Compall committed 980bccf Merge

Merge 0d454ad into dev

Comments (0)

Files changed (11)


   (format stream "During the rendering phase, ~A, which should ~
 		  typically be done only during action handling"
 	  (change-made-during-rendering c)))
+(define-condition misunderstood-action (webapp-style-warning)
+  ((action :initarg :action :reader misunderstood-action
+	   :documentation "What the user did to reveal this problem.")
+   (missing :initarg :missing :reader missing-action-handler-part
+	    :documentation "A description of what's missing for ACTION
+	    to be handled correctly."))
+  (:report report-misunderstood-action)
+  (:documentation "Signalled when a user invoked an action, and some
+part of the handler for which the app writer is responsible doesn't
+seem to be implemented correctly."))
+(defun report-misunderstood-action (c stream)
+  "Describe a `misunderstood-action'."
+  (format stream "A webapp user did: \"~A\"
+But it was handled incorrectly; this is probably an issue with ~A"
+	  (misunderstood-action c) (missing-action-handler-part c)))
 (in-package :weblocks)
-(export '(*json-content-type refresh-request-p initial-request-p
+(export '(*json-content-type* refresh-request-p initial-request-p
 	  ajax-request-p pure-request-p redirect post-action-redirect


 			 (attributize-name (object-class-name obj)))
-	     (:h1 (fmt (view-caption view)
-		       (humanize-name (object-class-name obj))))
+	     (unless (empty-p (view-caption view))
+	       (htm (:h1 (fmt (view-caption view)
+			      (humanize-name (object-class-name obj))))))
 	     (safe-apply fields-prefix-fn view obj args)
 	     (:ul (apply body-fn view obj args))
 	     (safe-apply fields-suffix-fn view obj args))))))
 			      &rest args)
     (:li :class (attributize-name (view-field-slot-name field))
-	 (:span :class (concatenate 'string "label "
-				    (attributize-presentation
-				     (view-field-presentation field)))
-		(str (view-field-label field)) ": ")
+	 (unless (empty-p (view-field-label field))
+	   (htm (:span :class (concatenate 'string "label "
+					   (attributize-presentation
+					    (view-field-presentation field)))
+		       (str (view-field-label field)) ": ")))
 	 (apply #'render-view-field-value
 		value presentation
 		field view widget obj


 	   :documentation "If this slot is bound to a function object,
 	   the function will be called with a new slot value and the
 	   object being rendered as arguments. If the slot is not
-	   bound, '(setf slot-value)' will be used."))
+	   bound, '(setf slot-value)' will be used.")
+   (delayed-write-p :initarg :delayed-write-p
+		    :initform nil
+		    :accessor form-view-field-writer-delayed-p
+		    :documentation "If this slot is set to t, then the
+writer will get called after the object has been persisted. This is useful
+for updating relations, where objects need to be assigned ids and stored
+before relations can be updated."))
   (:documentation "A writer slot mixin"))
 (defclass form-view-field (inline-view-field form-view-field-writer-mixin)
 			   (view-field-presentation field))
 		   (:span :class "slot-name"
 			  (:span :class "extra"
-				 (str (view-field-label field)) ": "
+				 (unless (empty-p (view-field-label field))
+				   (str (view-field-label field))
+				   (str ": "))
 				 (when (form-view-field-required-p field)
 				   (htm (:em :class "required-slot" "(required) ")))))
 		   (apply #'render-view-field-value


 			   (funcall writer value obj)
 			   (setf (slot-value obj (view-field-slot-name field))
-	     (deserialize-object-from-parsed-values (parsed-values)
+	     (deserialize-object-from-parsed-values (parsed-values &key write-delayed)
 	       "Accepts an an association list of field-info
                structures and parsed-values, and records each parsed
                value in the corresponding field's object slot."
 			 (let ((field (field-info-field field-info))
 			       (obj (field-info-object field-info)))
 			   (when (typep (view-field-presentation field) 'form-presentation)
-			     (write-value field parsed-value obj)))))
+			     (if (form-view-field-writer-delayed-p field)
+				 (when write-delayed
+				   (write-value field parsed-value obj))
+				 (unless write-delayed
+				   (write-value field parsed-value obj)))))))
 	     (persist-object-view (obj view field-info-list)
 	       "Persists an object view to the backend store. If the
 		    (deserialize-object-from-parsed-values results)
 		    (when (form-view-persist-p view)
 		      (persist-object-view obj view (mapcar #'car results)))
+		    (deserialize-object-from-parsed-values results :write-delayed t)
 		  (values nil errors)))
 	    (values nil results))))))


+(in-package #:weblocks)
+(export '(html-presentation))
+(defclass html-presentation (text-presentation)
+  ()
+  (:documentation "A presentation that simply renders its value as-is,
+  without any escaping, allowing for HTML inclusion."))
+(defmethod render-view-field-value (value (presentation html-presentation)
+                                    field view widget obj &rest args
+                                    &key &allow-other-keys)
+  (let ((printed-value (apply #'print-view-field-value value presentation field view widget obj args)))
+    (with-html
+      (:span :class "value"
+             (str printed-value)))))


 (export '(data-editor dataform-data dataform-class-store
 	  dataform-on-cancel dataform-on-success
-	  dataform-allow-close-p dataform-on-close))
+	  dataform-allow-close-p dataform-on-close
+	  render-dataform-data-buttons))
 (defwidget data-editor ()
   ((data :accessor dataform-data
     (setf (dataform-class-store obj)
 	  (object-store (dataform-data obj)))))
+(defgeneric (setf dataform-ui-state) (new-value data-editor)
+  (:documentation "When a dataform or similar, change DATA-EDITOR's
+  state to NEW-VALUE, which should be :data or :form.")
+  (:method (new-value (wij data-editor))
+    (style-warn 'misunderstood-action
+      :action (format nil "changed a dataform's state to ~S" new-value)
+      :missing "`dataform-ui-state' accessor implementation")
+    new-value))
 (defgeneric render-dataform-data-buttons (dataform data)
   (:documentation "Render the buttons and links appearing with the
   data view on a dataform."))
     (:div :class "submit"
 	  (render-link (make-action
-			(f_% (setf (slot-value obj 'ui-state) :form)))
+			(f_% (setf (dataform-ui-state obj) :form)))
 		       :class "modify")
 	  (when (and (dataform-allow-close-p obj)


 (export '(dataform dataform-data-view dataform-form-view
 	  render-dataform render-dataform-data render-dataform-form
-	  annihilate-dataform dataform-submit-action))
+	  annihilate-dataform dataform-submit-action dataform-ui-state))
 (defwidget dataform (data-editor)
   ((data-view :accessor dataform-data-view
 	      into form view. If 'form-view' isn't provided, the
 	      scaffold view will be used by default.")
    (ui-state :initform :data
+	     :accessor dataform-ui-state
 	     :initarg :ui-state
 	     :documentation "Current internal state of the
 	     widget. Normally :data when rendering via 'render-data'
 'args' - keyword arguments passed to functions internally. See
 'render-data', 'render-form', etc.")
   (:method ((obj dataform) data &rest args)
-    (ecase (slot-value obj 'ui-state)
+    (ecase (dataform-ui-state obj)
       (:data (apply #'render-dataform-data obj data (dataform-data-view obj) args))
       (:form (apply #'render-dataform-form obj data (dataform-form-view obj) args)))))
 				      (when break-out
 					(setf (slot-value obj 'validation-errors) nil)
 					(setf (slot-value obj 'intermediate-form-values) nil)
-					(setf (slot-value obj 'ui-state) :data))))))
+					(setf (dataform-ui-state obj) :data))))))
 	   :validation-errors (slot-value obj 'validation-errors)
 	   :intermediate-values (slot-value obj 'intermediate-form-values)
 	   :widget obj


 (in-package :weblocks)
-(export '(template-block-mixin template-block-source template-block-vars recreate-template-printer))
+(export '(template-block template-block-source template-block-vars recreate-template-printer))
-(defclass template-block-mixin ()
-  ((template-printer :accessor template-printer-of :initform nil)
+(defwidget template-block ()
+  ((template-printer :accessor template-printer-of :initform nil
+		     :affects-dirty-status-p nil)
    (source :accessor template-block-source :initarg :source :initform nil)
    (vars :type list :accessor template-block-vars :initarg :vars :initform nil))
   (:documentation "A block of HTML taken from 'source', which is processed by


 	      (w (make-instance 'dataform)))
 	  (declare (special weblocks::*dirty-widgets*))
 	  (render-widget w)
-	  (setf (slot-value w 'weblocks::ui-state) :form)
+	  (setf (dataform-ui-state w) :form)
 	  (widget-name (car weblocks::*dirty-widgets*)))))
 								   (:file "paragraph")
 								   (:file "excerpt")
 								   (:file "image")
-								   (:file "url")))
+								   (:file "url")
+								   (:file "html")))
 						      :components ((:file "common"))))