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))) |
---|