(export 'list-base-classes)
-
-(defmethod sync-instance ((view clsql:standard-db-object) &key (database *default-database*))
+(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)))
- (error "No default value for primary key : ~A" slot)))))
+ (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)))))
- (update-records-from-instance view :database database)
- (update-instance-from-records view :database database)
- (update-objects-joins (list view)))
+ (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)
(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
(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 ()
: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))))
-(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)
+(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)
+ "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-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))
HCoop / clinton / lisp-on-lines.git / blobdiff