Import to darcs

darcs-hash:20050603225345-39164-a5bce4ed1fb531cc4d6a69bc1e0c0b1e50661d6e.gz

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
new file mode 100644 (file)
index 0000000..031faa3
--- /dev/null
+++ b/lisp-on-lines.asd
@@ -0,0 +1,37 @@
+;;; -*- lisp -*-
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package :coop.tech.lisp-on-lines.system)
+    (defpackage :coop.tech.lisp-on-lines.system
+      (:documentation "ASDF System package for meta-model.")
+      (:use :common-lisp :asdf))))
+
+(in-package :coop.tech.lisp-on-lines.system)
+
+(defsystem :meta-model
+  :components (
+               (:module :src
+                :components ((:file "packages")
+                             (:file "meta-model" :depends-on ("packages"))))
+              (:module :backend
+                :depends-on (:src)      
+               :pathname "src/backend/"
+               :components ((:file "clsql"))))
+  :depends-on (:clsql))
+
+;; this is no longer used
+(defsystem :meta-model-clsql
+  :components ()
+  :depends-on  (:meta-model :clsql))
+
+(defsystem :mewa
+  :components ((:module :src 
+               :pathname "src/"
+               :components 
+                 ((:file "mewa")
+                  (:file "ucw" :depends-on ("mewa")))))
+  :depends-on (:ucw :meta-model))
+         
+(defsystem :lisp-on-lines
+  :components ((:static-file "lisp-on-lines.asd"))
+:depends-on (:meta-model :mewa))

diff --git a/lisp-on-lines.txt b/lisp-on-lines.txt
new file mode 100644 (file)
index 0000000..6518d61
--- /dev/null
+++ b/lisp-on-lines.txt
@@ -0,0 +1,172 @@
+LISP-ON-LINES 0.1
+
+
+Components:
+       
+Meta Model Protocol - A  Protocol for introspection on relational objects.
+Mewa Presentations : A Mewa-like[1] layer for UncommonWeb[2] Presentations.
+
+Description:            
+
+LISP-ON-LINES (LOL) is a framework for rapid development of complex data-driven web appilcations. 
+Introduction:
+
+
+Example:
+
+First we start with the data model. The Meta Model Protocol (MMP) is used to provide information on the data objects and how they relate to one another. Its is currently implemented as a layer over CLSQL[3], although support is planned for other backends (CLOS,Elephant[4], whatever).
+
+The MMP shares its definition syntax with CLSQL's Object Oriented Data Definition Language (OODDL). The macro to define view-classes is named DEF-VIEW-CLASS/META, and takes the same arguments as DEF-VIEW-CLASS from CLSQL. For the purposes of this simple example, we will only need two functions from the MMP beyond what CLSQL provides : LIST-SLOTS and LIST-SLOT-TYPES[5].
+
+We'll define a simple class to hold a user.
+LISP-ON-LINES> (def-view-class/meta user () 
+                ((userid  :initarg :userid :accessor userid :type integer :db-kind :key)
+                 (username :initarg :username :accessor username  :type string :db-kind :base)
+                 (password :initarg :password :accessor password :type string :db-kind :base)))
+STYLE-WARNING: redefining META-MODEL.METADATA (USER) in DEFMETHOD
+#<CLSQL-SYS::STANDARD-DB-CLASS USER>
+LISP-ON-LINES> (defparameter user (make-instance 'user :userid 1 :username "drewc" :password "p@ssw0rd"))
+USER
+LISP-ON-LINES> (list-slots user)
+(USERID USERNAME PASSWORD)
+LISP-ON-LINES> (list-slot-types user)
+((USERID INTEGER) (USERNAME STRING) (PASSWORD STRING))
+; compiling file "/tmp/fileQQsHyN" (written 03 JUN 2005 03:20:06 PM):
+
+; /tmp/fileQQsHyN.fasl written
+; compilation finished in 0:00:00
+LISP-ON-LINES> (default-attributes user)
+((USERID INTEGER :LABEL "USERID" :SLOT-NAME USERID)
+ (USERNAME STRING :LABEL "USERNAME" :SLOT-NAME USERNAME)
+ (PASSWORD STRING :LABEL "PASSWORD" :SLOT-NAME PASSWORD))
+LISP-ON-LINES> (set-default-attributes user)
+((USERID INTEGER :LABEL "USERID" :SLOT-NAME USERID)
+ (USERNAME STRING :LABEL "USERNAME" :SLOT-NAME USERNAME)
+ (PASSWORD STRING :LABEL "PASSWORD" :SLOT-NAME PASSWORD))
+LISP-ON-LINES> (find-class-attributes user)
+(USER (PASSWORD STRING :LABEL "PASSWORD" :SLOT-NAME PASSWORD)
+      (USERNAME STRING :LABEL "USERNAME" :SLOT-NAME USERNAME)
+      (USERID INTEGER :LABEL "USERID" :SLOT-NAME USERID)
+      COMMON-LISP:NIL)
+LISP-ON-LINES> ;;;; note that the mewa functions (find-attribute, set-attribute etc) can take either an instance, or a class-name as a symbol , ie :
+; No value
+LISP-ON-LINES> (find-class-attributes 'user)
+(USER (PASSWORD STRING :LABEL "PASSWORD" :SLOT-NAME PASSWORD)
+      (USERNAME STRING :LABEL "USERNAME" :SLOT-NAME USERNAME)
+      (USERID INTEGER :LABEL "USERID" :SLOT-NAME USERID)
+      COMMON-LISP:NIL)
+LISP-ON-LINES> (find-class-attributes (make-instance 'user))
+(USER (PASSWORD STRING :LABEL "PASSWORD" :SLOT-NAME PASSWORD)
+      (USERNAME STRING :LABEL "USERNAME" :SLOT-NAME USERNAME)
+      (USERID INTEGER :LABEL "USERID" :SLOT-NAME USERID)
+      COMMON-LISP:NIL)
+LISP-ON-LINES> 
+
+Using that information, we have enough to create an interface to the object. UncommonWeb includes a powerful presentation system, but it is not quite dynamic enough for our needs. Mewa defines an approach to presentations that suits our purposes, but the paper is written from a smalltalk point of view. A mixture of the two , Mewa Presentations(MP), is described here.
+
+MP introduces to UCW the concept of attributes. an attribute is essentially a named version of the defpresentation slot-like arguments. for example in :
+
+(defpresentation person-editor (object-presentation)
+  ((string :label "First Name" :slot-name 'first-name :max-length 30)))
+
+  the (string :label "First Name" ...) form is an attribute definiton. Attributes are accessed through FIND-ATTIRIBUTES, and are composed at run time (where the current system is done at compile time) to display the object. This allows a very flexible system of displaying objects which is reminiscent of CSS. I discovered this, rather than invent or design it, so there are some rough edges, but its a good start.
+
+Its much easier to show this then to tell. Lets present our user class. Currently in UCW, you'd define a presentation as such :
+
+(defpresentation user-presentation (object-presentation)
+((INTEGER :LABEL "USERID" :SLOT-NAME USERID)
+ (STRING :LABEL "USERNAME" :SLOT-NAME USERNAME)
+ (STRING :LABEL "PASSWORD" :SLOT-NAME PASSWORD)))
+
+which could be presented using PRESENT-OBJECT :
+
+(present-object user :using 'user-presentation)
+
+The equiv approach using mewa presentations is actually longer and more verbose(!) but it serves to demonstrate how the MP system works.
+
+Mewa Presentations adds a set of attributes to a class, keyed off the class name. Attributes are inherited, so if you define an attribute on T, you can use it with any class.
+
+MP stores named attributes keyed on a class name. to achieve the same functionality as the above using mp would look like this :
+
+LISP-ON-LINES> (setf (find-attribute 'user :viewer) '(mewa-object-presentation :attributes (userid username password) :global-properties (:editablep nil)))
+(:VIEWER MEWA-OBJECT-PRESENTATION
+         :ATTRIBUTES
+         (USERID USERNAME PASSWORD)
+         :GLOBAL-PROPERTIES
+         (:EDITABLEP NIL))
+LISP-ON-LINES> (setf (find-attribute 'user 'userid) '(INTEGER :LABEL "USERID" :SLOT-NAME USERID))
+(USERID INTEGER :LABEL "USERID" :SLOT-NAME USERID)
+LISP-ON-LINES> (setf (find-attribute 'user 'username) '(STRING :LABEL "USERNAME" :SLOT-NAME USERNAME))
+(USERNAME STRING :LABEL "USERNAME" :SLOT-NAME USERNAME)
+LISP-ON-LINES> (setf (find-attribute 'user 'password) '(STRING :LABEL "USERNAME" :SLOT-NAME PASSWORD))
+(PASSWORD STRING :LABEL "USERNAME" :SLOT-NAME PASSWORD)
+
+LISP-ON-LINES> (find-class-attributes 'user)                                 
+(USER (PASSWORD STRING :LABEL "PASSWORD" :SLOT-NAME PASSWORD)
+      (USERNAME STRING :LABEL "USERNAME" :SLOT-NAME USERNAME)
+      (USERID INTEGER :LABEL "USERID" :SLOT-NAME USERID)
+      (:VIEWER MEWA-OBJECT-PRESENTATION
+               :ATTRIBUTES
+               (USERID USERNAME PASSWORD)
+               :GLOBAL-PROPERTIES
+               (:EDITABLEP NIL))
+      COMMON-LISP:NIL)
+
+
+this is all turned into a UCW presentation at runtime using MAKE-PRESENTATION :
+
+(defmethod render-on ((res response) (e presentations-index))
+  "
+As you'll see, nothing is exported from the LISP-ON-LINES package. 
+if you wish to use LOL in your own package (or in UCW-USER or whatever),
+you simply need to use the MEWA and META-MODEL packages"  
+  (<ucw:render-component :component (lisp-on-lines::make-presentation lisp-on-lines::user :type :viewer)))
+
+
+SET-ATTRIBUTE can be used in place of (setf (find-attribute)) when you want to "inherit" the properties of an existing attribute definition :
+
+LISP-ON-LINES> (set-attribute 'user 'password '(string :label "password: (must be at leat 8 chars)"))
+(PASSWORD STRING
+          :LABEL
+          "password: (must be at leat 8 chars)"
+          :SLOT-NAME
+          PASSWORD)
+
+
+Now we want to create a presentation with which to edit the username. we will use the existing attributes on a subclass of mewa-object-presetation :
+
+LISP-ON-LINES> (defcomponent user-editor (mewa-object-presentation)
+                ()
+                (:default-initargs 
+                    :attributes '((username :label "Enter your New Username") password)
+                    :global-properties '(:editablep t)))
+USER-EDITOR
+LISP-ON-LINES> (setf (find-attribute 'user :editor) '(user-editor))
+(:EDITOR USER-EDITOR)
+LISP-ON-LINES> 
+
+
+which we then can display below our earlier example :
+
+(defmethod render-on ((res response) (e presentations-index))
+  "
+As you'll see, nothing is exported from the LISP-ON-LINES package. 
+if you wish to use LOL in your own package (or in UCW-USER or whatever),
+you simply need to use the MEWA and META-MODEL packages"  
+  (<ucw:render-component :component (lisp-on-lines::make-presentation lisp-on-lines::user :type :viewer))
+  (<ucw:render-component :component (lisp-on-lines::make-presentation lisp-on-lines::user :type :editor)))
+
+
+
+that should give you some idea on how it works .. ask me when you get confused :)
+
+
+
+
+
+
+
+
+
+
+

diff --git a/src/backend/clsql.lisp b/src/backend/clsql.lisp
new file mode 100644 (file)
index 0000000..26e21cb
--- /dev/null
+++ b/src/backend/clsql.lisp
@@ -0,0 +1,228 @@
+(in-package :meta-model)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (use-package :clsql))
+
+(export 'def-meta-model-from-table)
+(export 'def-meta-models)
+(export 'def-view-class/meta)
+(export 'list-base-classes)
+
+(defparameter *clsql-base-classes* (list) )
+
+(defmethod list-base-classes ((type (eql :clsql)))
+  *clsql-base-classes*)
+
+(defmethod def-base-class-expander ((model meta-model-class) (base-type (eql :clsql)) (name t) (args t))
+  `(def-view-class ,name () 
+                  ,(meta-model.metadata model)))
+
+(defmethod def-base-class-expander :after ((model meta-model-class) (base-type (eql :clsql)) (name t) (args t))
+  (unless (member name *clsql-base-classes*)
+    (setf *clsql-base-classes* (cons name *clsql-base-classes*))))
+
+(defparameter *sql-type-map* '((:INT4 integer) (:TEXT string) (:VARCHAR string) (:TIMESTAMP clsql-sys::wall-time) (:NUMERIC number)(:BYTEA string)))
+
+(defun gen-type (table column)
+  (cadr (assoc
+        (cadr (assoc
+               column
+               (list-attribute-types table)
+               :test #'equalp ))
+        *sql-type-map*)))
+
+(defun sql->sym (name &optional (package nil)) 
+  (flet ((xform (x)
+          (string-upcase (substitute #\- #\_ x))))
+    (if package
+       (intern (xform (string name)) package)
+       (intern (xform (string name))))))
+
+(defun table->slots (table pkey)
+  (mapcar
+   #'(lambda (col)
+       `(,(sql->sym col)
+        :accessor ,(sql->sym col)
+        :initarg ,(sql->sym col "KEYWORD")
+        :type ,(gen-type table col)
+        :db-kind
+        ,(if (equalp col pkey)
+             `:key
+             `:base)))
+   (list-attributes table)))
+
+(defun view-class-definition-list ()
+  (mapcar #'(lambda (x) `(def-meta-model-from-table ,x))
+               (list-tables)))
+
+(defmacro def-meta-models ()
+  (let ((defs (view-class-definition-list)))
+    `(progn ,@defs)))
+
+
+
+
+
+(defun get-pkeys ()
+  (let ((keys '()))
+    (dolist (row (get-pkeys-query))
+      (setf keys (acons (car row) (list (cadr row)) keys)))
+    keys))
+    
+(defun get-pkeys-query()
+  (query
+                   "SELECT  pg_class.relname, pg_attribute.attname, pg_catalog.quote_ident(conname) AS constraint_n
+                 , pg_catalog.pg_get_indexdef(d.objid) AS constraint_definition
+                 , CASE
+                   WHEN contype = 'p' THEN
+                         'PRIMARY KEY'
+                   ELSE
+                         'UNIQUE'
+                   END as constraint_type
+          FROM 
+                pg_class, pg_attribute,
+          pg_catalog.pg_constraint AS c
+          JOIN pg_catalog.pg_depend AS d ON (d.refobjid = c.oid)
+         WHERE contype IN ('p', 'u')
+           AND deptype = 'i'
+           and conrelid = pg_class.oid 
+            and pg_attribute.attnum = ANY (c.conkey)
+             and pg_attribute.attrelid = pg_class.oid"))
+
+;;here is how this works
+;;from the postgres system tables we get
+;;list of all the has-a relationships.
+;;the inverse of a has-a is an implicit has-many
+;;and any relation having more than one foreign key
+;;is a join table hosting a many-to-many relationship
+
+(defun get-fkey-explosions ()
+  (let ((key-table (get-fkey-explosions-query))
+       (keys '()))
+    (dolist (row key-table)
+      (setf row (mapcar #'(lambda (x)
+                           (sql->sym x))
+                       row))
+      ;;this one does the has-a 
+      (setf keys (acons (car row) (gen-has-a row)
+                       keys))
+      ;;the inverse of the previous represents a has-many.
+      (setf keys
+           (acons (fourth row) (gen-has-many row)
+                  keys))
+      
+      ;;many-to-many
+      (dolist (mrow
+               (remove-if #'(lambda (r) (or (not (equal (car row) (car r)))
+                                            (equal (last row) (last r))))
+                          (mapcar #'(lambda (x)
+                                      (mapcar #'sql->sym x))
+                                  key-table)))
+       (setf keys (acons (fourth row)
+                         (gen-many-to-many mrow (third row) (second row))
+                         keys))))
+    keys ))
+                         
+      
+(defun get-fkey-explosions-query ()
+;;these query's are a mess, i don't even know how they work :)
+  (query "
+SELECT pg_class.relname,
+       pg_attribute.attname,
+       fa.attname  ,
+       f.relname
+FROM   pg_class,
+       pg_constraint,
+       pg_attribute,
+       pg_class as f  ,
+       pg_attribute as fa
+WHERE pg_class.relname in (select tablename from pg_tables where schemaname = 'public')
+AND pg_class.oid = pg_constraint.conrelid
+AND pg_attribute.attnum = ANY (pg_constraint.conkey)
+AND pg_attribute.attrelid = pg_class.oid
+AND f.oid = confrelid
+AND fa.attrelid = f.oid
+AND fa.attnum = ANY (pg_constraint.confkey)"))
+
+
+;; i chose keyword args here so as to make the code more understandable.
+;; it didn't really work.
+(defun gen-join-slot (&key name home-key foreign-key join-class (set nil))
+  `(,(intern name)
+    :accessor ,(intern name)
+    :db-kind :join
+    :db-info (:join-class ,join-class
+             :home-key ,home-key
+             :foreign-key ,foreign-key
+             :set ,set)))
+
+(defun gen-has-a (row)
+  (gen-join-slot
+   :name
+   (format nil "~A->~A" (string (car row))(string (second row)))
+   :home-key (second row)
+   :foreign-key (third row)
+   :join-class (fourth row)))
+
+(defun gen-has-many (row)
+  (gen-join-slot
+   :name
+   (format nil "~A->~A" (string (car row))(string (second row)))
+   :home-key (third row)
+   :foreign-key (second row)
+   :join-class (car row)
+   :set t))
+
+(defun gen-many-to-many (row home-key foreign-key)
+ (let ((name (sql->sym (string-upcase (format nil "~A->~A" (string (car row)) (string (second row)))))))
+   (setf row (mapcar #'sql->sym row))
+   `(,name
+     :accessor ,name
+     :db-kind :join
+     :db-info (:join-class ,(car row)
+              :home-key ,home-key
+              :foreign-key ,foreign-key
+              :target-slot ,name
+              :set t))))
+ 
+(defmethod update-records-from-instance :before ((view clsql::standard-db-object) &key database)
+  (declare (ignorable database))
+  (labels ((sym->sql (sym) (string-downcase (substitute #\_ #\- (string sym))))
+          (get-def (slot) (caar (query
+                                 (format nil                                                             "SELECT DISTINCT adsrc from pg_attrdef join pg_attribute on attnum = adnum where adrelid = (select oid from pg_class where relname = '~A') and attname = '~A'" (sym->sql (class-name (class-of view))) (sym->sql slot)))))
+          (get-default-value (slot) (caar (query (format nil "SELECT ~A" (get-def slot))))))
+
+    (dolist (slot (list-slots view))
+      (when (and (primary-key-p view slot)
+                (or (not (slot-boundp view slot))
+                    (equal (slot-value view slot) nil)))
+       (setf (slot-value view slot) (get-default-value slot))))))
+
+;;;;
+
+(defmacro def-view-class/meta (name supers slots &rest args)  
+    `(progn
+       (let* ((m (def-meta-model model-name ,supers ,slots ,args))
+              (i (make-instance m)))
+         (prog1 (eval (def-base-class-expander i :clsql ',name ',args))
+       (defmethod meta-model.metadata ((self ,name))
+         (meta-model.metadata i))))))
+         
+
+(defmacro def-view-class/table (table &optional name)
+  "takes the name of a table as a string and
+creates a clsql view-class"
+  (let* ((pkey (cadr (assoc table (get-pkeys) :test #'equalp)))
+        (table-slots (table->slots table pkey))
+        (join-slots
+         (let ((slots nil))
+           (dolist (exp (get-fkey-explosions))
+             (when (equalp (car exp) (sql->sym table))
+               (setf slots (cons (cdr exp) slots))))
+           slots)))
+    `(def-view-class/meta ,(if name name (sql->sym table))
+      ()
+      ,(append table-slots join-slots))))       
+
+
+

diff --git a/src/backend/ucw.lisp b/src/backend/ucw.lisp
new file mode 100644 (file)
index 0000000..a7bab90
--- /dev/null
+++ b/src/backend/ucw.lisp
@@ -0,0 +1,76 @@
+(in-package :it.bese.ucw)
+
+(defslot-presentation clsql-wall-time-slot-presentation ()
+       ()
+       (:type-name clsql-sys:wall-time))
+
+(defmethod present-slot ((slot clsql-wall-time-slot-presentation) instance)
+  (<:as-html (presentation-slot-value slot instance)))
+
+(defslot-presentation  mewa-relation-slot-presentation ()
+  ((slot-name :accessor slot-name :initarg :slot-name)
+   (foreign-instance :accessor foreign-instance)
+   (editablep :initarg :editablep :accessor editablep :initform :inherit))
+  (:type-name relation))
+
+(defmethod present-relation (( slot mewa-relation-slot-presentation) instance)
+  (when (foreign-instance slot)
+  (when (eql (editablep slot) :inherit)
+    (setf (editablep slot) (editablep (parent slot))))
+  (flet ((render-slot () 
+                     (<ucw:render-component 
+                      :component (mewa::make-presentation (foreign-instance slot) :type :one-line :initargs '(:global-properties (:editablep nil))))))
+    (if (editablep slot)
+       (render-slot)
+      (<ucw:a :action (view-instance slot instance) 
+             (render-slot))))))
+
+(defmethod present-slot ((slot mewa-relation-slot-presentation) instance)
+  (setf (foreign-instance slot) (meta-model:explode-foreign-key instance (slot-name slot)))
+  (present-relation slot instance))
+
+(defslot-presentation foreign-key-slot-presentation (mewa-relation-slot-presentation)
+  ()
+  (:type-name foreign-key)
+  (:default-initargs :editablep :inherit))
+
+(defaction view-instance ((self component) instance &rest initargs)
+  (call-component (parent self) (apply #'mewa:make-presentation (foreign-instance self) initargs)))
+
+(defmethod  present-slot :before ((slot foreign-key-slot-presentation) instance)
+  (setf (foreign-instance slot) (meta-model:explode-foreign-key instance (slot-name slot))))
+
+
+(defslot-presentation has-many-slot-presentation (mewa-relation-slot-presentation)
+  ()
+  (:type-name has-many))
+
+(defmethod present-slot ((slot has-many-slot-presentation) instance)
+  (<:ul 
+   (dolist (s (slot-value instance (slot-name slot)))
+     (setf (foreign-instance slot) s)
+     (<:li (present-relation slot instance)))))
+
+
+
+(defslot-presentation has-a-slot-presentation (one-of-presentation)
+  ((key :initarg :key :accessor key))
+  (:type-name has-a))
+
+(defmethod get-foreign-slot-value ((slot has-a-slot-presentation) (object t) (slot-name t))
+  (slot-value object slot-name))
+
+(defmethod present-slot ((slot has-a-slot-presentation) instance)
+      (<:as-html (presentation-slot-value slot instance))
+  (if (editablep slot)
+      (<ucw:select :accessor (presentation-slot-value slot instance) :test #'equalp
+        (when (allow-nil-p slot)
+         (<ucw:option :value nil (<:as-html (none-label slot))))
+       (dolist (option (get-foreign-instances (presentation slot) instance))
+         (setf (instance (presentation slot)) option)
+         (<ucw:option :value (get-foreign-slot-value slot option (key slot)) (present (presentation slot)))))
+      (if (presentation-slot-value slot instance)
+         (progn
+           (setf (instance (presentation slot)) (presentation-slot-value slot instance))
+           (present (presentation slot)))
+         (<:as-html "--"))))
\ No newline at end of file

diff --git a/src/meta-model.lisp b/src/meta-model.lisp
new file mode 100644 (file)
index 0000000..b0d1ff5
--- /dev/null
+++ b/src/meta-model.lisp
@@ -0,0 +1,179 @@
+(in-package :meta-model)
+
+(defvar *meta-models* nil)
+
+(defun list-meta-models ()
+  *meta-models*)
+
+(defclass meta-model-class ()
+  ((metadata
+    :accessor meta-model.metadata
+    :initarg :metadata
+    :initform nil)
+   (instance
+    :accessor meta-model.instance
+    :initarg :instance
+    :initform nil)
+   (base-type
+    :accessor meta-model.base-type
+    :initform 'clsql)))
+
+(defmethod meta-model.metadata ((self (eql nil)))
+  nil)
+
+(defun gen-supers (supers)
+  (let (subclassp)
+    (dolist (x supers)
+      (when (member x (list-meta-models))
+       (setf subclassp t)))
+    (if subclassp
+       supers
+       (cons 'meta-model-class supers))))
+
+(defmethod %def-meta-model ((base-type t) name supers slots &rest options)
+  `(defclass ,name ,(gen-supers supers)
+     ()
+     (:default-initargs :metadata ',slots)))
+  
+  
+(defmacro def-meta-model (name supers slots &rest options)
+  `(progn
+     (when (not (member (quote ,name) *meta-models*))
+       (setf *meta-models* (cons (quote ,name) *meta-models*)))
+
+     (let ((class ,(%def-meta-model (cadr (or (assoc :base-type options) '(t t))) name supers slots options)))
+       class)))
+
+(defgeneric def-base-class-expander (model base-type name args))
+
+
+(defmacro def-base-class (name (model) &rest args)
+  (let ((i (make-instance model)))
+    `(progn 
+       ,(def-base-class-expander i :clsql name args)
+       (defmethod meta-model.metadata ((m ,name))
+        ',(meta-model.metadata i)))))
+  
+
+(defmethod base-class-name ((model t))
+  (class-name (class-of (meta-model.instance model))))
+  
+
+
+(defmethod view-class-metadata ((model t))
+  (meta-model.metadata model))
+
+(defun list-item-helper (type view &key (ret-fun #'car))
+  "A helper function for the LIST-* methods"
+   (remove nil
+          (mapcar #'(lambda (slot)
+                         (let ((ret-val (funcall ret-fun slot))
+                               (kind (getf (cdr slot) :db-kind)))
+                           (when (eql kind type)
+                             ret-val )))
+                  (view-class-metadata view))))
+
+(defmethod list-join-attributes ((view t))
+  "Returns all slots as an alist of (SLOT-NAME JOIN-ATTRIBUTES) where J-A is the contents of the :JOIN-CLASS portion of a slot definition"
+  (remove nil (mapcar #'(lambda (def)(cons (car def) (getf (cdr def) :db-info ))) (view-class-metadata view))))
+
+(defun list-relations-helper (view predicate-method &key (test-key :home-key) (return-key :join-class) (return-full nil))
+  "A helper function for the listing join, relations and the like"
+  (remove nil (mapcar #'(lambda (x)
+             (when (funcall predicate-method view (getf (cdr x) test-key ))
+               (if return-full
+                   x
+               (getf (cdr x) return-key ))))
+         (list-join-attributes view))))
+
+(defmethod list-slots ((view t))
+  "list the non-joined slots of VIEW-CLASS"
+  (remove-if #'(lambda (x) (find x (list-joins view)))
+            (append (list-item-helper :key view)
+                    (list-item-helper nil view)
+                    (list-item-helper :base view))))
+
+(defmethod list-slot-types ((view t))
+  "Returns an alist of (slot-name slot-type) where SLOT-TYPE is the CLSQL type"
+  (labels  ((rfun (slot)
+             (cons (car slot)
+                   (list (getf (cdr slot):type))))
+           (lister (type)
+             (list-item-helper
+              type view
+              :ret-fun #'rfun)))
+    (append (lister :key) (lister :base))))
+                        
+(defmethod slot-type ((view t) slot)
+  "returns the CLSQL type of SLOT"
+  (second (assoc slot (list-slot-types view))))
+  
+(defmethod list-joins ((view t))
+  "lists slots that represent joins"
+  (list-item-helper :join view))
+
+(defmethod list-keys ((view t))
+  "lists slots marked as :key"
+  (list-item-helper :key view))
+
+(defmethod primary-key-p ((view t) slot)
+  "returns slot if it is primary key (NOTE: Currently this returns T if the slot appears in LIST_KEYS and does not take into account the :primary-key option. b0rked, to be sure"
+  (find slot (list-keys view)))
+
+(defmethod list-foreign-keys ((view t))
+  "returns a list of FOREIGN-KEYS"
+  (flet ((my-primary-key-p (slot)
+          (primary-key-p view slot)))
+    (remove nil (remove-if #'my-primary-key-p
+              (mapcar #'(lambda (def)
+                          (getf (cdr def) :home-key))
+                      (list-join-attributes view))))))
+
+(defmethod foreign-key-p ((view t) slot)
+  "returns SLOT if it's a foreign key, nil otherwise"
+  (find slot (list-foreign-keys view)))
+
+
+
+(defmethod list-has-a ((view t))
+  "returns a list of view-classes that are in a 1:1 relationship with VIEW"
+  (list-relations-helper view #'foreign-key-p))
+
+(defmethod list-has-many ((view t))
+  "returns a list of view-classes that are in a 1:Many relationship with VIEW" 
+  (mapcar #'car
+         (remove-if #'(lambda (x) (getf (cdr x) :target-slot))
+                    (list-relations-helper
+                     view
+                     #'primary-key-p :return-full t))))
+
+(defmethod list-many-to-many ((view t))
+  "returns a list of view-classes that are in a Many:Many relationship with VIEW" 
+  (mapcar #'car (list-relations-helper
+                view
+                #'(lambda (c a)
+                    (declare (ignore c))a)
+                :test-key :target-slot
+                :return-full t)))
+
+(defmethod explode-foreign-key ((model clsql:standard-db-object) slot)
+  "returns the clsql view-class joined on SLOT"
+  (dolist (s (list-join-attributes model))
+    (when (equal (getf (cdr s) :home-key) slot)
+      (return-from explode-foreign-key (slot-value model (car s))))))
+
+(defun find-join-helper (foreign-key)
+  (lambda (class slot) 
+    (declare (ignore class))
+    (when (equal slot foreign-key) t)))
+
+(defmethod find-join-class ((view t) foreign-key)
+  "Returns the VIEW-CLASS that is joined to VIEW via FOREGN-KEY"
+  (car (list-relations-helper view (find-join-helper foreign-key) )))
+
+(defmethod find-join-key ((view t) foreign-key)
+  "returns the SLOT in the foreign VIEW-CLASS that joins with FOREIGN-KEY"
+  (car (list-relations-helper view (find-join-helper foreign-key) :return-key :foreign-key)))
+
+
+

diff --git a/src/mewa.lisp b/src/mewa.lisp
new file mode 100644 (file)
index 0000000..867b5a8
--- /dev/null
+++ b/src/mewa.lisp
@@ -0,0 +1,263 @@
+(defpackage :mewa 
+  (:use :ucw :common-lisp)
+  (:export :mewa :mewa-object-presentation :mewa-one-line-presentation :find-attribute :set-default-attributes :make-presentation :call-presentation :label :set-attribute :find-class-attributes))
+
+(in-package :mewa)
+ 
+(defparameter *default-type* :ucw)
+
+;;; maps meta-model slot-types to slot-presentation
+(defparameter *slot-type-map* '(number ucw:currency))
+
+;;; an alist of model-class-name . attributes
+;;; should really be a hash-table.
+(defvar *attribute-map* (list)) 
+
+;;; some utilities for merging plists
+
+(defun plist-nunion (new-props plist)
+  (loop for cons on new-props
+       for i from 1 to (length new-props)
+       when (oddp i)
+       do (setf (getf plist (first cons)) (second cons))
+       finally (return plist)))
+
+(defun plist-union (new-props plist)
+  "Non-destructive version of plist-nunion"
+                  (plist-nunion new-props (copy-list plist)))
+
+(defun gen-ptype (type)
+  (or (getf *slot-type-map* type) type))
+
+(defun gen-presentation-slots (instance)
+  (mapcar #'(lambda (x) (gen-pslot (cadr x) 
+                                  (string (car x)) 
+                                  (car x))) 
+         (list-slot-types instance)))
+
+
+(defun gen-pslot (type label slot-name)
+  (copy-list `(,(gen-ptype type) 
+              :label ,label
+              :slot-name ,slot-name))) 
+
+(defun gen-presentation-args (instance args)
+  (declare (ignore instance))
+  (if args args nil))
+
+
+(defun find-or-create-attributes (class-name)
+  "return an exisiting class attribute map or create one. 
+
+A map is a cons of class-name . attributes. 
+attributes is an alist keyed on the attribute nreeame."
+  (or (assoc class-name *attribute-map*) 
+      (progn 
+       (setf *attribute-map* (acons class-name (list (list)) *attribute-map*)) 
+       (assoc class-name *attribute-map*))))
+
+(defgeneric find-class-attributes (class))
+
+(defmethod find-class-attributes ((model t))
+  (find-or-create-attributes (class-name (class-of model))))
+
+(defmethod find-class-attributes ((model symbol))
+  (find-or-create-attributes model))
+
+(defmethod add-attribute ((model t) name def)
+  (let ((map (find-class-attributes model)))
+    (setf (cdr map) (acons name def (cdr map)))))
+
+(defmethod find-attribute ((model t) name)
+  (assoc name (cdr (find-class-attributes model))))
+
+(defmethod (setf find-attribute) ((def list) (model t) name)
+  (let ((attr (find-attribute model name)))
+    (if attr
+       (prog2 
+           (setf (cdr attr) def) 
+           attr)
+        (prog2 
+           (add-attribute model name def) 
+           (find-attribute model name)))))
+
+(defmethod set-attribute ((model t) name definition &key (inherit t))
+  (setf (find-attribute model name) 
+       (if inherit
+           (cons (car definition) 
+                 (plist-union (cdr definition)
+                        (cddr (find-attribute model name))))
+           definition)))
+
+
+(defgeneric attributes-getter (model))
+         
+(defcomponent mewa ()
+  ((attributes
+    :initarg :attributes
+    :accessor attributes
+    :initform nil)
+   (attributes-getter
+    :accessor attributes-getter
+    :initform #'get-attributes
+    :initarg :attributes-getter)
+   (global-properties
+    :initarg :global-properties
+    :accessor global-properties
+    :initform nil)
+   (classes 
+    :initarg :classes 
+    :accessor classes 
+    :initform nil)
+   (use-instance-class-p 
+    :initarg :use-instance-class-p 
+    :accessor use-instance-class-p 
+    :initform t)
+   (initializedp :initform nil)
+   (modifiedp :accessor modifiedp :initform nil)))
+
+(defcomponent mewa-object-presentation (mewa object-presentation) ())
+
+(defcomponent mewa-one-line-presentation (mewa one-line-presentation)
+  ()
+  (:default-initargs :attributes-getter #'one-line-attributes-getter))
+
+(defmethod attributes :around ((self mewa))
+  (let ((a (call-next-method)))
+    (or a (funcall (attributes-getter self) self))))
+
+(defmethod get-attributes ((self mewa))
+  (if (instance self)
+  (append (meta-model:list-slots (instance self))
+         (meta-model:list-has-many (instance self)))
+  nil))
+
+(defmethod one-line-attributes-getter ((self mewa))
+  (or (meta-model:list-keys (instance self))))
+
+
+
+(defmethod find-instance-classes ((self mewa))
+  (mapcar #'class-name 
+         (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self)))))
+
+(defmethod find-all-attributes ((self mewa))
+  (reduce #'append 
+         (mapcar #'(lambda (x) 
+                     (cdr (find-class-attributes x)))
+                 (classes self))))
+
+(defun make-attribute (&rest props &key type &allow-other-keys)
+       (remf props :type)
+       (cons (gensym) (cons type props)))
+
+
+(defmethod find-applicable-attributes ((self mewa))
+  (let ((all-attributes (find-all-attributes self)))
+    (flet ((gen-att (x) (let ((att (assoc x all-attributes)))
+                                    (when att 
+                                      (setf (cddr att) (plist-union (global-properties self) (cddr att)))
+                                      att))))
+    (if (attributes self)
+       (remove 'nil 
+               (mapcar #'(lambda (x)
+                           (cond 
+                            ;;simple casee
+                            ((symbolp x) 
+                             (gen-att x))
+                            ;;if the car is a keyword then this is an inline def
+                            ((and (listp x) (keywordp (car x)))
+                             (let ((att (apply #'make-attribute x)))
+                               (setf (cddr att) 
+                                     (plist-union (cddr att) (global-properties self)))
+                               att))
+                            ;; if the plist has a :type          
+                            ((and (listp x) (getf (cdr x) :type))
+                             (let ((new (cdr (apply #'make-attribute (cdr x))))
+                                   (def (gen-att (car x))))
+                               (setf (cdr new) (plist-union (cdr new) (cddr def)))
+                               (cons (car def) new)))
+                            ;;finally if we are just overiding the props
+                            ((and (listp x) (symbolp (car x)))
+                             (let ((new (cdr (apply #'make-attribute (cdr x))))
+                                   (def (gen-att (car x))))
+                               (setf (cdr new) (plist-union (cdr new) (cddr def)))
+                               (cons (car def) (cons (second def) (cdr new)))))
+
+                             )
+                            )
+                                  
+                       (attributes self)))
+      all-attributes))))
+
+(defmethod find-slot-presentations ((self mewa))
+  (mapcar #'(lambda (s)
+             (let ((class-name (or (gethash (second s) ucw::*slot-type-mapping*) 'mewa-object-presentation)))
+             (apply #'make-instance 
+                    class-name
+                    (append (cddr s) (list :parent self)))))
+         (find-applicable-attributes self)))
+
+(defmethod default-attributes ((model t))
+  (append (mapcar #'(lambda (s) (cons (car s) (gen-pslot (if (meta-model:foreign-key-p model (car s))
+                                                  'ucw::foreign-key
+                                                  (cadr s))
+                                                (string (car s)) (car s)))) 
+         (meta-model:list-slot-types model))
+         (mapcar #'(lambda (s) (cons s (append (gen-pslot 'ucw::has-many (string s) s) `(:presentation (make-presentation ,model :type :one-line)))))
+                 (meta-model:list-has-many model))))
+
+(defmethod set-default-attributes ((model t))
+  (mapcar #'(lambda (x) 
+             (setf (find-attribute model (car x)) (cdr x)))
+         (default-attributes model)))
+
+
+(defcomponent mewa-object-presentation (mewa ucw:object-presentation) ())
+
+(defcomponent mewa-list-presentation (mewa ucw:list-presentation) 
+  ((it.bese.ucw::instances :accessor instances :initarg :instances :initform nil)
+      (instance :accessor instance))) ;to make make-presentation happy
+
+(defmethod get-all-instances ((self mewa-list-presentation))
+  (instances self))
+
+
+
+
+(defmethod initialize-slots ((self mewa))
+  (when (use-instance-class-p self)
+    (setf (classes self) 
+         (append (find-instance-classes self)
+                 (classes self))))
+  (setf (slots self) (find-slot-presentations   self)))
+  
+
+(defmethod render-on :around ((res response) (self mewa))
+  (unless (slot-value self 'initializedp)
+    (initialize-slots self))
+  (setf (slot-value self 'initializedp) t)
+  (call-next-method))
+
+
+(defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
+  (let* ((p (make-instance 'mewa-object-presentation))
+        (a (progn (setf (slot-value p 'instance) object)
+                  (initialize-slots p) 
+                  (assoc type (find-all-attributes p))))
+        
+        (i (apply #'make-instance (second a) (plist-union initargs (cddr a)))))
+    (setf (slot-value i 'instance) object)
+    i))
+
+(defmethod call-component :before ((from standard-component) (to mewa))
+  (unless (slot-value to 'initializedp)
+    (initialize-slots to))
+  (setf (slot-value to 'initializedp) t)
+  (setf (slots to) (mapcar #'(lambda (x) (prog2 
+                                            (setf (component.place x) (component.place from))
+                                            x))
+                            (slots to))))
+
+(defmacro call-presentation (object &rest args)
+  `(present-object ,object :presentation (make-presentation ,object ,@args)))
\ No newline at end of file

diff --git a/src/packages.lisp b/src/packages.lisp
new file mode 100644 (file)
index 0000000..8c971ce
--- /dev/null
+++ b/src/packages.lisp
@@ -0,0 +1,34 @@
+(defpackage :meta-model
+  (:use :common-lisp )
+  (:export
+   :meta-model-class
+   :meta-model.base-type
+   :meta-model.instance
+   :meta-model.metadata
+   :def-meta-model
+   :def-base-class
+   :%def-base-class
+   :def-view-class/table
+   :def-view-class/meta
+   :view-class-metadata
+   :create-table-from-model
+   :list-slots
+   :list-slot-types
+   :slot-type
+   :display-slot
+   :list-joins
+   :list-join-attributes
+   :list-keys
+   :list-view-classes
+   :display-slot
+   :primary-key-p
+   :list-foreign-keys
+   :foreign-key-p
+   :explode-foreign-key
+   :find-join-class
+   :find-join-key
+   :find-default-value
+   :explode-foreign-key
+   :list-has-many
+   :list-many-to-many))
+

diff --git a/src/ucw.lisp b/src/ucw.lisp
new file mode 100644 (file)
index 0000000..ddf83af
--- /dev/null
+++ b/src/ucw.lisp
@@ -0,0 +1,151 @@
+(in-package :it.bese.ucw)
+
+
+(defslot-presentation clsql-wall-time-slot-presentation ()
+       ()
+       (:type-name clsql-sys:wall-time))
+
+(defmethod presentation-slot-value ((slot clsql-wall-time-slot-presentation) instance)
+  (let ((date (call-next-method)))
+    (when date (multiple-value-bind (y m d) (clsql:time-ymd date)
+      (format nil "~a/~a/~a" m d y)))))
+
+(defmethod (setf presentation-slot-value) ((value string) (slot clsql-wall-time-slot-presentation) instance)
+  (setf (presentation-slot-value slot instance) (clsql:parse-date-time (remove #\Space value))))
+
+(defmethod present-slot ((slot clsql-wall-time-slot-presentation) instance)
+  (let ((date (presentation-slot-value slot instance))
+       (input-id (string (gensym))))
+    (if (and date (not (editablep slot)))
+       (<:span (<:as-html date)))
+    (when (editablep slot)
+      (<ucw:input :accessor (presentation-slot-value slot instance) :id input-id)
+      (<:script :type "text/javascript" 
+               (<:as-is (format nil " 
+      Calendar.setup({
+        inputField     :    \"~a\",
+        ifFormat       :    \"%m/%d/%Y\",
+      });" input-id))))))
+
+(defslot-presentation  mewa-relation-slot-presentation ()
+  ((slot-name :accessor slot-name :initarg :slot-name)
+   (foreign-instance :accessor foreign-instance)
+   (linkedp :accessor linkedp :initarg :linkedp :initform t))
+  (:type-name relation))
+
+(defmethod present-relation ((slot mewa-relation-slot-presentation) instance)
+ ;;;;(<:as-html (slot-name slot) "=> " (foreign-instance slot) " from " instance )
+  (let* ((e (getf (mewa::global-properties (parent slot)) :editablep))
+        (i (foreign-instance slot))
+        (pres (mewa::make-presentation 
+               i
+               :type :one-line 
+               :initargs (list 
+                          :global-properties 
+                          (list :editablep nil :linkedp (linkedp slot))))))
+      (when (ucw::parent slot) (setf (component.place pres) (component.place (ucw::parent slot))))
+      (flet ((render () (when i (<ucw:render-component :component pres))))
+      (cond 
+       ((editablep slot)
+        (render)
+        (<ucw:a :action (search-records slot i) (<:as-html " (search)"))
+        (<ucw:a :action (create-record slot i) (<:as-html " (new)")))
+       ((linkedp slot)
+        (<ucw:a :action (view-instance slot i) 
+                (render)))
+       (t       
+        (render))))))
+
+(defmethod present-slot ((slot mewa-relation-slot-presentation) instance)
+  (present-relation slot instance))
+
+(defslot-presentation foreign-key-slot-presentation (mewa-relation-slot-presentation)
+  ()
+  (:type-name foreign-key)
+  (:default-initargs))
+
+(defaction view-instance ((self component) instance &rest initargs)
+  (call-component (parent self) (apply #'mewa:make-presentation instance initargs)))
+
+(defmethod  present-slot :before ((slot foreign-key-slot-presentation) instance)
+  (setf (foreign-instance slot) (meta-model:explode-foreign-key instance (slot-name slot))))
+
+;;;; HAS MANY 
+(defslot-presentation has-many-slot-presentation (mewa-relation-slot-presentation)
+  ()
+  (:type-name has-many))
+
+(defmethod present-slot ((slot has-many-slot-presentation) instance)
+  (let ((i (get-foreign-instances slot instance))
+       (linkedp (linkedp slot)))
+  (<:ul 
+   (dolist (s i)
+     (let ((s s))
+     (setf (foreign-instance slot) s)
+     (<ucw:a :action (view-instance slot s :initargs `(:global-properties ,(list :linkedp t :editablep nil)))
+     (<:li   (setf (linkedp slot) nil)
+            (present-relation slot instance))))))))
+
+
+(defmethod get-foreign-instances ((slot has-many-slot-presentation) instance)
+  (slot-value instance (slot-name slot)))
+
+(defslot-presentation has-very-many-slot-presentation (has-many-slot-presentation)
+  ((number-to-display :accessor number-to-display :initarg :number-to-display :initform 10)
+   (current :accessor current :initform 0)
+   (len :accessor len )
+   (instances :accessor instances))
+
+  (:type-name has-very-many))
+
+(defmethod list-next ((slot has-very-many-slot-presentation))
+  (setf (current slot) (incf (current slot) (number-to-display slot)))
+  (when (< (len slot) (current slot))
+    (setf (current slot) (- (number-to-display slot) (len slot)))))
+
+(defmethod list-prev ((slot has-very-many-slot-presentation))
+  (setf (current slot) (decf (current slot) (number-to-display slot)))
+  (when  (> 0 (current slot))
+    ;;what to do here is open to debate
+    (setf (current slot) (- (len slot)(number-to-display slot)  ))))
+
+
+(defmethod present-slot ((slot has-very-many-slot-presentation) instance)
+  ;;(<:as-html "isance: " instance)
+  (<ucw:a :action (list-prev slot) (<:as-html "<<"))
+  (let ((self (parent slot)))
+    (<ucw:a :action (call-component self (mewa:make-presentation (car (slot-value instance (slot-name slot))) :type :listing :initargs (list :instances (instances slot))))
+           (<:as-html  (label slot) (format nil " ~a-~a " (current slot) (+ (current slot) (number-to-display slot))))))
+  (<ucw:a :action (list-next slot) (<:as-html ">>"))
+  (call-next-method)
+  (<:as-html "total :" (len slot))) 
+
+(defmethod get-foreign-instances :around ((slot has-very-many-slot-presentation) instance)
+  (let ((f (call-next-method)))
+    (setf (len slot) (length f))
+    (setf (instances slot) f)
+  (loop for cons on (nthcdr (current slot) f)
+                  for i from 0 upto (number-to-display slot)
+                  collect (car cons))))
+
+(defslot-presentation has-a-slot-presentation (one-of-presentation)
+  ((key :initarg :key :accessor key))
+  (:type-name has-a))
+
+(defmethod get-foreign-slot-value ((slot has-a-slot-presentation) (object t) (slot-name t))
+  (slot-value object slot-name))
+
+(defmethod present-slot ((slot has-a-slot-presentation) instance)
+      (<:as-html (presentation-slot-value slot instance))
+  (if (editablep slot)
+      (<ucw:select :accessor (presentation-slot-value slot instance) :test #'equalp
+        (when (allow-nil-p slot)
+         (<ucw:option :value nil (<:as-html (none-label slot))))
+       (dolist (option (get-foreign-instances (presentation slot) instance))
+         (setf (instance (presentation slot)) option)
+         (<ucw:option :value (get-foreign-slot-value slot option (key slot)) (present (presentation slot)))))
+      (if (presentation-slot-value slot instance)
+         (progn
+           (setf (instance (presentation slot)) (presentation-slot-value slot instance))
+           (present (presentation slot)))
+         (<:as-html "--"))))
\ No newline at end of file