Changeset 24295 for lang/scheme

Timestamp:

11/19/08 19:12:38 (7 weeks ago)

Author:

hayamiz

Message:

lang/scheme/gauche-tokyocabinet/trunk:
Now that Gauche-tokyocabinet supports hash-based DB not only B+tree-based.

Location:

lang/scheme/gauche-tokyocabinet/trunk

Files:

• DIST (modified) (1 diff)
• DIST_EXCLUDE_X (modified) (1 diff)
• configure.ac (modified) (1 diff)
• dbm/tokyocabinet.scm (modified) (11 diffs)
• test.scm (modified) (1 diff)
• tokyocabinet.c (modified) (11 diffs)
• tokyocabinet.h (modified) (6 diffs)
• tokyocabinetlib.stub (modified) (7 diffs)

lang/scheme/gauche-tokyocabinet/trunk/DIST

@@ -32 +32 @@
   echo DIST > DIST_EXCLUDE_X
   echo DIST_EXCLUDE_X >> DIST_EXCLUDE_X
+  echo .svn >> DIST_EXCLUDE_X
   if [ -f DIST_EXCLUDE ]; then cat DIST_EXCLUDE >> DIST_EXCLUDE_X; fi
   find . -name CVS -print -prune >> DIST_EXCLUDE_X

lang/scheme/gauche-tokyocabinet/trunk/DIST_EXCLUDE_X

@@ -1 +1 @@
 DIST
 DIST_EXCLUDE_X
+.svn

lang/scheme/gauche-tokyocabinet/trunk/configure.ac

@@ -6 +6 @@
 
 AC_PREREQ(2.54)
-AC_INIT(Gauche-tokyocabinet, 0.1, y.hayamizu@gmail.com)
+AC_INIT(Gauche-tokyocabinet, 0.2, y.hayamizu@gmail.com)
 dnl If you want to use the system name (OS, architecture, etc) in the
 dnl configure, uncomment the following line.  In such a case, you need

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

@@ -5 +5 @@
 (define-module dbm.tokyocabinet
   (extend dbm)
-  (export <tcbdb>
+  (export <tcbdb> <tchdb>
 
           ;; low level interface
@@ -11 +11 @@
           tcbdb-open tcbdb-close
           tcbdb-put2 tcbdb-get2 tcbdb-out2
+
+          tchdb-new tchdb-ecode
+          tchdb-open tchdb-close
+          tchdb-put2 tchdb-get2 tchdb-out2
+
+          ;; B+ tree specific API
           tcbdbcur-new
           tcbdbcur-first tcbdbcur-last
           tcbdbcur-prev tcbdbcur-next
           tcbdbcur-key2 tcbdbcur-val2
-          tcbdb-fold tcbdb-map tcbdb-for-each
-          
+
+          ;; Hash specific API
+          tchdb-iterinit
+          tchdb-iternext2 tchdb-iternext3
+
           |BDBOREADER| |BDBOWRITER| |BDBOCREAT|
           |BDBOTRUNC| |BDBONOLCK| |BDBOLCKNB|
-
+          
+          |HDBOREADER| |HDBOWRITER| |HDBOCREAT|
+          |HDBOTRUNC| |HDBONOLCK| |HDBOLCKNB|
+          
           |TCESUCCESS| |TCETHREAD| |TCEINVALID|
           |TCENOFILE| |TCENOPERM| |TCEMETA|
@@ -37 +49 @@
 (define-class <tcbdb-meta> (<dbm-meta>)
   ())
+(define-class <tchdb-meta> (<dbm-meta>)
+  ())
 
 (define-class <tcbdb> (<dbm>)
@@ -43 +57 @@
    (nolock :init-keyword :nolock :initform #f))
   :metaclass <tcbdb-meta>)
-
-;;;
-;;; low level interfaces
-;;;
-
-(define (tcbdb-fold bdb proc knil)
-  (let1 cur (tcbdbcur-new bdb)
-    (if (not (tcbdbcur-first cur))
-        knil
-        (let loop((continue? #t) (ret knil))
-          (if (not continue?)
-              ret
-              (let1 newret (proc (tcbdbcur-key2 cur) (tcbdbcur-val2 cur) ret)
-                (loop (tcbdbcur-next cur) newret)))))))
-
-(define (tcbdb-map bdb proc)
-  (reverse (tcbdb-fold bdb
-                       (lambda (key val kdr)
-                         (cons (proc key val) kdr))
-                       ())))
-
-(define (tcbdb-for-each bdb proc)
-  (tcbdb-fold bdb
-              (lambda (key val kdr)
-                (proc key val))
-              ())
-  (begin))
+(define-class <tchdb> (<dbm>)
+  ((raw-tchdb :accessor raw-tchdb-of :initform #f)
+   (noblock-lock :init-keyword :noblock-lock :initform #f)
+   (nolock :init-keyword :nolock :initform #f))
+  :metaclass <tchdb-meta>)
 
 
@@ -80 +72 @@
   self
   (unless (slot-bound? self 'path)
-    (error "path must be set to open TokyoCabinet BDB database"))
+    (error "path must be specified in order to open TokyoCabinet BDB database"))
   (when (raw-tcbdb-of self)
-    (error "gdbm ~S already opened" self))
+    (error "tcbdb ~S already opened" self))
   (let* ((path   (slot-ref self 'path))
          (nolock (slot-ref self 'nolock))
@@ -100 +92 @@
            self)))
   )
+(define-method dbm-open ((self <tchdb>))
+  (next-method)
+  self
+  (unless (slot-bound? self 'path)
+    (error "path must be specified in order to open TokyoCabinet HDB database"))
+  (when (raw-tchdb-of self)
+    (error "tchdb ~S already opened" self))
+  (let* ((path   (slot-ref self 'path))
+         (nolock (slot-ref self 'nolock))
+         (noblock-lock (slot-ref self 'noblock-lock))
+         (omode  (case (slot-ref self 'rw-mode)
+                   ((:read) |HDBOREADER|)
+                   ((:write) (logior |HDBOCREAT| |HDBOWRITER|
+                                    (if nolock |HDBONOLCK| 0)
+                                    (if noblock-lock |HDBOLCKNB| 0)))
+                   ((:create) (logior |HDBOWRITER| |HDBOTRUNC| |HDBOCREAT|
+                                     (if nolock |HDBONOLCK| 0)
+                                     (if noblock-lock |HDBOLCKNB| 0)))))
+         (raw-tchdb (tchdb-new)))
+    (and (tchdb-open raw-tchdb path omode)
+         (begin
+           (slot-set! self 'raw-tchdb raw-tchdb)
+           self)))
+  )
 
 (define-method dbm-close ((self <tcbdb>))
@@ -106 +122 @@
          (begin (slot-set! self 'raw-tcbdb #f)
                 #t))))
+(define-method dbm-close ((self <tchdb>))
+  (let ((raw-tchdb (raw-tchdb-of self)))
+    (and raw-tchdb (tchdb-close raw-tchdb)
+         (begin (slot-set! self 'raw-tchdb #f)
+                #t))))
 
 (define-method dbm-closed? ((self <tcbdb>))
   (not (slot-ref self 'raw-tcbdb)))
+(define-method dbm-closed? ((self <tchdb>))
+  (not (slot-ref self 'raw-tchdb)))
 
 (define-method dbm-put! ((self <tcbdb>) key value)
@@ -120 +143 @@
             (error "tokyocabinet bdb: database is opened as read only")
             #f)))))
+(define-method dbm-put! ((self <tchdb>) key value)
+  (next-method)
+  (let ((key (%dbm-k2s self key))
+        (value (%dbm-v2s self value)))
+    (let1 ret (tchdb-put2 (raw-tchdb-of self) key value)
+    (if ret
+        ret
+        (if (eq? :read (slot-ref self 'rw-mode))
+            (error "tokyocabinet hdb: database is opened as read only")
+            #f)))))
 
 (define-method dbm-get ((self <tcbdb>) key . args)
@@ -131 +164 @@
                       key self)
               (car args))))))
+(define-method dbm-get ((self <tchdb>) key . args)
+  (next-method)
+  (let ((key (%dbm-k2s self key)))
+    (let1 ret (tchdb-get2 (raw-tchdb-of self) key)
+      (if ret
+          (%dbm-s2v self ret)
+          (if (null? args)
+              (errorf "tokyocabinet hdb: 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-exists? ((self <tchdb>) key)
+  (and (tchdb-get2 (raw-tchdb-of self) (%dbm-k2s self key)) #t))
 
 (define-method dbm-delete! ((self <tcbdb>) key)
@@ -139 +184 @@
       (if (eq? :read (slot-ref self 'rw-mode))
           (error "tokyocabinet bdb: database is opened as read only")
+          #f)))
+(define-method dbm-delete! ((self <tchdb>) key)
+  (or (tchdb-out2 (raw-tchdb-of self) (%dbm-k2s self key))
+      (if (eq? :read (slot-ref self 'rw-mode))
+          (error "tokyocabinet hdb: database is opened as read only")
           #f)))
 
@@ -153 +203 @@
                                  ret)
                 (loop (tcbdbcur-next cur) newret)))))))
+(define-method dbm-fold ((self <tchdb>) proc knil)
+  (let1 raw-hdb (raw-tchdb-of self)
+    (unless (tchdb-iterinit raw-hdb)
+      (error "tokyocabint hdb: iter init failed!"))
+    (let loop((continue? #t) (ret knil))
+      (if (not continue?)
+          ret
+          (receive (cont? key val)
+              (tchdb-iternext3 raw-hdb)
+            (loop cont?
+                  (proc (%dbm-s2k self key)
+                        (%dbm-s2v self val)
+                        ret)))))))
+
 
 ;; Epilogue

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

@@ -207 +207 @@
 
 (full-test <tcbdb>)
+(full-test <tchdb>)
 
 ;; epilogue
 (test-end)
 
-
-
-
-

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

@@ -6 +6 @@
 
 #define TCCALL(call) ((call) ? SCM_TRUE : SCM_FALSE)
-
-/*
- * The following function is a dummy one; replace it for
- * your C function definitions.
- */
+// #define DEBUG_GAUCHE_TOKYOCABINET
+
+/* These variables are for temporary use. */
+static TCXSTR * xkey;
+static TCXSTR * xvalue;
+
 
 static void tcbdb_finalize(ScmObj obj, void *data)
@@ -17 +18 @@
     tcbdbclose(bdb->bdb);
 }
+static void tchdb_finalize(ScmObj obj, void *data)
+{
+    ScmRawTchdb *hdb = SCM_RAW_TCHDB(obj);
+    tchdbclose(hdb->hdb);
+}
+
+
 
 static void tcbdb_print(ScmObj obj, ScmPort *out, ScmWriteContext *ctx){
     Scm_Printf(out, "#<tcbdb-file>");
 }
+static void tchdb_print(ScmObj obj, ScmPort *out, ScmWriteContext *ctx){
+    Scm_Printf(out, "#<tchdb-file>");
+}
+
+
 
 ScmObj test_tokyocabinet(void)
@@ -26 +39 @@
     return SCM_MAKE_STR("tokyocabinet is working");
 }
+
+
 
 ScmObj Scm_tcbdb_ecode(ScmRawTcbdb* bdb){
     return SCM_MAKE_INT(tcbdbecode(SCM_RAW_TCBDB(bdb)->bdb));
 }
+ScmObj Scm_tchdb_ecode(ScmRawTchdb* hdb){
+    return SCM_MAKE_INT(tchdbecode(SCM_RAW_TCHDB(hdb)->hdb));
+}
+
+
 
 ScmObj Scm_tcbdb_new(void){
@@ -38 +58 @@
     return SCM_OBJ(ret);
 }
+ScmObj Scm_tchdb_new(void){
+    ScmRawTchdb *ret = SCM_NEW(ScmRawTchdb);
+    SCM_SET_CLASS(ret, SCM_CLASS_RAW_TCHDB);
+    Scm_RegisterFinalizer(SCM_OBJ(ret), tchdb_finalize, NULL);
+    ret->hdb = tchdbnew();
+    return SCM_OBJ(ret);
+}
+
+
 
 ScmObj Scm_tcbdb_open(ScmRawTcbdb* bdb, ScmString* path, int omode){
@@ -44 +73 @@
                                   , omode));
 }
+ScmObj Scm_tchdb_open(ScmRawTchdb* hdb, ScmString* path, int omode){
+    ScmObj ret = TCCALL(tchdbopen(hdb->hdb
+                                  , Scm_GetString(path)
+                                  , omode));
+}
+
+
 
 ScmObj Scm_tcbdb_close(ScmRawTcbdb* bdb){
     return TCCALL(tcbdbclose(bdb->bdb));
 }
+ScmObj Scm_tchdb_close(ScmRawTchdb* hdb){
+    return TCCALL(tchdbclose(hdb->hdb));
+}
+
+
 
 ScmObj Scm_tcbdb_put2(ScmRawTcbdb* bdb, ScmString* key, ScmString* val){
@@ -54 +95 @@
                             , Scm_GetString(val)));
 }
+ScmObj Scm_tchdb_put2(ScmRawTchdb* hdb, ScmString* key, ScmString* val){
+    return TCCALL(tchdbput2(hdb->hdb
+                            , Scm_GetString(key)
+                            , Scm_GetString(val)));
+}
+
+
+
 ScmObj Scm_tcbdb_get2(ScmRawTcbdb* bdb, ScmString* key){
     char * val = tcbdbget2(bdb->bdb
@@ -64 +113 @@
     return ret;
 }
+ScmObj Scm_tchdb_get2(ScmRawTchdb* hdb, ScmString* key){
+    char * val = tchdbget2(hdb->hdb
+                           , Scm_GetString(key));
+    if(val == NULL){
+        return SCM_FALSE;
+    }
+
+    ScmObj ret = SCM_MAKE_STR(val);
+    return ret;
+}
+
+
 
 ScmObj Scm_tcbdb_out2(ScmRawTcbdb* bdb, ScmString* key){
@@ -69 +130 @@
                             , Scm_GetString(key)));
 }
-
+ScmObj Scm_tchdb_out2(ScmRawTchdb* hdb, ScmString* key){
+    return TCCALL(tchdbout2(hdb->hdb
+                            , Scm_GetString(key)));
+}
+
+
+/*
+  B+ tree specific API from here
+ */
 static void tcbdbcur_finalize(ScmObj obj, void *data)
 {
@@ -123 +192 @@
 
 /*
+  B+ tree specific API until here
+ */
+
+
+/*
+  Hash specific API from here
+ */
+
+
+
+/*
+  Hash specific API until here
+ */
+
+extern ScmObj Scm_tchdb_iterinit(ScmRawTchdb* hdb){
+#ifdef DEBUG_GAUCHE_TOKYOCABINET
+    puts("Scm_tchdb_iterinit");
+#endif
+    return TCCALL(tchdbiterinit(hdb->hdb));
+}
+
+extern ScmObj Scm_tchdb_iternext2(ScmRawTchdb* hdb){
+    char * key = tchdbiternext2(hdb->hdb);
+    if (key == NULL){
+        return SCM_FALSE;
+    }
+
+    /*
+     *key is newly malloced in tchdbiternext2, so
+     SCM_MAKE_STR is appropriate, because it does not
+     copy its argument (STM_MAKE_STR_COPYING does)
+     */
+    return SCM_MAKE_STR(key);
+}
+
+
+
+extern ScmObj Scm_tchdb_iternext3(ScmRawTchdb* hdb){
+#ifdef DEBUG_GAUCHE_TOKYOCABINET
+    printf("Scm_tchdb_iternext3( 0x%x )", (uintptr_t) hdb);
+#endif 
+    ScmObj ret_iternext, key, val;
+
+#ifdef DEBUG_GAUCHE_TOKYOCABINET
+    printf("call tchdbiternext3( 0x%x , 0x%x , 0x%x )"
+           , (uintptr_t) hdb->hdb
+           , (uintptr_t) xkey
+           , (uintptr_t) xvalue);
+#endif
+    ret_iternext = TCCALL(tchdbiternext3(hdb->hdb, xkey, xvalue));
+    key = SCM_MAKE_STR_COPYING(tcxstrptr(xkey));
+    val = SCM_MAKE_STR_COPYING(tcxstrptr(xvalue));
+    return Scm_Values3(ret_iternext, key, val);
+}
+
+
+
+/*
  * Module initialization function.
  */
@@ -130 +257 @@
 {
     ScmModule *mod;
+
+    xkey = tcxstrnew();
+    xvalue = tcxstrnew();
 
     /* Register this DSO to Gauche */
@@ -137 +267 @@
     mod = SCM_MODULE(SCM_FIND_MODULE("dbm.tokyocabinet", TRUE));
     Scm_InitStaticClass(&Scm_RawTcbdbClass, "<raw-tcbdb>", mod, NULL, 0);
+    Scm_InitStaticClass(&Scm_RawTchdbClass, "<raw-tchdb>", mod, NULL, 0);
 
     /* Register stub-generated procedures */

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

@@ -12 +12 @@
 #include <tcutil.h>
 #include <tcbdb.h>
+#include <tchdb.h>
 #include <stdlib.h>
 #include <stdbool.h>
 #include <stdint.h>
+
+
+
 
 SCM_DECL_BEGIN
@@ -48 +52 @@
 
 // (insert-class-decl "raw-tcbdb")
+// (insert-class-decl "raw-tchdb")
 SCM_CLASS_DECL(Scm_RawTcbdbClass);
+SCM_CLASS_DECL(Scm_RawTchdbClass);
+
+
+
 static void raw_tcbdb_print(ScmObj, ScmPort *, ScmWriteContext*);
+static void raw_tchdb_print(ScmObj, ScmPort *, ScmWriteContext*);
+
+
 
 #define SCM_CLASS_RAW_TCBDB (&Scm_RawTcbdbClass)
 #define SCM_RAW_TCBDB(obj)  ((ScmRawTcbdb*)obj)
 #define SCM_RAW_TCBDB_P(obj) SCM_XTYPEP(obj, SCM_CLASS_RAW_TCBDB)
+
+#define SCM_CLASS_RAW_TCHDB (&Scm_RawTchdbClass)
+#define SCM_RAW_TCHDB(obj)  ((ScmRawTchdb*)obj)
+#define SCM_RAW_TCHDB_P(obj) SCM_XTYPEP(obj, SCM_CLASS_RAW_TCHDB)
+
+
 
 typedef struct ScmRawTcbdbRec {
@@ -60 +78 @@
     // write manually
 } ScmRawTcbdb;
+
+typedef struct ScmRawTchdbRec {
+    SCM_HEADER;
+    TCHDB* hdb;
+    // write manually
+} ScmRawTchdb;
+
 
 
@@ -77 +102 @@
 
 
+
 static void tcbdb_finalize(ScmObj obj, void *data);
 static void tcbdb_print(ScmObj obj, ScmPort *out, ScmWriteContext *ctx);
+
+static void tchdb_finalize(ScmObj obj, void *data);
+static void tchdb_print(ScmObj obj, ScmPort *out, ScmWriteContext *ctx);
+
+
 
 extern ScmObj test_tokyocabinet(void);
@@ -88 +119 @@
 extern ScmObj Scm_tcbdb_get2(ScmRawTcbdb* bdb, ScmString* key);
 extern ScmObj Scm_tcbdb_out2(ScmRawTcbdb* bdb, ScmString* key);
+
+extern ScmObj Scm_tchdb_ecode(ScmRawTchdb* bdb);
+extern ScmObj Scm_tchdb_new(void);
+extern ScmObj Scm_tchdb_open(ScmRawTchdb* bdb, ScmString* path, int omode);
+extern ScmObj Scm_tchdb_close(ScmRawTchdb* bdb);
+extern ScmObj Scm_tchdb_put2(ScmRawTchdb* bdb, ScmString* key, ScmString* val);
+extern ScmObj Scm_tchdb_get2(ScmRawTchdb* bdb, ScmString* key);
+extern ScmObj Scm_tchdb_out2(ScmRawTchdb* bdb, ScmString* key);
+extern ScmObj Scm_tchdbcur_new(ScmRawTchdb* bdb);
+
+
+
+/* B+ tree specific API */
 extern ScmObj Scm_tcbdbcur_new(ScmRawTcbdb* bdb);
 extern ScmObj Scm_tcbdbcur_del(ScmTcbdbcur* cur);
@@ -97 +141 @@
 extern ScmObj Scm_tcbdbcur_val2(ScmTcbdbcur* cur);
 
+
+/* Hash specific API */
+extern ScmObj Scm_tchdb_iterinit(ScmRawTchdb* hdb);
+extern ScmObj Scm_tchdb_iternext2(ScmRawTchdb* hdb);
+extern ScmObj Scm_tchdb_iternext3(ScmRawTchdb* hdb);
+
+
 /* Epilogue */
 SCM_DECL_END

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

@@ -14 +14 @@
   ()
   ())
+(define-cclass <raw-tchdb> "ScmRawTchdb*" "Scm_RawTchdbClass"
+  ()
+  ())
+
+
 
 (define-cclass <tcbdbcur> "ScmTcbdbcur*" "Scm_TcbdbcurClass"
@@ -19 +24 @@
   ())
 
+
 (define-cproc test-tokyocabinet ()
   (return "test_tokyocabinet"))
 
+
+
 (define-cproc tcbdb-ecode (bdb::<raw-tcbdb>)
   (return "Scm_tcbdb_ecode"))
+(define-cproc tchdb-ecode (hdb::<raw-tchdb>)
+  (return "Scm_tchdb_ecode"))
+
+
 
 (define-cproc tcbdb-new ()
   (call "Scm_tcbdb_new"))
+(define-cproc tchdb-new ()
+  (call "Scm_tchdb_new"))
+
 
 (define-cproc tcbdb-open (bdb::<raw-tcbdb>
@@ -32 +47 @@
                           omode::<fixnum>)
   (call "Scm_tcbdb_open"))
+(define-cproc tchdb-open (hdb::<raw-tchdb>
+                          path::<string>
+                          omode::<fixnum>)
+  (call "Scm_tchdb_open"))
+
 
 (define-cproc tcbdb-close (bdb::<raw-tcbdb>)
   (call "Scm_tcbdb_close"))
+(define-cproc tchdb-close (hdb::<raw-tchdb>)
+  (call "Scm_tchdb_close"))
+
 
 (define-cproc tcbdb-put2 (bdb::<raw-tcbdb>
@@ -40 +63 @@
                           val::<string>)
   (call "Scm_tcbdb_put2"))
+(define-cproc tchdb-put2 (hdb::<raw-tchdb>
+                          key::<string>
+                          val::<string>)
+  (call "Scm_tchdb_put2"))
+
 
 (define-cproc tcbdb-get2 (bdb::<raw-tcbdb>
@@ -45 +73 @@
 
   (call "Scm_tcbdb_get2"))
+(define-cproc tchdb-get2 (hdb::<raw-tchdb>
+                          key::<string>)
+
+  (call "Scm_tchdb_get2"))
+
 
 (define-cproc tcbdb-out2 (bdb::<raw-tcbdb>
@@ -50 +83 @@
 
   (call "Scm_tcbdb_out2"))
+(define-cproc tchdb-out2 (hdb::<raw-tchdb>
+                          key::<string>)
 
+  (call "Scm_tchdb_out2"))
+
+;; B+ tree specific API
 (define-cproc tcbdbcur-new (bdb::<raw-tcbdb>)
   (call "Scm_tcbdbcur_new"))
-
 (define-cproc tcbdbcur-first (cur::<tcbdbcur>)
   (call "Scm_tcbdbcur_first"))
-
 (define-cproc tcbdbcur-last (cur::<tcbdbcur>)
   (call "Scm_tcbdbcur_last"))
-
 (define-cproc tcbdbcur-prev (cur::<tcbdbcur>)
   (call "Scm_tcbdbcur_prev"))
-
 (define-cproc tcbdbcur-next (cur::<tcbdbcur>)
   (call "Scm_tcbdbcur_next"))
-
 (define-cproc tcbdbcur-key2 (cur::<tcbdbcur>)
   (call "Scm_tcbdbcur_key2"))
-
 (define-cproc tcbdbcur-val2 (cur::<tcbdbcur>)
   (call "Scm_tcbdbcur_val2"))
+