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

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

ugarit: Significant README improvements, and enabled consistency check of read blocks by default, and removed warning about deletions from backend-cache.

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