added define-attributes macro

darcs-hash:20050922223808-5417e-7bd17a4e5293ac147e4bb731fbd8317378488e8f.gz

diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp
index 045b7c1..e620130 100644 (file)
--- a/src/mewa/mewa.lisp
+++ b/src/mewa/mewa.lisp
@@ -9,7 +9,7 @@
     number    mewa-currency
     integer   mewa-integer
     currency  mewa-currency
     number    mewa-currency
     integer   mewa-integer
     currency  mewa-currency

-    generalized-boolean mewa-boolean))
+    clsql:generalized-boolean mewa-boolean))

 
 ;;; an alist of model-class-name . attributes
 ;;; should really be a hash-table.
 
 ;;; an alist of model-class-name . attributes
 ;;; should really be a hash-table.


@@ -90,7 +90,7 @@ attributes is an alist keyed on the attribute name."
            (cons (car definition) 
                  (plist-union (cdr definition)
                         (cddr (find-attribute model name))))
            (cons (car definition) 
                  (plist-union (cdr definition)
                         (cddr (find-attribute model name))))

-           definition)))
+           definition))) 

 
 (defmethod perform-set-attributes ((model t) definitions)
   (dolist (def definitions)
 
 (defmethod perform-set-attributes ((model t) definitions)
   (dolist (def definitions)


@@ -105,6 +105,23 @@ attributes is an alist keyed on the attribute name."
 (defmethod perform-set-attribute-properties ((model t) definitions)
   (dolist (def definitions)
     (funcall #'set-attribute-properties model (car def) (cdr def))))
 (defmethod perform-set-attribute-properties ((model t) definitions)
   (dolist (def definitions)
     (funcall #'set-attribute-properties model (car def) (cdr def))))

+
+(defmethod perform-define-attributes ((model t) attributes)
+  (loop for attribute in attributes
+       do (destructuring-bind (name type &rest args)
+                 attribute
+               (cond ((eq type t)
+                      ;;use the existing (default) type
+                      (set-attribute-properties model name args))
+                     ((not (null type))
+                      ;;set the type as well
+                      (set-attribute model name (cons type args)))))))
+                      
+(defmacro define-attributes (models &body attribute-definitions)
+  `(progn
+    ,@(loop for model in models
+           collect `(perform-define-attributes (quote ,model) (quote ,attribute-definitions)))
+  (mapcar #'find-class-attributes (quote ,models ))))

   
 
 (defmethod default-attributes ((model t))
   
 
 (defmethod default-attributes ((model t))


@@ -137,8 +154,6 @@ attributes is an alist keyed on the attribute name."
          
 ;;;presentations 
 
          
 ;;;presentations 
 

-
-

 (defcomponent mewa ()
   ((instance :accessor instance :initarg :instance) 
    (attributes
 (defcomponent mewa ()
   ((instance :accessor instance :initarg :instance) 
    (attributes

diff --git a/src/mewa/packages.lisp b/src/mewa/packages.lisp
index 926cf90..76681d4 100644 (file)
--- a/src/mewa/packages.lisp
+++ b/src/mewa/packages.lisp
@@ -21,6 +21,7 @@
    :has-very-many-slot-presentation
    :has-very-many
    :slot-name
    :has-very-many-slot-presentation
    :has-very-many
    :slot-name

+   :define-attributes

    :find-attribute 
    :set-default-attributes 
    :make-presentation 
    :find-attribute 
    :set-default-attributes 
    :make-presentation 

diff --git a/src/packages.lisp b/src/packages.lisp
index 70401a2..0633ae4 100644 (file)
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -22,12 +22,18 @@
    :perform-set-attributes
    ;;
    :perform-set-attribute-properties
    :perform-set-attributes
    ;;
    :perform-set-attribute-properties

+   :define-attributes

 
    ;; presentation objects
    :mewa-object-presentation
    :mewa-one-line-presentation
    :mewa-list-presentation
 
 
    ;; presentation objects
    :mewa-object-presentation
    :mewa-one-line-presentation
    :mewa-list-presentation
 

+   ;; SLOT presentations
+   :defslot-presentation
+   :slot-name
+   :mewa-relation-slot-presentation
+   :has-many-slot-presentation

    ;; CRUD
    :instance-is-stored-p
 
    ;; CRUD
    :instance-is-stored-p