added ROFL test cases + extra formatting hooks for attributes

darcs-hash:20080404174358-39164-4dfd7751ed2a64ded2d0c91044336069a1fd8f32.gz

diff --git a/lisp-on-lines-ucw.asd b/lisp-on-lines-ucw.asd
index 5164fdc..5abc5d4 100644 (file)
--- a/lisp-on-lines-ucw.asd
+++ b/lisp-on-lines-ucw.asd
@@ -11,9 +11,12 @@
                        :components
                        ((:module :ucw
                                  :components ((:file "packages")
                        :components
                        ((:module :ucw
                                  :components ((:file "packages")

-                                              (:file "standard-components")

                                               (:file "lol-tags")
                                               (:file "lol-tags")

-                                              (:file "html-description"))
+                                              (:file "standard-components")
+                                              (:file "contextl-components")
+                                              (:file "html-description")
+                                              (:file "lol-components")
+                                              )

                        
                                  :serial t))))
   :serial t
                        
                                  :serial t))))
   :serial t

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
index a3181f2..b0cbff9 100644 (file)
--- a/lisp-on-lines.asd
+++ b/lisp-on-lines.asd
@@ -66,7 +66,9 @@ OTHER DEALINGS IN THE SOFTWARE."
                                     
                                     :serial t))
   :serial t
                                     
                                     :serial t))
   :serial t

-  :depends-on (:contextl :arnesi :alexandria :postmodern))
+  :depends-on (:contextl :arnesi :alexandria 
+                        ;;for rofl:
+                        :postmodern :simple-date))

 
 
 
 
 
 


@@ -77,6 +79,7 @@ OTHER DEALINGS IN THE SOFTWARE."
                                     (:file "description-test")
                                     (:file "attribute-test")
                                     (:file "display-test")
                                     (:file "description-test")
                                     (:file "attribute-test")
                                     (:file "display-test")

+                                    (:file "rofl-test")

                                     (:module :ucw
                                      :components ((:file "ucw-test"))
                                      :serial t))
                                     (:module :ucw
                                      :components ((:file "ucw-test"))
                                      :serial t))

diff --git a/src/attribute-test.lisp b/src/attribute-test.lisp
index 0cff6eb..74caa00 100644 (file)
--- a/src/attribute-test.lisp
+++ b/src/attribute-test.lisp
@@ -50,10 +50,6 @@
 
 (deftest (test-attribute-with-different-class :compile-before-run t) ()
   (eval '(progn 
 
 (deftest (test-attribute-with-different-class :compile-before-run t) ()
   (eval '(progn 

-;;;; We cannot ever redefine this class ic think... 
-;;; as attributes are also slot meta-objects.
-
-

          (define-layered-class
                test-attribute-class (lol::standard-attribute)
                ((some-slot :initarg :some-slot 
          (define-layered-class
                test-attribute-class (lol::standard-attribute)
                ((some-slot :initarg :some-slot 


@@ -70,6 +66,20 @@
            (find-class 'test-attribute-class)))
     (is (equalp "BRILLANT!" (some-slot a)))))
 
            (find-class 'test-attribute-class)))
     (is (equalp "BRILLANT!" (some-slot a)))))
 

+(deftest (test-attribute-with-different-class-and-subclassed-description :compile-before-run t) ()
+  (test-attribute-with-different-class)
+  (eval '(progn          
+         (define-description test-attribute-with-different-class-description-sub 
+             (test-attribute-with-different-class-description)
+           ())))
+
+  (let* ((d (find-description 'test-attribute-with-different-class-description-sub))
+
+        (a (find-attribute d 'attribute-with-different-class)))
+    (is (eq (class-of a)
+           (find-class 'test-attribute-class)))
+    (is (equalp "BRILLANT!" (some-slot a)))))
+

 
              
     
 
              
     

diff --git a/src/attribute.lisp b/src/attribute.lisp
index e93ef93..210b36d 100644 (file)
--- a/src/attribute.lisp
+++ b/src/attribute.lisp
@@ -55,7 +55,7 @@
     (unbound-slot () 
       (or 
        *init-time-description*
     (unbound-slot () 
       (or 
        *init-time-description*

-q       (call-next-method)))))
+       (call-next-method)))))

 
 (define-layered-class attribute ()
  ((description :initarg :description 
 
 (define-layered-class attribute ()
  ((description :initarg :description 


@@ -69,8 +69,7 @@ q       (call-next-method)))))
   (attribute-class 
    :accessor attribute-class 
    :initarg :attribute-class 
   (attribute-class 
    :accessor attribute-class 
    :initarg :attribute-class 

-   :initform 'standard-attribute
-   :layered t)
+   :initform 'standard-attribute)

   (keyword
    :layered-accessor attribute-keyword
    :initarg :keyword
   (keyword
    :layered-accessor attribute-keyword
    :initarg :keyword


@@ -82,8 +81,6 @@ q       (call-next-method)))))
    :special t)))
 
 
    :special t)))
 
 

-     
-                        

 (define-layered-class standard-attribute (attribute)
  ((label 
    :layered-accessor attribute-label 
 (define-layered-class standard-attribute (attribute)
  ((label 
    :layered-accessor attribute-label 


@@ -91,16 +88,28 @@ q       (call-next-method)))))
    :initform nil
    :layered t
    :special t)
    :initform nil
    :layered t
    :special t)

+  (label-formatter 
+   :layered-accessor attribute-label-formatter
+   :initarg :label-formatter
+   :initform  nil 
+   :layered t
+   :special t)

   (function 
    :initarg :function 
    :layered-accessor attribute-function
    :layered t
    :special t)
   (function 
    :initarg :function 
    :layered-accessor attribute-function
    :layered t
    :special t)

-   (value 
-    :layered-accessor attribute-value 
-    :initarg :value
-    :layered t
-    :special t)
+  (value 
+   :layered-accessor attribute-value 
+   :initarg :value
+   :layered t
+   :special t)
+  (value-formatter 
+   :layered-accessor attribute-value-formatter
+   :initarg :value-formatter
+   :initform nil
+   :layered t
+   :special t)

   (activep 
    :layered-accessor attribute-active-p
    :initarg :activep ;depreciated
   (activep 
    :layered-accessor attribute-active-p
    :initarg :activep ;depreciated


@@ -109,7 +118,33 @@ q       (call-next-method)))))
    :layered t
    :special t
    :documentation
    :layered t
    :special t
    :documentation

-   "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.")))
+   "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.")
+  (active-attributes :layered-accessor attribute-active-attributes
+                      :initarg :attributes
+                      :layered t
+                      :special t)
+  (active-descriptions :layered-accessor attribute-active-descriptions
+                      :initarg :activate
+                      :initform nil
+                      :layered t
+                      :special t)
+  (inactive-descriptions :layered-accessor attribute-inactive-descriptions
+                      :initarg :deactivate
+                      :initform nil
+                      :layered t
+                      :special t)))
+
+(define-layered-method attribute-label-formatter :around (attribute)
+   (or (slot-value attribute 'label-formatter) 
+       (attribute-value (find-attribute (attribute-description attribute) 'label-formatter))
+       (error "No Formatter .. fool!")))
+
+(define-layered-method attribute-value-formatter :around (attribute)
+                      
+   (or (slot-value attribute 'value-formatter) 
+       (attribute-value (find-attribute (attribute-description attribute) 'value-formatter))
+       (error "No Formatter .. fool!")))
+                      

 
 
 (define-layered-method attribute-object ((attribute standard-attribute))
 
 
 (define-layered-method attribute-object ((attribute standard-attribute))


@@ -118,10 +153,11 @@ q       (call-next-method)))))
      (described-object (attribute-description attribute))))
 
 
      (described-object (attribute-description attribute))))
 
 

+(define-layered-function attribute-value-using-object (object attribute))
+(define-layered-function (setf attribute-value-using-object) (value object attribute))
+

 (define-layered-method attribute-value ((attribute standard-attribute))
  (attribute-value-using-object (attribute-object attribute) attribute))
 (define-layered-method attribute-value ((attribute standard-attribute))
  (attribute-value-using-object (attribute-object attribute) attribute))

-                      
-(define-layered-function attribute-value-using-object (object attribute))

 
 (define-layered-method attribute-value-using-object (object attribute)
  (let ((fn (handler-case (attribute-function attribute)
 
 (define-layered-method attribute-value-using-object (object attribute)
  (let ((fn (handler-case (attribute-function attribute)


@@ -130,6 +166,14 @@ q       (call-next-method)))))
        (funcall fn object)
        (slot-value attribute 'value))))
 
        (funcall fn object)
        (slot-value attribute 'value))))
 

+(define-layered-method (setf attribute-value) (value (attribute standard-attribute))
+ (setf (attribute-value-using-object (attribute-object attribute) attribute) value))
+
+(define-layered-method (setf attribute-value-using-object) (value object attribute)
+ (error "No (SETF ATTRIBUTE-VALUE-USING-OBJECT) for ~A ~A and we are not editable"
+       object attribute))
+
+

 (defun ensure-access-function (class attribute property)
   (with-function-access 
     (if (slot-definition-specialp property)
 (defun ensure-access-function (class attribute property)
   (with-function-access 
     (if (slot-definition-specialp property)


@@ -255,6 +299,8 @@ q       (call-next-method)))))
   (:method ((attribute standard-attribute) initarg)
     nil)
   (:method ((attribute standard-attribute) (initarg (eql :function)))
   (:method ((attribute standard-attribute) initarg)
     nil)
   (:method ((attribute standard-attribute) (initarg (eql :function)))

+    t)
+  (:method ((attribute standard-attribute) (initarg (eql :value)))

     t))
 
 (defun prepare-initargs (att args)
     t))
 
 (defun prepare-initargs (att args)


@@ -271,7 +317,9 @@ q       (call-next-method)))))
   (attribute-value *object* attribute))
 
 (defmacro with-attributes (names description &body body)
   (attribute-value *object* attribute))
 
 (defmacro with-attributes (names description &body body)

-  `(with-slots ,names ,description ,@body))  
+  `(let ,(loop for name in names collect 
+             (list name `(find-attribute ,description ',name)))
+     ,@body))q

 
 
 
 
 
 

diff --git a/src/contextl-hacks.lisp b/src/contextl-hacks.lisp
index ee4e38a..b6af05e 100644 (file)
--- a/src/contextl-hacks.lisp
+++ b/src/contextl-hacks.lisp
@@ -1,5 +1,31 @@
 (in-package :contextl)
 
 (in-package :contextl)
 

+
+
+
+;;; HACK:
+;;; Since i'm not using deflayer, ensure-layer etc, 
+;;; There are a few places where contextl gets confused 
+;;; trying to locate my description layers.
+
+;;; TODO: investigate switching to deflayer!
+
+(defun contextl::prepare-layer (layer)
+  (if (symbolp layer)
+      (if (eq (symbol-package layer)
+         (find-package :description-definers))
+         layer
+         (contextl::defining-layer layer))
+      
+      layer))
+
+(defmethod find-layer-class :around ((layer symbol) &optional errorp environment)
+  (if (eq (symbol-package layer)
+         (find-package :description-definers))
+      (find-class layer)
+      (call-next-method)))
+
+

 ;;; HACK: We are ending up with classes named NIL in the superclass list.
 ;;; These cannot be given the special object superclass when re-initializing
 ;;; is it will be in the subclasses superclasses AFTER this class, causing
 ;;; HACK: We are ending up with classes named NIL in the superclass list.
 ;;; These cannot be given the special object superclass when re-initializing
 ;;; is it will be in the subclasses superclasses AFTER this class, causing

diff --git a/src/description-class.lisp b/src/description-class.lisp
index 7e364e3..fb6e7ff 100644 (file)
--- a/src/description-class.lisp
+++ b/src/description-class.lisp
@@ -4,27 +4,6 @@
 ;;;; A description is an object which is used 
 ;;;; to describe another object.
 
 ;;;; A description is an object which is used 
 ;;;; to describe another object.
 

-;;; HACK:
-;;; Since i'm not using deflayer, ensure-layer etc, 
-;;; There are a few places where contextl gets confused 
-;;; trying to locate my description layers.
-
-;;; TODO: investigate switching to deflayer!
-
-(defun contextl::prepare-layer (layer)
-  (if (symbolp layer)
-      (if (eq (symbol-package layer)
-         (find-package :description-definers))
-         layer
-         (contextl::defining-layer layer))
-      
-      layer))
-
-(defmethod find-layer-class :around ((layer symbol) &optional errorp environment)
-  (if (eq (symbol-package layer)
-         (find-package :description-definers))
-      (find-class layer)
-      (call-next-method)))

 
 ;;; #+HACK
 ;;; I'm having some 'issues' with 
 
 ;;; #+HACK
 ;;; I'm having some 'issues' with 


@@ -58,17 +37,25 @@
     attribute))
 
 (defmethod slot-value-using-class ((class description-access-class) object slotd)
     attribute))
 
 (defmethod slot-value-using-class ((class description-access-class) object slotd)

-  (if (or 
+        (call-next-method)
+#+nil  (if (or 

        (eq (slot-definition-name slotd) 'described-object)
        (not (slot-boundp slotd 'attribute-object)))
       (call-next-method)
       (slot-definition-attribute-object slotd)))
     
 
        (eq (slot-definition-name slotd) 'described-object)
        (not (slot-boundp slotd 'attribute-object)))
       (call-next-method)
       (slot-definition-attribute-object slotd)))
     
 

+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defparameter *description-attributes* (make-hash-table)))
+
+
+

 (defclass standard-description-class (description-access-class layered-class)
 (defclass standard-description-class (description-access-class layered-class)

-  ()
+  ((attributes :accessor description-class-attributes :initform (list)))

   (:default-initargs :defining-metaclass 'description-access-class))
 
   (:default-initargs :defining-metaclass 'description-access-class))
 

+
+

 (defmethod validate-superclass
            ((class standard-description-class)
             (superclass standard-class))
 (defmethod validate-superclass
            ((class standard-description-class)
             (superclass standard-class))


@@ -80,9 +67,74 @@
 
 (defun description-class-name  (description-class)
     (read-from-string (symbol-name (class-name description-class))))
 
 (defun description-class-name  (description-class)
     (read-from-string (symbol-name (class-name description-class))))

+
+(defgeneric standard-description-p (description-candidate)
+  (:method (not-description)
+    NIL)
+  (:method ((description standard-description-object))
+    T))

   
 (defun initialize-description-class (class)
 
   
 (defun initialize-description-class (class)
 

+;;; HACK: initialization does not happ   en properly 
+;;; when compiling and loading or something like that.
+;;; Obviously i'm not sure why.
+;;; So we're going to explicitly initialize things.
+;;; For now. --drewc
+
+  (pushnew class *defined-descriptions*)
+
+;;; ENDHACK.
+  
+  (let* ((description (find-layer class)) 
+        (attribute-objects 
+         (setf (description-class-attributes (class-of description))
+               (mapcar 
+                (lambda (slot)
+                  (or (find-attribute description 
+                                      (slot-definition-name slot))
+                      (let* ((*init-time-description* description)
+                             (attribute-class (or 
+                                               (ignore-errors 
+                                                 (slot-value-using-class 
+                                                  (class-of description) description slot))
+                                               'standard-attribute))
+                             (attribute                     
+                              (apply #'make-instance 
+                                     attribute-class
+                                     :description description
+                                     :attribute-class attribute-class
+                                     (attribute-object-initargs slot))))
+                        (setf (slot-definition-attribute-object slot) attribute))))
+                (remove 'described-object (class-slots (class-of description))
+                        :key #'slot-definition-name))))
+        (defining-classes 
+         (partial-class-defining-classes class)))
+
+    (loop 
+       :for (layer class) 
+       :on  defining-classes :by #'cddr 
+       :do (funcall-with-layer-context 
+           (adjoin-layer (find-layer layer) (current-layer-context))
+           (lambda ()
+             (loop :for direct-slot :in (class-direct-slots class) 
+                :do (let ((attribute 
+                           (find (slot-definition-name direct-slot) 
+                                 attribute-objects 
+                                 :key #'attribute-name)))
+                      (let ((initargs 
+                             (prepare-initargs attribute (direct-attribute-properties direct-slot))))
+                        
+                        (apply #'reinitialize-instance attribute 
+                               initargs )
+                        (setf (slot-value description (attribute-name attribute)) 
+                              (attribute-class attribute))
+                        (apply #'change-class attribute  (attribute-class attribute)
+                               initargs)))))))))
+
+
+#+old(defun initialize-description-class (class)
+

 ;;; HACK: initialization does not happ   en properly 
 ;;; when compiling and loading or something like that.
 ;;; Obviously i'm not sure why.
 ;;; HACK: initialization does not happ   en properly 
 ;;; when compiling and loading or something like that.
 ;;; Obviously i'm not sure why.


@@ -98,11 +150,12 @@
          (mapcar 
           (lambda (slot)
             (let* ((*init-time-description* description)
          (mapcar 
           (lambda (slot)
             (let* ((*init-time-description* description)

-                         (attribute                 (apply #'make-instance 
+                         (attribute                 
+                          (apply #'make-instance 

                            'standard-attribute
                            :description description
                            (attribute-object-initargs slot))))
                            'standard-attribute
                            :description description
                            (attribute-object-initargs slot))))

-                    
+              

                     
               (setf (slot-definition-attribute-object slot) attribute)))
           (remove 'described-object (class-slots (class-of description))
                     
               (setf (slot-definition-attribute-object slot) attribute)))
           (remove 'described-object (class-slots (class-of description))


@@ -125,14 +178,13 @@
                         
                         (apply #'reinitialize-instance attribute 
                                initargs )
                         
                         (apply #'reinitialize-instance attribute 
                                initargs )

+                        (warn "Attribute class for ~A is ~A" attribute (attribute-class attribute))

                         (when (not (eq (find-class (attribute-class attribute))
                                        (class-of attribute)))
                         (when (not (eq (find-class (attribute-class attribute))
                                        (class-of attribute)))

+                          (warn "~%CHANGING CLASS~%")

                           
                           (apply #'change-class attribute  (attribute-class attribute) 
                           
                           (apply #'change-class attribute  (attribute-class attribute) 

-                                 initargs)))
-                      
-
-                      )))))))
+                                 initargs))))))))))

 
 ;;;; HACK: run this at startup till we figure things out.
 (defun initialize-descriptions () 
 
 ;;;; HACK: run this at startup till we figure things out.
 (defun initialize-descriptions () 

diff --git a/src/description.lisp b/src/description.lisp
index ae5850c..710771f 100644 (file)
--- a/src/description.lisp
+++ b/src/description.lisp
@@ -7,20 +7,24 @@
 (defun description-print-name (description)
   (description-class-name (class-of description)))
 
 (defun description-print-name (description)
   (description-class-name (class-of description)))
 

-(defun find-attribute (description attribute-name)
-  (when (slot-exists-p description attribute-name) 
-    (slot-value description attribute-name)))
-
-

 (defun description-attributes (description)
 (defun description-attributes (description)

-  (let ((class (class-of description)))
-    (loop :for slot :in (class-slots class)
-       :if (and 
-               (not (eq 'described-object 
-                        (slot-definition-name slot))))
-       :collect (slot-definition-attribute-object slot))))
-
+  (description-class-attributes (class-of description)))

 
 

+(defun find-attribute (description attribute-name)
+  (find attribute-name (description-attributes description)
+       :key #'attribute-name))
+
+(define-layered-function description-active-descriptions (description)
+  (:method ((description standard-description-object))
+    (attribute-value (find-attribute description 'active-descriptions)))
+  (:method ((description attribute))
+    (attribute-active-descriptions description)))
+
+(define-layered-function description-inactive-descriptions (description)
+  (:method ((description standard-description-object))
+    (attribute-value (find-attribute description 'inactive-descriptions)))
+  (:method ((description attribute))
+    (attribute-inactive-descriptions description)))

 
 (define-layered-function attributes (description)
   (:method (description)
 
 (define-layered-function attributes (description)
   (:method (description)

diff --git a/src/display.lisp b/src/display.lisp
index f9998a7..423ee8c 100644 (file)
--- a/src/display.lisp
+++ b/src/display.lisp
@@ -4,16 +4,30 @@
 (defvar *display*)
 (defvar *object* nil)
 
 (defvar *display*)
 (defvar *object* nil)
 

-
-(deflayer display-layer)
-

 (define-layered-function display-using-description (description display object &rest args)
   (:documentation
    "Displays OBJECT via description using/in/with/on display"))
 
 (define-layered-function display-using-description (description display object &rest args)
   (:documentation
    "Displays OBJECT via description using/in/with/on display"))
 

-(defun display (display object &rest args &key attributes )
-  (let ((*display-attributes* attributes))
-    (apply #'display-using-description (description-of object) display object args)))
+
+
+(defun modify-layer-context (context &key activate deactivate)
+  (dolist (d deactivate)
+    (setf context (remove-layer (find-description d)
+                               context)))
+  (dolist (d activate context)
+    (setf context (adjoin-layer (find-description d)
+                               context))))
+  
+
+
+
+(defun display (display object &rest args &key deactivate activate &allow-other-keys)
+  (funcall-with-layer-context 
+   (modify-layer-context (current-layer-context) 
+                        :activate activate 
+                        :deactivate deactivate)
+   (lambda () 
+     (apply #'display-using-description (description-of object) display object args))))

 
 (define-layered-method display-using-description 
   :around (description display object &rest args)
 
 (define-layered-method display-using-description 
   :around (description display object &rest args)


@@ -21,26 +35,37 @@
   (let ((*description* description)
        (*display* display)
        (*object*  object))
   (let ((*description* description)
        (*display* display)
        (*object*  object))

+;    (<:as-html " " description "Layer Active?: "  (layer-active-p (defining-description 'maxclaims::link-to-viewer)))

     (dletf (((described-object description) object))
     (dletf (((described-object description) object))

-    (contextl::funcall-with-special-initargs  
-      (loop 
-        :for (key val) :on args :by #'cddr
-        :collect (list (find key (description-attributes description) 
-                             :key #'attribute-keyword)
-                       :value val))
-      (lambda ()
-       (contextl::funcall-with-special-initargs  
-        (let ((attribute (find-attribute description 'active-attributes)))     
-          (when attribute
-            (loop for spec in (attribute-value attribute)
-                 if (listp spec)
-                 collect (cons (or 
-                                (find-attribute description (car spec))
-                                                (error "No attribute matching ~A" (car spec)))
-                                (cdr spec)))))
-     (lambda ()
-       (call-next-method))))))))
-                             
+      (flet ((do-display ()
+              (contextl::funcall-with-special-initargs  
+               (loop 
+                  :for (key val) :on args :by #'cddr
+                  :collect (list (find key (description-attributes description) 
+                                       :key #'attribute-keyword)
+                                 :value val))
+               (lambda ()
+                 (contextl::funcall-with-special-initargs  
+                  (let ((attribute (ignore-errors (find-attribute description 'active-attributes))))   
+                    (when attribute
+                      (loop for spec in (attribute-value attribute)
+                         if (listp spec)
+                         collect (cons (or 
+                                        (find-attribute description (car spec))
+                                        (error "No attribute matching ~A" (car spec)))
+                                       (cdr spec)))))
+                  (lambda () (call-next-method)))))))
+       (funcall-with-layer-context
+        (modify-layer-context 
+         (if (standard-description-p description)
+             (adjoin-layer description (current-layer-context))
+             (current-layer-context))
+         :activate (description-active-descriptions description)
+         :deactivate (description-inactive-descriptions description))
+        (function do-display))))))
+
+
+

 
 
 (defun display/d (&rest args)
 
 
 (defun display/d (&rest args)

diff --git a/src/packages.lisp b/src/packages.lisp
index b10abdb..21d2151 100644 (file)
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -10,17 +10,22 @@
 
 ;; ROFL stuff here temporarily
    #:standard-db-access-class
 
 ;; ROFL stuff here temporarily
    #:standard-db-access-class

-   #:make-dao-from-row
+   #:make-object-from-plist

    #:described-db-access-class
    #:select-only
    #:select
    #:described-db-access-class
    #:select-only
    #:select

-
+   #:insert-into   
+   #:select-objects
+   #:select-only-n-objects
+   

 ;; Descriptions
    #:find-description
 ;; Descriptions
    #:find-description

+   #:description-of

    #:define-description
    #:described-object
    #:described-class
    #:with-active-descriptions
    #:define-description
    #:described-object
    #:described-class
    #:with-active-descriptions

+   #:with-inactive-descriptions

 
    ;; Displays
    #:define-display
 
    ;; Displays
    #:define-display


@@ -35,6 +40,7 @@
    #:attributes
    #:attribute-label
    #:attribute-function
    #:attributes
    #:attribute-label
    #:attribute-function

-   #:attribute-value))
+   #:attribute-value
+   #:active-attributes))

 
 
 
 

diff --git a/src/rofl-test.lisp b/src/rofl-test.lisp
new file mode 100644 (file)
index 0000000..97342f4
--- /dev/null
+++ b/src/rofl-test.lisp
@@ -0,0 +1,178 @@
+(in-package :lol-test)
+
+;;;; CREATE USER rofl_test PASSWORD 'rofl_test';
+;;;; CREATE DATABASE rofl_test OWNER rofl_test;
+
+
+(defmacro db (&body body)
+ `(postmodern:with-connection '("rofl_test" "rofl_test" "rofl_test" "localhost")
+    ,@body))
+   
+(deftest test-create-table ()
+  (finishes (db 
+    (postmodern:query (:DROP-TABLE 'rofl_test_base))
+
+    (postmodern:query (:CREATE-TABLE rofl_test_base 
+                      ((rofl_test_base_id :type SERIAL :primary-key t)
+                        (test_string :type string) 
+                       (test_integer :type integer)))))))
+
+(deftest test-simple-insert ()
+  (test-create-table)
+  (let ((plist '(test-string "Test Entry" test-integer 1)))
+    (finishes (db
+               (postmodern:execute 
+                (postmodern:sql-compile  `(:insert-into rofl-test-base :set ,@plist)))))))
+
+(deftest test-rofl-select ()
+  (test-simple-insert)
+  (db 
+  (finishes 
+    (let* ((result (first (select '* :from 'rofl-test-base))))
+      (is (equalp '(:ROFL-TEST-BASE-ID 1 :TEST-STRING "Test Entry" :TEST-INTEGER 1) result))))))
+
+(deftest test-rofl-select-only-1 ()
+  (test-simple-insert)
+  (db 
+  (finishes 
+    (let* ((result (select-only 1 '* :from 'rofl-test-base)))
+      (is (equalp '(:ROFL-TEST-BASE-ID 1 :TEST-STRING "Test Entry" :TEST-INTEGER 1) result))))))
+
+(deftest test-rofl-insert ()
+  (test-create-table)
+  (db 
+    (finishes (insert-into 'rofl-test-base :test-integer 2 :test-string "a"))
+    (finishes (insert-into 'rofl-test-base :test-integer 3 :test-string "b"))
+    (finishes (insert-into 'rofl-test-base :test-integer 4 :test-string "c"))
+    
+    (let ((r (select '* :from 'rofl-test-base)))
+      (is (equal 3 (length r))))))
+
+(deftest test-rofl-class-creation ()
+  (finishes (eval '(progn 
+                   (setf (find-class 'rofl-test-base) nil)
+                   (defclass rofl-test-base ()
+                     ((rofl-test-base-id :primary-key t)
+                      test-integer test-string)
+                     (:metaclass standard-db-access-class))))))
+
+
+(deftest test-rofl-make-object-from-plist ()
+  (test-rofl-class-creation)
+  (let* ((plist '(:ROFL-TEST-BASE-ID 1 :TEST-STRING "a" :TEST-INTEGER 2))
+        (object (make-object-from-plist 'rofl-test-base plist)))
+    (is (equal (slot-value object 'rofl-test-base-id) 1))))
+    
+
+(deftest test-rofl-select-objects ()
+  (test-create-table)
+  (test-rofl-class-creation)
+  (test-rofl-insert)
+
+  (db (finishes 
+    (let ((objects (select-objects 'rofl-test-base  
+                                :where '(:= rofl-test-base-id 1))))
+      (is (equal (slot-value (first objects) 'rofl-test-base-id) 1))))))
+
+(deftest test-rofl-create-references-tables ()
+  (finishes 
+    (db 
+      (ignore-errors (postmodern:query (:DROP-TABLE 'rofl_test_child)))
+      (ignore-errors (postmodern:query (:DROP-TABLE 'rofl_test_parent)))
+      
+      (postmodern:query (:CREATE-TABLE rofl_test_parent 
+                                      ((rofl_test_parent_id 
+                                        :type SERIAL 
+                                        :primary-key t)
+                                       (test_string 
+                                        :type string) 
+                                               (test_integer 
+                                                :type integer))))
+    
+
+
+             (postmodern:query (:CREATE-TABLE rofl_test_child 
+                                              ((rofl_test_child_id 
+                                                :type SERIAL 
+                                                :primary-key t)
+                                               (rofl_test_parent_id 
+                                                :type integer
+                                                :references (rofl_test_parent))
+                                               (test_string 
+                                                :type string) 
+                                               (test_integer 
+                                                :type integer)))))))
+
+(deftest test-rofl-def-references-classes ()
+  (finishes 
+    (eval 
+     '(progn
+       (defclass rofl-test-parent ()
+        ((rofl-test-parent-id 
+         :primary-key t)
+         (test-string)
+         (test-integer))
+        (:metaclass standard-db-access-class))
+
+       ;;; three ways to get to the parent.
+       ;;; The should all point to the same object.
+
+       (defclass rofl-test-child ()
+        ((rofl-test-child-id 
+         :primary-key t)
+         (rofl-test-parent-id
+          :references rofl-test-parent)
+         (parent :column rofl-test-parent-id 
+                 :references rofl-test-parent)
+         (same-parent :column rofl-test-parent-id
+                      :references (rofl-test-parent . 
+                                   rofl-test-parent-id))
+                      
+         (test-string)
+         (test-integer))
+        (:metaclass standard-db-access-class))))))
+
+(deftest test-rofl-foreign-references ()
+  (test-rofl-create-references-tables)
+  (test-rofl-def-references-classes)
+  (db 
+  (finishes 
+    (insert-into 'rofl-test-parent :test-string "Parent" :test-integer 1)
+    (insert-into 'rofl-test-child :test-string "Child 1" :test-integer 1
+                :rofl-test-parent-id 
+                (slot-value (first (select-objects 'rofl-test-parent)) 'rofl-test-parent-id)))
+  (let* ((child (select-only-n-objects 1 'rofl-test-child))
+        (parent-same-slot-name/fkey (slot-value child 'rofl-test-parent-id))
+        (parent-column-same-fkey (slot-value child 'parent))
+        (parent-column-table-and-key (slot-value child 'same-parent)))
+
+    (is (eql 1 (slot-value child 'test-integer)))
+    
+    (is (equal 1 (slot-value parent-same-slot-name/fkey 'test-integer)))
+    (is (equal 1 (slot-value parent-column-same-fkey 'test-integer)))
+    (is (equal 1 (slot-value parent-column-table-and-key 'test-integer))))))
+
+
+ 
+        
+                   
+
+  
+
+
+  
+
+    
+  
+  
+
+
+                  
+
+   
+    
+
+  
+
+
+  
\ No newline at end of file

diff --git a/src/rofl.lisp b/src/rofl.lisp
index 4982223..3d73725 100644 (file)
--- a/src/rofl.lisp
+++ b/src/rofl.lisp
@@ -1,8 +1,46 @@
 (in-package :lisp-on-lines)
 
 (in-package :lisp-on-lines)
 

+;;;; NB: These could really be in upstream
+
+;;;; * A PLIST reader for postmodern.    
+(postmodern::def-row-reader symbol-plist-row-reader (fields)
+  (let ((symbols (map 'list (lambda (desc) 
+                  (postmodern::from-sql-name (postmodern::field-name desc))) fields)))
+    (loop :while (postmodern::next-row)
+          :collect (loop :for field :across fields
+                         :for symbol :in symbols
+                         :nconc (list symbol (postmodern::next-field field))))))
+
+(s-sql::def-sql-op :between (n start end)
+  `(,@(s-sql::sql-expand n) " BETWEEN " ,@(s-sql::sql-expand start) " AND " ,@(s-sql::sql-expand end)))
+
+(s-sql::def-sql-op :case (&rest clauses)
+  `("CASE " ,@(loop for (test expr) in clauses collect (format nil "WHEN ~A THEN ~A " (s-sql::sql-expand test) (s-sql::sql-expand expr))) "END"))
+
+
+;;;; now the rofl code itself
+(defun %query (query)
+  (cl-postgres:exec-query *database* (sql-compile query) 'symbol-plist-row-reader))
+
+(defun select (&rest query)
+  (%query (cons :select query)))
+
+(defun select-only (num &rest query)
+  (let ((results (%query `(:limit ,(cons :select query) ,num))))
+    (if (eql 1 num)
+       (first results)
+       results)))
+
+(defun insert-into (table &rest values-plist)
+  (postmodern:execute 
+   (postmodern:sql-compile `(:insert-into ,table :set ,@values-plist))))
+    

 
 (defclass db-access-slot-definition ()
 
 (defclass db-access-slot-definition ()

-  ((column-name  :initform nil :initarg :db-name :accessor slot-definition-column-name
+  ((column-name  :initform nil 
+                :initarg :db-name 
+                :initarg :column
+                :accessor slot-definition-column-name

                :documentation
               "If non-NIL, contains the name of the column this slot is representing.")
    (primary-key :initform nil 
                :documentation
               "If non-NIL, contains the name of the column this slot is representing.")
    (primary-key :initform nil 


@@ -34,9 +72,6 @@ that, for some reason, could not be executed. If there's a slot with
 this attribute not-NIL in a class definition, then there's something
 wrong with its SQL counterpart.")))
 
 this attribute not-NIL in a class definition, then there's something
 wrong with its SQL counterpart.")))
 

-(defmethod slot-definition-column-name :around (slotd)
-  (or (call-next-method) (slot-definition-name slotd)))
-

 
 (defclass db-access-class (standard-class)
   ((table-name :initarg :table-name :initform nil :accessor class-table-name)
 
 (defclass db-access-class (standard-class)
   ((table-name :initarg :table-name :initform nil :accessor class-table-name)


@@ -89,6 +124,11 @@ inheritance and does not create any tables for it."))
   (let ((slotd (call-next-method)))
     (setf (slot-definition-primary-key-p slotd) 
          (some #'slot-definition-primary-key-p direct-slot-definitions)
   (let ((slotd (call-next-method)))
     (setf (slot-definition-primary-key-p slotd) 
          (some #'slot-definition-primary-key-p direct-slot-definitions)

+         (slot-definition-column-name slotd)
+         (or (let ((slot (find-if #'slot-definition-column-name direct-slot-definitions)))
+               (when slot
+                 (slot-definition-column-name slot)))
+             name)

          (slot-definition-transient-p slotd) 
          (every #'slot-definition-transient-p direct-slot-definitions)
          (slot-definition-foreign-type slotd) 
          (slot-definition-transient-p slotd) 
          (every #'slot-definition-transient-p direct-slot-definitions)
          (slot-definition-foreign-type slotd) 


@@ -146,6 +186,44 @@ inheritance and does not create any tables for it."))
 (defclass standard-db-access-object (standard-object)
   ())
 
 (defclass standard-db-access-object (standard-object)
   ())
 

+(defun %select-objects (type select-fn query)
+  (mapcar (curry 'make-object-from-plist type)
+         (apply select-fn (intern (format nil "*")) 
+                (if (string-equal (first query) :from)
+                    query
+                    (append `(:from ,type) query)))))
+
+(defun select-objects (type &rest query)
+  (%select-objects type #'select query))
+
+(defun select-only-n-objects (n type &rest query)
+  (let ((results (%query `(:limit ,(cons :select 
+                                        (intern (format nil "*")) 
+                                        (if (string-equal (first query) :from)
+                                            query
+                                            (append `(:from ,type) query))) ,n))))
+    (if (eql 1 n)
+       (make-object-from-plist type (first results))
+       (mapcar (curry 'make-object-from-plist type) results))))
+
+(defun make-object-from-plist (type plist)
+  (let* ((class (find-class type))
+        (object (make-instance class))
+        (slotds (class-slots class)))
+        
+    (loop 
+       :for (key val) :on plist :by #'cddr 
+       :do 
+       (dolist (slotd (remove key slotds 
+                             :key #'slot-definition-column-name
+                             :test-not #'string-equal))
+
+            (setf (slot-value-using-class class object slotd) val))
+       :finally (return (reinitialize-instance object)))))
+
+(defun make-object (type &rest plist)
+  (make-object-from-plist type plist))
+

 
 
 (defun find-dao (type id 
 
 
 (defun find-dao (type id 


@@ -154,20 +232,24 @@ inheritance and does not create any tables for it."))
                             
   "Get the dao corresponding to the given primary key,
 or return nil if it does not exist."
                             
   "Get the dao corresponding to the given primary key,
 or return nil if it does not exist."

-  (let ((row (first (query 
-             (:select '* 
+  (let ((plist 
+             (select-only 1 '* 

               :from table 
               :from table 

-               :where (:= id (or id-column-name
+               :where (list ':= id (or id-column-name

                                 (dao-id-column-name 
                                 (dao-id-column-name 

-                                 (find-class type)))))))))
-    (make-dao-from-row type row)))
+                                 (find-class type)))))))
+    (make-object-from-plist type plist)))

 
 (defmethod shared-initialize :after ((dao standard-db-access-object) 
                                     slots &rest initargs)
 
 (defmethod shared-initialize :after ((dao standard-db-access-object) 
                                     slots &rest initargs)

-  (let ((class (class-of dao)))
+  (let ((class (class-of dao))
+       (foreign-key))

     (dolist (slotd (class-slots class))
       (with-slots (foreign-type) slotd
        (when foreign-type
     (dolist (slotd (class-slots class))
       (with-slots (foreign-type) slotd
        (when foreign-type

+         (when (consp foreign-type)
+           (setf foreign-key (cdr foreign-type)
+                 foreign-type (car foreign-type)))

          (if (slot-boundp-using-class class dao slotd)
              (let ((value (slot-value-using-class class dao slotd)))           
                (unless (typep value foreign-type)
          (if (slot-boundp-using-class class dao slotd)
              (let ((value (slot-value-using-class class dao slotd)))           
                (unless (typep value foreign-type)


@@ -187,28 +269,6 @@ or return nil if it does not exist."
       
       (slot-value-using-class class dao (class-id-slot-definition class)))))
 
       
       (slot-value-using-class class dao (class-id-slot-definition class)))))
 

-(postmodern::def-row-reader symbol-plist-row-reader (fields)
-
-  (let ((symbols (map 'list (lambda (desc) 
-                  (postmodern::from-sql-name (postmodern::field-name desc))) fields)))
-    (loop :while (postmodern::next-row)
-          :collect (loop :for field :across fields
-                         :for symbol :in symbols
-                         :nconc (list symbol (postmodern::next-field field))))))
-
-
-(setf postmodern::*result-styles* 
-      (nconc (list '(:plists symbol-plist-row-reader nil)
-                  '(:plist symbol-plist-row-reader t))
-            postmodern::*result-styles*))
-
-(defun select (&rest query)
-    (query (sql-compile (cons :select query)) :plists))
-
-(defun select-only (num &rest query)
-  (query (sql-compile `(:limit ,(cons :select query) ,num)) 
-        :plists))
-

 (defun make-dao-from-row (type row &key slots)
   (let* ((class (find-class type))
         (dao (make-instance class))
 (defun make-dao-from-row (type row &key slots)
   (let* ((class (find-class type))
         (dao (make-instance class))

diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp
index 0fc53af..dc056a1 100644 (file)
--- a/src/standard-descriptions/clos.lisp
+++ b/src/standard-descriptions/clos.lisp
@@ -14,7 +14,9 @@
                :function (compose 'class-slots 'class-of))))
 
 (define-layered-class slot-definition-attribute (standard-attribute)
                :function (compose 'class-slots 'class-of))))
 
 (define-layered-class slot-definition-attribute (standard-attribute)

- ((slot-name :initarg :slot-name :accessor attribute-slot-name)))
+ ((slot-name :initarg :slot-name 
+            :accessor attribute-slot-name
+            :layered t)))

 
 (defmethod shared-initialize :around ((object slot-definition-attribute) 
                                      slots &rest args)
 
 (defmethod shared-initialize :around ((object slot-definition-attribute) 
                                      slots &rest args)


@@ -29,7 +31,7 @@
   (if (slot-boundp object (attribute-slot-name attribute))
                       
       (slot-value object (attribute-slot-name attribute))
   (if (slot-boundp object (attribute-slot-name attribute))
                       
       (slot-value object (attribute-slot-name attribute))

-      (gensym "UNBOUND-SLOT-")))
+      +unbound-slot+))

 
 (defun ensure-description-for-class (class &optional (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class)))))
   (let ((desc-class 
 
 (defun ensure-description-for-class (class &optional (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class)))))
   (let ((desc-class 


@@ -39,11 +41,12 @@
                                 :collect `(:name ,(slot-definition-name slot) 
                                            :attribute-class slot-definition-attribute
                                            :slot-name ,(slot-definition-name slot)
                                 :collect `(:name ,(slot-definition-name slot) 
                                            :attribute-class slot-definition-attribute
                                            :slot-name ,(slot-definition-name slot)

-                                           :label ,(slot-definition-name slot))
+                                           :label ,(format nil 
+                                                           "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot)))))

                                 :into slots
                                 :collect (slot-definition-name slot) :into names
                                 :finally (return (cons `(:name active-attributes
                                 :into slots
                                 :collect (slot-definition-name slot) :into names
                                 :finally (return (cons `(:name active-attributes

-                                                         :value ,names)
+                                                         :value ',names)

                                                        slots)))        
                :metaclass 'standard-description-class)))
     
                                                        slots)))        
                :metaclass 'standard-description-class)))
     

diff --git a/src/standard-descriptions/edit.lisp b/src/standard-descriptions/edit.lisp
index 6786ceb..0033502 100644 (file)
--- a/src/standard-descriptions/edit.lisp
+++ b/src/standard-descriptions/edit.lisp
@@ -14,12 +14,13 @@
    (class :editp nil))
   (:in-description editable))
 
    (class :editp nil))
   (:in-description editable))
 

-#+nil(define-layered-function (setf attribute-value) (v o a)
-  (:method (value object attribute)
-    (let ((setter (attribute-setter attribute)))
-      (if setter
-         (funcall setter value object)
-         (error "No setter in ~A for ~A" attribute object)))))
+(define-layered-method (setf attribute-value-using-object)
+ :in-layer #.(defining-description 'editable)(value object attribute)
+
+ (let ((setter (attribute-setter attribute)))
+   (if setter
+       (funcall setter value object)
+       (error "No setter in ~A for ~A" attribute object))))

 
 (define-layered-class standard-attribute
   :in-layer #.(defining-description 'editable)
 
 (define-layered-class standard-attribute
   :in-layer #.(defining-description 'editable)


@@ -43,9 +44,9 @@
   (object (attribute standard-attribute))
                       
   (if (eq :inherit (%attribute-editp attribute))
   (object (attribute standard-attribute))
                       
   (if (eq :inherit (%attribute-editp attribute))

-      (attribute-value object (find-attribute 
-                              (attribute-description attribute) 
-                              'editp))
+      (attribute-value (find-attribute 
+                       (attribute-description attribute) 
+                       'editp))

       (%attribute-editp attribute)))
                       
 
       (%attribute-editp attribute)))
                       
 

diff --git a/src/standard-descriptions/inline.lisp b/src/standard-descriptions/inline.lisp
dissimilarity index 67%
index 9d05b65..b620fcd 100644 (file)
--- a/src/standard-descriptions/inline.lisp
+++ b/src/standard-descriptions/inline.lisp
@@ -1,16 +1,19 @@
-(in-package :lisp-on-lines)
-
-(define-description inline ())
-
-(define-description t ()
-  ((identity :label nil)
-   (active-attributes :value (identity)))
-  (:in-description inline))
-
-(define-display :in-description inline ((description t))
-  (format *display* "~{~A ~}" 
-         (mapcar 
-          (lambda (attribute)
-            (with-output-to-string (*display*)
-              (display-attribute *object* attribute)))
-          (attributes description))))
+(in-package :lisp-on-lines)
+
+(define-description inline ())
+
+(define-description t ()
+  ((identity :label nil)
+   (active-attributes :value '(identity))
+   (attribute-delimiter :value ", ")
+   (label-formatter :value (curry #'format nil "~A: "))
+   (value-formatter :value (curry #'format nil "~A")))
+  (:in-description inline))
+
+(define-layered-class standard-attribute
+  :in-layer #.(defining-description 'inline)
+  ()
+  ())
+
+(define-display :in-description inline ((description t))               
+               (call-next-method))

diff --git a/src/standard-descriptions/t.lisp b/src/standard-descriptions/t.lisp
index eff4d4e..e5c6676 100644 (file)
--- a/src/standard-descriptions/t.lisp
+++ b/src/standard-descriptions/t.lisp
@@ -7,41 +7,72 @@
    (active-attributes :label "Attributes"
                      :value nil
                      :activep nil
    (active-attributes :label "Attributes"
                      :value nil
                      :activep nil

-                     :keyword :attributes)))
+                     :keyword :attributes)
+   (attribute-delimiter :label "Attribute Delimiter"
+                       :value "~%"
+                       :activep nil
+                       :keyword :delimter)
+   (active-descriptions :label "Active Descriptions"
+                       :value nil
+                       :activep nil
+                       :keyword :activate)
+   (inactive-descriptions :label "Inactive Descriptions"
+                       :value nil
+                       :activep nil
+                       :keyword :deactivate)
+   (label-formatter :value (curry #'format nil "~A "))
+   (value-formatter :value (curry #'format nil "~A"))))

 
 (define-layered-method description-of (any-lisp-object)
   (find-description 't))
 
 
 (define-layered-method description-of (any-lisp-object)
   (find-description 't))
 

-(define-layered-function display-attribute (object attribute)
-  (:method (object attribute)
-    (display-using-description attribute *display* object)))
+(define-layered-function display-attribute (attribute)
+  (:method (attribute)
+    (display-using-description attribute *display* (attribute-object attribute))))

 
 

-(define-layered-function display-attribute-label (object attribute)
-  (:method (object attribute)
-        (format *display* "~A " (attribute-label attribute))))
+(define-layered-function display-attribute-label (attribute)
+  (:method (attribute)
+    (princ (funcall (attribute-label-formatter attribute) (attribute-label attribute))
+          *display*)))

 
 

-(define-layered-function display-attribute-value (object attribute)
-  (:method (object attribute)
+
+(define-layered-function display-attribute-value (attribute)
+  (:method (attribute)
+    (flet ((disp (val &rest args)
+            (apply #'display *display* val 
+                   :activate (attribute-active-descriptions attribute)
+                   :deactivate (attribute-inactive-descriptions attribute)
+                   args)))
+            

     (let ((val (attribute-value attribute)))
     (let ((val (attribute-value attribute)))

-      (if (eql val object)
-         (format *display* "~A " val)
+      (if (eql val (attribute-object attribute))
+         (generic-format *display* (funcall (attribute-value-formatter attribute) val))

          (with-active-descriptions (inline)
          (with-active-descriptions (inline)

-           (display *display* val))))))
+           (if (slot-boundp attribute 'active-attributes)
+               (disp val :attributes (slot-value attribute 'active-attributes))
+               (disp val))))))))

 
 (define-layered-method display-using-description 
   ((attribute standard-attribute) display object &rest args)
   (declare (ignore args))
   (when (attribute-label attribute)
 
 (define-layered-method display-using-description 
   ((attribute standard-attribute) display object &rest args)
   (declare (ignore args))
   (when (attribute-label attribute)

-    (display-attribute-label object attribute))
-  (display-attribute-value object attribute))
+    (display-attribute-label attribute))
+  (display-attribute-value attribute))

 
 (define-display ((description t))
 
 (define-display ((description t))

-  (format *display* "~{~A~%~}" 
-         (mapcar 
-          (lambda (attribute)
-            (with-output-to-string (*display*)
-              (display-attribute *object* attribute)))
-          (attributes description))))
+ (let ((attributes (attributes description)))
+   (display-attribute (first attributes))
+   (dolist (attribute (rest attributes))
+     (generic-format *display* 
+      (attribute-value 
+       (find-attribute description 'attribute-delimiter)))
+     (display-attribute attribute))))
+  
+
+(define-display :around ((description t) (display null))
+ (with-output-to-string (*display*) 
+   (print (call-next-method) *display*)))              
+

 
 
 
 
 
 

diff --git a/src/ucw/html-description.lisp b/src/ucw/html-description.lisp
index 120d317..f05d010 100644 (file)
--- a/src/ucw/html-description.lisp
+++ b/src/ucw/html-description.lisp
@@ -2,6 +2,13 @@
 
 (export '(html-description) (find-package :lisp-on-lines))
 
 
 (export '(html-description) (find-package :lisp-on-lines))
 

+(defvar *escape-html* t)
+
+(defmethod generic-format ((display lol-ucw:component) string &rest args)
+  (<:as-html (with-output-to-string (stream)
+              (apply #'call-next-method stream string args))))
+      
+

 (define-description html-description ()
   ())
 
 (define-description html-description ()
   ())
 


@@ -32,36 +39,54 @@
            (when label 
              (<:as-html 
               (with-output-to-string (*display*)
            (when label 
              (<:as-html 
               (with-output-to-string (*display*)

-                (display-attribute-label object 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)))))))

 
 (define-layered-function display-html-attribute-value (object attribute)
   (:method (object attribute)
     (<:span 
        :class "lol-attribute-value"
        (<:as-html   
 
 (define-layered-function display-html-attribute-value (object attribute)
   (:method (object attribute)
     (<:span 
        :class "lol-attribute-value"
        (<:as-html   

-        (with-output-to-string (*display*)
-          (display-attribute-value object attribute))))
-))
+        (display-attribute-value attribute))))
+
+  (:method 
+    :in-layer #.(defining-description 'inline) (object attribute)
+    (display-attribute-value attribute)))

 
 (define-layered-function display-html-attribute (object attribute)
 
 (define-layered-function display-html-attribute (object attribute)

+  

   (:method (object attribute)
   (:method (object attribute)

- (<:div 
-       :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)
-       (<:br)))
-  (:method :in-layer #.(defining-description 'inline) 
-          (object attribute)
- (<:span 
+    (<:div 
+     :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)))
+  
+  (:method 
+      :in-layer #.(defining-description 'inline) 
+      (object attribute)
+      (<:span 

        :class (attribute-css-class attribute)
        (when (attribute-dom-id attribute) 
         :id (attribute-dom-id attribute))
        (display-html-attribute-label object attribute)
        :class (attribute-css-class attribute)
        (when (attribute-dom-id attribute) 
         :id (attribute-dom-id attribute))
        (display-html-attribute-label object attribute)

-       (<:as-html " ")
-       (display-html-attribute-value object attribute)
-       (<:as-html " "))))
+       (display-html-attribute-value object attribute))))
+
+(define-layered-method display-using-description 
+  :in-layer #.(defining-description 'html-description)
+  :around ((attribute standard-attribute) display object &rest args)
+ (declare (ignore args))
+ (display-html-attribute object attribute))
+
+

 
 (define-layered-method display-html-attribute-value 
   :in-layer #.(defining-description 'editable) (object attribute)
 
 (define-layered-method display-html-attribute-value 
   :in-layer #.(defining-description 'editable) (object attribute)


@@ -69,14 +94,16 @@
     (<:span 
        :class "lol-attribute-value"
     (if (attribute-editp object attribute)     
     (<:span 
        :class "lol-attribute-value"
     (if (attribute-editp object attribute)     

-    (<lol:input :reader (attribute-value object attribute)
-               :writer (lambda (val)
-                         (setf (attribute-value object attribute) val)))
+    (<lol:input :reader (attribute-value attribute)
+               :writer (let ((obj (described-object (attribute-description attribute))))
+                         (lambda (val)
+                           (dletf (((described-object attribute) obj))
+                             (setf (attribute-value attribute) val)))))

     (call-next-method))
 ))             
 
     (call-next-method))
 ))             
 

-(define-layered-function display-html-description (description display object)
-  (:method (description display object)
+(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 "
 
     (<:style
      (<:as-html "
 


@@ -105,32 +132,31 @@ clear: left;
    
 
       (<:div 
    
 
       (<:div 

-       :class (list (attribute-value* css-class) "lol-description" "t")
-       :id    (attribute-value* dom-id)
-       (unless *object* (error "Object is nil .. why?"))
-       (dolist (attribute (attributes description))
-        (display-html-attribute *object* attribute))))))
+       :class (list (attribute-value css-class) "lol-description" "t")
+       :id    (attribute-value dom-id)
+       (funcall next-method)))))

                       
 
 (define-layered-method display-html-description 
                       
 
 (define-layered-method display-html-description 

-  :in-layer #.(defining-description 'inline) (description display object)
-  
+  :in-layer #.(defining-description 'inline) (description display object &optional next-method)

   (with-attributes (css-class dom-id) description
   (with-attributes (css-class dom-id) description

-   
-

     (<:span
     (<:span

-     :class (list (attribute-value* css-class) "lol-description")
-     :id    (attribute-value* dom-id)
-     (unless *object* (error "Object is nil .. why?"))
-     (dolist (attribute (attributes description))
-       (display-html-attribute *object* attribute))))
-  )
+     :class (list (attribute-value css-class) "lol-description")
+     :id    (attribute-value dom-id)
+     (funcall next-method))))
+

 
 (define-display 
   :in-description html-description ((description t) 
                                    (display lol-ucw:component) 
                                    object)
 
 (define-display 
   :in-description html-description ((description t) 
                                    (display lol-ucw:component) 
                                    object)

-  (display-html-description description display object))
+  (display-html-description description display object (lambda ()
+                                                        (call-next-method))))
+
+
+
+
+

      
       
   
      
       
   

diff --git a/src/ucw/packages.lisp b/src/ucw/packages.lisp
index 172bff9..77a0362 100644 (file)
--- a/src/ucw/packages.lisp
+++ b/src/ucw/packages.lisp
@@ -8,7 +8,10 @@
    #:make-action
    #:standard-action
    #:uri-parse-error
    #:make-action
    #:standard-action
    #:uri-parse-error

-   #:standard-application)
+   #:standard-application
+
+   #:call
+   #:answer)

 
   (:shadowing-import-from :ucw
    #:parent)
 
   (:shadowing-import-from :ucw
    #:parent)


@@ -23,8 +26,9 @@
    #:service)
                
   (:export 
    #:service)
                
   (:export 

-   ;;; Symbols marked ";*" are not from UCW 
-   ;;; but either shadowed or created for lol. 
+
+   ;;; First, LOL-UCW exports. The rest are from UCW.
+   #:lol-component

 
    #:defcomponent
 
 
    #:defcomponent
 


@@ -51,6 +55,7 @@
 
    ;; Actions
    #:call
 
    ;; Actions
    #:call

+   #:answer

    #:make-action
    #:find-action
    #:defaction
    #:make-action
    #:find-action
    #:defaction


@@ -75,6 +80,7 @@
    
    #:standard-window-component ;*
    #:window-body
    
    #:standard-window-component ;*
    #:window-body

+   #:info-message

 
    ))
 
 
    ))
 

diff --git a/src/ucw/standard-components.lisp b/src/ucw/standard-components.lisp
index 361e61e..48eed0d 100644 (file)
--- a/src/ucw/standard-components.lisp
+++ b/src/ucw/standard-components.lisp
@@ -1,15 +1,46 @@
 (in-package :lisp-on-lines-ucw)
 
 (in-package :lisp-on-lines-ucw)
 

+(defparameter *source-component* nil)
+
+(defclass standard-basic-action (basic-action)
+  ((source-component :accessor action-source-component))
+  (:metaclass mopp:funcallable-standard-class))
+
+(defmethod shared-initialize :before ((action standard-basic-action) slots &rest args)
+  (declare (ignore slots args))  
+  (setf (action-source-component action) *source-component*))
+
+(defmethod handle-action :around ((action standard-basic-action) a s f)
+  (let ((*source-component* (action-source-component action)))
+    (call-next-method)))
+
+(defmethod render :around (component)
+  (let ((*source-component* component))
+    (call-next-method)))
+
+
+(defun/cc call (name &rest args)
+  (call-component *source-component* 
+                 (apply #'make-instance name args)))
+
+(defun/cc answer (&optional val)
+  (answer-component *source-component* 
+         val))
+

 (defclass described-component-class (standard-component-class described-class)
   ())
 
 (defmacro defaction (&rest args-and-body)
   `(arnesi:defmethod/cc ,@args-and-body))
 
 (defclass described-component-class (standard-component-class described-class)
   ())
 
 (defmacro defaction (&rest args-and-body)
   `(arnesi:defmethod/cc ,@args-and-body))
 

-(defun make-action (lambda &rest args)
-  (let ((ucw::*default-action-class* 'basic-action))
-    (apply #'ucw::make-action lambda args)))
+(defparameter *default-action-class* 'standard-basic-action)
+
+(defun make-action (lambda &rest initargs &key (class *default-action-class*) &allow-other-keys)
+  "Makes a new unregistered action."
+  (remf-keywords initargs :class)
+  (apply #'make-instance class :lambda lambda initargs))

 
 

+  

 (defclass standard-application (ucw:basic-application)
   ())
 
 (defclass standard-application (ucw:basic-application)
   ())
 


@@ -24,7 +55,6 @@
 (defmethod ucw::find-action-id :around ((context standard-request-context))
   (or 
    (loop
 (defmethod ucw::find-action-id :around ((context standard-request-context))
   (or 
    (loop

-

       :for (k . v) in (ucw::parameters 
                      (context.request context))
       :do(destructuring-bind (param-name &optional action-id)
       :for (k . v) in (ucw::parameters 
                      (context.request context))
       :do(destructuring-bind (param-name &optional action-id)


@@ -46,3 +76,14 @@
 
 (defmethod render-html-body ((window standard-window-component))
   (ucw:render (window-body window)))
 
 (defmethod render-html-body ((window standard-window-component))
   (ucw:render (window-body window)))

+
+(defcomponent info-message ()
+  ((message :accessor message :initarg :message)))
+
+(defmethod render ((m info-message))
+  (<:div
+   :class "info-mssage" 
+   (<:as-html (message m)))
+   (<lol:a :action (answer-component m nil) "Ok"))
+
+

diff --git a/src/ucw/ucw-test.lisp b/src/ucw/ucw-test.lisp
index c1a07f4..04abceb 100644 (file)
--- a/src/ucw/ucw-test.lisp
+++ b/src/ucw/ucw-test.lisp
@@ -93,7 +93,15 @@
    (<:li 
     (<lol:a 
      :action (call-component $component (make-instance 'lol-test-answer))
    (<:li 
     (<lol:a 
      :action (call-component $component (make-instance 'lol-test-answer))

-     "Test CALL/ANSWER"))
+     "Test CALL-COMPONENT/ANSWER-COMPONENT"))
+   (<:li 
+    (<lol:a 
+     :action (call-component $component (make-instance 'lol-test-call-magic))
+     "Test CALL/ANSWER MAGIC"))
+   (<:li 
+    (<lol:a 
+     :action (call-component $component (make-instance 'lol-test-call-answer-action-magic))
+     "Test CALL/ANSWER ACTION MAGIC"))

    (<:li 
     (<lol:a 
      :action (call-component $component (make-instance 'lol-test-simple-form))
    (<:li 
     (<lol:a 
      :action (call-component $component (make-instance 'lol-test-simple-form))


@@ -105,7 +113,8 @@
    (<:li 
     (<lol:a 
      :action (call-component $component (make-instance 'lol-test-input))
    (<:li 
     (<lol:a 
      :action (call-component $component (make-instance 'lol-test-input))

-     "Test Form input"))))
+     "Test Form input"))
+))

 
 (defcomponent lol-test-answer (lol-test-render) ()
   (:default-initargs :message "CALL was ok. Go Back will answer"))
 
 (defcomponent lol-test-answer (lol-test-render) ()
   (:default-initargs :message "CALL was ok. Go Back will answer"))


@@ -154,6 +163,43 @@
 
 
 
 
 
 

+(defcomponent lol-test-call-magic (lol-test-render) 
+ ()          
+  (:default-initargs :message "Testing CALL magic."))
+
+(defmethod render :wrapping ((self lol-test-call-magic))
+  (call-next-method)
+  (<lol:a :action (setf (message self) (call 'lol-test-answer-magic)) "Test CALL")
+  (<:br)
+  (<lol:a :action (answer-component self nil) "Go Back."))
+
+
+
+(defcomponent lol-test-answer-magic (lol-test-render) 
+ ()          
+  (:default-initargs :message "Hit it to answer"))
+
+(defmethod render :wrapping ((self lol-test-answer-magic))
+  (call-next-method)
+  
+  (<lol:a :action (answer "Ja, dat is vut ve answer" ) "IT! (hit here)"))
+
+(defcomponent lol-test-call-answer-action-magic (lol-test-render) 
+ ()          
+  (:default-initargs :message "Hit it to answer"))
+
+(defaction test-call-component ()
+  (call 'lol-test-call-answer-action-magic :message "We made it"))
+
+(defaction test-answer-component ()
+  (answer "We Made IT BACK!!!"))
+
+(defmethod render :wrapping ((self lol-test-call-answer-action-magic))
+  (call-next-method)
+  (<lol:a :action (test-call-component) "Test CALL from ACTION")
+  (<:br)  
+  (<lol:a :action (test-answer-component) "Test ANSWER from ACTION"))
+

 
                      
 
 
                      
 

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 4c78634..f8febce 100644 (file)
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -1,5 +1,12 @@
 (in-package :lisp-on-lines)
 
 (in-package :lisp-on-lines)
 

+(defgeneric generic-format (stream string &rest args)
+  (:method (stream string &rest args)
+    (apply #'format stream string args)))
+
+
+
+

 (defun make-enclosing-package (name)
   (make-package name :use '()))
 
 (defun make-enclosing-package (name)
   (make-package name :use '()))
 


@@ -18,6 +25,12 @@
        `(with-active-layers ,(mapcar #'defining-description descriptions)
          
         ,@body))
        `(with-active-layers ,(mapcar #'defining-description descriptions)
          
         ,@body))

+
+(defmacro with-inactive-descriptions (descriptions &body body)
+       `(with-inactive-layers ,(mapcar #'defining-description descriptions)
+         
+        ,@body))
+

 #|
 Descriptoons are represented as ContextL classes and layers. To avoid nameclashes with other classes or layers, the name of a description is actually mappend to an internal unambiguous name which is used instead of the regular name.
 |#
 #|
 Descriptoons are represented as ContextL classes and layers. To avoid nameclashes with other classes or layers, the name of a description is actually mappend to an internal unambiguous name which is used instead of the regular name.
 |#


@@ -42,6 +55,14 @@ Descriptoons are represented as ContextL classes and layers. To avoid nameclashe
 (defun find-slot-using-initarg (class initarg)
   (cdr (assoc-if #'(lambda (x) (member initarg x))
                                   (initargs.slots class))))
 (defun find-slot-using-initarg (class initarg)
   (cdr (assoc-if #'(lambda (x) (member initarg x))
                                   (initargs.slots class))))

+
+(defun ensure-class-finalized (class)
+  (unless (class-finalized-p class)
+      (finalize-inheritance class)))
+
+(defun superclasses (class)
+  (ensure-class-finalized class)
+  (rest (class-precedence-list class)))