forked from wlbr/cl-marshal
-
Notifications
You must be signed in to change notification settings - Fork 1
/
marshal.lisp
203 lines (163 loc) · 7.21 KB
/
marshal.lisp
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
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
;;; -*- Mode:LISP; Syntax: COMMON-LISP; Package: MARSHAL; Base: 10; indent-tabs-mode: nil -*-
;;; ***********************************************************
;;;
;;; Project: marshal
;;; Simple (de)serialization of Lisp datastructures.
;;;
;;; File: marshal.lisp
;;;
;;; ***********************************************************
(in-package :marshal)
;;; =============================================================
(defmethod class-persistant-slots ((class standard-object))
"Defines the slots that will be serialized. Has to return
list of valid slotnames.
If this is a nested list, then this the element of the second level
need to be pairs of slot and accessors."
NIL)
;;; =============================================================
(defclass persist-hashtable ()
((hashtable :initform NIL :accessor hashtable)
(next-key :initform 0 :accessor next-key)))
(defmethod initialize-instance :after ((self persist-hashtable) &rest initargs)
(declare (ignore initargs))
(setf (hashtable self) (make-hash-table :test #'eq :size 50 :rehash-size 1.5))
)
(defmethod genkey ((self persist-hashtable))
(incf (next-key self)))
; (setf (next-key self) (1+ (next-key self))))
(defmethod getvalue ((self persist-hashtable) key)
(gethash key (hashtable self)))
(defmethod setvalue ((self persist-hashtable) key value)
(setf (gethash key (hashtable self)) value))
;;; =============================================================
(defgeneric marshal (thing &optional circle-hash)
(:documentation "Generates an sexp when called with an object. The sexp can be used
to send it over a ntowrk or to store it in a database etc.")
)
(defmethod marshal (thing &optional (circle-hash NIL))
(declare (ignore circle-hash))
thing)
(defmethod marshal :around (thing &optional (circle-hash NIL))
(if circle-hash
(call-next-method thing circle-hash)
(progn
(setq circle-hash (make-instance 'persist-hashtable))
(list (coding-idiom :coding-identifier) (coding-idiom :coding-release-no) (call-next-method thing circle-hash)))
))
(defmethod marshal ((object standard-object) &optional (circle-hash NIL))
(let* ((class (class-of object))
(pslots (class-persistant-slots object))
(dummy NIL)
(outlist NIL))
(setq dummy (getvalue circle-hash object))
(if dummy
(setq outlist (list (coding-idiom :reference) dummy))
(progn
(when pslots
(setq dummy (genkey circle-hash))
(setvalue circle-hash object dummy)
(setq outlist (list (coding-idiom :object) dummy (class-name class)))
(dolist (walker pslots)
(setq outlist (nconc outlist (list (marshal (slot-value object walker) circle-hash))))
)))
)
outlist))
;;; 12.02.99 cjo: auch dotted lists werden korrekt behandelt
(defmethod marshal ((list list) &optional (circle-hash NIL))
(let* ((ckey NIL)
(output NIL)
(dotted-list (rest (last list))))
; ========= circle-stuff
(setf ckey (getvalue circle-hash list))
(if ckey
(setq output (list (coding-idiom :reference) ckey))
(progn
(setq ckey (genkey circle-hash))
(setvalue circle-hash list ckey)
(when dotted-list
(setf output (nconc output (list (marshal dotted-list circle-hash)))))
(LOOP FOR walker IN list
DO (setf output (nconc output (list (marshal walker circle-hash)))))
(push ckey output)
(push (if dotted-list
(coding-idiom :dlist)
(coding-idiom :list))
output)))
output))
;;; 04.01.99 cjo: wird jetzt als :array2 rausgeschrieben, dann ist eine unterscheidung zum alten
;;; :array moeglich
;;; 10.08.98 cjo: nreverse vergessen! push dreht die liste um. wenn es bloede laeuft hat man so
;;; :reference, bevor die nummer ueberhaupt existiert!
(defmethod marshal ((array array) &optional (circle-hash NIL))
(let* ((ckey NIL)
(output NIL)
(dummy NIL))
(setf ckey (getvalue circle-hash array))
(if ckey
(setq output (list (coding-idiom :reference) ckey))
(progn
(setq ckey (genkey circle-hash))
(setvalue circle-hash array ckey)
(setq output (list (coding-idiom :array) ckey
(array-dimensions array) (array-element-type array)))
(dotimes (walker (array-total-size array))
(push (marshal (row-major-aref array walker) circle-hash) dummy))
(setq output (nconc output (list (nreverse dummy))))))
output))
(defmethod marshal-simple-string (object circle-hash)
(let* ((ckey NIL)
(output NIL))
(setf ckey (getvalue circle-hash object))
(if ckey
(setq output (list (coding-idiom :reference) ckey))
(progn
(setq ckey (genkey circle-hash))
(setvalue circle-hash object ckey)
(setq output (list (coding-idiom :simple-string) ckey
object))))
output))
(defun marshal-string (object circle-hash)
(let* ((ckey NIL)
(output NIL))
(setf ckey (getvalue circle-hash object))
(if ckey
(setq output (list (coding-idiom :reference) ckey))
(let ((fill-pointer (fill-pointer object))
(adjustable-array-p (adjustable-array-p object)))
(setq ckey (genkey circle-hash))
(setvalue circle-hash object ckey)
(setf (fill-pointer object) (array-dimension object 0)) ; was 0, was: NIL
(setq output (list (coding-idiom :string) ckey
fill-pointer
adjustable-array-p
(princ-to-string object)))
(setf (fill-pointer object) fill-pointer)))
output))
(defmethod marshal ((object string) &optional (circle-hash NIL))
(typecase object
(simple-string (marshal-simple-string object circle-hash))
(T (marshal-string object circle-hash))))
;;; cjo 15.1.1999 hash-function kann man nicht mehr auslesen!!!
(defmethod marshal ((hash-table hash-table) &optional (circle-hash NIL))
(let* ((ckey NIL)
(output NIL)
(dummy NIL))
(setf ckey (getvalue circle-hash hash-table))
(if ckey
(setq output (list (coding-idiom :reference) ckey))
(progn
(setq ckey (genkey circle-hash))
(setvalue circle-hash hash-table ckey)
(setq output (list (coding-idiom :hash-table) ckey
(hash-table-size hash-table) (hash-table-rehash-size hash-table)
(hash-table-rehash-threshold hash-table) (hash-table-test hash-table)
;(hash-table-hash-function hash-table)
NIL
))
(maphash #'(lambda (key value)
(setq dummy (nconc dummy (list (marshal key circle-hash) (marshal value circle-hash)))))
hash-table)
(when dummy
(setq output (nconc output (list dummy))))))
output))