Perl 5.28.0

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)