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

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

ugarit: Dotting is, crossing ts...

File size: 2.8 KB
Line 
1(use ugarit-backend)
2(use sql-de-lite)
3(use matchable)
4
5(define cache-sql-schema
6  (list
7   "CREATE TABLE cache (key TEXT PRIMARY KEY, type TEST);"))
8
9(define (backend-cache cachepath be)
10   (define *db* (open-database cachepath))
11   (when (null? (schema *db*))
12         (for-each (lambda (statement)
13                     (exec (sql *db* statement)))
14                   cache-sql-schema))
15   (define *warn-about-delete* #t)
16
17   (define (cache-set! key type)
18      (when type
19          (exec (sql *db* "INSERT OR REPLACE INTO cache (key, type) VALUES (?,?)") key (symbol->string type)))
20      type)
21
22   (define (cache-get key)
23      (let ((result
24             (query fetch (sql *db* "SELECT type FROM cache WHERE key = ?") key)))
25        (if (pair? result)
26            (string->symbol (car result))
27            #f)))
28
29   (define (cache-delete! key)
30     (exec (sql *db* "DELETE FROM cache WHERE key = ?") key))
31
32   (make-storage
33      (storage-max-block-size be)
34      (storage-writable? be)
35      (storage-unlinkable? be)
36      (lambda (key data type) ; put!
37         (begin
38            ((storage-put! be) key data type)
39            (cache-set! key type)
40            (void)))
41      (lambda (key) ; exists?
42         (or
43            (cache-get key)
44            (cache-set! key ((storage-exists? be) key))))
45      (lambda (key) ; get
46         ((storage-get be) key))
47      (lambda (key) ; link!
48         ((storage-link! be) key))
49      (lambda (key) ; unlink!
50         (let ((result ((storage-unlink! be) key)))
51            (if result
52               (begin
53                  (if *warn-about-delete*
54                     (begin
55                        (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")
56                        (set! *warn-about-delete* #f)))
57                  (cache-delete! key)
58                  result)
59               result)))
60      (lambda (tag key) ; set-tag!
61         ((storage-set-tag! be) tag key))
62      (lambda (tag) ; tag
63         ((storage-tag be) tag))
64      (lambda () ; all-tags
65         ((storage-all-tags be)))
66      (lambda (tag) ; remove-tag!
67         ((storage-remove-tag! be) tag))
68      (lambda (tag) ; lock-tag!
69         ((storage-lock-tag! be) tag))
70      (lambda (tag) ; tag-locked?
71         ((storage-tag-locked? be) tag))
72      (lambda (tag) ; unlock-tag!
73         ((storage-unlock-tag! be) tag))
74      (lambda () ; close!
75         ((begin
76            (close-database *db*)
77            (storage-close! be))))))
78
79
80(define backend
81  (match (command-line-arguments)
82         ((cachepath backend)
83          (backend-cache cachepath (import-storage backend)))
84
85         (else
86          (printf "USAGE:\nbackend-cache <path-to-cache-file> \"<backend command line>\"\n")
87          #f)))
88
89(if backend
90    (export-storage! backend))
Note: See TracBrowser for help on using the repository browser.