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

Last change on this file since 13496 was 13496, checked in by Jim Ursetto, 11 years ago

tokyocabinet: expand HDB API, avoid segfaults

File size: 5.4 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  tc-hdb-sync tc-hdb-vanish tc-hdb-copy
20  tc-hdb-path
21  tc-hdb-transaction-begin tc-hdb-transaction-commit tc-hdb-transaction-abort
22  tc-hdb-record-count tc-hdb-file-size
23  ))
24
25(require-extension lolevel) ; free
26
27(declare
28  (foreign-declare "
29
30#include <tcutil.h>
31#include <tchdb.h>
32#include <stdlib.h>
33#include <stdbool.h>
34#include <stdint.h>
35
36#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)
37
38"))
39
40;;; Hash table API
41
42;; tc-hdb-tune flags
43(define-foreign-variable +max-string-length+ int "C_HEADER_SIZE_MASK")
44(define-foreign-variable HDBTLARGE int "HDBTLARGE")
45(define-foreign-variable HDBTDEFLATE int "HDBTDEFLATE")
46(define-foreign-variable HDBTBZIP int "HDBTBZIP")
47(define-foreign-variable HDBTTCBS int "HDBTTCBS")
48
49(define TC_HDBTLARGE HDBTLARGE)
50(define TC_HDBTDEFLATE HDBTDEFLATE)
51(define TC_HDBTBZIP HDBTBZIP)
52(define TC_HDBTTCBS HDBTTCBS)
53
54;; tc-hdb-open flags
55(define-foreign-variable HDBOWRITER int "HDBOWRITER")
56(define-foreign-variable HDBOREADER int "HDBOREADER")
57(define-foreign-variable HDBOCREAT int "HDBOCREAT")
58(define-foreign-variable HDBOTRUNC int "HDBOTRUNC")
59(define-foreign-variable HDBONOLCK int "HDBONOLCK")
60(define-foreign-variable HDBOLCKNB int "HDBOLCKNB")
61
62(define TC_HDBOWRITER HDBOWRITER)
63(define TC_HDBOREADER HDBOREADER)
64(define TC_HDBOCREAT HDBOCREAT)
65(define TC_HDBOTRUNC HDBOTRUNC)
66(define TC_HDBONOLCK HDBONOLCK)
67(define TC_HDBOLCKNB HDBOLCKNB)
68
69(define-record tc-hdb ptr path)
70(define-record-printer (tc-hdb hdb port)
71  (fprintf port "#<tc-hdb ~A on ~S>"
72           (or (tc-hdb-ptr hdb) "(closed)")
73           (tc-hdb-path hdb)))
74
75(define-foreign-type hdb
76  (nonnull-c-pointer "TCHDB")
77  ; tc-hdb-ptr
78  )
79
80#>? #include "tcapi.h" <#
81
82(define (tc-hdb-open file
83                     #!key
84                     (flags (fx+ HDBOWRITER (fx+ HDBOREADER HDBOCREAT)))
85                     (mutex? #f)
86                     (num-buckets #f)
87                     (record-alignment #f)
88                     (num-free-blocks #f)
89                     (tune-opts #f)
90                     (cache-limit #f)
91                     (mmap-size #f))
92  (let ((hdb (make-tc-hdb (%tc-hdb-new) file)))
93    (and (tc-hdb-ptr hdb)
94         ;; make sure all the specified keyword settings succeed, and
95         ;; return the hdb record
96         (or (and
97              (or (not mutex?) (%tc-hdb-setmutex hdb))
98              (or (not cache-limit) (%tc-hdb-setcache hdb cache-limit))
99              (or (not mmap-size) (%tc-hdb-setxmsiz hdb mmap-size))
100              (or (not (or num-buckets record-alignment num-free-blocks
101                           tune-opts))
102                  (%tc-hdb-tune hdb
103                                (or num-buckets 0)
104                                (or record-alignment -1)
105                                (or num-free-blocks -1)
106                                (or tune-opts 0)))
107              (%tc-hdb-open hdb file flags)
108              hdb)
109             (begin
110               ;; clean up and return #f if any of the functions failed
111               (%tc-hdb-del hdb)
112               #f)))))
113
114(define (tc-hdb-close hdb)
115  (and (%tc-hdb-close hdb)
116       (begin (%tc-hdb-del hdb)
117              (tc-hdb-ptr-set! hdb #f) ; prevent further use
118              #t)))
119
120(define (tc-hdb-put! hdb key value)
121  (%tc-hdb-put hdb key (string-length key)
122               value (string-length value)))
123
124(define (tc-hdb-delete! hdb key)
125  (%tc-hdb-out hdb key (string-length key)))
126
127(define (tc-hdb-get hdb key)
128  (let-location ((size int))
129    (and-let* ((ptr (%tc-hdb-get hdb key
130                                 (string-length key) (location size))))
131      (sized-c-string* ptr size 'tc-hdb-get))))
132
133;; Copy size bytes from ptr into new string and free ptr.
134;; Like c-string* return type but does not use null terminator.
135;; Note: Exception handling imposes an unacceptable overhead.
136(define (sized-c-string* ptr size #!optional (where 'sized-c-string*))
137  (when (> size +max-string-length+)
138    (free ptr)
139    (error where "string length too long" size))
140  (let ((val (make-string size)))
141    (##core#inline "copy_string_result" ptr size val)
142    (free ptr)
143    val))
144
145(define tc-hdb-iter-init %tc-hdb-iterinit)
146(define (tc-hdb-iter-next hdb)
147  (let-location ((size int))
148    (and-let* ((ptr (%tc-hdb-iternext hdb #$size)))
149      (sized-c-string* ptr size 'tc-hdb-iter-next))))
150
151(define (tc-hdb-fold hdb kons knil)
152  (tc-hdb-iter-init hdb)
153  (let lp ((acc knil))
154    (let ((key (tc-hdb-iter-next hdb)))
155      (if (not key)
156          acc
157          (let ((val (tc-hdb-get hdb key)))
158            (lp (kons key val acc)))))))
159
160(define tc-hdb-sync %tc-hdb-sync)
161(define tc-hdb-vanish %tc-hdb-vanish)
162(define tc-hdb-copy %tc-hdb-copy)
163(define tc-hdb-transaction-begin  %tc-hdb-tranbegin)
164(define tc-hdb-transaction-commit %tc-hdb-trancommit)
165(define tc-hdb-transaction-abort  %tc-hdb-tranabort)
166(define tc-hdb-record-count %tc-hdb-rnum)
167(define tc-hdb-file-size %tc-hdb-fsiz)
168
169;;; B+-tree API
170
Note: See TracBrowser for help on using the repository browser.