From 1dcdb31e2fa09e77b957c9ab06d5446dab496ea1 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Fri, 22 Jun 2018 01:16:54 -0700 Subject: [PATCH] =?utf8?q?Punt=20gdbm=20=C2=B5module;=20autoload=20gdbm=20?= =?utf8?q?plugin=20version=201.0.?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- doc/user-manual/user.texinfo | 10 +- src/gdbm/NEWS | 7 + src/gdbm/README | 17 +- src/gdbm/configure.ac | 2 +- src/gdbm/gdbm-check.sh | 4 +- src/gdbm/gdbm.pkg | 2 +- src/gdbm/gdbm.scm | 4 +- src/gdbm/make.scm | 2 +- src/gdbm/optiondb.scm | 2 +- src/microcode/configure.ac | 25 -- src/microcode/makegen/Makefile.in.in | 3 - src/microcode/makegen/files-optional.scm | 1 - src/microcode/ntutl/makefile | 7 +- src/microcode/ntutl/makefile.wcc | 6 +- src/microcode/prgdbm.c | 277 ----------------------- src/runtime/gdbm.scm | 166 ++++++-------- src/runtime/optiondb.scm | 1 - src/runtime/runtime.pkg | 2 +- 18 files changed, 100 insertions(+), 438 deletions(-) delete mode 100644 src/microcode/prgdbm.c diff --git a/doc/user-manual/user.texinfo b/doc/user-manual/user.texinfo index 445624569..6fab500fc 100644 --- a/doc/user-manual/user.texinfo +++ b/doc/user-manual/user.texinfo @@ -242,7 +242,7 @@ may need super-user privileges to do the installation step. @emph{After} you have installed Scheme, you can install a few dynamically loadable options. These are configured, built and -installed in the customary way. To install the @code{GDBM2} +installed in the customary way. To install the @code{gdbm} option: @smallexample @@ -278,13 +278,13 @@ so. Please see the @file{README} file in each option's subdirectory for more information. @table @option -@item BLOWFISH +@item blowfish libssl-dev (-lcrypto) -@item GDBM2 +@item gdbm libgdbm-dev (-lgdbm) -@item MCRYPT +@item mcrypt libmcrypt-dev (-lmcrypt) -@item PGSQL +@item pgsql libpq-dev (-lpq) @item X11 libx11-dev (-lX11) diff --git a/src/gdbm/NEWS b/src/gdbm/NEWS index 85510ffa4..3050986c5 100644 --- a/src/gdbm/NEWS +++ b/src/gdbm/NEWS @@ -22,6 +22,13 @@ 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-gdbm 1.0 - Matt Birkholz, 2018-06-22 +=============================================== + +Replace the gdbm µmodule. Change the option name to "gdbm". Rename +the import procedure "import-gdbm". The deprecated (runtime gdbm) +package now autoloads this plugin. + mit-scheme-gdbm 0.4 - Matt Birkholz, 2018-06-01 =============================================== diff --git a/src/gdbm/README b/src/gdbm/README index 89c7aa238..77a558320 100644 --- a/src/gdbm/README +++ b/src/gdbm/README @@ -1,21 +1,20 @@ -The GDBM2 option. +The GDBM option. -This plugin creates a (gdbm) package, a drop-in replacement for the -microcode module based (runtime gdbm) package. It is built in the -customary GNU way: +This plugin creates a (gdbm) package. It is built in the customary +GNU way: ./configure ... make all check install To use: - (load-option 'gdbm2) - (import-gdbm2) + (load-option 'gdbm) + (import-gdbm) -Import-gdbm2 will modify the REPL's current environment by adding +Import-gdbm will modify the REPL's current environment by adding bindings linked to the plugin's exports. They are not exported to the -global environment because they would conflict with the exports from -(runtime gdbm). +global environment because they would conflict with the deprecated +exports from (runtime gdbm). To import into a CREF package set, add this to your .pkg file: diff --git a/src/gdbm/configure.ac b/src/gdbm/configure.ac index 9edc1b030..401a53172 100644 --- a/src/gdbm/configure.ac +++ b/src/gdbm/configure.ac @@ -2,7 +2,7 @@ dnl Process this file with autoconf to produce a configure script. AC_PREREQ([2.69]) AC_INIT([MIT/GNU Scheme gdbm plugin], - [0.4], + [1.0], [bug-mit-scheme@gnu.org], [mit-scheme-gdbm]) AC_CONFIG_SRCDIR([gdbm.pkg]) diff --git a/src/gdbm/gdbm-check.sh b/src/gdbm/gdbm-check.sh index 3fc0e44fa..d10ac95d2 100755 --- a/src/gdbm/gdbm-check.sh +++ b/src/gdbm/gdbm-check.sh @@ -1,9 +1,9 @@ #!/bin/sh # -# Test the GDBM2 option. +# Test the GDBM option. set -e ${MIT_SCHEME_EXE} --prepend-library . <<\EOF -(load-option 'GDBM2) +(load-option 'GDBM) (load "gdbm-check" (->environment '(gdbm))) EOF diff --git a/src/gdbm/gdbm.pkg b/src/gdbm/gdbm.pkg index 0ab314faa..2d29d9be9 100644 --- a/src/gdbm/gdbm.pkg +++ b/src/gdbm/gdbm.pkg @@ -35,7 +35,7 @@ USA. ustring-cp-size ustring?) (export () - import-gdbm2) + import-gdbm) (export (gdbm global) gdbm-close gdbm-delete diff --git a/src/gdbm/gdbm.scm b/src/gdbm/gdbm.scm index 243dd0ec0..b87bbc8df 100644 --- a/src/gdbm/gdbm.scm +++ b/src/gdbm/gdbm.scm @@ -24,12 +24,12 @@ USA. |# -;;;; The GDBM2 option. +;;;; The GDBM option. ;;; package: (gdbm) (declare (usual-integrations)) -(define (import-gdbm2) +(define (import-gdbm) (let ((target-environment (nearest-repl/environment)) (source-environment (->environment '(gdbm)))) (for-each (lambda (name) diff --git a/src/gdbm/make.scm b/src/gdbm/make.scm index 3d16afed1..19c9946d9 100644 --- a/src/gdbm/make.scm +++ b/src/gdbm/make.scm @@ -6,4 +6,4 @@ (lambda () (load-package-set "gdbm"))) -(add-subsystem-identification! "GDBM2" '(0 4)) \ No newline at end of file +(add-subsystem-identification! "GDBM" '(1 0)) \ No newline at end of file diff --git a/src/gdbm/optiondb.scm b/src/gdbm/optiondb.scm index 25bfe24bb..dc780981d 100644 --- a/src/gdbm/optiondb.scm +++ b/src/gdbm/optiondb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- |# -(define-load-option 'GDBM2 +(define-load-option 'GDBM (standard-system-loader ".")) (further-load-options diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac index 9138c6d01..28fb21468 100644 --- a/src/microcode/configure.ac +++ b/src/microcode/configure.ac @@ -140,11 +140,6 @@ AC_ARG_WITH([mcrypt], [Use mcrypt library if available [[yes]]])) : ${with_mcrypt='yes'} -AC_ARG_WITH([gdbm], - AS_HELP_STRING([--with-gdbm], - [Use gdbm library if available [[yes]]])) -: ${with_gdbm='yes'} - AC_ARG_WITH([db-4], AS_HELP_STRING([--with-db-4], [Use Berkeley DB v4 library if available [[yes]]])) @@ -882,26 +877,6 @@ if test "${with_mcrypt}" != no; then ]) fi -dnl gdbm support -if test "${with_gdbm}" != no; then - if test "${with_gdbm}" != yes; then - CPPFLAGS="${CPPFLAGS} -I${with_gdbm}/include" - LDFLAGS="${LDFLAGS} -L${with_gdbm}/lib" - fi - AC_CHECK_HEADER([gdbm.h], - [ - AC_DEFINE([HAVE_GDBM_H], [1], - [Define to 1 if you have the header file.]) - AC_CHECK_LIB([gdbm], [gdbm_open], - [ - AC_DEFINE([HAVE_LIBGDBM], [1], - [Define to 1 if you have the `gdbm' library (-lgdbm).]) - MODULE_LIBS="-lgdbm ${MODULE_LIBS}" - MODULE_BASES="${MODULE_BASES} prgdbm" - ]) - ]) -fi - dnl DB v4 support if test "${with_db_4}" != no; then if test "${with_db_4}" != yes; then diff --git a/src/microcode/makegen/Makefile.in.in b/src/microcode/makegen/Makefile.in.in index 9582b5f6b..52a7951db 100644 --- a/src/microcode/makegen/Makefile.in.in +++ b/src/microcode/makegen/Makefile.in.in @@ -197,9 +197,6 @@ prbfish.so: prbfish.o @MODULE_LOADER@ prmcrypt.so: prmcrypt.o @MODULE_LOADER@ $(LINK_MODULE) prmcrypt.o -lmcrypt $(MODULE_LIBS) -prgdbm.so: prgdbm.o @MODULE_LOADER@ - $(LINK_MODULE) prgdbm.o -lgdbm $(MODULE_LIBS) - prdb4.so: prdb4.o @MODULE_LOADER@ $(LINK_MODULE) prdb4.o -ldb-4 $(MODULE_LIBS) diff --git a/src/microcode/makegen/files-optional.scm b/src/microcode/makegen/files-optional.scm index a5430411d..df88f1032 100644 --- a/src/microcode/makegen/files-optional.scm +++ b/src/microcode/makegen/files-optional.scm @@ -29,7 +29,6 @@ USA. "cmpint" "comutl" "prbfish" -"prgdbm" "prmcrypt" "prpgsql" "pruxdld" diff --git a/src/microcode/ntutl/makefile b/src/microcode/ntutl/makefile index de17c8a8f..39b116816 100644 --- a/src/microcode/ntutl/makefile +++ b/src/microcode/ntutl/makefile @@ -27,9 +27,9 @@ #### Makefile for Scheme under Win32 compiled by Microsoft Visual C++. !include -#USER_PRIM_SOURCES = prbfish.c prgdbm.c prmd5.c prpgsql.c -#USER_PRIM_OBJECTS = prbfish.obj prgdbm.obj prmd5.obj prpgsql.obj -#USER_LIBS = blowfish.lib gdbm.lib md5.lib pq.lib +#USER_PRIM_SOURCES = prbfish.c prmd5.c prpgsql.c +#USER_PRIM_OBJECTS = prbfish.obj prmd5.obj prpgsql.obj +#USER_LIBS = blowfish.lib md5.lib pq.lib # **** Microsoft supplies their assembler as a separate product, and # **** we don't currently have a copy, so use the Watcom assembler. @@ -470,7 +470,6 @@ vector.obj: vector.c $(SCHEME_H) $(PRIMS_H) wind.obj: wind.c $(OBSTACK_H) $(DSTACK_H) $(OUTF_H) prbfish.obj: prbfish.c $(SCHEME_H) $(PRIMS_H) -prgdbm.obj: prgdbm.c $(SCHEME_H) $(PRIMS_H) $(OS_H) prmd5.obj: prmd5.c $(SCHEME_H) $(PRIMS_H) prpgsql.obj: prpgsql.c $(SCHEME_H) $(PRIMS_H) $(USRDEF_H) $(OS_H) prosenv.obj: prosenv.c $(SCHEME_H) $(PRIMS_H) $(OSENV_H) $(OSTOP_H) $(LIMITS_H) diff --git a/src/microcode/ntutl/makefile.wcc b/src/microcode/ntutl/makefile.wcc index 4d6995ea9..645af69f6 100644 --- a/src/microcode/ntutl/makefile.wcc +++ b/src/microcode/ntutl/makefile.wcc @@ -27,9 +27,9 @@ #### Makefile for Scheme under Win32 compiled by Watcom C/C++ ### This makefile is meant to be used with Watcom make. -USER_PRIM_SOURCES = # prbfish.c prgdbm.c prmd5.c prpgsql.c -USER_PRIM_OBJECTS = # prbfish.obj prgdbm.obj prmd5.obj prpgsql.obj -USER_LIBS = library wsock32.lib #,blowfish.lib,gdbm.lib,md5.lib,pq.lib +USER_PRIM_SOURCES = # prbfish.c prmd5.c prpgsql.c +USER_PRIM_OBJECTS = # prbfish.obj prmd5.obj prpgsql.obj +USER_LIBS = library wsock32.lib #,blowfish.lib,md5.lib,pq.lib CC = wcc386 M4 = m4 diff --git a/src/microcode/prgdbm.c b/src/microcode/prgdbm.c deleted file mode 100644 index 17502e09b..000000000 --- a/src/microcode/prgdbm.c +++ /dev/null @@ -1,277 +0,0 @@ -/* -*-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, 2014, 2015, 2016, - 2017, 2018 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 "scheme.h" -#include "prims.h" -#include "os.h" - -#ifdef HAVE_GDBM_H -# include -#endif - -/* Allocation Tables */ - -struct allocation_table -{ - void ** items; - int length; -}; - -static void -allocation_table_initialize (struct allocation_table * table) -{ - (table -> length) = 0; -} - -static unsigned int -allocate_table_index (struct allocation_table * table, void * item) -{ - unsigned int length = (table -> length); - unsigned int new_length; - void ** items = (table -> items); - void ** new_items; - void ** scan; - void ** end; - if (length == 0) - { - new_length = 4; - new_items = (OS_malloc ((sizeof (void *)) * new_length)); - } - else - { - scan = items; - end = (scan + length); - while (scan < end) - if ((*scan++) == 0) - { - (*--scan) = item; - return (scan - items); - } - new_length = (length * 2); - new_items = (OS_realloc (items, ((sizeof (void *)) * new_length))); - } - scan = (new_items + length); - end = (new_items + new_length); - (*scan++) = item; - while (scan < end) - (*scan++) = 0; - (table -> items) = new_items; - (table -> length) = new_length; - return (length); -} - -static void * -allocation_item_arg (unsigned int arg, struct allocation_table * table) -{ - unsigned int index = (arg_ulong_index_integer (arg, (table -> length))); - void * item = ((table -> items) [index]); - if (item == 0) - error_bad_range_arg (arg); - return (item); -} - -static struct allocation_table dbf_table; - -#define DBF_VAL(dbf) \ - (ulong_to_integer (allocate_table_index ((&dbf_table), ((void *) (dbf))))) - -#define DBF_ARG(arg) \ - ((GDBM_FILE) (allocation_item_arg ((arg), (&dbf_table)))) - -#define GDBM_ERROR_VAL() \ - (char_pointer_to_string (gdbm_strerror (gdbm_errno))) - -#define VOID_GDBM_CALL(expression) \ - (((expression) == 0) ? SHARP_F : (GDBM_ERROR_VAL ())) - -static datum -arg_datum (int arg) -{ - datum d; - CHECK_ARG (arg, STRING_P); - (d . dptr) = (STRING_POINTER (ARG_REF (arg))); - (d . dsize) = (STRING_LENGTH (ARG_REF (arg))); - return (d); -} - -static SCHEME_OBJECT -datum_to_object (datum d) -{ - if (d . dptr) - { - SCHEME_OBJECT result = (allocate_string (d . dsize)); - const char * scan_d = (d . dptr); - const char * end_d = (scan_d + (d . dsize)); - char * scan_result = (STRING_POINTER (result)); - while (scan_d < end_d) - (*scan_result++) = (*scan_d++); - free (d . dptr); - return (result); - } - else - return (SHARP_F); -} - -static void -gdbm_fatal_error (const char * msg) -{ - outf_error ("\ngdbm: %s\n", msg); - outf_flush_error (); - error_external_return (); -} - -DEFINE_PRIMITIVE ("GDBM-OPEN", Prim_gdbm_open, 4, 4, 0) -{ - static int initialization_done = 0; - PRIMITIVE_HEADER (4); - if (!initialization_done) - { - allocation_table_initialize (&dbf_table); - initialization_done = 1; - } - { - GDBM_FILE dbf = (gdbm_open ((STRING_ARG (1)), - (arg_integer (2)), - (arg_integer (3)), - (arg_integer (4)), - gdbm_fatal_error)); - PRIMITIVE_RETURN ((dbf == 0) ? (GDBM_ERROR_VAL ()) : (DBF_VAL (dbf))); - } -} - -DEFINE_PRIMITIVE ("GDBM-CLOSE", Prim_gdbm_close, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - gdbm_close (DBF_ARG (1)); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("GDBM-STORE", Prim_gdbm_store, 4, 4, 0) -{ - PRIMITIVE_HEADER (4); - { - int result = (gdbm_store ((DBF_ARG (1)), - (arg_datum (2)), - (arg_datum (3)), - (arg_integer (4)))); - PRIMITIVE_RETURN - ((result < 0) ? (GDBM_ERROR_VAL ()) : (BOOLEAN_TO_OBJECT (!result))); - } -} - -DEFINE_PRIMITIVE ("GDBM-FETCH", Prim_gdbm_fetch, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - PRIMITIVE_RETURN - (datum_to_object (gdbm_fetch ((DBF_ARG (1)), (arg_datum (2))))); -} - -DEFINE_PRIMITIVE ("GDBM-EXISTS", Prim_gdbm_exists, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - PRIMITIVE_RETURN - (BOOLEAN_TO_OBJECT (gdbm_exists ((DBF_ARG (1)), (arg_datum (2))))); -} - -DEFINE_PRIMITIVE ("GDBM-DELETE", Prim_gdbm_delete, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - PRIMITIVE_RETURN - (((gdbm_delete ((DBF_ARG (1)), (arg_datum (2)))) == 0) - ? SHARP_T - : (gdbm_errno == GDBM_ITEM_NOT_FOUND) - ? SHARP_F - : (GDBM_ERROR_VAL ())); -} - -DEFINE_PRIMITIVE ("GDBM-FIRSTKEY", Prim_gdbm_firstkey, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - PRIMITIVE_RETURN (datum_to_object (gdbm_firstkey (DBF_ARG (1)))); -} - -DEFINE_PRIMITIVE ("GDBM-NEXTKEY", Prim_gdbm_nextkey, 2, 2, 0) -{ - PRIMITIVE_HEADER (2); - PRIMITIVE_RETURN - (datum_to_object (gdbm_nextkey ((DBF_ARG (1)), (arg_datum (2))))); -} - -DEFINE_PRIMITIVE ("GDBM-REORGANIZE", Prim_gdbm_reorganize, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - PRIMITIVE_RETURN (VOID_GDBM_CALL (gdbm_reorganize (DBF_ARG (1)))); -} - -DEFINE_PRIMITIVE ("GDBM-SYNC", Prim_gdbm_sync, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - gdbm_sync (DBF_ARG (1)); - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("GDBM-VERSION", Prim_gdbm_version, 0, 0, 0) -{ - PRIMITIVE_HEADER (0); - PRIMITIVE_RETURN (char_pointer_to_string (gdbm_version)); -} - -DEFINE_PRIMITIVE ("GDBM-SETOPT", Prim_gdbm_setopt, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - { - int value = (arg_integer (3)); - PRIMITIVE_RETURN - (VOID_GDBM_CALL (gdbm_setopt ((DBF_ARG (1)), - (arg_integer (2)), - (&value), - (sizeof (int))))); - } -} - -#ifdef COMPILE_AS_MODULE - -char * -dload_initialize_file (void) -{ - declare_primitive ("GDBM-OPEN", Prim_gdbm_open, 4, 4, 0); - declare_primitive ("GDBM-CLOSE", Prim_gdbm_close, 1, 1, 0); - declare_primitive ("GDBM-STORE", Prim_gdbm_store, 4, 4, 0); - declare_primitive ("GDBM-FETCH", Prim_gdbm_fetch, 2, 2, 0); - declare_primitive ("GDBM-EXISTS", Prim_gdbm_exists, 2, 2, 0); - declare_primitive ("GDBM-DELETE", Prim_gdbm_delete, 2, 2, 0); - declare_primitive ("GDBM-FIRSTKEY", Prim_gdbm_firstkey, 1, 1, 0); - declare_primitive ("GDBM-NEXTKEY", Prim_gdbm_nextkey, 2, 2, 0); - declare_primitive ("GDBM-REORGANIZE", Prim_gdbm_reorganize, 1, 1, 0); - declare_primitive ("GDBM-SYNC", Prim_gdbm_sync, 1, 1, 0); - declare_primitive ("GDBM-VERSION", Prim_gdbm_version, 0, 0, 0); - declare_primitive ("GDBM-SETOPT", Prim_gdbm_setopt, 3, 3, 0); - return ("#prgdbm"); -} - -#endif /* COMPILE_AS_MODULE */ diff --git a/src/runtime/gdbm.scm b/src/runtime/gdbm.scm index fafc84e7c..c97d481d9 100644 --- a/src/runtime/gdbm.scm +++ b/src/runtime/gdbm.scm @@ -29,106 +29,70 @@ USA. (declare (usual-integrations)) -(define gdbm-initialized? #f) -(define gdbf-finalizer) +;;; Access to the gdbm library is now accomplished with the FFI +;;; rather than a microcode module. The bindings in this package are +;;; linked to those in the (gdbm) package after the plugin is loaded. -(define (gdbm-available?) - (load-library-object-file "prgdbm" #f) - (and (implemented-primitive-procedure? (ucode-primitive gdbm-open 4)) - (begin - (if (not gdbm-initialized?) - (begin - (set! gdbf-finalizer - (make-gc-finalizer (ucode-primitive gdbm-close 1) - gdbf? - gdbf-descriptor - set-gdbf-descriptor!)) - (set! gdbm-initialized? #t))) - #t))) - -;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who can -;; create the database. -(define gdbm_reader 0) ;A reader. -(define gdbm_writer 1) ;A writer. -(define gdbm_wrcreat 2) ;A writer. Create the db if needed. -(define gdbm_newdb 3) ;A writer. Always create a new db. -(define gdbm_fast 16) ;Write fast! => No fsyncs. - -(define (gdbm-open filename block-size flags mode) - (if (not (gdbm-available?)) - (error "This Scheme system was built without gdbm support.")) - (let ((filename (->namestring (merge-pathnames filename)))) - (without-interruption - (lambda () - (add-to-gc-finalizer! - gdbf-finalizer - (make-gdbf (gdbm-error ((ucode-primitive gdbm-open 4) - filename block-size flags mode)) - filename)))))) - -(define (gdbm-close gdbf) - (if (not (gdbf? gdbf)) - (error:wrong-type-argument gdbf "gdbm handle" 'gdbm-close)) - (remove-from-gc-finalizer! gdbf-finalizer gdbf)) - -;; Parameters to gdbm_store for simple insertion or replacement in the -;; case that the key is already in the database. -(define gdbm_insert 0) ;Never replace old data with new. -(define gdbm_replace 1) ;Always replace old data with new. - -(define (gdbm-store gdbf key datum flags) - (gdbm-error - ((ucode-primitive gdbm-store 4) (guarantee-gdbf gdbf 'gdbm-store) - key datum flags))) - -(define (gdbm-fetch gdbf key) - ((ucode-primitive gdbm-fetch 2) (guarantee-gdbf gdbf 'gdbm-fetch) key)) - -(define (gdbm-exists? gdbf key) - ((ucode-primitive gdbm-exists 2) (guarantee-gdbf gdbf 'gdbm-exists?) key)) - -(define (gdbm-delete gdbf key) - (gdbm-error - ((ucode-primitive gdbm-delete 2) (guarantee-gdbf gdbf 'gdbm-delete) key))) - -(define (gdbm-firstkey gdbf) - ((ucode-primitive gdbm-firstkey 1) (guarantee-gdbf gdbf 'gdbm-firstkey))) +(define linked? #f) -(define (gdbm-nextkey gdbf key) - ((ucode-primitive gdbm-nextkey 2) (guarantee-gdbf gdbf 'gdbm-nextkey) key)) - -(define (gdbm-reorganize gdbf) - (gdbm-error - ((ucode-primitive gdbm-reorganize 1) - (guarantee-gdbf gdbf 'gdbm-reorganize)))) - -(define (gdbm-sync gdbf) - ((ucode-primitive gdbm-sync 1) (guarantee-gdbf gdbf 'gdbm-sync))) - -(define (gdbm-version) - ((ucode-primitive gdbm-version 0))) - -;; Parameters to gdbm_setopt, specifing the type of operation to perform. -(define gdbm_cachesize 1) ;Set the cache size. -(define gdbm_fastmode 2) ;Toggle fast mode. - -(define (gdbm-setopt gdbf opt val) - (gdbm-error - ((ucode-primitive gdbm-setopt 3) (guarantee-gdbf gdbf 'gdbm-setopt) - opt val))) - -(define-structure (gdbf - (print-procedure (standard-print-method 'gdbf - (lambda (gdbf) - (list (gdbf-filename gdbf)))))) - descriptor - (filename #f read-only #t)) - -(define (guarantee-gdbf gdbf procedure) - (if (gdbf? gdbf) - (or (gdbf-descriptor gdbf) (error:bad-range-argument gdbf procedure)) - (error:wrong-type-argument gdbf "gdbm handle" procedure))) - -(define (gdbm-error object) - (if (string? object) (error "gdbm error:" object)) - object) \ No newline at end of file +(define (gdbm-available?) + (and (plugin-available? "gdbm") + (or linked? + (begin + (load-option 'gdbm) + (link!) + #t)))) + +(define (link!) + (for-each + (let ((runtime (->environment '(runtime gdbm))) + (gdbm (->environment '(gdbm)))) + (lambda (name) + (environment-link-name runtime gdbm name))) + names) + (set! linked? #t)) + +(define names + '(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)) + +(define gdbm-close) +(define gdbm-delete) +(define gdbm-exists?) +(define gdbm-fetch) +(define gdbm-firstkey) +(define gdbm-nextkey) +(define gdbm-open) +(define gdbm-reorganize) +(define gdbm-setopt) +(define gdbm-store) +(define gdbm-sync) +(define gdbm-version) +(define gdbm_cachesize) +(define gdbm_fast) +(define gdbm_fastmode) +(define gdbm_insert) +(define gdbm_newdb) +(define gdbm_reader) +(define gdbm_replace) +(define gdbm_wrcreat) +(define gdbm_writer) \ No newline at end of file diff --git a/src/runtime/optiondb.scm b/src/runtime/optiondb.scm index 6e841e572..f5bf912b5 100644 --- a/src/runtime/optiondb.scm +++ b/src/runtime/optiondb.scm @@ -66,7 +66,6 @@ USA. '((compress (runtime compress) #f "cpress") (dosprocess () #f "dosproc") (format (runtime format) (initialize-package!) "format") - (gdbm (runtime gdbm) #f "gdbm") (mime-codec (runtime mime-codec) #f "mime-codec") (ordered-vector (runtime ordered-vector) #f "ordvec") (postgresql (runtime postgresql) #f "pgsql") diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 6ebfe61e1..3e8f7c75c 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -5177,7 +5177,7 @@ USA. ((load) "gdbm") (else)) (parent (runtime)) - (export () + (export () deprecated:gdbm gdbm-available? gdbm-close gdbm-delete -- 2.25.1