source: project/release/3/tokyocabinet/tokyocabinet.scm @ 12323

;;;; tokyocabinet.scm -- Tokyo Cabinet DBM bindings for Chicken
;;
;; Copyright (c) 2008 Alex Shinn
;; All rights reserved.
;;
;; BSD-style license: http://www.debian.org/misc/bsd.license

(declare
 (fixnum-arithmetic)
 (usual-integrations)
 (export
  TC_HDBTLARGE TC_HDBTDEFLATE TC_HDBTBZIP TC_HDBTTCBS
  TC_HDBOWRITER TC_HDBOREADER TC_HDBOCREAT TC_HDBOTRUNC
  TC_HDBONOLCK TC_HDBOLCKNB
  tc-hdb-open tc-hdb-close
  tc-hdb-put! tc-hdb-delete! tc-hdb-get
  tc-hdb-fold
  tc-hdb-iter-init tc-hdb-iter-next
  ))

(declare
  (foreign-declare "

#include <tcutil.h>
#include <tchdb.h>
#include <stdlib.h>
#include <stdbool.h>
#include <stdint.h>

#define copy_string_result(ptr, len, str)     (C_memcpy(C_c_string(str), (char *)C_block_item(ptr, 0), C_unfix(len)), C_SCHEME_UNDEFINED)

"))

;; tc-hdb-tune flags
(define-foreign-variable HDBTLARGE int "HDBTLARGE")
(define-foreign-variable HDBTDEFLATE int "HDBTDEFLATE")
(define-foreign-variable HDBTBZIP int "HDBTBZIP")
(define-foreign-variable HDBTTCBS int "HDBTTCBS")

(define TC_HDBTLARGE HDBTLARGE)
(define TC_HDBTDEFLATE HDBTDEFLATE)
(define TC_HDBTBZIP HDBTBZIP)
(define TC_HDBTTCBS HDBTTCBS)

;; tc-hdb-open flags
(define-foreign-variable HDBOWRITER int "HDBOWRITER")
(define-foreign-variable HDBOREADER int "HDBOREADER")
(define-foreign-variable HDBOCREAT int "HDBOCREAT")
(define-foreign-variable HDBOTRUNC int "HDBOTRUNC")
(define-foreign-variable HDBONOLCK int "HDBONOLCK")
(define-foreign-variable HDBOLCKNB int "HDBOLCKNB")

(define TC_HDBOWRITER HDBOWRITER)
(define TC_HDBOREADER HDBOREADER)
(define TC_HDBOCREAT HDBOCREAT)
(define TC_HDBOTRUNC HDBOTRUNC)
(define TC_HDBONOLCK HDBONOLCK)
(define TC_HDBOLCKNB HDBOLCKNB)

(define %tc-hdb-new (foreign-lambda c-pointer "tchdbnew"))

(define %tc-hdb-del
  (foreign-lambda* void ((c-pointer hdb))
    "tchdbdel((TCHDB*) hdb);"))

(define %tc-hdb-set-mutex!
  (foreign-lambda* bool ((c-pointer hdb))
    "return(tchdbsetmutex((TCHDB*) hdb));"))

(define %tc-hdb-set-cache!
  (foreign-lambda* bool ((c-pointer hdb) (int rcnum))
    "return(tchdbsetcache((TCHDB*) hdb, rcnum));"))

(define %tc-hdb-set-xmsiz!
  (foreign-lambda* bool ((c-pointer hdb) (int xmsiz))
    "return(tchdbsetxmsiz((TCHDB*) hdb, xmsiz));"))

(define %tc-hdb-tune!
  (foreign-lambda* bool ((c-pointer hdb)
                         (int bnum) (int apow) (int fpow) (int opts))
    "return(tchdbtune((TCHDB*) hdb, bnum, apow, fpow, opts));"))

(define %tc-hdb-open
  (foreign-lambda* bool ((c-pointer hdb) (c-string file) (int flags))
    "return(tchdbopen(hdb, file, flags));"))

(define (tc-hdb-open file
                     #!key
                     (flags (fx+ HDBOWRITER (fx+ HDBOREADER HDBOCREAT)))
                     (mutex? #f)
                     (num-buckets #f)
                     (record-alignment #f)
                     (num-free-blocks #f)
                     (tune-opts #f)
                     (cache-limit #f)
                     (mmap-size #f))
  (let ((hdb (%tc-hdb-new)))
    (and hdb
         ;; make sure all the specified keyword settings succeed, and
         ;; return the hdb c-pointer
         (or (and
              (or (not mutex?) (%tc-hdb-set-mutex! hdb))
              (or (not cache-limit) (%tc-hdb-set-cache! hdb cache-limit))
              (or (not mmap-size) (%tc-hdb-set-xmsiz! hdb mmap-size))
              (or (not (or num-buckets record-alignment num-free-blocks
                           tune-opts))
                  (%tc-hdb-tune! hdb
                                 (or num-buckets 0)
                                 (or record-alignment -1)
                                 (or num-free-blocks -1)
                                 (or tune-opts 0)))
              (%tc-hdb-open hdb file flags)
              hdb)
             (begin
               ;; clean up and return #f if any of the functions failed
               (%tc-hdb-del hdb)
               #f)))))

(define tc-hdb-close
  (foreign-lambda* bool ((c-pointer hdb))
    "if (tchdbclose((TCHDB*) hdb)) {"
    "    tchdbdel((TCHDB*) hdb);"
    "    return(1);"
    "} else {"
    "    return(0);"
    "}"))

(define %tc-hdb-put!
  (foreign-lambda* bool ((c-pointer hdb)
                         (pointer kptr) (int ksize)
                         (pointer vptr) (int vsize))
    "return(tchdbput((TCHDB*) hdb, kptr, ksize, vptr, vsize));"))

(define (tc-hdb-put! hdb key value)
  (%tc-hdb-put! hdb key (string-length key) value (string-length value)))

(define %tc-hdb-delete!
  (foreign-lambda* bool ((c-pointer hdb) (pointer kptr) (int ksize))
    "return(tchdbout((TCHDB*) hdb, kptr, ksize));"))

(define (tc-hdb-delete! hdb key)
  (%tc-hdb-delete! hdb key (string-length key)))

(define %tc-hdb-get
  (foreign-safe-lambda* scheme-object
                        ((c-pointer hdb) (pointer kptr) (int ksize))
    "int size;"
    "void* res;"
    "if (! (res=tchdbget((TCHDB*) hdb, kptr, ksize, &size))) {"
    "    return(C_SCHEME_FALSE);"
    "} else {"
    "    return(make_string_with_len(res, size));"
    "}"))

(define (tc-hdb-get hdb key)
  (%tc-hdb-get hdb key (string-length key)))

(define tc-hdb-iter-init
  (foreign-lambda* bool ((c-pointer hdb))
    "return(tchdbiterinit((TCHDB*) hdb));"))

(define tc-hdb-iter-next
  (foreign-lambda* c-string ((c-pointer hdb))
    "return(tchdbiternext2((TCHDB*) hdb));"))

(define (tc-hdb-fold hdb kons knil)
  (tc-hdb-iter-init hdb)
  (let lp ((acc knil))
    (let ((key (tc-hdb-iter-next hdb)))
      (if (not key)
          acc
          (let ((val (tc-hdb-get hdb key)))
            (lp (kons key val acc)))))))

(define-external (make_string_with_len (c-pointer ptr) (int len)) scheme-object
  (and ptr
       (let ((str (make-string len)))
         (##core#inline "copy_string_result" ptr len str)
         str)))