From 68a53dce242a91b60aa9006db596987911082fec Mon Sep 17 00:00:00 2001 From: Drew Crampsie Date: Mon, 22 Aug 2005 13:54:57 -0700 Subject: [PATCH] fixes for ucw+interpreter darcs-hash:20050822205457-5417e-33be4ebe946a8e5bbe7df391c1523545ec68aa93.gz --- lisp-on-lines.asd | 2 ++ src/backend/clsql.lisp | 5 ++- src/meta-model.lisp | 19 +++++++++--- src/mewa/mewa.lisp | 52 +++++++++++--------------------- src/mewa/slot-presentations.lisp | 5 ++- src/packages.lisp | 8 ++++- 6 files changed, 47 insertions(+), 44 deletions(-) diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd index 45cf603..865f11d 100644 --- a/lisp-on-lines.asd +++ b/lisp-on-lines.asd @@ -35,6 +35,8 @@ (defsystem :lisp-on-lines :components ((:static-file "lisp-on-lines.asd") + (:module :src + :components ((:file "lisp-on-lines"))) (:module :components :pathname "src/components/" :components ((:file "range-list")))) diff --git a/src/backend/clsql.lisp b/src/backend/clsql.lisp index 9bbea61..8d593dc 100644 --- a/src/backend/clsql.lisp +++ b/src/backend/clsql.lisp @@ -33,7 +33,10 @@ (return-from sync-instance)) (update-records-from-instance view :database database) (update-instance-from-records view :database database) - (update-objects-joins (list view)))) + (update-objects-joins (list view))) + + ;; return the modified and hopefully now persistent object + view) diff --git a/src/meta-model.lisp b/src/meta-model.lisp index 4416423..09f7f6f 100644 --- a/src/meta-model.lisp +++ b/src/meta-model.lisp @@ -156,14 +156,23 @@ most of the below functions expect this method to exist" :test-key :target-slot :return-full t))) -(defmethod explode-foreign-key ((model clsql:standard-db-object) slot) +(defmethod explode-foreign-key ((model clsql:standard-db-object) slot &key (createp t)) "returns the clsql view-class joined on SLOT" (dolist (s (list-join-attributes model)) (when (equal (getf (cdr s) :home-key) slot) - (let ((val (slot-value model (car s)))) - (return-from explode-foreign-key - (values (if val val (make-instance (getf (cdr s) :join-class))) - (getf (cdr s) :foreign-key))))))) + (let* ((fkey (getf (cdr s) :foreign-key)) + (new (sync-instance (make-instance (getf (cdr s) :join-class)))) + (val (or (slot-value model (car s)) + (progn + (when createp + (setf + (slot-value model slot) + (slot-value new fkey)) + (sync-instance model) + (slot-value model (car s))))))) + + (return-from explode-foreign-key + (values val fkey)))))) (defun find-join-helper (foreign-key) (lambda (class slot) diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp index 4434039..785f05d 100644 --- a/src/mewa/mewa.lisp +++ b/src/mewa/mewa.lisp @@ -1,4 +1,3 @@ - (in-package :mewa) (defparameter *default-type* :ucw) @@ -170,10 +169,6 @@ attributes is an alist keyed on the attribute name." (modifications :accessor modifications :initform nil))) - - - - (defmethod attributes :around ((self mewa)) (let ((a (call-next-method))) (or a (funcall (attributes-getter self) self)))) @@ -264,31 +259,20 @@ attributes is an alist keyed on the attribute name." (setf (attribute-slot-map self) (find-slot-presentations self)) (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self ))))) - -(defmethod make-presentation ((object t) &key (type :viewer) (initargs nil)) - (let* ((p (make-instance 'mewa-object-presentation)) - (a (progn (setf (slot-value p 'instance) object) - (initialize-slots p) - (assoc type (find-all-attributes p)))) - - (i (apply #'make-instance (second a) (plist-union initargs (cddr a))))) - (setf (slot-value i 'instance) object) - i)) - (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil)) (let* ((p (make-instance 'mewa-object-presentation)) - (a (progn (setf (slot-value p 'instance) object) + (a (progn (setf (slot-value p 'ucw::instance) object) (initialize-slots p) (assoc type (find-all-attributes p)))) - - (i (apply #'make-instance (or (second a) - ;; if we didnt find the type, - ;; use the symbol as a class. - (if (eql (symbol-package type) - (find-package 'keyword)) - (symbol-name type) - type)) - (plist-union initargs (cddr a))))) + ;;;; TODO: this can be cleaned up, probably CHANGE-CLASS is better here + (i (apply #'change-class p (or (second a) + ;; if we didnt find the type, + ;; use the symbol as a class. + (if (eql (symbol-package type) + (find-package 'keyword)) + (symbol-name type) + type)) + (plist-union initargs (cddr a))))) (setf (slot-value i 'instance) object) (initialize-slots i) (setf (slot-value i 'initializedp) t) @@ -301,14 +285,14 @@ attributes is an alist keyed on the attribute name." (setf (component.place x) place))) (slots mewa)))) -(defmethod call-component :before ((from standard-component) (to mewa)) +(arnesi:defmethod/cc call-component :before ((from standard-component) (to mewa)) (unless (slot-value to 'initializedp) (initialize-slots to)) (setf (slot-value to 'initializedp) t) - (setf (slots to) (mapcar #'(lambda (x) (prog2 - (setf (component.place x) (component.place from)) - x)) - (slots to)))) + (initialize-slots-place (component.place from) to) + to) + + (defmacro call-presentation (object &rest args) `(present-object ,object :presentation (make-presentation ,object ,@args))) @@ -357,9 +341,9 @@ attributes is an alist keyed on the attribute name." (defaction ok ((self mewa) &optional arg) "Returns the component if it has not been modified. if it has been, prompt user to save or cancel" - (declare (ignore arg)) - (ensure-instance-sync self) - (answer self)) + ;(declare (ignore arg)) + (meta-model::sync-instance (instance self)) + (answer (instance self))) (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance) (let* ((old (prog1 diff --git a/src/mewa/slot-presentations.lisp b/src/mewa/slot-presentations.lisp index 2232ec1..4254227 100644 --- a/src/mewa/slot-presentations.lisp +++ b/src/mewa/slot-presentations.lisp @@ -30,8 +30,6 @@ (<:as-html (presentation-slot-value slot instance))))) - - (defcomponent mewa-slot-presentation () ((slot-name :accessor slot-name :initarg :slot-name @@ -42,7 +40,8 @@ :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.")) +When T, only the default value for primary keys and the joins are updated.") + (show-label-p :accessor show-label-p :initarg :show-label-p :initform t)) (:documentation "The superclass of all Mewa slot presentations")) ;;;; this has to be in the eval when i would think diff --git a/src/packages.lisp b/src/packages.lisp index 596af25..0c7568e 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -79,10 +79,16 @@ (:use :mewa :meta-model :common-lisp :it.bese.ucw) (:nicknames :lol) (:export + ;;;; LoL + :initialize-lol-for-table + :initialize-lol-for-database + + + ;;;; Mewa Exports :mewa ;the superclass of all mewa-presentations :make-presentation - + :call-presentation ;;attributes :attributes :set-default-attributes -- 2.20.1