Anonymous committed 333369d

introduce dom-object-mixin and a uniform dom-id generation scheme

Comments (0)

Files changed (8)


+(in-package :weblocks)
+(export '(dom-object-mixin dom-id dom-class dom-classes))
+(defclass dom-object-mixin ()
+  ((dom-id :accessor dom-id
+	   :initarg :dom-id
+	   :documentation "The DOM id of an object. Can be a symbol, a
+	   string or nil. When accessed through the 'dom-id' accessor,
+	   will always become a string. Use ensure-dom-id or
+	   widget-name (for widgets) to access its underlying
+	   implementation.")
+   (dom-class :accessor dom-class :initform nil :initarg :dom-class
+	      :documentation "The DOM class (CSS class) of an
+	      object. Set this to a string if you'd like to add an
+	      additional CSS class to the ones generated from the class
+	      hierarchy by default."))
+  (:documentation "Represents attributes and functionality common to all
+  DOM-renderable objects."))
+(defgeneric ensure-dom-id (obj)
+  (:documentation "Ensure that the object has a 'dom-id' and return
+  it. 'dom-id' is lazily generated on first read, because its creation
+  requires a session to be present. Returns a string, symbol, or nil.")
+  (:method ((obj dom-object-mixin))
+    (if (slot-boundp obj 'dom-id)
+	(slot-value obj 'dom-id)
+	(setf (slot-value obj 'dom-id) (gen-id)))))
+(defgeneric dom-id (obj)
+  (:documentation "Provides a consistent interface to identifying widgets
+by their DOM id. Returns a string or nil if the object is to have no id.")
+  (:method ((obj dom-object-mixin))
+    (let ((id (ensure-dom-id obj)))
+      (and id (attributize-name id))))
+  (:method ((obj symbol)) nil)
+  (:method ((obj function)) nil)
+  (:method ((obj string)) nil))
+(defgeneric dom-classes (obj)
+  (:documentation "Returns a string that represents all applicable CSS
+classes for an object (usually a widget). Normally includes the class
+name and the names of its subclasses. It is safe to assume that all
+widgets will have a CSS class of 'widget'."))
+(defmethod dom-classes ((obj dom-object-mixin))
+  (format nil "~A~@[~A~]"
+	  (apply #'concatenate 'string
+		 (intersperse
+		  (mapcar (compose #'attributize-name #'class-name)
+			  (reverse
+			   ;; we remove the dom-object-mixin from the list of classes, as it
+			   ;; isn't too useful when styling widgets --jwr
+			   (loop for i in (remove (find-class 'dom-object-mixin)
+						  (superclasses obj :proper? nil))
+			      until (string-equal (class-name i) 'standard-object)
+			      collect i)))
+		  " "))
+	  (dom-class obj)))
+(defmethod dom-classes ((obj symbol))
+  (format nil "widget function ~A" (attributize-name obj)))
+(defmethod dom-classes ((obj function))
+  "widget function")
+(defmethod dom-classes ((obj string))
+  "widget string")


 		 (mapcar (lambda (w)
-			    (when (widget-name w)
-			      (attributize-name (widget-name w)))
+			    (dom-id w)
 			      (render-widget w :inlinep t)
 			      (get-output-stream-string *weblocks-output-stream*))))


 		     (flash-old-messages obj))
 	    (if (flash-messages obj)
 		(push (json-function
-		       (ps* `(new (*effect.*pulsate ,(attributize-name (widget-name obj))
+		       (ps* `(new (*effect.*pulsate ,(dom-id obj)
 						    (create :pulses 3 :duration 0.5)))))
-		(push (json-function (ps* `(new (*effect.*blind-up ,(attributize-name (widget-name obj))))))
+		(push (json-function (ps* `(new (*effect.*blind-up ,(dom-id obj)))))
 	(request-hook :session :post-action))
   (push (lambda ()
 		      (mapc (lambda (msg)
 			      (htm (:li (apply #'render-widget msg args))))
-      (push (json-function (ps* `(.show ($ ,(attributize-name (widget-name obj))))))
+      (push (json-function (ps* `(.show ($ ,(dom-id obj)))))


 	  make-navigation find-pane reset-current-pane))
 (defwidget navigation (widget)
-  ((name :initform nil
-	 :documentation "A navigation widget doesn't have a random
-	 name assigned to automatically because the name is also
-	 displayed to the user.")
-   (panes :accessor navigation-panes
+  ((panes :accessor navigation-panes
 	  :initform nil
 	  :initarg :panes
 	  :documentation "An association list of names and
   (declare (ignore initargs))
   (when (null (navigation-current-pane obj))
     (setf (navigation-current-pane obj)
-	  (navigation-default-pane obj))))
+	  (navigation-default-pane obj)))
+  ;; A navigation widget doesn't have a random name assigned to
+  ;; automatically because the name is also displayed to the user.
+  (unless (slot-boundp obj 'dom-id)
+    (setf (slot-value obj 'dom-id) nil)))
 (defgeneric with-navigation-header (obj body-fn &rest args)


 (in-package :weblocks)
-(export '(defwidget widget widget-name widget-dom-id
+(export '(defwidget widget widget-name
           widget-propagate-dirty widget-rendered-p widget-continuation
           widget-parent widget-prefix-fn widget-suffix-fn
        (declare (ignore obj))
        (dependencies-by-symbol (quote ,name)))))
-(defclass widget ()
-  ((name :accessor widget-name
-	 :initform (gen-id)
-	 :initarg :name
-	 :documentation "A name of the widget used in rendering CSS
-	 classes. If the name is not provided it will be generated
-	 automatically with 'gen-id'.")
-   (propagate-dirty :accessor widget-propagate-dirty
+(defclass widget (dom-object-mixin)
+  ((propagate-dirty :accessor widget-propagate-dirty
 		    :initform nil
 		    :initarg :propagate-dirty
 		    :documentation "A list of widget paths (see
   (:metaclass widget-class)
   (:documentation "Base class for all widget objects."))
+;; Process the :name initarg and set the dom-id accordingly. Note that
+;; it is possible to pass :name nil, which simply means that objects
+;; will render without id in generated HTML.
+(defmethod initialize-instance :after ((obj widget) &key name &allow-other-keys)
+  (when name (setf (dom-id obj) name)))
+(defgeneric widget-name (obj)
+  (:documentation "An interface to the DOM id of a widget. Provides
+  access to the underlying implementation, can return either a symbol, a
+  string, or nil.")
+  (:method ((obj widget)) (ensure-dom-id obj))
+  (:method ((obj symbol)) obj)
+  (:method ((obj function)) nil)
+  (:method ((obj string)) nil))
+(defmethod (setf widget-name) (name (obj widget))
+  (setf (dom-id obj) name))
 ;;; Define widget-rendered-p for objects that don't derive from
 ;;; 'widget'
 (defmethod widget-rendered-p (obj)
   (:method (obj body-fn &rest args
 	    &key widget-prefix-fn widget-suffix-fn
-    (let* ((obj-name (widget-dom-id obj)) ; obj-name may be null in functions
-	   (widget-id (when (not (string-equal obj-name "")) obj-name)))
-      (with-html
-	(:div :class (widget-css-classes obj)
-	      :id widget-id
-	      (safe-apply widget-prefix-fn obj args)
-	      (apply body-fn obj args)
-	      (safe-apply widget-suffix-fn obj args))))))
+    (with-html
+      (:div :class (dom-classes obj)
+	    :id (dom-id obj)
+	    (safe-apply widget-prefix-fn obj args)
+	    (apply body-fn obj args)
+	    (safe-apply widget-suffix-fn obj args)))))
 (defgeneric render-widget-body (obj &rest args &key &allow-other-keys)
     (:p :id id :class class (str obj))))
-(defgeneric widget-css-classes (widget)
-  (:documentation "Returns a string that represents applicable CSS
-classes for 'widget'. Normally includes the class name and the names
-of its subclasses. It is safe to assume that the class 'widget' will
-be present for all widgets."))
-(defmethod widget-css-classes ((obj widget))
-  (apply #'concatenate 'string
-	 (intersperse
-	  (mapcar (compose #'attributize-name #'class-name)
-		  (reverse
-		   (loop for i in (superclasses obj :proper? nil)
-		      until (string-equal (class-name i) 'standard-object)
-		      collect i))) " ")))
-(defmethod widget-css-classes ((obj symbol))
-  (format nil "widget function ~A" (attributize-name obj)))
-(defmethod widget-css-classes ((obj function))
-  "widget function")
-(defmethod widget-css-classes ((obj string))
-  "widget string")
-(defmethod widget-name ((obj symbol))
-  obj)
-(defmethod widget-name ((obj function))
-  nil)
-(defmethod widget-name ((obj string))
-  nil)
-(defgeneric widget-dom-id (obj)
-  (:documentation "Provides a consistent interface to identifying widgets
-by their DOM id.")
-  (:method ((obj widget))
-    (attributize-name (widget-name obj)))
-  (:method ((obj symbol))
-    "")
-  (:method ((obj function))
-    "")
-  (:method ((obj string))
-    ""))
 (defmethod widget-prefix-fn (obj)
 (defmethod print-object ((obj widget) stream)
   (print-unreadable-object (obj stream :type t)
-    (format stream "~s" (slot-value obj 'name))))
+    (format stream "~s" (ensure-dom-id obj))))


 	(:div :class "extra-bottom-3" "<!-- empty -->")))
 (deftest-html with-navigation-header-2
-    (with-navigation-header (make-instance 'navigation :panes `(("Test One" . nil)))
+    (with-navigation-header (make-instance 'navigation :panes `(("Test One" . nil)) :dom-id nil)
       (lambda (x &rest args)
 	(with-html (:div "test"))))
   (:div :class "view menu"


     (render-widget-body 'dummy-symbol-function)
   (:p "test"))
-;;; test widget-css-classes
-(deftest widget-css-classes-1
-    (widget-css-classes #'identity)
+;;; test dom-classes
+(deftest dom-classes-1
+    (dom-classes #'identity)
   "widget function")
-(deftest widget-css-classes-2
-    (widget-css-classes 'identity)
+(deftest dom-classes-2
+    (dom-classes 'identity)
   "widget function identity")
-(deftest widget-css-classes-3
-    (widget-css-classes "test")
+(deftest dom-classes-3
+    (dom-classes "test")
   "widget string")
-(deftest widget-css-classes-4
+(deftest dom-classes-4
     (with-request :get nil
-      (widget-css-classes (make-instance 'gridedit
+      (dom-classes (make-instance 'gridedit
 					 :data-class 'employee)))
   "widget dataseq datagrid dataedit-mixin gridedit")
 ;;; test customized widget printing
 (deftest widget-printing-1
     (progv '(*package*) (list (find-package :weblocks-test))
-      (format nil "~s" (make-instance 'weblocks::navigation)))
+      (format nil "~s" (make-instance 'weblocks::navigation :dom-id nil)))
 (deftest widget-printing-2
       (format nil "~s" (make-instance 'weblocks::dataform :name 'users)))
+;; note that navigation is a special case which DOES NOT autogenerate ids
+(deftest widget-printing-3
+    (with-request :get nil
+      (progv '(*package*) (list (find-package :weblocks-test))
+	(format nil "~s" (make-instance 'weblocks::navigation))))
+(deftest widget-printing-4
+    (with-request :get nil
+      (progv '(*package*) (list (find-package :weblocks-test))
+	(format nil "~s" (make-instance 'weblocks::navigation :dom-id "id-123"))))
+  "#<NAVIGATION \"id-123\">")
 			  :depends-on ("weblocks"))
 		 (:file "dependencies"
 			:depends-on ("weblocks" "server" utils))
+		 (:file "dom-object"
+			:depends-on ("weblocks" utils))
 		 (:file "page-template"
 			:depends-on ("weblocks" utils "application"))
 		 (:file "actions"
 				       (:file "isearch"
 					      :depends-on ("html-utils"))
 				       (:file "html-utils"))
-			  :depends-on ("weblocks" "request" "server" "actions"))
+			  :depends-on ("weblocks" "request" "server" "actions" "dom-object"))
 		 (:module linguistic
 			  :components ((:file "grammar"))
 			  :depends-on ("weblocks" utils))
 				       (:file "navigation"
 					      :depends-on ("composite" widget)))
 			  :depends-on (snippets views utils "dependencies" "actions" "server" "request"
-						"request-hooks" linguistic store))
+						"request-hooks" "dom-object" linguistic store))
 		 (:module control-flow
 			  :components ((:file "call-answer")
 				       (:file "dialog"