From: Drew Crampsie Date: Mon, 4 Jul 2005 11:12:58 +0000 (-0700) Subject: Renamed fill-gaps-only to fill-gaps-only-p, and added the :fill-gaps-only-p initarg... X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/commitdiff_plain/e9454185bda3d35420ad39ae2817260bd222e789?hp=835ac88dcdbdb3389dd922748d31546875b1599a;ds=sidebyside Renamed fill-gaps-only to fill-gaps-only-p, and added the :fill-gaps-only-p initarg to all mewa-slot-presentations. the default is NIL as T breaks my existing system. I also made a macro to simplify the creation of the mewa-slot-presentations. darcs-hash:20050704111258-5417e-ceee0eba9b48fa77dd71ec5096d392113416000d.gz --- diff --git a/src/backend/clsql.lisp b/src/backend/clsql.lisp index 6d84dc7..a6e9c68 100644 --- a/src/backend/clsql.lisp +++ b/src/backend/clsql.lisp @@ -10,7 +10,7 @@ -(defmethod sync-instance ((view clsql:standard-db-object) &key (fill-gaps-only nil) (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))))) @@ -26,9 +26,9 @@ (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)) + (not fill-gaps-only-p)) (error "No default value for primary key : ~A" slot)))) - (when fill-gaps-only + (when fill-gaps-only-p (update-objects-joins (list view)) (return-from sync-instance)) (update-records-from-instance view :database database) diff --git a/src/mewa/slot-presentations.lisp b/src/mewa/slot-presentations.lisp index 09d1488..4e69bd8 100644 --- a/src/mewa/slot-presentations.lisp +++ b/src/mewa/slot-presentations.lisp @@ -8,27 +8,42 @@ (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)) +(defcomponent mewa-slot-presentation () + ((slot-name :accessor slot-name + :initarg :slot-name + :documentation + "The name of the slot being accessed") + (fill-gaps-only-p :accessor fill-gaps-only-p + :initarg :fill-gaps-only-p + :initform nil + :documentation + "When nil, the instance is syncronised with the database. +When T, only the default value for primary keys and the joins are updated.")) + (:documentation "The superclass of all Mewa slot presentations")) + +;;;; this has to be in the eval when i would think +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun generate-slot-presentation-definition-for-type (type) + (let* ((u-name (intern (format nil "~A-SLOT-PRESENTATION" type))) + (sp-name (intern (format nil "MEWA-~A" u-name))) + (t-name (intern (format nil "MEWA-~A" type)))) + `(defslot-presentation ,sp-name (,u-name mewa-slot-presentation) + () + (:type-name ,t-name))))) + +(defmacro define-base-mewa-presentations (&body types) + "Define the mewa-slot-presentations by subclassing the base UCW ones" + `(progn ,@(mapcar #'generate-slot-presentation-definition-for-type + types))) + +;;;then actually define the base presentations : +(define-base-mewa-presentations + boolean + string + number + integer + currency) -(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) () @@ -65,9 +80,8 @@ ifFormat : \"%m/%d/%Y\", });" input-id)))))) -(defslot-presentation mewa-relation-slot-presentation () - ((slot-name :accessor slot-name :initarg :slot-name) - (foreign-instance :accessor foreign-instance) +(defslot-presentation mewa-relation-slot-presentation (mewa-slot-presentation slot-presentation) + ((foreign-instance :accessor foreign-instance) (linkedp :accessor linkedp :initarg :linkedp :initform t)) (:type-name relation)) @@ -78,23 +92,32 @@ (cons finstance foreign-slot-name))) (defaction search-records ((slot mewa-relation-slot-presentation) instance) - (let* ((d (get-fkey-data instance (slot-name slot))) - (finstance (car d)) - (foreign-slot-name (cdr d)) - (new-instance - (call-component - (parent slot) - (make-instance (or (cadr (mewa:find-attribute finstance :presentation-search)) - 'mewa::mewa-presentation-search) - :search-presentation - (mewa:make-presentation finstance - :type :search-presentation) - :list-presentation - (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))) - + (multiple-value-bindf (finstance foreign-slot-name) + (meta-model:explode-foreign-key instance (slot-name slot)) + (let ((new-instance + (call-component + (parent slot) + (make-instance (or (cadr (mewa:find-attribute finstance :presentation-search)) + 'mewa::mewa-presentation-search) + :search-presentation + (mewa:make-presentation finstance + :type :search-presentation) + :list-presentation + (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 :fill-gaps-only t)))) + +(defaction create-record ((slot mewa-relation-slot-presentation) instance) + (multiple-value-bindf (finstance foreign-slot-name) + (meta-model:explode-foreign-key instance (slot-name slot)) + (let ((new-instance + (call-component + (parent slot) + (mewa:make-presentation finstance :type :editor)))) + (setf (slot-value instance (slot-name slot)) (slot-value new-instance foreign-slot-name)) + (meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p self))))) + (defmethod present-relation ((slot mewa-relation-slot-presentation) instance) ;;;;(<:as-html (slot-name slot) "=> " (foreign-instance slot) " from " instance ) (let* ((i (foreign-instance slot)) @@ -150,9 +173,9 @@ (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 :fill-gaps-only t) + (meta-model:sync-instance new :fill-gaps-only-p (fill-gaps-only-p self)) (call-component (parent slot) (mewa:make-presentation new :type :editor)) - (meta-model:sync-instance (instance (parent slot)))))) + (meta-model:sync-instance instance)))) (defmethod present-slot ((slot has-many-slot-presentation) instance) (