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

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

Initial import of chicken3 code

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      (lambda (key) ; exists?
29         (or
30            (cache-get key)
31            (cache-set! key ((storage-exists? be) key))))
32      (lambda (key) ; get
33         ((storage-get be) key))
34      (lambda (key) ; link!
35         ((storage-link! be) key))
36      (lambda (key) ; unlink!
37         (let ((result ((storage-unlink! be) key)))
38            (if result
39               (begin
40                  (if *warn-about-delete*
41                     (begin
42                        (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")
43                        (set! *warn-about-delete* #f)))
44                  (cache-delete! key)
45                  result)
46               result)))
47      (lambda (tag key) ; set-tag!
48         ((storage-set-tag! be) tag key))
49      (lambda (tag) ; tag
50         ((storage-tag be) tag))
51      (lambda () ; all-tags
52         ((storage-all-tags be)))
53      (lambda (tag) ; remove-tag!
54         ((storage-remove-tag! be) tag))
55      (lambda (tag) ; lock-tag!
56         ((storage-lock-tag! be) tag))
57      (lambda (tag) ; tag-locked?
58         ((storage-tag-locked? be) tag))
59      (lambda (tag) ; unlock-tag!
60         ((storage-unlock-tag! be) tag))
61      (lambda () ; close!
62         ((begin
63            (gdbm-close *key-cache*)
64            (storage-close! be))))))
Note: See TracBrowser for help on using the repository browser.