diff options
author | Sergey Poznyakoff <gray@gnu.org> | 2018-07-03 15:01:55 +0300 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org> | 2018-07-03 15:01:55 +0300 |
commit | 3a1d5f8bdc29803fb7a6713515f2c0c332e379fc (patch) | |
tree | f95c9240257bec56094b938541c80aa7b61c62f3 | |
download | GDBM_File-3a1d5f8bdc29803fb7a6713515f2c0c332e379fc.tar.gz GDBM_File-3a1d5f8bdc29803fb7a6713515f2c0c332e379fc.tar.bz2 |
Perl 5.28.0
-rw-r--r-- | GDBM_File.pm | 80 | ||||
-rw-r--r-- | GDBM_File.xs | 203 | ||||
-rw-r--r-- | Makefile.PL | 20 | ||||
-rw-r--r-- | hints/sco.pl | 2 | ||||
-rw-r--r-- | t/fatal.t | 49 | ||||
-rw-r--r-- | t/gdbm.t | 6 | ||||
-rw-r--r-- | typemap | 56 |
7 files changed, 416 insertions, 0 deletions
diff --git a/GDBM_File.pm b/GDBM_File.pm new file mode 100644 index 0000000..a33b8b5 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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'; @@ -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); |