src/backend/clsql.lisp

   1 (in-package :meta-model)
   2
   3 (eval-when (:compile-toplevel :load-toplevel :execute)
   4  (use-package :clsql))
   5
   6 (export 'def-meta-model-from-table)
   7 (export 'def-meta-models)
   8 (export 'def-view-class/meta)
   9 (export 'list-base-classes)
  10
  11
  12 (defmethod sync-instance ((view clsql:standard-db-object) &key (fill-gaps-only-p nil) (database *default-database*))
  13   (labels ((sym->sql (sym) (string-downcase (substitute #\_ #\- (string sym))))
  14            (get-def (slot) (caar (query
  15                                   (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)))))
  16            (get-default-value (slot)
  17              (let ((def (get-def slot)))
  18                (if def
  19                    (caar (query (format nil "SELECT ~A" def)))))))
  20
  21     (dolist (slot (list-slots view))
  22       (when (and (primary-key-p view slot)
  23                  (or (not (slot-boundp view slot))
  24                      (equal (slot-value view slot) nil)))
  25         (setf (slot-value view slot) (get-default-value slot))
  26         (when (and (primary-key-p view slot)
  27                    (not (slot-value view slot))
  28                    (not  fill-gaps-only-p))
  29           (error "No default value for primary key : ~A" slot))))
  30     (when fill-gaps-only-p
  31       (update-objects-joins (list view))
  32       (return-from sync-instance))
  33     (update-records-from-instance view :database database)
  34     (update-instance-from-records view :database database)
  35     (update-objects-joins (list view)))
  36
  37   ;; return the modified and hopefully now persistent object
  38   view)
  39
  40
  41
  42 (defparameter *clsql-base-classes* (list) )
  43
  44 (defmethod list-base-classes ((type (eql :clsql)))
  45   *clsql-base-classes*)
  46
  47 (defmethod generate-base-class-definition ((base-type (eql :clsql)) (model meta-model-class) (name t) (args t))
  48   `(def-view-class ,name ()
  49                    ,(meta-model.metadata model)))
  50
  51 (defmethod generate-base-class-definition :after ((base-type (eql :clsql)) (model meta-model-class) (name t) (args t))
  52   (unless (member name *clsql-base-classes*)
  53     (setf *clsql-base-classes* (cons name *clsql-base-classes*))))
  54
  55 (defparameter *sql-type-map* '((:INT4 integer) (:BOOL boolean) (:TEXT string) (:VARCHAR string) (:TIMESTAMP clsql-sys::wall-time) (:NUMERIC number)(:BYTEA string)))
  56
  57 (defun gen-type (table column)
  58   (cadr (assoc
  59          (cadr (assoc
  60                 column
  61                 (list-attribute-types table)
  62                 :test #'equalp ))
  63          *sql-type-map*)))
  64
  65 (defun sql->sym (name &optional (package nil))
  66   (flet ((xform (x)
  67            (string-upcase (substitute #\- #\_ x))))
  68     (if package
  69         (intern (xform (string name)) package)
  70         (intern (xform (string name))))))
  71
  72 (defun table->slots (table pkey &optional (accesor-prefix table) (prefix-all-p nil))
  73   (mapcar
  74    #'(lambda (col)
  75        (flet ((accessor-name (col)
  76                 (let ((name (sql->sym col)))
  77                   (if (or prefix-all-p
  78                           (and (fboundp name)
  79                                (eq (type-of (symbol-function name)) 'function)))
  80                       (sql->sym (concatenate 'string
  81                                              (string accesor-prefix) "-" col))
  82                       name))))
  83
  84          `(,(sql->sym col)
  85             :accessor ,(accessor-name col)
  86             :initarg ,(sql->sym col "KEYWORD")
  87             :type ,(gen-type table col)
  88             :db-kind
  89             ,(if (equalp col pkey)
  90                  `:key
  91                  `:base))))
  92    (list-attributes table)))
  93
  94 (defun view-class-definition-list ()
  95   (mapcar #'(lambda (x) `(def-meta-model-from-table ,x))
  96                 (list-tables)))
  97
  98 (defmacro def-meta-models ()
  99   (let ((defs (view-class-definition-list)))
 100     `(progn ,@defs)))
 101
 102
 103 (defun get-pkeys ()
 104   (let ((keys '()))
 105     (dolist (row (get-pkeys-query))
 106       (setf keys (acons (car row) (list (cadr row)) keys)))
 107     keys))
 108
 109 (defun get-pkeys-query()
 110   (query
 111                     "SELECT  pg_class.relname, pg_attribute.attname, pg_catalog.quote_ident(conname) AS constraint_n
 112                  , pg_catalog.pg_get_indexdef(d.objid) AS constraint_definition
 113                  , CASE
 114                    WHEN contype = 'p' THEN
 115                          'PRIMARY KEY'
 116                    ELSE
 117                          'UNIQUE'
 118                    END as constraint_type
 119           FROM
 120                 pg_class, pg_attribute,
 121           pg_catalog.pg_constraint AS c
 122           JOIN pg_catalog.pg_depend AS d ON (d.refobjid = c.oid)
 123          WHERE contype IN ('p', 'u')
 124            AND deptype = 'i'
 125            and conrelid = pg_class.oid
 126             and pg_attribute.attnum = ANY (c.conkey)
 127              and pg_attribute.attrelid = pg_class.oid"))
 128
 129 ;;here is how this works
 130 ;;from the postgres system tables we get
 131 ;;list of all the has-a relationships.
 132 ;;the inverse of a has-a is an implicit has-many
 133 ;;and any relation having more than one foreign key
 134 ;;is a join table hosting a many-to-many relationship
 135
 136 (defun get-fkey-explosions ()
 137   (let ((key-table (get-fkey-explosions-query))
 138         (keys '()))
 139     (dolist (row key-table)
 140       (setf row (mapcar #'(lambda (x)
 141                             (sql->sym x))
 142                         row))
 143       ;;this one does the has-a
 144       (setf keys (acons (car row) (gen-has-a row)
 145                         keys))
 146       ;;the inverse of the previous represents a has-many.
 147       (setf keys
 148             (acons (fourth row) (gen-has-many row)
 149                    keys))
 150
 151       ;;many-to-many
 152       (dolist (mrow
 153                 (remove-if #'(lambda (r) (or (not (equal (car row) (car r)))
 154                                              (equal (last row) (last r))))
 155                            (mapcar #'(lambda (x)
 156                                        (mapcar #'sql->sym x))
 157                                    key-table)))
 158         (setf keys (acons (fourth row)
 159                           (gen-many-to-many mrow (third row) (second row))
 160                           keys))))
 161     keys ))
 162
 163
 164 (defun get-fkey-explosions-query ()
 165 ;;these query's are a mess, i don't even know how they work :)
 166   (query "
 167 SELECT pg_class.relname,
 168        pg_attribute.attname,
 169        fa.attname  ,
 170        f.relname
 171 FROM   pg_class,
 172        pg_constraint,
 173        pg_attribute,
 174        pg_class as f  ,
 175        pg_attribute as fa
 176 WHERE pg_class.relname in (select tablename from pg_tables where schemaname = 'public')
 177 AND pg_class.oid = pg_constraint.conrelid
 178 AND pg_attribute.attnum = ANY (pg_constraint.conkey)
 179 AND pg_attribute.attrelid = pg_class.oid
 180 AND f.oid = confrelid
 181 AND fa.attrelid = f.oid
 182 AND fa.attnum = ANY (pg_constraint.confkey)"))
 183
 184
 185 ;; i chose keyword args here so as to make the code more understandable.
 186 ;; it didn't really work.
 187 (defun gen-join-slot (&key name home-key foreign-key join-class (set nil))
 188   `(,(intern name)
 189     :accessor ,(intern name)
 190     :db-kind :join
 191     :db-info (:join-class ,join-class
 192               :home-key ,home-key
 193               :foreign-key ,foreign-key
 194               :set ,set)))
 195
 196 (defun gen-has-a (row)
 197   (gen-join-slot
 198    :name
 199    (format nil "~A->~A" (string (car row))(string (second row)))
 200    :home-key (second row)
 201    :foreign-key (third row)
 202    :join-class (fourth row)))
 203
 204 (defun gen-has-many (row)
 205   (gen-join-slot
 206    :name
 207    (format nil "~A->~A" (string (car row))(string (second row)))
 208    :home-key (third row)
 209    :foreign-key (second row)
 210    :join-class (car row)
 211    :set t))
 212
 213 (defun gen-many-to-many (row home-key foreign-key)
 214  (let ((name (sql->sym (string-upcase (format nil "~A<-~A->~A" (string (car row)) (string foreign-key) (string (second row)))))))
 215    (setf row (mapcar #'sql->sym row))
 216    `(,name
 217      :accessor ,name
 218      :db-kind :join
 219      :db-info (:join-class ,(car row)
 220                :home-key ,home-key
 221                :foreign-key ,foreign-key
 222                :target-slot ,name
 223                :set t))))
 224
 225 (defmethod update-records-from-instance :before ((view clsql::standard-db-object) &key database)
 226   (declare (ignorable database))
 227   (labels ((sym->sql (sym) (string-downcase (substitute #\_ #\- (string sym))))
 228            (get-def (slot) (caar (query
 229                                   (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)))))
 230            (get-default-value (slot) (caar (query (format nil "SELECT ~A" (get-def slot))))))
 231
 232     (dolist (slot (list-slots view))
 233       (when (and (primary-key-p view slot)
 234                  (or (not (slot-boundp view slot))
 235                      (equal (slot-value view slot) nil)))
 236         (setf (slot-value view slot) (get-default-value slot))))))
 237
 238 ;;;;
 239
 240 (defmacro def-view-class/meta (name supers slots &rest args)
 241   "Create and instrument CLSQL view-class NAME and
 242 appropriate meta-model class its default name is %NAME-meta-model."
 243
 244   `(progn
 245     (let* ((m (define-meta-model ,name ,supers ,slots ,args)))
 246       (setf (meta-model.base-type m) :clsql)
 247       (eval (generate-base-class-expander m ',name ',args)))))
 248
 249 (defmacro def-view-class-from-table (table &optional
 250                                 (name (clsql-pg-introspect::intern-normalize-for-lisp table)))
 251   "takes the name of a table as a string and
 252 creates a clsql view-class"
 253   `(clsql-pg-introspect:gen-view-class ,table
 254     :classname ,name
 255     :generate-joins :all
 256     :definer def-view-class/meta))
 257
 258
 259 (defmethod prepare-slot-name-for-select ((i standard-db-object) slot-name)
 260   (clsql:sql-expression :attribute slot-name))
 261
 262 (def-compare-expr standard-db-object expr-= sql-=)
 263 (def-compare-expr standard-db-object expr-< sql-<)
 264 (def-compare-expr standard-db-object expr-> sql->)
 265 (def-compare-expr standard-db-object expr-ends-with sql-uplike :value-format "%~A")
 266 (def-compare-expr standard-db-object expr-starts-with sql-uplike :value-format "~A%")
 267 (def-compare-expr standard-db-object expr-contains sql-uplike :value-format "%~A%")
 268
 269 (def-logical-expr standard-db-object expr-and #'sql-and)
 270
 271 (def-logical-expr standard-db-object expr-or #'sql-or)
 272
 273 (def-logical-expr standard-db-object expr-not #'sql-not)
 274
 275 (defmethod select-instances ((instance standard-db-object) &rest query)
 276   (unless (keywordp (car query))
 277     (setf query (cons :where query)))
 278   (apply #'select (class-name (class-of instance)) :flatp t query))