source: project/release/4/ugarit/trunk/backend-cache.scm @ 21301

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

ugarit: Backend unit tests now all pass!

File size: 2.1 KB
Line 
1(use gdbm)
2
3(define (backend-cache be cachepath)
4   (define *key-cache* (gdbm-open cachepath))
5   (define *warn-about-delete* #t)
6   
7   (define (cache-set! key type)
8      (if type
9         (gdbm-store *key-cache* key (symbol->string type) GDBM_REPLACE)
10         type)
11      type)
12   (define (cache-get key)
13      (let ((result (gdbm-fetch *key-cache* key)))
14         (if result
15            (string->symbol result)
16            #f)))
17   (define (cache-delete! key)
18      (gdbm-delete *key-cache* key))
19
20   (make-storage
21      (storage-max-block-size be)
22      (storage-writable? be)
23      (storage-unlinkable? be)
24      (lambda (key data type) ; put!
25         (begin
26            ((storage-put! be) key data type)
27            (cache-set! key type)
28            (void)))
29      (lambda (key) ; exists?
30         (or
31            (cache-get key)
32            (cache-set! key ((storage-exists? be) key))))
33      (lambda (key) ; get
34         ((storage-get be) key))
35      (lambda (key) ; link!
36         ((storage-link! be) key))
37      (lambda (key) ; unlink!
38         (let ((result ((storage-unlink! be) key)))
39            (if result
40               (begin
41                  (if *warn-about-delete*
42                     (begin
43                        (printf "WARNING: Deleting from a shared storage backend will INVALIDATE\nany OTHER caches. Please flush your caches on any other computers\nthat use the same backend store!\n")
44                        (set! *warn-about-delete* #f)))
45                  (cache-delete! key)
46                  result)
47               result)))
48      (lambda (tag key) ; set-tag!
49         ((storage-set-tag! be) tag key))
50      (lambda (tag) ; tag
51         ((storage-tag be) tag))
52      (lambda () ; all-tags
53         ((storage-all-tags be)))
54      (lambda (tag) ; remove-tag!
55         ((storage-remove-tag! be) tag))
56      (lambda (tag) ; lock-tag!
57         ((storage-lock-tag! be) tag))
58      (lambda (tag) ; tag-locked?
59         ((storage-tag-locked? be) tag))
60      (lambda (tag) ; unlock-tag!
61         ((storage-unlock-tag! be) tag))
62      (lambda () ; close!
63         ((begin
64            (gdbm-close *key-cache*)
65            (storage-close! be))))))
Note: See TracBrowser for help on using the repository browser.