cl-binary-store/src/magic-numbers.lisp at 2888748bef9645e0087e891c50b3bc53d6a0b004 · ajberkley/cl-binary-store · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
;; Simple versioning mechanism.  All versioned output should start
;; with +magic-number-code+ and then a number (though it can occur
;; anywhere and even multiple times in the stream / file, not sure why
;; you'd want that).  When restored, the magic number is used to
;; pull up the correct `codespace' in *codespaces* and then restoration
;; continues.  If there is no codespace matching that magic number
;; an error will be signalled.

(in-package :cl-binary-store)

(defvar *write-version* #x0001
  "Set this to the magic number you wish to write into the file.  It may
 be queried by serialization routines if desired.")

(defvar *allow-codespace-switching* nil
  "Set this to NIL if you want to specify the format of file you want to load and
 not allow it to be set automatically based on the data format of the file.")

(defstruct (magic-number (:include action (code +magic-number-action-code+)))
  (number #x0001 :type integer :read-only t))

(defmethod action ((code (eql +magic-number-action-code+)) storage references restore-object)
  (let ((magic-number (funcall restore-object)))
    (let ((codespace (gethash magic-number *codespaces*)))
      (unless codespace
	(error 'invalid-input-data
               :format-control "Unsupported codespace version #x~X, we have ~{~x~X~^ ~}~%"
               :format-arguments (list
	                          magic-number (loop for key being the hash-keys of *codespaces*
				                     collect key))))
      (cond
	((not (eq *current-codespace* codespace))
	 (cond
	   (*allow-codespace-switching*
	    (format t "Switching codespace from ~A to #x~X (~A)~%"
		    (codespace-name *current-codespace*)
		    magic-number
		    (codespace-name codespace))
	    (setf *current-codespace* codespace)
	    (setf *version-being-read* magic-number)
	    (restore-objects storage))
	   (t
	    (error 'invalid-input-data
                   :format-control "Switching codespace away from #x~X (~A) is DISALLOWED"
                   :format-arguments (list
		                      (codespace-magic-number *current-codespace*)
		                      (codespace-name *current-codespace*))))))
	(t
	 (setf *version-being-read* magic-number)
	 (format t "Deserializing from version #x~X (~A)~%"
		 magic-number (codespace-name codespace))
	 (values nil :ignore))))))

(defmethod store-action ((action magic-number) storage store-object)
  (when storage (store-fixnum (magic-number-number action) storage)))