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