1. Stephen Compall
  2. weblocks-dev


Stephen Compall  committed 7a66418 Merge

Merge jwr into dev

  • Participants
  • Parent commits f1b5bce, c89b2a6
  • Branches default

Comments (0)

Files changed (17)

File .hgtags

View file
 88d26b07f7c2f22061f1e126311b88f99255e223 pre 0.1
 7b0d8ac2dcb522d056971a77e789088532bf5644 before-make-widget-place-writer-merge
+7b1fea8d1d6f872fb5b927062ee3b6716648089c 0.8

File scripts/new-app-templates/init-session.lisp

View file
 (in-package :{APPNAME})
-;; Define our application
-(defwebapp '{APPNAME}
-    :description "A web application based on Weblocks")
-;; Set public files directory to {APPNAME}/pub
-(setf *public-files-path* (compute-public-files-path :{APPNAME}))
 ;; Define callback function to initialize new sessions
 (defun init-user-session (comp)
   (setf (composite-widgets comp)

File scripts/new-app-templates/{APPNAME}.lisp

View file
     :ignore-default-dependencies nil ;; accept the defaults
-;; Ensure that your public files directory is setup appropriately
-(eval-when (:load-toplevel :execute)
-  (set-weblocks-default-public-files-path 
-   (compute-public-files-path :{APPNAME})))
 ;; Top level start & stop scripts
 (defun start-{APPNAME} (&rest args)
   "Starts the application by calling 'start-weblocks' with appropriate
-  (apply #'start-weblocks args))
+  (apply #'start-weblocks args)
+  (start-webapp '{APPNAME})
 (defun stop-{APPNAME} ()
   "Stops the application by calling 'stop-weblocks'."
+  (stop-webapp '{APPNAME})

File src/application.lisp

File contents unchanged.

File src/debug-mode.lisp

View file
   (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)))

File src/server.lisp

File contents unchanged.

File src/store/clsql/clsql.lisp

View file
 (defmethod open-store ((store-type (eql :clsql)) &rest args)
   (setf *default-caching* nil)
-  (setf *default-store* (apply #'connect args)))
+  (setf *default-store* (apply #'make-instance 'fluid-database
+			       :connection-spec args)))
 (defmethod close-store ((store database))
   (when (eq *default-store* store)

File src/store/clsql/weblocks-clsql.asd

View file
   :author "Slava Akhmechet"
   :licence "LLGPL"
   :description "A weblocks backend for clsql."
-  :depends-on (:closer-mop :metatilities :clsql :weblocks)
+  :depends-on (:closer-mop :metatilities :clsql :clsql-fluid :weblocks)
   :components ((:file "clsql")))

File src/store/elephant/elephant.lisp

View file
 (defmethod open-store ((store-type (eql :elephant)) &rest args &key spec &allow-other-keys)
   (declare (ignore args)) 
-  (setup-elephant-transaction-hooks)
   (setf *default-store*
 	(make-instance 'elephant-store
 		       :controller (setf *store-controller* (elephant:open-store spec)))))
     (setf *default-store* nil))
   (elephant:close-store (elephant-controller store))
   (when (eq (elephant-controller store) *store-controller*)
-    (setf *store-controller* nil))
-  (remove-elephant-transaction-hooks))
+    (setf *store-controller* nil)))
 (defmethod clean-store ((store elephant-store))
   ;; Drop everything from the root
 ;;; Transactions ;;;
-(defmethod begin-transaction ((store elephant-store))
+(defmethod use-dynamic-transaction-p ((store elephant-store))
-(defmethod commit-transaction ((store elephant-store))
-  t)
-(defmethod rollback-transaction ((store elephant-store))
-  t)
-(defun elephant-transaction-hook (hooks)
+(defmethod dynamic-transaction ((store elephant-store) proc)
   "This dynamic hook wraps an elephant transaction macro around the body hooks.
    This allows us to gain the benefits of the stable transaction system in elephant"
-  (let ((valid-sc (get-valid-sc)))
-    (if valid-sc
-	(ensure-transaction (:store-controller valid-sc)
-	  (eval-dynamic-hooks hooks))
-	(eval-dynamic-hooks hooks))))
-(defun get-valid-sc ()
-  "This function provides some reasonable defaults for elephant.  Namely, that
-   the default transaction is either the default store or the current store controller.
-   Care must be taken when using multiple elephant stores with weblocks.  The 
-   consequences are as yet undefined."
-  (cond ((subtypep (type-of *default-store*) 'elephant-store)
-	 (elephant-controller *default-store*))
-	((not (null *store-controller*))
-	 *store-controller*)))
-(defun setup-elephant-transaction-hooks ()
-  "Ensure that the elephant transaction hook is registered on action and rendering code"
-  (pushnew 'elephant-transaction-hook (request-hook :application :dynamic-action)))
-;;  (pushnew 'elephant-transaction-hook (request-hook :application :dynamic-render)))
-(defun remove-elephant-transaction-hooks ()
-  "Remove the elephant-specific transaction hooks"
-  (symbol-macrolet ((action-list (request-hook :application :dynamic-action))
-		    (render-list (request-hook :application :dynamic-render)))
-    (setf action-list (delete 'elephant-transaction-hook action-list))
-    (setf render-list (delete 'elephant-transaction-hook render-list))))
+  (ensure-transaction (:store-controller store)
+    (funcall proc)))
 ;;; Creating and deleting persistent objects ;;;

File src/views/formview/formview.lisp

View file
 		   (:span :class "slot-name"
 			  (:span :class "extra"
 				 (unless (empty-p (view-field-label field))
-				   (str (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

File src/views/view/utils.lisp

View file
 if it was mixed into the view."
   field object parent-info)
+(defun factor-overridden-fields (field-info-list)
+  "Overrides parent fields redefined in children."
+  #+lp-view-field-debug
+  (format t "fil: ~S~%" field-info-list)
+  (labels ((field-key (field-info)
+	     (cons (fi-slot-name field-info)
+		   (awhen (parent field-info)
+		     (view-field-slot-name (field-info-field IT)))))
+	   (fi-slot-name (field-info)
+	     (view-field-slot-name (field-info-field field-info)))
+	   (parent (field-info)
+	     (field-info-parent-info field-info))
+	   (mixin-p (field-info)
+	     (typep (field-info-field field-info) 'mixin-view-field))
+	   (true-inline? (field-info)
+	     (not (or (parent field-info) (mixin-p field-info)))))
+    #+lp-view-field-debug
+    (format t "in: ~S~%" (mapcar (compose #'describe #'field-info-field) field-info-list))
+    (let* ((fields (coerce field-info-list 'simple-vector))
+	   (true-inlines (make-hash-table :test 'eq))
+	   (positions (make-hash-table :test 'equal))
+	   (nils? nil))
+      (declare (type simple-vector fields))
+      ;; find the true inlines so we can eliminate others of same
+      ;; slot-name
+      (loop for field across fields
+	    do (when (true-inline? field)
+		 (setf (gethash (fi-slot-name field) true-inlines) t)))
+      (loop for pos from (1- (length fields)) downto 0
+	    for field = (aref fields pos)
+	    for fkey = (field-key field)
+	    do (acond ((gethash fkey positions)
+		       ;; "carry" to simulate <=980bccf ordering
+		       (shiftf (aref fields pos) (aref fields it) nil)
+		       (setf nils? t))
+		      ((and (not (true-inline? field))
+			    (gethash (fi-slot-name field) true-inlines))
+		       (setf (aref fields pos) nil nils? t)))
+	       (setf (gethash fkey positions) pos))
+      (let ((merged-fields (coerce fields 'list)))
+	(when nils?
+	  (setf merged-fields (delete nil merged-fields)))
+	#+lp-view-field-debug
+	(format t "merged ~S~%" (mapcar (compose #'describe #'field-info-field) merged-fields))
+	merged-fields))))
+(defun map-view-field-info-list (proc view-designator obj parent-field-info)
+  "Walk a full list of view fields, including inherited fields."
+  (let ((view (when view-designator
+		(find-view view-designator))))
+    (when view
+      (map-view-field-info-list proc (view-inherit-from view) obj
+				parent-field-info)
+      (dolist (field (view-fields view))
+	(funcall proc (make-field-info :field field :object obj
+				       :parent-info parent-field-info))))))
+(defun map-expanding-mixin-fields (proc field-info-list &optional include-invisible-p)
+  "Expands mixin fields into inline fields. Returns two values - a
+list of expanded field-infos, and true if at least one field has been
+  (labels ((map-emf (field-info)
+	     (let ((field (field-info-field field-info))
+		   (obj (field-info-object field-info)))
+	       (etypecase field
+		 (inline-view-field (funcall proc field-info))
+		 (mixin-view-field
+		    (when (or include-invisible-p
+			      (not (view-field-hide-p field)))
+		      (map-view-field-info-list
+		       #'map-emf
+		       (mixin-view-field-view field)
+		       (when obj
+			 (or (obtain-view-field-value field obj)
+			     (funcall (mixin-view-field-init-form field))))
+		       field-info)))))))
+    (mapc #'map-emf field-info-list)))
 (defun get-object-view-fields (obj view-designator &rest args
 			       &key include-invisible-p (expand-mixins t) custom-fields
 view-field. Field-info structures are inserted as is, and view-fields
 are wrapped in field-info structures with common-sense defaults."
   (declare (ignore args))
-  (labels ((compute-view-field-info-list (view-designator obj parent-field-info)
-	     "Computes a full list of view fields, including inherited
-	     fields. Returns a list of field-infos."
-	     (let ((view (when view-designator
-			   (find-view view-designator))))
-	       (when view
-		 (append (compute-view-field-info-list
-			  (view-inherit-from view) obj
-			  parent-field-info)
-			 (mapcar (lambda (field)
-				   (make-field-info :field field :object obj
-						    :parent-info parent-field-info))
-				 (view-fields view))))))
-	   (factor-overriden-fields (field-info-list)
-	     "Overrides parent fields redefined in children."
-             ;(format t "fil: ~S~%" field-info-list)
-             (flet ((field-key (field-info &aux (field (field-info-field field-info)))
-                      (cons (view-field-slot-name field) (awhen (field-info-parent-info field-info)
-                                                              (view-field-slot-name (field-info-field IT)))))
-                    (parent (field-info &aux (field (field-info-field field-info)))
-                      (field-info-parent-info field-info))
-                    (mixin-p (field-info &aux (field (field-info-field field-info)))
-                      (typep field 'mixin-view-field)))
-               ;(format t "in: ~S~%" (mapcar (compose #'describe #'field-info-field) field-info-list))
-               (let* ((fields (remove-duplicates field-info-list :key #'field-key :from-end nil))
-                      (true-inline-fields (remove-duplicates fields :test #'equal
-                                                             :key (compose #'view-field-slot-name #'field-info-field)
-                                                             :from-end nil))
-                      (true-inline-fields (remove-if (lambda (fi) (or (parent fi) (mixin-p fi))) true-inline-fields
-                                                     :from-end t))
-                      (expanded-mixin-fields (remove-if-not (lambda (fi) (or (parent fi) (mixin-p fi)))
-                                                            fields))
-                      (expanded-mixin-fields (remove-duplicates expanded-mixin-fields :test #'equal :key #'field-key))
-                      (expanded-mixin-fields (remove-if (curry-after #'find true-inline-fields
-                                                                     :test #'equal :key (compose #'view-field-slot-name
-                                                                                                 #'field-info-field)
-                                                                     :from-end nil) expanded-mixin-fields))
-                      (merged-fields (sort (union true-inline-fields expanded-mixin-fields)
-                                           #'< :key (lambda (field)
-                                                      (flet ((pos (field where)
-                                                               (let ((r (position (field-key field) where :key #'field-key :test #'equal)))
-                                                               ;(format t "field: ~S / where: ~S -> ~S%" (field-key field)
-                                                               ;        (mapcar #'field-key where) r)
-                                                               r
-                                                               )))
-                                                        (let ((result (or (pos field fields)
-                                                                          (pos field true-inline-fields)
-                                                                          (pos field expanded-mixin-fields)
-                                                                          0)))
-                                                        #+(or)(format t "result for field ~A: ~A~%" field result) result))))))
-                 ;(format t "true inline: ~S~%" (mapcar #'field-key true-inline-fields))
-                 ;(format t "expanded ~S~%" (mapcar #'field-key expanded-mixin-fields))
-                 ;(format t "fields ~S~%" (mapcar #'field-key fields))
-                 ;(format t "merged ~S~%" (mapcar (compose #'describe #'field-info-field) merged-fields))
-                 merged-fields))) ; XXX this is quite inefficient (at least n^2 + n*log(n))
-	   (expand-mixin-fields (field-info-list)
-	     "Expands mixin fields into inline fields. Returns two
-              values - a list of expanded field-infos, and true if at
-              least one field has been expanded."
-	     (apply #'append
-		    (mapcar (lambda (field-info)
-			      (let ((field (field-info-field field-info))
-				    (obj (field-info-object field-info)))
-				(etypecase field
-				  (inline-view-field (list field-info))
-				  (mixin-view-field (when (or include-invisible-p
-							      (not (view-field-hide-p field)))
-						      (compute-view-field-info-list
-						       (mixin-view-field-view field)
-						       (when obj
-							 (or (obtain-view-field-value field obj)
-							     (funcall (mixin-view-field-init-form field))))
-						       field-info))))))
-			    field-info-list)))
-	   (custom-field->field-info (custom-field)
+  (labels ((custom-field->field-info (custom-field)
 	     (etypecase custom-field
 	       (field-info custom-field)
 	       (view-field (make-field-info :field custom-field
 					    :object obj
 					    :parent-info nil)))))
-    (let* ((initial-step (factor-overriden-fields
-			  (compute-view-field-info-list view-designator obj nil)))
-	   (results
-	    (if expand-mixins
-		(loop for field-info-list = initial-step
-		   then (factor-overriden-fields
-			 (expand-mixin-fields field-info-list))
-		   until (notany (lambda (field-info)
-				   (typep (field-info-field field-info) 'mixin-view-field))
-				 field-info-list)
-		   finally (return (if include-invisible-p
-				       field-info-list
-				       (remove-if #'view-field-hide-p field-info-list
-						  :key #'field-info-field))))
-		initial-step)))
+    (let* ((results (factor-overridden-fields
+		     (let ((expansion '()))
+		       (map-view-field-info-list (f_ (push _ expansion))
+						 view-designator obj nil)
+		       (nreverse expansion)))))
+      (when expand-mixins
+	(setf results (factor-overridden-fields
+		       (let ((expansion '()))
+			 (map-expanding-mixin-fields
+			  (f_ (push _ expansion)) results include-invisible-p)
+			 (nreverse expansion)))))
+      (unless include-invisible-p
+	(setf results (remove-if #'view-field-hide-p results
+				 :key #'field-info-field)))
       (dolist (custom-field custom-fields results)
 	(if (consp custom-field)
 	    (insert-at (custom-field->field-info (cdr custom-field)) results (car custom-field))

File src/widgets/data-editor.lisp

View file
     (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)

File src/widgets/dataform.lisp

View file
 '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

File src/widgets/template-block.lisp

View file
 (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

File test/views/view/utils.lisp

View file
 (in-package :weblocks-test)
+(deftestsuite views/view/utils-suite (weblocks-suite)
+  ())
 ;;; Test find-view
 (deftest find-view-1
     (multiple-value-bind (res err)
 					    (education :type mixin
 						       :view '(data education-history))
 					    (graduation-year :hidep t))))
-  (name manager university graduation-year))
+  (name manager university))
+(addtest get-object-view-fields.direct-shadows-mixedin
+  (dolist (view (list (defview () (:inherit-from '(:scaffold employee))
+			(education :type mixin
+				   :view '(data education-history))
+			(graduation-year))
+		      (defview () (:inherit-from '(:scaffold employee))
+			(education :type mixin
+				   :view '(data education-history))
+			(graduation-year :hidep t))))
+    (let ((fields (get-object-view-fields *joe* view :include-invisible-p t)))
+      (ensure-same (mapcar #'print-field-info fields)
+		   '(name manager university graduation-year))
+      (ensure-same (field-info-object (car (last fields)))
+		   *joe*))))
+(addtest get-object-view-fields.direct-shadow-proper-mixin
+  (let ((fields (get-object-view-fields
+		 *joe* (defview () (:inherit-from '(:scaffold employee))
+			 (education :type mixin
+				    :view '(data education-history))
+			 (education)))))
+    (ensure-same (mapcar #'print-field-info fields)
+		 '(name manager education))
+    (ensure-same (field-info-object (third fields)) *joe*)))
 (deftest get-object-view-fields-8
     (mapcar #'print-field-info

File test/widgets/widget/widget.lisp

View file
 	      (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 weblocks.asd

View file
   :licence "LLGPL"
   :description "A Common Lisp web framework."
   :depends-on (:closer-mop :metatilities :hunchentoot :cl-who :cl-ppcre :cl-json :puri :md5
-	       :cl-fad :fare-matcher :cl-cont :parenscript :anaphora :f-underscore :html-template)
+	       :cl-fad :fare-matcher :cl-cont :parenscript :anaphora :f-underscore)
   :components ((:module src
 		:components (
 		 (:file "weblocks")
 							     (:file "widget-mop")))
 				       (:file "flash"
 					      :depends-on (widget))
-				       (:file "template-block"
-					      :depends-on (widget))
 				       (:file "data-editor"
 					      :depends-on (widget))
 				       (:file "dataform"
 		(doc-op (load-op "weblocks-scripts"))
 		(make-app-op (load-op "weblocks-scripts"))))
+(defsystem-connection weblocks+html-template
+  :requires (:weblocks :html-template)
+  :components ((:module src :pathname "src/widgets/"
+		:components ((:file "template-block")))))
 ;;; test-op
 (defmethod perform ((o asdf:test-op) (c (eql (find-system :weblocks))))
   "A method specializer to run the weblocks test suite through ASDF."