Patches sent from Vladimir Sekissov <svg@surnet.ru> 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

diff --git a/doc/lisp-on-lines.lyx b/doc/lisp-on-lines.lyx
index 5bf6161..0dd1a9e 100644 (file)
--- a/doc/lisp-on-lines.lyx
+++ b/doc/lisp-on-lines.lyx
@@ -31,7 +31,9 @@ LISP-ON-LINES
 
 
 \noun on 
 
 
 \noun on 

+v v v v v v v

 Drew Crampsie
 Drew Crampsie

+^ ^ ^ ^ ^ ^ ^

 \noun default 
 , 
 \noun on 
 \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
 \series bold 
 (setf (lisp-on-lines::find-attribute 'user 'userid)
 \begin_inset Marginal

-collapsed true
+collapsed false

 
 \layout Standard
 
 
 \layout Standard
 


@@ -954,7 +956,7 @@ product
 
 > 
 \series bold 
 
 > 
 \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
 
 \begin_inset Marginal
 collapsed true
 

diff --git a/src/backend/clsql.lisp b/src/backend/clsql.lisp
index 815653e..14f8b15 100644 (file)
--- 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
   (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)))
 
     (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 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)))
 
   `(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*))))
 
   (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))))))
 
        (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)
   (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 ()
    (list-attributes table)))
 
 (defun view-class-definition-list ()


@@ -205,29 +220,63 @@ AND fa.attnum = ANY (pg_constraint.confkey)"))
               :target-slot ,name
               :set t))))
  
               :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
     `(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)))
   "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)))
         (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 (file)
--- a/src/meta-model.lisp
+++ b/src/meta-model.lisp
@@ -16,7 +16,8 @@
     :initform nil)
    (base-type
     :accessor meta-model.base-type
     :initform nil)
    (base-type
     :accessor meta-model.base-type

-    :initform 'clsql)))
+    :initarg :base-type
+    :initform :clsql)))

 
 (defmethod meta-model.metadata ((self (eql nil)))
   nil)
 
 (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)
      ()
 (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)
   
   
 (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)))
 
      (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)))
 
 (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)))))
   
        (defmethod meta-model.metadata ((m ,name))
         ',(meta-model.metadata i)))))
   


@@ -184,6 +187,45 @@
            (getf (cdr att) :home-key) 
            (getf (cdr att) :foreign-key))))
   
            (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 (file)
--- 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 *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.
 
 ;;; 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))) 
   (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)
 
 
 (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))
   (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)))
 
 (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 (file)
--- a/src/mewa/presentations.lisp
+++ b/src/mewa/presentations.lisp
@@ -73,29 +73,80 @@
 
 
 ;;; searching
 
 
 ;;; 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))
 
 (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))
 
   (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)
 (defmethod render-on ((res response) (self mewa-presentation-search))
   (ucw::render-criteria res self)

+  (<ucw:input :type "submit" :value "Search" :action (ok self))

   (when (display-results-p self)
   (when (display-results-p self)

-    (let ((listing (ucw::list-presentation self))) 
-      (setf (instances listing ) (ucw::valid-instances self)
-           (slot-value listing 'ucw::calling-component) (slot-value self 'ucw::calling-component)
-           (slot-value listing 'ucw::place) (slot-value self 'ucw::place)
-           (slot-value listing 'ucw::continuation) (slot-value self 'ucw::continuation))
-    
+    (let ((listing (ucw::list-presentation self)))
+      (setf 
+       (slot-value listing 'ucw::calling-component) (slot-value self 'ucw::calling-component)
+       (slot-value listing 'ucw::place) (slot-value self 'ucw::place)
+       (slot-value listing 'ucw::continuation) (slot-value self 'ucw::continuation))
+      

       (render-on res listing))))
 
       (render-on res listing))))
 

-

 ;;;;
 (defcomponent dont-show-unset-slots ()())
 
 ;;;;
 (defcomponent dont-show-unset-slots ()())
 

diff --git a/src/mewa/slot-presentations.lisp b/src/mewa/slot-presentations.lisp
index fce3887..26a3332 100644 (file)
--- a/src/mewa/slot-presentations.lisp
+++ b/src/mewa/slot-presentations.lisp
@@ -8,6 +8,28 @@
                     (multiple-value-funcall->list #',(car form) ,@(cdr form))
                     ,@body))
 
                     (multiple-value-funcall->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))
 (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) 
         (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)
                    :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))
                    (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 )
     
 (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)))))
                :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 (<ucw:render-component :component pres))))
 
        (setf (component.place pres) (component.place (ucw::parent slot))))
       (when i (<ucw:render-component :component pres))))
 


@@ -127,10 +149,10 @@
 
 (defaction add-to-has-many ((slot has-many-slot-presentation) instance)
   (destructuring-bind (class home foreign) 
 
 (defaction add-to-has-many ((slot has-many-slot-presentation) instance)
   (destructuring-bind (class home foreign) 

-      (multiple-value-funcall #'meta-model:explode-has-many instance (slot-name slot))
+      (multiple-value-funcall->list #'meta-model:explode-has-many instance (slot-name slot))

     (let ((new (make-instance class)))
       (setf (slot-value new foreign) (slot-value instance home))
     (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)
       (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 (file)
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -32,7 +32,18 @@
    :list-has-many
    :list-many-to-many
    :sync-instance
    :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 
 
 
 (defpackage :mewa 


@@ -40,7 +51,8 @@
   (:export 
    :mewa 
    :mewa-object-presentation 
   (:export 
    :mewa 
    :mewa-object-presentation 

-   :mewa-one-line-presentation 
+   :mewa-one-line-presentation
+   :mewa-presentation-search

    :find-attribute 
    :set-default-attributes 
    :make-presentation 
    :find-attribute 
    :set-default-attributes 
    :make-presentation 


@@ -53,7 +65,9 @@
    :edit-instance
    :save-instance
    :cancel-save-instance
    :edit-instance
    :save-instance
    :cancel-save-instance

-   :global-properties))
+   :global-properties
+   :search-expr
+   :search-query))

 
 
 (defpackage :lisp-on-lines
 
 
 (defpackage :lisp-on-lines