├── .gitignore ├── kyoto-cabinet.swig ├── README ├── cl-kyoto-cabinet-package.lisp ├── cl-kyoto-cabinet.asd ├── LICENSE ├── kyoto-cabinet-dbm.lisp ├── kyoto-cabinet-ffi.lisp └── kyoto-cabinet.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | -------------------------------------------------------------------------------- /kyoto-cabinet.swig: -------------------------------------------------------------------------------- 1 | %module kc 2 | 3 | %include "/usr/local/include/kclangc.h" 4 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | (in-package :kyoto-cabinet) 2 | (defparameter *db* (make-instance 'kc-dbm)) 3 | (dbm-open *db* "/tmp/hello.kch" :create :write) 4 | 5 | (dbm-put *db* "Ilya" "Sterin" :mode :keep) 6 | (dbm-get *db* "Ilya") 7 | (dbm-remove *db* "Ilya") 8 | 9 | (dbm-put *db* 123 "456" :mode :keep) 10 | (dbm-get *db* 123) 11 | (dbm-remove *db* 123) 12 | 13 | (defparameter *iter* (iter-open *db*)) 14 | (iter-first *iter*) 15 | (multiple-value-bind (key val) (iter-item *iter*) (list key val)) 16 | (iter-next *iter*) 17 | 18 | (dbm-put *db* 123 (make-array 2 :initial-contents '(75 76) :element-type '(unsigned-byte 8)) :mode :replace) 19 | (dbm-put *db* 123 (make-octet-vector 100 101) :mode :replace) 20 | 21 | (multiple-value-bind (key val) (iter-item *iter* :key-type :integer) (list key val)) -------------------------------------------------------------------------------- /cl-kyoto-cabinet-package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:kyoto-cabinet-ffi 2 | (:use #:common-lisp #:cffi) 3 | (:export :kcdbnew 4 | :kcdbopen 5 | :kcdbecode 6 | :kcdbemsg 7 | :kcdbdel 8 | :kcdbclose 9 | :kcdbclear 10 | :kcdbbegintran 11 | :kcdbendtran 12 | :kcdbset 13 | :kcdbadd 14 | :kcdbappend 15 | :kcdbget 16 | :kcdbremove 17 | 18 | :kcdbcursor 19 | :kccurdel 20 | :kccurjump 21 | :kccurstep 22 | :kccurget 23 | :kccurgetvalue 24 | :kccurgetkey 25 | :kccurdb 26 | :kccurjumpkey 27 | :kccurremove 28 | 29 | :kcfree 30 | :kcmalloc 31 | 32 | :dbm-open-flags 33 | :dbm-return-values) 34 | 35 | (:documentation "CFFI interface to Kyoto Cabinet functions. The 36 | original C function names are preserved.")) 37 | 38 | (defpackage #:kyoto-cabinet 39 | (:use #:common-lisp #:cffi #:kyoto-cabinet-ffi) 40 | (:nicknames #:kc) 41 | (:export 42 | ;; Classes 43 | #:kc-dbm 44 | 45 | ;; Specials 46 | #:*in-transaction-p* 47 | 48 | ;; Generics 49 | #:dbm-open 50 | #:dbm-close 51 | #:dbm-begin 52 | #:dbm-commit 53 | #:dbm-rollback 54 | #:dbm-delete 55 | #:dbm-put 56 | #:dbm-get 57 | #:dbm-remove 58 | #:dbm-put-fast 59 | #:dbm-get-fast 60 | #:dbm-remove-fast 61 | #:iter-open 62 | #:iter-first 63 | #:iter-last 64 | #:iter-prev 65 | #:iter-next 66 | #:iter-go-to 67 | #:iter-put 68 | #:iter-remove 69 | #:iter-key 70 | #:iter-value 71 | #:iter-get 72 | #:iter-close 73 | #:iter-item 74 | #:iter-put-fast 75 | #:iter-key-fast 76 | #:iter-value-fast 77 | #:iter-go-to-fast 78 | #:iter-item-fast 79 | 80 | #:dbm-num-records 81 | #:dbm-file-size 82 | #:dbm-optimize 83 | #:dbm-cache 84 | #:dbm-xmsize 85 | #:set-comparator 86 | 87 | ;; Macros 88 | #:with-database 89 | #:with-transaction 90 | #:with-iterator) 91 | (:documentation "A Lisp-style abstract interface to Kyoto 92 | Cabinet. The original C function names are not preserved (see 93 | the :kyoto-cabinet-ffi package for functions that do preserve the 94 | nomenclature).")) 95 | 96 | -------------------------------------------------------------------------------- /cl-kyoto-cabinet.asd: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Copyright (c) 2010, Kevin Raison. 3 | ;;; 4 | ;;; All rights reserved. 5 | ;;; 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | ;;; 10 | ;;; * Redistributions of source code must retain the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer. 13 | ;;; 14 | ;;; * Redistributions in binary form must reproduce the above 15 | ;;; copyright notice, this list of conditions and the following 16 | ;;; disclaimer in the documentation and/or other materials 17 | ;;; provided with the distribution. 18 | ;;; 19 | ;;; * Neither the names of the copyright holders nor the names of 20 | ;;; its contributors may be used to endorse or promote products 21 | ;;; derived from this software without specific prior written 22 | ;;; permission. 23 | ;;; 24 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 25 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 26 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 27 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 28 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS 29 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 30 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 31 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 32 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 33 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR 34 | ;;; TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF 35 | ;;; THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 36 | ;;; SUCH DAMAGE. 37 | ;;; 38 | 39 | (defpackage :cl-kyoto-cabinet-system (:use :cl :asdf)) 40 | (in-package :cl-kyoto-cabinet-system) 41 | 42 | (defsystem cl-kyoto-cabinet 43 | :name "Common Lisp Kyoto Cabinet Interface" 44 | :version "0.1" 45 | :author "Kevin Raison " 46 | :licence "New BSD" 47 | :depends-on ((:version :cffi "0.10.3")) 48 | :components ((:file "cl-kyoto-cabinet-package") 49 | (:file "kyoto-cabinet-ffi" 50 | :depends-on ("cl-kyoto-cabinet-package")) 51 | (:file "kyoto-cabinet" 52 | :depends-on ("cl-kyoto-cabinet-package" "kyoto-cabinet-ffi")) 53 | (:file "kyoto-cabinet-dbm" 54 | :depends-on ("cl-kyoto-cabinet-package" "kyoto-cabinet" "kyoto-cabinet-ffi")) 55 | )) 56 | 57 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010, Kevin Raison & Ilya Sterin. 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | * Redistributions of source code must retain the above 10 | copyright notice, this list of conditions and the following 11 | disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above 14 | copyright notice, this list of conditions and the following 15 | disclaimer in the documentation and/or other materials 16 | provided with the distribution. 17 | 18 | * Neither the names of the copyright holders nor the names of 19 | its contributors may be used to endorse or promote products 20 | derived from this software without specific prior written 21 | permission. 22 | 23 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 24 | CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 25 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 26 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 27 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS 28 | BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 29 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 30 | TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 31 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 32 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR 33 | TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF 34 | THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 35 | SUCH DAMAGE. 36 | 37 | 38 | Portions of the code are from Keith James' cl-tokyo-cabinet and are covered by this license: 39 | 40 | ;;; 41 | ;;; Copyright (c) 2008-2010, Keith James. 42 | ;;; 43 | ;;; All rights reserved. 44 | ;;; 45 | ;;; Redistribution and use in source and binary forms, with or without 46 | ;;; modification, are permitted provided that the following conditions 47 | ;;; are met: 48 | ;;; 49 | ;;; * Redistributions of source code must retain the above 50 | ;;; copyright notice, this list of conditions and the following 51 | ;;; disclaimer. 52 | ;;; 53 | ;;; * Redistributions in binary form must reproduce the above 54 | ;;; copyright notice, this list of conditions and the following 55 | ;;; disclaimer in the documentation and/or other materials 56 | ;;; provided with the distribution. 57 | ;;; 58 | ;;; * Neither the names of the copyright holders nor the names of 59 | ;;; its contributors may be used to endorse or promote products 60 | ;;; derived from this software without specific prior written 61 | ;;; permission. 62 | ;;; 63 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 64 | ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 65 | ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 66 | ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 67 | ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS 68 | ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 69 | ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 70 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 71 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 72 | ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR 73 | ;;; TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF 74 | ;;; THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 75 | ;;; SUCH DAMAGE. 76 | ;;; 77 | -------------------------------------------------------------------------------- /kyoto-cabinet-dbm.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:kyoto-cabinet) 2 | 3 | (defmethod initialize-instance :after ((db kc-dbm) &key instance) 4 | (with-slots (ptr) db 5 | (if (null instance) 6 | (setf ptr (kcdbnew)) 7 | (setf ptr instance)))) 8 | 9 | (defmethod initialize-instance :after ((iter kc-iterator) &key) 10 | (with-slots (ptr) iter 11 | (setf ptr iter))) 12 | 13 | 14 | (defmethod raise-error ((db kc-dbm) &optional (message "") 15 | &rest message-arguments) 16 | (let* ((code (kcdbecode (ptr-of db))) 17 | (msg (kcdbemsg (ptr-of db)))) 18 | (error 'dbm-error :error-code code :error-msg msg 19 | :text (apply #'format nil message message-arguments)))) 20 | 21 | 22 | (defmethod raise-error ((iter kc-iterator) &optional (message "") 23 | &rest message-arguments) 24 | (raise-error (make-instance 'kc-dbm :instance (kccurdb (ptr-of iter))) message message-arguments)) 25 | 26 | (defmethod maybe-raise-error ((db kc-dbm) &optional message 27 | &rest message-arguments) 28 | (let ((ecode (kcdbecode (ptr-of db)))) 29 | (maybe-raise-error-with-ecode db ecode message message-arguments))) 30 | 31 | (defmethod maybe-raise-error ((iter kc-iterator) &optional message 32 | &rest message-arguments) 33 | (let ((ecode (kcdbecode (kccurdb (ptr-of iter))))) 34 | (maybe-raise-error-with-ecode iter ecode message message-arguments))) 35 | 36 | (defun maybe-raise-error-with-ecode (what ecode &optional message 37 | &rest message-arguments) 38 | (cond ((= (foreign-enum-value 'dbm-return-values :success) 39 | ecode) 40 | t) 41 | ((= (foreign-enum-value 'dbm-return-values :norec) 42 | ecode) 43 | nil) 44 | ((= (foreign-enum-value 'dbm-return-values :duprec) 45 | ecode) 46 | nil) 47 | (t 48 | (apply #'raise-error what message message-arguments)))) 49 | 50 | (defmethod dbm-open ((db kc-dbm) filename &rest mode) 51 | (let ((db-ptr (ptr-of db))) 52 | (check-open-mode mode) 53 | (unless (kcdbopen db-ptr filename mode) ; opens db by side-effect 54 | (let* ((code (kcdbecode db-ptr)) 55 | (msg (kcdbemsg db-ptr))) 56 | (kcdbdel db-ptr) ; clean up on error 57 | (error 'dbm-error :error-code code :error-msg msg)))) 58 | db) 59 | 60 | (defmethod dbm-close ((db kc-dbm)) 61 | (kcdbclose (ptr-of db))) 62 | 63 | (defmethod dbm-delete ((db kc-dbm)) 64 | (kcdbdel (ptr-of db))) 65 | 66 | (defmethod dbm-clear ((db kc-dbm)) 67 | (kcdbclear (ptr-of db))) 68 | 69 | (defmethod dbm-begin ((db kc-dbm) &rest hard) 70 | (kcdbbegintran (ptr-of db) hard)) 71 | 72 | (defmethod dbm-commit ((db kc-dbm)) 73 | (kcdbendtran (ptr-of db) T)) 74 | 75 | (defmethod dbm-rollback ((db kc-dbm)) 76 | (kcdbendtran (ptr-of db) NIL)) 77 | 78 | 79 | ;; Define overloaded put methods 80 | 81 | (defmethod dbm-put ((db kc-dbm) (key string) (value string) &key (mode :replace)) 82 | (let ((func (put-method-for mode))) 83 | (put-string->string db key value func))) 84 | 85 | (defmethod dbm-put ((db kc-dbm) (key string) (value vector) &key (mode :replace)) 86 | (let ((func (put-method-for mode))) 87 | (put-string->octets db key value func))) 88 | 89 | (defmethod dbm-put ((db kc-dbm) (key vector) (value vector) &key (mode :replace)) 90 | (let ((func (put-method-for mode))) 91 | (put-octets->octets db key value func))) 92 | 93 | (defmethod dbm-put ((db kc-dbm) (key integer) (value string) &key (mode :replace)) 94 | (let ((func (put-method-for mode))) 95 | (put-int32->string db key value func))) 96 | 97 | (defmethod dbm-put ((db kc-dbm) (key integer) (value vector) &key (mode :replace)) 98 | (let ((func (put-method-for mode))) 99 | (put-int32->octets db key value func))) 100 | 101 | (defun dbm-put-fast (db key key-len value value-len &key (mode :replace)) 102 | (let ((func (put-method-for mode))) 103 | (put-pointer->pointer db key key-len value value-len func))) 104 | 105 | 106 | ;; Define overloaded get methods 107 | 108 | (defmethod dbm-get ((db kc-dbm) (key string) &optional (type :string)) 109 | (let ((fn #'kcdbget)) 110 | (ecase type 111 | (:string (get-string->string db key fn)) 112 | (:octets (get-string->octets db key fn))))) 113 | 114 | (defmethod dbm-get ((db kc-dbm) (key integer) &optional (type :string)) 115 | (let ((fn #'kcdbget)) 116 | (ecase type 117 | (:string (get-int32->string db key fn)) 118 | (:octets (get-int32->octets db key fn))))) 119 | 120 | (defmethod dbm-get ((db kc-dbm) (key vector) &optional (type :string)) 121 | (let ((fn #'kcdbget)) 122 | (ecase type 123 | (:string (get-octets->string db key fn)) 124 | (:octets (get-octets->octets db key fn))))) 125 | 126 | (defun dbm-get-fast (db key key-len) 127 | (get-pointer->pointer db key key-len #'kcdbget)) 128 | 129 | 130 | ;; Define overloaded remove methods 131 | 132 | (defmethod dbm-remove ((db kc-dbm) (key string)) 133 | (rem-string->value db key)) 134 | 135 | (defmethod dbm-remove ((db kc-dbm) (key integer)) 136 | (rem-int32->value db key)) 137 | 138 | (defmethod dbm-remove ((db kc-dbm) (key vector)) 139 | (rem-octets->value db key)) 140 | 141 | (defun dbm-remove-fast (db key key-len) 142 | (rem-pointer->value db key key-len)) 143 | 144 | ;; Define iterator methods below 145 | 146 | (defmethod iter-open ((db kc-dbm)) 147 | (let ((iterator (make-instance 'kc-iterator))) 148 | (with-slots ((iter-ptr ptr)) iterator 149 | (with-slots ((db-ptr ptr)) db 150 | (setf iter-ptr (kcdbcursor db-ptr)))) 151 | iterator)) 152 | 153 | (defmethod iter-close ((iter kc-iterator)) 154 | (kccurdel (ptr-of iter))) 155 | 156 | (defmethod iter-item ((iter kc-iterator) &key (key-type :string) (value-type :string)) 157 | (let* ((key-size (foreign-alloc :pointer)) 158 | (key-ptr (foreign-alloc :pointer)) 159 | (value-size (foreign-alloc :pointer)) 160 | (value-ptr (foreign-alloc :pointer)) 161 | (key-ptr (kccurget (ptr-of iter) key-size value-ptr value-size NIL)) 162 | (key (convert-to-lisp key-type key-ptr key-size)) 163 | (value (convert-to-lisp value-type (mem-ref value-ptr :pointer) value-size))) 164 | (foreign-free key-size) 165 | (foreign-free key-ptr) 166 | (foreign-free value-size) 167 | (foreign-free value-ptr) 168 | (if (null key) 169 | (progn 170 | (maybe-raise-error iter) 171 | ()) 172 | (values key value)))) 173 | 174 | (defmethod iter-item-fast ((iter kc-iterator)) 175 | (let* ((key-size (foreign-alloc :unsigned-int)) 176 | (value-size (foreign-alloc :unsigned-int)) 177 | (value-ptr (foreign-alloc :pointer)) 178 | (key-ptr (kccurget (ptr-of iter) key-size value-ptr value-size nil))) 179 | (values key-ptr key-size value-ptr value-size))) 180 | 181 | (defmethod iter-key ((iter kc-iterator) &optional (type :string)) 182 | (get-something iter 'kccurgetkey type)) 183 | 184 | (defmethod iter-key-fast ((iter kc-iterator) &optional type) 185 | (declare (ignore type)) 186 | (get-pointer iter 'kccurgetkey)) 187 | 188 | (defmethod iter-value ((iter kc-iterator) &optional (type :string)) 189 | (get-something iter 'kccurgetvalue type)) 190 | 191 | (defmethod iter-value-fast ((iter kc-iterator) &optional type) 192 | (declare (ignore type)) 193 | (get-pointer iter 'kccurgetvalue)) 194 | 195 | (defmethod iter-first ((iter kc-iterator)) 196 | (kccurjump (ptr-of iter))) 197 | 198 | (defmethod iter-next ((iter kc-iterator)) 199 | (kccurstep (ptr-of iter))) 200 | 201 | (defmethod iter-go-to ((iter kc-iterator) (key string)) 202 | (with-foreign-string ((key-ptr key-len) key :null-terminated-p nil) 203 | (kccurjumpkey (ptr-of iter) key-ptr key-len))) 204 | 205 | (defmethod iter-go-to ((iter kc-iterator) (key integer)) 206 | (with-foreign-object (key-ptr :int32) 207 | (setf (mem-ref key-ptr :int32) key) 208 | (kccurjumpkey (ptr-of iter) key-ptr (foreign-type-size :int32)))) 209 | 210 | (defmethod iter-go-to ((iter kc-iterator) (key vector)) 211 | (let ((key-len (length key))) 212 | (with-foreign-objects ((key-ptr :unsigned-char key-len)) 213 | (loop for i from 0 below key-len 214 | do (setf (mem-aref key-ptr :unsigned-char i) (aref key i))) 215 | (kccurjumpkey (ptr-of iter) key-ptr key-len)))) 216 | 217 | (defmethod iter-go-to-fast ((iter kc-iterator) key-ptr key-len) 218 | (kccurjumpkey (ptr-of iter) key-ptr key-len)) 219 | 220 | (defmethod iter-remove ((iter kc-iterator)) 221 | (kccurremove (ptr-of iter))) 222 | 223 | -------------------------------------------------------------------------------- /kyoto-cabinet-ffi.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:kyoto-cabinet-ffi) 2 | 3 | ;;; This file was automatically generated by SWIG (http://www.swig.org). 4 | ;;; Version 1.3.40 5 | ;;; 6 | ;;; Do not make changes to this file unless you know what you are doing--modify 7 | ;;; the SWIG interface file instead. 8 | 9 | 10 | ;;;SWIG wrapper code starts here 11 | 12 | (cl:defmacro defanonenum (&body enums) 13 | "Converts anonymous enums to defconstants." 14 | `(cl:progn ,@(cl:loop for value in enums 15 | for index = 0 then (cl:1+ index) 16 | when (cl:listp value) do (cl:setf index (cl:second value) 17 | value (cl:first value)) 18 | collect `(cl:defconstant ,value ,index)))) 19 | 20 | (cl:eval-when (:compile-toplevel :load-toplevel) 21 | (cl:unless (cl:fboundp 'swig-lispify) 22 | (cl:defun swig-lispify (name flag cl:&optional (package cl:*package*)) 23 | (cl:labels ((helper (lst last rest cl:&aux (c (cl:car lst))) 24 | (cl:cond 25 | ((cl:null lst) 26 | rest) 27 | ((cl:upper-case-p c) 28 | (helper (cl:cdr lst) 'upper 29 | (cl:case last 30 | ((lower digit) (cl:list* c #\- rest)) 31 | (cl:t (cl:cons c rest))))) 32 | ((cl:lower-case-p c) 33 | (helper (cl:cdr lst) 'lower (cl:cons (cl:char-upcase c) rest))) 34 | ((cl:digit-char-p c) 35 | (helper (cl:cdr lst) 'digit 36 | (cl:case last 37 | ((upper lower) (cl:list* c #\- rest)) 38 | (cl:t (cl:cons c rest))))) 39 | ((cl:char-equal c #\_) 40 | (helper (cl:cdr lst) '_ (cl:cons #\- rest))) 41 | (cl:t 42 | (cl:error "Invalid character: ~A" c))))) 43 | (cl:let ((fix (cl:case flag 44 | ((constant enumvalue) "+") 45 | (variable "*") 46 | (cl:t "")))) 47 | (cl:intern 48 | (cl:concatenate 49 | 'cl:string 50 | fix 51 | (cl:nreverse (helper (cl:concatenate 'cl:list name) cl:nil cl:nil)) 52 | fix) 53 | package)))))) 54 | 55 | ;;;SWIG wrapper code ends here 56 | 57 | (define-foreign-library libkc 58 | (t (:default "libkyotocabinet"))) 59 | 60 | (use-foreign-library libkc) 61 | 62 | (cffi:defcunion KCDB 63 | (db :pointer)) 64 | 65 | (defcenum dbm-return-values 66 | :success 67 | :noimpl 68 | :invalid 69 | :nofile 70 | :noperm 71 | :broken 72 | :duprec 73 | :norec 74 | :logic 75 | :system 76 | (:kcemisc #.15)) 77 | 78 | (defbitfield dbm-open-flags 79 | :read 80 | :write 81 | :create 82 | :truncate 83 | :autotran 84 | :autosync 85 | :nolock 86 | :trylock 87 | :norepair) 88 | 89 | (cffi:defcvar ("KCVERSION" KCVERSION) 90 | :string) 91 | 92 | (cffi:defcvar ("KCVISNOP" KCVISNOP) 93 | :string) 94 | 95 | (cffi:defcvar ("KCVISREMOVE" KCVISREMOVE) 96 | :string) 97 | 98 | (cffi:defcunion KCCUR 99 | (cur :pointer)) 100 | 101 | (cffi:defcfun ("kcmalloc" kcmalloc) :pointer 102 | (size :pointer)) 103 | 104 | (cffi:defcfun ("kcfree" kcfree) :void 105 | (ptr :pointer)) 106 | 107 | (cffi:defcfun ("kctime" kctime) :double) 108 | 109 | (cffi:defcfun ("kcatoi" kcatoi) :pointer 110 | (str :string)) 111 | 112 | (cffi:defcfun ("kcatoix" kcatoix) :pointer 113 | (str :string)) 114 | 115 | (cffi:defcfun ("kcatof" kcatof) :double 116 | (str :string)) 117 | 118 | (cffi:defcfun ("kchashmurmur" kchashmurmur) :pointer 119 | (buf :pointer) 120 | (size :pointer)) 121 | 122 | (cffi:defcfun ("kchashfnv" kchashfnv) :pointer 123 | (buf :pointer) 124 | (size :pointer)) 125 | 126 | (cffi:defcfun ("kcnan" kcnan) :double) 127 | 128 | (cffi:defcfun ("kcinf" kcinf) :double) 129 | 130 | (cffi:defcfun ("kcchknan" kcchknan) :pointer 131 | (num :double)) 132 | 133 | (cffi:defcfun ("kcchkinf" kcchkinf) :pointer 134 | (num :double)) 135 | 136 | (cffi:defcfun ("kcecodename" kcecodename) :string 137 | (code :pointer)) 138 | 139 | 140 | (cffi:defcfun ("kcdbnew" kcdbnew) :pointer) 141 | 142 | (cffi:defcfun ("kcdbopen" kcdbopen) :boolean 143 | (db :pointer) 144 | (path :string) 145 | (mode dbm-open-flags)) 146 | 147 | (cffi:defcfun ("kcdbdel" kcdbdel) :void 148 | (db :pointer)) 149 | 150 | (cffi:defcfun ("kcdbset" kcdbset) :boolean 151 | (db :pointer) 152 | (kbuf :pointer) 153 | (ksiz :uint32) 154 | (vbuf :pointer) 155 | (vsiz :uint32)) 156 | 157 | (cffi:defcfun ("kcdbadd" kcdbadd) :boolean 158 | (db :pointer) 159 | (kbuf :pointer) 160 | (ksiz :uint32) 161 | (vbuf :pointer) 162 | (vsiz :uint32)) 163 | 164 | (cffi:defcfun ("kcdbappend" kcdbappend) :boolean 165 | (db :pointer) 166 | (kbuf :pointer) 167 | (ksiz :uint32) 168 | (vbuf :pointer) 169 | (vsiz :uint32)) 170 | 171 | 172 | (cffi:defcfun ("kcdbget" kcdbget) :pointer 173 | (db :pointer) 174 | (kbuf :string) 175 | (ksiz :uint32) 176 | (sp :pointer)) 177 | 178 | 179 | (cffi:defcfun ("kcdbclose" kcdbclose) :pointer 180 | (db :pointer)) 181 | 182 | (cffi:defcfun ("kcdbecode" kcdbecode) :int 183 | (db :pointer)) 184 | 185 | (cffi:defcfun ("kcdbemsg" kcdbemsg) :string 186 | (db :pointer)) 187 | 188 | (cffi:defcfun ("kcdbaccept" kcdbaccept) :pointer 189 | (db :pointer) 190 | (kbuf :string) 191 | (ksiz :pointer) 192 | (fullproc :pointer) 193 | (emptyproc :pointer) 194 | (opq :pointer) 195 | (writable :pointer)) 196 | 197 | (cffi:defcfun ("kcdbiterate" kcdbiterate) :pointer 198 | (db :pointer) 199 | (fullproc :pointer) 200 | (opq :pointer) 201 | (writable :boolean)) 202 | 203 | 204 | (cffi:defcfun ("kcdbincrint" kcdbincrint) :pointer 205 | (db :pointer) 206 | (kbuf :string) 207 | (ksiz :pointer) 208 | (num :pointer)) 209 | 210 | (cffi:defcfun ("kcdbincrdouble" kcdbincrdouble) :double 211 | (db :pointer) 212 | (kbuf :string) 213 | (ksiz :pointer) 214 | (num :double)) 215 | 216 | (cffi:defcfun ("kcdbcas" kcdbcas) :pointer 217 | (db :pointer) 218 | (kbuf :string) 219 | (ksiz :pointer) 220 | (nvbuf :string) 221 | (nvsiz :pointer) 222 | (ovbuf :string) 223 | (ovsiz :pointer)) 224 | 225 | (cffi:defcfun ("kcdbremove" kcdbremove) :boolean 226 | (db :pointer) 227 | (kbuf :string) 228 | (ksiz :uint32)) 229 | 230 | (cffi:defcfun ("kcdbgetbuf" kcdbgetbuf) :pointer 231 | (db :pointer) 232 | (kbuf :string) 233 | (ksiz :pointer) 234 | (vbuf :string) 235 | (max :pointer)) 236 | 237 | (cffi:defcfun ("kcdbclear" kcdbclear) :boolean 238 | (db :pointer)) 239 | 240 | (cffi:defcfun ("kcdbsync" kcdbsync) :pointer 241 | (db :pointer) 242 | (hard :pointer) 243 | (proc :pointer) 244 | (opq :pointer)) 245 | 246 | (cffi:defcfun ("kcdbcopy" kcdbcopy) :pointer 247 | (db :pointer) 248 | (dest :string)) 249 | 250 | (cffi:defcfun ("kcdbbegintran" kcdbbegintran) :boolean 251 | (db :pointer) 252 | (hard :boolean)) 253 | 254 | (cffi:defcfun ("kcdbbegintrantry" kcdbbegintrantry) :boolean 255 | (db :pointer) 256 | (hard :boolean)) 257 | 258 | (cffi:defcfun ("kcdbendtran" kcdbendtran) :boolean 259 | (db :pointer) 260 | (commit :boolean)) 261 | 262 | (cffi:defcfun ("kcdbdumpsnap" kcdbdumpsnap) :pointer 263 | (db :pointer) 264 | (dest :string)) 265 | 266 | (cffi:defcfun ("kcdbloadsnap" kcdbloadsnap) :pointer 267 | (db :pointer) 268 | (src :string)) 269 | 270 | (cffi:defcfun ("kcdbcount" kcdbcount) :pointer 271 | (db :pointer)) 272 | 273 | (cffi:defcfun ("kcdbsize" kcdbsize) :pointer 274 | (db :pointer)) 275 | 276 | (cffi:defcfun ("kcdbpath" kcdbpath) :string 277 | (db :pointer)) 278 | 279 | (cffi:defcfun ("kcdbstatus" kcdbstatus) :string 280 | (db :pointer)) 281 | 282 | (cffi:defcfun ("kcdbcursor" kcdbcursor) :pointer 283 | (db :pointer)) 284 | 285 | (cffi:defcfun ("kccurdel" kccurdel) :void 286 | (cur :pointer)) 287 | 288 | (cffi:defcfun ("kccuraccept" kccuraccept) :pointer 289 | (cur :pointer) 290 | (fullproc :pointer) 291 | (opq :pointer) 292 | (writable :pointer) 293 | (step :pointer)) 294 | 295 | (cffi:defcfun ("kccursetvalue" kccursetvalue) :pointer 296 | (cur :pointer) 297 | (vbuf :string) 298 | (vsiz :pointer) 299 | (step :pointer)) 300 | 301 | (cffi:defcfun ("kccurremove" kccurremove) :boolean 302 | (cur :pointer)) 303 | 304 | (cffi:defcfun ("kccurgetkey" kccurgetkey) :pointer 305 | (cur :pointer) 306 | (sp :pointer) 307 | (step :boolean)) 308 | 309 | (cffi:defcfun ("kccurgetvalue" kccurgetvalue) :pointer 310 | (cur :pointer) 311 | (sp :pointer) 312 | (step :boolean)) 313 | 314 | (cffi:defcfun ("kccurget" kccurget) :pointer 315 | (cur :pointer) 316 | (ksp :pointer) 317 | (vbp :pointer) 318 | (vsp :pointer) 319 | (step :boolean)) 320 | 321 | (cffi:defcfun ("kccurjump" kccurjump) :boolean 322 | (cur :pointer)) 323 | 324 | (cffi:defcfun ("kccurjumpkey" kccurjumpkey) :boolean 325 | (cur :pointer) 326 | (kbuf :string) 327 | (ksiz :uint32)) 328 | 329 | (cffi:defcfun ("kccurstep" kccurstep) :boolean 330 | (cur :pointer)) 331 | 332 | (cffi:defcfun ("kccurdb" kccurdb) :pointer 333 | (cur :pointer)) 334 | 335 | (cffi:defcfun ("kccurecode" kccurecode) :pointer 336 | (cur :pointer)) 337 | 338 | (cffi:defcfun ("kccuremsg" kccuremsg) :string 339 | (cur :pointer)) 340 | 341 | -------------------------------------------------------------------------------- /kyoto-cabinet.lisp: -------------------------------------------------------------------------------- 1 | (in-package :kyoto-cabinet) 2 | 3 | (deftype int32 () 4 | "The 32bit built-in DBM key type." 5 | '(signed-byte 32)) 6 | 7 | (deftype int64 () 8 | "The 64bit built-in DBM key type." 9 | '(signed-byte 64)) 10 | 11 | (deftype octet () 12 | '(unsigned-byte 8)) 13 | 14 | (defparameter *in-transaction-p* nil 15 | "Bound when in a transaction.") 16 | 17 | 18 | (define-condition dbm-error (error) 19 | ((error-code :initform nil 20 | :initarg :error-code 21 | :reader error-code-of 22 | :documentation "The error code provided by KC.") 23 | (error-msg :initform nil 24 | :initarg :error-msg 25 | :reader error-msg-of 26 | :documentation "The error message provided by KC.") 27 | (text :initform nil 28 | 29 | :reader text 30 | :documentation "Any additional message provided by the CL API.")) 31 | (:report (lambda (condition stream) 32 | (format stream "DBM error (~a) ~a~@[: ~a~]." 33 | (error-code-of condition) 34 | (error-msg-of condition) 35 | (text condition))))) 36 | 37 | (defclass kc-dbm () 38 | ((ptr :initarg :ptr 39 | :accessor ptr-of 40 | :documentation "A pointer to a KC native database object.")) 41 | (:documentation "A KC database.")) 42 | 43 | (defclass kc-iterator () 44 | ((ptr :initarg :ptr 45 | :accessor ptr-of 46 | :documentation "A KC pointer.")) 47 | (:documentation "A KC database iterator, the superclass of both B+ 48 | tree cursors and hash iterators.")) 49 | 50 | 51 | 52 | (defgeneric raise-error (db &optional message &rest message-arguments) 53 | (:documentation "Raises a {define-condition dbm-error} with 54 | MESSAGE. MESSAGE may be a format template, in which case the rest of 55 | the arguments are taken to be format arguments for that template. The 56 | error code and TC error message are automatically obtained from the DB 57 | handle.")) 58 | 59 | (defgeneric maybe-raise-error (db &optional message &rest message-arguments) 60 | (:documentation "Checks the DB handle for any error reported by TC 61 | and raises a {define-condition dbm-error} if one has occurred by 62 | calling {defun raise-error} .")) 63 | 64 | 65 | 66 | (defgeneric dbm-open (db filespec &rest mode) 67 | (:documentation "Opens a new, or existing KC database. 68 | 69 | Arguments: 70 | 71 | - db (object): A KC dbm object. 72 | - filespec (string): A pathname designator for the database file. 73 | 74 | Rest: 75 | 76 | - mode (list symbol): A list of mode keywords used when opening the 77 | file. The modes are :KCOWRITER :KCOREADER :KCOCREATE :KCOTRUNCATE 78 | :KCOAUTOTRAN :KCOAUTOSYNC :KCONOLOCK :KCOTRYLOCK :KCONOREPAIR 79 | which correspond to those described in the KC specification. 80 | 81 | Returns: 82 | 83 | - The KC dbm object, now open.")) 84 | 85 | (defgeneric dbm-close (db) 86 | (:documentation "Closes an open KC database. 87 | 88 | Arguments: 89 | 90 | - db (object): A KC dbm object. 91 | 92 | Returns: 93 | 94 | - T on success, or NIL otherwise.")) 95 | 96 | (defgeneric dbm-delete (db) 97 | (:documentation "Deletes a KC database. If open, implicitly closes 98 | it first. 99 | 100 | Arguments: 101 | 102 | - db (object): A KC dbm object. 103 | 104 | Returns: 105 | 106 | - NIL .")) 107 | 108 | (defgeneric dbm-clear (db) 109 | (:documentation "Removes all records from DB.")) 110 | 111 | (defgeneric dbm-begin (db &rest hard) 112 | (:documentation "Begins a transaction with DB.")) 113 | 114 | (defgeneric dbm-commit (db) 115 | (:documentation "Commits a transaction with DB.")) 116 | 117 | (defgeneric dbm-rollback (db) 118 | (:documentation "Rolls back a transaction with DB.")) 119 | 120 | 121 | (defgeneric dbm-put (db key value &key mode) 122 | (:documentation "Inserts KEY and VALUE into DB. MODE varies with DB 123 | class. 124 | 125 | Arguments: 126 | 127 | - db (object): A KC database object. 128 | - key (object): A key under which to insert. 129 | - value (object): A value to insert under key. 130 | 131 | Key: 132 | 133 | - :mode (symbol): A symbol designating one of the KC insertion modes: 134 | replace, keep, concat, etc. 135 | 136 | Valid modes for B+ tree databases are: 137 | 138 | - :REPLACE : If a record with the same key exists in the database, it 139 | is overwritten. 140 | - :KEEP : If a record with the same key exists in the database, this 141 | function has no effect. 142 | - :CONCAT : Concatenates a value at the end of the existing record in 143 | the database. If there is no corresponding record, a new record is 144 | created. 145 | 146 | Valid modes for hash databases are: 147 | 148 | :REPLACE , :KEEP and :CONCAT , as above.")) 149 | 150 | 151 | 152 | (defgeneric dbm-get (db key &optional type) 153 | (:documentation "Returns the value under KEY in DB. Type may be one 154 | of :STRING or :OCTETS , depending on how the value is to be 155 | treated. :STRING indicates that the value should be converted to a 156 | Lisp string, while :OCTETS indicates that the byte vector should be 157 | returned.")) 158 | 159 | (defgeneric dbm-remove (db key) 160 | (:documentation "Removes the value under KEY in DB. If REMOVE-DUPS 161 | is T, duplicate values will be removed from a B+ tree database.")) 162 | 163 | 164 | ;;; Iterator based methods below 165 | 166 | (defgeneric iter-item (db &key key-type value-type) 167 | (:documentation "Returns the current item in the iterator. ** DOES NOT advance the cursor **")) 168 | 169 | (defgeneric iter-iterate (db fn) 170 | (:documentation "Iterates through all records and calls function fn for each record. 171 | 172 | Arguments: 173 | 174 | - db (object): A KC dbm object. 175 | - fn (function): A callback function 176 | 177 | Returns: 178 | - Boolean representing true for success or false for failure.")) 179 | 180 | 181 | (defgeneric iter-open (db) 182 | (:documentation "Opens an iterator on DB. 183 | 184 | Arguments: 185 | 186 | - db (object): A KC dbm object. 187 | 188 | Returns: 189 | - A TC iterator object.")) 190 | 191 | (defgeneric iter-close (iterator) 192 | (:documentation "Closes ITERATOR. Only effective for B+ tree 193 | databases.")) 194 | 195 | (defgeneric iter-first (iterator) 196 | (:documentation "Moves ITERATOR to the first record and returns T, 197 | or NIL if the database is empty. Only effective for B+ tree 198 | databases.")) 199 | 200 | (defgeneric iter-last (iterator) 201 | (:documentation "Moves ITERATOR to the last record and returns T, or 202 | NIL if the database is empty. Only effective for B+ tree databases.")) 203 | 204 | (defgeneric iter-prev (iterator) 205 | (:documentation "Moves ITERATOR to the previous record and returns 206 | T, or NIL if already at the first record. Only effective for B+ tree 207 | databases.")) 208 | 209 | (defgeneric iter-next (iterator) 210 | (:documentation "Moves ITERATOR to the next record and returns T, or 211 | NIL if already at the last record.")) 212 | 213 | (defgeneric iter-go-to (iterator key) 214 | (:documentation "Moves ITERATOR to the record at KEY. Only effective 215 | for B+ tree databases.")) 216 | 217 | 218 | (defgeneric iter-put (iterator value &key mode) 219 | (:documentation "Inserts VALUE around ITERATOR. Mode may be one 220 | of :CURRENT , :BEFORE or :AFTER . Only effective for B+ tree 221 | databases.")) 222 | 223 | (defgeneric iter-remove (iterator) 224 | (:documentation "Removed the record at the ITERATOR position and 225 | advances ITERATOR, if possible. Only effective for B+ tree 226 | databases.")) 227 | 228 | (defgeneric iter-key (iterator &optional type) 229 | (:documentation "Returns current key at the ITERATOR position. Type 230 | may be one of :STRING or :OCTETS , depending on how the value is to be 231 | treated. :STRING indicates that the value should be converted to a 232 | Lisp string, while :OCTETS indicates that the byte vector should be 233 | returned.")) 234 | 235 | (defgeneric iter-value (iterator &optional type) 236 | (:documentation "Returns the current value at ITERATOR. Type may be 237 | one of :STRING or :OCTETS , depending on how the value is to be 238 | treated. :STRING indicates that the value should be converted to a 239 | Lisp string, while :OCTETS indicates that the byte vector should be 240 | returned.")) 241 | 242 | (defgeneric dbm-num-records (db) 243 | (:documentation "Returns the number of records in DB.")) 244 | 245 | (defgeneric dbm-file-namestring (db) 246 | (:documentation "Returns the name of the DB file.")) 247 | 248 | (defgeneric dbm-file-size (db) 249 | (:documentation "Returns the size of the DB file in bytes.")) 250 | 251 | (defgeneric dbm-optimize (db &rest args) 252 | (:documentation "Sets the DB optimization parameters on an open 253 | database. These are described in the TC documentation. 254 | 255 | The keyword arguments for B+ tree databases are: 256 | 257 | - :LEAF (fixnum) : Sets the number of leaf nodes. 258 | - :NON-LEAF (fixnum) : Sets the number of non-leaf nodes. 259 | - :BUCKET-SIZE (fixnum) : Sets the bucket 260 | - :REC-ALIGN (fixnum) : A power of 2 indicating record alignment. 261 | - :FREE-POOL (fixnum): A power of 2 indicating the size of the free 262 | record pool. 263 | 264 | - :OPTS (list symbol): A list of keywords indicating optional database 265 | parameters. 266 | 267 | The keyword arguments for hash databases are: 268 | 269 | :BUCKET-SIZE :REC-ALIGN :FREE-POOL and :OPTS , as above. 270 | 271 | In both cases the :OPTS value is a list of one or more of 272 | 273 | - :LARGE : Use a 64-bit bucket array to allow datbases > 2Gb. 274 | - :DEFLATE : Use deflate compression. 275 | - :BZIP : Use bzip compression. 276 | - :TCBS : Use tcbs compression. 277 | - :DEFAULTS : Use the current settings. 278 | 279 | For example: 280 | 281 | ;;; (dbm-optimize db :leaf 512 :non-leaf 256 :bucket-size 100000000 282 | ;;; :rec-align 4 :free-pool 10 :opts '(:large :deflate))")) 283 | 284 | (defgeneric dbm-cache (db &rest args) 285 | (:documentation "Sets the caching parameters of DB. These are 286 | described in the TC documentation. 287 | 288 | The keyword arguments for B+ tree databases are: 289 | 290 | - :LEAF : The number of leaf nodes to cache. Defaults to 1024. 291 | - :NON-LEAF : The number of non-leaf nodes to cache. Defaults to 512. 292 | 293 | The keyword arguments for hash databases are: 294 | 295 | - :RECORDS : The number of records to cache. Defaults to 0.")) 296 | 297 | (defgeneric dbm-xmsize (db size) 298 | (:documentation "Sets the DB extra mapped memory to SIZE bytes.")) 299 | 300 | (defgeneric set-comparator (db fn) 301 | (:documentation "Sets the DB comparator function to that given by 302 | symbol FN.")) 303 | 304 | (defmacro with-database ((var filespec type &rest mode) &body body) 305 | "Evaluates BODY with VAR bound to an open database. 306 | 307 | Arguments: 308 | 309 | - var (symbol): The binding for the new database object. 310 | - filespec (filespec): The database file. 311 | - type (symbol): A symbol that names a TC database class. 312 | 313 | Rest: 314 | 315 | - mode (symbols): :READ :WRITE :CREATE :TRUNCATE 316 | :NOLOCK :NOBLOCK and :TSYNC 317 | 318 | See the TC documentation for the meaning of the mode arguments." 319 | `(let ((,var (make-instance ,type))) 320 | (unwind-protect 321 | (progn 322 | (dbm-open ,var ,filespec ,@mode) 323 | ,@body) 324 | (when ,var 325 | (dbm-close ,var))))) 326 | 327 | (defmacro with-iterator ((var db) &body body) 328 | "Evaluates BODY on with VAR bound to a new, open iterator on DB." 329 | `(let ((,var (iter-open ,db))) 330 | (unwind-protect 331 | (progn 332 | ,@body) 333 | (when ,var 334 | (iter-close ,var))))) 335 | 336 | (defmacro with-string-value ((value-ptr initform) &body body) 337 | "Helper macro for managing string values." 338 | `(let ((,value-ptr ,initform)) 339 | (unwind-protect 340 | (progn 341 | ,@body) 342 | (when (and value-ptr (not (null-pointer-p ,value-ptr))) 343 | (kcfree ,value-ptr))))) 344 | 345 | (defun check-open-mode (mode) 346 | "Checks the list MODE for valid and consistent database opening 347 | arguments." 348 | (cond ((and (member :create mode) 349 | (not (member :write mode))) 350 | (error 'dbm-error 351 | :text "The :CREATE argument may not be used in :READ mode")) 352 | ((and (member :truncate mode) 353 | (not (member :write mode))) 354 | (error 'dbm-error 355 | :text "The :TRUNCATE argument may not be used in :READ mode")) 356 | (t t))) 357 | 358 | (defun get-pointer->pointer (db key-ptr key-len fn) 359 | "Returns a value from DB under KEY using FN where the key and value 360 | are cffi pointers." 361 | (declare (optimize (speed 3))) 362 | (declare (type function fn) 363 | (type integer key-len)) 364 | (with-foreign-object (size-ptr :int) 365 | (let ((value-ptr (funcall fn (ptr-of db) 366 | key-ptr key-len size-ptr))) 367 | (if (null-pointer-p value-ptr) 368 | (maybe-raise-error db "(key ~a)" key-ptr) 369 | (values value-ptr (mem-ref size-ptr :int)))))) 370 | 371 | (defun get-string->string (db key fn) 372 | "Returns a value from DB under KEY using FN where the key and value 373 | are strings." 374 | (declare (optimize (speed 3))) 375 | (declare (type function fn)) 376 | (let ((p (foreign-alloc :uint32))) 377 | (with-string-value (value-ptr (funcall fn (ptr-of db) key (length key) p)) 378 | (if (null-pointer-p value-ptr) 379 | (maybe-raise-error db "(key ~a)" key) 380 | (foreign-string-to-lisp value-ptr))))) 381 | 382 | (defun get-string->octets (db key fn) 383 | "Returns a value from DB under KEY using FN where the key is a 384 | string and the value an octet vector. Note that for the key we 385 | allocate a foreign string that is not null-terminated." 386 | (declare (optimize (speed 3))) 387 | (declare (type function fn)) 388 | (with-foreign-string ((key-ptr key-len) key :null-terminated-p nil) 389 | (with-foreign-object (size-ptr :int) 390 | (with-string-value (value-ptr (funcall fn (ptr-of db) 391 | key-ptr key-len size-ptr)) 392 | (if (null-pointer-p value-ptr) 393 | (maybe-raise-error db "(key ~a)" key) 394 | (copy-foreign-value value-ptr size-ptr)))))) 395 | 396 | (defun get-octets->octets (db key fn) 397 | "Returns a value from DB under KEY using FN where the key and value 398 | are octet vectors." 399 | (declare (optimize (speed 3))) 400 | (declare (type (simple-array octet) key) 401 | (type function fn)) 402 | (let ((key-len (length key))) 403 | (with-foreign-object (key-ptr :unsigned-char key-len) 404 | (loop 405 | for i from 0 below key-len 406 | do (setf (mem-aref key-ptr :unsigned-char i) (aref key i))) 407 | (with-foreign-object (size-ptr :int) 408 | (with-string-value (value-ptr (funcall fn (ptr-of db) 409 | key-ptr key-len size-ptr)) 410 | (if (null-pointer-p value-ptr) 411 | (maybe-raise-error db "(key ~a)" key) 412 | (copy-foreign-value value-ptr size-ptr))))))) 413 | 414 | (defun get-octets->string (db key fn) 415 | "Returns a value from DB under KEY using FN where the key is a 416 | vector of octets and value is a string." 417 | (declare (optimize (speed 3))) 418 | (declare (type (simple-array octet) key) 419 | (type function fn)) 420 | (let ((key-len (length key))) 421 | (with-foreign-object (key-ptr :unsigned-char key-len) 422 | (loop 423 | for i from 0 below key-len 424 | do (setf (mem-aref key-ptr :unsigned-char i) (aref key i))) 425 | (with-foreign-object (size-ptr :int) 426 | (with-string-value (value-ptr (funcall fn (ptr-of db) 427 | key-ptr key-len size-ptr)) 428 | (if (null-pointer-p value-ptr) 429 | (maybe-raise-error db "(key ~a)" key) 430 | (foreign-string-to-lisp value-ptr 431 | :count (mem-ref size-ptr :int)))))))) 432 | 433 | (defun get-int32->string (db key fn) 434 | "Returns a value from DB under KEY using FN where the key is a 435 | 32-but integer and the value a string." 436 | (declare (optimize (speed 3))) 437 | (declare (type function fn)) 438 | (let ((key-len (foreign-type-size :int32))) 439 | (with-foreign-objects ((key-ptr :int32) 440 | (size-ptr :int)) 441 | (setf (mem-ref key-ptr :int32) key) 442 | (with-string-value (value-ptr (funcall fn (ptr-of db) 443 | key-ptr key-len size-ptr)) 444 | (if (null-pointer-p value-ptr) 445 | (maybe-raise-error db "(key ~a)" key) 446 | (foreign-string-to-lisp value-ptr 447 | :count (mem-ref size-ptr :int))))))) 448 | 449 | (defun get-int32->octets (db key fn) 450 | "Returns a value from DB under KEY using FN where the key is a 451 | 32-bit integer and the value an octet vector." 452 | (declare (optimize (speed 3))) 453 | (declare (type function fn)) 454 | (let ((key-len (foreign-type-size :int32)) 455 | (value-ptr nil)) 456 | (unwind-protect 457 | (with-foreign-objects ((key-ptr :int32) 458 | (size-ptr :int)) 459 | (setf (mem-ref key-ptr :int32) key 460 | value-ptr (funcall fn (ptr-of db) key-ptr key-len size-ptr)) 461 | (if (null-pointer-p value-ptr) 462 | (maybe-raise-error db "(key ~a)" key) 463 | (copy-foreign-value value-ptr size-ptr))) 464 | (when (and value-ptr (not (null-pointer-p value-ptr))) 465 | (foreign-free value-ptr))))) 466 | 467 | (defun put-pointer->pointer (db key-ptr key-len value-ptr value-len fn) 468 | "Inserts VALUE into DB under KEY using FN where the key and value 469 | are cffi pointers." 470 | (declare (optimize (speed 3))) 471 | (declare (type function fn) 472 | (type integer key-len value-len)) 473 | (or (funcall fn (ptr-of db) key-ptr key-len value-ptr value-len) 474 | (maybe-raise-error db "(key ~a) (value ~a)" key-ptr value-ptr))) 475 | 476 | (defun put-string->string (db key value fn) 477 | "Inserts VALUE into DB under KEY using FN where the key and value 478 | are strings." 479 | (declare (optimize (speed 3))) 480 | (declare (type function fn)) 481 | (with-foreign-string ((key-ptr key-len) key :null-terminated-p nil) 482 | (with-foreign-string ((value-ptr value-len) value :null-terminated-p nil) 483 | (or (funcall fn (ptr-of db) key-ptr key-len value-ptr value-len) 484 | (maybe-raise-error db "(key ~a) (value ~a)" key value))))) 485 | 486 | (defun put-string->octets (db key value fn) 487 | "Inserts VALUE into DB under KEY using FN where the key is a string 488 | and the value an octet vector. Note that for the key we allocate a 489 | foreign string that is not null-terminated." 490 | (declare (optimize (speed 3))) 491 | (declare (type (simple-array (unsigned-byte 8)) value) 492 | (type function fn)) 493 | (let ((value-len (length value))) 494 | (with-foreign-string ((key-ptr key-len) key :null-terminated-p nil) 495 | (with-foreign-object (value-ptr :unsigned-char value-len) 496 | (loop 497 | for i from 0 below value-len 498 | do (setf (mem-aref value-ptr :unsigned-char i) (aref value i))) 499 | (or (funcall fn (ptr-of db) key-ptr key-len value-ptr value-len) 500 | (maybe-raise-error db "(key ~a) (value ~a)" key value)))))) 501 | 502 | (defun put-octets->octets (db key value fn) 503 | "Inserts VALUE into DB under KEY using FN where the key and value 504 | are octet vectors." 505 | (declare (optimize (speed 3))) 506 | (declare (type (simple-array (unsigned-byte 8)) key value) 507 | (type function fn)) 508 | (let ((key-len (length key)) 509 | (value-len (length value))) 510 | (with-foreign-object (key-ptr :unsigned-char key-len) 511 | (with-foreign-object (value-ptr :unsigned-char value-len) 512 | (loop 513 | for i from 0 below key-len 514 | do (setf (mem-aref key-ptr :unsigned-char i) (aref key i))) 515 | (loop 516 | for i from 0 below value-len 517 | do (setf (mem-aref value-ptr :unsigned-char i) (aref value i))) 518 | (or (funcall fn (ptr-of db) key-ptr key-len value-ptr value-len) 519 | (maybe-raise-error db "(key ~a) (value ~a)" key value)))))) 520 | 521 | (defun put-int32->string (db key value fn) 522 | "Inserts VALUE into DB under KEY using FN where the key is a 32-bit 523 | integer and the value is a string." 524 | (declare (optimize (speed 3))) 525 | (declare (type simple-string value) 526 | (type function fn)) 527 | (let ((key-len (foreign-type-size :int32)) 528 | (value-len (length value))) 529 | (with-foreign-object (key-ptr :int32) 530 | (setf (mem-ref key-ptr :int32) (convert-to-foreign key :int32)) 531 | (with-foreign-string (value-ptr value) 532 | (or (funcall fn (ptr-of db) key-ptr key-len value-ptr value-len) 533 | (maybe-raise-error db "(key ~a) (value ~a)" key value)))))) 534 | 535 | (defun put-int32->octets (db key value fn) 536 | "Inserts VALUE into DB under KEY using FN where the key is a 32-bit 537 | integer and the value is an octet vector." 538 | (declare (optimize (speed 3))) 539 | (declare (type (simple-array (unsigned-byte 8)) value) 540 | (type function fn)) 541 | (let ((key-len (foreign-type-size :int32)) 542 | (value-len (length value))) 543 | (with-foreign-objects ((key-ptr :int32) 544 | (value-ptr :unsigned-char value-len)) 545 | (setf (mem-ref key-ptr :int32) key) 546 | (loop 547 | for i from 0 below value-len 548 | do (setf (mem-aref value-ptr :unsigned-char i) (aref value i))) 549 | (or (funcall fn (ptr-of db) key-ptr key-len value-ptr value-len) 550 | (maybe-raise-error db "(key ~a) (value ~a)" key value))))) 551 | 552 | (defun rem-pointer->value (db key key-len) 553 | "Removes value from DB under KEY where the key is a cffi pointer" 554 | (declare (optimize (speed 3))) 555 | (or (kcdbremove (ptr-of db) key key-len) 556 | (maybe-raise-error db "(key ~a)" key))) 557 | 558 | (defun rem-string->value (db key) 559 | "Removes value from DB under KEY where the key is a 560 | string." 561 | (declare (optimize (speed 3))) 562 | (with-foreign-string ((key-ptr key-len) key :null-terminated-p nil) 563 | (or (kcdbremove (ptr-of db) key key-len) 564 | (maybe-raise-error db "(key ~a)" key)))) 565 | 566 | (defun rem-int32->value (db key) 567 | "Removes value from DB under KEY where the key is a 32-bit 568 | integer." 569 | (declare (optimize (speed 3))) 570 | (with-foreign-object (key-ptr :int32) 571 | (setf (mem-ref key-ptr :int32) key) 572 | (or (kcdbremove (ptr-of db) key-ptr (foreign-type-size :int32)) 573 | (maybe-raise-error db "(key ~a)" key)))) 574 | 575 | (defun rem-octets->value (db key) 576 | "Removes value from DB under KEY where the key is a octet vector" 577 | (declare (optimize (speed 3))) 578 | (let ((key-len (length key))) 579 | (with-foreign-object (key-ptr :unsigned-char key-len) 580 | (loop 581 | for i from 0 below key-len 582 | do (setf (mem-aref key-ptr :unsigned-char i) (aref key i))) 583 | (or (kcdbremove (ptr-of db) key-ptr key-len) 584 | (maybe-raise-error db "(key ~a)" key))))) 585 | 586 | 587 | (declaim (inline copy-foreign-value)) 588 | (defun copy-foreign-value (value-ptr size-ptr) 589 | (declare (optimize (speed 3))) 590 | (let ((size (mem-ref size-ptr :int))) 591 | (loop 592 | with value = (make-array size :element-type '(unsigned-byte 8)) 593 | for i from 0 below size 594 | do (setf (aref value i) (mem-aref value-ptr :unsigned-char i)) 595 | finally (return value)))) 596 | 597 | (defgeneric put-method-for (mode) 598 | (:method ((mode (eql :replace))) #'kcdbset) 599 | (:method ((mode (eql :keep))) #'kcdbadd) 600 | (:method ((mode (eql :concat))) #'kcdbappend)) 601 | 602 | 603 | (defgeneric convert-to-lisp (type what-ptr &optional size ) 604 | (:method ((type (eql :string)) what-ptr &optional size) 605 | (foreign-string-to-lisp what-ptr)) 606 | (:method ((type (eql :integer)) what-ptr &optional size) 607 | (mem-aref what-ptr :int32)) 608 | (:method ((type (eql :octets)) what-ptr &optional size ) 609 | (copy-foreign-value what-ptr size))) 610 | 611 | (defgeneric convert-from-lisp (type what) 612 | (:method ((type (eql :string)) what) 613 | (convert-to-foreign what type)) 614 | (:method ((type (eql :integer)) what) 615 | (convert-to-foreign what :int32)) 616 | (:method ((type (eql :octets)) what) 617 | (with-foreign-object (what-ptr :unsigned-char) 618 | (loop 619 | for i from 0 below (length what) 620 | do (setf (mem-aref what-ptr :unsigned-char i) (aref what i))) 621 | what-ptr))) 622 | 623 | (defun make-octet-vector (&rest body) 624 | (make-array (length body) :initial-contents body :element-type '(unsigned-byte 8))) 625 | 626 | (defmacro with-transaction ((db) &body body) 627 | "Evaluates BODY in the context of a transaction on DB. If no 628 | transaction is in progress, a new one is started. If a transaction is 629 | already in progress, BODY is evaluated in its context. If an error 630 | occurs, the transaction will rollback, otherwise it will commit." 631 | (let ((success (gensym))) 632 | `(let ((,success nil)) 633 | (flet ((atomic-op () 634 | ,@body)) 635 | (if *in-transaction-p* 636 | (atomic-op) 637 | (unwind-protect 638 | (let ((*in-transaction-p* t)) 639 | (prog2 640 | (dbm-begin ,db) 641 | (atomic-op) 642 | (setf ,success t))) 643 | (if ,success 644 | (dbm-commit ,db) 645 | (dbm-rollback ,db)))))))) 646 | 647 | 648 | (defun get-something (iter fn &optional (type :string)) 649 | (let* ((size (foreign-alloc :pointer)) 650 | (val (funcall fn (ptr-of iter) size NIL))) 651 | (convert-to-lisp type val size))) 652 | 653 | (defun get-pointer (iter fn) 654 | (with-foreign-object (size-ptr :int) 655 | (values (funcall fn (ptr-of iter) size-ptr NIL) (mem-ref size-ptr :int)))) 656 | --------------------------------------------------------------------------------