From 9d6c69fb50810bef64e6f3357a21b4f4397e2b1b Mon Sep 17 00:00:00 2001 From: Drew Crampsie Date: Wed, 29 Jun 2005 15:14:41 -0700 Subject: [PATCH] Patches sent from Vladimir Sekissov applied manually Patch changes summary: * Search presentation now works as expected. Search criteria and queries are dispatched to appropriate backend. Added :presentation-search (could be subclass of mewa:mewa-presentation-search) view to model. * Fixed creation of meta-model class with distinct name * Added :fill-gaps-only keyword to meta-model:sync-instance With :fill-gaps-only true instance is not saved to database, only default values and join slots are setted. Previous behaviour failed on tables with not nullable fields without defaults. * Prepend generated slot accessor name with view name if it conflicts with existing functions. * Various small fixes. Best Regards, Vladimir Sekissov darcs-hash:20050629221441-5417e-0a1370d295df6cb6c9ce2f43c0b9c676d3ce7942.gz --- doc/lisp-on-lines.lyx | 6 +- src/backend/clsql.lisp | 111 ++++++++++++++++++++++--------- src/meta-model.lisp | 52 +++++++++++++-- src/mewa/mewa.lisp | 12 +++- src/mewa/presentations.lisp | 75 +++++++++++++++++---- src/mewa/slot-presentations.lisp | 34 ++++++++-- src/packages.lisp | 20 +++++- 7 files changed, 248 insertions(+), 62 deletions(-) diff --git a/doc/lisp-on-lines.lyx b/doc/lisp-on-lines.lyx index 5bf6161..0dd1a9e 100644 --- a/doc/lisp-on-lines.lyx +++ b/doc/lisp-on-lines.lyx @@ -31,7 +31,9 @@ LISP-ON-LINES \noun on +v v v v v v v Drew Crampsie +^ ^ ^ ^ ^ ^ ^ \noun default , \noun on @@ -561,7 +563,7 @@ Isn't this too imperative (in contrast to functional, lispy). \series bold (setf (lisp-on-lines::find-attribute 'user 'userid) \begin_inset Marginal -collapsed true +collapsed false \layout Standard @@ -954,7 +956,7 @@ product > \series bold -(lisp-on-lines::set-default-attributes (make-instance 'product)) +(lisp-on-lines::set-default-attributes (make-instance 'product))- \begin_inset Marginal collapsed true diff --git a/src/backend/clsql.lisp b/src/backend/clsql.lisp index 815653e..14f8b15 100644 --- a/src/backend/clsql.lisp +++ b/src/backend/clsql.lisp @@ -10,24 +10,30 @@ -(defmethod sync-instance ((view clsql:standard-db-object) &key (database *default-database*)) +(defmethod sync-instance ((view clsql:standard-db-object) &key (fill-gaps-only 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)) + (error "No default value for primary key : ~A" slot)))) + (when fill-gaps-only + (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)))) @@ -36,11 +42,11 @@ (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 def-base-type-class-expander ((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 def-base-type-class-expander :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*)))) @@ -61,17 +67,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 () @@ -205,29 +220,63 @@ AND fa.attnum = ANY (pg_constraint.confkey)")) :target-slot ,name :set t)))) -(defmacro def-view-class/meta (name supers slots &rest args) +(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). +(DEF-VIEW-CLASS/META NAME SUPERS SLOTS &key (MODEL-NAME (intern (format nil \"%~S-META-MODEL\" NAME))) &rest ARGS)." + (let ((model-name (cond ((eq :model-name (car args)) + (pop args) ; remove keyword + (pop args)) ; get value + (t (intern (format nil "%~S-META-MODEL" name)))))) `(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) + (def-meta-model ,model-name ,supers ,slots (:base-type :clsql) ,@args) + (def-base-class ,name (,model-name) ,@args)))) + +(defmacro def-view-class/table (table &optional (name (sql->sym table)) model-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)) + (table-slots (table->slots table pkey name)) (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)))) + `(def-view-class/meta ,name + () + ,(append table-slots join-slots) + ,@(when model-name (list :model-name model-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-like :value-format "%~A") +(def-compare-expr standard-db-object expr-starts-with sql-like :value-format "~A%") +(def-compare-expr standard-db-object expr-contains sql-like :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)) diff --git a/src/meta-model.lisp b/src/meta-model.lisp index 9065071..a0c842a 100644 --- a/src/meta-model.lisp +++ b/src/meta-model.lisp @@ -16,7 +16,8 @@ :initform nil) (base-type :accessor meta-model.base-type - :initform 'clsql))) + :initarg :base-type + :initform :clsql))) (defmethod meta-model.metadata ((self (eql nil))) nil) @@ -33,7 +34,7 @@ (defmethod %def-meta-model ((base-type t) name supers slots &rest options) `(defclass ,name ,(gen-supers supers) () - (:default-initargs :metadata ',slots))) + (:default-initargs :metadata ',slots :base-type ,base-type))) (defmacro def-meta-model (name supers slots &rest options) @@ -44,13 +45,15 @@ (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)) +(defgeneric def-base-type-class-expander (base-type model name args)) +(defmethod def-base-class-expander ((model t) name args) + (def-base-type-class-expander (meta-model.base-type model) model name args)) (defmacro def-base-class (name (model) &rest args) (let ((i (make-instance model))) - `(progn - ,(def-base-class-expander i :clsql name args) + `(prog1 + (eval ,(def-base-class-expander i name args)) (defmethod meta-model.metadata ((m ,name)) ',(meta-model.metadata i))))) @@ -184,6 +187,45 @@ (getf (cdr att) :home-key) (getf (cdr att) :foreign-key)))) +(defgeneric expr-= (instance slot-name value) + (:documentation "Create search expression for appropriate backend.")) +(defgeneric expr-> (instance slot-name value) + (:documentation "Create search expression for appropriate backend.")) +(defgeneric expr-< (instance slot-name value) + (:documentation "Create search expression for appropriate backend.")) +(defgeneric expr-ends-with (instance slot-name value) + (:documentation "Create search expression for appropriate backend.")) + +(defgeneric expr-starts-with (instance slot-name value) + (:documentation "Create search expression for appropriate backend.")) + +(defgeneric expr-contains (instance slot-name value) + (:documentation "Create search expression for appropriate backend.")) + +(defgeneric expr-and (instance &rest args) + (:documentation "Create search expression for appropriate backend.")) + +(defgeneric expr-or (instance &rest args) + (:documentation "Create search expression for appropriate backend.")) + +(defgeneric expr-not (instance &rest args) + (:documentation "Create search expression for appropriate backend.")) + +(defgeneric select-instances (instance &rest args) + (:documentation "Select instances in backend dependent way")) + +(defmacro def-compare-expr (instance-type name expr &key value-format) + `(defmethod ,name ((instance ,instance-type) slot-name value) + (declare (ignore instance)) + (,expr slot-name ,(typecase value-format + (null 'value) + (string `(format nil ,value-format value)) + (t `(,value-format value)))))) + +(defmacro def-logical-expr (instance-type name expr) + `(defmethod ,name ((instance ,instance-type) &rest args) + (declare (ignore instance)) + (apply ,expr args))) \ No newline at end of file diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp index ba7d6d9..782e19f 100644 --- a/src/mewa/mewa.lisp +++ b/src/mewa/mewa.lisp @@ -3,7 +3,13 @@ (defparameter *default-type* :ucw) ;;; maps meta-model slot-types to slot-presentation -(defparameter *slot-type-map* '(number ucw:currency)) +(defparameter *slot-type-map* + '(boolean ucw::mewa-boolean + string ucw::mewa-string + number ucw::mewa-currency + integer ucw::mewa-integer + currency ucw::mewa-currency + )) ;;; an alist of model-class-name . attributes ;;; should really be a hash-table. @@ -27,7 +33,7 @@ (mapcar #'(lambda (x) (gen-pslot (cadr x) (string (car x)) (car x))) - (list-slot-types instance))) + (meta-model:list-slot-types instance))) (defun gen-pslot (type label slot-name) @@ -265,7 +271,7 @@ attributes is an alist keyed on the attribute nreeame." (setf (slots to) (mapcar #'(lambda (x) (prog2 (setf (component.place x) (component.place from)) x)) - (slots to)))) + (slots to)))) (defmacro call-presentation (object &rest args) `(present-object ,object :presentation (make-presentation ,object ,@args))) diff --git a/src/mewa/presentations.lisp b/src/mewa/presentations.lisp index 9cf4fcb..39a6647 100644 --- a/src/mewa/presentations.lisp +++ b/src/mewa/presentations.lisp @@ -73,29 +73,80 @@ ;;; searching +(defgeneric search-expr (criteria instance) + (:documentation "Return ready to apply criteria. + What to do with it is backend dependent.")) -(defcomponent mewa-presentation-search (ucw::presentation-search) - ((display-results-p :accessor display-results-p :initarg :display-results-p :initform nil))) +(defmacro def-search-expr (((self criteria-type)) (model-expr &body body)) + `(defmethod search-expr ((,self ,criteria-type) instance) + (,model-expr + instance + (ucw::slot-name (ucw::presentation ,self)) + ,@body))) + +(defmethod search-expr ((self ucw::negated-criteria) instance) + (when (ucw::criteria self) + (meta-model:expr-not + instance + (search-expr (ucw::criteria self) instance)))) + +(def-search-expr ((self ucw::string-starts-with)) + (meta-model:expr-starts-with (ucw::search-text self))) + +(def-search-expr ((self ucw::string-ends-with)) + (meta-model:expr-ends-with (ucw::search-text self))) + +(def-search-expr ((self ucw::string-contains)) + (meta-model:expr-contains (ucw::search-text self))) + +(def-search-expr ((self ucw::number-less-than)) + (meta-model:expr-< (ucw::number-input self))) + +(def-search-expr ((self ucw::number-greater-than)) + (meta-model:expr-> (ucw::number-input self))) + +(def-search-expr ((self ucw::number-equal-to)) + (meta-model:expr-= (ucw::number-input self))) + +(defcomponent mewa-presentation-search (ucw::presentation-search) + ((display-results-p :accessor display-results-p :initarg :display-results-p :initform nil))) + +(defmethod instance ((self mewa:mewa-presentation-search)) + (instance (ucw::search-presentation self))) + +(defmethod search-expr ((self mewa:mewa-presentation-search) instance) + (apply #'meta-model:expr-and instance + (mapcan (lambda (c) (let ((e (search-expr c instance))) + (if (listp e) e (list e)))) + (ucw::criteria self)))) + + +(defmethod search-query ((self mewa:mewa-presentation-search)) + (search-expr self (instance self))) + +(defmethod valid-instances ((self mewa:mewa-presentation-search)) + (meta-model:select-instances (instance self) (search-query self))) + +(defmethod get-all-instances ((self mewa-presentation-search)) + (meta-model:select-instances (instance self))) (defmethod ok ((self mewa-presentation-search) &optional arg) (declare (ignore arg)) + (setf (ucw::list-presentation self) (valid-instances self)) (setf (display-results-p self) t)) -(defmethod get-all-instances ((self mewa-presentation-search)) - (clsql:select (class-name (class-of (instance (ucw::search-presentation self)))) :flatp t)) - (defmethod render-on ((res response) (self mewa-presentation-search)) (ucw::render-criteria res self) + (list #',(car form) ,@(cdr form)) ,@body)) +(defslot-presentation mewa-boolean-slot-presentation (boolean-slot-presentation) + ((slot-name :accessor slot-name :initarg :slot-name)) + (:type-name mewa-boolean)) + +(defslot-presentation mewa-string-slot-presentation (string-slot-presentation ) + + ((slot-name :accessor slot-name :initarg :slot-name)) + (:type-name mewa-string)) + +(defslot-presentation mewa-number-slot-presentation (number-slot-presentation) + ((slot-name :accessor slot-name :initarg :slot-name)) + (:type-name mewa-number)) + +(defslot-presentation mewa-integer-slot-presentation (integer-slot-presentation) + ((slot-name :accessor slot-name :initarg :slot-name)) + (:type-name mewa-integer)) + +(defslot-presentation mewa-currency-slot-presentation (currency-slot-presentation) + + ((slot-name :accessor slot-name :initarg :slot-name)) + (:type-name mewa-currency)) + (defslot-presentation clsql-wall-time-slot-presentation (mewa-relation-slot-presentation) () (:type-name clsql-sys:wall-time)) @@ -62,7 +84,8 @@ (new-instance (call-component (parent slot) - (make-instance 'mewa::mewa-presentation-search + (make-instance (or (cadr (mewa:find-attribute finstance :presentation-search)) + 'mewa::mewa-presentation-search) :search-presentation (mewa:make-presentation finstance :type :search-presentation) @@ -70,8 +93,7 @@ (mewa:make-presentation finstance :type :listing))))) (setf (slot-value instance (slot-name slot)) (slot-value new-instance foreign-slot-name)) - (meta-model:sync-instance instance) - (clsql:update-objects-joins (list instance)))) + (meta-model:sync-instance instance))) (defmethod present-relation ((slot mewa-relation-slot-presentation) instance) ;;;;(<:as-html (slot-name slot) "=> " (foreign-instance slot) " from " instance ) @@ -82,7 +104,7 @@ :initargs (list :global-properties (list :editablep nil :linkedp nil))))) - (when (ucw::parent slot) + (when (and (ucw::parent slot) (slot-boundp slot 'ucw::place)) (setf (component.place pres) (component.place (ucw::parent slot)))) (when i (list #'meta-model:explode-has-many instance (slot-name slot)) (let ((new (make-instance class))) (setf (slot-value new foreign) (slot-value instance home)) - (meta-model:sync-instance new) + (meta-model:sync-instance new :fill-gaps-only t) (call-component (parent slot) (mewa:make-presentation new :type :editor))))) (defmethod present-slot ((slot has-many-slot-presentation) instance) diff --git a/src/packages.lisp b/src/packages.lisp index 267ca22..2466038 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -32,7 +32,18 @@ :list-has-many :list-many-to-many :sync-instance - :explode-has-many)) + :explode-has-many + :expr-ends-with + :expr-starts-with + :expr-contains + :expr-= + :expr-< + :expr-> + :expr-and + :expr-or + :expr-not + :select-instances + )) (defpackage :mewa @@ -40,7 +51,8 @@ (:export :mewa :mewa-object-presentation - :mewa-one-line-presentation + :mewa-one-line-presentation + :mewa-presentation-search :find-attribute :set-default-attributes :make-presentation @@ -53,7 +65,9 @@ :edit-instance :save-instance :cancel-save-instance - :global-properties)) + :global-properties + :search-expr + :search-query)) (defpackage :lisp-on-lines -- 2.20.1