summaryrefslogtreecommitdiffabout
authorSergey Poznyakoff <gray@gnu.org>2018-07-03 12:01:55 (GMT)
committer Sergey Poznyakoff <gray@gnu.org>2018-07-03 12:01:55 (GMT)
commit3a1d5f8bdc29803fb7a6713515f2c0c332e379fc (patch) (side-by-side diff)
treef95c9240257bec56094b938541c80aa7b61c62f3
downloadGDBM_File-3a1d5f8bdc29803fb7a6713515f2c0c332e379fc.tar.gz
GDBM_File-3a1d5f8bdc29803fb7a6713515f2c0c332e379fc.tar.bz2
Perl 5.28.0
Diffstat (more/less context) (ignore whitespace changes)
-rw-r--r--GDBM_File.pm80
-rw-r--r--GDBM_File.xs203
-rw-r--r--Makefile.PL20
-rw-r--r--hints/sco.pl2
-rw-r--r--t/fatal.t49
-rw-r--r--t/gdbm.t6
-rw-r--r--typemap56
7 files changed, 416 insertions, 0 deletions
diff --git a/GDBM_File.pm b/GDBM_File.pm
new file mode 100644
index 0000000..a33b8b5
--- a/dev/null
+++ b/GDBM_File.pm
@@ -0,0 +1,80 @@
+# GDBM_File.pm -- Perl 5 interface to GNU gdbm library.
+
+=head1 NAME
+
+GDBM_File - Perl5 access to the gdbm library.
+
+=head1 SYNOPSIS
+
+ use GDBM_File ;
+ tie %hash, 'GDBM_File', $filename, &GDBM_WRCREAT, 0640;
+ # Use the %hash array.
+ untie %hash ;
+
+=head1 DESCRIPTION
+
+B<GDBM_File> is a module which allows Perl programs to make use of the
+facilities provided by the GNU gdbm library. If you intend to use this
+module you should really have a copy of the gdbm manualpage at hand.
+
+Most of the libgdbm.a functions are available through the GDBM_File
+interface.
+
+Unlike Perl's built-in hashes, it is not safe to C<delete> the current
+item from a GDBM_File tied hash while iterating over it with C<each>.
+This is a limitation of the gdbm library.
+
+=head1 AVAILABILITY
+
+gdbm is available from any GNU archive. The master site is
+C<ftp.gnu.org>, but you are strongly urged to use one of the many
+mirrors. You can obtain a list of mirror sites from
+L<http://www.gnu.org/order/ftp.html>.
+
+=head1 BUGS
+
+The available functions and the gdbm/perl interface need to be documented.
+
+The GDBM error number and error message interface needs to be added.
+
+=head1 SEE ALSO
+
+L<perl(1)>, L<DB_File(3)>, L<perldbmfilter>.
+
+=cut
+
+package GDBM_File;
+
+use strict;
+use warnings;
+our($VERSION, @ISA, @EXPORT);
+
+require Carp;
+require Tie::Hash;
+require Exporter;
+require XSLoader;
+@ISA = qw(Tie::Hash Exporter);
+@EXPORT = qw(
+ GDBM_CACHESIZE
+ GDBM_CENTFREE
+ GDBM_COALESCEBLKS
+ GDBM_FAST
+ GDBM_FASTMODE
+ GDBM_INSERT
+ GDBM_NEWDB
+ GDBM_NOLOCK
+ GDBM_OPENMASK
+ GDBM_READER
+ GDBM_REPLACE
+ GDBM_SYNC
+ GDBM_SYNCMODE
+ GDBM_WRCREAT
+ GDBM_WRITER
+);
+
+# This module isn't dual life, so no need for dev version numbers.
+$VERSION = '1.17';
+
+XSLoader::load();
+
+1;
diff --git a/GDBM_File.xs b/GDBM_File.xs
new file mode 100644
index 0000000..7f91049
--- a/dev/null
+++ b/GDBM_File.xs
@@ -0,0 +1,203 @@
+#define PERL_NO_GET_CONTEXT
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include <gdbm.h>
+#include <fcntl.h>
+
+#define fetch_key 0
+#define store_key 1
+#define fetch_value 2
+#define store_value 3
+
+typedef struct {
+ GDBM_FILE dbp ;
+ SV * filter[4];
+ int filtering ;
+ } GDBM_File_type;
+
+typedef GDBM_File_type * GDBM_File ;
+typedef datum datum_key ;
+typedef datum datum_value ;
+typedef datum datum_key_copy;
+
+#if defined(GDBM_VERSION_MAJOR) && defined(GDBM_VERSION_MINOR) \
+ && GDBM_VERSION_MAJOR > 1 || \
+ (GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 9)
+typedef void (*FATALFUNC)(const char *);
+#else
+typedef void (*FATALFUNC)();
+#endif
+
+#ifndef GDBM_FAST
+static int
+not_here(char *s)
+{
+ croak("GDBM_File::%s not implemented on this architecture", s);
+ return -1;
+}
+#endif
+
+/* GDBM allocates the datum with system malloc() and expects the user
+ * to free() it. So we either have to free() it immediately, or have
+ * perl free() it when it deallocates the SV, depending on whether
+ * perl uses malloc()/free() or not. */
+static void
+output_datum(pTHX_ SV *arg, char *str, int size)
+{
+ sv_setpvn(arg, str, size);
+# undef free
+ free(str);
+}
+
+/* Versions of gdbm prior to 1.7x might not have the gdbm_sync,
+ gdbm_exists, and gdbm_setopt functions. Apparently Slackware
+ (Linux) 2.1 contains gdbm-1.5 (which dates back to 1991).
+*/
+#ifndef GDBM_FAST
+#define gdbm_exists(db,key) not_here("gdbm_exists")
+#define gdbm_sync(db) (void) not_here("gdbm_sync")
+#define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt")
+#endif
+
+static void
+croak_string(const char *message) {
+ Perl_croak_nocontext("%s", message);
+}
+
+#include "const-c.inc"
+
+MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_
+
+INCLUDE: const-xs.inc
+
+GDBM_File
+gdbm_TIEHASH(dbtype, name, read_write, mode)
+ char * dbtype
+ char * name
+ int read_write
+ int mode
+ PREINIT:
+ GDBM_FILE dbp;
+ CODE:
+ dbp = gdbm_open(name, 0, read_write, mode, (FATALFUNC)croak_string);
+ if (!dbp && gdbm_errno == GDBM_BLOCK_SIZE_ERROR) {
+ /*
+ * By specifying a block size of 0 above, we asked gdbm to
+ * default to the filesystem's block size. That's usually the
+ * right size to choose. But some versions of gdbm require
+ * a power-of-two block size, and some unusual filesystems
+ * or devices have a non-power-of-two size that cause this
+ * defaulting to fail. In that case, force an acceptable
+ * block size.
+ */
+ dbp = gdbm_open(name, 4096, read_write, mode,
+ (FATALFUNC)croak_string);
+ }
+ if (dbp) {
+ RETVAL = (GDBM_File)safecalloc(1, sizeof(GDBM_File_type));
+ RETVAL->dbp = dbp;
+ } else {
+ RETVAL = NULL;
+ }
+ OUTPUT:
+ RETVAL
+
+
+#define gdbm_close(db) gdbm_close(db->dbp)
+void
+gdbm_close(db)
+ GDBM_File db
+ CLEANUP:
+
+void
+gdbm_DESTROY(db)
+ GDBM_File db
+ PREINIT:
+ int i = store_value;
+ CODE:
+ gdbm_close(db);
+ do {
+ if (db->filter[i])
+ SvREFCNT_dec(db->filter[i]);
+ } while (i-- > 0);
+ safefree(db);
+
+#define gdbm_FETCH(db,key) gdbm_fetch(db->dbp,key)
+datum_value
+gdbm_FETCH(db, key)
+ GDBM_File db
+ datum_key_copy key
+
+#define gdbm_STORE(db,key,value,flags) gdbm_store(db->dbp,key,value,flags)
+int
+gdbm_STORE(db, key, value, flags = GDBM_REPLACE)
+ GDBM_File db
+ datum_key key
+ datum_value value
+ int flags
+ CLEANUP:
+ if (RETVAL) {
+ if (RETVAL < 0 && errno == EPERM)
+ croak("No write permission to gdbm file");
+ croak("gdbm store returned %d, errno %d, key \"%.*s\"",
+ RETVAL,errno,key.dsize,key.dptr);
+ }
+
+#define gdbm_DELETE(db,key) gdbm_delete(db->dbp,key)
+int
+gdbm_DELETE(db, key)
+ GDBM_File db
+ datum_key key
+
+#define gdbm_FIRSTKEY(db) gdbm_firstkey(db->dbp)
+datum_key
+gdbm_FIRSTKEY(db)
+ GDBM_File db
+
+#define gdbm_NEXTKEY(db,key) gdbm_nextkey(db->dbp,key)
+datum_key
+gdbm_NEXTKEY(db, key)
+ GDBM_File db
+ datum_key key
+
+#define gdbm_reorganize(db) gdbm_reorganize(db->dbp)
+int
+gdbm_reorganize(db)
+ GDBM_File db
+
+
+#define gdbm_sync(db) gdbm_sync(db->dbp)
+void
+gdbm_sync(db)
+ GDBM_File db
+
+#define gdbm_EXISTS(db,key) gdbm_exists(db->dbp,key)
+int
+gdbm_EXISTS(db, key)
+ GDBM_File db
+ datum_key key
+
+#define gdbm_setopt(db,optflag, optval, optlen) gdbm_setopt(db->dbp,optflag, optval, optlen)
+int
+gdbm_setopt (db, optflag, optval, optlen)
+ GDBM_File db
+ int optflag
+ int &optval
+ int optlen
+
+
+SV *
+filter_fetch_key(db, code)
+ GDBM_File db
+ SV * code
+ SV * RETVAL = &PL_sv_undef ;
+ ALIAS:
+ GDBM_File::filter_fetch_key = fetch_key
+ GDBM_File::filter_store_key = store_key
+ GDBM_File::filter_fetch_value = fetch_value
+ GDBM_File::filter_store_value = store_value
+ CODE:
+ DBM_setFilter(db->filter[ix], code);
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..2a44d3e
--- a/dev/null
+++ b/Makefile.PL
@@ -0,0 +1,20 @@
+use ExtUtils::MakeMaker;
+use ExtUtils::Constant 0.11 'WriteConstants';
+WriteMakefile(
+ NAME => 'GDBM_File',
+ LIBS => ["-lgdbm", "-ldbm"],
+ XSPROTOARG => '-noprototypes', # XXX remove later?
+ VERSION_FROM => 'GDBM_File.pm',
+ realclean => {FILES=> 'const-c.inc const-xs.inc'},
+ XS_VERSION => eval MM->parse_version('GDBM_File.pm'), #silence warnings if we are a dev release
+);
+WriteConstants(
+ NAME => 'GDBM_File',
+ DEFAULT_TYPE => 'IV',
+ BREAKOUT_AT => 8,
+ PROXYSUBS => {autoload => 1},
+ NAMES => [qw(GDBM_CACHESIZE GDBM_CENTFREE GDBM_COALESCEBLKS
+ GDBM_FAST GDBM_FASTMODE GDBM_INSERT GDBM_NEWDB GDBM_NOLOCK
+ GDBM_OPENMASK GDBM_READER GDBM_REPLACE GDBM_SYNC GDBM_SYNCMODE
+ GDBM_WRCREAT GDBM_WRITER)],
+);
diff --git a/hints/sco.pl b/hints/sco.pl
new file mode 100644
index 0000000..5c74a77
--- a/dev/null
+++ b/hints/sco.pl
@@ -0,0 +1,2 @@
+# SCO OSR5 needs to link with libc.so again to have C<fsync> defined
+$self->{LIBS} = ['-lgdbm -lc'];
diff --git a/t/fatal.t b/t/fatal.t
new file mode 100644
index 0000000..0e426d4
--- a/dev/null
+++ b/t/fatal.t
@@ -0,0 +1,49 @@
+#!./perl -w
+use strict;
+
+use Test::More;
+use Config;
+
+BEGIN {
+ plan(skip_all => "GDBM_File was not built")
+ unless $Config{extensions} =~ /\bGDBM_File\b/;
+
+ # https://rt.perl.org/Public/Bug/Display.html?id=117967
+ plan(skip_all => "GDBM_File is flaky in $^O")
+ if $^O =~ /darwin/;
+
+ plan(tests => 8);
+ use_ok('GDBM_File');
+}
+
+unlink <Op_dbmx*>;
+
+open my $fh, '<', $^X or die "Can't open $^X: $!";
+my $fileno = fileno $fh;
+isnt($fileno, undef, "Can find next available file descriptor");
+close $fh or die $!;
+
+is((open $fh, "<&=$fileno"), undef,
+ "Check that we cannot open fileno $fileno. \$! is $!");
+
+umask(0);
+my %h;
+isa_ok(tie(%h, 'GDBM_File', 'Op_dbmx', GDBM_WRCREAT, 0640), 'GDBM_File');
+
+isnt((open $fh, "<&=$fileno"), undef, "dup fileno $fileno")
+ or diag("\$! = $!");
+isnt(close $fh, undef,
+ "close fileno $fileno, out from underneath the GDBM_File");
+is(eval {
+ $h{Perl} = 'Rules';
+ untie %h;
+ 1;
+}, undef, 'Trapped error when attempting to write to knobbled GDBM_File');
+
+# Observed "File write error" and "lseek error" from two different systems.
+# So there might be more variants. Important part was that we trapped the error
+# via croak.
+like($@, qr/ at .*\bfatal\.t line \d+\.\n\z/,
+ 'expected error message from GDBM_File');
+
+unlink <Op_dbmx*>;
diff --git a/t/gdbm.t b/t/gdbm.t
new file mode 100644
index 0000000..af9dd38
--- a/dev/null
+++ b/t/gdbm.t
@@ -0,0 +1,6 @@
+#!./perl
+
+$::Create_and_Write = '(GDBM_WRCREAT, GDBM_WRITER)';
+our $DBM_Class = 'GDBM_File';
+
+require '../../t/lib/dbmt_common.pl';
diff --git a/typemap b/typemap
new file mode 100644
index 0000000..8d6edee
--- a/dev/null
+++ b/typemap
@@ -0,0 +1,56 @@
+#
+#################################### DBM SECTION
+#
+
+datum_key T_DATUM_K
+datum_key_copy T_DATUM_K
+datum_value T_DATUM_V
+NDBM_File T_PTROBJ
+GDBM_File T_PTROBJ
+SDBM_File T_PTROBJ
+ODBM_File T_PTROBJ
+DB_File T_PTROBJ
+DBZ_File T_PTROBJ
+
+INPUT
+T_DATUM_K
+ DBM_ckFilter($arg, filter[store_key], \"filter_store_key\");
+ {
+ STRLEN len;
+ $var.dptr = SvPVbyte($arg, len);
+ $var.dsize = (int)len;
+ }
+T_DATUM_K_C
+ {
+ SV * tmpSV;
+ STRLEN len;
+ if (db->filter[store_key]) {
+ tmpSV = sv_2mortal(newSVsv($arg));
+ DBM_ckFilter(tmpSV, filter[store_key], \"filter_store_key\");
+ }
+ else
+ tmpSV = $arg;
+ $var.dptr = SvPVbyte(tmpSV, len);
+ $var.dsize = (int)len;
+ }
+T_DATUM_V
+ DBM_ckFilter($arg, filter[store_value], \"filter_store_value\");
+ if (SvOK($arg)) {
+ STRLEN len;
+ $var.dptr = SvPVbyte($arg, len);
+ $var.dsize = (int)len;
+ }
+ else {
+ $var.dptr = (char *)\"\";
+ /* better would be for .dptr to be const char * */
+ $var.dsize = 0;
+ }
+OUTPUT
+T_DATUM_K
+ output_datum(aTHX_ $arg, $var.dptr, $var.dsize);
+ DBM_ckFilter($arg, filter[fetch_key],\"filter_fetch_key\");
+T_DATUM_V
+ output_datum(aTHX_ $arg, $var.dptr, $var.dsize);
+ DBM_ckFilter($arg, filter[fetch_value],\"filter_fetch_value\");
+T_PTROBJ
+ sv_setref_pv($arg, dbtype, (void*)$var);

Return to:

Send suggestions and report system problems to the System administrator.