Changeset 2600

Show
Ignore:
Timestamp:
02/23/08 17:45:03 (11 months ago)
Author:
hans
Message:

Add multiple-store support. :MAKE-DEFAULT initarg to make-instance 'store
prevents *store* from being set. WITH-STORE can be used to select a store
to work with.

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • trunk/bknr/datastore/src/bknr.datastore.asd

    r2559 r2600  
    3232  :depends-on (:bknr.datastore :fiveam :cl-store :bknr.utils) 
    3333  :components ((:module "data" :components ((:file "encoding-test") 
    34                                             )))) 
     34                                            (:file "object-tests"))))) 
    3535 
    3636(defmethod asdf:perform ((op asdf:test-op) (system (eql (find-system :bknr.datastore)))) 

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

    r1826 r2600  
    3030          unless (pathname-name file) do (delete-directory file)) 
    3131    #+sbcl 
    32     (sb-posix:rmdir (namestring pathname)))) 
     32    (sb-posix:rmdir (namestring pathname)) 
     33    #+openmcl 
     34    (ccl::recursive-delete-directory pathname))) 
    3335 
    3436(defvar *test-datastore-directory* #p"/tmp/test-datastore/") 
    …… 
    4850    :unit :datastore 
    4951    :name ,name 
    50     :body #'(lambda () ,@body))) 
     52    :body (lambda () 
     53            ,@body))) 
    5154 
    5255(define-datastore-test "Datastore setup" 
    53   (test-assert *test-datastore*)) 
     56    (test-assert *test-datastore*)) 
    5457 
    5558(define-datastore-test "Create object" 
    …… 
    104107(define-datastore-test "Stress test object creation" 
    105108    (format t "Creating ~a objects~%" +stress-size+) 
    106     (time (bknr.datastore::without-sync () 
    107             (dotimes (i +stress-size+) 
    108               (make-object 'store-object)))) 
    109     (test-equal (length (all-store-objects)) +stress-size+) 
    110     (format t "Delete ~A objects~%" +stress-size+) 
    111     (time (bknr.datastore::without-sync () 
    112             (map-store-objects #'delete-object))) 
    113     (test-equal (all-store-objects) nil)) 
    114  
     109  (time (bknr.datastore::without-sync () 
     110          (dotimes (i +stress-size+) 
     111            (make-object 'store-object)))) 
     112  (test-equal (length (all-store-objects)) +stress-size+) 
     113  (format t "Delete ~A objects~%" +stress-size+) 
     114  (time (bknr.datastore::without-sync () 
     115          (map-store-objects #'delete-object))) 
     116  (test-equal (all-store-objects) nil)) 

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

    r2584 r2600  
    265265;;; binary snapshot 
    266266 
    267 (defvar *current-object-slot* nil) 
    268 (defvar *current-slot-relaxed-p* nil) 
     267(defvar *current-object-slot*) 
     268(defvar *current-slot-relaxed-p*) 
    269269 
    270270(defun encode-layout (id class slots stream) 
    …… 
    310310    (%encode-set-slots slots object stream))) 
    311311 
    312 (defvar *class-rename-hash* (make-hash-table)) 
     312(defvar *class-rename-hash*) 
    313313 
    314314(defun find-class-with-interactive-renaming (class-name) 
    …… 
    327327        finally (return slot-name))) 
    328328 
    329 (defvar *slot-name-map* nil) 
     329(defvar *slot-name-map*) 
    330330 
    331331(defun rename-slot (class slot-name) 
    …… 
    521521              (created-objects 0) 
    522522              (read-slots 0) 
    523               (error t)) 
     523              (error t) 
     524              (*class-rename-hash* (make-hash-table)) 
     525              (*slot-name-map* nil)) 
    524526          (unwind-protect 
    525527               (progn 

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

    r2553 r2600  
    1010  (:export #:*store-debug* 
    1111           #:*store* 
     12           #:with-store 
    1213 
    1314           ;; session 

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

    r2525 r2600  
    2020;;; store 
    2121 
    22 (defvar *store* nil) 
     22(defvar *store*) 
     23 
     24(defmacro with-store ((store &key) &body body) 
     25  `(let ((*store* ,store)) 
     26    ,@body)) 
    2327 
    2428(defclass store () 
    …… 
    6670  (declare (ignore store store-existed-p))) 
    6771 
    68 (defmethod initialize-instance :before ((store store) &key) 
    69   (restart-case 
    70       (unless (null *store*) 
    71         (error "A store is already opened.")) 
    72     (close-store () 
    73       :report "Close the opened store." 
    74       (close-store)))) 
    75  
    76 (defmethod initialize-instance :after ((store store) &key) 
     72(defmethod initialize-instance :before ((store store) &key (make-default t)) 
     73  (when make-default 
     74    (restart-case 
     75        (when (and (boundp '*store*) 
     76                   *store*) 
     77          (error "A store is already opened.")) 
     78      (close-store () 
     79        :report "Close the opened store." 
     80        (close-store))))) 
     81 
     82(defmethod initialize-instance :after ((store store) &key (make-default t)) 
    7783  (when (stringp (store-directory store)) 
    7884    (setf (store-directory store) (pathname (store-directory store)))) 
    79   (setf *store* store) 
    80   (let ((store-existed-p (probe-file (store-current-directory store)))) 
    81     (ensure-store-current-directory store) 
    82     (dolist (subsystem (store-subsystems store)) 
    83       (when *store-debug* 
    84         (format *trace-output* "Initializing subsystem ~A of ~A~%" subsystem store)) 
    85       (initialize-subsystem subsystem store store-existed-p)) 
    86     (restore-store store)) 
    87   (setf (store-state store) :opened)) 
     85  (when make-default 
     86    (setf *store* store)) 
     87  (with-store (store) 
     88    (let ((store-existed-p (probe-file (store-current-directory store)))) 
     89      (ensure-store-current-directory store) 
     90      (dolist (subsystem (store-subsystems store)) 
     91        (when *store-debug* 
     92          (format *trace-output* "Initializing subsystem ~A of ~A~%" subsystem store)) 
     93        (initialize-subsystem subsystem store store-existed-p)) 
     94      (restore-store store)) 
     95    (setf (store-state store) :opened))) 
    8896 
    8997(defmethod close-store-object ((store store)) 
    …… 
    402410         (let ((*disable-sync* t)) 
    403411           ,@body) 
    404       (let ((store *store*)) 
    405         (with-log-guard () 
    406           (fsync (store-transaction-log-stream *store*)))))) 
     412      (with-log-guard () 
     413        (fsync (store-transaction-log-stream *store*))))) 
    407414 
    408415;;; XXX transaction evaluated twice 
    …… 
    509516  (snapshot-store *store*)) 
    510517 
     518(defun make-backup-directory (store) 
     519  "Create directory pathname to place backup for STORE in.  By 
     520default, the current time stamp is used.  If that directory already 
     521exists, attach a dot and an incrementing number to the directory 
     522pathname until a non-existant directory name has been found." 
     523  (loop with timetag = (timetag) 
     524        for i = nil then (if i (incf i) 1) 
     525        for directory = (merge-pathnames (make-pathname :directory (list :relative (format nil "~A~@[.~A~]" timetag i))) 
     526                                         (store-directory store)) 
     527        unless (probe-file directory) 
     528        return directory)) 
     529 
    511530(defmethod snapshot-store ((store store)) 
    512531  (unless (store-open-p) 
    …… 
    518537    (with-store-guard () 
    519538      (with-log-guard () 
    520         (let* ((timetag (timetag)) 
    521                (backup-directory (merge-pathnames (make-pathname :directory `(:relative ,timetag)) 
    522                                                   (store-directory store)))) 
    523           (when (probe-file backup-directory) 
    524             (error "Backup of datastore already exists! Snapshotting could lead to data loss, aborting.")) 
     539        (let ((backup-directory (make-backup-directory store))) 
    525540          (close-transaction-log-stream store) 
    526541 

  • trunk/build.lisp

    r2578 r2600  
    66(load (compile-file "thirdparty/asdf/asdf.lisp")) 
    77 
    8 (defpackage :build (:use :cl :asdf)) 
     8(defpackage :build (:use :cl)) 
    99 
    1010(in-package :build) 
    …… 
    2323                                  :version nil  
    2424                                  :defaults asd-pathname) 
    25                    *central-registry* 
     25                   asdf:*central-registry* 
    2626                   :test #'equal)) 
    2727        (directory (merge-pathnames #p"**/*.asd" directory-path)))) 
    …… 
    3131  (mapc #'delete-file (directory (compile-file-pathname #P"**/*.lisp")))) 
    3232 
     33(defun exit (code) 
     34  #+sbcl 
     35  (sb-unix:unix-exit code) 
     36  #+openmcl 
     37  (ccl:quit code) 
     38  #+cmu 
     39  (unix:unix-exit code)) 
     40 
     41(defun load-all () 
     42  (asdf:oos 'asdf:load-op :bknr.web) 
     43  (asdf:oos 'asdf:load-op :quickhoney) 
     44  (asdf:oos 'asdf:load-op :bos.web) 
     45  (asdf:oos 'asdf:load-op :lisp-ecoop) 
     46  (asdf:oos 'asdf:load-op :bknr.datastore.test)) 
     47 
     48(defun build () 
     49  (clean-fasls) 
     50  (load-all)) 
     51 
     52(defun test () 
     53  (load-all) 
     54  ) 
     55 
    3356(setup-registry (probe-file *default-pathname-defaults*)) 
    34 (clean-fasls) 
    3557 
    36 (oos 'load-op :bknr.web) 
     58(exit 0) 
    3759 
    38 (oos 'load-op :quickhoney) 
    39 (oos 'load-op :bos.web) 
    40 (oos 'load-op :lisp-ecoop) 
    4160 
    42 #+sbcl 
    43 (sb-unix:unix-exit 0) 
    44 #+openmcl 
    45 (ccl:quit 0) 
    46 #+cmu 
    47 (unix:unix-exit 0) 

  • trunk/test.lisp

    r2579 r2600  
    1010(in-package :test) 
    1111 
     12(asdf:oos 'asdf:load-op :bos.web) 
    1213 
    1314#+sbcl 

  • trunk/thirdparty/unit-test/unit-test.lisp

    r12 r2600  
    77;;;;   Implements: A simple unit test harness package. 
    88;;;;   Author: Alain Picard, Memetrics Pty. 
    9 ;;;;   File: $Id: unit-test.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $ 
     9;;;;   File: $Id$ 
    1010 
    1111;;;;   Modified for generic unit testing 
    …… 
    380380      (format output   "~&~D tests total." (+ total-fail total-crash total-pass)) 
    381381      (format output   "~&   ~D passed."   total-pass) 
    382         (when (not (zerop total-fail)) 
    383           (format output "~&   ~D failed."   total-fail)) 
    384         (when (not (zerop total-crash)) 
    385           (format output "~&   ~D crashed."  total-crash))) 
    386     (finish-output output))) 
     382      (when (not (zerop total-fail)) 
     383        (format output "~&   ~D failed."   total-fail)) 
     384      (when (not (zerop total-crash)) 
     385        (format output "~&   ~D crashed."  total-crash)) 
     386      (finish-output output) 
     387      (every #'zerop (list total-fail total-crash))))) 
    387388 
    388389(defun delete-all-tests ()