X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/f4efa7fff2efa6a3144fc664683137df92c42f91..8032a7fe4b6d2470476115b307c105b93c4100e5:/src/ucw/html-description.lisp

diff --git a/src/ucw/html-description.lisp b/src/ucw/html-description.lisp
index 0a8c205..94a8add 100644
--- a/src/ucw/html-description.lisp
+++ b/src/ucw/html-description.lisp
@@ -4,11 +4,10 @@
 
 (defvar *escape-html* t)
 
-(defmethod generic-format ((display lol-ucw:component) string &rest args)
+(defmethod generic-format ((display ucw-core:component) string &rest args)
   (<:as-html (with-output-to-string (stream)
 	       (apply #'call-next-method stream string args))))
       
-
 (define-description html-description ()
   ())
 
@@ -24,7 +23,9 @@
 (define-layered-class html-attribute ()
   ((css-class :accessor attribute-css-class 
 	      :initform "lol-attribute")
-   (dom-id :accessor attribute-dom-id :initform nil)))
+   (dom-id :accessor attribute-dom-id :initform nil)
+   (value-tag :accessor attribute-html-tag :initform nil :initarg :html-tag)
+   (display-empty-label :accessor attribute-display-empty-label-p :initarg :display-empty-label-p :initform t)))
 
 (define-layered-class standard-attribute
   :in-layer #.(defining-description 'html-description)
@@ -33,38 +34,40 @@
 
 (define-layered-function display-html-attribute-label (object attribute)
   (:method (object attribute)
+    
     (let ((label (attribute-label attribute)))
-      	   (<:label 
+      (when (or label (attribute-display-empty-label-p attribute))
+      	   (<:td (<:label 
 	    :class "lol-attribute-label"
 	    (when label 
 	      (<:as-html 
 	       (with-output-to-string (*display*)
-		 (display-attribute-label attribute)))))))
+		 (display-attribute-label attribute)))))))))
   (:method 
       :in-layer #.(defining-description 'inline)
       (object attribute)
     (let ((label (attribute-label attribute)))
       (when label
-		 (<:as-html 
-	  (with-output-to-string (*display*)
-	    (display-attribute-label attribute)))))))
+	(<:as-html (display-attribute-label attribute))))))
 
 (define-layered-function display-html-attribute-value (object attribute)
   (:method (object attribute)
-    (<:span 
-	:class "lol-attribute-value"
-	(<:as-html   
-	 (display-attribute-value attribute))))
+
+    (<:td 
+     :class "lol-attribute-value"
+     (<:as-html   
+      (display-attribute-value attribute))))
 
   (:method 
     :in-layer #.(defining-description 'inline) (object attribute)
     (display-attribute-value attribute)))
 
+
 (define-layered-function display-html-attribute (object attribute)
   
   (:method (object attribute)
-    (<:div 
-     :class (attribute-css-class attribute)
+    (<:tr 
+     :class (format nil "~A lol-attribute" (attribute-css-class attribute))
      (when (attribute-dom-id attribute) 
        :id (attribute-dom-id attribute))
      (display-html-attribute-label object attribute)
@@ -77,8 +80,10 @@
        :class (attribute-css-class attribute)
        (when (attribute-dom-id attribute) 
 	 :id (attribute-dom-id attribute))
-       (display-html-attribute-label object attribute)
-       (display-html-attribute-value object attribute))))
+       (<:span :class "lol-attribute-label"
+       (display-html-attribute-label object attribute))
+       (<:span :class "lol-attribute-value"
+       (display-html-attribute-value object attribute)))))
 
 (define-layered-method display-using-description 
   :in-layer #.(defining-description 'html-description)
@@ -87,25 +92,46 @@
  (display-html-attribute object attribute))
 
 
+(defun capture-description (attribute function)
+   (let ((obj (described-object (attribute-description attribute))))
+   (lambda (&rest args)
+     (dletf (((described-object attribute) obj))
+       (apply function args)))))
+
 (defun make-attribute-value-writer (attribute)
- (let ((obj (described-object (attribute-description attribute))))
+ (let ((obj (described-object (attribute-description attribute)))
+       (value (attribute-value attribute)))
    (lambda (val)
      (dletf (((described-object attribute) obj))
-       (setf (attribute-value attribute) 
-	     (parse-attribute-value attribute val))))))
+       (with-active-descriptions (editable)
+	 (unless (and (unbound-slot-value-p value)
+		      (equal "" val))
+	 (setf (attribute-value attribute) 
+	     (parse-attribute-value attribute val))))))))
 
 
+(defmethod html-attribute-value (attribute)
+  (let ((val (attribute-value attribute)))
+    (if (unbound-slot-value-p val)
+	""
+	val)))
+
 (defmethod display-html-attribute-editor (attribute editor)
-  (<lol:input :type "text"
-	      :reader (attribute-value attribute)
+  (<ucw:input :type "text"
+	      :reader (html-attribute-value attribute)
 	      :writer (make-attribute-value-writer attribute)))
 
+(defmethod display-html-attribute-editor ((attribute slot-definition-attribute) editor)
+  (call-next-method))
+
 (defmethod display-html-attribute-editor (attribute (editor password-attribute-editor))
-  (<lol:input :type "password"
-	      :reader (attribute-value attribute)
+  (<ucw:input :type "password"
+	      :reader (html-attribute-value attribute)
 	      :writer (make-attribute-value-writer attribute)))
 
 
+
+
 (define-layered-method display-attribute-editor 
    :in-layer #.(defining-description 'html-description) (attribute)
    (display-html-attribute-editor attribute (attribute-editor attribute)))
@@ -114,46 +140,24 @@
 (define-layered-method display-html-attribute-value 
   :in-layer #.(defining-description 'editable) (object attribute)
 
-    (<:span 
-	:class "lol-attribute-value"
+
     (if (attribute-editp attribute)	
-	(display-attribute-editor attribute)
-    
-	(call-next-method))))		
+	    (<:td
+	     :class "lol-attribute-value"(display-attribute-editor attribute))
+	(call-next-method)))
 
 (define-layered-function display-html-description (description display object &optional next-method)
   (:method (description display object &optional (next-method #'display-using-description))
-    (<:style
-     (<:as-html "
-
-div.lol-description .lol-attribute-label, 
-div.lol-description .lol-attribute-value {
-      display: block;
-      width: 69%;
-      float: left;
-      margin-bottom: 1em;
-
-}
-div.lol-description 
-.lol-attribute-label {
-     text-align: right;
-     width: 24%;
-     padding-right: 20px;
-}
-
-
-div.lol-description 
-br {
-clear: left;
-}"))
+    
 		       
     (with-attributes (css-class dom-id) description
    
 
-      (<:div 
+      (<:table
        :class (list (attribute-value css-class) "lol-description" "t")
        :id    (attribute-value dom-id)
-       (funcall next-method)))))
+       (funcall next-method)
+       (<:br :class "clear")))))
 		       
 
 (define-layered-method display-html-description 
@@ -167,17 +171,17 @@ clear: left;
 
 (define-display 
   :in-description html-description ((description t) 
-				    (display lol-ucw:component) 
+				    (display ucw-core:component) 
 				    object)
   (display-html-description description display object (lambda ()
 							 (call-next-method))))
 
-
-
-
-
-     
-      
-  
-		
-  
+(define-layered-method display-html-attribute-value 
+  (object (attribute list-attribute))
+  (let ((val (attribute-value attribute)))
+    (when (listp  val) 
+      (<:ul
+       (arnesi:dolist* (item (attribute-value attribute))
+
+	 (dletf (((attribute-object attribute) item))
+	   (<:li (apply #'display *display* item (slot-value attribute 'item-args)))))))))
\ No newline at end of file