Changeset 3694

Show
Ignore:
Timestamp:
07/30/08 13:21:33 (4 months ago)
Author:
hans
Message:

back out 3685-3692, that was too much to swallow

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • trunk/bknr/datastore/src/data/object-tests.lisp

    r3692 r3694  
    4848(defvar *tests* (make-hash-table)) 
    4949 
    50 (defmacro define-datastore-test (name &body body) 
     50(defmacro define-datastore-test (name &rest body) 
    5151  `(setf (gethash ,name *tests*) 
    5252         (make-instance 'datastore-test-class 
    …… 
    119119  (test-equal (all-store-objects) nil)) 
    120120 
    121 (define-datastore-test :make-instance-in-anon-txn 
    122   (with-transaction () 
    123     (make-instance 'store-object))) 
    124  
    125 (define-datastore-test :make-object-in-anon-txn 
    126   (with-transaction () 
    127     (make-object 'store-object))) 
    128  
    129121(define-persistent-class parent () 
    130122  ((child :update :initform nil))) 

  • trunk/bknr/datastore/src/data/object.lisp

    r3691 r3694  
    9292    (when (and (persistent-slot-p slotd) 
    9393               (not (eq :restore (store-state *store*))) 
    94                (not (member slot-name '(last-change id)))) 
     94               (not (eq 'last-change slot-name))) 
    9595      (setf (slot-value object 'last-change) (current-transaction-timestamp))))) 
    9696 
    …… 
    191191(aclmop::finalize-inheritance (find-class 'store-object)) 
    192192 
    193 (defmethod initialize-instance :around ((object store-object) &rest initargs &key) 
     193(defmethod initialize-instance :around 
     194    ((object store-object) &key &allow-other-keys) 
    194195  (if (in-anonymous-transaction-p) 
    195196      (prog1 
    …… 
    198199                               :function-symbol 'make-instance 
    199200                               :timestamp (get-universal-time) 
    200                                :args (cons (class-name (class-of object)) initargs)) 
     201                               :args (cons (class-name (class-of object)) 
     202                                           (loop for slotd in (class-slots (class-of object)) 
     203                                              for slot-name = (slot-definition-name slotd) 
     204                                              for slot-initarg = (first (slot-definition-initargs slotd)) 
     205                                              when (and slot-initarg 
     206                                                        (slot-boundp object slot-name)) 
     207                                              appending (list slot-initarg (slot-value object slot-name))))) 
    201208                (anonymous-transaction-log-buffer *current-transaction*))) 
    202209      (call-next-method))) 
    203210 
    204 (defmethod allocate-instance :around ((class persistent-class) &key) 
    205   (let* ((object (call-next-method)) 
    206          (subsystem (store-object-subsystem)) 
    207          (id (next-object-id subsystem))) 
    208     (incf (next-object-id subsystem)) 
    209     (setf (slot-value object 'id) id) 
    210     object)) 
    211  
    212 (defmethod initialize-instance :after ((object store-object) &key) 
    213   ;; This is called only when initially creating the (persistent) 
    214   ;; instance, not during restore.  During restore, the 
    215   ;; INITIALIZE-TRANSIENT-INSTANCE function is called after the 
    216   ;; snapshot has been read, but before running the transaction log. 
    217   (initialize-transient-instance object)) 
     211(defmethod initialize-instance :after ((object store-object) &key id &allow-other-keys) 
     212  (let ((subsystem (store-object-subsystem))) 
     213    (cond (id 
     214           ;; during restore, use the given ID 
     215           (when (>= id (next-object-id subsystem)) 
     216             (setf (next-object-id subsystem) (1+ id)))) 
     217          (t 
     218           ;; normal transaction: assign a new ID 
     219           (setf id (next-object-id subsystem)) 
     220           (incf (next-object-id subsystem)) 
     221           (setf (slot-value object 'id) id))))) 
    218222 
    219223(defmethod print-object ((object store-object) stream) 
    …… 
    241245                          :args (append (list object (if (symbolp class) class (class-name class))) args)))) 
    242246 
     247(defgeneric initialize-persistent-instance (store-object &key &allow-other-keys) 
     248  (:documentation 
     249   "Initializes the persistent aspects of a persistent object. This 
     250method is called at the creation of a persistent object, but not when 
     251the object is loaded from a snapshot.")) 
     252 
    243253(defgeneric initialize-transient-instance (store-object) 
    244254  (:documentation 
    245255   "Initializes the transient aspects of a persistent object. This 
    246 method is called after a persistent object has been initialized, also 
    247 when the object is loaded from a snapshot, but before reading the 
    248 transaction log.")) 
    249  
     256method is called whenever a persistent object is initialized, also 
     257when the object is loaded from a snapshot.")) 
     258 
     259(defmethod initialize-persistent-instance ((object store-object) &key)) 
    250260(defmethod initialize-transient-instance ((object store-object))) 
    251261 
    …… 
    455465      ;; running Lisp image and objects of this class will be ignored. 
    456466      (when class 
    457         (setf (next-object-id (store-object-subsystem)) object-id) 
    458         (let ((object (allocate-instance class))) 
    459           (assert (= object-id (slot-value object 'id))) 
    460           (dolist (index (class-slot-indices class 'id)) 
    461             (index-add index object))))))) 
     467        (make-instance class :id object-id))))) 
    462468 
    463469(defun snapshot-read-slots (stream layouts) 
    …… 
    636642                                (remove-transient-slot-initargs (find-class class-name) initargs) 
    637643                                initargs))) 
     644           (apply #'initialize-persistent-instance obj initargs) 
     645           (initialize-transient-instance obj) 
    638646           (setf error nil) 
    639647           obj) 
    …… 
    642650 
    643651(defun make-object (class-name &rest initargs) 
    644   "Make a persistent object of class named CLASS-NAME. Calls MAKE-INSTANCE with INITARGS." 
    645   (if (in-anonymous-transaction-p) 
    646       (apply #'make-instance class-name initargs) 
    647       (with-store-guard () 
    648         (execute (make-instance 'transaction 
    649                                 :function-symbol 'tx-make-object 
    650                                 :args (append (list class-name 
    651                                                     :id (next-object-id (store-object-subsystem))) 
    652                                               initargs)))))) 
     652  "Make a persistent object of class named CLASS-NAME. Calls MAKE-INSTANCE with INITARGS."   
     653  (with-store-guard () 
     654    (execute (make-instance 'transaction 
     655                            :function-symbol 'tx-make-object 
     656                            :args (append (list class-name 
     657                                                :id (next-object-id (store-object-subsystem))) 
     658                                          initargs))))) 
    653659 
    654660(defun tx-delete-object (id) 

  • trunk/bknr/datastore/src/data/package.lisp

    r3689 r3694  
    5252           #:cascading-delete-object 
    5353    
     54           #:initialize-persistent-instance 
    5455           #:initialize-transient-instance 
    5556 

  • trunk/bknr/datastore/src/data/tutorial.lisp

    r3689 r3694  
    459459;;; to be created using the function `MAKE-OBJECT'. This creates an 
    460460;;; instance of the object inside a transaction, sets its ID slot 
    461 ;;; appropriately, and then calls `INITIALIZE-TRANSIENT-INSTANCE'. The 
    462 ;;; standard CLOS function `INITIALIZE-INSTANCE' is called when the 
    463 ;;; object is created inside a transaction, but not if the object is 
    464 ;;; being restored from the snapshot file. 
    465 ;;; `INITIALIZE-TRANSIENT-INSTANCE' is called at object creation 
    466 ;;; inside a transaction and at object creation during restore. It 
    467 ;;; must be specialized to initialize the transient slots (not logged 
     461;;; appropriately, and then calls `INITIALIZE-PERSISTENT-INSTANCE' and 
     462;;; `INITIALIZE-TRANSIENT-INSTANCE'. The first method is called when 
     463;;; the object is created inside a transaction, but not if the object 
     464;;; is being restored from the snapshot file. This method has to be 
     465;;; overridden in order to initialize persistent 
     466;;; slots. `INITIALIZE-TRANSIENT-INSTANCE' is called at object 
     467;;; creation inside a transaction and at object creation during 
     468;;; restore. It is used to initialize the transient slots (not logged 
    468469;;; to the snapshot file) of a persistent object. 
    469470;;; 
    …… 
    816817;;; after each slot value has been set, the method 
    817818;;; `INITIALIZE-TRANSIENT-INSTANCE' is called for each created 
    818 ;;; object. 
     819;;; object. The method `INITIALIZE-PERSISTENT-INSTANCE' is not called, 
     820;;; as it has to be executed only once at the time the persistent 
     821;;; object is created. 
    819822 
    820823;;;## Garbage collecting blobs 

  • trunk/bknr/modules/feed/feed.lisp

    r3689 r3694  
    2424   (type :update :documentation "(or :rss091 :rss10 :rss20 :atom)") 
    2525   (encoding :update :initform :iso-8859-1 :documentation "(or :utf8 :iso-8859-1)"))) 
     26 
     27;(defmethod initialize-transient-instance ((feed feed)) 
     28;  (ignore-errors (update-feed feed))) 
    2629 
    2730(defmethod print-object ((object feed) stream) 

  • trunk/bknr/modules/text/article.lisp

    r3689 r3694  
    3737                                        (article-text article)))) 
    3838 
    39 (defmethod initialize-instance :after ((article article) &key) 
     39(defmethod initialize-persistent-instance :after ((article article) &key) 
    4040  (setf (article-search-vector article) 
    4141        (article-to-search-vector article))) 

  • trunk/bknr/web/src/rss/rss.lisp

    r3689 r3694  
    177177    (warn "no RSS channel defined for item ~A" item))) 
    178178 
    179 (defmethod initialize-instance :after ((rss-item rss-item) &key) 
     179(defmethod initialize-persistent-instance :after ((rss-item rss-item) &key) 
    180180  (add-item (rss-item-channel rss-item) rss-item)) 
    181181 

  • trunk/bknr/web/src/sysclasses/user.lisp

    r3689 r3694  
    6161                "unbound")))) 
    6262 
    63 (defmethod initialize-instance ((user user) &key) 
     63(defmethod initialize-persistent-instance ((user user) &key) 
    6464  (let* ((plaintext-password (slot-value user 'password)) 
    6565         (password (when plaintext-password (crypt-md5 plaintext-password (make-salt))))) 
    …… 
    7373  ()) 
    7474 
    75 (defmethod initialize-instance ((user smb-user) &key) 
     75(defmethod initialize-persistent-instance ((user smb-user) &key) 
    7676  (let* ((plaintext-password (slot-value user 'password))) 
    7777    (when plaintext-password 

  • trunk/build.lisp

    r3688 r3694  
    192192 
    193193(defun test () 
    194   (cl-gd::load-gd-glue)   
     194  (cl-gd::load-gd-glue) 
    195195  (format t "~&;;; --- running tests~%") 
    196196  (run-tests 
    197     #+(or) 
    198     (cl-ppcre-run-no-failures-p)     
    199     (cl-gd-run-no-failures-p) 
    200     #+(or) 
    201     (flexi-streams-no-failures-p) 
    202     (unit-test:run-all-tests) 
    203     (rt:do-tests) 
    204     (fiveam-run-no-failures-p :bknr.datastore) 
    205     #-darwin (fiveam-run-no-failures-p :bos.test) 
    206     (progn #+(or) (fiveam-run-no-failures-p :it.bese.FiveAM) 
    207           (warn "skipping :it.bese.FiveAM tests") 
    208           t) 
    209     (fiveam-run-no-failures-p 'json-test::json) 
    210     )) 
    211  
     197   #+(or) 
     198   (cl-ppcre-run-no-failures-p)     
     199   (cl-gd-run-no-failures-p) 
     200   #+(or) 
     201   (flexi-streams-no-failures-p) 
     202   (unit-test:run-all-tests) 
     203   (rt:do-tests) 
     204   (fiveam-run-no-failures-p :bknr.datastore) 
     205   #-darwin (fiveam-run-no-failures-p :bos.test) 
     206   (progn #+(or) (fiveam-run-no-failures-p :it.bese.FiveAM) 
     207          (warn "skipping :it.bese.FiveAM tests") 
     208          t) 
     209   (fiveam-run-no-failures-p 'json-test::json) 
     210   )) 
     211 

  • trunk/projects/bos/m2/allocation.lisp

    r3689 r3694  
    3535            (store-object-id allocation-area)))) 
    3636 
    37 (defmethod initialize-instance :after ((allocation-area allocation-area) &key) 
     37(defmethod initialize-persistent-instance :after ((allocation-area allocation-area) &key) 
    3838  (with-slots (total-m2s free-m2s) allocation-area 
    3939    (setf total-m2s (calculate-total-m2-count allocation-area)) 

  • trunk/projects/bos/m2/m2.lisp

    r3689 r3694  
    279279  (equal (class-of object) (find-class 'contract))) 
    280280 
    281 (defmethod initialize-instance :after ((contract contract) &key) 
     281(defmethod initialize-persistent-instance :after ((contract contract) &key) 
    282282  (pushnew contract (sponsor-contracts (contract-sponsor contract))) 
    283283  (dolist (m2 (contract-m2s contract)) 

  • trunk/projects/bos/m2/poi.lisp

    r3689 r3694  
    3636  (apply #'make-object class-name rest)) 
    3737 
    38 (defmethod initialize-instance :after ((poi-medium poi-medium) &key language title subtitle description poi) 
     38(defmethod initialize-persistent-instance :after ((poi-medium poi-medium) &key language title subtitle description poi) 
    3939  (when poi 
    4040    (push poi-medium (poi-media poi))) 
    …… 
    8585    poi)) 
    8686 
    87 (defmethod initialize-instance :after ((poi poi) &key language title subtitle description) 
     87(defmethod initialize-persistent-instance :after ((poi poi) &key language title subtitle description) 
    8888  (update-textual-attributes poi language 
    8989                             :title title 

  • trunk/projects/lisp-ecoop/src/participant.lisp

    r3689 r3694  
    88  (:default-initargs :type "application/pdf" :submission (error ":submission argument missing while creating document"))) 
    99 
    10 (defmethod initialize-instance :after ((document document) &key) 
     10(defmethod initialize-persistent-instance :after ((document document) &key) 
    1111  (with-slots (submission) document 
    1212    (push document (submission-documents submission)))) 
    …… 
    9393      (apply fun (append args more)))) 
    9494 
    95 (defmethod initialize-instance :after ((participant participant) &key) 
     95(defmethod initialize-persistent-instance :after ((participant participant) &key) 
    9696  (make-email-list)) 
    9797 

  • trunk/projects/unmaintained/raw-data/mcp/bluetooth.lisp

    r3689 r3694  
    8989  (:metaclass persistent-class)) 
    9090 
    91 (defmethod initialize-instance :after ((event bluetooth-event) &key) 
     91(defmethod initialize-persistent-instance :after ((event bluetooth-event) &key) 
    9292  (with-slots (device) event 
    9393    (push event (bluetooth-device-events device)) 

  • trunk/projects/unmaintained/raw-data/mcp/sensors.lisp

    r3689 r3694  
    6161  (format nil "sample_event_~(~A~)" (sensor-type sensor))) 
    6262 
    63 (defmethod initialize-instance :after ((sensor sensor) &key) 
     63(defmethod initialize-persistent-instance :after ((sensor sensor) &key) 
    6464  (let ((id (store-object-id sensor))) 
    6565    (with-slots (name unit type) sensor