| 1 |
(in-package :bos.test) |
|---|
| 2 |
|
|---|
| 3 |
(defun %reopen-store (&key snapshot) |
|---|
| 4 |
(format t "~&;; ++ reopen-store~%") |
|---|
| 5 |
(when snapshot |
|---|
| 6 |
(format t "~&;; ++ taking snapshot~%") |
|---|
| 7 |
(snapshot)) |
|---|
| 8 |
(bos.m2::reinit :directory (bknr.datastore::store-directory *store*) |
|---|
| 9 |
:website-url bos.m2::*website-url*) |
|---|
| 10 |
(format t "~&;; ++ reopen-store done~%")) |
|---|
| 11 |
|
|---|
| 12 |
(defmacro reopen-store ((&key snapshot) &rest store-object-vars) |
|---|
| 13 |
(let ((id-vars (iter |
|---|
| 14 |
(with *print-case* = :upcase) |
|---|
| 15 |
(for store-object-var in store-object-vars) |
|---|
| 16 |
(for id-var = (gensym (format nil "~A-ID" store-object-var))) |
|---|
| 17 |
(collect id-var)))) |
|---|
| 18 |
`(let (,@(iter |
|---|
| 19 |
(for id-var in id-vars) |
|---|
| 20 |
(for store-object-var in store-object-vars) |
|---|
| 21 |
(collect `(,id-var (when (and ,store-object-var |
|---|
| 22 |
(not (object-destroyed-p ,store-object-var))) |
|---|
| 23 |
(store-object-id ,store-object-var)))))) |
|---|
| 24 |
(%reopen-store :snapshot ,snapshot) |
|---|
| 25 |
(setf ,@(iter |
|---|
| 26 |
(for id-var in id-vars) |
|---|
| 27 |
(for store-object-var in store-object-vars) |
|---|
| 28 |
(collect store-object-var) |
|---|
| 29 |
(collect `(when ,id-var (find-store-object ,id-var)))))))) |
|---|
| 30 |
|
|---|
| 31 |
(defmacro %with-store-reopenings ((&key snapshot bypass) |
|---|
| 32 |
(&rest store-object-vars) &body body) |
|---|
| 33 |
`(let ((snapshot ,snapshot) |
|---|
| 34 |
(bypass ,bypass)) |
|---|
| 35 |
(if bypass |
|---|
| 36 |
(progn ,@body) |
|---|
| 37 |
(progn |
|---|
| 38 |
,@(iter |
|---|
| 39 |
(for form in body) |
|---|
| 40 |
(unless (first-time-p) |
|---|
| 41 |
(collect `(reopen-store (:snapshot ,snapshot) ,@store-object-vars))) |
|---|
| 42 |
(collect form)))))) |
|---|
| 43 |
|
|---|
| 44 |
(defmacro with-store-reopenings ((&rest store-object-vars) &body body) |
|---|
| 45 |
`(%with-store-reopenings (:snapshot snapshot :bypass bypass) |
|---|
| 46 |
(,@store-object-vars) |
|---|
| 47 |
,@body)) |
|---|
| 48 |
|
|---|
| 49 |
(def-fixture initial-bos-store (&key (delete-store t)) |
|---|
| 50 |
(let ((store-path (parse-namestring |
|---|
| 51 |
(format nil "/tmp/test-store-~D.tmp/" (get-universal-time))))) |
|---|
| 52 |
(unwind-protect |
|---|
| 53 |
(progn |
|---|
| 54 |
(bos.m2::reinit :delete t |
|---|
| 55 |
:directory store-path |
|---|
| 56 |
:website-url bos.m2::*website-url*) |
|---|
| 57 |
(make-user "anonymous") ; needed for web tests |
|---|
| 58 |
(&body)) |
|---|
| 59 |
(close-store) |
|---|
| 60 |
;; (cl-fad:delete-directory-and-files store-path) ; fails on ccl |
|---|
| 61 |
(if delete-store |
|---|
| 62 |
(asdf:run-shell-command "rm -r '~A'" store-path) |
|---|
| 63 |
(warn "not deleting store at ~A" store-path))))) |
|---|
| 64 |
|
|---|
| 65 |
(defmacro store-test (name &body body) |
|---|
| 66 |
`(progn |
|---|
| 67 |
,@(iter |
|---|
| 68 |
(for config in '((:suffix reopenings-no-snapshot :snapshot nil :bypass nil) |
|---|
| 69 |
(:suffix reopenings-with-snapshot :snapshot t :bypass nil) |
|---|
| 70 |
(:suffix nil :snapshot nil :bypass t))) |
|---|
| 71 |
(for test-name = (if (getf config :suffix) |
|---|
| 72 |
(intern (format nil "~a.~a" name (getf config :suffix))) |
|---|
| 73 |
name)) |
|---|
| 74 |
(collect `(test ,test-name |
|---|
| 75 |
(with-fixture initial-bos-store () |
|---|
| 76 |
(let ((snapshot ,(getf config :snapshot)) |
|---|
| 77 |
(bypass ,(getf config :bypass))) |
|---|
| 78 |
(declare (ignorable snapshot bypass)) |
|---|
| 79 |
,@body))))))) |
|---|
