source: project/release/4/ugarit/trunk/backend-devtools.scm @ 25570

Last change on this file since 25570 was 25570, checked in by Alaric Snell-Pym, 9 years ago

ugarit: Version 2 of the backend protocol, supporting better reporting back to the user, and administrative interfaces. Backends outfitted with admin interfaces, and a ugarit-archive-admin tool added to drive them.

File size: 4.9 KB
Line 
1 (define (backend-nullwrap be)
2   (make-storage
3      (storage-max-block-size be)
4      (storage-writable? be)
5      (storage-unlinkable? be)
6      (lambda (key data type) ; put!
7         ((storage-put! be) key data type))
8      (lambda () ; flush!
9        ((storage-flush! be)))
10      (lambda (key) ; exists?
11         ((storage-exists? be) key))
12      (lambda (key) ; get
13         ((storage-get be) key))
14      (lambda (key) ; link!
15         ((storage-link! be) key))
16      (lambda (key) ; unlink!
17         ((storage-unlink! be) key))
18      (lambda (tag key) ; set-tag!
19         ((storage-set-tag! be) tag key))
20      (lambda (tag) ; tag
21         ((storage-tag be) tag))
22      (lambda () ; all-tags
23         ((storage-all-tags be)))
24      (lambda (tag) ; remove-tag!
25         ((storage-remove-tag! be) tag))
26      (lambda (tag) ; lock-tag!
27         ((storage-lock-tag! be) tag))
28      (lambda (tag) ; tag-locked?
29         ((storage-tag-locked? be) tag))
30      (lambda (tag) ; unlock-tag!
31         ((storage-unlock-tag! be) tag))
32      (lambda (command) ; admin!
33         ((storage-admin! be) command))
34      (lambda () ; close!
35         ((storage-close! be)))))
36
37(define (backend-limit-block-size be max-block-size)
38   (make-storage
39      (min max-block-size (storage-max-block-size be))
40      (storage-writable? be)
41      (storage-unlinkable? be)
42      (lambda (key data type) ; put!
43         ((storage-put! be) key data type))
44      (lambda () ; flush!
45        ((storage-flush! be)))
46      (lambda (key) ; exists?
47         ((storage-exists? be) key))
48      (lambda (key) ; get
49         ((storage-get be) key))
50      (lambda (key) ; link!
51         ((storage-link! be) key))
52      (lambda (key) ; unlink!
53         ((storage-unlink! be) key))
54      (lambda (tag key) ; set-tag!
55         ((storage-set-tag! be) tag key))
56      (lambda (tag) ; tag
57         ((storage-tag be) tag))
58      (lambda () ; all-tags
59         ((storage-all-tags be)))
60      (lambda (tag) ; remove-tag!
61         ((storage-remove-tag! be) tag))
62      (lambda (tag) ; lock-tag!
63         ((storage-lock-tag! be) tag))
64      (lambda (tag) ; tag-locked?
65         ((storage-tag-locked? be) tag))
66      (lambda (tag) ; unlock-tag!
67         ((storage-unlock-tag! be) tag))
68      (lambda (command) ; admin!
69         ((storage-admin! be) command))
70      (lambda () ; close!
71         ((storage-close! be)))))
72
73(define (backend-debug be name)
74   (make-storage
75      (storage-max-block-size be)
76      (storage-writable? be)
77      (storage-unlinkable? be)
78      (lambda (key data type) ; put!
79         (begin
80            (printf "~A: (put! ~A ~A ~A)\n" name key data type)
81            ((storage-put! be) key data type)))
82
83      (lambda () ; flush!
84        (begin
85          (printf "~A: (flush!)\n" name)
86          ((storage-flush! be))))
87
88      (lambda (key) ; exists?
89         (let ((result ((storage-exists? be) key)))
90            (begin
91               (printf "~A: (exists? ~A) = ~A\n" name key result)
92               result)))
93      (lambda (key) ; get
94         (let ((result ((storage-get be) key)))
95            (begin
96               (printf "~A: (get ~A) = ~A\n" name key result)
97               result)))
98      (lambda (key) ; link!
99         (begin
100            (printf "~A: (link! ~A)\n" name key)
101            ((storage-link! be) key)))
102      (lambda (key) ; unlink!
103         (let ((result ((storage-unlink! be) key)))
104            (begin
105               (printf "~A: (unlink! ~A) = ~A\n" name key result)
106               result)))
107      (lambda (tag key) ; set-tag!
108         (begin
109            (printf "~A: (set-tag! ~A ~A)\n" name tag key)
110            ((storage-set-tag! be) tag key)))
111      (lambda (tag) ; tag
112         (let ((result ((storage-tag be) tag)))
113            (begin
114               (printf "~A: (tag ~A) = ~A\n" name tag result)
115               result)))
116      (lambda () ; all-tags
117         (let ((result ((storage-all-tags be))))
118            (begin
119               (printf "~A: (all-tags) = ~A\n" name result)
120               result)))
121      (lambda (tag) ; remove-tag!
122         (begin
123            (printf "~A: (remove-tag! ~A)\n" name tag)
124            ((storage-remove-tag! be) tag)))
125      (lambda (tag) ; lock-tag!
126        (let ((result ((storage-lock-tag! be) tag)))
127          (begin
128            (printf "~A: (lock-tag! ~A) = ~A\n" name tag result)
129            result)))
130      (lambda (tag) ; tag-locked?
131         (let ((result ((storage-tag-locked? be) tag)))
132            (begin
133               (printf "~A: (tag-locked? ~A) = ~A\n" name tag result)
134               result)))
135      (lambda (tag) ; unlock-tag!
136         (begin
137            (printf "~A: (lock-tag! ~A)\n" name tag)
138            ((storage-unlock-tag! be) tag)))
139      (lambda (command) ; admin!
140         (let ((result ((storage-admin! be) command)))
141            (begin
142               (printf "~A: (admin! ~A) = ~A\n" name command result)
143               result)))
144      (lambda () ; close!
145         (begin
146            (printf "~A: (close!)\n" name)
147            ((storage-close! be))))))
Note: See TracBrowser for help on using the repository browser.