MOP-ish introspection for OODML

Hello,

In a recent project i needed to generate vew-classes and the interface 
based on the tables in the database. For that i needed a little more 
introspection in CLSQL, so i hacked together the following. Someone on 
#lisp thought it might be a good addition to CLSQL proper (and now that 
i have it i can't live without it), so i thought i'd post it here.

If you are interested, i have a demo of that prototype up at 
http://merlin.tech.coop:8080/rr/index.ucw. Everything is generated, the 
actual app is about 3 lines of code :
	
	(in-package :rr)
	(connect '("localhost" ...))
	(def-view-classes)

Code is at http://merlin.tech.coop/~drewc/

I can't guarantee that those web addresses will work beyond tonight :)

Following the Mopish bit are some functions that generate the 
view-classes from a postgresql database. Similar to perls 
Class::DBI::Loader, except it also generates the relationships properly.

There is also a :before method on update-records-from-instance that 
automatically adds the serial primary key to a recently created record, 
allowing me to do stuff like "Create a new record, add it to database, 
and keep using the same object (with it's pkey now filled) in the program."

Inheritance is not yet implemented, because i haven't needed it yet. 
Same with all the sql types. Obviously, the code is quite hackish.

Is this something that could be added to CLSQL or would it be better to 
start a new project?


;;;; Copyright (c) 2005 www.tech.coop Services Co-operative.
(defpackage rr-sql
   (:use :common-lisp :clsql)
   (:export
    :select
    :connect
    :update-records-from-instance
    :update-instance-from-records
    :def-view-class
    :view-class
    :def-view-class-from-table
    :def-view-class/metadata
    :def-view-classes
    :list-slots
    :list-slot-types
    :slot-type
    :display-slot
    :list-joins
    :list-join-attributes
    :list-primary-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-join-class
    :list-has-a
    :list-has-many
    :list-many-to-many))

(in-package :rr-sql)

(setf *default-caching* nil)

(defparameter *view-classes* nil)

(def-view-class view-class ()
   ()
   (:documentation "This is the base for all view-classes"))

(defgeneric view-class-metadata (view-class))

(defmacro def-view-class/metadata (class-name supers &body body)
   (setf *view-classes* (cons class-name *view-classes*))
	  `(progn
	    (def-view-class ,class-name ,(cons 'view-class supers),@body)
	    (defmethod view-class-metadata ((view-class ,class-name))
	      ',(car body))))
	
(defun list-view-classes ()
   *view-classes*)

(defmethod list-slots ((view view-class))
   (append (list-item-helper :key view)
	  (list-item-helper :base view)))

(defmethod list-slot-types ((view view-class))
   (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 view-class) slot)
   (second (assoc slot (list-slot-types view))))

(defmethod list-joins ((view view-class))
   (list-item-helper :join view))

(defmethod list-primary-keys ((view view-class))
   (list-item-helper :key view))

(defmethod primary-key-p ((view view-class) slot)
   (find slot (list-primary-keys view)))

(defmethod list-join-attributes ((view view-class))
   (remove nil (mapcar #'(lambda (def)(cons (car def) (getf (cdr def) 
:db-info ))) (view-class-metadata view))))

(defmethod list-has-a ((view view-class))
   (list-relations-helper view #'foreign-key-p))

(defmethod list-has-many ((view view-class))
   (mapcar #'(lambda (_) (getf (cdr _) :join-class))
	  (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 view-class))
   (mapcar #'car (list-relations-helper view
    #'(lambda (c a)(declare (ignore c))a)
    :test-key :target-slot
    :return-full t)))

(defmethod find-join-class ((view view-class) foreign-key)
   (declare (special foreign-key))
   (car (list-relations-helper view #'find-join-helper)))

(defmethod find-join-key ((view view-class) foreign-key)
   (declare (special foreign-key))
   (car (list-relations-helper view #'find-join-helper :return-key 
:foreign-key)))

(defun find-join-helper (class slot)
   (declare (ignore class)(special foreign-key))
   (when (equal slot foreign-key) t))

(defun list-relations-helper (view predicate-method &key (test-key 
:home-key) (return-key :join-class) (return-full nil))
   (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-foreign-keys ((view view-class))
   (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 view-class) slot)
   (find slot (list-foreign-keys view)))

  (defmethod explode-foreign-key ((view view-class) slot)
   (let ((class nil))
     (dolist (x (view-class-metadata view))
       (let ((name (car x))
	    (home-key (getf (getf (cdr x) :db-info) :home-key)))
	(when (equal home-key slot)
	  (setf class (slot-value view name)))))
     class))


(defmethod explode-join-class ((view view-class) join-class-name)
   (let ((objs nil))
     (dolist (def (view-class-metadata view))
       (let ((name (car def))
	    (join-class (getf (getf (cdr def) :db-info) :join-class)))
	(when (equal join-class join-class-name)
	  (handler-case (setf objs (slot-value view name))
	    (simple-error nil nil)))))
     objs))
	
(defun list-item-helper (type view &key (ret-fun #'car))
    (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))))


;;;;;; POSTGRES autoloader follows

(defmethod update-records-from-instance :before ((view view-class) &key 
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))))))


(defparameter *sql-type-map* '((:INT4 integer) (:TEXT string) (:VARCHAR 
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-view-class-from-table ,x))
		(list-tables)))

(defmacro def-view-classes ()
   (let ((defs (view-class-definition-list)))
     `(progn ,@defs)))


(defmacro def-view-class-from-table (table)
   "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/metadata ,(sql->sym table)
       ()
       ,(append table-slots join-slots))))


(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 ()
   (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 
after trying to read this mess after a week.

(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))))