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

Last change on this file since 12323 was 12323, checked in by Alex Shinn, 12 years ago

Initial import.

File size: 5.6 KB
Line 
1;;;; tokyocabinet.scm -- Tokyo Cabinet DBM bindings for Chicken
2;;
3;; Copyright (c) 2008 Alex Shinn
4;; All rights reserved.
5;;
6;; BSD-style license: http://www.debian.org/misc/bsd.license
7
8(declare
9 (fixnum-arithmetic)
10 (usual-integrations)
11 (export
12  TC_HDBTLARGE TC_HDBTDEFLATE TC_HDBTBZIP TC_HDBTTCBS
13  TC_HDBOWRITER TC_HDBOREADER TC_HDBOCREAT TC_HDBOTRUNC
14  TC_HDBONOLCK TC_HDBOLCKNB
15  tc-hdb-open tc-hdb-close
16  tc-hdb-put! tc-hdb-delete! tc-hdb-get
17  tc-hdb-fold
18  tc-hdb-iter-init tc-hdb-iter-next
19  ))
20
21(declare
22  (foreign-declare "
23
24#include <tcutil.h>
25#include <tchdb.h>
26#include <stdlib.h>
27#include <stdbool.h>
28#include <stdint.h>
29
30#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)
31
32"))
33
34;; tc-hdb-tune flags
35(define-foreign-variable HDBTLARGE int "HDBTLARGE")
36(define-foreign-variable HDBTDEFLATE int "HDBTDEFLATE")
37(define-foreign-variable HDBTBZIP int "HDBTBZIP")
38(define-foreign-variable HDBTTCBS int "HDBTTCBS")
39
40(define TC_HDBTLARGE HDBTLARGE)
41(define TC_HDBTDEFLATE HDBTDEFLATE)
42(define TC_HDBTBZIP HDBTBZIP)
43(define TC_HDBTTCBS HDBTTCBS)
44
45;; tc-hdb-open flags
46(define-foreign-variable HDBOWRITER int "HDBOWRITER")
47(define-foreign-variable HDBOREADER int "HDBOREADER")
48(define-foreign-variable HDBOCREAT int "HDBOCREAT")
49(define-foreign-variable HDBOTRUNC int "HDBOTRUNC")
50(define-foreign-variable HDBONOLCK int "HDBONOLCK")
51(define-foreign-variable HDBOLCKNB int "HDBOLCKNB")
52
53(define TC_HDBOWRITER HDBOWRITER)
54(define TC_HDBOREADER HDBOREADER)
55(define TC_HDBOCREAT HDBOCREAT)
56(define TC_HDBOTRUNC HDBOTRUNC)
57(define TC_HDBONOLCK HDBONOLCK)
58(define TC_HDBOLCKNB HDBOLCKNB)
59
60(define %tc-hdb-new (foreign-lambda c-pointer "tchdbnew"))
61
62(define %tc-hdb-del
63  (foreign-lambda* void ((c-pointer hdb))
64    "tchdbdel((TCHDB*) hdb);"))
65
66(define %tc-hdb-set-mutex!
67  (foreign-lambda* bool ((c-pointer hdb))
68    "return(tchdbsetmutex((TCHDB*) hdb));"))
69
70(define %tc-hdb-set-cache!
71  (foreign-lambda* bool ((c-pointer hdb) (int rcnum))
72    "return(tchdbsetcache((TCHDB*) hdb, rcnum));"))
73
74(define %tc-hdb-set-xmsiz!
75  (foreign-lambda* bool ((c-pointer hdb) (int xmsiz))
76    "return(tchdbsetxmsiz((TCHDB*) hdb, xmsiz));"))
77
78(define %tc-hdb-tune!
79  (foreign-lambda* bool ((c-pointer hdb)
80                         (int bnum) (int apow) (int fpow) (int opts))
81    "return(tchdbtune((TCHDB*) hdb, bnum, apow, fpow, opts));"))
82
83(define %tc-hdb-open
84  (foreign-lambda* bool ((c-pointer hdb) (c-string file) (int flags))
85    "return(tchdbopen(hdb, file, flags));"))
86
87(define (tc-hdb-open file
88                     #!key
89                     (flags (fx+ HDBOWRITER (fx+ HDBOREADER HDBOCREAT)))
90                     (mutex? #f)
91                     (num-buckets #f)
92                     (record-alignment #f)
93                     (num-free-blocks #f)
94                     (tune-opts #f)
95                     (cache-limit #f)
96                     (mmap-size #f))
97  (let ((hdb (%tc-hdb-new)))
98    (and hdb
99         ;; make sure all the specified keyword settings succeed, and
100         ;; return the hdb c-pointer
101         (or (and
102              (or (not mutex?) (%tc-hdb-set-mutex! hdb))
103              (or (not cache-limit) (%tc-hdb-set-cache! hdb cache-limit))
104              (or (not mmap-size) (%tc-hdb-set-xmsiz! hdb mmap-size))
105              (or (not (or num-buckets record-alignment num-free-blocks
106                           tune-opts))
107                  (%tc-hdb-tune! hdb
108                                 (or num-buckets 0)
109                                 (or record-alignment -1)
110                                 (or num-free-blocks -1)
111                                 (or tune-opts 0)))
112              (%tc-hdb-open hdb file flags)
113              hdb)
114             (begin
115               ;; clean up and return #f if any of the functions failed
116               (%tc-hdb-del hdb)
117               #f)))))
118
119(define tc-hdb-close
120  (foreign-lambda* bool ((c-pointer hdb))
121    "if (tchdbclose((TCHDB*) hdb)) {"
122    "    tchdbdel((TCHDB*) hdb);"
123    "    return(1);"
124    "} else {"
125    "    return(0);"
126    "}"))
127
128(define %tc-hdb-put!
129  (foreign-lambda* bool ((c-pointer hdb)
130                         (pointer kptr) (int ksize)
131                         (pointer vptr) (int vsize))
132    "return(tchdbput((TCHDB*) hdb, kptr, ksize, vptr, vsize));"))
133
134(define (tc-hdb-put! hdb key value)
135  (%tc-hdb-put! hdb key (string-length key) value (string-length value)))
136
137(define %tc-hdb-delete!
138  (foreign-lambda* bool ((c-pointer hdb) (pointer kptr) (int ksize))
139    "return(tchdbout((TCHDB*) hdb, kptr, ksize));"))
140
141(define (tc-hdb-delete! hdb key)
142  (%tc-hdb-delete! hdb key (string-length key)))
143
144(define %tc-hdb-get
145  (foreign-safe-lambda* scheme-object
146                        ((c-pointer hdb) (pointer kptr) (int ksize))
147    "int size;"
148    "void* res;"
149    "if (! (res=tchdbget((TCHDB*) hdb, kptr, ksize, &size))) {"
150    "    return(C_SCHEME_FALSE);"
151    "} else {"
152    "    return(make_string_with_len(res, size));"
153    "}"))
154
155(define (tc-hdb-get hdb key)
156  (%tc-hdb-get hdb key (string-length key)))
157
158(define tc-hdb-iter-init
159  (foreign-lambda* bool ((c-pointer hdb))
160    "return(tchdbiterinit((TCHDB*) hdb));"))
161
162(define tc-hdb-iter-next
163  (foreign-lambda* c-string ((c-pointer hdb))
164    "return(tchdbiternext2((TCHDB*) hdb));"))
165
166(define (tc-hdb-fold hdb kons knil)
167  (tc-hdb-iter-init hdb)
168  (let lp ((acc knil))
169    (let ((key (tc-hdb-iter-next hdb)))
170      (if (not key)
171          acc
172          (let ((val (tc-hdb-get hdb key)))
173            (lp (kons key val acc)))))))
174
175(define-external (make_string_with_len (c-pointer ptr) (int len)) scheme-object
176  (and ptr
177       (let ((str (make-string len)))
178         (##core#inline "copy_string_result" ptr len str)
179         str)))
Note: See TracBrowser for help on using the repository browser.