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

Last change on this file since 13486 was 13486, checked in by Jim Ursetto, 12 years ago

tokyocabinet: free() value even when too long for string

File size: 5.7 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(require-extension lolevel) ; free
22
23(declare
24  (foreign-declare "
25
26#include <tcutil.h>
27#include <tchdb.h>
28#include <stdlib.h>
29#include <stdbool.h>
30#include <stdint.h>
31
32#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)
33
34"))
35
36;; tc-hdb-tune flags
37(define-foreign-variable +max-string-length+ int "C_HEADER_SIZE_MASK")
38(define-foreign-variable HDBTLARGE int "HDBTLARGE")
39(define-foreign-variable HDBTDEFLATE int "HDBTDEFLATE")
40(define-foreign-variable HDBTBZIP int "HDBTBZIP")
41(define-foreign-variable HDBTTCBS int "HDBTTCBS")
42
43(define TC_HDBTLARGE HDBTLARGE)
44(define TC_HDBTDEFLATE HDBTDEFLATE)
45(define TC_HDBTBZIP HDBTBZIP)
46(define TC_HDBTTCBS HDBTTCBS)
47
48;; tc-hdb-open flags
49(define-foreign-variable HDBOWRITER int "HDBOWRITER")
50(define-foreign-variable HDBOREADER int "HDBOREADER")
51(define-foreign-variable HDBOCREAT int "HDBOCREAT")
52(define-foreign-variable HDBOTRUNC int "HDBOTRUNC")
53(define-foreign-variable HDBONOLCK int "HDBONOLCK")
54(define-foreign-variable HDBOLCKNB int "HDBOLCKNB")
55
56(define TC_HDBOWRITER HDBOWRITER)
57(define TC_HDBOREADER HDBOREADER)
58(define TC_HDBOCREAT HDBOCREAT)
59(define TC_HDBOTRUNC HDBOTRUNC)
60(define TC_HDBONOLCK HDBONOLCK)
61(define TC_HDBOLCKNB HDBOLCKNB)
62
63(define %tc-hdb-new (foreign-lambda c-pointer "tchdbnew"))
64
65(define %tc-hdb-del
66  (foreign-lambda* void ((c-pointer hdb))
67    "tchdbdel((TCHDB*) hdb);"))
68
69(define %tc-hdb-set-mutex!
70  (foreign-lambda* bool ((c-pointer hdb))
71    "return(tchdbsetmutex((TCHDB*) hdb));"))
72
73(define %tc-hdb-set-cache!
74  (foreign-lambda* bool ((c-pointer hdb) (int rcnum))
75    "return(tchdbsetcache((TCHDB*) hdb, rcnum));"))
76
77(define %tc-hdb-set-xmsiz!
78  (foreign-lambda* bool ((c-pointer hdb) (int xmsiz))
79    "return(tchdbsetxmsiz((TCHDB*) hdb, xmsiz));"))
80
81(define %tc-hdb-tune!
82  (foreign-lambda* bool ((c-pointer hdb)
83                         (int bnum) (int apow) (int fpow) (int opts))
84    "return(tchdbtune((TCHDB*) hdb, bnum, apow, fpow, opts));"))
85
86(define %tc-hdb-open
87  (foreign-lambda* bool ((c-pointer hdb) (c-string file) (int flags))
88    "return(tchdbopen(hdb, file, flags));"))
89
90(define (tc-hdb-open file
91                     #!key
92                     (flags (fx+ HDBOWRITER (fx+ HDBOREADER HDBOCREAT)))
93                     (mutex? #f)
94                     (num-buckets #f)
95                     (record-alignment #f)
96                     (num-free-blocks #f)
97                     (tune-opts #f)
98                     (cache-limit #f)
99                     (mmap-size #f))
100  (let ((hdb (%tc-hdb-new)))
101    (and hdb
102         ;; make sure all the specified keyword settings succeed, and
103         ;; return the hdb c-pointer
104         (or (and
105              (or (not mutex?) (%tc-hdb-set-mutex! hdb))
106              (or (not cache-limit) (%tc-hdb-set-cache! hdb cache-limit))
107              (or (not mmap-size) (%tc-hdb-set-xmsiz! hdb mmap-size))
108              (or (not (or num-buckets record-alignment num-free-blocks
109                           tune-opts))
110                  (%tc-hdb-tune! hdb
111                                 (or num-buckets 0)
112                                 (or record-alignment -1)
113                                 (or num-free-blocks -1)
114                                 (or tune-opts 0)))
115              (%tc-hdb-open hdb file flags)
116              hdb)
117             (begin
118               ;; clean up and return #f if any of the functions failed
119               (%tc-hdb-del hdb)
120               #f)))))
121
122(define tc-hdb-close
123  (foreign-lambda* bool ((c-pointer hdb))
124    "if (tchdbclose((TCHDB*) hdb)) {"
125    "    tchdbdel((TCHDB*) hdb);"
126    "    return(1);"
127    "} else {"
128    "    return(0);"
129    "}"))
130
131(define %tc-hdb-put!
132  (foreign-lambda* bool ((c-pointer hdb)
133                         (pointer kptr) (int ksize)
134                         (pointer vptr) (int vsize))
135    "return(tchdbput((TCHDB*) hdb, kptr, ksize, vptr, vsize));"))
136
137(define (tc-hdb-put! hdb key value)
138  (%tc-hdb-put! hdb key (string-length key) value (string-length value)))
139
140(define %tc-hdb-delete!
141  (foreign-lambda* bool ((c-pointer hdb) (pointer kptr) (int ksize))
142    "return(tchdbout((TCHDB*) hdb, kptr, ksize));"))
143
144(define (tc-hdb-delete! hdb key)
145  (%tc-hdb-delete! hdb key (string-length key)))
146
147(define (tc-hdb-get hdb key)
148  (define tchdbget
149    (foreign-lambda c-pointer "tchdbget"
150                    c-pointer scheme-pointer int (c-pointer int)))
151  (let-location ((size int))
152    (and-let* ((valptr (tchdbget hdb key
153                                 (string-length key) (location size))))
154      ;; Exception handling imposes an unacceptable overhead.
155      (when (fx> size +max-string-length+)
156        (free valptr)
157        (error 'tc-hdb-get "value length too long" size))
158      (let ((val (make-string size)))
159        (##core#inline "copy_string_result" valptr size val)
160        (free valptr)
161        val))))
162
163(define tc-hdb-iter-init
164  (foreign-lambda* bool ((c-pointer hdb))
165    "return(tchdbiterinit((TCHDB*) hdb));"))
166
167(define tc-hdb-iter-next
168  (foreign-lambda* c-string ((c-pointer hdb))
169    "return(tchdbiternext2((TCHDB*) hdb));"))
170
171(define (tc-hdb-fold hdb kons knil)
172  (tc-hdb-iter-init hdb)
173  (let lp ((acc knil))
174    (let ((key (tc-hdb-iter-next hdb)))
175      (if (not key)
176          acc
177          (let ((val (tc-hdb-get hdb key)))
178            (lp (kons key val acc)))))))
Note: See TracBrowser for help on using the repository browser.