| 1 |
(in-package :bos.m2) |
|---|
| 2 |
|
|---|
| 3 |
;;; transient-init-functions |
|---|
| 4 |
;;; |
|---|
| 5 |
;;; Allows for registering transient init functions that |
|---|
| 6 |
;;; will be called after each restore of m2-store |
|---|
| 7 |
|
|---|
| 8 |
(defvar *transient-init-functions* nil) |
|---|
| 9 |
(defvar *transient-init-constraints* nil) |
|---|
| 10 |
|
|---|
| 11 |
(defun register-transient-init-function (init-function &rest dependencies) |
|---|
| 12 |
"Register INIT-FUNCTION (a function-name) to be called after |
|---|
| 13 |
each restore of m2-store. Optionally, names of other |
|---|
| 14 |
init-functions can be specified as DEPENDENCIES. The specified |
|---|
| 15 |
INIT-FUNCTION will only be called after all of its DEPENDENCIES |
|---|
| 16 |
have been called." |
|---|
| 17 |
(labels ((ignorant-tie-breaker (choices reverse-partial-solution) |
|---|
| 18 |
(declare (ignore reverse-partial-solution)) |
|---|
| 19 |
;; we dont care about making any particular choice here - |
|---|
| 20 |
;; this would be different for computing the class |
|---|
| 21 |
;; precedence list, for which the topological-sort used here |
|---|
| 22 |
;; was originally intended |
|---|
| 23 |
(first choices)) |
|---|
| 24 |
(build-constraints () |
|---|
| 25 |
(loop for dependency in dependencies |
|---|
| 26 |
collect (cons dependency init-function)))) |
|---|
| 27 |
(check-type init-function symbol) |
|---|
| 28 |
(dolist (dependency dependencies) |
|---|
| 29 |
(check-type dependency symbol)) |
|---|
| 30 |
(let (new-transient-init-functions |
|---|
| 31 |
new-transient-init-constraints) |
|---|
| 32 |
(let ((constraints (build-constraints)) |
|---|
| 33 |
;; dont know yet whether we have a circular dependency - so |
|---|
| 34 |
;; we want to be able to abort without changes |
|---|
| 35 |
(*transient-init-functions* *transient-init-functions*) |
|---|
| 36 |
(*transient-init-constraints* *transient-init-constraints*)) |
|---|
| 37 |
(pushnew init-function *transient-init-functions*) |
|---|
| 38 |
(dolist (dependency dependencies) |
|---|
| 39 |
(pushnew dependency *transient-init-functions*)) |
|---|
| 40 |
(dolist (constraint constraints) |
|---|
| 41 |
(pushnew constraint *transient-init-constraints* :test #'equal)) |
|---|
| 42 |
(setq new-transient-init-functions |
|---|
| 43 |
(topological-sort *transient-init-functions* |
|---|
| 44 |
*transient-init-constraints* |
|---|
| 45 |
#'ignorant-tie-breaker) |
|---|
| 46 |
new-transient-init-constraints |
|---|
| 47 |
*transient-init-constraints*)) |
|---|
| 48 |
(setq *transient-init-functions* |
|---|
| 49 |
new-transient-init-functions |
|---|
| 50 |
*transient-init-constraints* |
|---|
| 51 |
new-transient-init-constraints)))) |
|---|
| 52 |
|
|---|
| 53 |
(defun invoke-transient-init-functions () |
|---|
| 54 |
(dolist (function-name *transient-init-functions*) |
|---|
| 55 |
(format t "~&initialization-subsystem is calling ~A..." function-name) |
|---|
| 56 |
(with-simple-restart (skip-init-function "Skip transient-init-function ~A" |
|---|
| 57 |
function-name) |
|---|
| 58 |
(funcall function-name)) |
|---|
| 59 |
(format t "done~%"))) |
|---|
| 60 |
|
|---|
| 61 |
;;; initialization-subsystem |
|---|
| 62 |
(defclass initialization-subsystem () |
|---|
| 63 |
()) |
|---|
| 64 |
|
|---|
| 65 |
(defmethod bknr.datastore::restore-subsystem (store (subsystem initialization-subsystem) |
|---|
| 66 |
&key until) |
|---|
| 67 |
(declare (ignore until)) |
|---|
| 68 |
(invoke-transient-init-functions)) |
|---|
| 69 |
|
|---|
| 70 |
(defmethod bknr.datastore::snapshot-subsystem (store (subsystem initialization-subsystem)) |
|---|
| 71 |
;; We are calling the initialization functions also here, because |
|---|
| 72 |
;; for transactions that follow the current snapshot we want to be |
|---|
| 73 |
;; in the same initial state as if the store had been freshly |
|---|
| 74 |
;; restored. |
|---|
| 75 |
(invoke-transient-init-functions)) |
|---|
