diff options
| author | Paul Marquess <paul.marquess@btinternet.com> | 2002-09-03 00:56:40 +0100 |
|---|---|---|
| committer | hv <hv@crypt.org> | 2002-09-04 13:35:36 +0000 |
| commit | efc79c7d1f6a9a021e95d1caa1c90ae0f9adcd45 (patch) | |
| tree | b300f17fb8005d15aa8fde781026488845b8d796 /ext | |
| parent | b8f55b69fbd0df7045f7d14d66b22d94744f42c5 (diff) | |
| download | perl-efc79c7d1f6a9a021e95d1caa1c90ae0f9adcd45.tar.gz | |
DB_File 1.805
From: "Paul Marquess" <Paul.Marquess@btinternet.com>
Message-ID: <AIEAJICLCBDNAAOLLOKLAEMCFFAA.Paul.Marquess@btinternet.com>
p4raw-id: //depot/perl@17836
Diffstat (limited to 'ext')
| -rw-r--r-- | ext/DB_File/Changes | 503 | ||||
| -rw-r--r-- | ext/DB_File/DB_File.pm | 36 | ||||
| -rw-r--r-- | ext/DB_File/DB_File.xs | 119 | ||||
| -rw-r--r-- | ext/DB_File/dbinfo | 9 | ||||
| -rwxr-xr-x | ext/DB_File/t/db-btree.t | 432 | ||||
| -rwxr-xr-x | ext/DB_File/t/db-hash.t | 285 | ||||
| -rwxr-xr-x | ext/DB_File/t/db-recno.t | 292 | ||||
| -rw-r--r-- | ext/DB_File/typemap | 18 |
8 files changed, 1092 insertions, 602 deletions
diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes index 3351542eee..7883cbdfef 100644 --- a/ext/DB_File/Changes +++ b/ext/DB_File/Changes @@ -1,208 +1,224 @@ -0.1 +1.805 1st September 2002 - First Release. + * Added support to allow DB_File to build with Berkeley DB 4.1.X -0.2 + * Tightened up the test harness to test that calls to untie don't generate + the "untie attempted while %d inner references still exist" warning. - When DB_File is opening a database file it no longer terminates the - process if dbopen returned an error. This allows file protection - errors to be caught at run time. Thanks to Judith Grass - <grass@cybercash.com> for spotting the bug. + * added code to guard against calling the callbacks (compare,hash & prefix) + recursively. -0.3 + * pasing undef for the flags and/or mode when opening a database could cause + a "Use of uninitialized value in subroutine entry" warning. Now silenced. - Added prototype support for multiple btree compare callbacks. + * DBM filter code beefed up to cope with read-only $_. -1.0 +1.804 2nd June 2002 - DB_File has been in use for over a year. To reflect that, the - version number has been incremented to 1.0. + * Perl core patch 14939 added a new warning to "splice". This broke the + db-recno test harness. Fixed. - Added complete support for multiple concurrent callbacks. + * merged core patches 16502 & 16540. - Using the push method on an empty list didn't work properly. This - has been fixed. +1.803 1st March 2002 -1.01 + * Fixed a problem with db-btree.t where it complained about an "our" + variable redeclaation. - Fixed a core dump problem with SunOS. + * FETCH, STORE & DELETE don't map the flags parameter into the + equivalent Berkeley DB function anymore. - The return value from TIEHASH wasn't set to NULL when dbopen - returned an error. +1.802 6th January 2002 -1.02 + * The message about some test failing in db-recno.t had the wrong test + numbers. Fixed. - Merged OS/2 specific code into DB_File.xs + * merged core patch 13942. - Removed some redundant code in DB_File.xs. +1.801 26th November 2001 - Documentation update. + * Fixed typo in Makefile.PL - Allow negative subscripts with RECNO interface. + * Added "clean" attribute to Makefile.PL + +1.800 23rd November 2001 - Changed the default flags from O_RDWR to O_CREAT|O_RDWR. + * use pport.h for perl backward compatability code. - The example code which showed how to lock a database needed a call - to sync added. Without it the resultant database file was empty. + * use new ExtUtils::Constant module to generate XS constants. - Added get_dup method. + * upgrade Makefile.PL upgrade/downgrade code to toggle "our" with + "use vars" -1.03 +1.79 22nd October 2001 - Documentation update. + * Added a "local $SIG{__DIE__}" inside the eval that checks for + the presence of XSLoader s suggested by Andrew Hryckowin. - DB_File now imports the constants (O_RDWR, O_CREAT etc.) from Fcntl - automatically. + * merged core patch 12277. - The standard hash function exists is now supported. + * Changed NEXTKEY to not initialise the input key. It isn't used anyway. - Modified the behavior of get_dup. When it returns an associative - array, the value is the count of the number of matching BTREE - values. +1.79 22nd October 2001 -1.04 + * Fixed test harness for cygwin - Minor documentation changes. +1.78 30th July 2001 - Fixed a bug in hash_cb. Patches supplied by Dave Hammen, - <hammen@gothamcity.jsc.nasa.govt>. + * the test in Makefile.PL for AIX used -plthreads. Should have been + -lpthreads - 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 -w clean. + * merged Core patches + 10372, 10335, 10372, 10534, 10549, 10643, 11051, 11194, 11432 - Reworked part of the test harness to be more locale friendly. + * added documentation patch regarding duplicate keys from Andrew Johnson -1.05 - Made all scripts in the documentation strict and -w clean. +1.77 26th April 2001 - Added logic to DB_File.xs to allow the module to be built after - Perl is installed. + * AIX is reported to need -lpthreads, so Makefile.PL now checks for + AIX and adds it to the link options. -1.06 + * Minor documentation updates. - Minor namespace cleanup: Localized PrintBtree. + * Merged Core patch 9176 -1.07 + * Added a patch from Edward Avis that adds support for splice with + recno databases. - Fixed bug with RECNO, where bval wasn't defaulting to "\n". + * Modified Makefile.PL to only enable the warnings pragma if using perl + 5.6.1 or better. -1.08 +1.76 15th January 2001 - Documented operation of bval. + * Added instructions for using LD_PRELOAD to get Berkeley DB 2.x to work + with DB_File on Linux. Thanks to Norbert Bollow for sending details of + this approach. -1.09 - Minor bug fix in DB_File::HASHINFO, DB_File::RECNOINFO and - DB_File::BTREEINFO. +1.75 17th December 2000 - Changed default mode to 0666. + * Fixed perl core patch 7703 -1.10 + * Added suppport to allow DB_File to be built with Berkeley DB 3.2 -- + btree_compare, btree_prefix and hash_cb needed to be changed. - Fixed fd method so that it still returns -1 for in-memory files - when db 1.86 is used. + * Updated dbinfo to support Berkeley DB 3.2 file format changes. -1.11 - Documented the untie gotcha. +1.74 10th December 2000 -1.12 + * A "close" call in DB_File.xs needed parenthesised to stop win32 from + thinking it was one of its macros. - Documented the incompatibility with version 2 of Berkeley DB. + * Updated dbinfo to support Berkeley DB 3.1 file format changes. -1.13 + * DB_File.pm & the test hasness now use the warnings pragma (when + available). - Minor changes to DB_FIle.xs and DB_File.pm + * Included Perl core patch 7703 -- size argument for hash_cb is different + for Berkeley DB 3.x -1.14 + * Included Perl core patch 7801 -- Give __getBerkeleyDBInfo the ANSI C + treatment. - Made it illegal to tie an associative array to a RECNO database and - an ordinary array to a HASH or BTREE database. + * @a = () produced the warning 'Argument "" isn't numeric in entersub' + This has been fixed. Thanks to Edward Avis for spotting this bug. -1.15 + * Added note about building under Linux. Included patches. - Patch from Gisle Aas <gisle@aas.no> to suppress "use of undefined - value" warning with db_get and db_seq. + * Included Perl core patch 8068 -- fix for bug 20001013.009 + When run with warnings enabled "$hash{XX} = undef " produced an + "Uninitialized value" warning. This has been fixed. - Patch from Gisle Aas <gisle@aas.no> to make DB_File export only the - O_* constants from Fcntl. +1.73 31st May 2000 - Removed the DESTROY method from the DB_File::HASHINFO module. + * Added support in version.c for building with threaded Perl. - Previously DB_File hard-wired the class name of any object that it - created to "DB_File". This makes sub-classing difficult. Now - DB_File creats objects in the namespace of the package it has been - inherited into. + * Berkeley DB 3.1 has reenabled support for null keys. The test + harness has been updated to reflect this. +1.72 16th January 2000 -1.16 + * Added hints/sco.pl - A harmless looking tab was causing Makefile.PL to fail on AIX 3.2.5 + * The module will now use XSLoader when it is available. When it + isn't it will use DynaLoader. - Small fix for the AIX strict C compiler XLC which doesn't like - __attribute__ being defined via proto.h and redefined via db.h. Fix - courtesy of Jarkko Hietaniemi. + * The locking section in DB_File.pm has been discredited. Many thanks + to David Harris for spotting the underlying problem, contributing + the updates to the documentation and writing DB_File::Lock (available + on CPAN). -1.50 +1.71 7th September 1999 - DB_File can now build with either DB 1.x or 2.x, but not both at - the same time. + * Fixed a bug that prevented 1.70 from compiling under win32 -1.51 + * Updated to support Berkeley DB 3.x - Fixed the test harness so that it doesn't expect DB_File to have - been installed by the main Perl build. + * Updated dbinfo for Berkeley DB 3.x file formats. +1.70 4th August 1999 - Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent + * Initialise $DB_File::db_ver and $DB_File::db_version with + GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. -1.52 + * Added a BOOT check to test for equivalent versions of db.h & + libdb.a/so. - Patch from Nick Ing-Simmons now allows DB_File to build on NT. - Merged 1.15 patch. +1.69 3rd August 1999 -1.53 + * fixed a bug in push -- DB_APPEND wasn't working properly. - Added DB_RENUMBER to flags for recno. + * Fixed the R_SETCURSOR bug introduced in 1.68 -1.54 + * Added a new Perl variable $DB_File::db_ver + +1.68 22nd July 1999 - Fixed a small bug in the test harness when run under win32 - The emulation of fd when useing DB 2.x was busted. + * Merged changes from 5.005_58 -1.55 - Merged 1.16 changes. + * Fixed a bug in R_IBEFORE & R_IAFTER procesing in Berkeley DB + 2 databases. -1.56 - Documented the Solaris 2.5 mutex bug + * Added some of the examples in the POD into the test harness. -1.57 - If Perl has been compiled with Threads support,the symbol op will be - defined. This clashes with a field name in db.h, so it needs to be - #undef'ed before db.h is included. +1.67 6th June 1999 -1.58 - Tied Array support was enhanced in Perl 5.004_57. DB_File now - supports PUSH,POP,SHIFT,UNSHIFT & STORESIZE. + * Added DBM Filter documentation to DB_File.pm - Fixed a problem with the use of sv_setpvn. When the size is - specified as 0, it does a strlen on the data. This was ok for DB - 1.x, but isn't for DB 2.x. + * Fixed DBM Filter code to work with 5.004 -1.59 - Updated the license section. + * A few instances of newSVpvn were used in 1.66. This isn't available in + Perl 5.004_04 or earlier. Replaced with newSVpv. - Berkeley DB 2.4.10 disallows zero length keys. Tests 32 & 42 in - db-btree.t and test 27 in db-hash.t failed because of this change. - Those tests have been zapped. +1.66 15th March 1999 - Added dbinfo to the distribution. + * Added DBM Filter code -1.60 - Changed the test to check for full tied array support +1.65 6th March 1999 + + * Fixed a bug in the recno PUSH logic. + * The BOOT version check now needs 2.3.4 when using Berkeley DB version 2 + +1.64 21st February 1999 + + * Tidied the 1.x to 2.x flag mapping code. + * Added a patch from Mark Kettenis <kettenis@wins.uva.nl> to fix a flag + mapping problem with O_RDONLY on the Hurd + * Updated the message that db-recno.t prints when tests 51, 53 or 55 fail. + +1.63 19th December 1998 + + * Fix to allow DB 2.6.x to build with DB_File + * Documentation updated to use push,pop etc in the RECNO example & + to include the find_dup & del_dup methods. + +1.62 30th November 1998 + + Added hints/dynixptx.pl. + Fixed typemap -- 1.61 used PL_na instead of na 1.61 19th November 1998 @@ -211,207 +227,208 @@ Minor modifications to get the module to build with DB 2.5.x Fixed a typo in the definition of O_RDONLY, courtesy of Mark Kettenis. -1.62 30th November 1998 +1.60 + Changed the test to check for full tied array support - Added hints/dynixptx.pl. - Fixed typemap -- 1.61 used PL_na instead of na +1.59 + Updated the license section. -1.63 19th December 1998 + Berkeley DB 2.4.10 disallows zero length keys. Tests 32 & 42 in + db-btree.t and test 27 in db-hash.t failed because of this change. + Those tests have been zapped. - * Fix to allow DB 2.6.x to build with DB_File - * Documentation updated to use push,pop etc in the RECNO example & - to include the find_dup & del_dup methods. + Added dbinfo to the distribution. -1.64 21st February 1999 +1.58 + Tied Array support was enhanced in Perl 5.004_57. DB_File now + supports PUSH,POP,SHIFT,UNSHIFT & STORESIZE. - * Tidied the 1.x to 2.x flag mapping code. - * Added a patch from Mark Kettenis <kettenis@wins.uva.nl> to fix a flag - mapping problem with O_RDONLY on the Hurd - * Updated the message that db-recno.t prints when tests 51, 53 or 55 fail. + Fixed a problem with the use of sv_setpvn. When the size is + specified as 0, it does a strlen on the data. This was ok for DB + 1.x, but isn't for DB 2.x. -1.65 6th March 1999 +1.57 + If Perl has been compiled with Threads support,the symbol op will be + defined. This clashes with a field name in db.h, so it needs to be + #undef'ed before db.h is included. - * Fixed a bug in the recno PUSH logic. - * The BOOT version check now needs 2.3.4 when using Berkeley DB version 2 +1.56 + Documented the Solaris 2.5 mutex bug -1.66 15th March 1999 +1.55 + Merged 1.16 changes. - * Added DBM Filter code +1.54 -1.67 6th June 1999 + Fixed a small bug in the test harness when run under win32 + The emulation of fd when useing DB 2.x was busted. - * Added DBM Filter documentation to DB_File.pm +1.53 - * Fixed DBM Filter code to work with 5.004 + Added DB_RENUMBER to flags for recno. - * A few instances of newSVpvn were used in 1.66. This isn't available in - Perl 5.004_04 or earlier. Replaced with newSVpv. +1.52 -1.68 22nd July 1999 + Patch from Nick Ing-Simmons now allows DB_File to build on NT. + Merged 1.15 patch. - * Merged changes from 5.005_58 +1.51 - * Fixed a bug in R_IBEFORE & R_IAFTER procesing in Berkeley DB - 2 databases. + Fixed the test harness so that it doesn't expect DB_File to have + been installed by the main Perl build. - * Added some of the examples in the POD into the test harness. -1.69 3rd August 1999 + Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent - * fixed a bug in push -- DB_APPEND wasn't working properly. +1.50 - * Fixed the R_SETCURSOR bug introduced in 1.68 + DB_File can now build with either DB 1.x or 2.x, but not both at + the same time. - * Added a new Perl variable $DB_File::db_ver - -1.70 4th August 1999 +1.16 - * Initialise $DB_File::db_ver and $DB_File::db_version with - GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. + A harmless looking tab was causing Makefile.PL to fail on AIX 3.2.5 - * Added a BOOT check to test for equivalent versions of db.h & - libdb.a/so. + Small fix for the AIX strict C compiler XLC which doesn't like + __attribute__ being defined via proto.h and redefined via db.h. Fix + courtesy of Jarkko Hietaniemi. -1.71 7th September 1999 +1.15 - * Fixed a bug that prevented 1.70 from compiling under win32 + Patch from Gisle Aas <gisle@aas.no> to suppress "use of undefined + value" warning with db_get and db_seq. - * Updated to support Berkeley DB 3.x + Patch from Gisle Aas <gisle@aas.no> to make DB_File export only the + O_* constants from Fcntl. - * Updated dbinfo for Berkeley DB 3.x file formats. + Removed the DESTROY method from the DB_File::HASHINFO module. -1.72 16th January 2000 + Previously DB_File hard-wired the class name of any object that it + created to "DB_File". This makes sub-classing difficult. Now + DB_File creats objects in the namespace of the package it has been + inherited into. - * Added hints/sco.pl - * The module will now use XSLoader when it is available. When it - isn't it will use DynaLoader. +1.14 - * The locking section in DB_File.pm has been discredited. Many thanks - to David Harris for spotting the underlying problem, contributing - the updates to the documentation and writing DB_File::Lock (available - on CPAN). + Made it illegal to tie an associative array to a RECNO database and + an ordinary array to a HASH or BTREE database. -1.73 31st May 2000 +1.13 - * Added support in version.c for building with threaded Perl. + Minor changes to DB_FIle.xs and DB_File.pm - * Berkeley DB 3.1 has reenabled support for null keys. The test - harness has been updated to reflect this. +1.12 -1.74 10th December 2000 + Documented the incompatibility with version 2 of Berkeley DB. - * A "close" call in DB_File.xs needed parenthesised to stop win32 from - thinking it was one of its macros. +1.11 - * Updated dbinfo to support Berkeley DB 3.1 file format changes. + Documented the untie gotcha. - * DB_File.pm & the test hasness now use the warnings pragma (when - available). +1.10 - * Included Perl core patch 7703 -- size argument for hash_cb is different - for Berkeley DB 3.x + Fixed fd method so that it still returns -1 for in-memory files + when db 1.86 is used. - * Included Perl core patch 7801 -- Give __getBerkeleyDBInfo the ANSI C - treatment. +1.09 - * @a = () produced the warning 'Argument "" isn't numeric in entersub' - This has been fixed. Thanks to Edward Avis for spotting this bug. + Minor bug fix in DB_File::HASHINFO, DB_File::RECNOINFO and + DB_File::BTREEINFO. - * Added note about building under Linux. Included patches. + Changed default mode to 0666. - * Included Perl core patch 8068 -- fix for bug 20001013.009 - When run with warnings enabled "$hash{XX} = undef " produced an - "Uninitialized value" warning. This has been fixed. +1.08 -1.75 17th December 2000 + Documented operation of bval. - * Fixed perl core patch 7703 +1.07 - * Added suppport to allow DB_File to be built with Berkeley DB 3.2 -- - btree_compare, btree_prefix and hash_cb needed to be changed. + Fixed bug with RECNO, where bval wasn't defaulting to "\n". - * Updated dbinfo to support Berkeley DB 3.2 file format changes. +1.06 + Minor namespace cleanup: Localized PrintBtree. -1.76 15th January 2001 +1.05 - * Added instructions for using LD_PRELOAD to get Berkeley DB 2.x to work - with DB_File on Linux. Thanks to Norbert Bollow for sending details of - this approach. + Made all scripts in the documentation strict and -w clean. + Added logic to DB_File.xs to allow the module to be built after + Perl is installed. -1.77 26th April 2001 +1.04 - * AIX is reported to need -lpthreads, so Makefile.PL now checks for - AIX and adds it to the link options. + Minor documentation changes. - * Minor documentation updates. + Fixed a bug in hash_cb. Patches supplied by Dave Hammen, + <hammen@gothamcity.jsc.nasa.govt>. - * Merged Core patch 9176 + 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 -w clean. - * Added a patch from Edward Avis that adds support for splice with - recno databases. + Reworked part of the test harness to be more locale friendly. - * Modified Makefile.PL to only enable the warnings pragma if using perl - 5.6.1 or better. +1.03 -1.78 30th July 2001 + Documentation update. - * the test in Makefile.PL for AIX used -plthreads. Should have been - -lpthreads + DB_File now imports the constants (O_RDWR, O_CREAT etc.) from Fcntl + automatically. - * merged Core patches - 10372, 10335, 10372, 10534, 10549, 10643, 11051, 11194, 11432 + The standard hash function exists is now supported. - * added documentation patch regarding duplicate keys from Andrew Johnson + Modified the behavior of get_dup. When it returns an associative + array, the value is the count of the number of matching BTREE + values. -1.79 22nd October 2001 +1.02 - * Added a "local $SIG{__DIE__}" inside the eval that checks for - the presence of XSLoader s suggested by Andrew Hryckowin. + Merged OS/2 specific code into DB_File.xs - * merged core patch 12277. + Removed some redundant code in DB_File.xs. - * Changed NEXTKEY to not initialise the input key. It isn't used anyway. + Documentation update. -1.79 22nd October 2001 + Allow negative subscripts with RECNO interface. - * Fixed test harness for cygwin + Changed the default flags from O_RDWR to O_CREAT|O_RDWR. + The example code which showed how to lock a database needed a call + to sync added. Without it the resultant database file was empty. -1.800 23rd November 2001 + Added get_dup method. - * use pport.h for perl backward compatability code. +1.01 - * use new ExtUtils::Constant module to generate XS constants. + Fixed a core dump problem with SunOS. - * upgrade Makefile.PL upgrade/downgrade code to toggle "our" with - "use vars" + The return value from TIEHASH wasn't set to NULL when dbopen + returned an error. -1.801 26th November 2001 +1.0 - * Fixed typo in Makefile.PL + DB_File has been in use for over a year. To reflect that, the + version number has been incremented to 1.0. - * Added "clean" attribute to Makefile.PL - -1.802 6th January 2002 + Added complete support for multiple concurrent callbacks. - * The message about some test failing in db-recno.t had the wrong test - numbers. Fixed. + Using the push method on an empty list didn't work properly. This + has been fixed. - * merged core patch 13942. +0.3 -1.803 1st March 2002 + Added prototype support for multiple btree compare callbacks. - * Fixed a problem with db-btree.t where it complained about an "our" - variable redeclaation. +0.2 - * FETCH, STORE & DELETE don't map the flags parameter into the - equivalent Berkeley DB function anymore. + When DB_File is opening a database file it no longer terminates the + process if dbopen returned an error. This allows file protection + errors to be caught at run time. Thanks to Judith Grass + <grass@cybercash.com> for spotting the bug. -1.804 2nd March 2002 +0.1 - * Perl core patch 14939 added a new warning to "splice". This broke the - db-recno test harness. Fixed. + First Release. diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index df189eb1cd..49004ffa14 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -1,8 +1,8 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (Paul.Marquess@btinternet.com) -# last modified 1st March 2002 -# version 1.804 +# last modified 1st September 2002 +# version 1.805 # # Copyright (c) 1995-2002 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or @@ -32,8 +32,13 @@ sub TIEHASH { my $pkg = shift ; - bless { VALID => { map {$_, 1} - qw( bsize ffactor nelem cachesize hash lorder) + bless { VALID => { + bsize => 1, + ffactor => 1, + nelem => 1, + cachesize => 1, + hash => 2, + lorder => 1, }, GOT => {} }, $pkg ; @@ -58,8 +63,12 @@ sub STORE my $key = shift ; my $value = shift ; - if ( exists $self->{VALID}{$key} ) + my $type = $self->{VALID}{$key}; + + if ( $type ) { + croak "Key '$key' not associated with a code reference" + if $type == 2 && !ref $value && ref $value ne 'CODE'; $self->{GOT}{$key} = $value ; return ; } @@ -132,9 +141,15 @@ sub TIEHASH { my $pkg = shift ; - bless { VALID => { map {$_, 1} - qw( flags cachesize maxkeypage minkeypage psize - compare prefix lorder ) + bless { VALID => { + flags => 1, + cachesize => 1, + maxkeypage => 1, + minkeypage => 1, + psize => 1, + compare => 2, + prefix => 2, + lorder => 1, }, GOT => {}, }, $pkg ; @@ -150,7 +165,7 @@ our ($db_version, $use_XSLoader, $splice_end_array); use Carp; -$VERSION = "1.804" ; +$VERSION = "1.805" ; { local $SIG{__WARN__} = sub {$splice_end_array = "@_";}; @@ -248,6 +263,9 @@ sub tie_hash_or_array $arg[4] = tied %{ $arg[4] } if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ; + $arg[2] = O_CREAT()|O_RDWR() if @arg >=3 && ! defined $arg[2]; + $arg[3] = 0666 if @arg >=4 && ! defined $arg[3]; + # make recno in Berkeley DB version 2 work like recno in version 1. if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and $arg[1] and ! -e $arg[1]) { diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index 489ba96890..fba8dede79 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 <Paul.Marquess@btinternet.com> - last modified 1st March 2002 - version 1.803 + last modified 1st September 2002 + version 1.805 All comments/suggestions/problems are welcome @@ -101,6 +101,10 @@ 1.802 - No change to DB_File.xs 1.803 - FETCH, STORE & DELETE don't map the flags parameter into the equivalent Berkeley DB function anymore. + 1.804 - no change. + 1.805 - recursion detection added to the callbacks + Support for 4.1.X added. + Filter code can now cope with read-only $_ */ @@ -182,6 +186,10 @@ # define AT_LEAST_DB_3_2 #endif +#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 1) +# define AT_LEAST_DB_4_1 +#endif + /* map version 2 features & constants onto their version 1 equivalent */ #ifdef DB_Prefix_t @@ -334,8 +342,8 @@ typedef union INFO { #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) #ifdef DB_VERSION_MAJOR -#define db_DESTROY(db) ( db->cursor->c_close(db->cursor),\ - (db->dbp->close)(db->dbp, 0) ) +#define db_DESTROY(db) (!db->aborted && ( db->cursor->c_close(db->cursor),\ + (db->dbp->close)(db->dbp, 0) )) #define db_close(db) ((db->dbp)->close)(db->dbp, 0) #define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \ ? ((db->cursor)->c_del)(db->cursor, 0) \ @@ -343,7 +351,7 @@ typedef union INFO { #else /* ! DB_VERSION_MAJOR */ -#define db_DESTROY(db) ((db->dbp)->close)(db->dbp) +#define db_DESTROY(db) (!db->aborted && ((db->dbp)->close)(db->dbp)) #define db_close(db) ((db->dbp)->close)(db->dbp) #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags) @@ -357,8 +365,12 @@ typedef struct { DBTYPE type ; DB * dbp ; SV * compare ; + bool in_compare ; SV * prefix ; + bool in_prefix ; SV * hash ; + bool in_hash ; + bool aborted ; int in_memory ; #ifdef BERKELEY_DB_1_OR_2 INFO info ; @@ -382,6 +394,8 @@ typedef DBT DBTKEY ; #define OutputValue(arg, name) \ { if (RETVAL == 0) { \ my_sv_setpvn(arg, name.data, name.size) ; \ + TAINT; \ + SvTAINTED_on(arg); \ DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \ } \ } @@ -394,6 +408,8 @@ typedef DBT DBTKEY ; } \ else \ sv_setiv(arg, (I32)*(I32*)name.data - 1); \ + TAINT; \ + SvTAINTED_on(arg); \ DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \ } \ } @@ -422,6 +438,8 @@ START_MY_CXT #define CurrentDB (MY_CXT.x_CurrentDB) #define empty (MY_CXT.x_empty) +#define ERR_BUFF "DB_File::Error" + #ifdef DB_VERSION_MAJOR static int @@ -484,6 +502,13 @@ u_int flags ; #endif /* DB_VERSION_MAJOR */ +static void +tidyUp(DB_File db) +{ + /* db_DESTROY(db); */ + db->aborted = TRUE ; +} + static int #ifdef AT_LEAST_DB_3_2 @@ -518,7 +543,14 @@ const DBT * key2 ; void * data1, * data2 ; int retval ; int count ; + DB_File keep_CurrentDB = CurrentDB; + + if (CurrentDB->in_compare) { + tidyUp(CurrentDB); + croak ("DB_File btree_compare: recursion detected\n") ; + } + data1 = (char *) key1->data ; data2 = (char *) key2->data ; @@ -542,18 +574,26 @@ const DBT * key2 ; PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); PUTBACK ; + CurrentDB->in_compare = TRUE; + count = perl_call_sv(CurrentDB->compare, G_SCALAR); + CurrentDB = keep_CurrentDB; + CurrentDB->in_compare = FALSE; + SPAGAIN ; - if (count != 1) + if (count != 1){ + tidyUp(CurrentDB); croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ; + } retval = POPi ; PUTBACK ; FREETMPS ; LEAVE ; + return (retval) ; } @@ -590,7 +630,13 @@ const DBT * key2 ; char * data1, * data2 ; int retval ; int count ; + DB_File keep_CurrentDB = CurrentDB; + if (CurrentDB->in_prefix){ + tidyUp(CurrentDB); + croak ("DB_File btree_prefix: recursion detected\n") ; + } + data1 = (char *) key1->data ; data2 = (char *) key2->data ; @@ -614,12 +660,19 @@ const DBT * key2 ; PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); PUTBACK ; + CurrentDB->in_prefix = TRUE; + count = perl_call_sv(CurrentDB->prefix, G_SCALAR); + CurrentDB = keep_CurrentDB; + CurrentDB->in_prefix = FALSE; + SPAGAIN ; - if (count != 1) + if (count != 1){ + tidyUp(CurrentDB); croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ; + } retval = POPi ; @@ -668,6 +721,12 @@ HASH_CB_SIZE_TYPE size ; dMY_CXT; int retval ; int count ; + DB_File keep_CurrentDB = CurrentDB; + + if (CurrentDB->in_hash){ + tidyUp(CurrentDB); + croak ("DB_File hash callback: recursion detected\n") ; + } #ifndef newSVpvn if (size == 0) @@ -683,12 +742,19 @@ HASH_CB_SIZE_TYPE size ; XPUSHs(sv_2mortal(newSVpvn((char*)data,size))); PUTBACK ; + keep_CurrentDB->in_hash = TRUE; + count = perl_call_sv(CurrentDB->hash, G_SCALAR); + CurrentDB = keep_CurrentDB; + CurrentDB->in_hash = FALSE; + SPAGAIN ; - if (count != 1) + if (count != 1){ + tidyUp(CurrentDB); croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ; + } retval = POPi ; @@ -699,6 +765,23 @@ HASH_CB_SIZE_TYPE size ; return (retval) ; } +static void +#ifdef CAN_PROTOTYPE +db_errcall_cb(const char * db_errpfx, char * buffer) +#else +db_errcall_cb(db_errpfx, buffer) +const char * db_errpfx; +char * buffer; +#endif +{ + SV * sv = perl_get_sv(ERR_BUFF, FALSE) ; + if (sv) { + if (db_errpfx) + sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ; + else + sv_setpv(sv, buffer) ; + } +} #if defined(TRACE) && defined(BERKELEY_DB_1_OR_2) @@ -808,8 +891,10 @@ I32 value ; I32 length = GetArrayLength(aTHX_ db) ; /* check for attempt to write before start of array */ - if (length + value + 1 <= 0) + if (length + value + 1 <= 0) { + tidyUp(db); croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ; + } value = length + value + 1 ; } @@ -1333,14 +1418,22 @@ SV * sv ; Flags |= DB_TRUNCATE ; #endif +#ifdef AT_LEAST_DB_4_1 + status = (RETVAL->dbp->open)(RETVAL->dbp, NULL, name, NULL, RETVAL->type, + Flags, mode) ; +#else status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, Flags, mode) ; +#endif /* printf("open returned %d %s\n", status, db_strerror(status)) ; */ - if (status == 0) + if (status == 0) { + RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ; + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, 0) ; - /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */ + /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */ + } if (status) RETVAL->dbp = NULL ; @@ -1362,6 +1455,7 @@ INCLUDE: constants.xs BOOT: { + SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ; MY_CXT_INIT; __getBerkeleyDBInfo() ; @@ -1404,7 +1498,9 @@ db_DESTROY(db) dMY_CXT; INIT: CurrentDB = db ; + Trace(("DESTROY %p\n", db)); CLEANUP: + Trace(("DESTROY %p done\n", db)); if (db->hash) SvREFCNT_dec(db->hash) ; if (db->compare) @@ -1468,7 +1564,6 @@ db_FETCH(db, key, flags=0) DBT_clear(value) ; CurrentDB = db ; - /* RETVAL = ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) ; */ RETVAL = db_get(db, key, value, flags) ; ST(0) = sv_newmortal(); OutputValue(ST(0), value) diff --git a/ext/DB_File/dbinfo b/ext/DB_File/dbinfo index d349d07eef..af2c45facf 100644 --- a/ext/DB_File/dbinfo +++ b/ext/DB_File/dbinfo @@ -29,7 +29,8 @@ my %Data = 5 => "2.0.0 -> 2.3.0", 6 => "2.3.1 -> 2.7.7", 7 => "3.0.x", - 8 => "3.1.x or greater", + 8 => "3.1.x -> 4.0.x", + 9 => "4.1.x or greater", } }, 0x061561 => { @@ -42,7 +43,8 @@ my %Data = 4 => "2.0.0 -> 2.1.0", 5 => "2.2.6 -> 2.7.7", 6 => "3.0.x", - 7 => "3.1.x or greater", + 7 => "3.1.x -> 4.0.x", + 8 => "4.1.x or greater", } }, 0x042253 => { @@ -51,7 +53,8 @@ my %Data = { 1 => "3.0.x", 2 => "3.1.x", - 3 => "3.2.x or greater", + 3 => "3.2.x -> 4.0.x", + 4 => "4.1.x or greater", } }, ) ; diff --git a/ext/DB_File/t/db-btree.t b/ext/DB_File/t/db-btree.t index 1a79435f99..a990a5c4ba 100755 --- a/ext/DB_File/t/db-btree.t +++ b/ext/DB_File/t/db-btree.t @@ -24,7 +24,7 @@ BEGIN { && $Config{db_version_patch} == 0) { warn <<EOM; # -# This test is known to crash in Mac OS X versions 10.1.5 (or earlier) +# This test is known to crash in Mac OS X versions 10.1.4 (or earlier) # because of the buggy Berkeley DB version included with the OS. # EOM @@ -34,7 +34,7 @@ EOM use DB_File; use Fcntl; -print "1..163\n"; +print "1..177\n"; sub ok { @@ -110,6 +110,15 @@ sub normalise return $data ; } +sub safeUntie +{ + my $hashref = shift ; + my $no_inner = 1; + local $SIG{__WARN__} = sub {-- $no_inner } ; + untie %$hashref; + return $no_inner; +} + my $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; @@ -151,22 +160,16 @@ ok(13, $dbh->{minkeypage} == 123) ; $dbh->{maxkeypage} = 1234 ; ok(14, $dbh->{maxkeypage} == 1234 ); -$dbh->{compare} = 1234 ; -ok(15, $dbh->{compare} == 1234) ; - -$dbh->{prefix} = 1234 ; -ok(16, $dbh->{prefix} == 1234 ); - # Check that an invalid entry is caught both for store & fetch eval '$dbh->{fred} = 1234' ; -ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ; +ok(15, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ; eval 'my $q = $dbh->{fred}' ; -ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ; +ok(16, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ; # Now check the interface to BTREE my ($X, %h) ; -ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ; +ok(17, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ; die "Could not tie: $!" unless $X; my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, @@ -174,22 +177,22 @@ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ; -ok(20, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) +ok(18, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) || $noMode{$^O} ); my ($key, $value, $i); while (($key,$value) = each(%h)) { $i++; } -ok(21, !$i ) ; +ok(19, !$i ) ; $h{'goner1'} = 'snork'; $h{'abc'} = 'ABC'; -ok(22, $h{'abc'} eq 'ABC' ); -ok(23, ! defined $h{'jimmy'} ) ; -ok(24, ! exists $h{'jimmy'} ) ; -ok(25, defined $h{'abc'} ) ; +ok(20, $h{'abc'} eq 'ABC' ); +ok(21, ! defined $h{'jimmy'} ) ; +ok(22, ! exists $h{'jimmy'} ) ; +ok(23, defined $h{'abc'} ) ; $h{'def'} = 'DEF'; $h{'jkl','mno'} = "JKL\034MNO"; @@ -220,7 +223,7 @@ undef $X ; untie(%h); # tie to the same file again -ok(26, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ; +ok(24, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ; # Modify an entry from the previous tie $h{'g'} = 'G'; @@ -251,7 +254,7 @@ $X->DELETE('goner3'); my @keys = keys(%h); my @values = values(%h); -ok(27, $#keys == 29 && $#values == 29) ; +ok(25, $#keys == 29 && $#values == 29) ; $i = 0 ; while (($key,$value) = each(%h)) { @@ -261,18 +264,18 @@ while (($key,$value) = each(%h)) { } } -ok(28, $i == 30) ; +ok(26, $i == 30) ; @keys = ('blurfl', keys(%h), 'dyick'); -ok(29, $#keys == 31) ; +ok(27, $#keys == 31) ; #Check that the keys can be retrieved in order my @b = keys %h ; my @c = sort lexical @b ; -ok(30, ArrayCompare(\@b, \@c)) ; +ok(28, ArrayCompare(\@b, \@c)) ; $h{'foo'} = ''; -ok(31, $h{'foo'} eq '' ) ; +ok(29, $h{'foo'} eq '' ) ; # Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. # This feature was reenabled in version 3.1 of Berkeley DB. @@ -283,21 +286,21 @@ if ($null_keys_allowed) { } else { $result = 1 } -ok(32, $result) ; +ok(30, $result) ; # check cache overflow and numeric keys and contents my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -ok(33, $ok); +ok(31, $ok); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); -ok(34, $size > 0 ); +ok(32, $size > 0 ); @h{0..200} = 200..400; my @foo = @h{0..200}; -ok(35, join(':',200..400) eq join(':',@foo) ); +ok(33, join(':',200..400) eq join(':',@foo) ); # Now check all the non-tie specific stuff @@ -306,57 +309,57 @@ ok(35, join(':',200..400) eq join(':',@foo) ); # an existing record. my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; -ok(36, $status == 1 ); +ok(34, $status == 1 ); # check that the value of the key 'x' has not been changed by the # previous test -ok(37, $h{'x'} eq 'X' ); +ok(35, $h{'x'} eq 'X' ); # standard put $status = $X->put('key', 'value') ; -ok(38, $status == 0 ); +ok(36, $status == 0 ); #check that previous put can be retrieved $value = 0 ; $status = $X->get('key', $value) ; -ok(39, $status == 0 ); -ok(40, $value eq 'value' ); +ok(37, $status == 0 ); +ok(38, $value eq 'value' ); # Attempting to delete an existing key should work $status = $X->del('q') ; -ok(41, $status == 0 ); +ok(39, $status == 0 ); if ($null_keys_allowed) { $status = $X->del('') ; } else { $status = 0 ; } -ok(42, $status == 0 ); +ok(40, $status == 0 ); # Make sure that the key deleted, cannot be retrieved -ok(43, ! defined $h{'q'}) ; -ok(44, ! defined $h{''}) ; +ok(41, ! defined $h{'q'}) ; +ok(42, ! defined $h{''}) ; undef $X ; untie %h ; -ok(45, $X = tie(%h, 'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE )); +ok(43, $X = tie(%h, 'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE )); # Attempting to delete a non-existant key should fail $status = $X->del('joe') ; -ok(46, $status == 1 ); +ok(44, $status == 1 ); # Check the get interface # First a non-existing key $status = $X->get('aaaa', $value) ; -ok(47, $status == 1 ); +ok(45, $status == 1 ); # Next an existing key $status = $X->get('a', $value) ; -ok(48, $status == 0 ); -ok(49, $value eq 'A' ); +ok(46, $status == 0 ); +ok(47, $value eq 'A' ); # seq # ### @@ -365,15 +368,15 @@ ok(49, $value eq 'A' ); $key = 'ke' ; $value = '' ; $status = $X->seq($key, $value, R_CURSOR) ; -ok(50, $status == 0 ); -ok(51, $key eq 'key' ); -ok(52, $value eq 'value' ); +ok(48, $status == 0 ); +ok(49, $key eq 'key' ); +ok(50, $value eq 'value' ); # seq when the key does not match $key = 'zzz' ; $value = '' ; $status = $X->seq($key, $value, R_CURSOR) ; -ok(53, $status == 1 ); +ok(51, $status == 1 ); # use seq to set the cursor, then delete the record @ the cursor. @@ -381,36 +384,36 @@ ok(53, $status == 1 ); $key = 'x' ; $value = '' ; $status = $X->seq($key, $value, R_CURSOR) ; -ok(54, $status == 0 ); -ok(55, $key eq 'x' ); -ok(56, $value eq 'X' ); +ok(52, $status == 0 ); +ok(53, $key eq 'x' ); +ok(54, $value eq 'X' ); $status = $X->del(0, R_CURSOR) ; -ok(57, $status == 0 ); +ok(55, $status == 0 ); $status = $X->get('x', $value) ; -ok(58, $status == 1 ); +ok(56, $status == 1 ); # ditto, but use put to replace the key/value pair. $key = 'y' ; $value = '' ; $status = $X->seq($key, $value, R_CURSOR) ; -ok(59, $status == 0 ); -ok(60, $key eq 'y' ); -ok(61, $value eq 'Y' ); +ok(57, $status == 0 ); +ok(58, $key eq 'y' ); +ok(59, $value eq 'Y' ); $key = "replace key" ; $value = "replace value" ; $status = $X->put($key, $value, R_CURSOR) ; -ok(62, $status == 0 ); -ok(63, $key eq 'replace key' ); -ok(64, $value eq 'replace value' ); +ok(60, $status == 0 ); +ok(61, $key eq 'replace key' ); +ok(62, $value eq 'replace value' ); $status = $X->get('y', $value) ; -ok(65, 1) ; # hard-wire to always pass. the previous test ($status == 1) +ok(63, 1) ; # hard-wire to always pass. the previous test ($status == 1) # only worked because of a bug in 1.85/6 # use seq to walk forwards through a file $status = $X->seq($key, $value, R_FIRST) ; -ok(66, $status == 0 ); +ok(64, $status == 0 ); my $previous = $key ; $ok = 1 ; @@ -419,12 +422,12 @@ while (($status = $X->seq($key, $value, R_NEXT)) == 0) ($ok = 0), last if ($previous cmp $key) == 1 ; } -ok(67, $status == 1 ); -ok(68, $ok == 1 ); +ok(65, $status == 1 ); +ok(66, $ok == 1 ); # use seq to walk backwards through a file $status = $X->seq($key, $value, R_LAST) ; -ok(69, $status == 0 ); +ok(67, $status == 0 ); $previous = $key ; $ok = 1 ; @@ -434,8 +437,8 @@ while (($status = $X->seq($key, $value, R_PREV)) == 0) #print "key = [$key] value = [$value]\n" ; } -ok(70, $status == 1 ); -ok(71, $ok == 1 ); +ok(68, $status == 1 ); +ok(69, $ok == 1 ); # check seq FIRST/LAST @@ -444,14 +447,14 @@ ok(71, $ok == 1 ); # #### $status = $X->sync ; -ok(72, $status == 0 ); +ok(70, $status == 0 ); # fd # ## $status = $X->fd ; -ok(73, $status != 0 ); +ok(71, $status != 0 ); undef $X ; @@ -461,11 +464,11 @@ unlink $Dfile; # Now try an in memory file my $Y; -ok(74, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )); +ok(72, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )); # fd with an in memory file should return failure $status = $Y->fd ; -ok(75, $status == -1 ); +ok(73, $status == -1 ); undef $Y ; @@ -475,7 +478,7 @@ untie %h ; my $bt = new DB_File::BTREEINFO ; $bt->{flags} = R_DUP ; my ($YY, %hh); -ok(76, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ; +ok(74, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ; $hh{'Wall'} = 'Larry' ; $hh{'Wall'} = 'Stone' ; # Note the duplicate key @@ -485,33 +488,33 @@ $hh{'Smith'} = 'John' ; $hh{'mouse'} = 'mickey' ; # first work in scalar context -ok(77, scalar $YY->get_dup('Unknown') == 0 ); -ok(78, scalar $YY->get_dup('Smith') == 1 ); -ok(79, scalar $YY->get_dup('Wall') == 4 ); +ok(75, scalar $YY->get_dup('Unknown') == 0 ); +ok(76, scalar $YY->get_dup('Smith') == 1 ); +ok(77, scalar $YY->get_dup('Wall') == 4 ); # now in list context my @unknown = $YY->get_dup('Unknown') ; -ok(80, "@unknown" eq "" ); +ok(78, "@unknown" eq "" ); my @smith = $YY->get_dup('Smith') ; -ok(81, "@smith" eq "John" ); +ok(79, "@smith" eq "John" ); { my @wall = $YY->get_dup('Wall') ; my %wall ; @wall{@wall} = @wall ; -ok(82, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ); +ok(80, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ); } # hash my %unknown = $YY->get_dup('Unknown', 1) ; -ok(83, keys %unknown == 0 ); +ok(81, keys %unknown == 0 ); my %smith = $YY->get_dup('Smith', 1) ; -ok(84, keys %smith == 1 && $smith{'John'}) ; +ok(82, keys %smith == 1 && $smith{'John'}) ; my %wall = $YY->get_dup('Wall', 1) ; -ok(85, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 +ok(83, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 && $wall{'Brick'} == 2); undef $YY ; @@ -570,9 +573,9 @@ sub ArrayCompare 1 ; } -ok(86, ArrayCompare (\@srt_1, [keys %h]) ); -ok(87, ArrayCompare (\@srt_2, [keys %g]) ); -ok(88, ArrayCompare (\@srt_3, [keys %k]) ); +ok(84, ArrayCompare (\@srt_1, [keys %h]) ); +ok(85, ArrayCompare (\@srt_2, [keys %g]) ); +ok(86, ArrayCompare (\@srt_3, [keys %k]) ); untie %h ; untie %g ; @@ -582,7 +585,7 @@ unlink $Dfile1, $Dfile2, $Dfile3 ; # clear # ##### -ok(89, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); +ok(87, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); foreach (1 .. 10) { $h{$_} = $_ * 100 } @@ -591,7 +594,7 @@ $i = 0 ; while (($key,$value) = each(%h)) { $i++; } -ok(90, $i == 10); +ok(88, $i == 10); # now clear the hash %h = () ; @@ -601,7 +604,7 @@ $i = 0 ; while (($key,$value) = each(%h)) { $i++; } -ok(91, $i == 0); +ok(89, $i == 0); untie %h ; unlink $Dfile1 ; @@ -612,7 +615,7 @@ unlink $Dfile1 ; my $filename = "xyz" ; my @x ; eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE ; } ; - ok(92, $@ =~ /^DB_File can only tie an associative array to a DB_BTREE database/) ; + ok(90, $@ =~ /^DB_File can only tie an associative array to a DB_BTREE database/) ; unlink $filename ; } @@ -679,31 +682,31 @@ EOM BEGIN { push @INC, '.'; } eval 'use SubDB ; '; - main::ok(93, $@ eq "") ; + main::ok(91, $@ eq "") ; my %h ; my $X ; eval ' $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE ); ' ; - main::ok(94, $@ eq "") ; + main::ok(92, $@ eq "") ; my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok(95, $@ eq "") ; - main::ok(96, $ret == 5) ; + main::ok(93, $@ eq "") ; + main::ok(94, $ret == 5) ; my $value = 0; $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; - main::ok(97, $@ eq "") ; - main::ok(98, $ret == 10) ; + main::ok(95, $@ eq "") ; + main::ok(96, $ret == 10) ; $ret = eval ' R_NEXT eq main::R_NEXT ' ; - main::ok(99, $@ eq "" ) ; - main::ok(100, $ret == 1) ; + main::ok(97, $@ eq "" ) ; + main::ok(98, $ret == 1) ; $ret = eval '$X->A_new_method("joe") ' ; - main::ok(101, $@ eq "") ; - main::ok(102, $ret eq "[[11]]") ; + main::ok(99, $@ eq "") ; + main::ok(100, $ret eq "[[11]]") ; undef $X; untie(%h); @@ -728,7 +731,7 @@ EOM $_ eq 'original' ; } - ok(103, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + ok(101, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); $db->filter_fetch_key (sub { $fetch_key = $_ }) ; $db->filter_store_key (sub { $store_key = $_ }) ; @@ -739,17 +742,17 @@ EOM $h{"fred"} = "joe" ; # fk sk fv sv - ok(104, checkOutput( "", "fred", "", "joe")) ; + ok(102, checkOutput( "", "fred", "", "joe")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(105, $h{"fred"} eq "joe"); + ok(103, $h{"fred"} eq "joe"); # fk sk fv sv - ok(106, checkOutput( "", "fred", "joe", "")) ; + ok(104, checkOutput( "", "fred", "joe", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(107, $db->FIRSTKEY() eq "fred") ; + ok(105, $db->FIRSTKEY() eq "fred") ; # fk sk fv sv - ok(108, checkOutput( "fred", "", "", "")) ; + ok(106, checkOutput( "fred", "", "", "")) ; # replace the filters, but remember the previous set my ($old_fk) = $db->filter_fetch_key @@ -764,17 +767,17 @@ EOM ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $h{"Fred"} = "Joe" ; # fk sk fv sv - ok(109, checkOutput( "", "fred", "", "Jxe")) ; + ok(107, checkOutput( "", "fred", "", "Jxe")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(110, $h{"Fred"} eq "[Jxe]"); + ok(108, $h{"Fred"} eq "[Jxe]"); # fk sk fv sv - ok(111, checkOutput( "", "fred", "[Jxe]", "")) ; + ok(109, checkOutput( "", "fred", "[Jxe]", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(112, $db->FIRSTKEY() eq "FRED") ; + ok(110, $db->FIRSTKEY() eq "FRED") ; # fk sk fv sv - ok(113, checkOutput( "FRED", "", "", "")) ; + ok(111, checkOutput( "FRED", "", "", "")) ; # put the original filters back $db->filter_fetch_key ($old_fk); @@ -784,15 +787,15 @@ EOM ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $h{"fred"} = "joe" ; - ok(114, checkOutput( "", "fred", "", "joe")) ; + ok(112, checkOutput( "", "fred", "", "joe")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(115, $h{"fred"} eq "joe"); - ok(116, checkOutput( "", "fred", "joe", "")) ; + ok(113, $h{"fred"} eq "joe"); + ok(114, checkOutput( "", "fred", "joe", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(117, $db->FIRSTKEY() eq "fred") ; - ok(118, checkOutput( "fred", "", "", "")) ; + ok(115, $db->FIRSTKEY() eq "fred") ; + ok(116, checkOutput( "fred", "", "", "")) ; # delete the filters $db->filter_fetch_key (undef); @@ -802,15 +805,15 @@ EOM ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $h{"fred"} = "joe" ; - ok(119, checkOutput( "", "", "", "")) ; + ok(117, checkOutput( "", "", "", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(120, $h{"fred"} eq "joe"); - ok(121, checkOutput( "", "", "", "")) ; + ok(118, $h{"fred"} eq "joe"); + ok(119, checkOutput( "", "", "", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(122, $db->FIRSTKEY() eq "fred") ; - ok(123, checkOutput( "", "", "", "")) ; + ok(120, $db->FIRSTKEY() eq "fred") ; + ok(121, checkOutput( "", "", "", "")) ; undef $db ; untie %h; @@ -825,7 +828,7 @@ EOM my (%h, $db) ; unlink $Dfile; - ok(124, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + ok(122, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); my %result = () ; @@ -849,32 +852,32 @@ EOM $_ = "original" ; $h{"fred"} = "joe" ; - ok(125, $result{"store key"} eq "store key - 1: [fred]"); - ok(126, $result{"store value"} eq "store value - 1: [joe]"); - ok(127, ! defined $result{"fetch key"} ); - ok(128, ! defined $result{"fetch value"} ); - ok(129, $_ eq "original") ; - - ok(130, $db->FIRSTKEY() eq "fred") ; - ok(131, $result{"store key"} eq "store key - 1: [fred]"); - ok(132, $result{"store value"} eq "store value - 1: [joe]"); - ok(133, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(134, ! defined $result{"fetch value"} ); - ok(135, $_ eq "original") ; + ok(123, $result{"store key"} eq "store key - 1: [fred]"); + ok(124, $result{"store value"} eq "store value - 1: [joe]"); + ok(125, ! defined $result{"fetch key"} ); + ok(126, ! defined $result{"fetch value"} ); + ok(127, $_ eq "original") ; + + ok(128, $db->FIRSTKEY() eq "fred") ; + ok(129, $result{"store key"} eq "store key - 1: [fred]"); + ok(130, $result{"store value"} eq "store value - 1: [joe]"); + ok(131, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(132, ! defined $result{"fetch value"} ); + ok(133, $_ eq "original") ; $h{"jim"} = "john" ; - ok(136, $result{"store key"} eq "store key - 2: [fred jim]"); - ok(137, $result{"store value"} eq "store value - 2: [joe john]"); - ok(138, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(139, ! defined $result{"fetch value"} ); - ok(140, $_ eq "original") ; - - ok(141, $h{"fred"} eq "joe"); - ok(142, $result{"store key"} eq "store key - 3: [fred jim fred]"); - ok(143, $result{"store value"} eq "store value - 2: [joe john]"); - ok(144, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(145, $result{"fetch value"} eq "fetch value - 1: [joe]"); - ok(146, $_ eq "original") ; + ok(134, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(135, $result{"store value"} eq "store value - 2: [joe john]"); + ok(136, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(137, ! defined $result{"fetch value"} ); + ok(138, $_ eq "original") ; + + ok(139, $h{"fred"} eq "joe"); + ok(140, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(141, $result{"store value"} eq "store value - 2: [joe john]"); + ok(142, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(143, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(144, $_ eq "original") ; undef $db ; untie %h; @@ -888,12 +891,12 @@ EOM my (%h, $db) ; unlink $Dfile; - ok(147, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + ok(145, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); $db->filter_store_key (sub { $_ = $h{$_} }) ; eval '$h{1} = 1234' ; - ok(148, $@ =~ /^recursion detected in filter_store_key at/ ); + ok(146, $@ =~ /^recursion detected in filter_store_key at/ ); undef $db ; untie %h; @@ -953,7 +956,7 @@ EOM delete $DB_BTREE->{'compare'} ; - ok(149, docat_del($file) eq <<'EOM') ; + ok(147, docat_del($file) eq <<'EOM') ; mouse Smith Wall @@ -997,7 +1000,7 @@ EOM unlink $filename ; } - ok(150, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ; + ok(148, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ; Smith -> John Wall -> Brick Wall -> Brick @@ -1052,7 +1055,7 @@ EOM untie %h ; } - ok(151, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ; + ok(149, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ; Smith -> John Wall -> Brick Wall -> Brick @@ -1107,7 +1110,7 @@ EOM untie %h ; } - ok(152, docat_del($file) eq <<'EOM') ; + ok(150, docat_del($file) eq <<'EOM') ; Wall occurred 3 times Larry is there There are 2 Brick Walls @@ -1146,7 +1149,7 @@ EOM untie %h ; } - ok(153, docat_del($file) eq <<'EOM') ; + ok(151, docat_del($file) eq <<'EOM') ; Larry Wall is there Harry Wall is not there EOM @@ -1182,7 +1185,7 @@ EOM unlink $filename ; } - ok(154, docat_del($file) eq <<'EOM') ; + ok(152, docat_del($file) eq <<'EOM') ; Larry Wall is not there EOM @@ -1242,7 +1245,7 @@ EOM } - ok(155, docat_del($file) eq <<'EOM') ; + ok(153, docat_del($file) eq <<'EOM') ; IN ORDER Smith -> John Wall -> Larry @@ -1301,7 +1304,7 @@ EOM tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE or die "Can't open file: $!\n" ; $h{ABC} = undef; - ok(156, $a eq "") ; + ok(154, $a eq "") ; untie %h ; unlink $Dfile; } @@ -1321,7 +1324,7 @@ EOM tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE or die "Can't open file: $!\n" ; %h = (); ; - ok(157, $a eq "") ; + ok(155, $a eq "") ; untie %h ; unlink $Dfile; } @@ -1341,31 +1344,146 @@ EOM my $bad_key = 0 ; my %h = () ; my $db ; - ok(158, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ; $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ; $h{'Alpha_ABC'} = 2 ; $h{'Alpha_DEF'} = 5 ; - ok(159, $h{'Alpha_ABC'} == 2); - ok(160, $h{'Alpha_DEF'} == 5); + ok(157, $h{'Alpha_ABC'} == 2); + ok(158, $h{'Alpha_DEF'} == 5); my ($k, $v) = ("",""); while (($k, $v) = each %h) {} - ok(161, $bad_key == 0); + ok(159, $bad_key == 0); $bad_key = 0 ; foreach $k (keys %h) {} - ok(162, $bad_key == 0); + ok(160, $bad_key == 0); $bad_key = 0 ; foreach $v (values %h) {} - ok(163, $bad_key == 0); + ok(161, $bad_key == 0); undef $db ; untie %h ; unlink $Dfile; } +{ + # now an error to pass 'compare' a non-code reference + my $dbh = new DB_File::BTREEINFO ; + + eval { $dbh->{compare} = 2 }; + ok(162, $@ =~ /^Key 'compare' not associated with a code reference at/); + + eval { $dbh->{prefix} = 2 }; + ok(163, $@ =~ /^Key 'prefix' not associated with a code reference at/); + +} + + +{ + # recursion detection in btree + my %hash ; + unlink $Dfile; + my $dbh = new DB_File::BTREEINFO ; + $dbh->{compare} = sub { $hash{3} = 4 ; length $_[0] } ; + + + my (%h); + ok(164, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ); + + eval { $hash{1} = 2; + $hash{4} = 5; + }; + + ok(165, $@ =~ /^DB_File btree_compare: recursion detected/); + { + no warnings; + untie %hash; + } + unlink $Dfile; +} + +{ + # Check that two callbacks don't interact + my %hash1 ; + my %hash2 ; + my $h1_count = 0; + my $h2_count = 0; + unlink $Dfile, $Dfile2; + my $dbh1 = new DB_File::BTREEINFO ; + $dbh1->{compare} = sub { ++ $h1_count ; $_[0] cmp $_[1] } ; + + my $dbh2 = new DB_File::BTREEINFO ; + $dbh2->{compare} = sub { ;++ $h2_count ; $_[0] cmp $_[1] } ; + + + + my (%h); + ok(166, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) ); + ok(167, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ); + + $hash1{DEFG} = 5; + $hash1{XYZ} = 2; + $hash1{ABCDE} = 5; + + $hash2{defg} = 5; + $hash2{xyz} = 2; + $hash2{abcde} = 5; + + ok(168, $h1_count > 0); + ok(169, $h1_count == $h2_count); + + ok(170, safeUntie \%hash1); + ok(171, safeUntie \%hash2); + unlink $Dfile, $Dfile2; +} + +{ + # Check that DBM Filter can cope with read-only $_ + + use warnings ; + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(172, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + $db->filter_fetch_key (sub { }) ; + $db->filter_store_key (sub { }) ; + $db->filter_fetch_value (sub { }) ; + $db->filter_store_value (sub { }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(173, $h{"fred"} eq "joe"); + + eval { grep { $h{$_} } (1, 2, 3) }; + ok (174, ! $@); + + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + $h{"fred"} = "joe" ; + + ok(175, $h{"fred"} eq "joe"); + + ok(176, $db->FIRSTKEY() eq "fred") ; + + eval { grep { $h{$_} } (1, 2, 3) }; + ok (177, ! $@); + + undef $db ; + untie %h; + unlink $Dfile; +} + exit ; diff --git a/ext/DB_File/t/db-hash.t b/ext/DB_File/t/db-hash.t index 931b03c96a..10623cc82a 100755 --- a/ext/DB_File/t/db-hash.t +++ b/ext/DB_File/t/db-hash.t @@ -23,7 +23,7 @@ BEGIN { use DB_File; use Fcntl; -print "1..117\n"; +print "1..143\n"; sub ok { @@ -76,9 +76,18 @@ sub normalise return $data ; } +sub safeUntie +{ + my $hashref = shift ; + my $no_inner = 1; + local $SIG{__WARN__} = sub {-- $no_inner } ; + untie %$hashref; + return $no_inner; +} my $Dfile = "dbhash.tmp"; +my $Dfile2 = "dbhash2.tmp"; my $null_keys_allowed = ($DB_File::db_ver < 2.004010 || $DB_File::db_ver >= 3.1 ); @@ -109,8 +118,9 @@ ok(9, $dbh->{nelem} == 400 ); $dbh->{cachesize} = 65 ; ok(10, $dbh->{cachesize} == 65 ); -$dbh->{hash} = "abc" ; -ok(11, $dbh->{hash} eq "abc" ); +my $some_sub = sub {} ; +$dbh->{hash} = $some_sub; +ok(11, $dbh->{hash} eq $some_sub ); $dbh->{lorder} = 1234 ; ok(12, $dbh->{lorder} == 1234 ); @@ -498,9 +508,22 @@ EOM sub checkOutput { + no warnings 'uninitialized'; my($fk, $sk, $fv, $sv) = @_ ; + + print "# Fetch Key : expected '$fk' got '$fetch_key'\n" + if $fetch_key ne $fk ; + print "# Fetch Value : expected '$fv' got '$fetch_value'\n" + if $fetch_value ne $fv ; + print "# Store Key : expected '$sk' got '$store_key'\n" + if $store_key ne $sk ; + print "# Store Value : expected '$sv' got '$store_value'\n" + if $store_value ne $sv ; + print "# \$_ : expected 'original' got '$_'\n" + if $_ ne 'original' ; + return - $fetch_key eq $fk && $store_key eq $sk && + $fetch_key eq $fk && $store_key eq $sk && $fetch_value eq $fv && $store_value eq $sv && $_ eq 'original' ; } @@ -524,9 +547,13 @@ EOM ok(66, checkOutput( "", "fred", "joe", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(67, $db->FIRSTKEY() eq "fred") ; + my ($k, $v) ; + $k = 'fred'; + ok(67, ! $db->seq($k, $v, R_FIRST) ) ; + ok(68, $k eq "fred") ; + ok(69, $v eq "joe") ; # fk sk fv sv - ok(68, checkOutput( "fred", "", "", "")) ; + ok(70, checkOutput( "fred", "fred", "joe", "")) ; # replace the filters, but remember the previous set my ($old_fk) = $db->filter_fetch_key @@ -541,17 +568,20 @@ EOM ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $h{"Fred"} = "Joe" ; # fk sk fv sv - ok(69, checkOutput( "", "fred", "", "Jxe")) ; + ok(71, checkOutput( "", "fred", "", "Jxe")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(70, $h{"Fred"} eq "[Jxe]"); + ok(72, $h{"Fred"} eq "[Jxe]"); # fk sk fv sv - ok(71, checkOutput( "", "fred", "[Jxe]", "")) ; + ok(73, checkOutput( "", "fred", "[Jxe]", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(72, $db->FIRSTKEY() eq "FRED") ; + $k = 'Fred'; $v =''; + ok(74, ! $db->seq($k, $v, R_FIRST) ) ; + ok(75, $k eq "FRED") ; + ok(76, $v eq "[Jxe]") ; # fk sk fv sv - ok(73, checkOutput( "FRED", "", "", "")) ; + ok(77, checkOutput( "FRED", "fred", "[Jxe]", "")) ; # put the original filters back $db->filter_fetch_key ($old_fk); @@ -561,15 +591,20 @@ EOM ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $h{"fred"} = "joe" ; - ok(74, checkOutput( "", "fred", "", "joe")) ; + ok(78, checkOutput( "", "fred", "", "joe")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(75, $h{"fred"} eq "joe"); - ok(76, checkOutput( "", "fred", "joe", "")) ; + ok(79, $h{"fred"} eq "joe"); + ok(80, checkOutput( "", "fred", "joe", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(77, $db->FIRSTKEY() eq "fred") ; - ok(78, checkOutput( "fred", "", "", "")) ; + #ok(77, $db->FIRSTKEY() eq "fred") ; + $k = 'fred'; + ok(81, ! $db->seq($k, $v, R_FIRST) ) ; + ok(82, $k eq "fred") ; + ok(83, $v eq "joe") ; + # fk sk fv sv + ok(84, checkOutput( "fred", "fred", "joe", "")) ; # delete the filters $db->filter_fetch_key (undef); @@ -579,15 +614,18 @@ EOM ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $h{"fred"} = "joe" ; - ok(79, checkOutput( "", "", "", "")) ; + ok(85, checkOutput( "", "", "", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(80, $h{"fred"} eq "joe"); - ok(81, checkOutput( "", "", "", "")) ; + ok(86, $h{"fred"} eq "joe"); + ok(87, checkOutput( "", "", "", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(82, $db->FIRSTKEY() eq "fred") ; - ok(83, checkOutput( "", "", "", "")) ; + $k = 'fred'; + ok(88, ! $db->seq($k, $v, R_FIRST) ) ; + ok(89, $k eq "fred") ; + ok(90, $v eq "joe") ; + ok(91, checkOutput( "", "", "", "")) ; undef $db ; untie %h; @@ -602,7 +640,7 @@ EOM my (%h, $db) ; unlink $Dfile; - ok(84, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + ok(92, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); my %result = () ; @@ -626,32 +664,32 @@ EOM $_ = "original" ; $h{"fred"} = "joe" ; - ok(85, $result{"store key"} eq "store key - 1: [fred]"); - ok(86, $result{"store value"} eq "store value - 1: [joe]"); - ok(87, ! defined $result{"fetch key"} ); - ok(88, ! defined $result{"fetch value"} ); - ok(89, $_ eq "original") ; - - ok(90, $db->FIRSTKEY() eq "fred") ; - ok(91, $result{"store key"} eq "store key - 1: [fred]"); - ok(92, $result{"store value"} eq "store value - 1: [joe]"); - ok(93, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(94, ! defined $result{"fetch value"} ); - ok(95, $_ eq "original") ; + ok(93, $result{"store key"} eq "store key - 1: [fred]"); + ok(94, $result{"store value"} eq "store value - 1: [joe]"); + ok(95, ! defined $result{"fetch key"} ); + ok(96, ! defined $result{"fetch value"} ); + ok(97, $_ eq "original") ; + + ok(98, $db->FIRSTKEY() eq "fred") ; + ok(99, $result{"store key"} eq "store key - 1: [fred]"); + ok(100, $result{"store value"} eq "store value - 1: [joe]"); + ok(101, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(102, ! defined $result{"fetch value"} ); + ok(103, $_ eq "original") ; $h{"jim"} = "john" ; - ok(96, $result{"store key"} eq "store key - 2: [fred jim]"); - ok(97, $result{"store value"} eq "store value - 2: [joe john]"); - ok(98, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(99, ! defined $result{"fetch value"} ); - ok(100, $_ eq "original") ; - - ok(101, $h{"fred"} eq "joe"); - ok(102, $result{"store key"} eq "store key - 3: [fred jim fred]"); - ok(103, $result{"store value"} eq "store value - 2: [joe john]"); - ok(104, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(105, $result{"fetch value"} eq "fetch value - 1: [joe]"); - ok(106, $_ eq "original") ; + ok(104, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(105, $result{"store value"} eq "store value - 2: [joe john]"); + ok(106, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(107, ! defined $result{"fetch value"} ); + ok(108, $_ eq "original") ; + + ok(109, $h{"fred"} eq "joe"); + ok(110, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(111, $result{"store value"} eq "store value - 2: [joe john]"); + ok(112, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(113, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(114, $_ eq "original") ; undef $db ; untie %h; @@ -665,12 +703,12 @@ EOM my (%h, $db) ; unlink $Dfile; - ok(107, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + ok(115, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); $db->filter_store_key (sub { $_ = $h{$_} }) ; eval '$h{1} = 1234' ; - ok(108, $@ =~ /^recursion detected in filter_store_key at/ ); + ok(116, $@ =~ /^recursion detected in filter_store_key at/ ); undef $db ; untie %h; @@ -715,7 +753,7 @@ EOM unlink "fruit" ; } - ok(109, docat_del($file) eq <<'EOM') ; + ok(117, docat_del($file) eq <<'EOM') ; Banana Exists orange -> orange @@ -741,7 +779,7 @@ EOM tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; $h{ABC} = undef; - ok(110, $a eq "") ; + ok(118, $a eq "") ; untie %h ; unlink $Dfile; } @@ -760,7 +798,7 @@ EOM tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; %h = (); ; - ok(111, $a eq "") ; + ok(119, $a eq "") ; untie %h ; unlink $Dfile; } @@ -780,31 +818,164 @@ EOM my $bad_key = 0 ; my %h = () ; my $db ; - ok(112, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + ok(120, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ; $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ; $h{'Alpha_ABC'} = 2 ; $h{'Alpha_DEF'} = 5 ; - ok(113, $h{'Alpha_ABC'} == 2); - ok(114, $h{'Alpha_DEF'} == 5); + ok(121, $h{'Alpha_ABC'} == 2); + ok(122, $h{'Alpha_DEF'} == 5); my ($k, $v) = ("",""); while (($k, $v) = each %h) {} - ok(115, $bad_key == 0); + ok(123, $bad_key == 0); $bad_key = 0 ; foreach $k (keys %h) {} - ok(116, $bad_key == 0); + ok(124, $bad_key == 0); $bad_key = 0 ; foreach $v (values %h) {} - ok(117, $bad_key == 0); + ok(125, $bad_key == 0); undef $db ; untie %h ; unlink $Dfile; } +{ + # now an error to pass 'hash' a non-code reference + my $dbh = new DB_File::HASHINFO ; + + eval { $dbh->{hash} = 2 }; + ok(126, $@ =~ /^Key 'hash' not associated with a code reference at/); + +} + +{ + # recursion detection in hash + my %hash ; + unlink $Dfile; + my $dbh = new DB_File::HASHINFO ; + $dbh->{hash} = sub { $hash{3} = 4 ; length $_[0] } ; + + + my (%h); + ok(127, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ); + + eval { $hash{1} = 2; + $hash{4} = 5; + }; + + ok(128, $@ =~ /^DB_File hash callback: recursion detected/); + { + no warnings; + untie %hash; + } + unlink $Dfile; +} + +{ + # Check that two hash's don't interact + my %hash1 ; + my %hash2 ; + my $h1_count = 0; + my $h2_count = 0; + unlink $Dfile, $Dfile2; + my $dbh1 = new DB_File::HASHINFO ; + $dbh1->{hash} = sub { ++ $h1_count ; length $_[0] } ; + + my $dbh2 = new DB_File::HASHINFO ; + $dbh2->{hash} = sub { ++ $h2_count ; length $_[0] } ; + + + + my (%h); + ok(129, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) ); + ok(130, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ); + + $hash1{DEFG} = 5; + $hash1{XYZ} = 2; + $hash1{ABCDE} = 5; + + $hash2{defg} = 5; + $hash2{xyz} = 2; + $hash2{abcde} = 5; + + ok(131, $h1_count > 0); + ok(132, $h1_count == $h2_count); + + ok(133, safeUntie \%hash1); + ok(134, safeUntie \%hash2); + unlink $Dfile, $Dfile2; +} + +{ + # Passing undef for flags and/or mode when calling tie could cause + # Use of uninitialized value in subroutine entry + + + my $warn_count = 0 ; + #local $SIG{__WARN__} = sub { ++ $warn_count }; + my %hash1; + unlink $Dfile; + + tie %hash1, 'DB_File',$Dfile, undef; + ok(135, $warn_count == 0); + $warn_count = 0; + tie %hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, undef; + ok(136, $warn_count == 0); + tie %hash1, 'DB_File',$Dfile, undef, undef; + ok(137, $warn_count == 0); + $warn_count = 0; + + unlink $Dfile; +} + +{ + # Check that DBM Filter can cope with read-only $_ + + use warnings ; + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(138, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + $db->filter_fetch_key (sub { }) ; + $db->filter_store_key (sub { }) ; + $db->filter_fetch_value (sub { }) ; + $db->filter_store_value (sub { }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(139, $h{"fred"} eq "joe"); + + eval { grep { $h{$_} } (1, 2, 3) }; + ok (140, ! $@); + + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + $h{"fred"} = "joe" ; + + ok(141, $h{"fred"} eq "joe"); + + ok(142, $db->FIRSTKEY() eq "fred") ; + + eval { grep { $h{$_} } (1, 2, 3) }; + ok (143, ! $@); + + undef $db ; + untie %h; + unlink $Dfile; +} + exit ; diff --git a/ext/DB_File/t/db-recno.t b/ext/DB_File/t/db-recno.t index 9387e334e7..5390b54937 100755 --- a/ext/DB_File/t/db-recno.t +++ b/ext/DB_File/t/db-recno.t @@ -89,6 +89,15 @@ sub docat_del return $result; } +sub safeUntie +{ + my $hashref = shift ; + my $no_inner = 1; + local $SIG{__WARN__} = sub {-- $no_inner } ; + untie @$hashref; + return $no_inner; +} + sub bad_one { unless ($bad_ones++) { @@ -103,7 +112,7 @@ EOM && $Config{db_version_patch} == 0) { print STDERR <<EOM ; # -# For example Mac OS X 10.1.5 (or earlier) has such an old +# For example Mac OS X 10.1.4 (or earlier) has such an old # version of Berkeley DB. EOM } @@ -141,8 +150,8 @@ BEGIN } } -my $splice_tests = 10 + 11 + 1; # ten regressions, 11 warnings, plus the randoms -my $total_tests = 138 ; +my $splice_tests = 10 + 12 + 1; # ten regressions, plus the randoms +my $total_tests = 158 ; $total_tests += $splice_tests if $FA ; print "1..$total_tests\n"; @@ -313,7 +322,7 @@ ok(57, $@ =~ '^Modification of non-creatable array value attempted' ); # IMPORTANT - $X must be undefined before the untie otherwise the # underlying DB close routine will not get called. undef $X ; -untie(@h); +ok(58, safeUntie \@h); unlink $Dfile; @@ -323,14 +332,14 @@ unlink $Dfile; my @h = () ; my $dbh = new DB_File::RECNOINFO ; - ok(58, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + ok(59, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; $h[0] = "abc" ; $h[1] = "def" ; $h[3] = "ghi" ; - untie @h ; + ok(60, safeUntie \@h); my $x = docat($Dfile) ; unlink $Dfile; - ok(59, $x eq "abc\ndef\n\nghi\n") ; + ok(61, $x eq "abc\ndef\n\nghi\n") ; } { @@ -339,16 +348,16 @@ unlink $Dfile; my @h = () ; my $dbh = new DB_File::RECNOINFO ; $dbh->{bval} = "-" ; - ok(60, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + ok(62, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; $h[0] = "abc" ; $h[1] = "def" ; $h[3] = "ghi" ; - untie @h ; + ok(63, safeUntie \@h); my $x = docat($Dfile) ; unlink $Dfile; my $ok = ($x eq "abc-def--ghi-") ; bad_one() unless $ok ; - ok(61, $ok) ; + ok(64, $ok) ; } { @@ -358,16 +367,16 @@ unlink $Dfile; my $dbh = new DB_File::RECNOINFO ; $dbh->{flags} = R_FIXEDLEN ; $dbh->{reclen} = 5 ; - ok(62, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + ok(65, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; $h[0] = "abc" ; $h[1] = "def" ; $h[3] = "ghi" ; - untie @h ; + ok(66, safeUntie \@h); my $x = docat($Dfile) ; unlink $Dfile; my $ok = ($x eq "abc def ghi ") ; bad_one() unless $ok ; - ok(63, $ok) ; + ok(67, $ok) ; } { @@ -378,16 +387,16 @@ unlink $Dfile; $dbh->{flags} = R_FIXEDLEN ; $dbh->{bval} = "-" ; $dbh->{reclen} = 5 ; - ok(64, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + ok(68, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; $h[0] = "abc" ; $h[1] = "def" ; $h[3] = "ghi" ; - untie @h ; + ok(69, safeUntie \@h); my $x = docat($Dfile) ; unlink $Dfile; my $ok = ($x eq "abc--def-------ghi--") ; bad_one() unless $ok ; - ok(65, $ok) ; + ok(70, $ok) ; } { @@ -396,7 +405,7 @@ unlink $Dfile; my $filename = "xyz" ; my %x ; eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ; - ok(66, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ; + ok(71, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ; unlink $filename ; } @@ -463,7 +472,7 @@ EOM BEGIN { push @INC, '.'; } eval 'use SubDB ; '; - main::ok(67, $@ eq "") ; + main::ok(72, $@ eq "") ; my @h ; my $X ; eval ' @@ -471,27 +480,27 @@ EOM ' ; die "Could not tie: $!" unless $X; - main::ok(68, $@ eq "") ; + main::ok(73, $@ eq "") ; my $ret = eval '$h[3] = 3 ; return $h[3] ' ; - main::ok(69, $@ eq "") ; - main::ok(70, $ret == 5) ; + main::ok(74, $@ eq "") ; + main::ok(75, $ret == 5) ; my $value = 0; $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ; - main::ok(71, $@ eq "") ; - main::ok(72, $ret == 10) ; + main::ok(76, $@ eq "") ; + main::ok(77, $ret == 10) ; $ret = eval ' R_NEXT eq main::R_NEXT ' ; - main::ok(73, $@ eq "" ) ; - main::ok(74, $ret == 1) ; + main::ok(78, $@ eq "" ) ; + main::ok(79, $ret == 1) ; $ret = eval '$X->A_new_method(1) ' ; - main::ok(75, $@ eq "") ; - main::ok(76, $ret eq "[[11]]") ; + main::ok(80, $@ eq "") ; + main::ok(81, $ret eq "[[11]]") ; undef $X; - untie(@h); + main::ok(82, main::safeUntie \@h); unlink "SubDB.pm", "recno.tmp" ; } @@ -501,52 +510,52 @@ EOM # test $# my $self ; unlink $Dfile; - ok(77, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; + ok(83, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; $h[0] = "abc" ; $h[1] = "def" ; $h[2] = "ghi" ; $h[3] = "jkl" ; - ok(78, $FA ? $#h == 3 : $self->length() == 4) ; + ok(84, $FA ? $#h == 3 : $self->length() == 4) ; undef $self ; - untie @h ; + ok(85, safeUntie \@h); my $x = docat($Dfile) ; - ok(79, $x eq "abc\ndef\nghi\njkl\n") ; + ok(86, $x eq "abc\ndef\nghi\njkl\n") ; # $# sets array to same length - ok(80, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + ok(87, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; if ($FA) { $#h = 3 } else { $self->STORESIZE(4) } - ok(81, $FA ? $#h == 3 : $self->length() == 4) ; + ok(88, $FA ? $#h == 3 : $self->length() == 4) ; undef $self ; - untie @h ; + ok(89, safeUntie \@h); $x = docat($Dfile) ; - ok(82, $x eq "abc\ndef\nghi\njkl\n") ; + ok(90, $x eq "abc\ndef\nghi\njkl\n") ; # $# sets array to bigger - ok(83, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + ok(91, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; if ($FA) { $#h = 6 } else { $self->STORESIZE(7) } - ok(84, $FA ? $#h == 6 : $self->length() == 7) ; + ok(92, $FA ? $#h == 6 : $self->length() == 7) ; undef $self ; - untie @h ; + ok(93, safeUntie \@h); $x = docat($Dfile) ; - ok(85, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ; + ok(94, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ; # $# sets array smaller - ok(86, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + ok(95, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; if ($FA) { $#h = 2 } else { $self->STORESIZE(3) } - ok(87, $FA ? $#h == 2 : $self->length() == 3) ; + ok(96, $FA ? $#h == 2 : $self->length() == 3) ; undef $self ; - untie @h ; + ok(97, safeUntie \@h); $x = docat($Dfile) ; - ok(88, $x eq "abc\ndef\nghi\n") ; + ok(98, $x eq "abc\ndef\nghi\n") ; unlink $Dfile; @@ -564,13 +573,25 @@ EOM sub checkOutput { my($fk, $sk, $fv, $sv) = @_ ; + + print "# Fetch Key : expected '$fk' got '$fetch_key'\n" + if $fetch_key ne $fk ; + print "# Fetch Value : expected '$fv' got '$fetch_value'\n" + if $fetch_value ne $fv ; + print "# Store Key : expected '$sk' got '$store_key'\n" + if $store_key ne $sk ; + print "# Store Value : expected '$sv' got '$store_value'\n" + if $store_value ne $sv ; + print "# \$_ : expected 'original' got '$_'\n" + if $_ ne 'original' ; + return - $fetch_key eq $fk && $store_key eq $sk && + $fetch_key eq $fk && $store_key eq $sk && $fetch_value eq $fv && $store_value eq $sv && $_ eq 'original' ; } - ok(89, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + ok(99, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); $db->filter_fetch_key (sub { $fetch_key = $_ }) ; $db->filter_store_key (sub { $store_key = $_ }) ; @@ -581,17 +602,17 @@ EOM $h[0] = "joe" ; # fk sk fv sv - ok(90, checkOutput( "", 0, "", "joe")) ; + ok(100, checkOutput( "", 0, "", "joe")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(91, $h[0] eq "joe"); + ok(101, $h[0] eq "joe"); # fk sk fv sv - ok(92, checkOutput( "", 0, "joe", "")) ; + ok(102, checkOutput( "", 0, "joe", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(93, $db->FIRSTKEY() == 0) ; + ok(103, $db->FIRSTKEY() == 0) ; # fk sk fv sv - ok(94, checkOutput( 0, "", "", "")) ; + ok(104, checkOutput( 0, "", "", "")) ; # replace the filters, but remember the previous set my ($old_fk) = $db->filter_fetch_key @@ -606,17 +627,17 @@ EOM ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $h[1] = "Joe" ; # fk sk fv sv - ok(95, checkOutput( "", 2, "", "Jxe")) ; + ok(105, checkOutput( "", 2, "", "Jxe")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(96, $h[1] eq "[Jxe]"); + ok(106, $h[1] eq "[Jxe]"); # fk sk fv sv - ok(97, checkOutput( "", 2, "[Jxe]", "")) ; + ok(107, checkOutput( "", 2, "[Jxe]", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(98, $db->FIRSTKEY() == 1) ; + ok(108, $db->FIRSTKEY() == 1) ; # fk sk fv sv - ok(99, checkOutput( 1, "", "", "")) ; + ok(109, checkOutput( 1, "", "", "")) ; # put the original filters back $db->filter_fetch_key ($old_fk); @@ -626,15 +647,15 @@ EOM ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $h[0] = "joe" ; - ok(100, checkOutput( "", 0, "", "joe")) ; + ok(110, checkOutput( "", 0, "", "joe")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(101, $h[0] eq "joe"); - ok(102, checkOutput( "", 0, "joe", "")) ; + ok(111, $h[0] eq "joe"); + ok(112, checkOutput( "", 0, "joe", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(103, $db->FIRSTKEY() == 0) ; - ok(104, checkOutput( 0, "", "", "")) ; + ok(113, $db->FIRSTKEY() == 0) ; + ok(114, checkOutput( 0, "", "", "")) ; # delete the filters $db->filter_fetch_key (undef); @@ -644,18 +665,18 @@ EOM ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $h[0] = "joe" ; - ok(105, checkOutput( "", "", "", "")) ; + ok(115, checkOutput( "", "", "", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(106, $h[0] eq "joe"); - ok(107, checkOutput( "", "", "", "")) ; + ok(116, $h[0] eq "joe"); + ok(117, checkOutput( "", "", "", "")) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(108, $db->FIRSTKEY() == 0) ; - ok(109, checkOutput( "", "", "", "")) ; + ok(118, $db->FIRSTKEY() == 0) ; + ok(119, checkOutput( "", "", "", "")) ; undef $db ; - untie @h; + ok(120, safeUntie \@h); unlink $Dfile; } @@ -667,7 +688,7 @@ EOM my (@h, $db) ; unlink $Dfile; - ok(110, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + ok(121, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); my %result = () ; @@ -691,35 +712,35 @@ EOM $_ = "original" ; $h[0] = "joe" ; - ok(111, $result{"store key"} eq "store key - 1: [0]"); - ok(112, $result{"store value"} eq "store value - 1: [joe]"); - ok(113, ! defined $result{"fetch key"} ); - ok(114, ! defined $result{"fetch value"} ); - ok(115, $_ eq "original") ; - - ok(116, $db->FIRSTKEY() == 0 ) ; - ok(117, $result{"store key"} eq "store key - 1: [0]"); - ok(118, $result{"store value"} eq "store value - 1: [joe]"); - ok(119, $result{"fetch key"} eq "fetch key - 1: [0]"); - ok(120, ! defined $result{"fetch value"} ); - ok(121, $_ eq "original") ; - - $h[7] = "john" ; - ok(122, $result{"store key"} eq "store key - 2: [0 7]"); - ok(123, $result{"store value"} eq "store value - 2: [joe john]"); - ok(124, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(122, $result{"store key"} eq "store key - 1: [0]"); + ok(123, $result{"store value"} eq "store value - 1: [joe]"); + ok(124, ! defined $result{"fetch key"} ); ok(125, ! defined $result{"fetch value"} ); ok(126, $_ eq "original") ; - ok(127, $h[0] eq "joe"); - ok(128, $result{"store key"} eq "store key - 3: [0 7 0]"); - ok(129, $result{"store value"} eq "store value - 2: [joe john]"); + ok(127, $db->FIRSTKEY() == 0 ) ; + ok(128, $result{"store key"} eq "store key - 1: [0]"); + ok(129, $result{"store value"} eq "store value - 1: [joe]"); ok(130, $result{"fetch key"} eq "fetch key - 1: [0]"); - ok(131, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(131, ! defined $result{"fetch value"} ); ok(132, $_ eq "original") ; + $h[7] = "john" ; + ok(133, $result{"store key"} eq "store key - 2: [0 7]"); + ok(134, $result{"store value"} eq "store value - 2: [joe john]"); + ok(135, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(136, ! defined $result{"fetch value"} ); + ok(137, $_ eq "original") ; + + ok(138, $h[0] eq "joe"); + ok(139, $result{"store key"} eq "store key - 3: [0 7 0]"); + ok(140, $result{"store value"} eq "store value - 2: [joe john]"); + ok(141, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(142, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(143, $_ eq "original") ; + undef $db ; - untie @h; + ok(144, safeUntie \@h); unlink $Dfile; } @@ -730,15 +751,15 @@ EOM my (@h, $db) ; unlink $Dfile; - ok(133, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + ok(145, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); $db->filter_store_key (sub { $_ = $h[0] }) ; eval '$h[1] = 1234' ; - ok(134, $@ =~ /^recursion detected in filter_store_key at/ ); + ok(146, $@ =~ /^recursion detected in filter_store_key at/ ); undef $db ; - untie @h; + ok(147, safeUntie \@h); unlink $Dfile; } @@ -793,7 +814,7 @@ EOM unlink $filename ; } - ok(135, docat_del($file) eq <<'EOM') ; + ok(148, docat_del($file) eq <<'EOM') ; The array contains 5 entries popped black shifted white @@ -878,7 +899,7 @@ EOM unlink $file ; } - ok(136, docat_del($save_output) eq <<'EOM') ; + ok(149, docat_del($save_output) eq <<'EOM') ; ORIGINAL 0: zero @@ -926,8 +947,8 @@ EOM tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO or die "Can't open file: $!\n" ; $h[0] = undef; - ok(137, $a eq "") ; - untie @h ; + ok(150, $a eq "") ; + ok(151, safeUntie \@h); unlink $Dfile; } @@ -946,11 +967,53 @@ EOM tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO or die "Can't open file: $!\n" ; @h = (); ; - ok(138, $a eq "") ; - untie @h ; + ok(152, $a eq "") ; + ok(153, safeUntie \@h); unlink $Dfile; } +{ + # Check that DBM Filter can cope with read-only $_ + + use warnings ; + use strict ; + my (@h, $db) ; + unlink $Dfile; + + ok(154, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + $db->filter_fetch_key (sub { }) ; + $db->filter_store_key (sub { }) ; + $db->filter_fetch_value (sub { }) ; + $db->filter_store_value (sub { }) ; + + $_ = "original" ; + + $h[0] = "joe" ; + ok(155, $h[0] eq "joe"); + + eval { grep { $h[$_] } (1, 2, 3) }; + ok (156, ! $@); + + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + $h[1] = "joe" ; + + ok(157, $h[1] eq "joe"); + + eval { grep { $h[$_] } (1, 2, 3) }; + ok (158, ! $@); + + undef $db ; + untie @h; + unlink $Dfile; +} + # Only test splice if this is a newish version of Perl exit unless $FA ; @@ -978,36 +1041,36 @@ exit unless $FA ; my $offset ; $a = ''; splice(@a, $offset); - ok(139, $a =~ /^Use of uninitialized value /); + ok(159, $a =~ /^Use of uninitialized value /); $a = ''; splice(@tied, $offset); - ok(140, $a =~ /^Use of uninitialized value in splice/); + ok(160, $a =~ /^Use of uninitialized value in splice/); no warnings 'uninitialized'; $a = ''; splice(@a, $offset); - ok(141, $a eq ''); + ok(161, $a eq ''); $a = ''; splice(@tied, $offset); - ok(142, $a eq ''); + ok(162, $a eq ''); # uninitialized length use warnings; my $length ; $a = ''; splice(@a, 0, $length); - ok(143, $a =~ /^Use of uninitialized value /); + ok(163, $a =~ /^Use of uninitialized value /); $a = ''; splice(@tied, 0, $length); - ok(144, $a =~ /^Use of uninitialized value in splice/); + ok(164, $a =~ /^Use of uninitialized value in splice/); no warnings 'uninitialized'; $a = ''; splice(@a, 0, $length); - ok(145, $a eq ''); + ok(165, $a eq ''); $a = ''; splice(@tied, 0, $length); - ok(146, $a eq ''); + ok(166, $a eq ''); # offset past end of array use warnings; @@ -1016,17 +1079,17 @@ exit unless $FA ; my $splice_end_array = ($a =~ /^splice\(\) offset past end of array/); $a = ''; splice(@tied, 3); - ok(147, !$splice_end_array || $a =~ /^splice\(\) offset past end of array/); + ok(167, !$splice_end_array || $a =~ /^splice\(\) offset past end of array/); no warnings 'misc'; $a = ''; splice(@a, 3); - ok(148, $a eq ''); + ok(168, $a eq ''); $a = ''; splice(@tied, 3); - ok(149, $a eq ''); + ok(169, $a eq ''); - untie @tied; + ok(170, safeUntie \@tied); unlink $Dfile; } @@ -1087,7 +1150,7 @@ my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion', 'void' ], ); -my $testnum = 150; +my $testnum = 171; my $failed = 0; require POSIX; my $tmp = POSIX::tmpnam(); foreach my $test (@tests) { @@ -1124,7 +1187,8 @@ else { ok($testnum++, not $failed); } -die if $testnum != $total_tests + 1; +die "testnum ($testnum) != total_tests ($total_tests) + 1" + if $testnum != $total_tests + 1; exit ; @@ -1360,3 +1424,5 @@ sub rand_word { } return $r; } + + diff --git a/ext/DB_File/typemap b/ext/DB_File/typemap index ecd378514a..8ad7b1282d 100644 --- a/ext/DB_File/typemap +++ b/ext/DB_File/typemap @@ -17,14 +17,16 @@ INPUT T_dbtkeydatum DBM_ckFilter($arg, filter_store_key, \"filter_store_key\"); DBT_clear($var) ; - if (db->type != DB_RECNO) { - $var.data = SvPV($arg, PL_na); - $var.size = (int)PL_na; - } - else { - Value = GetRecnoKey(aTHX_ db, SvIV($arg)) ; - $var.data = & Value; - $var.size = (int)sizeof(recno_t); + if (SvOK($arg)){ + if (db->type != DB_RECNO) { + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + } + else { + Value = GetRecnoKey(aTHX_ db, SvIV($arg)) ; + $var.data = & Value; + $var.size = (int)sizeof(recno_t); + } } T_dbtdatum DBM_ckFilter($arg, filter_store_value, \"filter_store_value\"); |