1;;;
2;;; dbm - abstract base class for dbm interface
3;;;
4;;;   Copyright (c) 2000-2020  Shiro Kawai  <shiro@acm.org>
5;;;
6;;;   Redistribution and use in source and binary forms, with or without
7;;;   modification, are permitted provided that the following conditions
8;;;   are met:
9;;;
10;;;   1. Redistributions of source code must retain the above copyright
11;;;      notice, this list of conditions and the following disclaimer.
12;;;
13;;;   2. Redistributions in binary form must reproduce the above copyright
14;;;      notice, this list of conditions and the following disclaimer in the
15;;;      documentation and/or other materials provided with the distribution.
16;;;
17;;;   3. Neither the name of the authors nor the names of its contributors
18;;;      may be used to endorse or promote products derived from this
19;;;      software without specific prior written permission.
20;;;
21;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32;;;
33
34(define-module dbm
35  (use gauche.collection)
36  (use gauche.dictionary)
37  (use gauche.generator)
38  (export <dbm> <dbm-meta>
39          dbm-open    dbm-close   dbm-closed? dbm-get
40          dbm-put!    dbm-delete! dbm-exists?
41          dbm-fold    dbm-for-each  dbm-map
42          dbm-db-exists? dbm-db-remove dbm-db-copy dbm-db-move dbm-db-rename
43          dbm-type->class)
44  )
45(select-module dbm)
46
47(define-class <dbm-meta> (<class>)
48  ())
49
50(define-class <dbm> (<dictionary>)
51  ((path       :init-keyword :path)
52   (rw-mode    :init-keyword :rw-mode    :initform :write)
53   (file-mode  :init-keyword :file-mode  :initform #o664)
54   (key-convert   :init-keyword :key-convert :initform #f)
55   (value-convert :init-keyword :value-convert :initform #f)
56   ;; internal.  set up by dbm-open
57   k2s s2k v2s s2v)
58  :metaclass <dbm-meta>)
59
60;; Macros & procedures that can be used by implementation modules
61(define-syntax %dbm-k2s
62  (syntax-rules ()
63    ((_ self key) ((slot-ref self 'k2s) key))))
64
65(define-syntax %dbm-s2k
66  (syntax-rules ()
67    ((_ self key) ((slot-ref self 's2k) key))))
68
69(define-syntax %dbm-v2s
70  (syntax-rules ()
71    ((_ self key) ((slot-ref self 'v2s) key))))
72
73(define-syntax %dbm-s2v
74  (syntax-rules ()
75    ((_ self key) ((slot-ref self 's2v) key))))
76
77;; Utilities to copy/rename two files (esp. *.dir and *.pag file of
78;; traditional dbm).  Makes some effort to take care of rollback on failure.
79;; Also check if two files are hard-linked (gdbm_compat does that).
80
81(autoload file.util file-eq? copy-file move-file)
82
83(define (%dbm-copy2 from1 to1 from2 to2 :key (if-exists :error))
84  (if (file-eq? from1 from2)
85    (begin ;; dir and pag files are identical
86      (copy-file from1 to1 :safe #t :if-exists if-exists)
87      (sys-link to1 to2))
88    (begin
89      (copy-file from1 to1 :safe #t :if-exists if-exists)
90      (guard (e [else (sys-unlink to1) (sys-unlink to2) (raise e)])
91        (copy-file from2 to2 :safe #t :if-exists if-exists)))))
92
93(define (%dbm-rename2 from1 to1 from2 to2 :key (if-exists :error))
94  (if (file-eq? from1 from2)
95    (begin
96      (move-file from1 to1 :if-exists if-exists)
97      (sys-link to1 to2)
98      (sys-unlink from2))
99    (begin
100      (move-file from1 to1 :if-exists if-exists)
101      (move-file from2 to2 :if-exists if-exists))))
102
103;;
104;; DBM-OPEN
105;;
106
107(define-method dbm-open ((class <dbm-meta>) . initargs)
108  (dbm-open (apply make class initargs)))
109
110(define-method dbm-open ((self <dbm>))
111  (define (pick-proc slot default custom)
112    (let1 spec (slot-ref self slot)
113      (cond [(eq? spec #f) identity]
114            [(eq? spec #t) default]
115            [(and (pair? spec)
116                  (null? (cddr spec))
117                  (procedure? (car spec))
118                  (procedure? (cadr spec)))
119             (custom spec)]
120            [else (errorf "bad value for ~s: has to be boolean or a list of two procedures, but got ~s" slot spec)])))
121
122  (slot-set! self 'k2s (pick-proc 'key-convert write-to-string car))
123  (slot-set! self 's2k (pick-proc 'key-convert read-from-string cadr))
124  (slot-set! self 'v2s (pick-proc 'value-convert write-to-string car))
125  (slot-set! self 's2v (pick-proc 'value-convert read-from-string cadr))
126  self)
127
128;;
129;; Method prototypes.  Actual method should be defined in subclasses.
130;;
131
132(define-method dbm-put! ((dbm <dbm>) key value)
133  (when (dbm-closed? dbm) (errorf "dbm-put!: dbm already closed: ~s" dbm))
134  (when (eqv? (slot-ref dbm 'rw-mode) :read)
135    (errorf "dbm-put!: dbm is read only: ~s" dbm)))
136
137(define-method dbm-get ((dbm <dbm>) key . args)
138  (when (dbm-closed? dbm) (errorf "dbm-get: dbm already closed: ~s" dbm)))
139
140(define-method dbm-exists? ((dbm <dbm>) key)
141  (when (dbm-closed? dbm) (errorf "dbm-exists?: dbm already closed: ~s" dbm)))
142
143(define-method dbm-delete! ((dbm <dbm>) key)
144  (when (dbm-closed? dbm) (errorf "dbm-delete!: dbm already closed: ~s" dbm))
145  (when (eqv? (slot-ref dbm 'rw-mode) :read)
146    (errorf "dbm-delete!: dbm is read only: ~s" dbm)))
147
148(define-method dbm-fold ((dbm <dbm>) proc knil) #f)
149
150(define-method dbm-close ((dbm <dbm>)) #f)
151
152(define-method dbm-closed? ((dbm <dbm>)) #f)
153
154;;
155;; These work if dbm-fold is defined, but may be more efficient
156;; if specialized.
157;;
158
159(define-method dbm-for-each ((dbm <dbm>) proc)
160  (when (dbm-closed? dbm) (errorf "dbm-for-each: dbm already closed: ~s" dbm))
161  (dbm-fold dbm (^[key value r] (proc key value)) #f))
162
163(define-method dbm-map ((dbm <dbm>) proc)
164  (when (dbm-closed? dbm) (errorf "dbm-map: dbm already closed: ~s" dbm))
165  (reverse
166   (dbm-fold dbm (^[key value r] (cons (proc key value) r)) '())))
167
168;;
169;; Collection framework
170;;
171(define-method call-with-iterator ((dbm <dbm>) proc . options)
172  (let* ([g (generate
173             (^[yield] (dbm-fold dbm (^[k v r] (yield (cons k v))) #f)))]
174         [buf (g)])
175    (proc (^[] (eof-object? buf))
176          (^[] (begin0 buf (set! buf (g)))))))
177
178(define-method coerce-to ((target <list-meta>) (dbm <dbm>))
179  (dbm-map dbm cons))
180
181;;
182;; Dictionary framework
183;;
184(define-dict-interface <dbm>
185  :get       dbm-get
186  :put!      dbm-put!
187  :exists?   dbm-exists?
188  :delete!   dbm-delete!
189  :fold      dbm-fold
190  :map       dbm-map
191  :for-each  dbm-for-each)
192
193(define-method dict-comparator ((dbm <dbm>))
194  (let1 k2s (~ dbm'k2s)
195    (make-comparator #t
196                     (^[a b] (equal? (k2s a) (k2s b)))
197                     #f #f)))
198
199;;
200;; Meta-operations
201;;  Subclass has to implement at least dbm-db-exists? and dbm-db-remove.
202;;
203
204(define-method dbm-db-exists? ((class <dbm-meta>) name)
205  (errorf "dbm-db-exists?: not supported in ~a" class))
206
207(define-method dbm-db-remove ((class <dbm-meta>) name)
208  (errorf "dbm-db-remove: not supported in ~a" class))
209
210(define-method dbm-db-copy ((class <dbm-meta>) from to)
211  ;; generic one - might be slow, and it may not copy meta info.
212  ;; it also doesn't check if from and to is the same databases;
213  ;; but it opens from-db first with read mode, so if the implementation
214  ;; has sane locking, the to-db opening with create option would fail.
215  ;; (That's why we're using let* here.)
216  (let* ([from-db (dbm-open class :path from :rw-mode :read)]
217         [to-db   (dbm-open class :path to   :rw-mode :create)])
218    (dbm-for-each from-db (^[k v] (dbm-put! to-db k v)))
219    (dbm-close to-db)
220    (dbm-close from-db)))
221
222(define-method dbm-db-move ((class <dbm-meta>) from to)
223  ;; generic one - see above.
224  (let* ([from-db (dbm-open class :path from :rw-mode :read)]
225         [to-db   (dbm-open class :path to   :rw-mode :create)])
226    (dbm-for-each from-db (^[k v] (dbm-put! to-db k v)))
227    (dbm-close to-db)
228    (dbm-close from-db)
229    (dbm-db-remove class from)))
230
231(define dbm-db-rename dbm-db-move) ; backward compatibility
232
233;; Try to dynamically load named dbm module and returns the class.
234;; DBMTYPE must be a symbol like 'gdbm'.
235;; Returns #f if it couldn't retrieve the named dbm module.
236
237(define (dbm-type->class dbmtype)
238  (let ([module-name (string->symbol #"dbm.~dbmtype")]
239        [class-name (string->symbol #"<~|dbmtype|>")])
240    (and (library-exists? module-name :strict? #t)
241         (guard (e [else #f])
242           ((with-module gauche.internal %require)
243            (module-name->path module-name))
244           (global-variable-ref (find-module module-name) class-name)))))
245