X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/579597e310dfac262d629aade17f86c3d6b80da4..ec044146bf44d8b651c6da400bbb78694f5eb9a0:/src/backend/clsql.lisp diff --git a/src/backend/clsql.lisp b/src/backend/clsql.lisp index 26e21cb..0083efc 100644 --- a/src/backend/clsql.lisp +++ b/src/backend/clsql.lisp @@ -8,20 +8,51 @@ (export 'def-view-class/meta) (export 'list-base-classes) + +(defmethod sync-instance ((view clsql:standard-db-object) &key (fill-gaps-only-p nil) (database *default-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) + (let ((def (get-def slot))) + (if def + (caar (query (format nil "SELECT ~A" def))))))) + + (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)) + (when (and (primary-key-p view slot) + (not (slot-value view slot)) + (not fill-gaps-only-p)) + (error "No default value for primary key : ~A" slot)))) + (when fill-gaps-only-p + (update-objects-joins (list view)) + (return-from sync-instance)) + (update-records-from-instance view :database database) + (update-instance-from-records view :database database) + (update-objects-joins (list view))) + + ;; return the modified and hopefully now persistent object + view) + + + (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)) +(defmethod generate-base-class-definition ((base-type (eql :clsql)) (model meta-model-class) (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)) +(defmethod generate-base-class-definition :after ((base-type (eql :clsql)) (model meta-model-class) (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))) +(defparameter *sql-type-map* '((:INT4 integer) (:BOOL boolean) (:TEXT string) (:VARCHAR string) (:TIMESTAMP clsql-sys::wall-time) (:NUMERIC number)(:BYTEA string))) (defun gen-type (table column) (cadr (assoc @@ -38,17 +69,26 @@ (intern (xform (string name)) package) (intern (xform (string name)))))) -(defun table->slots (table pkey) +(defun table->slots (table pkey &optional (accesor-prefix table) (prefix-all-p nil)) (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))) + (flet ((accessor-name (col) + (let ((name (sql->sym col))) + (if (or prefix-all-p + (and (fboundp name) + (eq (type-of (symbol-function name)) 'function))) + (sql->sym (concatenate 'string + (string accesor-prefix) "-" col)) + name)))) + + `(,(sql->sym col) + :accessor ,(accessor-name 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 () @@ -60,9 +100,6 @@ `(progn ,@defs))) - - - (defun get-pkeys () (let ((keys '())) (dolist (row (get-pkeys-query)) @@ -174,13 +211,13 @@ AND fa.attnum = ANY (pg_constraint.confkey)")) :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))))))) + (let ((name (sql->sym (string-upcase (format nil "~A<-~A->~A" (string (car row)) (string foreign-key) (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 + :home-key ,home-key :foreign-key ,foreign-key :target-slot ,name :set t)))) @@ -200,29 +237,42 @@ AND fa.attnum = ANY (pg_constraint.confkey)")) ;;;; -(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/meta (name supers slots &rest args) + "Create and instrument CLSQL view-class NAME and +appropriate meta-model class its default name is %NAME-meta-model." + + `(progn + (let* ((m (define-meta-model ,name ,supers ,slots ,args))) + (setf (meta-model.base-type m) :clsql) + (eval (generate-base-class-expander m ',name ',args))))) -(defmacro def-view-class/table (table &optional name) +(defmacro def-view-class-from-table (table &optional + (name (clsql-pg-introspect::intern-normalize-for-lisp 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/meta ,(if name name (sql->sym table)) - () - ,(append table-slots join-slots)))) + `(clsql-pg-introspect:gen-view-class ,table + :classname ,name + :generate-joins :all + :definer def-view-class/meta)) + + +(defmethod prepare-slot-name-for-select ((i standard-db-object) slot-name) + (clsql:sql-expression :attribute slot-name)) + +(def-compare-expr standard-db-object expr-= sql-=) +(def-compare-expr standard-db-object expr-< sql-<) +(def-compare-expr standard-db-object expr-> sql->) +(def-compare-expr standard-db-object expr-ends-with sql-uplike :value-format "%~A") +(def-compare-expr standard-db-object expr-starts-with sql-uplike :value-format "~A%") +(def-compare-expr standard-db-object expr-contains sql-uplike :value-format "%~A%") + +(def-logical-expr standard-db-object expr-and #'sql-and) +(def-logical-expr standard-db-object expr-or #'sql-or) +(def-logical-expr standard-db-object expr-not #'sql-not) +(defmethod select-instances ((instance standard-db-object) &rest query) + (unless (keywordp (car query)) + (setf query (cons :where query))) + (apply #'select (class-name (class-of instance)) :flatp t query))