From: Matt Birkholz Date: Sun, 1 Sep 2013 01:12:05 +0000 (-0700) Subject: gdbm: A separately buildable FFI wrapper. X-Git-Tag: release-9.2.0~131 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=75db6ae159561994d1a22f11c95534d94c489753;p=mit-scheme.git gdbm: A separately buildable FFI wrapper. This is a drop-in replacement for the gdbm microcode module and runtime/gdbm.scm. Run `make install' and install the following in your optiondb.scm. (define-load-option 'GDBM2 (guarded-system-loader '(gdbm) "gdbm")) You will need to call it GDBM2 while GDBM refers to the original microcode module wrapper. --- diff --git a/src/gdbm/Makefile b/src/gdbm/Makefile new file mode 100644 index 000000000..4d27d0541 --- /dev/null +++ b/src/gdbm/Makefile @@ -0,0 +1,67 @@ +# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, +# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, +# 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 +# Massachusetts Institute of Technology +# +# This file is part of MIT/GNU Scheme. +# +# MIT/GNU Scheme is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License as +# published by the Free Software Foundation; either version 2 of the +# License, or (at your option) any later version. +# +# MIT/GNU Scheme is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with MIT/GNU Scheme; if not, write to the Free Software +# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA +# 02110-1301, USA. + +MIT_SCHEME_EXE = mit-scheme +EXE = '$(MIT_SCHEME_EXE)' --batch-mode + +build: gdbm-shim.so gdbm-types.bin gdbm-const.bin + echo "(compile-bundle)" | $(EXE) + +check: + echo '(load "check")' | $(EXE) + +install: build + echo "(install-bundle)" | $(EXE) -- *.com *.bci *.pkd make.scm + echo '(install-shim "gdbm")' | $(EXE) + +clean: + rm -f gdbm-const.scm gdbm-const gdbm-const.c gdbm-shim.c + rm -f gdbm-*.crf gdbm-*.fre gdbm-*.pkd + rm -f *.o *.so *.bin *.ext *.com *.bci + rm -f *.moc *.fni *-init.c *-init.h *-init.o + rm -f gdbm-check.db + +gdbm-shim.so: gdbm-shim.o gdbm-adapter.o + echo "(link-shim)" | $(EXE) -- -o $@ $^ -lgdbm + +gdbm-adapter.o: gdbm-adapter.c gdbm-shim.h + echo '(compile-shim)' | $(EXE) -- -c $< + +gdbm-shim.o: gdbm-shim.c gdbm-shim.h + echo '(compile-shim)' | $(EXE) -- -c $< + +gdbm-shim.c gdbm-const.c gdbm-types.bin: gdbm-shim.h gdbm.cdecl + echo '(generate-shim "gdbm" "#include \"gdbm-shim.h\"")' | $(EXE) + +gdbm-const.bin: gdbm-const.scm + echo '(sf "gdbm-const")' | $(EXE) + +gdbm-const.scm: gdbm-const + ./gdbm-const + +gdbm-const: gdbm-const.o + $(CC) $(LDFLAGS) -o $@ $^ + +gdbm-const.o: gdbm-const.c gdbm-shim.h + $(CC) $(CFLAGS) -c $< + +.PHONY: build install clean \ No newline at end of file diff --git a/src/gdbm/check.scm b/src/gdbm/check.scm new file mode 100644 index 000000000..62d147a35 --- /dev/null +++ b/src/gdbm/check.scm @@ -0,0 +1,9 @@ +#| -*-Scheme-*- |# + +;;;; Test the GDBM adapter. + +(load "make") +(with-system-library-directories + '("./") + (lambda () + (load "gdbm-check" (->environment '(gdbm))))) \ No newline at end of file diff --git a/src/gdbm/compile.scm b/src/gdbm/compile.scm new file mode 100644 index 000000000..f675f5714 --- /dev/null +++ b/src/gdbm/compile.scm @@ -0,0 +1,9 @@ +#| -*-Scheme-*- |# + +;;;; Compile the GDBM adapter + +(fluid-let ((load/suppress-loading-message? #t)) + (load-option 'CREF) + (load-option 'FFI)) + +(compile-system "gdbm" (directory-pathname (current-load-pathname))) \ No newline at end of file diff --git a/src/gdbm/gdbm-adapter.c b/src/gdbm/gdbm-adapter.c new file mode 100644 index 000000000..d0c4c6822 --- /dev/null +++ b/src/gdbm/gdbm-adapter.c @@ -0,0 +1,205 @@ +/* -*-C-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts + Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +/* Interface to the gdbm database library */ + +#include +#include "gdbm-shim.h" + +extern char * +alloc_gdbm_key (gdbm_args * args, int size) +{ + char * bytes; + + if (size <= args->key_allocation) + { + bytes = args->key.dptr; + } + else + { + if (args->key.dptr != NULL) + free (args->key.dptr); + bytes = args->key.dptr = malloc (size); + args->key_allocation = size; + } + args->key.dsize = size; + return (bytes); +} + +extern char * +alloc_gdbm_content (gdbm_args * args, int size) +{ + char * bytes; + + if (size <= args->content_allocation) + bytes = args->content.dptr; + else + { + if (args->content.dptr != NULL) + free (args->content.dptr); + bytes = args->content.dptr = malloc (size); + args->content_allocation = size; + } + args->content.dsize = size; + return (bytes); +} + +extern char * +get_gdbm_version (void) +{ + return (gdbm_version); +} + +static void +fatal_error (const char * msg) +{ + outf_error ("\ngdbm: %s\n", msg); + outf_flush_error (); + error_external_return (); +} + +extern gdbm_args * +do_gdbm_open (char * name, int block_size, int read_write, int mode) +{ + gdbm_args *args = (gdbm_args *) malloc (sizeof (gdbm_args)); + if (!args) return (args); + + args->key.dsize = 0; + args->key.dptr = NULL; + args->key_allocation = 0; + args->content.dsize = 0; + args->content.dptr = NULL; + args->content_allocation = 0; + args->gdbm_errno = 0; + args->sys_errno = 0; + args->dbf = gdbm_open (name, block_size, read_write, mode, &fatal_error); + + if (args->dbf == NULL) + { + args->gdbm_errno = gdbm_errno; + args->sys_errno = errno; + } + return (args); +} + +extern void +do_gdbm_close (gdbm_args * args) +{ + gdbm_close (args->dbf); + if (args->key.dptr != NULL) + free (args->key.dptr); + if (args->content.dptr != NULL) + free (args->content.dptr); + free (args); +} + +extern int +do_gdbm_store (gdbm_args * args, int flag) +{ + int ret = gdbm_store (args->dbf, args->key, args->content, flag); + if (ret == -1) + { + args->gdbm_errno = gdbm_errno; + args->sys_errno = errno; + } + return (ret); +} + +extern void +do_gdbm_fetch (gdbm_args * args) +{ + if (args->content.dptr != NULL) + free (args->content.dptr); + args->content = gdbm_fetch (args->dbf, args->key); + args->content_allocation = args->content.dsize; +} + +extern int +do_gdbm_exists (gdbm_args * args) +{ + return (gdbm_exists (args->dbf, args->key)); +} + +extern int +do_gdbm_delete (gdbm_args * args) +{ + return (gdbm_delete (args->dbf, args->key)); +} + +extern void +do_gdbm_firstkey (gdbm_args * args) +{ + if (args->key.dptr != NULL) + free (args->key.dptr); + args->key = gdbm_firstkey (args->dbf); + if (args->key.dptr != NULL) + args->key_allocation = args->key.dsize; + else + args->key_allocation = 0; +} + +extern int +do_gdbm_nextkey (gdbm_args * args) +{ + datum next = gdbm_nextkey (args->dbf, args->key); + if (next.dptr == NULL) + return (1); + if (args->key.dptr != NULL) + free (args->key.dptr); + args->key = next; + args->key_allocation = next.dsize; + return (0); +} + +extern int +do_gdbm_reorganize (gdbm_args * args) +{ + int ret = gdbm_reorganize (args->dbf); + if (ret) + { + args->gdbm_errno = gdbm_errno; + args->sys_errno = errno; + } + return (ret); +} + +extern void +do_gdbm_sync (gdbm_args * args) +{ + gdbm_sync (args->dbf); +} + +extern int +do_gdbm_setopt (gdbm_args * args, int option, int value) +{ + int ret = gdbm_setopt (args->dbf, option, &value, sizeof (int)); + if (ret) + { + args->gdbm_errno = gdbm_errno; + args->sys_errno = errno; + } + return (ret); +} diff --git a/src/gdbm/gdbm-check.scm b/src/gdbm/gdbm-check.scm new file mode 100644 index 000000000..ddf029f8b --- /dev/null +++ b/src/gdbm/gdbm-check.scm @@ -0,0 +1,99 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts + Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Test the GDBM adapter. + +(if (not (gdbm-available?)) + (warn "gdbm adapter not found") + (let ((filename.db "gdbm-check.db")) + (ignore-errors (lambda () (delete-file filename.db))) + (let ((dbf (gdbm-open filename.db 0 GDBM_WRCREAT #o660))) + ;; Must be set before first store. + (gdbm-setopt dbf GDBM_CACHESIZE 101) + + (gdbm-store dbf "Silly String" "Testing 1 2 3." GDBM_REPLACE) + (if (not (condition? + (ignore-errors + (lambda () (gdbm-store dbf "NullString" "" GDBM_INSERT))))) + (error "storing null content did not signal")) + (if (not (condition? + (ignore-errors + (lambda () (gdbm-store dbf "" "NullString" GDBM_INSERT))))) + (error "storing null key did not signal")) + (if (not (eq? #t (gdbm-store dbf "Silly String" "Ahoy!" GDBM_REPLACE))) + (error "replace produced wrong indication")) + (if (not (eq? #f (gdbm-store dbf "Silly String" "Oy!" GDBM_INSERT))) + (error "double insert produced no indication")) + + (gdbm-setopt dbf GDBM_SYNCMODE 1) + + (let ((content (gdbm-fetch dbf "Silly String"))) + (if (not (string=? "Ahoy!" content)) + (error "fetched:" content))) + (let ((content (gdbm-fetch dbf "Missing String"))) + (if (not (eq? #f content)) + (error "missing fetched:" content))) + + (if (gdbm-exists? dbf "Missing String") + (error "exists")) + (if (not (gdbm-exists? dbf "Silly String")) + (error "not exists")) + + (gdbm-delete dbf "Silly String") + (if (gdbm-exists? dbf "Silly String") + (error "not deleted")) + (if (gdbm-delete dbf "Missing String") + (error "deleted")) + + (let ((k (gdbm-firstkey dbf))) + (if k + (error "empty database returned a firstkey:" k))) + (gdbm-store dbf "AString" "Testing 1 2 3." GDBM_INSERT) + (gdbm-store dbf "ASecondString" "Testing 1 2 3." GDBM_REPLACE) + (gdbm-store dbf "AThirdString" "Testing 1 2 3." GDBM_INSERT) + #;(let ((keys (sort (gdbm-keys dbf) string +#include +#include +#include + +typedef struct gdbm_args { + GDBM_FILE dbf; + gdbm_error gdbm_errno; + int sys_errno; + datum key, content; + int key_allocation, content_allocation; +} gdbm_args; + +extern char * alloc_gdbm_key (gdbm_args * args, int size); +extern char * alloc_gdbm_content (gdbm_args * args, int size); + +extern gdbm_args * do_gdbm_open (char * name, + int block_size, int read_write, int mode); +extern void do_gdbm_close (gdbm_args * args); +extern int do_gdbm_store (gdbm_args * args, int flag); +extern void do_gdbm_fetch (gdbm_args * args); +extern int do_gdbm_exists (gdbm_args * args); +extern int do_gdbm_delete (gdbm_args * args); +extern void do_gdbm_firstkey (gdbm_args * args); +extern int do_gdbm_nextkey (gdbm_args * args); +extern int do_gdbm_reorganize (gdbm_args * args); +extern void do_gdbm_sync (gdbm_args * args); +extern int do_gdbm_setopt (gdbm_args * args, int option, int value); +extern char * get_gdbm_version (void); diff --git a/src/gdbm/gdbm.cdecl b/src/gdbm/gdbm.cdecl new file mode 100644 index 000000000..02b21153a --- /dev/null +++ b/src/gdbm/gdbm.cdecl @@ -0,0 +1,105 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts + Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; C declarations for gdbm-shim.so. + +;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who +;; can create the database. +(enum (GDBM_READER) ;; A reader. + (GDBM_WRITER) ;; A writer. + (GDBM_WRCREAT) ;; A writer. Create the db if needed. + (GDBM_NEWDB) ;; A writer. Always create a new db. + (GDBM_FAST) ;; Write fast! => No fsyncs. OBSOLETE. + (GDBM_SYNC) ;; Sync operations to the disk. + (GDBM_NOLOCK)) ;; Don't do file locking operations. + +;; Parameters to gdbm_store for simple insertion or replacement in the +;; case that the key is already in the database. +(enum (GDBM_INSERT) ;; Never replace old data with new. + (GDBM_REPLACE)) ;; Always replace old data with new. + +;; Parameters to gdbm_setopt, specifing the type of operation to perform. +(enum (GDBM_CACHESIZE) ;; Set the cache size. + (GDBM_FASTMODE) ;; Toggle fast mode. OBSOLETE. + (GDBM_SYNCMODE) ;; Turn on or off sync operations. + (GDBM_CENTFREE) ;; Keep all free blocks in the header. + (GDBM_COALESCEBLKS)) ;; Attempt to coalesce free blocks. + +(typedef datum + (struct + (dptr (* char)) + (dsize int))) + +(typedef gdbm_args + (struct + (dbf GDBM_FILE) + (gdbm_errno int) + (sys_errno int) + (key datum) + (content datum))) + +(typedef GDBM_FILE (* dummy)) + +(extern (* char) alloc_gdbm_key (args (* gdbm_args)) (size int)) +(extern (* char) alloc_gdbm_content (args (* gdbm_args)) (size int)) + +(extern (* gdbm_args) do_gdbm_open + (name (* char)) (block_size int) (read_write int) (mode int)) +(extern void do_gdbm_close (args (* gdbm_args))) +(extern int do_gdbm_store (args (* gdbm_args)) (flag int)) +(extern void do_gdbm_fetch (args (* gdbm_args))) +(extern int do_gdbm_exists (args (* gdbm_args))) +(extern int do_gdbm_delete (args (* gdbm_args))) +(extern void do_gdbm_firstkey (args (* gdbm_args))) +(extern int do_gdbm_nextkey (args (* gdbm_args))) +(extern int do_gdbm_reorganize (args (* gdbm_args))) +(extern void do_gdbm_sync (args (* gdbm_args))) +(extern (* char) gdbm_strerror (errnum int)) +(extern (* char) strerror (errnum int)) +(extern int do_gdbm_setopt (args (* gdbm_args)) (option int) (value int)) +(extern (* char) get_gdbm_version) + +(enum (GDBM_NO_ERROR) + (GDBM_MALLOC_ERROR) + (GDBM_BLOCK_SIZE_ERROR) + (GDBM_FILE_OPEN_ERROR) + (GDBM_FILE_WRITE_ERROR) + (GDBM_FILE_SEEK_ERROR) + (GDBM_FILE_READ_ERROR) + (GDBM_BAD_MAGIC_NUMBER) + (GDBM_EMPTY_DATABASE) + (GDBM_CANT_BE_READER) + (GDBM_CANT_BE_WRITER) + (GDBM_READER_CANT_DELETE) + (GDBM_READER_CANT_STORE) + (GDBM_READER_CANT_REORGANIZE) + (GDBM_UNKNOWN_UPDATE) + (GDBM_ITEM_NOT_FOUND) + (GDBM_REORGANIZE_FAILED) + (GDBM_CANNOT_REPLACE) + (GDBM_ILLEGAL_DATA) + (GDBM_OPT_ALREADY_SET) + (GDBM_OPT_ILLEGAL)) \ No newline at end of file diff --git a/src/gdbm/gdbm.pkg b/src/gdbm/gdbm.pkg new file mode 100644 index 000000000..66bcd0831 --- /dev/null +++ b/src/gdbm/gdbm.pkg @@ -0,0 +1,57 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts + Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +(global-definitions runtime/) + +(define-package (gdbm) + (files "gdbm") + (parent ()) + (initialization (initialize-package!)) + ;; You'll have to import these from (gdbm). They are currently + ;; bound in () by exports from (runtime gdbm). + #;(export #f + gdbm-available? + gdbm-close + gdbm-delete + gdbm-exists? + gdbm-fetch + gdbm-firstkey + gdbm-nextkey + gdbm-open + gdbm-reorganize + gdbm-setopt + gdbm-store + gdbm-sync + gdbm-version + gdbm_cachesize + gdbm_fast + gdbm_fastmode + gdbm_insert + gdbm_newdb + gdbm_reader + gdbm_replace + gdbm_wrcreat + gdbm_writer)) \ No newline at end of file diff --git a/src/gdbm/gdbm.scm b/src/gdbm/gdbm.scm new file mode 100644 index 000000000..6418c944e --- /dev/null +++ b/src/gdbm/gdbm.scm @@ -0,0 +1,370 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts + Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; gdbm Database Library Interface +;;; package: (gdbm) + +(declare (usual-integrations) + (integrate-external)) + +(C-include "gdbm") + +(define (gdbm-available?) + (let ((path (ignore-errors (lambda () + (system-library-pathname "gdbm-shim.so"))))) + (and (pathname? path) + (file-loadable? path)))) + +;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who can +;; create the database. +(define GDBM_READER (C-enum "GDBM_READER")) ;A reader. +(define GDBM_WRITER (C-enum "GDBM_WRITER")) ;A writer. +(define GDBM_WRCREAT(C-enum "GDBM_WRCREAT")) ;A writer. Create the db if needed. +(define GDBM_NEWDB (C-enum "GDBM_NEWDB")) ;A writer. Always create a new db. +(define GDBM_FAST (C-enum "GDBM_FAST")) ;Write fast! => No fsyncs. + +(define (gdbm-open filename block-size flags mode) + (guarantee-integer block-size 'GDBM-OPEN) + (guarantee-integer mode 'GDBM-OPEN) + (let ((args (make-alien '|gdbm_args|)) + (flagsnum (guarantee-gdbm-open-flags flags))) + (let ((gdbf (make-gdbf args (make-thread-mutex) filename))) + (if (not (gdbm-available?)) + (error "GDBM support is not installed.")) + (add-open-gdbf-cleanup gdbf) + (with-gdbf-locked + gdbf + (lambda () + (C-call "do_gdbm_open" args filename block-size flagsnum mode) + (if (alien-null? args) + (error "gdbm_open failed: malloc failed") + (if (alien-null? (C-> args "gdbm_args dbf")) + (gdbm-error gdbf "gdbm_open"))))) + gdbf))) + +(define (guarantee-gdbm-open-flags flags) + (define (flag->number flag) + (case flag + ((READER) (C-enum "GDBM_READER")) + ((WRITER) (C-enum "GDBM_WRITER")) + ((WRCREAT) (C-enum "GDBM_WRCREAT")) + ((NEWDB) (C-enum "GDBM_NEWDB")) + ((FAST) (C-enum "GDBM_FAST")) + (else (error:wrong-type-argument flags "gdbm-open flags" 'GDBM-OPEN)))) + (cond ((integer? flags) flags) + ((symbol? flags) (flag->number flags)) + ((list-of-type? flags symbol?) + (reduce + 0 (map flag->number flags))) + (else (error:wrong-type-argument flags "gdbm-open flags" 'GDBM-OPEN)))) + +(define (gdbm-close gdbf) + (guarantee-gdbf gdbf 'GDBM-CLOSE) + (with-gdbf-locked + gdbf + (lambda () + (let ((args (gdbf-args gdbf))) + (if (not (alien-null? args)) + (begin + (C-call "do_gdbm_close" args) + (alien-null! args) + (remove-open-gdbf-cleanup gdbf)))) + unspecific))) + +;; Parameters to gdbm_store for simple insertion or replacement in the +;; case that the key is already in the database. +(define GDBM_INSERT (C-enum "GDBM_INSERT")) ;Never replace old data. +(define GDBM_REPLACE (C-enum "GDBM_REPLACE")) ;Always replace old data. + +(define (gdbm-store gdbf key content flag) + (guarantee-gdbf gdbf 'GDBM-STORE) + (guarantee-nonnull-string key 'GDBM-STORE) + (guarantee-nonnull-string content 'GDBM-STORE) + (let ((flagnum (cond ((= flag GDBM_INSERT) flag) + ((= flag GDBM_REPLACE) flag) + ((eq? flag 'INSERT) (C-enum "GDBM_INSERT")) + ((eq? flag 'REPLACE) (C-enum "GDBM_REPLACE")) + (else (error:wrong-type-argument flag "gdbm-store flag" + 'GDBM-STORE))))) + (with-gdbf-locked-open + gdbf 'GDBM-STORE + (lambda (args) + (gdbf-args-put-key! args key) + (gdbf-args-put-content! args content) + (let ((ret (C-call "do_gdbm_store" args flagnum))) + (cond ((fix:zero? ret) #t) + ((fix:< 0 ret) #f) + (else (gdbm-error gdbf "gdbm_store")))))))) + +(define (gdbm-fetch gdbf key) + (guarantee-gdbf gdbf 'GDBM-FETCH) + (guarantee-nonnull-string key 'GDBM-FETCH) + (with-gdbf-locked-open + gdbf 'GDBM-FETCH + (lambda (args) + (gdbf-args-put-key! args key) + (C-call "do_gdbm_fetch" args) + (gdbf-args-get-content args)))) + +(define (gdbm-exists? gdbf key) + (guarantee-gdbf gdbf 'GDBM-EXISTS?) + (guarantee-nonnull-string key 'GDBM-EXISTS?) + (with-gdbf-locked-open + gdbf 'GDBM-EXISTS + (lambda (args) + (gdbf-args-put-key! args key) + (not (zero? (C-call "do_gdbm_exists" args)))))) + +(define (gdbm-delete gdbf key) + (guarantee-gdbf gdbf 'GDBM-DELETE) + (guarantee-nonnull-string key 'GDBM-DELETE) + (with-gdbf-locked-open + gdbf 'GDBM-DELETE + (lambda (args) + (gdbf-args-put-key! args key) + (zero? (C-call "do_gdbm_delete" (gdbf-args gdbf)))))) + +(define (gdbm-keys gdbf) + (guarantee-gdbf gdbf 'GDBM-KEYS) + (with-gdbf-locked-open + gdbf 'GDBM-KEYS + (lambda (args) + (C-call "do_gdbm_firstkey" args) + (let ((key (gdbf-args-get-key args))) + (if (not key) + '() + (let loop ((keys (list key))) + (if (zero? (C-call "do_gdbm_nextkey" args)) + (loop (cons (gdbf-args-get-key args) keys)) + keys))))))) + +(define (gdbm-firstkey gdbf) + (guarantee-gdbf gdbf 'GDBM-FIRSTKEY) + (with-gdbf-locked-open + gdbf 'GDBM-FIRSTKEY + (lambda (args) + (C-call "do_gdbm_firstkey" args) + (gdbf-args-get-key args)))) + +(define (gdbm-nextkey gdbf key) + ;; Returns #f if KEY is not (or no longer) in the database. Use + ;; gdbm-keys to read a complete list despite deletes. Gdbm-keys + ;; also avoids copying the keys back for gdbm_nextkey. + (guarantee-gdbf gdbf 'GDBM-NEXTKEY) + (guarantee-nonnull-string key 'GDBM-NEXTKEY) + (with-gdbf-locked-open + gdbf 'GDBM-NEXTKEY + (lambda (args) + (gdbf-args-put-key! args key) + (if (zero? (C-call "do_gdbm_nextkey" args)) + (gdbf-args-get-key args) + #f)))) + +(define (gdbm-reorganize gdbf) + (guarantee-gdbf gdbf 'GDBM-REORGANIZE) + (with-gdbf-locked-open + gdbf 'GDBM-REORGANIZE + (lambda (args) + (if (not (zero? (C-call "do_gdbm_reorganize" args))) + (gdbm-error gdbf "gdbm_reorganize"))))) + +(define (gdbm-sync gdbf) + (guarantee-gdbf gdbf 'GDBM-SYNC) + (with-gdbf-locked-open + gdbf 'GDBM-SYNC + (lambda (args) + (C-call "do_gdbm_sync" args)))) + +(define (gdbm-strerror errno) + (guarantee-fixnum errno 'GDBM-STRERROR) + (c-peek-cstring (C-call "gdbm_strerror" (make-alien '(* char)) errno))) + +(define (strerror errno) + (guarantee-fixnum errno 'STRERROR) + (c-peek-cstring (C-call "strerror" (make-alien '(* char)) errno))) + +;; Parameters to gdbm_setopt, specifing the type of operation to perform. +(define GDBM_CACHESIZE (C-enum "GDBM_CACHESIZE")) ;Set the cache size. +(define GDBM_SYNCMODE (C-enum "GDBM_SYNCMODE")) ;Toggle fast mode. + +(define (gdbm-setopt gdbf opt val) + (guarantee-gdbf gdbf 'GDBM-SETOPT) + (let* ((optnum + (cond ((eq? opt 'SYNCMODE) (C-enum "GDBM_SYNCMODE")) + ((eq? opt 'CACHESIZE) (C-enum "GDBM_CACHESIZE")) + ((and (number? opt) (= opt GDBM_SYNCMODE)) opt) + ((and (number? opt) (= opt GDBM_CACHESIZE)) opt) + (else (error:wrong-type-argument opt "option" 'GDBM-SETOPT)))) + (valnum + (cond ((= optnum GDBM_SYNCMODE) + (cond ((not val) 0) + ((eq? val #t) 1) + ((zero? val) val) + ((= val 1) val) + (else (error:wrong-type-argument val "SYNCMODE boolean" + 'GDBM-SETOPT)))) + ((= optnum GDBM_CACHESIZE) + (guarantee-integer val 'GDBM-SETOPT) + val)))) + (with-gdbf-locked-open + gdbf 'GDBM-SETOPT + (lambda (args) + (if (not (zero? (C-call "do_gdbm_setopt" args optnum valnum))) + (gdbm-error gdbf "gdbm_setopt")))))) + +(define (gdbm-version) + (c-peek-cstring (C-call "get_gdbm_version" (make-alien '(* char))))) + +(define (guarantee-nonnull-string obj procedure) + (if (or (not (string? obj)) (string-null? obj)) + (error:wrong-type-argument obj "non-null string" procedure))) + +(define-structure (gdbf (constructor make-gdbf) + (print-procedure + (standard-unparser-method + 'GDBF + (lambda (gdbf port) + (write-char #\space port) + (write (gdbf-filename gdbf) port))))) + ;; Note that communicating through this malloced-per-GDBM_FILE + ;; helper struct assumes there are no callbacks possible during gdbm + ;; operations (via which this procedure could be called multiple + ;; times [requiring a malloc per operation]). The per-gdbf lock is + ;; probably already be poised to deadlock any thread trying it. + (args #f read-only #t) + (mutex #f read-only #t) + (filename #f read-only #t)) + +(define (guarantee-gdbf gdbf procedure) + (if (gdbf? gdbf) + (or (not (alien-null? (gdbf-args gdbf))) + (error:bad-range-argument gdbf procedure)) + (error:wrong-type-argument gdbf "gdbm handle" procedure))) + +(define-integrable (with-gdbf-locked gdbf thunk) + (with-thread-mutex-locked (gdbf-mutex gdbf) thunk)) + +(define (with-gdbf-locked-open gdbf operator receiver) + (with-thread-mutex-locked + (gdbf-mutex gdbf) + (lambda () + (let ((args (gdbf-args gdbf))) + (if (alien-null? args) + (error (string-append (symbol-name operator) " failed: closed"))) + (receiver args))))) + +(define (gdbm-error gdbf msg) + (let ((args (gdbf-args gdbf))) + (error (string-append msg " failed:") + (gdbm-strerror (C-> args "gdbm_args gdbm_errno")) + (strerror (C-> args "gdbm_args sys_errno"))))) + +(define (gdbf-args-put-key! args key) + (let ((size (string-length key)) + (dptr (make-alien '(* char)))) + (if (< size 1) + (error "empty key:" key)) + (C-call "alloc_gdbm_key" dptr args size) + (if (alien-null? dptr) + (error "gdbf-args-put-key!: malloc failed" key)) + (c-poke-bytes dptr 0 size key 0))) + +(define (gdbf-args-put-content! args content) + (let ((size (string-length content)) + (dptr (make-alien '(* char)))) + (if (< size 1) + (error "empty content:" content)) + (C-call "alloc_gdbm_content" dptr args size) + (if (alien-null? dptr) + (error "gdbf-args-put-content!: malloc failed" size)) + (c-poke-bytes dptr 0 size content 0))) + +(define (gdbf-args-get-key args) + (let ((data (C-> args "gdbm_args key dptr"))) + (if (alien-null? data) + #f + (let* ((size (C-> args "gdbm_args key dsize")) + (string (string-allocate size))) + (c-peek-bytes data 0 size string 0) + string)))) + +(define (gdbf-args-get-content args) + (let ((data (C-> args "gdbm_args content dptr"))) + (if (alien-null? data) + #f + (let* ((size (C-> args "gdbm_args content dsize")) + (string (string-allocate size))) + (c-peek-bytes data 0 size string 0) + string)))) + +(define open-gdbfs '()) +(define open-gdbfs-mutex) + +(define (add-open-gdbf-cleanup gdbf) + (with-thread-mutex-locked + open-gdbfs-mutex + (lambda () + (set! open-gdbfs (cons (weak-cons gdbf (gdbf-args gdbf)) + open-gdbfs))))) + +(define (remove-open-gdbf-cleanup gdbf) + (with-thread-mutex-locked + open-gdbfs-mutex + (lambda () + (let ((entry (weak-assq gdbf open-gdbfs))) + (if entry + (set! open-gdbfs (delq! entry open-gdbfs))))))) + +(define (weak-assq obj alist) + (let loop ((alist alist)) + (if (null? alist) #f + (let* ((entry (car alist)) + (key (weak-car entry))) + (if (eq? obj key) entry + (loop (cdr alist))))))) + +(define (cleanup-open-gdbfs) + (if (not (thread-mutex-owner open-gdbfs-mutex)) + (let loop ((entries open-gdbfs) + (prev #f)) + (if (pair? entries) + (let ((entry (car entries)) + (next (cdr entries))) + (if (weak-pair/car? entry) + (loop next entries) + (let ((args (weak-cdr entry))) + (if prev + (set-cdr! prev next) + (set! open-gdbfs next)) + (if (not (alien-null? args)) + (begin + (C-call "do_gdbm_close" args) + (alien-null! args))) + (loop next prev)))))))) + +(define (initialize-package!) + (set! open-gdbfs-mutex (make-thread-mutex)) + (set! open-gdbfs '()) + (add-gc-daemon! cleanup-open-gdbfs)) \ No newline at end of file diff --git a/src/gdbm/make.scm b/src/gdbm/make.scm new file mode 100644 index 000000000..797efbb58 --- /dev/null +++ b/src/gdbm/make.scm @@ -0,0 +1,9 @@ +#| -*-Scheme-*- |# + +;;;; Load the GDBM option. + +(with-working-directory-pathname (directory-pathname (current-load-pathname)) + (lambda () + (load-package-set "gdbm"))) + +(add-subsystem-identification! "GDBM2" '(0 1)) \ No newline at end of file