From: Paul Marquess Date: Mon, 18 Nov 1996 06:06:27 +0000 (+1200) Subject: DB_File 1.05 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=610ab055100fa571cc7f544c38118f901cbd0eaf;p=p5sagit%2Fp5-mst-13.2.git DB_File 1.05 --- diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index 8f3dd96..fcc84c3 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -1,11 +1,13 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (pmarquess@bfsec.bt.co.uk) -# last modified 4th Sept 1996 -# version 1.03 +# last modified 10th Nov 1996 +# version 1.05 package DB_File::HASHINFO ; +require 5.003 ; + use strict; use Carp; require Tie::Hash; @@ -19,19 +21,21 @@ sub new bless \%x, $pkg ; } + sub TIEHASH { my $pkg = shift ; - bless { 'bsize' => undef, - 'ffactor' => undef, - 'nelem' => undef, - 'cachesize' => undef, + bless { 'bsize' => 0, + 'ffactor' => 0, + 'nelem' => 0, + 'cachesize' => 0, 'hash' => undef, - 'lorder' => undef, + 'lorder' => 0, }, $pkg ; } + sub FETCH { my $self = shift ; @@ -106,12 +110,12 @@ sub TIEHASH { my $pkg = shift ; - bless { 'bval' => undef, - 'cachesize' => undef, - 'psize' => undef, - 'flags' => undef, - 'lorder' => undef, - 'reclen' => undef, + bless { 'bval' => 0, + 'cachesize' => 0, + 'psize' => 0, + 'flags' => 0, + 'lorder' => 0, + 'reclen' => 0, 'bfname' => "", }, $pkg ; } @@ -126,14 +130,14 @@ sub TIEHASH { my $pkg = shift ; - bless { 'flags' => undef, - 'cachesize' => undef, - 'maxkeypage' => undef, - 'minkeypage' => undef, - 'psize' => undef, + bless { 'flags' => 0, + 'cachesize' => 0, + 'maxkeypage' => 0, + 'minkeypage' => 0, + 'psize' => 0, 'compare' => undef, 'prefix' => undef, - 'lorder' => undef, + 'lorder' => 0, }, $pkg ; } @@ -145,13 +149,9 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO) ; use Carp; -$VERSION = "1.03" ; +$VERSION = "1.05" ; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; -#$DB_BTREE = TIEHASH DB_File::BTREEINFO ; -#$DB_HASH = TIEHASH DB_File::HASHINFO ; -#$DB_RECNO = TIEHASH DB_File::RECNOINFO ; - $DB_BTREE = new DB_File::BTREEINFO ; $DB_HASH = new DB_File::HASHINFO ; $DB_RECNO = new DB_File::RECNOINFO ; @@ -232,6 +232,17 @@ bootstrap DB_File $VERSION; # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. +sub TIEHASH +{ + my (@arg) = @_ ; + + $arg[4] = tied %{ $arg[4] } + if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ; + + DoTie_(@arg) ; +} + +*TIEARRAY = \&TIEHASH ; sub get_dup { @@ -249,9 +260,6 @@ sub get_dup my $counter = 0 ; my $status = 0 ; - # get the first value associated with the key, $key - #$db->seq($key, $value, R_CURSOR()) ; - # iterate through the database until either EOF ($status == 0) # or a different key is encountered ($key ne $origkey). for ($status = $db->seq($key, $value, R_CURSOR()) ; @@ -286,7 +294,6 @@ DB_File - Perl5 access to Berkeley DB =head1 SYNOPSIS use DB_File ; - use strict 'untie' ; [$X =] tie %hash, 'DB_File', [$filename, $flags, $mode, $DB_HASH] ; [$X =] tie %hash, 'DB_File', $filename, $flags, $mode, $DB_BTREE ; @@ -532,8 +539,9 @@ This example shows how to create a database, add key/value pairs to the database, delete keys/value pairs and finally how to enumerate the contents of the database. + use strict ; use DB_File ; - use strict 'untie' ; + use vars qw( %h $k $v ) ; tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH or die "Cannot open file 'fruit': $!\n"; @@ -580,8 +588,10 @@ This script shows how to override the default sorting algorithm that BTREE uses. Instead of using the normal lexical ordering, a case insensitive compare function will be used. + use strict ; use DB_File ; - use strict 'untie' ; + + my %h ; sub Compare { @@ -645,9 +655,11 @@ There are some difficulties in using the tied hash interface if you want to manipulate a BTREE database with duplicate keys. Consider this code: + use strict ; use DB_File ; - use strict 'untie' ; - + + use vars qw($filename %h ) ; + $filename = "tree" ; unlink $filename ; @@ -697,9 +709,11 @@ and the API in general. Here is the script above rewritten using the C API method. + use strict ; use DB_File ; - use strict 'untie' ; + use vars qw($filename $x %h $status $key $value) ; + $filename = "tree" ; unlink $filename ; @@ -718,6 +732,7 @@ Here is the script above rewritten using the C API method. # iterate through the btree using seq # and print each key/value pair. + $key = $value = 0 ; for ($status = $x->seq($key, $value, R_FIRST) ; $status == 0 ; $status = $x->seq($key, $value, R_NEXT) ) @@ -762,14 +777,14 @@ value occurred in the BTREE. So assuming the database created above, we can use C like this: - $cnt = $x->get_dup("Wall") ; + my $cnt = $x->get_dup("Wall") ; print "Wall occurred $cnt times\n" ; - %hash = $x->get_dup("Wall", 1) ; + my %hash = $x->get_dup("Wall", 1) ; print "Larry is there\n" if $hash{'Larry'} ; print "There are $hash{'Brick'} Brick Walls\n" ; - @list = $x->get_dup("Wall") ; + my @list = $x->get_dup("Wall") ; print "Wall => [@list]\n" ; @list = $x->get_dup("Smith") ; @@ -799,24 +814,24 @@ is used along with the R_CURSOR flag. Here is the relevant quote from the dbopen man page where it defines the use of the R_CURSOR flag with seq: - Note, for the DB_BTREE access method, the returned key is not necessarily an exact match for the specified key. The returned key is the smallest key greater than or equal to the specified key, permitting partial key matches and range searches. - In the example script below, the C sub uses this feature to find and print the first matching key/value pair given a partial key. + use strict ; use DB_File ; use Fcntl ; - use strict 'untie' ; + + use vars qw($filename $x %h $st $key $value) ; sub match { my $key = shift ; - my $value ; + my $value = 0; my $orig_key = $key ; $x->seq($key, $value, R_CURSOR) ; print "$orig_key\t-> $key\t-> $value\n" ; @@ -835,6 +850,7 @@ and print the first matching key/value pair given a partial key. $h{'Smith'} = 'John' ; + $key = $value = 0 ; print "IN ORDER\n" ; for ($st = $x->seq($key, $value, R_FIRST) ; $st == 0 ; @@ -881,9 +897,10 @@ the start of the array will raise a fatal run-time error. Here is a simple example that uses RECNO. + use strict ; use DB_File ; - use strict 'untie' ; + my @h ; tie @h, "DB_File", "text", O_RDWR|O_CREAT, 0640, $DB_RECNO or die "Cannot open file 'text': $!\n" ; @@ -1007,7 +1024,7 @@ L). # same again, but use the API functions instead print "\nREVERSE again\n" ; - my ($s, $k, $v) ; + my ($s, $k, $v) = (0, 0, 0) ; for ($s = $H->seq($k, $v, R_LAST) ; $s == 0 ; $s = $H->seq($k, $v, R_PREV)) @@ -1091,7 +1108,7 @@ as B methods directly like this: B If you have saved a copy of the object returned from C, the underlying database file will I be closed until both the tied variable is untied and all copies of the saved object are -destroyed. See L for more details. +destroyed. use DB_File ; $db = tie %hash, "DB_File", "filename" @@ -1227,101 +1244,6 @@ R_RECNOSYNC is the only valid flag at present. =head1 HINTS AND TIPS -=head2 The strict untie pragma - -If you run Perl version 5.004 or later (actually any version from the -5.003_01 development release on will suffice) and you make use of the -Berkeley DB API, it is is I strongly recommended that you always -include the C pragma in any of your scripts that -make use of B. - -Even if you don't currently make use of the API interface, it is still -a good idea to include the pragma. It won't affect the performance of -your script, but it will prevent problems in the future. - -If possible you should try to run with the full strict pragma, but that -is another story. For further details see L and -L>. - -To illustrate the importance of including the untie pragma, here is an -example script that fails in an unexpected place because it doesn't use -it: - - use DB_File ; - use Fcntl ; - - $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT - or die "Cannot tie first time: $!" ; - - $x{123} = 456 ; - - untie %x ; - - $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT - or die "Cannot tie second time: $!" ; - - untie %x ; - -When run the script will produce this error message: - - Cannot tie second time: Invalid argument at bad.file line 12. - -Although the error message above refers to the second tie statement in -the script, the source of the problem is really with the untie -statement that precedes it. - -To understand why there is a problem at all with the untie statement, -consider what the tie does for a moment. - -Whenever the tie is executed, it creates a logical link between a Perl -variable, the associative array C<%x> in this case, and a Berkeley DB -database, C. The logical link ensures that all operation on -the associative array are automatically mirrored to the database file. - -In normal circumstances the untie is enough to break the logical link -and also close the database. In this particular case there is another -logical link, namely the API object returned from the tie and stored in -C<$X>. Whenever the untie is executed in this case, only the link -between the associative array and the database will be broken. The API -object in C<$X> is still valid, so the database will not be closed. - -The end result of this is that when the second tie is executed, the -database will be in an inconsistent state (i.e. it is still opened by -the first tie) - thus the second tie will fail. - -If the C pragma is included in the script, like -this: - - use DB_File ; - use Fcntl ; - use strict 'untie' ; - - $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT - or die "Cannot tie first time: $!" ; - - $x{123} = 456 ; - - untie %x ; - - $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT - or die "Cannot tie second time: $!" ; - -then the error message becomes: - - Can't untie: 1 inner references still exist at bad.file line 11. - -which pinpoints the real problem. Finally the script can now be -modified to fix the original problem by destroying the API object -before the untie: - - ... - $x{123} = 456 ; - - undef $X ; - untie %x ; - - $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT - ... =head2 Locking Databases @@ -1331,7 +1253,6 @@ uses the I method to get the file descriptor, and then a careful open() to give something Perl will flock() for you. Run this repeatedly in the background to watch the locks granted in proper order. - use strict 'untie'; use DB_File; use strict; @@ -1374,7 +1295,7 @@ in the background to watch the locks granted in proper order. print "$$: Write lock granted\n"; $db{$key} = $value; - $db->sync; + $db->sync; # to flush sleep 10; flock(DB_FH, LOCK_UN); @@ -1406,10 +1327,11 @@ Here is a snippet of code that is loosely based on Tom Christiansen's I script (available from your nearest CPAN archive in F). + use strict ; use DB_File ; use Fcntl ; - use strict 'untie' ; + use vars qw( $dotdir $HISTORY %hist_db $href $binary_time $date ) ; $dotdir = $ENV{HOME} || $ENV{LOGNAME}; $HISTORY = "$dotdir/.netscape/history.db"; @@ -1480,8 +1402,7 @@ Here are a couple of possibilities: =item 1. -Attempting to reopen a database without closing it. See -L for an example. +Attempting to reopen a database without closing it. =item 2. @@ -1577,6 +1498,28 @@ The standard hash function C is now supported. Modified the behavior of get_dup. When it returns an associative array, the value is the count of the number of matching BTREE values. +=item 1.04 + +Minor documentation changes. + +Fixed a bug in hash_cb. Patches supplied by Dave Hammen, +Ehammen@gothamcity.jsc.nasa.govE. + +Fixed a bug with the constructors for DB_File::HASHINFO, +DB_File::BTREEINFO and DB_File::RECNOINFO. Also tidied up the +constructors to make them C<-w> clean. + +Reworked part of the test harness to be more locale friendly. + +=item 1.05 + +Made all scripts in the documentation C and C<-w> clean. + +Added logic to F to allow the module to be built after Perl +is installed. + +=back + =head1 BUGS Some older versions of Berkeley DB had problems with fixed length @@ -1593,8 +1536,9 @@ the directory F. Berkeley DB is available at your nearest CPAN archive (see L for a list) in F, or via the -host F in F. It is I under -the GPL. +host F in F. Alternatively, +check out the Berkeley DB home page at F. It +is I under the GPL. If you are running IRIX, then get Berkeley DB from F. It has the patches necessary to diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index aecfb0c..3832a26 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -3,8 +3,8 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess (pmarquess@bfsec.bt.co.uk) - last modified 4th Sept 1996 - version 1.03 + last modified 10th Nov 1996 + version 1.05 All comments/suggestions/problems are welcome @@ -23,6 +23,10 @@ Allow negative subscripts with RECNO interface. Changed the default flags to O_CREAT|O_RDWR 1.03 - Added EXISTS + 1.04 - fixed a couple of bugs in hash_cb. Patches supplied by + Dave Hammen, hammen@gothamcity.jsc.nasa.gov + 1.05 - Added logic to allow prefix & hash types to be specified via + Makefile.PL */ @@ -34,25 +38,40 @@ #include +#ifdef mDB_Prefix_t +#ifdef DB_Prefix_t +#undef DB_Prefix_t +#endif +#define DB_Prefix_t mDB_Prefix_t +#endif + +#ifdef mDB_Hash_t +#ifdef DB_Hash_t +#undef DB_Hash_t +#endif +#define DB_Hash_t mDB_Hash_t +#endif + +union INFO { + HASHINFO hash ; + RECNOINFO recno ; + BTREEINFO btree ; + } ; + typedef struct { DBTYPE type ; DB * dbp ; SV * compare ; SV * prefix ; SV * hash ; + union INFO info ; } DB_File_type; typedef DB_File_type * DB_File ; typedef DBT DBTKEY ; -union INFO { - HASHINFO hash ; - RECNOINFO recno ; - BTREEINFO btree ; - } ; - -/* #define TRACE */ +/* #define TRACE */ #define db_DESTROY(db) ((db->dbp)->close)(db->dbp) #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) @@ -198,7 +217,12 @@ size_t size ; if (size == 0) data = "" ; + /* DGH - Next two lines added to fix corrupted stack problem */ + ENTER ; + SAVETMPS; + PUSHMARK(sp) ; + XPUSHs(sv_2mortal(newSVpv((char*)data,size))); PUTBACK ; @@ -223,44 +247,44 @@ size_t size ; static void PrintHash(hash) -HASHINFO hash ; +HASHINFO * hash ; { printf ("HASH Info\n") ; - printf (" hash = %s\n", (hash.hash != NULL ? "redefined" : "default")) ; - printf (" bsize = %d\n", hash.bsize) ; - printf (" ffactor = %d\n", hash.ffactor) ; - printf (" nelem = %d\n", hash.nelem) ; - printf (" cachesize = %d\n", hash.cachesize) ; - printf (" lorder = %d\n", hash.lorder) ; + printf (" hash = %s\n", (hash->hash != NULL ? "redefined" : "default")) ; + printf (" bsize = %d\n", hash->bsize) ; + printf (" ffactor = %d\n", hash->ffactor) ; + printf (" nelem = %d\n", hash->nelem) ; + printf (" cachesize = %d\n", hash->cachesize) ; + printf (" lorder = %d\n", hash->lorder) ; } static void PrintRecno(recno) -RECNOINFO recno ; +RECNOINFO * recno ; { printf ("RECNO Info\n") ; - printf (" flags = %d\n", recno.flags) ; - printf (" cachesize = %d\n", recno.cachesize) ; - printf (" psize = %d\n", recno.psize) ; - printf (" lorder = %d\n", recno.lorder) ; - printf (" reclen = %d\n", recno.reclen) ; - printf (" bval = %d\n", recno.bval) ; - printf (" bfname = %d [%s]\n", recno.bfname, recno.bfname) ; + printf (" flags = %d\n", recno->flags) ; + printf (" cachesize = %d\n", recno->cachesize) ; + printf (" psize = %d\n", recno->psize) ; + printf (" lorder = %d\n", recno->lorder) ; + printf (" reclen = %d\n", recno->reclen) ; + printf (" bval = %d\n", recno->bval) ; + printf (" bfname = %d [%s]\n", recno->bfname, recno->bfname) ; } PrintBtree(btree) -BTREEINFO btree ; +BTREEINFO * btree ; { printf ("BTREE Info\n") ; - printf (" compare = %s\n", (btree.compare ? "redefined" : "default")) ; - printf (" prefix = %s\n", (btree.prefix ? "redefined" : "default")) ; - printf (" flags = %d\n", btree.flags) ; - printf (" cachesize = %d\n", btree.cachesize) ; - printf (" psize = %d\n", btree.psize) ; - printf (" maxkeypage = %d\n", btree.maxkeypage) ; - printf (" minkeypage = %d\n", btree.minkeypage) ; - printf (" lorder = %d\n", btree.lorder) ; + printf (" compare = %s\n", (btree->compare ? "redefined" : "default")) ; + printf (" prefix = %s\n", (btree->prefix ? "redefined" : "default")) ; + printf (" flags = %d\n", btree->flags) ; + printf (" cachesize = %d\n", btree->cachesize) ; + printf (" psize = %d\n", btree->psize) ; + printf (" maxkeypage = %d\n", btree->maxkeypage) ; + printf (" minkeypage = %d\n", btree->minkeypage) ; + printf (" lorder = %d\n", btree->lorder) ; } #else @@ -311,101 +335,104 @@ I32 value ; } static DB_File -ParseOpenInfo(name, flags, mode, sv, string) +ParseOpenInfo(name, flags, mode, sv) char * name ; int flags ; int mode ; SV * sv ; -char * string ; { SV ** svp; HV * action ; - union INFO info ; DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; void * openinfo = NULL ; + union INFO * info = &RETVAL->info ; /* Default to HASH */ RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; RETVAL->type = DB_HASH ; + /* DGH - Next line added to avoid SEGV on existing hash DB */ + CurrentDB = RETVAL; + if (sv) { if (! SvROK(sv) ) croak ("type parameter is not a reference") ; action = (HV*)SvRV(sv); + if (sv_isa(sv, "DB_File::HASHINFO")) { RETVAL->type = DB_HASH ; - openinfo = (void*)&info ; + openinfo = (void*)info ; svp = hv_fetch(action, "hash", 4, FALSE); if (svp && SvOK(*svp)) { - info.hash.hash = hash_cb ; + info->hash.hash = hash_cb ; RETVAL->hash = newSVsv(*svp) ; } else - info.hash.hash = NULL ; + info->hash.hash = NULL ; svp = hv_fetch(action, "bsize", 5, FALSE); - info.hash.bsize = svp ? SvIV(*svp) : 0; + info->hash.bsize = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "ffactor", 7, FALSE); - info.hash.ffactor = svp ? SvIV(*svp) : 0; + info->hash.ffactor = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "nelem", 5, FALSE); - info.hash.nelem = svp ? SvIV(*svp) : 0; + info->hash.nelem = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "cachesize", 9, FALSE); - info.hash.cachesize = svp ? SvIV(*svp) : 0; + info->hash.cachesize = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "lorder", 6, FALSE); - info.hash.lorder = svp ? SvIV(*svp) : 0; + info->hash.lorder = svp ? SvIV(*svp) : 0; PrintHash(info) ; } else if (sv_isa(sv, "DB_File::BTREEINFO")) { RETVAL->type = DB_BTREE ; - openinfo = (void*)&info ; + openinfo = (void*)info ; svp = hv_fetch(action, "compare", 7, FALSE); if (svp && SvOK(*svp)) { - info.btree.compare = btree_compare ; + info->btree.compare = btree_compare ; RETVAL->compare = newSVsv(*svp) ; } else - info.btree.compare = NULL ; + info->btree.compare = NULL ; svp = hv_fetch(action, "prefix", 6, FALSE); if (svp && SvOK(*svp)) { - info.btree.prefix = btree_prefix ; + info->btree.prefix = btree_prefix ; RETVAL->prefix = newSVsv(*svp) ; } else - info.btree.prefix = NULL ; + info->btree.prefix = NULL ; svp = hv_fetch(action, "flags", 5, FALSE); - info.btree.flags = svp ? SvIV(*svp) : 0; + info->btree.flags = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "cachesize", 9, FALSE); - info.btree.cachesize = svp ? SvIV(*svp) : 0; + info->btree.cachesize = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "minkeypage", 10, FALSE); - info.btree.minkeypage = svp ? SvIV(*svp) : 0; + info->btree.minkeypage = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "maxkeypage", 10, FALSE); - info.btree.maxkeypage = svp ? SvIV(*svp) : 0; + info->btree.maxkeypage = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "psize", 5, FALSE); - info.btree.psize = svp ? SvIV(*svp) : 0; + info->btree.psize = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "lorder", 6, FALSE); - info.btree.lorder = svp ? SvIV(*svp) : 0; + info->btree.lorder = svp ? SvIV(*svp) : 0; PrintBtree(info) ; @@ -413,43 +440,43 @@ char * string ; else if (sv_isa(sv, "DB_File::RECNOINFO")) { RETVAL->type = DB_RECNO ; - openinfo = (void *)&info ; + openinfo = (void *)info ; svp = hv_fetch(action, "flags", 5, FALSE); - info.recno.flags = (u_long) svp ? SvIV(*svp) : 0; + info->recno.flags = (u_long) svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "cachesize", 9, FALSE); - info.recno.cachesize = (u_int) svp ? SvIV(*svp) : 0; + info->recno.cachesize = (u_int) svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "psize", 5, FALSE); - info.recno.psize = (int) svp ? SvIV(*svp) : 0; + info->recno.psize = (int) svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "lorder", 6, FALSE); - info.recno.lorder = (int) svp ? SvIV(*svp) : 0; + info->recno.lorder = (int) svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "reclen", 6, FALSE); - info.recno.reclen = (size_t) svp ? SvIV(*svp) : 0; + info->recno.reclen = (size_t) svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "bval", 4, FALSE); if (svp && SvOK(*svp)) { if (SvPOK(*svp)) - info.recno.bval = (u_char)*SvPV(*svp, na) ; + info->recno.bval = (u_char)*SvPV(*svp, na) ; else - info.recno.bval = (u_char)(unsigned long) SvIV(*svp) ; + info->recno.bval = (u_char)(unsigned long) SvIV(*svp) ; } else { - if (info.recno.flags & R_FIXEDLEN) - info.recno.bval = (u_char) ' ' ; + if (info->recno.flags & R_FIXEDLEN) + info->recno.bval = (u_char) ' ' ; else - info.recno.bval = (u_char) '\n' ; + info->recno.bval = (u_char) '\n' ; } svp = hv_fetch(action, "bfname", 6, FALSE); if (svp) { char * ptr = SvPV(*svp,na) ; - info.recno.bfname = (char*) na ? ptr : 0 ; + info->recno.bfname = (char*) na ? ptr : 0 ; } PrintRecno(info) ; @@ -727,11 +754,10 @@ constant(name,arg) DB_File -db_TIEHASH(dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0640, type=DB_HASH) +db_DoTie_(dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0640, type=DB_HASH) char * dbtype int flags int mode - ALIAS: TIEARRAY = 1 CODE: { char * name = (char *) NULL ; @@ -743,7 +769,7 @@ db_TIEHASH(dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0640, type=DB_HASH) if (items == 5) sv = ST(4) ; - RETVAL = ParseOpenInfo(name, flags, mode, sv, "new") ; + RETVAL = ParseOpenInfo(name, flags, mode, sv) ; if (RETVAL->dbp == NULL) RETVAL = NULL ; } @@ -1039,3 +1065,4 @@ db_seq(db, key, value, flags) OUTPUT: key value + diff --git a/t/lib/db-hash.t b/t/lib/db-hash.t index 527dfc9..e6ffa6b 100755 --- a/t/lib/db-hash.t +++ b/t/lib/db-hash.t @@ -1,9 +1,7 @@ -#!./perl #!./perl -w BEGIN { - #@INC = '../lib' if -d '../lib' ; - @INC = '../lib' ; + @INC = '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0\n"; @@ -14,7 +12,7 @@ BEGIN { use DB_File; use Fcntl; -print "1..48\n"; +print "1..51\n"; sub ok { @@ -34,14 +32,14 @@ umask(0); my $dbh = new DB_File::HASHINFO ; +ok(1, $dbh->{bsize} == 0) ; +ok(2, $dbh->{ffactor} == 0) ; +ok(3, $dbh->{nelem} == 0) ; +ok(4, $dbh->{cachesize} == 0) ; $^W = 0 ; -ok(1, $dbh->{bsize} == undef) ; -ok(2, $dbh->{ffactor} == undef) ; -ok(3, $dbh->{nelem} == undef) ; -ok(4, $dbh->{cachesize} == undef) ; ok(5, $dbh->{hash} == undef) ; -ok(6, $dbh->{lorder} == undef) ; $^W = 1 ; +ok(6, $dbh->{lorder} == 0) ; $dbh->{bsize} = 3000 ; ok(7, $dbh->{bsize} == 3000 ); @@ -64,9 +62,10 @@ ok(12, $dbh->{lorder} == 1234 ); # Check that an invalid entry is caught both for store & fetch eval '$dbh->{fred} = 1234' ; ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ ); -eval '$q = $dbh->{fred}' ; +eval 'my $q = $dbh->{fred}' ; ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ ); + # Now check the interface to HASH ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); @@ -295,7 +294,22 @@ ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); $status = $X->fd ; ok(48, $status == -1 ); -untie %h ; undef $X ; +untie %h ; + +{ + # check ability to override the default hashing + my %x ; + my $filename = "xyz" ; + my $hi = new DB_File::HASHINFO ; + $::count = 0 ; + $hi->{hash} = sub { ++$::count ; length $_[0] } ; + ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ; + $h{"abc"} = 123 ; + ok(50, $h{"abc"} == 123) ; + untie %x ; + unlink $filename ; + ok(51, $::count >0) ; +} exit ;