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

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

ugarit: tag locking, and strict enforcement of maximum file size in splitlog archives

File size: 4.6 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 () ; close!
33         ((storage-close! be)))))
34
35(define (backend-limit-block-size be max-block-size)
36   (make-storage
37      (min max-block-size (storage-max-block-size be))
38      (storage-writable? be)
39      (storage-unlinkable? be)
40      (lambda (key data type) ; put!
41         ((storage-put! be) key data type))
42      (lambda () ; flush!
43        ((storage-flush! be)))
44      (lambda (key) ; exists?
45         ((storage-exists? be) key))
46      (lambda (key) ; get
47         ((storage-get be) key))
48      (lambda (key) ; link!
49         ((storage-link! be) key))
50      (lambda (key) ; unlink!
51         ((storage-unlink! be) key))
52      (lambda (tag key) ; set-tag!
53         ((storage-set-tag! be) tag key))
54      (lambda (tag) ; tag
55         ((storage-tag be) tag))
56      (lambda () ; all-tags
57         ((storage-all-tags be)))
58      (lambda (tag) ; remove-tag!
59         ((storage-remove-tag! be) tag))
60      (lambda (tag) ; lock-tag!
61         ((storage-lock-tag! be) tag))
62      (lambda (tag) ; tag-locked?
63         ((storage-tag-locked? be) tag))
64      (lambda (tag) ; unlock-tag!
65         ((storage-unlock-tag! be) tag))
66      (lambda () ; close!
67         ((storage-close! be)))))
68
69(define (backend-debug be name)
70   (make-storage
71      (storage-max-block-size be)
72      (storage-writable? be)
73      (storage-unlinkable? be)
74      (lambda (key data type) ; put!
75         (begin
76            (printf "~A: (put! ~A ~A ~A)\n" name key data type)
77            ((storage-put! be) key data type)))
78
79      (lambda () ; flush!
80        (begin
81          (printf "~A: (flush!)\n" name)
82          ((storage-flush! be))))
83
84      (lambda (key) ; exists?
85         (let ((result ((storage-exists? be) key)))
86            (begin
87               (printf "~A: (exists? ~A) = ~A\n" name key result)
88               result)))
89      (lambda (key) ; get
90         (let ((result ((storage-get be) key)))
91            (begin
92               (printf "~A: (get ~A) = ~A\n" name key result)
93               result)))
94      (lambda (key) ; link!
95         (begin
96            (printf "~A: (link! ~A)\n" name key)
97            ((storage-link! be) key)))
98      (lambda (key) ; unlink!
99         (let ((result ((storage-unlink! be) key)))
100            (begin
101               (printf "~A: (unlink! ~A) = ~A\n" name key result)
102               result)))
103      (lambda (tag key) ; set-tag!
104         (begin
105            (printf "~A: (set-tag! ~A ~A)\n" name tag key)
106            ((storage-set-tag! be) tag key)))
107      (lambda (tag) ; tag
108         (let ((result ((storage-tag be) tag)))
109            (begin
110               (printf "~A: (tag ~A) = ~A\n" name tag result)
111               result)))
112      (lambda () ; all-tags
113         (let ((result ((storage-all-tags be))))
114            (begin
115               (printf "~A: (all-tags) = ~A\n" name result)
116               result)))
117      (lambda (tag) ; remove-tag!
118         (begin
119            (printf "~A: (remove-tag! ~A)\n" name tag)
120            ((storage-remove-tag! be) tag)))
121      (lambda (tag) ; lock-tag!
122        (let ((result ((storage-lock-tag! be) tag)))
123          (begin
124            (printf "~A: (lock-tag! ~A) = ~A\n" name tag result)
125            result)))
126      (lambda (tag) ; tag-locked?
127         (let ((result ((storage-tag-locked? be) tag)))
128            (begin
129               (printf "~A: (tag-locked? ~A) = ~A\n" name tag result)
130               result)))
131      (lambda (tag) ; unlock-tag!
132         (begin
133            (printf "~A: (lock-tag! ~A)\n" name tag)
134            ((storage-unlock-tag! be) tag)))
135      (lambda () ; close!
136         (begin
137            (printf "~A: (close!)\n" name)
138            ((storage-close! be))))))
Note: See TracBrowser for help on using the repository browser.