Changeset 10508 for lang/scheme

Timestamp:

04/27/08 02:55:57 (7 months ago)

Author:

hayamiz

Message:

add error handling and so on. Test-pass rate was improved.

Location:

lang/scheme/gauche-tokyocabinet/trunk

Files:

• Gauche-tokyocabinet.gpd (added)
• dbm/tokyocabinet.scm (modified) (5 diffs)
• test.scm (modified) (2 diffs)
• tokyocabinet.c (modified) (2 diffs)
• tokyocabinet.gpd (deleted)
• tokyocabinet.h (modified) (2 diffs)
• tokyocabinetlib.stub (modified) (3 diffs)

lang/scheme/gauche-tokyocabinet/trunk/dbm/tokyocabinet.scm

@@ -4 +4 @@
 
 (define-module dbm.tokyocabinet
-  (use dbm)
+  (extend dbm)
   (export <tcbdb>
 
           ;; low level interface
-;;        tcbdb-new
-;;        tcbdb-open tcbdb-close
-;;        tcbdb-put2 tcbdb-get2
-;;        tcbdbcur-new
-;;        tcbdbcur-first tcbdbcur-last
-;;        tcbdbcur-prev tcbdbcur-next
-;;        tcbdbcur-key2 tcbdbcur-val2
-;;        tcbdb-fold tcbdb-map tcbdb-for-each
+          tcbdb-new tcbdb-ecode
+          tcbdb-open tcbdb-close
+          tcbdb-put2 tcbdb-get2 tcbdb-out2
+          tcbdbcur-new
+          tcbdbcur-first tcbdbcur-last
+          tcbdbcur-prev tcbdbcur-next
+          tcbdbcur-key2 tcbdbcur-val2
+          tcbdb-fold tcbdb-map tcbdb-for-each
           
           |BDBOREADER| |BDBOWRITER| |BDBOCREAT|
           |BDBOTRUNC| |BDBONOLCK| |BDBOLCKNB|
+
+          |TCESUCCESS| |TCETHREAD| |TCEINVALID|
+          |TCENOFILE| |TCENOPERM| |TCEMETA|
+          |TCERHEAD| |TCEOPEN| |TCECLOSE|
+          |TCETRUNC| |TCESYNC| |TCESTAT|
+          |TCESEEK| |TCEREAD| |TCEWRITE|
+          |TCEMMAP| |TCELOCK| |TCEUNLINK|
+          |TCERENAME| |TCEMKDIR| |TCERMDIR|
+          |TCEKEEP| |TCENOREC| |TCEMISC|
           )
   )
@@ -69 +78 @@
 (define-method dbm-open ((self <tcbdb>))
   (next-method)
+  self
   (unless (slot-bound? self 'path)
     (error "path must be set to open TokyoCabinet BDB database"))
@@ -81 +91 @@
                                     (if nolock |BDBONOLCK| 0)
                                     (if noblock-lock |BDBOLCKNB| 0)))
-                   ((:create) (logior |BDBOWRITER| |BDBOTRUNC|
+                   ((:create) (logior |BDBOWRITER| |BDBOTRUNC| |BDBOCREAT|
                                      (if nolock |BDBONOLCK| 0)
                                      (if noblock-lock |BDBOLCKNB| 0)))))
@@ -93 +103 @@
 (define-method dbm-close ((self <tcbdb>))
   (let ((raw-tcbdb (raw-tcbdb-of self)))
-    (and raw-tcbdb (tcbdb-close tcbdb)
+    (and raw-tcbdb (tcbdb-close raw-tcbdb)
          (begin (slot-set! self 'raw-tcbdb #f)
                 #t))))
 
-(define-method dbm-put! ((self <tcbdb> key value))
-  (tcbdb-put2 (raw-tcbdb-of self) key value))
+(define-method dbm-closed? ((self <tcbdb>))
+  (not (slot-ref self 'raw-tcbdb)))
+
+(define-method dbm-put! ((self <tcbdb>) key value)
+  (next-method)
+  (let ((key (%dbm-k2s self key))
+        (value (%dbm-v2s self value)))
+    (let1 ret (tcbdb-put2 (raw-tcbdb-of self) key value)
+    (if ret
+        ret
+        (if (eq? :read (slot-ref self 'rw-mode))
+            (error "tokyocabinet bdb: database is opened as read only")
+            #f)))))
 
 (define-method dbm-get ((self <tcbdb>) key . args)
-  (and (tcbdb-get2 (raw-tcbdb-of self) key)
-       (if (null? args)
-           (errorf "tokyocabinet bdb: not data for key ~s in database ~s"
-                   key self))))
+  (next-method)
+  (let ((key (%dbm-k2s self key)))
+    (let1 ret (tcbdb-get2 (raw-tcbdb-of self) key)
+      (if ret
+          ret
+          (if (null? args)
+              (errorf "tokyocabinet bdb: not data for key ~s in database ~s"
+                      key self)
+              (car args))))))
+
+(define-method dbm-exists? ((self <tcbdb>) key)
+  (and (tcbdb-get2 (raw-tcbdb-of self) (%dbm-k2s self key)) #t))
+
+(define-method dbm-delete! ((self <tcbdb>) key)
+  (or (tcbdb-out2 (raw-tcbdb-of self) (%dbm-k2s self key))
+      (if (eq? :read (slot-ref self 'rw-mode))
+          (error "tokyocabinet bdb: database is opened as read only")
+          #f)))
 
 (define-method dbm-fold ((self <tcbdb>) proc knil)
@@ -115 +150 @@
 (provide "dbm/tokyocabinet")
 
-

lang/scheme/gauche-tokyocabinet/trunk/test.scm

@@ -4 +4 @@
 
 (use gauche.test)
+(use srfi-1)
+(use gauche.collection)
 
 (test-start "dbm.tokyocabinet")
+(use dbm)
 (use dbm.tokyocabinet)
 (test-module 'dbm.tokyocabinet)
@@ -11 +14 @@
 ;; The following is a dummy test code.
 ;; Replace it for your tests.
-(test* "test-tokyocabinet" "tokyocabinet is working"
-       (test-tokyocabinet))
+
+;;
+;; Common test suite
+;;
+
+(define-syntax catch
+  (syntax-rules ()
+    ((_ body ...)
+     (with-error-handler
+      (lambda (e) #t)
+      (lambda () body ... #f)))))
+
+(define *test-dbm* "test.dbm")
+(define *current-dbm* #f)
+
+;; prepair dataset
+(define *test1-dataset* (make-hash-table 'equal?)) ;string only
+(define *test2-dataset* (make-hash-table 'equal?)) ;other objects
+
+(define (generate-test-set size)
+  (do ((i   0 (+ i 1))
+       (key (sys-random) (sys-random))
+       (val (cons (sys-random) (sys-random)) (cons (sys-random) (sys-random))))
+      ((>= i size))
+    (hash-table-put! *test1-dataset*
+                     (x->string key)
+                     (x->string val))
+    (hash-table-put! *test2-dataset* key val)))
+
+(generate-test-set 1000)
+
+;; create test
+(define (test:make class rw-mode serializer)
+  (set! *current-dbm*
+        (dbm-open class
+                  :path *test-dbm* :rw-mode rw-mode
+                  :key-convert serializer
+                  :value-convert serializer))
+  #t)
+
+;; put everything to the database
+(define (test:put! dataset)
+  (hash-table-for-each
+   dataset
+   (lambda (k v)
+     (dbm-put! *current-dbm* k v)))
+  #t)
+
+;; does database has all of them?
+(define (test:get dataset)
+  (call/cc
+   (lambda (return)
+     (hash-table-for-each
+      dataset
+      (lambda (k v)
+        (unless (dbm-exists? *current-dbm* k)
+          (return #f))
+        (unless (equal? v (dbm-get *current-dbm* k))
+          (return #f))))
+     #t)))
+
+;; does database properly deal with exceptional case?
+(define (test:get-exceptional)
+  (and
+   ;; must raise an error
+   (catch (dbm-get *current-dbm* "this_is_not_a_key"))
+   ;; use default
+   (dbm-get *current-dbm* "this_is_not_a_key" #t)))
+
+;; does for-each and map do a right thing?
+(define (test:for-each dataset)
+  (call/cc
+   (lambda (return)
+     (let ((r '()))
+       (dbm-for-each *current-dbm*
+                     (lambda (k v)
+                       (unless (equal? v (hash-table-get dataset k #f))
+                         (return #f))
+                       (set! r (cons v r))))
+       (equal? (reverse r)
+               (dbm-map *current-dbm*
+                        (lambda (k v) v)))))))
+
+;; does collection framework works?
+(define (test:collection-read dataset)
+  (call/cc
+   (lambda (return)
+     (for-each (lambda (entry)
+                 (unless (equal? (hash-table-get dataset (car entry))
+                                 (cdr entry))
+                   (return #f)))
+               *current-dbm*)
+     #t)))
+
+;; does delete work?
+(define (test:delete dataset)
+  (call/cc
+   (lambda (return)
+     (hash-table-for-each
+      dataset
+      (lambda (k v)
+        (unless (and (dbm-exists? *current-dbm* k)
+                     (begin (dbm-delete! *current-dbm* k)
+                            (not (dbm-exists? *current-dbm* k))))
+          (return #f))))
+     #t)))
+
+;; does read-only work?
+(define (test:read-only)
+  ;; if db is read-only, following procedures must throw an error.
+  (and (catch (dbm-put! *current-dbm* "" ""))
+       (catch (dbm-delete! *current-dbm* ""))))
+
+;; does close work?
+(define (test:close)
+  (dbm-close *current-dbm*)
+  (and (dbm-closed? *current-dbm*)
+       ;; following procedures must throw an error.
+       (catch (dbm-get *current-dbm* "" #f))
+       (catch (dbm-exists? *current-dbm* ""))
+       (catch (dbm-put! *current-dbm* "" ""))
+       (catch (dbm-delete! *current-dbm* ""))
+       (catch (dbm-for-each *current-dbm* (lambda _ #f)))
+       (catch (dbm-map *current-dbm* (lambda _ #f)))))
+
+;; clean up files
+(define (clean-up)
+  (when (file-exists? *test-dbm*) (sys-system #`"rm -rf ,*test-dbm*"))
+  (when (file-exists? (string-append *test-dbm* ".dir"))
+    (sys-unlink (string-append *test-dbm* ".dir")))
+  (when (file-exists? (string-append *test-dbm* ".pag"))
+    (sys-unlink (string-append *test-dbm* ".pag")))
+  (when (file-exists? (string-append *test-dbm* ".db"))
+    (sys-unlink (string-append *test-dbm* ".db"))))
+
+;; a series of test per dataset and class
+(define (run-through-test class dataset serializer)
+  (define (tag msg) (format #f "~s ~a" class msg))
+  (dynamic-wind
+   clean-up
+   (lambda ()
+     ;; create read/write db
+     (test (tag "make") #t (lambda () (test:make class :create serializer)))
+     ;; put stuffs
+     (test (tag "put!") #t (lambda () (test:put! dataset)))
+     ;; get stuffs
+     (test (tag "get") #t (lambda () (test:get dataset)))
+     (test (tag "get-exceptional") #t (lambda () (test:get-exceptional)))
+     ;; traverse
+     (test (tag "for-each") #t (lambda () (test:for-each dataset)))
+     ;(test (tag "collection-read") #t
+     ;      (lambda () (test:collection-read dataset)))
+     ;; close
+     (test (tag "close") #t (lambda () (test:close)))
+     ;; open again with read only
+     (test (tag "read-only open") #t (lambda () (test:make class :read serializer)))
+     ;; does it still have stuffs?
+     (test (tag "get again") #t (lambda () (test:get dataset)))
+     ;; does it work as read-only?
+     (test (tag "read-only") #t (lambda () (test:read-only)))
+     ;; close and open it again
+     (test (tag "close again") #t
+           (lambda ()
+             (dbm-close *current-dbm*)
+             (test:make class :write serializer)))
+     ;; delete stuffs
+     (test (tag "delete") #t (lambda () (test:delete dataset)))
+     ;; close again
+     (test (tag "close again") #t (lambda () (test:close))))
+   clean-up))
+
+
+;; Do test for two datasets
+(define (full-test class)
+  (test-section (format #f "~a dataset 1" (class-name class)))
+  (run-through-test class *test1-dataset* #f)
+  (test-section (format #f "~a dataset 2" (class-name class)))
+  (run-through-test class *test2-dataset* #t)
+  )
+
+;; conditionally test
+(define-macro (test-if-exists file module class)
+  (when (file-exists? (string-append file "." (gauche-dso-suffix)))
+    `(begin (use ,module)
+            (test-module ',module)
+            (full-test ,class))
+    ))
+
+;;
+;; run test
+;;
+
+(full-test <tcbdb>)
 
 ;; epilogue

lang/scheme/gauche-tokyocabinet/trunk/tokyocabinet.c

@@ -25 +25 @@
 {
     return SCM_MAKE_STR("tokyocabinet is working");
+}
+
+ScmObj Scm_tcbdb_ecode(ScmRawTcbdb* bdb){
+    return SCM_MAKE_INT(tcbdbecode(SCM_RAW_TCBDB(bdb)->bdb));
 }
 
@@ -59 +63 @@
     ScmObj ret = SCM_MAKE_STR(val);
     return ret;
+}
+
+ScmObj Scm_tcbdb_out2(ScmRawTcbdb* bdb, ScmString* key){
+    return TCCALL(tcbdbout2(bdb->bdb
+                            , Scm_GetString(key)));
 }
 

lang/scheme/gauche-tokyocabinet/trunk/tokyocabinet.h

@@ -81 +81 @@
 
 extern ScmObj test_tokyocabinet(void);
+extern ScmObj Scm_tcbdb_ecode(ScmRawTcbdb* bdb);
 extern ScmObj Scm_tcbdb_new(void);
 extern ScmObj Scm_tcbdb_open(ScmRawTcbdb* bdb, ScmString* path, int omode);
@@ -86 +87 @@
 extern ScmObj Scm_tcbdb_put2(ScmRawTcbdb* bdb, ScmString* key, ScmString* val);
 extern ScmObj Scm_tcbdb_get2(ScmRawTcbdb* bdb, ScmString* key);
+extern ScmObj Scm_tcbdb_out2(ScmRawTcbdb* bdb, ScmString* key);
 extern ScmObj Scm_tcbdbcur_new(ScmRawTcbdb* bdb);
 extern ScmObj Scm_tcbdbcur_del(ScmTcbdbcur* cur);

lang/scheme/gauche-tokyocabinet/trunk/tokyocabinetlib.stub

@@ -22 +22 @@
   (return "test_tokyocabinet"))
 
+(define-cproc tcbdb-ecode (bdb::<raw-tcbdb>)
+  (return "Scm_tcbdb_ecode"))
+
 (define-cproc tcbdb-new ()
   (call "Scm_tcbdb_new"))
@@ -42 +45 @@
 
   (call "Scm_tcbdb_get2"))
+
+(define-cproc tcbdb-out2 (bdb::<raw-tcbdb>
+                          key::<string>)
+
+  (call "Scm_tcbdb_out2"))
 
 (define-cproc tcbdbcur-new (bdb::<raw-tcbdb>)
@@ -71 +79 @@
 (define-enum BDBOLCKNB)
 
+(define-enum TCESUCCESS)
+(define-enum TCETHREAD)
+(define-enum TCEINVALID)
+(define-enum TCENOFILE)
+(define-enum TCENOPERM)
+(define-enum TCEMETA)
+(define-enum TCERHEAD)
+(define-enum TCEOPEN)
+(define-enum TCECLOSE)
+(define-enum TCETRUNC)
+(define-enum TCESYNC)
+(define-enum TCESTAT)
+(define-enum TCESEEK)
+(define-enum TCEREAD)
+(define-enum TCEWRITE)
+(define-enum TCEMMAP)
+(define-enum TCELOCK)
+(define-enum TCEUNLINK)
+(define-enum TCERENAME)
+(define-enum TCEMKDIR)
+(define-enum TCERMDIR)
+(define-enum TCEKEEP)
+(define-enum TCENOREC)
+(define-enum TCEMISC)
+
 ;; (use srfi-13)
 ;; (dolist (var '(reader writer creat trunc nolck lcknb)) (format #t "(define-enum BDBO~a)\n" (string-upcase (x->string var))))