[perl #114350] access to sdbm_prep()

This allows the .dir and .pag filenames to be specified explicitly

3 files changed, 77 insertions, 4 deletions

diff --git a/ext/SDBM_File/SDBM_File.pm b/ext/SDBM_File/SDBM_File.pm
index 5f7bc77ff5..ca181b79bd 100644
--- a/ext/SDBM_File/SDBM_File.pm
+++ b/ext/SDBM_File/SDBM_File.pm
@@ -62,7 +62,8 @@ package to perform the functions of the hash.)
 
 =item 3. 
 
-The name of the file you want to tie to the hash.  
+The name of the file you want to tie to the hash.  If the page file
+name is supplied, this becomes the directory file name.
 
 =item 4.
 
@@ -94,8 +95,40 @@ The default permissions to use if a new file is created.  The actual
 permissions will be modified by the user's umask, so you should
 probably use 0666 here. (See L<perlfunc/umask>.)
 
+=item 6.
+
+Optionally, the name of the data page file (normally F<<
+I<filename>.pag >>.  If this is supplied, then the first filename is
+treated as the directory file (normally F<< I<filename>.dir >> based
+on the first filename parameter).
+
+=back
+
+=head1 EXPORTS
+
+SDBM_File optionally exports the following constants:
+
+=over
+
+=item *
+
+C<PAGFEXT> - the extension used for the page file, usually C<.pag>.
+
+=item *
+
+C<DIRFEXT> - the extension used for the directory file, C<.dir>
+everywhere but VMS, where it is C<.sdbm_dir>.
+
+=item *
+
+C<PAIRMAX> - the maximum size of a stored hash entry, including the
+length of both the key and value.
+
 =back
 
+These constants can also be used with fully qualified names,
+eg. C<SDBM_File::PAGFEXT>.
+
 =head1 DIAGNOSTICS
 
 On failure, the C<tie> call returns an undefined value and probably
diff --git a/ext/SDBM_File/SDBM_File.xs b/ext/SDBM_File/SDBM_File.xs
index d47e72674d..070f0745ad 100644
--- a/ext/SDBM_File/SDBM_File.xs
+++ b/ext/SDBM_File/SDBM_File.xs
@@ -19,7 +19,6 @@ typedef SDBM_File_type * SDBM_File ;
 typedef datum datum_key ;
 typedef datum datum_value ;
 
-#define sdbm_TIEHASH(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode)
 #define sdbm_FETCH(db,key)			sdbm_fetch(db->dbp,key)
 #define sdbm_STORE(db,key,value,flags)		sdbm_store(db->dbp,key,value,flags)
 #define sdbm_DELETE(db,key)			sdbm_delete(db->dbp,key)
@@ -31,17 +30,24 @@ typedef datum datum_value ;
 MODULE = SDBM_File	PACKAGE = SDBM_File	PREFIX = sdbm_
 
 SDBM_File
-sdbm_TIEHASH(dbtype, filename, flags, mode)
+sdbm_TIEHASH(dbtype, filename, flags, mode, pagname=NULL)
 	char *		dbtype
 	char *		filename
 	int		flags
 	int		mode
+	char *		pagname
 	CODE:
 	{
 	    DBM * 	dbp ;
 
 	    RETVAL = NULL ;
-	    if ((dbp = sdbm_open(filename,flags,mode))) {
+	    if (pagname == NULL) {
+	        dbp = sdbm_open(filename, flags, mode);
+	    }
+	    else {
+	        dbp = sdbm_prep(filename, pagname, flags, mode);
+	    }
+	    if (dbp) {
 	        RETVAL = (SDBM_File)safecalloc(1, sizeof(SDBM_File_type));
 		RETVAL->dbp = dbp ;
 	    }
diff --git a/ext/SDBM_File/t/prep.t b/ext/SDBM_File/t/prep.t
new file mode 100644
index 0000000000..a222a648f0
--- /dev/null
+++ b/ext/SDBM_File/t/prep.t
@@ -0,0 +1,34 @@
+#!./perl
+use strict;
+use Test::More tests => 4;
+
+use SDBM_File;
+use File::Temp 'tempfile';
+use Fcntl;
+
+my ($dirfh, $dirname) = tempfile();
+my ($pagfh, $pagname) = tempfile();
+
+# close so Win32 allows them to be re-opened
+close $dirfh;
+close $pagfh;
+
+{
+    my %h;
+
+    ok(eval { tie %h, "SDBM_File", $dirname, O_CREAT | O_RDWR | O_TRUNC, 0640, $pagname; 1 },
+       "create SDBM with explicit filenames")
+      or diag $@;
+    is(keys %h, 0, "should be empty");
+
+    # basic sanity checks, the real storage checks are done by sdbm.t
+    $h{abc} = 1;
+    $h{def} = 1;
+}
+
+{
+    my %h;
+    ok(eval { tie %h, "SDBM_File", $dirname, O_RDWR, 0640, $pagname; 1 },
+       "open SDBM with explicit filenames");
+    is_deeply([ sort keys  %h] , [ qw(abc def) ], "should have two keys");
+}