diff options
| author | unknown <tim@threads.polyesthetic.msg> | 2001-03-04 19:42:05 -0500 |
|---|---|---|
| committer | unknown <tim@threads.polyesthetic.msg> | 2001-03-04 19:42:05 -0500 |
| commit | ec6ae091617bdfdca9e65e8d3e65b950d234f676 (patch) | |
| tree | 9dd732e08dba156ee3d7635caedc0dc3107ecac6 /bdb/perl.DB_File | |
| parent | 87d70fb598105b64b538ff6b81eef9da626255b1 (diff) | |
| download | mariadb-git-ec6ae091617bdfdca9e65e8d3e65b950d234f676.tar.gz | |
Import changeset
Diffstat (limited to 'bdb/perl.DB_File')
27 files changed, 10744 insertions, 0 deletions
diff --git a/bdb/perl.DB_File/Changes b/bdb/perl.DB_File/Changes new file mode 100644 index 00000000000..b8684cac3de --- /dev/null +++ b/bdb/perl.DB_File/Changes @@ -0,0 +1,343 @@ + +0.1 + + First Release. + +0.2 + + 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. + +0.3 + + Added prototype support for multiple btree compare callbacks. + +1.0 + + DB_File has been in use for over a year. To reflect that, the + version number has been incremented to 1.0. + + Added complete support for multiple concurrent callbacks. + + Using the push method on an empty list didn't work properly. This + has been fixed. + +1.01 + + Fixed a core dump problem with SunOS. + + The return value from TIEHASH wasn't set to NULL when dbopen + returned an error. + +1.02 + + Merged OS/2 specific code into DB_File.xs + + Removed some redundant code in DB_File.xs. + + Documentation update. + + Allow negative subscripts with RECNO interface. + + 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. + + Added get_dup method. + +1.03 + + Documentation update. + + DB_File now imports the constants (O_RDWR, O_CREAT etc.) from Fcntl + automatically. + + The standard hash function exists 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. + +1.04 + + Minor documentation changes. + + Fixed a bug in hash_cb. Patches supplied by Dave Hammen, + <hammen@gothamcity.jsc.nasa.govt>. + + 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. + + Reworked part of the test harness to be more locale friendly. + +1.05 + + 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.06 + + Minor namespace cleanup: Localized PrintBtree. + +1.07 + + Fixed bug with RECNO, where bval wasn't defaulting to "\n". + +1.08 + + Documented operation of bval. + +1.09 + + Minor bug fix in DB_File::HASHINFO, DB_File::RECNOINFO and + DB_File::BTREEINFO. + + Changed default mode to 0666. + +1.10 + + Fixed fd method so that it still returns -1 for in-memory files + when db 1.86 is used. + +1.11 + + Documented the untie gotcha. + +1.12 + + Documented the incompatibility with version 2 of Berkeley DB. + +1.13 + + Minor changes to DB_FIle.xs and DB_File.pm + +1.14 + + Made it illegal to tie an associative array to a RECNO database and + an ordinary array to a HASH or BTREE database. + +1.15 + + Patch from Gisle Aas <gisle@aas.no> to suppress "use of undefined + value" warning with db_get and db_seq. + + Patch from Gisle Aas <gisle@aas.no> to make DB_File export only the + O_* constants from Fcntl. + + Removed the DESTROY method from the DB_File::HASHINFO module. + + 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. + + +1.16 + + A harmless looking tab was causing Makefile.PL to fail on AIX 3.2.5 + + 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.50 + + DB_File can now build with either DB 1.x or 2.x, but not both at + the same time. + +1.51 + + Fixed the test harness so that it doesn't expect DB_File to have + been installed by the main Perl build. + + + Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent + +1.52 + + Patch from Nick Ing-Simmons now allows DB_File to build on NT. + Merged 1.15 patch. + +1.53 + + Added DB_RENUMBER to flags for recno. + +1.54 + + Fixed a small bug in the test harness when run under win32 + The emulation of fd when useing DB 2.x was busted. + +1.55 + Merged 1.16 changes. + +1.56 + Documented the Solaris 2.5 mutex bug + +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.58 + Tied Array support was enhanced in Perl 5.004_57. DB_File now + supports PUSH,POP,SHIFT,UNSHIFT & STORESIZE. + + 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.59 + Updated the license section. + + 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. + + Added dbinfo to the distribution. + +1.60 + Changed the test to check for full tied array support + +1.61 19th November 1998 + + Added a note to README about how to build Berkeley DB 2.x when + using HP-UX. + 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 + + Added hints/dynixptx.pl. + Fixed typemap -- 1.61 used PL_na instead of na + +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.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.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.66 15th March 1999 + + * Added DBM Filter code + +1.67 6th June 1999 + + * Added DBM Filter documentation to DB_File.pm + + * Fixed DBM Filter code to work with 5.004 + + * 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.68 22nd July 1999 + + * Merged changes from 5.005_58 + + * Fixed a bug in R_IBEFORE & R_IAFTER procesing in Berkeley DB + 2 databases. + + * Added some of the examples in the POD into the test harness. + +1.69 3rd August 1999 + + * fixed a bug in push -- DB_APPEND wasn't working properly. + + * Fixed the R_SETCURSOR bug introduced in 1.68 + + * Added a new Perl variable $DB_File::db_ver + +1.70 4th August 1999 + + * Initialise $DB_File::db_ver and $DB_File::db_version with + GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. + + * Added a BOOT check to test for equivalent versions of db.h & + libdb.a/so. + +1.71 7th September 1999 + + * Fixed a bug that prevented 1.70 from compiling under win32 + + * Updated to support Berkeley DB 3.x + + * Updated dbinfo for Berkeley DB 3.x file formats. + +1.72 16th January 2000 + + * Added hints/sco.pl + + * The module will now use XSLoader when it is available. When it + isn't it will use DynaLoader. + + * 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.73 31st May 2000 + + * Added support in version.c for building with threaded Perl. + + * Berkeley DB 3.1 has reenabled support for null keys. The test + harness has been updated to reflect this. + +1.74 10th December 2000 + + * A "close" call in DB_File.xs needed parenthesised to stop win32 from + thinking it was one of its macros. + + * Updated dbinfo to support Berkeley DB 3.1 file format changes. + + * DB_File.pm & the test hasness now use the warnings pragma (when + available). + + * Included Perl core patch 7703 -- size argument for hash_cb is different + for Berkeley DB 3.x + + * Included Perl core patch 7801 -- Give __getBerkeleyDBInfo the ANSI C + treatment. + + * @a = () produced the warning 'Argument "" isn't numeric in entersub' + This has been fixed. Thanks to Edward Avis for spotting this bug. + + * Added note about building under Linux. Included patches. + + * 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.75 17th December 2000 + + * Fixed perl core patch 7703 + + * 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. + + * Updated dbinfo to support Berkeley DB 3.2 file format changes. + + +1.76 15th January 2001 + + * 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. + + diff --git a/bdb/perl.DB_File/DB_File.pm b/bdb/perl.DB_File/DB_File.pm new file mode 100644 index 00000000000..e9b6a40d7e3 --- /dev/null +++ b/bdb/perl.DB_File/DB_File.pm @@ -0,0 +1,2072 @@ +# DB_File.pm -- Perl 5 interface to Berkeley DB +# +# written by Paul Marquess (Paul.Marquess@btinternet.com) +# last modified 15th January 2001 +# version 1.76 +# +# Copyright (c) 1995-2001 Paul Marquess. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + + +package DB_File::HASHINFO ; + +require 5.003 ; + +use warnings; +use strict; +use Carp; +require Tie::Hash; +@DB_File::HASHINFO::ISA = qw(Tie::Hash); + +sub new +{ + my $pkg = shift ; + my %x ; + tie %x, $pkg ; + bless \%x, $pkg ; +} + + +sub TIEHASH +{ + my $pkg = shift ; + + bless { VALID => { map {$_, 1} + qw( bsize ffactor nelem cachesize hash lorder) + }, + GOT => {} + }, $pkg ; +} + + +sub FETCH +{ + my $self = shift ; + my $key = shift ; + + return $self->{GOT}{$key} if exists $self->{VALID}{$key} ; + + my $pkg = ref $self ; + croak "${pkg}::FETCH - Unknown element '$key'" ; +} + + +sub STORE +{ + my $self = shift ; + my $key = shift ; + my $value = shift ; + + if ( exists $self->{VALID}{$key} ) + { + $self->{GOT}{$key} = $value ; + return ; + } + + my $pkg = ref $self ; + croak "${pkg}::STORE - Unknown element '$key'" ; +} + +sub DELETE +{ + my $self = shift ; + my $key = shift ; + + if ( exists $self->{VALID}{$key} ) + { + delete $self->{GOT}{$key} ; + return ; + } + + my $pkg = ref $self ; + croak "DB_File::HASHINFO::DELETE - Unknown element '$key'" ; +} + +sub EXISTS +{ + my $self = shift ; + my $key = shift ; + + exists $self->{VALID}{$key} ; +} + +sub NotHere +{ + my $self = shift ; + my $method = shift ; + + croak ref($self) . " does not define the method ${method}" ; +} + +sub FIRSTKEY { my $self = shift ; $self->NotHere("FIRSTKEY") } +sub NEXTKEY { my $self = shift ; $self->NotHere("NEXTKEY") } +sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") } + +package DB_File::RECNOINFO ; + +use warnings; +use strict ; + +@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ; + +sub TIEHASH +{ + my $pkg = shift ; + + bless { VALID => { map {$_, 1} + qw( bval cachesize psize flags lorder reclen bfname ) + }, + GOT => {}, + }, $pkg ; +} + +package DB_File::BTREEINFO ; + +use warnings; +use strict ; + +@DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ; + +sub TIEHASH +{ + my $pkg = shift ; + + bless { VALID => { map {$_, 1} + qw( flags cachesize maxkeypage minkeypage psize + compare prefix lorder ) + }, + GOT => {}, + }, $pkg ; +} + + +package DB_File ; + +use warnings; +use strict; +use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO + $db_version $use_XSLoader + ) ; +use Carp; + + +$VERSION = "1.76" ; + +#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; +$DB_BTREE = new DB_File::BTREEINFO ; +$DB_HASH = new DB_File::HASHINFO ; +$DB_RECNO = new DB_File::RECNOINFO ; + +require Tie::Hash; +require Exporter; +use AutoLoader; +BEGIN { + $use_XSLoader = 1 ; + eval { require XSLoader } ; + + if ($@) { + $use_XSLoader = 0 ; + require DynaLoader; + @ISA = qw(DynaLoader); + } +} + +push @ISA, qw(Tie::Hash Exporter); +@EXPORT = qw( + $DB_BTREE $DB_HASH $DB_RECNO + + BTREEMAGIC + BTREEVERSION + DB_LOCK + DB_SHMEM + DB_TXN + HASHMAGIC + HASHVERSION + MAX_PAGE_NUMBER + MAX_PAGE_OFFSET + MAX_REC_NUMBER + RET_ERROR + RET_SPECIAL + RET_SUCCESS + R_CURSOR + R_DUP + R_FIRST + R_FIXEDLEN + R_IAFTER + R_IBEFORE + R_LAST + R_NEXT + R_NOKEY + R_NOOVERWRITE + R_PREV + R_RECNOSYNC + R_SETCURSOR + R_SNAPSHOT + __R_UNUSED + +); + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/ || $!{EINVAL}) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + my($pack,$file,$line) = caller; + croak "Your vendor has not defined DB macro $constname, used at $file line $line. +"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + + +eval { + # Make all Fcntl O_XXX constants available for importing + require Fcntl; + my @O = grep /^O_/, @Fcntl::EXPORT; + Fcntl->import(@O); # first we import what we want to export + push(@EXPORT, @O); +}; + +if ($use_XSLoader) + { XSLoader::load("DB_File", $VERSION)} +else + { bootstrap DB_File $VERSION } + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +sub tie_hash_or_array +{ + my (@arg) = @_ ; + my $tieHASH = ( (caller(1))[3] =~ /TIEHASH/ ) ; + + $arg[4] = tied %{ $arg[4] } + if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ; + + # 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]) { + open(FH, ">$arg[1]") or return undef ; + close FH ; + chmod $arg[3] ? $arg[3] : 0666 , $arg[1] ; + } + + DoTie_($tieHASH, @arg) ; +} + +sub TIEHASH +{ + tie_hash_or_array(@_) ; +} + +sub TIEARRAY +{ + tie_hash_or_array(@_) ; +} + +sub CLEAR +{ + my $self = shift; + my $key = 0 ; + my $value = "" ; + my $status = $self->seq($key, $value, R_FIRST()); + my @keys; + + while ($status == 0) { + push @keys, $key; + $status = $self->seq($key, $value, R_NEXT()); + } + foreach $key (reverse @keys) { + my $s = $self->del($key); + } +} + +sub EXTEND { } + +sub STORESIZE +{ + my $self = shift; + my $length = shift ; + my $current_length = $self->length() ; + + if ($length < $current_length) { + my $key ; + for ($key = $current_length - 1 ; $key >= $length ; -- $key) + { $self->del($key) } + } + elsif ($length > $current_length) { + $self->put($length-1, "") ; + } +} + +sub find_dup +{ + croak "Usage: \$db->find_dup(key,value)\n" + unless @_ == 3 ; + + my $db = shift ; + my ($origkey, $value_wanted) = @_ ; + my ($key, $value) = ($origkey, 0); + my ($status) = 0 ; + + for ($status = $db->seq($key, $value, R_CURSOR() ) ; + $status == 0 ; + $status = $db->seq($key, $value, R_NEXT() ) ) { + + return 0 if $key eq $origkey and $value eq $value_wanted ; + } + + return $status ; +} + +sub del_dup +{ + croak "Usage: \$db->del_dup(key,value)\n" + unless @_ == 3 ; + + my $db = shift ; + my ($key, $value) = @_ ; + my ($status) = $db->find_dup($key, $value) ; + return $status if $status != 0 ; + + $status = $db->del($key, R_CURSOR() ) ; + return $status ; +} + +sub get_dup +{ + croak "Usage: \$db->get_dup(key [,flag])\n" + unless @_ == 2 or @_ == 3 ; + + my $db = shift ; + my $key = shift ; + my $flag = shift ; + my $value = 0 ; + my $origkey = $key ; + my $wantarray = wantarray ; + my %values = () ; + my @values = () ; + my $counter = 0 ; + my $status = 0 ; + + # 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()) ; + $status == 0 and $key eq $origkey ; + $status = $db->seq($key, $value, R_NEXT()) ) { + + # save the value or count number of matches + if ($wantarray) { + if ($flag) + { ++ $values{$value} } + else + { push (@values, $value) } + } + else + { ++ $counter } + + } + + return ($wantarray ? ($flag ? %values : @values) : $counter) ; +} + + +1; +__END__ + +=head1 NAME + +DB_File - Perl5 access to Berkeley DB version 1.x + +=head1 SYNOPSIS + + use DB_File ; + + [$X =] tie %hash, 'DB_File', [$filename, $flags, $mode, $DB_HASH] ; + [$X =] tie %hash, 'DB_File', $filename, $flags, $mode, $DB_BTREE ; + [$X =] tie @array, 'DB_File', $filename, $flags, $mode, $DB_RECNO ; + + $status = $X->del($key [, $flags]) ; + $status = $X->put($key, $value [, $flags]) ; + $status = $X->get($key, $value [, $flags]) ; + $status = $X->seq($key, $value, $flags) ; + $status = $X->sync([$flags]) ; + $status = $X->fd ; + + # BTREE only + $count = $X->get_dup($key) ; + @list = $X->get_dup($key) ; + %list = $X->get_dup($key, 1) ; + $status = $X->find_dup($key, $value) ; + $status = $X->del_dup($key, $value) ; + + # RECNO only + $a = $X->length; + $a = $X->pop ; + $X->push(list); + $a = $X->shift; + $X->unshift(list); + + # DBM Filters + $old_filter = $db->filter_store_key ( sub { ... } ) ; + $old_filter = $db->filter_store_value( sub { ... } ) ; + $old_filter = $db->filter_fetch_key ( sub { ... } ) ; + $old_filter = $db->filter_fetch_value( sub { ... } ) ; + + untie %hash ; + untie @array ; + +=head1 DESCRIPTION + +B<DB_File> is a module which allows Perl programs to make use of the +facilities provided by Berkeley DB version 1.x (if you have a newer +version of DB, see L<Using DB_File with Berkeley DB version 2 or 3>). +It is assumed that you have a copy of the Berkeley DB manual pages at +hand when reading this documentation. The interface defined here +mirrors the Berkeley DB interface closely. + +Berkeley DB is a C library which provides a consistent interface to a +number of database formats. B<DB_File> provides an interface to all +three of the database types currently supported by Berkeley DB. + +The file types are: + +=over 5 + +=item B<DB_HASH> + +This database type allows arbitrary key/value pairs to be stored in data +files. This is equivalent to the functionality provided by other +hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though, +the files created using DB_HASH are not compatible with any of the +other packages mentioned. + +A default hashing algorithm, which will be adequate for most +applications, is built into Berkeley DB. If you do need to use your own +hashing algorithm it is possible to write your own in Perl and have +B<DB_File> use it instead. + +=item B<DB_BTREE> + +The btree format allows arbitrary key/value pairs to be stored in a +sorted, balanced binary tree. + +As with the DB_HASH format, it is possible to provide a user defined +Perl routine to perform the comparison of keys. By default, though, the +keys are stored in lexical order. + +=item B<DB_RECNO> + +DB_RECNO allows both fixed-length and variable-length flat text files +to be manipulated using the same key/value pair interface as in DB_HASH +and DB_BTREE. In this case the key will consist of a record (line) +number. + +=back + +=head2 Using DB_File with Berkeley DB version 2 or 3 + +Although B<DB_File> is intended to be used with Berkeley DB version 1, +it can also be used with version 2.or 3 In this case the interface is +limited to the functionality provided by Berkeley DB 1.x. Anywhere the +version 2 or 3 interface differs, B<DB_File> arranges for it to work +like version 1. This feature allows B<DB_File> scripts that were built +with version 1 to be migrated to version 2 or 3 without any changes. + +If you want to make use of the new features available in Berkeley DB +2.x or greater, use the Perl module B<BerkeleyDB> instead. + +B<Note:> The database file format has changed in both Berkeley DB +version 2 and 3. If you cannot recreate your databases, you must dump +any existing databases with the C<db_dump185> utility that comes with +Berkeley DB. +Once you have rebuilt DB_File to use Berkeley DB version 2 or 3, your +databases can be recreated using C<db_load>. Refer to the Berkeley DB +documentation for further details. + +Please read L<"COPYRIGHT"> before using version 2.x or 3.x of Berkeley +DB with DB_File. + +=head2 Interface to Berkeley DB + +B<DB_File> allows access to Berkeley DB files using the tie() mechanism +in Perl 5 (for full details, see L<perlfunc/tie()>). This facility +allows B<DB_File> to access Berkeley DB files using either an +associative array (for DB_HASH & DB_BTREE file types) or an ordinary +array (for the DB_RECNO file type). + +In addition to the tie() interface, it is also possible to access most +of the functions provided in the Berkeley DB API directly. +See L<THE API INTERFACE>. + +=head2 Opening a Berkeley DB Database File + +Berkeley DB uses the function dbopen() to open or create a database. +Here is the C prototype for dbopen(): + + DB* + dbopen (const char * file, int flags, int mode, + DBTYPE type, const void * openinfo) + +The parameter C<type> is an enumeration which specifies which of the 3 +interface methods (DB_HASH, DB_BTREE or DB_RECNO) is to be used. +Depending on which of these is actually chosen, the final parameter, +I<openinfo> points to a data structure which allows tailoring of the +specific interface method. + +This interface is handled slightly differently in B<DB_File>. Here is +an equivalent call using B<DB_File>: + + tie %array, 'DB_File', $filename, $flags, $mode, $DB_HASH ; + +The C<filename>, C<flags> and C<mode> parameters are the direct +equivalent of their dbopen() counterparts. The final parameter $DB_HASH +performs the function of both the C<type> and C<openinfo> parameters in +dbopen(). + +In the example above $DB_HASH is actually a pre-defined reference to a +hash object. B<DB_File> has three of these pre-defined references. +Apart from $DB_HASH, there is also $DB_BTREE and $DB_RECNO. + +The keys allowed in each of these pre-defined references is limited to +the names used in the equivalent C structure. So, for example, the +$DB_HASH reference will only allow keys called C<bsize>, C<cachesize>, +C<ffactor>, C<hash>, C<lorder> and C<nelem>. + +To change one of these elements, just assign to it like this: + + $DB_HASH->{'cachesize'} = 10000 ; + +The three predefined variables $DB_HASH, $DB_BTREE and $DB_RECNO are +usually adequate for most applications. If you do need to create extra +instances of these objects, constructors are available for each file +type. + +Here are examples of the constructors and the valid options available +for DB_HASH, DB_BTREE and DB_RECNO respectively. + + $a = new DB_File::HASHINFO ; + $a->{'bsize'} ; + $a->{'cachesize'} ; + $a->{'ffactor'}; + $a->{'hash'} ; + $a->{'lorder'} ; + $a->{'nelem'} ; + + $b = new DB_File::BTREEINFO ; + $b->{'flags'} ; + $b->{'cachesize'} ; + $b->{'maxkeypage'} ; + $b->{'minkeypage'} ; + $b->{'psize'} ; + $b->{'compare'} ; + $b->{'prefix'} ; + $b->{'lorder'} ; + + $c = new DB_File::RECNOINFO ; + $c->{'bval'} ; + $c->{'cachesize'} ; + $c->{'psize'} ; + $c->{'flags'} ; + $c->{'lorder'} ; + $c->{'reclen'} ; + $c->{'bfname'} ; + +The values stored in the hashes above are mostly the direct equivalent +of their C counterpart. Like their C counterparts, all are set to a +default values - that means you don't have to set I<all> of the +values when you only want to change one. Here is an example: + + $a = new DB_File::HASHINFO ; + $a->{'cachesize'} = 12345 ; + tie %y, 'DB_File', "filename", $flags, 0777, $a ; + +A few of the options need extra discussion here. When used, the C +equivalent of the keys C<hash>, C<compare> and C<prefix> store pointers +to C functions. In B<DB_File> these keys are used to store references +to Perl subs. Below are templates for each of the subs: + + sub hash + { + my ($data) = @_ ; + ... + # return the hash value for $data + return $hash ; + } + + sub compare + { + my ($key, $key2) = @_ ; + ... + # return 0 if $key1 eq $key2 + # -1 if $key1 lt $key2 + # 1 if $key1 gt $key2 + return (-1 , 0 or 1) ; + } + + sub prefix + { + my ($key, $key2) = @_ ; + ... + # return number of bytes of $key2 which are + # necessary to determine that it is greater than $key1 + return $bytes ; + } + +See L<Changing the BTREE sort order> for an example of using the +C<compare> template. + +If you are using the DB_RECNO interface and you intend making use of +C<bval>, you should check out L<The 'bval' Option>. + +=head2 Default Parameters + +It is possible to omit some or all of the final 4 parameters in the +call to C<tie> and let them take default values. As DB_HASH is the most +common file format used, the call: + + tie %A, "DB_File", "filename" ; + +is equivalent to: + + tie %A, "DB_File", "filename", O_CREAT|O_RDWR, 0666, $DB_HASH ; + +It is also possible to omit the filename parameter as well, so the +call: + + tie %A, "DB_File" ; + +is equivalent to: + + tie %A, "DB_File", undef, O_CREAT|O_RDWR, 0666, $DB_HASH ; + +See L<In Memory Databases> for a discussion on the use of C<undef> +in place of a filename. + +=head2 In Memory Databases + +Berkeley DB allows the creation of in-memory databases by using NULL +(that is, a C<(char *)0> in C) in place of the filename. B<DB_File> +uses C<undef> instead of NULL to provide this functionality. + +=head1 DB_HASH + +The DB_HASH file format is probably the most commonly used of the three +file formats that B<DB_File> supports. It is also very straightforward +to use. + +=head2 A Simple Example + +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 warnings ; + use strict ; + use DB_File ; + use vars qw( %h $k $v ) ; + + unlink "fruit" ; + tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH + or die "Cannot open file 'fruit': $!\n"; + + # Add a few key/value pairs to the file + $h{"apple"} = "red" ; + $h{"orange"} = "orange" ; + $h{"banana"} = "yellow" ; + $h{"tomato"} = "red" ; + + # Check for existence of a key + print "Banana Exists\n\n" if $h{"banana"} ; + + # Delete a key/value pair. + delete $h{"apple"} ; + + # print the contents of the file + while (($k, $v) = each %h) + { print "$k -> $v\n" } + + untie %h ; + +here is the output: + + Banana Exists + + orange -> orange + tomato -> red + banana -> yellow + +Note that the like ordinary associative arrays, the order of the keys +retrieved is in an apparently random order. + +=head1 DB_BTREE + +The DB_BTREE format is useful when you want to store data in a given +order. By default the keys will be stored in lexical order, but as you +will see from the example shown in the next section, it is very easy to +define your own sorting function. + +=head2 Changing the BTREE sort order + +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 warnings ; + use strict ; + use DB_File ; + + my %h ; + + sub Compare + { + my ($key1, $key2) = @_ ; + "\L$key1" cmp "\L$key2" ; + } + + # specify the Perl sub that will do the comparison + $DB_BTREE->{'compare'} = \&Compare ; + + unlink "tree" ; + tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open file 'tree': $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; + +Here is the output from the code above. + + mouse + Smith + Wall + +There are a few point to bear in mind if you want to change the +ordering in a BTREE database: + +=over 5 + +=item 1. + +The new compare function must be specified when you create the database. + +=item 2. + +You cannot change the ordering once the database has been created. Thus +you must use the same compare function every time you access the +database. + +=back + +=head2 Handling Duplicate Keys + +The BTREE file type optionally allows a single key to be associated +with an arbitrary number of values. This option is enabled by setting +the flags element of C<$DB_BTREE> to R_DUP when creating the database. + +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 warnings ; + use strict ; + use DB_File ; + + use vars qw($filename %h ) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the associative array + # and print each key/value pair. + foreach (sort keys %h) + { print "$_ -> $h{$_}\n" } + + untie %h ; + +Here is the output: + + Smith -> John + Wall -> Larry + Wall -> Larry + Wall -> Larry + mouse -> mickey + +As you can see 3 records have been successfully created with key C<Wall> +- the only thing is, when they are retrieved from the database they +I<seem> to have the same value, namely C<Larry>. The problem is caused +by the way that the associative array interface works. Basically, when +the associative array interface is used to fetch the value associated +with a given key, it will only ever retrieve the first value. + +Although it may not be immediately obvious from the code above, the +associative array interface can be used to write values with duplicate +keys, but it cannot be used to read them back from the database. + +The way to get around this problem is to use the Berkeley DB API method +called C<seq>. This method allows sequential access to key/value +pairs. See L<THE API INTERFACE> for details of both the C<seq> method +and the API in general. + +Here is the script above rewritten using the C<seq> API method. + + use warnings ; + use strict ; + use DB_File ; + + use vars qw($filename $x %h $status $key $value) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # 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) ) + { print "$key -> $value\n" } + + undef $x ; + untie %h ; + +that prints: + + Smith -> John + Wall -> Brick + Wall -> Brick + Wall -> Larry + mouse -> mickey + +This time we have got all the key/value pairs, including the multiple +values associated with the key C<Wall>. + +To make life easier when dealing with duplicate keys, B<DB_File> comes with +a few utility methods. + +=head2 The get_dup() Method + +The C<get_dup> method assists in +reading duplicate values from BTREE databases. The method can take the +following forms: + + $count = $x->get_dup($key) ; + @list = $x->get_dup($key) ; + %list = $x->get_dup($key, 1) ; + +In a scalar context the method returns the number of values associated +with the key, C<$key>. + +In list context, it returns all the values which match C<$key>. Note +that the values will be returned in an apparently random order. + +In list context, if the second parameter is present and evaluates +TRUE, the method returns an associative array. The keys of the +associative array correspond to the values that matched in the BTREE +and the values of the array are a count of the number of times that +particular value occurred in the BTREE. + +So assuming the database created above, we can use C<get_dup> like +this: + + use warnings ; + use strict ; + use DB_File ; + + use vars qw($filename $x %h ) ; + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + my $cnt = $x->get_dup("Wall") ; + print "Wall occurred $cnt times\n" ; + + my %hash = $x->get_dup("Wall", 1) ; + print "Larry is there\n" if $hash{'Larry'} ; + print "There are $hash{'Brick'} Brick Walls\n" ; + + my @list = sort $x->get_dup("Wall") ; + print "Wall => [@list]\n" ; + + @list = $x->get_dup("Smith") ; + print "Smith => [@list]\n" ; + + @list = $x->get_dup("Dog") ; + print "Dog => [@list]\n" ; + + +and it will print: + + Wall occurred 3 times + Larry is there + There are 2 Brick Walls + Wall => [Brick Brick Larry] + Smith => [John] + Dog => [] + +=head2 The find_dup() Method + + $status = $X->find_dup($key, $value) ; + +This method checks for the existence of a specific key/value pair. If the +pair exists, the cursor is left pointing to the pair and the method +returns 0. Otherwise the method returns a non-zero value. + +Assuming the database from the previous example: + + use warnings ; + use strict ; + use DB_File ; + + use vars qw($filename $x %h $found) ; + + my $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; + print "Harry Wall is $found there\n" ; + + undef $x ; + untie %h ; + +prints this + + Larry Wall is there + Harry Wall is not there + + +=head2 The del_dup() Method + + $status = $X->del_dup($key, $value) ; + +This method deletes a specific key/value pair. It returns +0 if they exist and have been deleted successfully. +Otherwise the method returns a non-zero value. + +Again assuming the existence of the C<tree> database + + use warnings ; + use strict ; + use DB_File ; + + use vars qw($filename $x %h $found) ; + + my $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $x->del_dup("Wall", "Larry") ; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + undef $x ; + untie %h ; + +prints this + + Larry Wall is not there + +=head2 Matching Partial Keys + +The BTREE interface has a feature which allows partial keys to be +matched. This functionality is I<only> available when the C<seq> method +is used along with the R_CURSOR flag. + + $x->seq($key, $value, R_CURSOR) ; + +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<match> sub uses this feature to find +and print the first matching key/value pair given a partial key. + + use warnings ; + use strict ; + use DB_File ; + use Fcntl ; + + use vars qw($filename $x %h $st $key $value) ; + + sub match + { + my $key = shift ; + my $value = 0; + my $orig_key = $key ; + $x->seq($key, $value, R_CURSOR) ; + print "$orig_key\t-> $key\t-> $value\n" ; + } + + $filename = "tree" ; + unlink $filename ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'mouse'} = 'mickey' ; + $h{'Wall'} = 'Larry' ; + $h{'Walls'} = 'Brick' ; + $h{'Smith'} = 'John' ; + + + $key = $value = 0 ; + print "IN ORDER\n" ; + for ($st = $x->seq($key, $value, R_FIRST) ; + $st == 0 ; + $st = $x->seq($key, $value, R_NEXT) ) + + { print "$key -> $value\n" } + + print "\nPARTIAL MATCH\n" ; + + match "Wa" ; + match "A" ; + match "a" ; + + undef $x ; + untie %h ; + +Here is the output: + + IN ORDER + Smith -> John + Wall -> Larry + Walls -> Brick + mouse -> mickey + + PARTIAL MATCH + Wa -> Wall -> Larry + A -> Smith -> John + a -> mouse -> mickey + +=head1 DB_RECNO + +DB_RECNO provides an interface to flat text files. Both variable and +fixed length records are supported. + +In order to make RECNO more compatible with Perl, the array offset for +all RECNO arrays begins at 0 rather than 1 as in Berkeley DB. + +As with normal Perl arrays, a RECNO array can be accessed using +negative indexes. The index -1 refers to the last element of the array, +-2 the second last, and so on. Attempting to access an element before +the start of the array will raise a fatal run-time error. + +=head2 The 'bval' Option + +The operation of the bval option warrants some discussion. Here is the +definition of bval from the Berkeley DB 1.85 recno manual page: + + The delimiting byte to be used to mark the end of a + record for variable-length records, and the pad charac- + ter for fixed-length records. If no value is speci- + fied, newlines (``\n'') are used to mark the end of + variable-length records and fixed-length records are + padded with spaces. + +The second sentence is wrong. In actual fact bval will only default to +C<"\n"> when the openinfo parameter in dbopen is NULL. If a non-NULL +openinfo parameter is used at all, the value that happens to be in bval +will be used. That means you always have to specify bval when making +use of any of the options in the openinfo parameter. This documentation +error will be fixed in the next release of Berkeley DB. + +That clarifies the situation with regards Berkeley DB itself. What +about B<DB_File>? Well, the behavior defined in the quote above is +quite useful, so B<DB_File> conforms to it. + +That means that you can specify other options (e.g. cachesize) and +still have bval default to C<"\n"> for variable length records, and +space for fixed length records. + +=head2 A Simple Example + +Here is a simple example that uses RECNO (if you are using a version +of Perl earlier than 5.004_57 this example won't work -- see +L<Extra RECNO Methods> for a workaround). + + use warnings ; + use strict ; + use DB_File ; + + my $filename = "text" ; + unlink $filename ; + + my @h ; + tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file 'text': $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + push @h, "green", "black" ; + + my $elements = scalar @h ; + print "The array contains $elements entries\n" ; + + my $last = pop @h ; + print "popped $last\n" ; + + unshift @h, "white" ; + my $first = shift @h ; + print "shifted $first\n" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + # use a negative index + print "The last element is $h[-1]\n" ; + print "The 2nd last element is $h[-2]\n" ; + + untie @h ; + +Here is the output from the script: + + The array contains 5 entries + popped black + shifted white + Element 1 Exists with value blue + The last element is green + The 2nd last element is yellow + +=head2 Extra RECNO Methods + +If you are using a version of Perl earlier than 5.004_57, the tied +array interface is quite limited. In the example script above +C<push>, C<pop>, C<shift>, C<unshift> +or determining the array length will not work with a tied array. + +To make the interface more useful for older versions of Perl, a number +of methods are supplied with B<DB_File> to simulate the missing array +operations. All these methods are accessed via the object returned from +the tie call. + +Here are the methods: + +=over 5 + +=item B<$X-E<gt>push(list) ;> + +Pushes the elements of C<list> to the end of the array. + +=item B<$value = $X-E<gt>pop ;> + +Removes and returns the last element of the array. + +=item B<$X-E<gt>shift> + +Removes and returns the first element of the array. + +=item B<$X-E<gt>unshift(list) ;> + +Pushes the elements of C<list> to the start of the array. + +=item B<$X-E<gt>length> + +Returns the number of elements in the array. + +=back + +=head2 Another Example + +Here is a more complete example that makes use of some of the methods +described above. It also makes use of the API interface directly (see +L<THE API INTERFACE>). + + use warnings ; + use strict ; + use vars qw(@h $H $file $i) ; + use DB_File ; + use Fcntl ; + + $file = "text" ; + + unlink $file ; + + $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file $file: $!\n" ; + + # first create a text file to play with + $h[0] = "zero" ; + $h[1] = "one" ; + $h[2] = "two" ; + $h[3] = "three" ; + $h[4] = "four" ; + + + # Print the records in order. + # + # The length method is needed here because evaluating a tied + # array in a scalar context does not return the number of + # elements in the array. + + print "\nORIGINAL\n" ; + foreach $i (0 .. $H->length - 1) { + print "$i: $h[$i]\n" ; + } + + # use the push & pop methods + $a = $H->pop ; + $H->push("last") ; + print "\nThe last record was [$a]\n" ; + + # and the shift & unshift methods + $a = $H->shift ; + $H->unshift("first") ; + print "The first record was [$a]\n" ; + + # Use the API to add a new record after record 2. + $i = 2 ; + $H->put($i, "Newbie", R_IAFTER) ; + + # and a new record before record 1. + $i = 1 ; + $H->put($i, "New One", R_IBEFORE) ; + + # delete record 3 + $H->del(3) ; + + # now print the records in reverse order + print "\nREVERSE\n" ; + for ($i = $H->length - 1 ; $i >= 0 ; -- $i) + { print "$i: $h[$i]\n" } + + # same again, but use the API functions instead + print "\nREVERSE again\n" ; + my ($s, $k, $v) = (0, 0, 0) ; + for ($s = $H->seq($k, $v, R_LAST) ; + $s == 0 ; + $s = $H->seq($k, $v, R_PREV)) + { print "$k: $v\n" } + + undef $H ; + untie @h ; + +and this is what it outputs: + + ORIGINAL + 0: zero + 1: one + 2: two + 3: three + 4: four + + The last record was [four] + The first record was [zero] + + REVERSE + 5: last + 4: three + 3: Newbie + 2: one + 1: New One + 0: first + + REVERSE again + 5: last + 4: three + 3: Newbie + 2: one + 1: New One + 0: first + +Notes: + +=over 5 + +=item 1. + +Rather than iterating through the array, C<@h> like this: + + foreach $i (@h) + +it is necessary to use either this: + + foreach $i (0 .. $H->length - 1) + +or this: + + for ($a = $H->get($k, $v, R_FIRST) ; + $a == 0 ; + $a = $H->get($k, $v, R_NEXT) ) + +=item 2. + +Notice that both times the C<put> method was used the record index was +specified using a variable, C<$i>, rather than the literal value +itself. This is because C<put> will return the record number of the +inserted line via that parameter. + +=back + +=head1 THE API INTERFACE + +As well as accessing Berkeley DB using a tied hash or array, it is also +possible to make direct use of most of the API functions defined in the +Berkeley DB documentation. + +To do this you need to store a copy of the object returned from the tie. + + $db = tie %hash, "DB_File", "filename" ; + +Once you have done that, you can access the Berkeley DB API functions +as B<DB_File> methods directly like this: + + $db->put($key, $value, R_NOOVERWRITE) ; + +B<Important:> If you have saved a copy of the object returned from +C<tie>, the underlying database file will I<not> be closed until both +the tied variable is untied and all copies of the saved object are +destroyed. + + use DB_File ; + $db = tie %hash, "DB_File", "filename" + or die "Cannot tie filename: $!" ; + ... + undef $db ; + untie %hash ; + +See L<The untie() Gotcha> for more details. + +All the functions defined in L<dbopen> are available except for +close() and dbopen() itself. The B<DB_File> method interface to the +supported functions have been implemented to mirror the way Berkeley DB +works whenever possible. In particular note that: + +=over 5 + +=item * + +The methods return a status value. All return 0 on success. +All return -1 to signify an error and set C<$!> to the exact +error code. The return code 1 generally (but not always) means that the +key specified did not exist in the database. + +Other return codes are defined. See below and in the Berkeley DB +documentation for details. The Berkeley DB documentation should be used +as the definitive source. + +=item * + +Whenever a Berkeley DB function returns data via one of its parameters, +the equivalent B<DB_File> method does exactly the same. + +=item * + +If you are careful, it is possible to mix API calls with the tied +hash/array interface in the same piece of code. Although only a few of +the methods used to implement the tied interface currently make use of +the cursor, you should always assume that the cursor has been changed +any time the tied hash/array interface is used. As an example, this +code will probably not do what you expect: + + $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE + or die "Cannot tie $filename: $!" ; + + # Get the first key/value pair and set the cursor + $X->seq($key, $value, R_FIRST) ; + + # this line will modify the cursor + $count = scalar keys %x ; + + # Get the second key/value pair. + # oops, it didn't, it got the last key/value pair! + $X->seq($key, $value, R_NEXT) ; + +The code above can be rearranged to get around the problem, like this: + + $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE + or die "Cannot tie $filename: $!" ; + + # this line will modify the cursor + $count = scalar keys %x ; + + # Get the first key/value pair and set the cursor + $X->seq($key, $value, R_FIRST) ; + + # Get the second key/value pair. + # worked this time. + $X->seq($key, $value, R_NEXT) ; + +=back + +All the constants defined in L<dbopen> for use in the flags parameters +in the methods defined below are also available. Refer to the Berkeley +DB documentation for the precise meaning of the flags values. + +Below is a list of the methods available. + +=over 5 + +=item B<$status = $X-E<gt>get($key, $value [, $flags]) ;> + +Given a key (C<$key>) this method reads the value associated with it +from the database. The value read from the database is returned in the +C<$value> parameter. + +If the key does not exist the method returns 1. + +No flags are currently defined for this method. + +=item B<$status = $X-E<gt>put($key, $value [, $flags]) ;> + +Stores the key/value pair in the database. + +If you use either the R_IAFTER or R_IBEFORE flags, the C<$key> parameter +will have the record number of the inserted key/value pair set. + +Valid flags are R_CURSOR, R_IAFTER, R_IBEFORE, R_NOOVERWRITE and +R_SETCURSOR. + +=item B<$status = $X-E<gt>del($key [, $flags]) ;> + +Removes all key/value pairs with key C<$key> from the database. + +A return code of 1 means that the requested key was not in the +database. + +R_CURSOR is the only valid flag at present. + +=item B<$status = $X-E<gt>fd ;> + +Returns the file descriptor for the underlying database. + +See L<Locking: The Trouble with fd> for an explanation for why you should +not use C<fd> to lock your database. + +=item B<$status = $X-E<gt>seq($key, $value, $flags) ;> + +This interface allows sequential retrieval from the database. See +L<dbopen> for full details. + +Both the C<$key> and C<$value> parameters will be set to the key/value +pair read from the database. + +The flags parameter is mandatory. The valid flag values are R_CURSOR, +R_FIRST, R_LAST, R_NEXT and R_PREV. + +=item B<$status = $X-E<gt>sync([$flags]) ;> + +Flushes any cached buffers to disk. + +R_RECNOSYNC is the only valid flag at present. + +=back + +=head1 DBM FILTERS + +A DBM Filter is a piece of code that is be used when you I<always> +want to make the same transformation to all keys and/or values in a +DBM database. + +There are four methods associated with DBM Filters. All work identically, +and each is used to install (or uninstall) a single DBM Filter. Each +expects a single parameter, namely a reference to a sub. The only +difference between them is the place that the filter is installed. + +To summarise: + +=over 5 + +=item B<filter_store_key> + +If a filter has been installed with this method, it will be invoked +every time you write a key to a DBM database. + +=item B<filter_store_value> + +If a filter has been installed with this method, it will be invoked +every time you write a value to a DBM database. + + +=item B<filter_fetch_key> + +If a filter has been installed with this method, it will be invoked +every time you read a key from a DBM database. + +=item B<filter_fetch_value> + +If a filter has been installed with this method, it will be invoked +every time you read a value from a DBM database. + +=back + +You can use any combination of the methods, from none, to all four. + +All filter methods return the existing filter, if present, or C<undef> +in not. + +To delete a filter pass C<undef> to it. + +=head2 The Filter + +When each filter is called by Perl, a local copy of C<$_> will contain +the key or value to be filtered. Filtering is achieved by modifying +the contents of C<$_>. The return code from the filter is ignored. + +=head2 An Example -- the NULL termination problem. + +Consider the following scenario. You have a DBM database +that you need to share with a third-party C application. The C application +assumes that I<all> keys and values are NULL terminated. Unfortunately +when Perl writes to DBM databases it doesn't use NULL termination, so +your Perl application will have to manage NULL termination itself. When +you write to the database you will have to use something like this: + + $hash{"$key\0"} = "$value\0" ; + +Similarly the NULL needs to be taken into account when you are considering +the length of existing keys/values. + +It would be much better if you could ignore the NULL terminations issue +in the main application code and have a mechanism that automatically +added the terminating NULL to all keys and values whenever you write to +the database and have them removed when you read from the database. As I'm +sure you have already guessed, this is a problem that DBM Filters can +fix very easily. + + use warnings ; + use strict ; + use DB_File ; + + my %hash ; + my $filename = "/tmp/filt" ; + unlink $filename ; + + my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH + or die "Cannot open $filename: $!\n" ; + + # Install DBM Filters + $db->filter_fetch_key ( sub { s/\0$// } ) ; + $db->filter_store_key ( sub { $_ .= "\0" } ) ; + $db->filter_fetch_value( sub { s/\0$// } ) ; + $db->filter_store_value( sub { $_ .= "\0" } ) ; + + $hash{"abc"} = "def" ; + my $a = $hash{"ABC"} ; + # ... + undef $db ; + untie %hash ; + +Hopefully the contents of each of the filters should be +self-explanatory. Both "fetch" filters remove the terminating NULL, +and both "store" filters add a terminating NULL. + + +=head2 Another Example -- Key is a C int. + +Here is another real-life example. By default, whenever Perl writes to +a DBM database it always writes the key and value as strings. So when +you use this: + + $hash{12345} = "soemthing" ; + +the key 12345 will get stored in the DBM database as the 5 byte string +"12345". If you actually want the key to be stored in the DBM database +as a C int, you will have to use C<pack> when writing, and C<unpack> +when reading. + +Here is a DBM Filter that does it: + + use warnings ; + use strict ; + use DB_File ; + my %hash ; + my $filename = "/tmp/filt" ; + unlink $filename ; + + + my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH + or die "Cannot open $filename: $!\n" ; + + $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ; + $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ; + $hash{123} = "def" ; + # ... + undef $db ; + untie %hash ; + +This time only two filters have been used -- we only need to manipulate +the contents of the key, so it wasn't necessary to install any value +filters. + +=head1 HINTS AND TIPS + + +=head2 Locking: The Trouble with fd + +Until version 1.72 of this module, the recommended technique for locking +B<DB_File> databases was to flock the filehandle returned from the "fd" +function. Unfortunately this technique has been shown to be fundamentally +flawed (Kudos to David Harris for tracking this down). Use it at your own +peril! + +The locking technique went like this. + + $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0644) + || die "dbcreat /tmp/foo.db $!"; + $fd = $db->fd; + open(DB_FH, "+<&=$fd") || die "dup $!"; + flock (DB_FH, LOCK_EX) || die "flock: $!"; + ... + $db{"Tom"} = "Jerry" ; + ... + flock(DB_FH, LOCK_UN); + undef $db; + untie %db; + close(DB_FH); + +In simple terms, this is what happens: + +=over 5 + +=item 1. + +Use "tie" to open the database. + +=item 2. + +Lock the database with fd & flock. + +=item 3. + +Read & Write to the database. + +=item 4. + +Unlock and close the database. + +=back + +Here is the crux of the problem. A side-effect of opening the B<DB_File> +database in step 2 is that an initial block from the database will get +read from disk and cached in memory. + +To see why this is a problem, consider what can happen when two processes, +say "A" and "B", both want to update the same B<DB_File> database +using the locking steps outlined above. Assume process "A" has already +opened the database and has a write lock, but it hasn't actually updated +the database yet (it has finished step 2, but not started step 3 yet). Now +process "B" tries to open the same database - step 1 will succeed, +but it will block on step 2 until process "A" releases the lock. The +important thing to notice here is that at this point in time both +processes will have cached identical initial blocks from the database. + +Now process "A" updates the database and happens to change some of the +data held in the initial buffer. Process "A" terminates, flushing +all cached data to disk and releasing the database lock. At this point +the database on disk will correctly reflect the changes made by process +"A". + +With the lock released, process "B" can now continue. It also updates the +database and unfortunately it too modifies the data that was in its +initial buffer. Once that data gets flushed to disk it will overwrite +some/all of the changes process "A" made to the database. + +The result of this scenario is at best a database that doesn't contain +what you expect. At worst the database will corrupt. + +The above won't happen every time competing process update the same +B<DB_File> database, but it does illustrate why the technique should +not be used. + +=head2 Safe ways to lock a database + +Starting with version 2.x, Berkeley DB has internal support for locking. +The companion module to this one, B<BerkeleyDB>, provides an interface +to this locking functionality. If you are serious about locking +Berkeley DB databases, I strongly recommend using B<BerkeleyDB>. + +If using B<BerkeleyDB> isn't an option, there are a number of modules +available on CPAN that can be used to implement locking. Each one +implements locking differently and has different goals in mind. It is +therefore worth knowing the difference, so that you can pick the right +one for your application. Here are the three locking wrappers: + +=over 5 + +=item B<Tie::DB_Lock> + +A B<DB_File> wrapper which creates copies of the database file for +read access, so that you have a kind of a multiversioning concurrent read +system. However, updates are still serial. Use for databases where reads +may be lengthy and consistency problems may occur. + +=item B<Tie::DB_LockFile> + +A B<DB_File> wrapper that has the ability to lock and unlock the database +while it is being used. Avoids the tie-before-flock problem by simply +re-tie-ing the database when you get or drop a lock. Because of the +flexibility in dropping and re-acquiring the lock in the middle of a +session, this can be massaged into a system that will work with long +updates and/or reads if the application follows the hints in the POD +documentation. + +=item B<DB_File::Lock> + +An extremely lightweight B<DB_File> wrapper that simply flocks a lockfile +before tie-ing the database and drops the lock after the untie. Allows +one to use the same lockfile for multiple databases to avoid deadlock +problems, if desired. Use for databases where updates are reads are +quick and simple flock locking semantics are enough. + +=back + +=head2 Sharing Databases With C Applications + +There is no technical reason why a Berkeley DB database cannot be +shared by both a Perl and a C application. + +The vast majority of problems that are reported in this area boil down +to the fact that C strings are NULL terminated, whilst Perl strings are +not. See L<DBM FILTERS> for a generic way to work around this problem. + +Here is a real example. Netscape 2.0 keeps a record of the locations you +visit along with the time you last visited them in a DB_HASH database. +This is usually stored in the file F<~/.netscape/history.db>. The key +field in the database is the location string and the value field is the +time the location was last visited stored as a 4 byte binary value. + +If you haven't already guessed, the location string is stored with a +terminating NULL. This means you need to be careful when accessing the +database. + +Here is a snippet of code that is loosely based on Tom Christiansen's +I<ggh> script (available from your nearest CPAN archive in +F<authors/id/TOMC/scripts/nshist.gz>). + + use warnings ; + use strict ; + use DB_File ; + use Fcntl ; + + use vars qw( $dotdir $HISTORY %hist_db $href $binary_time $date ) ; + $dotdir = $ENV{HOME} || $ENV{LOGNAME}; + + $HISTORY = "$dotdir/.netscape/history.db"; + + tie %hist_db, 'DB_File', $HISTORY + or die "Cannot open $HISTORY: $!\n" ;; + + # Dump the complete database + while ( ($href, $binary_time) = each %hist_db ) { + + # remove the terminating NULL + $href =~ s/\x00$// ; + + # convert the binary time into a user friendly string + $date = localtime unpack("V", $binary_time); + print "$date $href\n" ; + } + + # check for the existence of a specific key + # remember to add the NULL + if ( $binary_time = $hist_db{"http://mox.perl.com/\x00"} ) { + $date = localtime unpack("V", $binary_time) ; + print "Last visited mox.perl.com on $date\n" ; + } + else { + print "Never visited mox.perl.com\n" + } + + untie %hist_db ; + +=head2 The untie() Gotcha + +If you make use of the Berkeley DB API, it is I<very> strongly +recommended that you read L<perltie/The untie Gotcha>. + +Even if you don't currently make use of the API interface, it is still +worth reading it. + +Here is an example which illustrates the problem from a B<DB_File> +perspective: + + use DB_File ; + use Fcntl ; + + my %x ; + my $X ; + + $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_TRUNC + or die "Cannot tie first time: $!" ; + + $x{123} = 456 ; + + untie %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 14. + +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. + +Having read L<perltie> you will probably have already guessed that the +error is caused by the extra copy of the tied object stored in C<$X>. +If you haven't, then the problem boils down to the fact that the +B<DB_File> destructor, DESTROY, will not be called until I<all> +references to the tied object are destroyed. Both the tied variable, +C<%x>, and C<$X> above hold a reference to the object. The call to +untie() will destroy the first, but C<$X> still holds a valid +reference, so the destructor will not get called and the database file +F<tst.fil> will remain open. The fact that Berkeley DB then reports the +attempt to open a database that is already open via the catch-all +"Invalid argument" doesn't help. + +If you run the script with the C<-w> flag the error message becomes: + + untie attempted while 1 inner references still exist at bad.file line 12. + Cannot tie second time: Invalid argument at bad.file line 14. + +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 + ... + + +=head1 COMMON QUESTIONS + +=head2 Why is there Perl source in my database? + +If you look at the contents of a database file created by DB_File, +there can sometimes be part of a Perl script included in it. + +This happens because Berkeley DB uses dynamic memory to allocate +buffers which will subsequently be written to the database file. Being +dynamic, the memory could have been used for anything before DB +malloced it. As Berkeley DB doesn't clear the memory once it has been +allocated, the unused portions will contain random junk. In the case +where a Perl script gets written to the database, the random junk will +correspond to an area of dynamic memory that happened to be used during +the compilation of the script. + +Unless you don't like the possibility of there being part of your Perl +scripts embedded in a database file, this is nothing to worry about. + +=head2 How do I store complex data structures with DB_File? + +Although B<DB_File> cannot do this directly, there is a module which +can layer transparently over B<DB_File> to accomplish this feat. + +Check out the MLDBM module, available on CPAN in the directory +F<modules/by-module/MLDBM>. + +=head2 What does "Invalid Argument" mean? + +You will get this error message when one of the parameters in the +C<tie> call is wrong. Unfortunately there are quite a few parameters to +get wrong, so it can be difficult to figure out which one it is. + +Here are a couple of possibilities: + +=over 5 + +=item 1. + +Attempting to reopen a database without closing it. + +=item 2. + +Using the O_WRONLY flag. + +=back + +=head2 What does "Bareword 'DB_File' not allowed" mean? + +You will encounter this particular error message when you have the +C<strict 'subs'> pragma (or the full strict pragma) in your script. +Consider this script: + + use warnings ; + use strict ; + use DB_File ; + use vars qw(%x) ; + tie %x, DB_File, "filename" ; + +Running it produces the error in question: + + Bareword "DB_File" not allowed while "strict subs" in use + +To get around the error, place the word C<DB_File> in either single or +double quotes, like this: + + tie %x, "DB_File", "filename" ; + +Although it might seem like a real pain, it is really worth the effort +of having a C<use strict> in all your scripts. + +=head1 REFERENCES + +Articles that are either about B<DB_File> or make use of it. + +=over 5 + +=item 1. + +I<Full-Text Searching in Perl>, Tim Kientzle (tkientzle@ddj.com), +Dr. Dobb's Journal, Issue 295, January 1999, pp 34-41 + +=back + +=head1 HISTORY + +Moved to the Changes file. + +=head1 BUGS + +Some older versions of Berkeley DB had problems with fixed length +records using the RECNO file format. This problem has been fixed since +version 1.85 of Berkeley DB. + +I am sure there are bugs in the code. If you do find any, or can +suggest any enhancements, I would welcome your comments. + +=head1 AVAILABILITY + +B<DB_File> comes with the standard Perl source distribution. Look in +the directory F<ext/DB_File>. Given the amount of time between releases +of Perl the version that ships with Perl is quite likely to be out of +date, so the most recent version can always be found on CPAN (see +L<perlmod/CPAN> for details), in the directory +F<modules/by-module/DB_File>. + +This version of B<DB_File> will work with either version 1.x, 2.x or +3.x of Berkeley DB, but is limited to the functionality provided by +version 1. + +The official web site for Berkeley DB is F<http://www.sleepycat.com>. +All versions of Berkeley DB are available there. + +Alternatively, Berkeley DB version 1 is available at your nearest CPAN +archive in F<src/misc/db.1.85.tar.gz>. + +If you are running IRIX, then get Berkeley DB version 1 from +F<http://reality.sgi.com/ariel>. It has the patches necessary to +compile properly on IRIX 5.3. + +=head1 COPYRIGHT + +Copyright (c) 1995-1999 Paul Marquess. All rights reserved. This program +is free software; you can redistribute it and/or modify it under the +same terms as Perl itself. + +Although B<DB_File> is covered by the Perl license, the library it +makes use of, namely Berkeley DB, is not. Berkeley DB has its own +copyright and its own license. Please take the time to read it. + +Here are are few words taken from the Berkeley DB FAQ (at +F<http://www.sleepycat.com>) regarding the license: + + Do I have to license DB to use it in Perl scripts? + + No. The Berkeley DB license requires that software that uses + Berkeley DB be freely redistributable. In the case of Perl, that + software is Perl, and not your scripts. Any Perl scripts that you + write are your property, including scripts that make use of + Berkeley DB. Neither the Perl license nor the Berkeley DB license + place any restriction on what you may do with them. + +If you are in any doubt about the license situation, contact either the +Berkeley DB authors or the author of DB_File. See L<"AUTHOR"> for details. + + +=head1 SEE ALSO + +L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>, +L<dbmfilter> + +=head1 AUTHOR + +The DB_File interface was written by Paul Marquess +E<lt>Paul.Marquess@btinternet.comE<gt>. +Questions about the DB system itself may be addressed to +E<lt>db@sleepycat.com<gt>. + +=cut diff --git a/bdb/perl.DB_File/DB_File.xs b/bdb/perl.DB_File/DB_File.xs new file mode 100644 index 00000000000..6811342066d --- /dev/null +++ b/bdb/perl.DB_File/DB_File.xs @@ -0,0 +1,2072 @@ +/* + + DB_File.xs -- Perl 5 interface to Berkeley DB + + written by Paul Marquess <Paul.Marquess@btinternet.com> + last modified 15th January 2001 + version 1.76 + + All comments/suggestions/problems are welcome + + Copyright (c) 1995-2001 Paul Marquess. All rights reserved. + This program is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + + Changes: + 0.1 - Initial Release + 0.2 - No longer bombs out if dbopen returns an error. + 0.3 - Added some support for multiple btree compares + 1.0 - Complete support for multiple callbacks added. + Fixed a problem with pushing a value onto an empty list. + 1.01 - Fixed a SunOS core dump problem. + The return value from TIEHASH wasn't set to NULL when + dbopen returned an error. + 1.02 - Use ALIAS to define TIEARRAY. + Removed some redundant commented code. + Merged OS2 code into the main distribution. + 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 + 1.06 - Minor namespace cleanup: Localized PrintBtree. + 1.07 - Fixed bug with RECNO, where bval wasn't defaulting to "\n". + 1.08 - No change to DB_File.xs + 1.09 - Default mode for dbopen changed to 0666 + 1.10 - Fixed fd method so that it still returns -1 for + in-memory files when db 1.86 is used. + 1.11 - No change to DB_File.xs + 1.12 - No change to DB_File.xs + 1.13 - Tidied up a few casts. + 1.14 - Made it illegal to tie an associative array to a RECNO + database and an ordinary array to a HASH or BTREE database. + 1.50 - Make work with both DB 1.x or DB 2.x + 1.51 - Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent + 1.52 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of + undefined value" warning with db_get and db_seq. + 1.53 - Added DB_RENUMBER to flags for recno. + 1.54 - Fixed bug in the fd method + 1.55 - Fix for AIX from Jarkko Hietaniemi + 1.56 - No change to DB_File.xs + 1.57 - added the #undef op to allow building with Threads support. + 1.58 - 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.59 - No change to DB_File.xs + 1.60 - Some code tidy up + 1.61 - added flagSet macro for DB 2.5.x + fixed typo in O_RDONLY test. + 1.62 - No change to DB_File.xs + 1.63 - Fix to alllow DB 2.6.x to build. + 1.64 - Tidied up the 1.x to 2.x flags mapping code. + Added a patch from Mark Kettenis <kettenis@wins.uva.nl> + to fix a flag mapping problem with O_RDONLY on the Hurd + 1.65 - Fixed a bug in the PUSH logic. + Added BOOT check that using 2.3.4 or greater + 1.66 - Added DBM filter code + 1.67 - Backed off the use of newSVpvn. + Fixed DBM Filter code for Perl 5.004. + Fixed a small memory leak in the filter code. + 1.68 - fixed backward compatability bug with R_IAFTER & R_IBEFORE + merged in the 5.005_58 changes + 1.69 - fixed a bug in push -- DB_APPEND wasn't working properly. + Fixed the R_SETCURSOR bug introduced in 1.68 + Added a new Perl variable $DB_File::db_ver + 1.70 - Initialise $DB_File::db_ver and $DB_File::db_version with + GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. + Added a BOOT check to test for equivalent versions of db.h & + libdb.a/so. + 1.71 - Support for Berkeley DB version 3. + Support for Berkeley DB 2/3's backward compatability mode. + Rewrote push + 1.72 - No change to DB_File.xs + 1.73 - No change to DB_File.xs + 1.74 - A call to open needed parenthesised to stop it clashing + with a win32 macro. + Added Perl core patches 7703 & 7801. + 1.75 - Fixed Perl core patch 7703. + 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. + 1.76 - No change to DB_File.xs + +*/ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifndef PERL_VERSION +# include "patchlevel.h" +# define PERL_REVISION 5 +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION +#endif + +#if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75 )) + +# define PL_sv_undef sv_undef +# define PL_na na + +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(defgv) +#endif + +/* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be + * shortly #included by the <db.h>) __attribute__ to the possibly + * already defined __attribute__, for example by GNUC or by Perl. */ + +#undef __attribute__ + +/* If Perl has been compiled with Threads support,the symbol op will + be defined here. This clashes with a field name in db.h, so get rid of it. + */ +#ifdef op +# undef op +#endif + +#ifdef COMPAT185 +# include <db_185.h> +#else +# include <db.h> +#endif + +#ifdef CAN_PROTOTYPE +extern void __getBerkeleyDBInfo(void); +#endif + +#ifndef pTHX +# define pTHX +# define pTHX_ +# define aTHX +# define aTHX_ +#endif + +#ifndef newSVpvn +# define newSVpvn(a,b) newSVpv(a,b) +#endif + +#include <fcntl.h> + +/* #define TRACE */ +#define DBM_FILTERING + +#ifdef TRACE +# define Trace(x) printf x +#else +# define Trace(x) +#endif + + +#define DBT_clear(x) Zero(&x, 1, DBT) ; + +#ifdef DB_VERSION_MAJOR + +#if DB_VERSION_MAJOR == 2 +# define BERKELEY_DB_1_OR_2 +#endif + +#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2) +# define AT_LEAST_DB_3_2 +#endif + +/* map version 2 features & constants onto their version 1 equivalent */ + +#ifdef DB_Prefix_t +# undef DB_Prefix_t +#endif +#define DB_Prefix_t size_t + +#ifdef DB_Hash_t +# undef DB_Hash_t +#endif +#define DB_Hash_t u_int32_t + +/* DBTYPE stays the same */ +/* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */ +#if DB_VERSION_MAJOR == 2 + typedef DB_INFO INFO ; +#else /* DB_VERSION_MAJOR > 2 */ +# define DB_FIXEDLEN (0x8000) +#endif /* DB_VERSION_MAJOR == 2 */ + +/* version 2 has db_recno_t in place of recno_t */ +typedef db_recno_t recno_t; + + +#define R_CURSOR DB_SET_RANGE +#define R_FIRST DB_FIRST +#define R_IAFTER DB_AFTER +#define R_IBEFORE DB_BEFORE +#define R_LAST DB_LAST +#define R_NEXT DB_NEXT +#define R_NOOVERWRITE DB_NOOVERWRITE +#define R_PREV DB_PREV + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 +# define R_SETCURSOR 0x800000 +#else +# define R_SETCURSOR (-100) +#endif + +#define R_RECNOSYNC 0 +#define R_FIXEDLEN DB_FIXEDLEN +#define R_DUP DB_DUP + + +#define db_HA_hash h_hash +#define db_HA_ffactor h_ffactor +#define db_HA_nelem h_nelem +#define db_HA_bsize db_pagesize +#define db_HA_cachesize db_cachesize +#define db_HA_lorder db_lorder + +#define db_BT_compare bt_compare +#define db_BT_prefix bt_prefix +#define db_BT_flags flags +#define db_BT_psize db_pagesize +#define db_BT_cachesize db_cachesize +#define db_BT_lorder db_lorder +#define db_BT_maxkeypage +#define db_BT_minkeypage + + +#define db_RE_reclen re_len +#define db_RE_flags flags +#define db_RE_bval re_pad +#define db_RE_bfname re_source +#define db_RE_psize db_pagesize +#define db_RE_cachesize db_cachesize +#define db_RE_lorder db_lorder + +#define TXN NULL, + +#define do_SEQ(db, key, value, flag) (db->cursor->c_get)(db->cursor, &key, &value, flag) + + +#define DBT_flags(x) x.flags = 0 +#define DB_flags(x, v) x |= v + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 +# define flagSet(flags, bitmask) ((flags) & (bitmask)) +#else +# define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask)) +#endif + +#else /* db version 1.x */ + +#define BERKELEY_DB_1 +#define BERKELEY_DB_1_OR_2 + +typedef union INFO { + HASHINFO hash ; + RECNOINFO recno ; + BTREEINFO btree ; + } INFO ; + + +#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 + +#define db_HA_hash hash.hash +#define db_HA_ffactor hash.ffactor +#define db_HA_nelem hash.nelem +#define db_HA_bsize hash.bsize +#define db_HA_cachesize hash.cachesize +#define db_HA_lorder hash.lorder + +#define db_BT_compare btree.compare +#define db_BT_prefix btree.prefix +#define db_BT_flags btree.flags +#define db_BT_psize btree.psize +#define db_BT_cachesize btree.cachesize +#define db_BT_lorder btree.lorder +#define db_BT_maxkeypage btree.maxkeypage +#define db_BT_minkeypage btree.minkeypage + +#define db_RE_reclen recno.reclen +#define db_RE_flags recno.flags +#define db_RE_bval recno.bval +#define db_RE_bfname recno.bfname +#define db_RE_psize recno.psize +#define db_RE_cachesize recno.cachesize +#define db_RE_lorder recno.lorder + +#define TXN + +#define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag) +#define DBT_flags(x) +#define DB_flags(x, v) +#define flagSet(flags, bitmask) ((flags) & (bitmask)) + +#endif /* db version 1 */ + + + +#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, TXN &key, flags) +#define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, flags) +#define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) + +#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags) +#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_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) \ + : ((db->dbp)->del)(db->dbp, NULL, &key, flags) ) + +#else /* ! DB_VERSION_MAJOR */ + +#define db_DESTROY(db) ((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) + +#endif /* ! DB_VERSION_MAJOR */ + + +#define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags) + +typedef struct { + DBTYPE type ; + DB * dbp ; + SV * compare ; + SV * prefix ; + SV * hash ; + int in_memory ; +#ifdef BERKELEY_DB_1_OR_2 + INFO info ; +#endif +#ifdef DB_VERSION_MAJOR + DBC * cursor ; +#endif +#ifdef DBM_FILTERING + SV * filter_fetch_key ; + SV * filter_store_key ; + SV * filter_fetch_value ; + SV * filter_store_value ; + int filtering ; +#endif /* DBM_FILTERING */ + + } DB_File_type; + +typedef DB_File_type * DB_File ; +typedef DBT DBTKEY ; + +#ifdef DBM_FILTERING + +#define ckFilter(arg,type,name) \ + if (db->type) { \ + SV * save_defsv ; \ + /* printf("filtering %s\n", name) ;*/ \ + if (db->filtering) \ + croak("recursion detected in %s", name) ; \ + db->filtering = TRUE ; \ + save_defsv = newSVsv(DEFSV) ; \ + sv_setsv(DEFSV, arg) ; \ + PUSHMARK(sp) ; \ + (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \ + sv_setsv(arg, DEFSV) ; \ + sv_setsv(DEFSV, save_defsv) ; \ + SvREFCNT_dec(save_defsv) ; \ + db->filtering = FALSE ; \ + /*printf("end of filtering %s\n", name) ;*/ \ + } + +#else + +#define ckFilter(arg,type, name) + +#endif /* DBM_FILTERING */ + +#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s) + +#define OutputValue(arg, name) \ + { if (RETVAL == 0) { \ + my_sv_setpvn(arg, name.data, name.size) ; \ + ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \ + } \ + } + +#define OutputKey(arg, name) \ + { if (RETVAL == 0) \ + { \ + if (db->type != DB_RECNO) { \ + my_sv_setpvn(arg, name.data, name.size); \ + } \ + else \ + sv_setiv(arg, (I32)*(I32*)name.data - 1); \ + ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \ + } \ + } + + +/* Internal Global Data */ +static recno_t Value ; +static recno_t zero = 0 ; +static DB_File CurrentDB ; +static DBTKEY empty ; + +#ifdef DB_VERSION_MAJOR + +static int +#ifdef CAN_PROTOTYPE +db_put(DB_File db, DBTKEY key, DBT value, u_int flags) +#else +db_put(db, key, value, flags) +DB_File db ; +DBTKEY key ; +DBT value ; +u_int flags ; +#endif +{ + int status ; + + if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) { + DBC * temp_cursor ; + DBT l_key, l_value; + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 + if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0) +#else + if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0) +#endif + return (-1) ; + + memset(&l_key, 0, sizeof(l_key)); + l_key.data = key.data; + l_key.size = key.size; + memset(&l_value, 0, sizeof(l_value)); + l_value.data = value.data; + l_value.size = value.size; + + if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) { + (void)temp_cursor->c_close(temp_cursor); + return (-1); + } + + status = temp_cursor->c_put(temp_cursor, &key, &value, flags); + (void)temp_cursor->c_close(temp_cursor); + + return (status) ; + } + + + if (flagSet(flags, R_CURSOR)) { + return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT); + } + + if (flagSet(flags, R_SETCURSOR)) { + if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0) + return -1 ; + return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE); + + } + + return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ; + +} + +#endif /* DB_VERSION_MAJOR */ + + +static int +#ifdef AT_LEAST_DB_3_2 + +#ifdef CAN_PROTOTYPE +btree_compare(DB * db, const DBT *key1, const DBT *key2) +#else +btree_compare(db, key1, key2) +DB * db ; +const DBT * key1 ; +const DBT * key2 ; +#endif /* CAN_PROTOTYPE */ + +#else /* Berkeley DB < 3.2 */ + +#ifdef CAN_PROTOTYPE +btree_compare(const DBT *key1, const DBT *key2) +#else +btree_compare(key1, key2) +const DBT * key1 ; +const DBT * key2 ; +#endif + +#endif + +{ +#ifdef dTHX + dTHX; +#endif + dSP ; + void * data1, * data2 ; + int retval ; + int count ; + + data1 = key1->data ; + data2 = key2->data ; + +#ifndef newSVpvn + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; +#endif + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); + PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); + PUTBACK ; + + count = perl_call_sv(CurrentDB->compare, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + return (retval) ; + +} + +static DB_Prefix_t +#ifdef AT_LEAST_DB_3_2 + +#ifdef CAN_PROTOTYPE +btree_prefix(DB * db, const DBT *key1, const DBT *key2) +#else +btree_prefix(db, key1, key2) +Db * db ; +const DBT * key1 ; +const DBT * key2 ; +#endif + +#else /* Berkeley DB < 3.2 */ + +#ifdef CAN_PROTOTYPE +btree_prefix(const DBT *key1, const DBT *key2) +#else +btree_prefix(key1, key2) +const DBT * key1 ; +const DBT * key2 ; +#endif + +#endif +{ +#ifdef dTHX + dTHX; +#endif + dSP ; + void * data1, * data2 ; + int retval ; + int count ; + + data1 = key1->data ; + data2 = key2->data ; + +#ifndef newSVpvn + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an + empty string if the length is 0 + */ + if (key1->size == 0) + data1 = "" ; + if (key2->size == 0) + data2 = "" ; +#endif + + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + EXTEND(SP,2) ; + PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); + PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); + PUTBACK ; + + count = perl_call_sv(CurrentDB->prefix, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + return (retval) ; +} + + +#ifdef BERKELEY_DB_1 +# define HASH_CB_SIZE_TYPE size_t +#else +# define HASH_CB_SIZE_TYPE u_int32_t +#endif + +static DB_Hash_t +#ifdef AT_LEAST_DB_3_2 + +#ifdef CAN_PROTOTYPE +hash_cb(DB * db, const void *data, u_int32_t size) +#else +hash_cb(db, data, size) +DB * db ; +const void * data ; +HASH_CB_SIZE_TYPE size ; +#endif + +#else /* Berkeley DB < 3.2 */ + +#ifdef CAN_PROTOTYPE +hash_cb(const void *data, HASH_CB_SIZE_TYPE size) +#else +hash_cb(data, size) +const void * data ; +HASH_CB_SIZE_TYPE size ; +#endif + +#endif +{ +#ifdef dTHX + dTHX; +#endif + dSP ; + int retval ; + int count ; + +#ifndef newSVpvn + if (size == 0) + data = "" ; +#endif + + /* DGH - Next two lines added to fix corrupted stack problem */ + ENTER ; + SAVETMPS; + + PUSHMARK(SP) ; + + XPUSHs(sv_2mortal(newSVpvn((char*)data,size))); + PUTBACK ; + + count = perl_call_sv(CurrentDB->hash, G_SCALAR); + + SPAGAIN ; + + if (count != 1) + croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ; + + retval = POPi ; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + return (retval) ; +} + + +#if defined(TRACE) && defined(BERKELEY_DB_1_OR_2) + +static void +#ifdef CAN_PROTOTYPE +PrintHash(INFO *hash) +#else +PrintHash(hash) +INFO * hash ; +#endif +{ + printf ("HASH Info\n") ; + printf (" hash = %s\n", + (hash->db_HA_hash != NULL ? "redefined" : "default")) ; + printf (" bsize = %d\n", hash->db_HA_bsize) ; + printf (" ffactor = %d\n", hash->db_HA_ffactor) ; + printf (" nelem = %d\n", hash->db_HA_nelem) ; + printf (" cachesize = %d\n", hash->db_HA_cachesize) ; + printf (" lorder = %d\n", hash->db_HA_lorder) ; + +} + +static void +#ifdef CAN_PROTOTYPE +PrintRecno(INFO *recno) +#else +PrintRecno(recno) +INFO * recno ; +#endif +{ + printf ("RECNO Info\n") ; + printf (" flags = %d\n", recno->db_RE_flags) ; + printf (" cachesize = %d\n", recno->db_RE_cachesize) ; + printf (" psize = %d\n", recno->db_RE_psize) ; + printf (" lorder = %d\n", recno->db_RE_lorder) ; + printf (" reclen = %ul\n", (unsigned long)recno->db_RE_reclen) ; + printf (" bval = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ; + printf (" bfname = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ; +} + +static void +#ifdef CAN_PROTOTYPE +PrintBtree(INFO *btree) +#else +PrintBtree(btree) +INFO * btree ; +#endif +{ + printf ("BTREE Info\n") ; + printf (" compare = %s\n", + (btree->db_BT_compare ? "redefined" : "default")) ; + printf (" prefix = %s\n", + (btree->db_BT_prefix ? "redefined" : "default")) ; + printf (" flags = %d\n", btree->db_BT_flags) ; + printf (" cachesize = %d\n", btree->db_BT_cachesize) ; + printf (" psize = %d\n", btree->db_BT_psize) ; +#ifndef DB_VERSION_MAJOR + printf (" maxkeypage = %d\n", btree->db_BT_maxkeypage) ; + printf (" minkeypage = %d\n", btree->db_BT_minkeypage) ; +#endif + printf (" lorder = %d\n", btree->db_BT_lorder) ; +} + +#else + +#define PrintRecno(recno) +#define PrintHash(hash) +#define PrintBtree(btree) + +#endif /* TRACE */ + + +static I32 +#ifdef CAN_PROTOTYPE +GetArrayLength(pTHX_ DB_File db) +#else +GetArrayLength(db) +DB_File db ; +#endif +{ + DBT key ; + DBT value ; + int RETVAL ; + + DBT_clear(key) ; + DBT_clear(value) ; + RETVAL = do_SEQ(db, key, value, R_LAST) ; + if (RETVAL == 0) + RETVAL = *(I32 *)key.data ; + else /* No key means empty file */ + RETVAL = 0 ; + + return ((I32)RETVAL) ; +} + +static recno_t +#ifdef CAN_PROTOTYPE +GetRecnoKey(pTHX_ DB_File db, I32 value) +#else +GetRecnoKey(db, value) +DB_File db ; +I32 value ; +#endif +{ + if (value < 0) { + /* Get the length of the array */ + I32 length = GetArrayLength(aTHX_ db) ; + + /* check for attempt to write before start of array */ + if (length + value + 1 <= 0) + croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ; + + value = length + value + 1 ; + } + else + ++ value ; + + return value ; +} + + +static DB_File +#ifdef CAN_PROTOTYPE +ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv) +#else +ParseOpenInfo(isHASH, name, flags, mode, sv) +int isHASH ; +char * name ; +int flags ; +int mode ; +SV * sv ; +#endif +{ + +#ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1 or 2 */ + + SV ** svp; + HV * action ; + DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; + void * openinfo = NULL ; + INFO * info = &RETVAL->info ; + STRLEN n_a; + +/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ + Zero(RETVAL, 1, DB_File_type) ; + + /* Default to HASH */ +#ifdef DBM_FILTERING + RETVAL->filtering = 0 ; + RETVAL->filter_fetch_key = RETVAL->filter_store_key = + RETVAL->filter_fetch_value = RETVAL->filter_store_value = +#endif /* DBM_FILTERING */ + RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; + RETVAL->type = DB_HASH ; + + /* DGH - Next line added to avoid SEGV on existing hash DB */ + CurrentDB = RETVAL; + + /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ + RETVAL->in_memory = (name == NULL) ; + + if (sv) + { + if (! SvROK(sv) ) + croak ("type parameter is not a reference") ; + + svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; + if (svp && SvOK(*svp)) + action = (HV*) SvRV(*svp) ; + else + croak("internal error") ; + + if (sv_isa(sv, "DB_File::HASHINFO")) + { + + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_HASH database") ; + + RETVAL->type = DB_HASH ; + openinfo = (void*)info ; + + svp = hv_fetch(action, "hash", 4, FALSE); + + if (svp && SvOK(*svp)) + { + info->db_HA_hash = hash_cb ; + RETVAL->hash = newSVsv(*svp) ; + } + else + info->db_HA_hash = NULL ; + + svp = hv_fetch(action, "ffactor", 7, FALSE); + info->db_HA_ffactor = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "nelem", 5, FALSE); + info->db_HA_nelem = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "bsize", 5, FALSE); + info->db_HA_bsize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info->db_HA_cachesize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "lorder", 6, FALSE); + info->db_HA_lorder = svp ? SvIV(*svp) : 0; + + PrintHash(info) ; + } + else if (sv_isa(sv, "DB_File::BTREEINFO")) + { + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_BTREE database"); + + RETVAL->type = DB_BTREE ; + openinfo = (void*)info ; + + svp = hv_fetch(action, "compare", 7, FALSE); + if (svp && SvOK(*svp)) + { + info->db_BT_compare = btree_compare ; + RETVAL->compare = newSVsv(*svp) ; + } + else + info->db_BT_compare = NULL ; + + svp = hv_fetch(action, "prefix", 6, FALSE); + if (svp && SvOK(*svp)) + { + info->db_BT_prefix = btree_prefix ; + RETVAL->prefix = newSVsv(*svp) ; + } + else + info->db_BT_prefix = NULL ; + + svp = hv_fetch(action, "flags", 5, FALSE); + info->db_BT_flags = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info->db_BT_cachesize = svp ? SvIV(*svp) : 0; + +#ifndef DB_VERSION_MAJOR + svp = hv_fetch(action, "minkeypage", 10, FALSE); + info->btree.minkeypage = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "maxkeypage", 10, FALSE); + info->btree.maxkeypage = svp ? SvIV(*svp) : 0; +#endif + + svp = hv_fetch(action, "psize", 5, FALSE); + info->db_BT_psize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "lorder", 6, FALSE); + info->db_BT_lorder = svp ? SvIV(*svp) : 0; + + PrintBtree(info) ; + + } + else if (sv_isa(sv, "DB_File::RECNOINFO")) + { + if (isHASH) + croak("DB_File can only tie an array to a DB_RECNO database"); + + RETVAL->type = DB_RECNO ; + openinfo = (void *)info ; + + info->db_RE_flags = 0 ; + + svp = hv_fetch(action, "flags", 5, FALSE); + info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "reclen", 6, FALSE); + info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "psize", 5, FALSE); + info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0); + + svp = hv_fetch(action, "lorder", 6, FALSE); + info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0); + +#ifdef DB_VERSION_MAJOR + info->re_source = name ; + name = NULL ; +#endif + svp = hv_fetch(action, "bfname", 6, FALSE); + if (svp && SvOK(*svp)) { + char * ptr = SvPV(*svp,n_a) ; +#ifdef DB_VERSION_MAJOR + name = (char*) n_a ? ptr : NULL ; +#else + info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ; +#endif + } + else +#ifdef DB_VERSION_MAJOR + name = NULL ; +#else + info->db_RE_bfname = NULL ; +#endif + + svp = hv_fetch(action, "bval", 4, FALSE); +#ifdef DB_VERSION_MAJOR + if (svp && SvOK(*svp)) + { + int value ; + if (SvPOK(*svp)) + value = (int)*SvPV(*svp, n_a) ; + else + value = SvIV(*svp) ; + + if (info->flags & DB_FIXEDLEN) { + info->re_pad = value ; + info->flags |= DB_PAD ; + } + else { + info->re_delim = value ; + info->flags |= DB_DELIMITER ; + } + + } +#else + if (svp && SvOK(*svp)) + { + if (SvPOK(*svp)) + info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ; + else + info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ; + DB_flags(info->flags, DB_DELIMITER) ; + + } + else + { + if (info->db_RE_flags & R_FIXEDLEN) + info->db_RE_bval = (u_char) ' ' ; + else + info->db_RE_bval = (u_char) '\n' ; + DB_flags(info->flags, DB_DELIMITER) ; + } +#endif + +#ifdef DB_RENUMBER + info->flags |= DB_RENUMBER ; +#endif + + PrintRecno(info) ; + } + else + croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); + } + + + /* OS2 Specific Code */ +#ifdef OS2 +#ifdef __EMX__ + flags |= O_BINARY; +#endif /* __EMX__ */ +#endif /* OS2 */ + +#ifdef DB_VERSION_MAJOR + + { + int Flags = 0 ; + int status ; + + /* Map 1.x flags to 2.x flags */ + if ((flags & O_CREAT) == O_CREAT) + Flags |= DB_CREATE ; + +#if O_RDONLY == 0 + if (flags == O_RDONLY) +#else + if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR) +#endif + Flags |= DB_RDONLY ; + +#ifdef O_TRUNC + if ((flags & O_TRUNC) == O_TRUNC) + Flags |= DB_TRUNCATE ; +#endif + + status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ; + if (status == 0) +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ; +#else + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, + 0) ; +#endif + + if (status) + RETVAL->dbp = NULL ; + + } +#else + +#if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2 + RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ; +#else + RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; +#endif /* DB_LIBRARY_COMPATIBILITY_API */ + +#endif + + return (RETVAL) ; + +#else /* Berkeley DB Version > 2 */ + + SV ** svp; + HV * action ; + DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; + DB * dbp ; + STRLEN n_a; + int status ; + +/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ + Zero(RETVAL, 1, DB_File_type) ; + + /* Default to HASH */ +#ifdef DBM_FILTERING + RETVAL->filtering = 0 ; + RETVAL->filter_fetch_key = RETVAL->filter_store_key = + RETVAL->filter_fetch_value = RETVAL->filter_store_value = +#endif /* DBM_FILTERING */ + RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; + RETVAL->type = DB_HASH ; + + /* DGH - Next line added to avoid SEGV on existing hash DB */ + CurrentDB = RETVAL; + + /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ + RETVAL->in_memory = (name == NULL) ; + + status = db_create(&RETVAL->dbp, NULL,0) ; + /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */ + if (status) { + RETVAL->dbp = NULL ; + return (RETVAL) ; + } + dbp = RETVAL->dbp ; + + if (sv) + { + if (! SvROK(sv) ) + croak ("type parameter is not a reference") ; + + svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; + if (svp && SvOK(*svp)) + action = (HV*) SvRV(*svp) ; + else + croak("internal error") ; + + if (sv_isa(sv, "DB_File::HASHINFO")) + { + + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_HASH database") ; + + RETVAL->type = DB_HASH ; + + svp = hv_fetch(action, "hash", 4, FALSE); + + if (svp && SvOK(*svp)) + { + (void)dbp->set_h_hash(dbp, hash_cb) ; + RETVAL->hash = newSVsv(*svp) ; + } + + svp = hv_fetch(action, "ffactor", 7, FALSE); + if (svp) + (void)dbp->set_h_ffactor(dbp, SvIV(*svp)) ; + + svp = hv_fetch(action, "nelem", 5, FALSE); + if (svp) + (void)dbp->set_h_nelem(dbp, SvIV(*svp)) ; + + svp = hv_fetch(action, "bsize", 5, FALSE); + if (svp) + (void)dbp->set_pagesize(dbp, SvIV(*svp)); + + svp = hv_fetch(action, "cachesize", 9, FALSE); + if (svp) + (void)dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ; + + svp = hv_fetch(action, "lorder", 6, FALSE); + if (svp) + (void)dbp->set_lorder(dbp, SvIV(*svp)) ; + + PrintHash(info) ; + } + else if (sv_isa(sv, "DB_File::BTREEINFO")) + { + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_BTREE database"); + + RETVAL->type = DB_BTREE ; + + svp = hv_fetch(action, "compare", 7, FALSE); + if (svp && SvOK(*svp)) + { + (void)dbp->set_bt_compare(dbp, btree_compare) ; + RETVAL->compare = newSVsv(*svp) ; + } + + svp = hv_fetch(action, "prefix", 6, FALSE); + if (svp && SvOK(*svp)) + { + (void)dbp->set_bt_prefix(dbp, btree_prefix) ; + RETVAL->prefix = newSVsv(*svp) ; + } + + svp = hv_fetch(action, "flags", 5, FALSE); + if (svp) + (void)dbp->set_flags(dbp, SvIV(*svp)) ; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + if (svp) + (void)dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ; + + svp = hv_fetch(action, "psize", 5, FALSE); + if (svp) + (void)dbp->set_pagesize(dbp, SvIV(*svp)) ; + + svp = hv_fetch(action, "lorder", 6, FALSE); + if (svp) + (void)dbp->set_lorder(dbp, SvIV(*svp)) ; + + PrintBtree(info) ; + + } + else if (sv_isa(sv, "DB_File::RECNOINFO")) + { + int fixed = FALSE ; + + if (isHASH) + croak("DB_File can only tie an array to a DB_RECNO database"); + + RETVAL->type = DB_RECNO ; + + svp = hv_fetch(action, "flags", 5, FALSE); + if (svp) { + int flags = SvIV(*svp) ; + /* remove FIXDLEN, if present */ + if (flags & DB_FIXEDLEN) { + fixed = TRUE ; + flags &= ~DB_FIXEDLEN ; + } + } + + svp = hv_fetch(action, "cachesize", 9, FALSE); + if (svp) { + status = dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ; + } + + svp = hv_fetch(action, "psize", 5, FALSE); + if (svp) { + status = dbp->set_pagesize(dbp, SvIV(*svp)) ; + } + + svp = hv_fetch(action, "lorder", 6, FALSE); + if (svp) { + status = dbp->set_lorder(dbp, SvIV(*svp)) ; + } + + svp = hv_fetch(action, "bval", 4, FALSE); + if (svp && SvOK(*svp)) + { + int value ; + if (SvPOK(*svp)) + value = (int)*SvPV(*svp, n_a) ; + else + value = SvIV(*svp) ; + + if (fixed) { + status = dbp->set_re_pad(dbp, value) ; + } + else { + status = dbp->set_re_delim(dbp, value) ; + } + + } + + if (fixed) { + svp = hv_fetch(action, "reclen", 6, FALSE); + if (svp) { + u_int32_t len = (u_int32_t)SvIV(*svp) ; + status = dbp->set_re_len(dbp, len) ; + } + } + + if (name != NULL) { + status = dbp->set_re_source(dbp, name) ; + name = NULL ; + } + + svp = hv_fetch(action, "bfname", 6, FALSE); + if (svp && SvOK(*svp)) { + char * ptr = SvPV(*svp,n_a) ; + name = (char*) n_a ? ptr : NULL ; + } + else + name = NULL ; + + + status = dbp->set_flags(dbp, DB_RENUMBER) ; + + if (flags){ + (void)dbp->set_flags(dbp, flags) ; + } + PrintRecno(info) ; + } + else + croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); + } + + { + int Flags = 0 ; + int status ; + + /* Map 1.x flags to 3.x flags */ + if ((flags & O_CREAT) == O_CREAT) + Flags |= DB_CREATE ; + +#if O_RDONLY == 0 + if (flags == O_RDONLY) +#else + if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR) +#endif + Flags |= DB_RDONLY ; + +#ifdef O_TRUNC + if ((flags & O_TRUNC) == O_TRUNC) + Flags |= DB_TRUNCATE ; +#endif + + status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, + Flags, mode) ; + /* printf("open returned %d %s\n", status, db_strerror(status)) ; */ + + if (status == 0) + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, + 0) ; + /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */ + + if (status) + RETVAL->dbp = NULL ; + + } + + return (RETVAL) ; + +#endif /* Berkeley DB Version > 2 */ + +} /* ParseOpenInfo */ + + +static double +#ifdef CAN_PROTOTYPE +constant(char *name, int arg) +#else +constant(name, arg) +char *name; +int arg; +#endif +{ + errno = 0; + switch (*name) { + case 'A': + break; + case 'B': + if (strEQ(name, "BTREEMAGIC")) +#ifdef BTREEMAGIC + return BTREEMAGIC; +#else + goto not_there; +#endif + if (strEQ(name, "BTREEVERSION")) +#ifdef BTREEVERSION + return BTREEVERSION; +#else + goto not_there; +#endif + break; + case 'C': + break; + case 'D': + if (strEQ(name, "DB_LOCK")) +#ifdef DB_LOCK + return DB_LOCK; +#else + goto not_there; +#endif + if (strEQ(name, "DB_SHMEM")) +#ifdef DB_SHMEM + return DB_SHMEM; +#else + goto not_there; +#endif + if (strEQ(name, "DB_TXN")) +#ifdef DB_TXN + return (U32)DB_TXN; +#else + goto not_there; +#endif + break; + case 'E': + break; + case 'F': + break; + case 'G': + break; + case 'H': + if (strEQ(name, "HASHMAGIC")) +#ifdef HASHMAGIC + return HASHMAGIC; +#else + goto not_there; +#endif + if (strEQ(name, "HASHVERSION")) +#ifdef HASHVERSION + return HASHVERSION; +#else + goto not_there; +#endif + break; + case 'I': + break; + case 'J': + break; + case 'K': + break; + case 'L': + break; + case 'M': + if (strEQ(name, "MAX_PAGE_NUMBER")) +#ifdef MAX_PAGE_NUMBER + return (U32)MAX_PAGE_NUMBER; +#else + goto not_there; +#endif + if (strEQ(name, "MAX_PAGE_OFFSET")) +#ifdef MAX_PAGE_OFFSET + return MAX_PAGE_OFFSET; +#else + goto not_there; +#endif + if (strEQ(name, "MAX_REC_NUMBER")) +#ifdef MAX_REC_NUMBER + return (U32)MAX_REC_NUMBER; +#else + goto not_there; +#endif + break; + case 'N': + break; + case 'O': + break; + case 'P': + break; + case 'Q': + break; + case 'R': + if (strEQ(name, "RET_ERROR")) +#ifdef RET_ERROR + return RET_ERROR; +#else + goto not_there; +#endif + if (strEQ(name, "RET_SPECIAL")) +#ifdef RET_SPECIAL + return RET_SPECIAL; +#else + goto not_there; +#endif + if (strEQ(name, "RET_SUCCESS")) +#ifdef RET_SUCCESS + return RET_SUCCESS; +#else + goto not_there; +#endif + if (strEQ(name, "R_CURSOR")) +#ifdef R_CURSOR + return R_CURSOR; +#else + goto not_there; +#endif + if (strEQ(name, "R_DUP")) +#ifdef R_DUP + return R_DUP; +#else + goto not_there; +#endif + if (strEQ(name, "R_FIRST")) +#ifdef R_FIRST + return R_FIRST; +#else + goto not_there; +#endif + if (strEQ(name, "R_FIXEDLEN")) +#ifdef R_FIXEDLEN + return R_FIXEDLEN; +#else + goto not_there; +#endif + if (strEQ(name, "R_IAFTER")) +#ifdef R_IAFTER + return R_IAFTER; +#else + goto not_there; +#endif + if (strEQ(name, "R_IBEFORE")) +#ifdef R_IBEFORE + return R_IBEFORE; +#else + goto not_there; +#endif + if (strEQ(name, "R_LAST")) +#ifdef R_LAST + return R_LAST; +#else + goto not_there; +#endif + if (strEQ(name, "R_NEXT")) +#ifdef R_NEXT + return R_NEXT; +#else + goto not_there; +#endif + if (strEQ(name, "R_NOKEY")) +#ifdef R_NOKEY + return R_NOKEY; +#else + goto not_there; +#endif + if (strEQ(name, "R_NOOVERWRITE")) +#ifdef R_NOOVERWRITE + return R_NOOVERWRITE; +#else + goto not_there; +#endif + if (strEQ(name, "R_PREV")) +#ifdef R_PREV + return R_PREV; +#else + goto not_there; +#endif + if (strEQ(name, "R_RECNOSYNC")) +#ifdef R_RECNOSYNC + return R_RECNOSYNC; +#else + goto not_there; +#endif + if (strEQ(name, "R_SETCURSOR")) +#ifdef R_SETCURSOR + return R_SETCURSOR; +#else + goto not_there; +#endif + if (strEQ(name, "R_SNAPSHOT")) +#ifdef R_SNAPSHOT + return R_SNAPSHOT; +#else + goto not_there; +#endif + break; + case 'S': + break; + case 'T': + break; + case 'U': + break; + case 'V': + break; + case 'W': + break; + case 'X': + break; + case 'Y': + break; + case 'Z': + break; + case '_': + break; + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +MODULE = DB_File PACKAGE = DB_File PREFIX = db_ + +BOOT: + { + __getBerkeleyDBInfo() ; + + DBT_clear(empty) ; + empty.data = &zero ; + empty.size = sizeof(recno_t) ; + } + +double +constant(name,arg) + char * name + int arg + + +DB_File +db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH) + int isHASH + char * dbtype + int flags + int mode + CODE: + { + char * name = (char *) NULL ; + SV * sv = (SV *) NULL ; + STRLEN n_a; + + if (items >= 3 && SvOK(ST(2))) + name = (char*) SvPV(ST(2), n_a) ; + + if (items == 6) + sv = ST(5) ; + + RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ; + if (RETVAL->dbp == NULL) + RETVAL = NULL ; + } + OUTPUT: + RETVAL + +int +db_DESTROY(db) + DB_File db + INIT: + CurrentDB = db ; + CLEANUP: + if (db->hash) + SvREFCNT_dec(db->hash) ; + if (db->compare) + SvREFCNT_dec(db->compare) ; + if (db->prefix) + SvREFCNT_dec(db->prefix) ; +#ifdef DBM_FILTERING + if (db->filter_fetch_key) + SvREFCNT_dec(db->filter_fetch_key) ; + if (db->filter_store_key) + SvREFCNT_dec(db->filter_store_key) ; + if (db->filter_fetch_value) + SvREFCNT_dec(db->filter_fetch_value) ; + if (db->filter_store_value) + SvREFCNT_dec(db->filter_store_value) ; +#endif /* DBM_FILTERING */ + safefree(db) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; +#endif + + +int +db_DELETE(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + INIT: + CurrentDB = db ; + + +int +db_EXISTS(db, key) + DB_File db + DBTKEY key + CODE: + { + DBT value ; + + DBT_clear(value) ; + CurrentDB = db ; + RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ; + } + OUTPUT: + RETVAL + +int +db_FETCH(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + CODE: + { + DBT value ; + + 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) + } + +int +db_STORE(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value + u_int flags + INIT: + CurrentDB = db ; + + +int +db_FIRSTKEY(db) + DB_File db + CODE: + { + DBTKEY key ; + DBT value ; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; + RETVAL = do_SEQ(db, key, value, R_FIRST) ; + ST(0) = sv_newmortal(); + OutputKey(ST(0), key) ; + } + +int +db_NEXTKEY(db, key) + DB_File db + DBTKEY key + CODE: + { + DBT value ; + + DBT_clear(value) ; + CurrentDB = db ; + RETVAL = do_SEQ(db, key, value, R_NEXT) ; + ST(0) = sv_newmortal(); + OutputKey(ST(0), key) ; + } + +# +# These would be nice for RECNO +# + +int +unshift(db, ...) + DB_File db + ALIAS: UNSHIFT = 1 + CODE: + { + DBTKEY key ; + DBT value ; + int i ; + int One ; + DB * Db = db->dbp ; + STRLEN n_a; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; +#ifdef DB_VERSION_MAJOR + /* get the first value */ + RETVAL = do_SEQ(db, key, value, DB_FIRST) ; + RETVAL = 0 ; +#else + RETVAL = -1 ; +#endif + for (i = items-1 ; i > 0 ; --i) + { + value.data = SvPV(ST(i), n_a) ; + value.size = n_a ; + One = 1 ; + key.data = &One ; + key.size = sizeof(int) ; +#ifdef DB_VERSION_MAJOR + RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ; +#else + RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ; +#endif + if (RETVAL != 0) + break; + } + } + OUTPUT: + RETVAL + +I32 +pop(db) + DB_File db + ALIAS: POP = 1 + CODE: + { + DBTKEY key ; + DBT value ; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; + + /* First get the final value */ + RETVAL = do_SEQ(db, key, value, R_LAST) ; + ST(0) = sv_newmortal(); + /* Now delete it */ + if (RETVAL == 0) + { + /* the call to del will trash value, so take a copy now */ + OutputValue(ST(0), value) ; + RETVAL = db_del(db, key, R_CURSOR) ; + if (RETVAL != 0) + sv_setsv(ST(0), &PL_sv_undef); + } + } + +I32 +shift(db) + DB_File db + ALIAS: SHIFT = 1 + CODE: + { + DBT value ; + DBTKEY key ; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; + /* get the first value */ + RETVAL = do_SEQ(db, key, value, R_FIRST) ; + ST(0) = sv_newmortal(); + /* Now delete it */ + if (RETVAL == 0) + { + /* the call to del will trash value, so take a copy now */ + OutputValue(ST(0), value) ; + RETVAL = db_del(db, key, R_CURSOR) ; + if (RETVAL != 0) + sv_setsv (ST(0), &PL_sv_undef) ; + } + } + + +I32 +push(db, ...) + DB_File db + ALIAS: PUSH = 1 + CODE: + { + DBTKEY key ; + DBT value ; + DB * Db = db->dbp ; + int i ; + STRLEN n_a; + int keyval ; + + DBT_flags(key) ; + DBT_flags(value) ; + CurrentDB = db ; + /* Set the Cursor to the Last element */ + RETVAL = do_SEQ(db, key, value, R_LAST) ; +#ifndef DB_VERSION_MAJOR + if (RETVAL >= 0) +#endif + { + if (RETVAL == 0) + keyval = *(int*)key.data ; + else + keyval = 0 ; + for (i = 1 ; i < items ; ++i) + { + value.data = SvPV(ST(i), n_a) ; + value.size = n_a ; + ++ keyval ; + key.data = &keyval ; + key.size = sizeof(int) ; + RETVAL = (Db->put)(Db, TXN &key, &value, 0) ; + if (RETVAL != 0) + break; + } + } + } + OUTPUT: + RETVAL + +I32 +length(db) + DB_File db + ALIAS: FETCHSIZE = 1 + CODE: + CurrentDB = db ; + RETVAL = GetArrayLength(aTHX_ db) ; + OUTPUT: + RETVAL + + +# +# Now provide an interface to the rest of the DB functionality +# + +int +db_del(db, key, flags=0) + DB_File db + DBTKEY key + u_int flags + CODE: + CurrentDB = db ; + RETVAL = db_del(db, key, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + + +int +db_get(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value = NO_INIT + u_int flags + CODE: + CurrentDB = db ; + DBT_clear(value) ; + RETVAL = db_get(db, key, value, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + value + +int +db_put(db, key, value, flags=0) + DB_File db + DBTKEY key + DBT value + u_int flags + CODE: + CurrentDB = db ; + RETVAL = db_put(db, key, value, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_KEYEXIST) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + key if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key); + +int +db_fd(db) + DB_File db + int status = 0 ; + CODE: + CurrentDB = db ; +#ifdef DB_VERSION_MAJOR + RETVAL = -1 ; + status = (db->in_memory + ? -1 + : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ; + if (status != 0) + RETVAL = -1 ; +#else + RETVAL = (db->in_memory + ? -1 + : ((db->dbp)->fd)(db->dbp) ) ; +#endif + OUTPUT: + RETVAL + +int +db_sync(db, flags=0) + DB_File db + u_int flags + CODE: + CurrentDB = db ; + RETVAL = db_sync(db, flags) ; +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; +#endif + OUTPUT: + RETVAL + + +int +db_seq(db, key, value, flags) + DB_File db + DBTKEY key + DBT value = NO_INIT + u_int flags + CODE: + CurrentDB = db ; + DBT_clear(value) ; + RETVAL = db_seq(db, key, value, flags); +#ifdef DB_VERSION_MAJOR + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; +#endif + OUTPUT: + RETVAL + key + value + +#ifdef DBM_FILTERING + +#define setFilter(type) \ + { \ + if (db->type) \ + RETVAL = sv_mortalcopy(db->type) ; \ + ST(0) = RETVAL ; \ + if (db->type && (code == &PL_sv_undef)) { \ + SvREFCNT_dec(db->type) ; \ + db->type = NULL ; \ + } \ + else if (code) { \ + if (db->type) \ + sv_setsv(db->type, code) ; \ + else \ + db->type = newSVsv(code) ; \ + } \ + } + + +SV * +filter_fetch_key(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_key) ; + +SV * +filter_store_key(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_key) ; + +SV * +filter_fetch_value(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_value) ; + +SV * +filter_store_value(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_value) ; + +#endif /* DBM_FILTERING */ diff --git a/bdb/perl.DB_File/DB_File_BS b/bdb/perl.DB_File/DB_File_BS new file mode 100644 index 00000000000..9282c498811 --- /dev/null +++ b/bdb/perl.DB_File/DB_File_BS @@ -0,0 +1,6 @@ +# NeXT needs /usr/lib/libposix.a to load along with DB_File.so +if ( $dlsrc eq "dl_next.xs" ) { + @DynaLoader::dl_resolve_using = ( '/usr/lib/libposix.a' ); +} + +1; diff --git a/bdb/perl.DB_File/MANIFEST b/bdb/perl.DB_File/MANIFEST new file mode 100644 index 00000000000..0cc30dbfb47 --- /dev/null +++ b/bdb/perl.DB_File/MANIFEST @@ -0,0 +1,27 @@ +Makefile.PL +DB_File.pm +DB_File.xs +DB_File_BS +Changes +config.in +dbinfo +hints/dynixptx.pl +hints/sco.pl +MANIFEST +README +typemap +t/db-btree.t +t/db-hash.t +t/db-recno.t +version.c +patches/5.004 +patches/5.004_01 +patches/5.004_02 +patches/5.004_03 +patches/5.004_04 +patches/5.004_05 +patches/5.005 +patches/5.005_01 +patches/5.005_02 +patches/5.005_03 +patches/5.6.0 diff --git a/bdb/perl.DB_File/Makefile.PL b/bdb/perl.DB_File/Makefile.PL new file mode 100644 index 00000000000..25e707df6ea --- /dev/null +++ b/bdb/perl.DB_File/Makefile.PL @@ -0,0 +1,187 @@ +#! perl -w +use strict ; +use ExtUtils::MakeMaker 5.16 ; +use Config ; + +my $VER_INFO ; +my $LIB_DIR ; +my $INC_DIR ; +my $DB_NAME ; +my $LIBS ; +my $COMPAT185 = "" ; + +my @files = ('DB_File.pm', glob "t/*.t") ; +# See if warnings is available +eval 'use warnings;'; +if ($@) { + # not there, so write a dummy warnings.pm + oldWarnings(@files) ; +} else { + # is there, + newWarnings(@files) ; +} + +ParseCONFIG() ; + +if (defined $DB_NAME) + { $LIBS = $DB_NAME } +else { + if ($^O eq 'MSWin32') + { $LIBS = '-llibdb' } + else + { $LIBS = '-ldb' } +} + +# Solaris is special. +#$LIBS .= " -lthread" if $^O eq 'solaris' ; + +# OS2 is a special case, so check for it now. +my $OS2 = "" ; +$OS2 = "-DOS2" if $Config{'osname'} eq 'os2' ; + +WriteMakefile( + NAME => 'DB_File', + LIBS => ["-L${LIB_DIR} $LIBS"], + MAN3PODS => ' ', # Pods will be built by installman. + INC => "-I$INC_DIR", + VERSION_FROM => 'DB_File.pm', + XSPROTOARG => '-noprototypes', + DEFINE => "$OS2 $VER_INFO $COMPAT185", + OBJECT => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)', + OPTIMIZE => '-g', + 'macro' => { INSTALLDIRS => 'perl' }, + 'dist' => {COMPRESS=>'gzip', SUFFIX=>'gz'}, + ); + + +sub MY::postamble { + ' +version$(OBJ_EXT): version.c + +$(NAME).xs: typemap + @$(TOUCH) $(NAME).xs + +Makefile: config.in + +' ; +} + + +sub ParseCONFIG +{ + my ($k, $v) ; + my @badkey = () ; + my %Info = () ; + my @Options = qw( INCLUDE LIB PREFIX HASH DBNAME COMPAT185 ) ; + my %ValidOption = map {$_, 1} @Options ; + my %Parsed = %ValidOption ; + my $CONFIG = 'config.in' ; + + print "Parsing $CONFIG...\n" ; + + # DBNAME & COMPAT185 are optional, so pretend they have + # been parsed. + delete $Parsed{'DBNAME'} ; + delete $Parsed{'COMPAT185'} ; + $Info{COMPAT185} = "No" ; + + + open(F, "$CONFIG") or die "Cannot open file $CONFIG: $!\n" ; + while (<F>) { + s/^\s*|\s*$//g ; + next if /^\s*$/ or /^\s*#/ ; + s/\s*#\s*$// ; + + ($k, $v) = split(/\s+=\s+/, $_, 2) ; + $k = uc $k ; + if ($ValidOption{$k}) { + delete $Parsed{$k} ; + $Info{$k} = $v ; + } + else { + push(@badkey, $k) ; + } + } + close F ; + + print "Unknown keys in $CONFIG ignored [@badkey]\n" + if @badkey ; + + # check parsed values + my @missing = () ; + die "The following keys are missing from $CONFIG file: [@missing]\n" + if @missing = keys %Parsed ; + + $INC_DIR = $ENV{'DB_FILE_INCLUDE'} || $Info{'INCLUDE'} ; + $LIB_DIR = $ENV{'DB_FILE_LIB'} || $Info{'LIB'} ; + $DB_NAME = $Info{'DBNAME'} if defined $Info{'DBNAME'} ; + $COMPAT185 = "-DCOMPAT185 -DDB_LIBRARY_COMPATIBILITY_API" + if (defined $ENV{'DB_FILE_COMPAT185'} && + $ENV{'DB_FILE_COMPAT185'} =~ /^\s*(on|true|1)\s*$/i) || + $Info{'COMPAT185'} =~ /^\s*(on|true|1)\s*$/i ; + my $PREFIX = $Info{'PREFIX'} ; + my $HASH = $Info{'HASH'} ; + + $VER_INFO = "-DmDB_Prefix_t=${PREFIX} -DmDB_Hash_t=${HASH}" ; + + print <<EOM if 0 ; + INCLUDE [$INC_DIR] + LIB [$LIB_DIR] + HASH [$HASH] + PREFIX [$PREFIX] + DBNAME [$DB_NAME] + +EOM + + print "Looks Good.\n" ; + +} + +sub oldWarnings +{ + local ($^I) = ".bak" ; + local (@ARGV) = @_ ; + + while (<>) + { + if (/^__END__/) + { + print ; + my $this = $ARGV ; + while (<>) + { + last if $ARGV ne $this ; + print ; + } + } + + s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ; + s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ; + print ; + } +} + +sub newWarnings +{ + local ($^I) = ".bak" ; + local (@ARGV) = @_ ; + + while (<>) + { + if (/^__END__/) + { + my $this = $ARGV ; + print ; + while (<>) + { + last if $ARGV ne $this ; + print ; + } + } + + s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ; + print ; + } +} + +# end of file Makefile.PL diff --git a/bdb/perl.DB_File/README b/bdb/perl.DB_File/README new file mode 100644 index 00000000000..e780111b2e9 --- /dev/null +++ b/bdb/perl.DB_File/README @@ -0,0 +1,396 @@ + DB_File + + Version 1.76 + + 15th January 2001 + + Copyright (c) 1995-2001 Paul Marquess. All rights reserved. This + program is free software; you can redistribute it and/or modify + it under the same terms as Perl itself. + + +IMPORTANT NOTICE +================ + +If are using the locking technique described in older versions of +DB_File, please read the section called "Locking: The Trouble with fd" +in DB_File.pm immediately. The locking method has been found to be +unsafe. You risk corrupting your data if you continue to use it. + +DESCRIPTION +----------- + +DB_File is a module which allows Perl programs to make use of the +facilities provided by Berkeley DB version 1. (DB_File can be built +version 2 or 3 of Berkeley DB, but it will only support the 1.x +features), + +If you want to make use of the new features available in Berkeley DB +2.x or 3.x, use the Perl module BerkeleyDB instead. + +Berkeley DB is a C library which provides a consistent interface to a +number of database formats. DB_File provides an interface to all three +of the database types (hash, btree and recno) currently supported by +Berkeley DB. + +For further details see the documentation included at the end of the +file DB_File.pm. + +PREREQUISITES +------------- + +Before you can build DB_File you must have the following installed on +your system: + + * Perl 5.004 or greater. + + * Berkeley DB. + + The official web site for Berkeley DB is http://www.sleepycat.com. + The latest version of Berkeley DB is always available there. It + is recommended that you use the most recent version available at + the Sleepycat site. + + The one exception to this advice is where you want to use DB_File + to access database files created by a third-party application, like + Sendmail or Netscape. In these cases you must build DB_File with a + compatible version of Berkeley DB. + + If you want to use Berkeley DB 2.x, you must have version 2.3.4 + or greater. If you want to use Berkeley DB 3.x, any version will + do. For Berkeley DB 1.x, use either version 1.85 or 1.86. + + +BUILDING THE MODULE +------------------- + +Assuming you have met all the prerequisites, building the module should +be relatively straightforward. + +Step 1 : If you are running either Solaris 2.5 or HP-UX 10 and want + to use Berkeley DB version 2 or 3, read either the Solaris Notes + or HP-UX Notes sections below. If you are running Linux please + read the Linux Notes section before proceeding. + +Step 2 : Edit the file config.in to suit you local installation. + Instructions are given in the file. + +Step 3 : Build and test the module using this sequence of commands: + + perl Makefile.PL + make + make test + + + NOTE: + If you have a very old version of Berkeley DB (i.e. pre 1.85), + three of the tests in the recno test harness may fail (tests 51, + 53 and 55). You can safely ignore the errors if you're never + going to use the broken functionality (recno databases with a + modified bval). Otherwise you'll have to upgrade your DB + library. + + +INSTALLATION +------------ + + make install + + +TROUBLESHOOTING +=============== + +Here are some of the common problems people encounter when building +DB_File. + +Missing db.h or libdb.a +----------------------- + +If you get an error like this: + + cc -c -I/usr/local/include -Dbool=char -DHAS_BOOL + -O2 -DVERSION=\"1.64\" -DXS_VERSION=\"1.64\" -fpic + -I/usr/local/lib/perl5/i586-linux/5.00404/CORE -DmDB_Prefix_t=size_t + -DmDB_Hash_t=u_int32_t DB_File.c + DB_File.xs:101: db.h: No such file or directory + +or this: + + LD_RUN_PATH="/lib" cc -o blib/arch/auto/DB_File/DB_File.so -shared + -L/usr/local/lib DB_File.o -L/usr/local/lib -ldb + ld: cannot open -ldb: No such file or directory + +This symptom can imply: + + 1. You don't have Berkeley DB installed on your system at all. + Solution: get & install Berkeley DB. + + 2. You do have Berkeley DB installed, but it isn't in a standard place. + Solution: Edit config.in and set the LIB and INCLUDE variables to point + to the directories where libdb.a and db.h are installed. + + +Undefined symbol db_version +--------------------------- + +DB_File seems to have built correctly, but you get an error like this +when you run the test harness: + + $ make test + PERL_DL_NONLAZY=1 /usr/bin/perl5.00404 -I./blib/arch -I./blib/lib + -I/usr/local/lib/perl5/i586-linux/5.00404 -I/usr/local/lib/perl5 -e 'use + Test::Harness qw(&runtests $verbose); $verbose=0; runtests @ARGV;' t/*.t + t/db-btree..........Can't load './blib/arch/auto/DB_File/DB_File.so' for + module DB_File: ./blib/arch/auto/DB_File/DB_File.so: undefined symbol: + db_version at /usr/local/lib/perl5/i586-linux/5.00404/DynaLoader.pm + line 166. + + at t/db-btree.t line 21 + BEGIN failed--compilation aborted at t/db-btree.t line 21. + dubious Test returned status 2 (wstat 512, 0x200) + +This error usually happens when you have both version 1 and version +2 of Berkeley DB installed on your system and DB_File attempts to +build using the db.h for Berkeley DB version 2 and the version 1 +library. Unfortunately the two versions aren't compatible with each +other. The undefined symbol error is actually caused because Berkeley +DB version 1 doesn't have the symbol db_version. + +Solution: Setting the LIB & INCLUDE variables in config.in to point to the + correct directories can sometimes be enough to fix this + problem. If that doesn't work the easiest way to fix the + problem is to either delete or temporarily rename the copies + of db.h and libdb.a that you don't want DB_File to use. + +Incompatible versions of db.h and libdb +--------------------------------------- + +BerkeleyDB seems to have built correctly, but you get an error like this +when you run the test harness: + + $ make test + PERL_DL_NONLAZY=1 /home/paul/perl/install/bin/perl5.00560 -Iblib/arch + -Iblib/lib -I/home/paul/perl/install/5.005_60/lib/5.00560/i586-linux + -I/home/paul/perl/install/5.005_60/lib/5.00560 -e 'use Test::Harness + qw(&runtests $verbose); $verbose=0; runtests @ARGV;' t/*.t + t/db-btree.......... + DB_File needs compatible versions of libdb & db.h + you have db.h version 2.3.7 and libdb version 2.7.5 + BEGIN failed--compilation aborted at t/db-btree.t line 21. + ... + +Another variation on the theme of having two versions of Berkeley DB on +your system. + +Solution: Setting the LIB & INCLUDE variables in config.in to point to the + correct directories can sometimes be enough to fix this + problem. If that doesn't work the easiest way to fix the + problem is to either delete or temporarily rename the copies + of db.h and libdb.a that you don't want BerkeleyDB to use. + If you are running Linux, please read the Linux Notes section + below. + + +Linux Notes +----------- + +Newer versions of Linux (e.g. RedHat 6, SuSe 6) ship with a C library +that has version 2.x of Berkeley DB linked into it. This makes it +difficult to build this module with anything other than the version of +Berkeley DB that shipped with your Linux release. If you do try to use +a different version of Berkeley DB you will most likely get the error +described in the "Incompatible versions of db.h and libdb" section of +this file. + +To make matters worse, prior to Perl 5.6.1, the perl binary itself +*always* included the Berkeley DB library. + +If you want to use a newer version of Berkeley DB with this module, the +easiest solution is to use Perl 5.6.1 (or better) and Berkeley DB 3.x +(or better). + +There are two approaches you can use to get older versions of Perl to +work with specific versions of Berkeley DB. Both have their advantages +and disadvantages. + +The first approach will only work when you want to build a version of +Perl older than 5.6.1 along with Berkeley DB 3.x. If you want to use +Berkeley DB 2.x, you must use the next approach. This approach involves +rebuilding your existing version of Perl after applying an unofficial +patch. The "patches" directory in the this module's source distribution +contains a number of patch files. There is one patch file for every +stable version of Perl since 5.004. Apply the appropriate patch to your +Perl source tree before re-building and installing Perl from scratch. +For example, assuming you are in the top-level source directory for +Perl 5.6.0, the command below will apply the necessary patch. Remember +to replace the path shown below with one that points to this module's +patches directory. + + patch -p1 -N </path/to/DB_File/patches/5.6.0 + +Now rebuild & install perl. You should now have a perl binary that can +be used to build this module. Follow the instructions in "BUILDING THE +MODULE", remembering to set the INCLUDE and LIB variables in config.in. + + +The second approach will work with both Berkeley DB 2.x and 3.x. +Start by building Berkeley DB as a shared library. This is from +the Berkeley DB build instructions: + + Building Shared Libraries for the GNU GCC compiler + + If you're using gcc and there's no better shared library example for + your architecture, the following shared library build procedure will + probably work. + + Add the -fpic option to the CFLAGS value in the Makefile. + + Rebuild all of your .o files. This will create a Berkeley DB library + that contains .o files with PIC code. To build the shared library, + then take the following steps in the library build directory: + + % mkdir tmp + % cd tmp + % ar xv ../libdb.a + % gcc -shared -o libdb.so *.o + % mv libdb.so .. + % cd .. + % rm -rf tmp + + Note, you may have to change the gcc line depending on the + requirements of your system. + + The file libdb.so is your shared library + +Once you have built libdb.so, you will need to store it somewhere safe. + + cp libdb.so /usr/local/BerkeleyDB/lib + +If you now set the LD_PRELOAD environment variable to point to this +shared library, Perl will use it instead of the version of Berkeley DB +that shipped with your Linux distribution. + + export LD_PRELOAD=/usr/local/BerkeleyDB/lib/libdb.so + +Finally follow the instructions in "BUILDING THE MODULE" to build, +test and install this module. Don't forget to set the INCLUDE and LIB +variables in config.in. + +Remember, you will need to have the LD_PRELOAD variable set anytime you +want to use Perl with Berkeley DB. Also note that if you have LD_PRELOAD +permanently set it will affect ALL commands you execute. This may be a +problem if you run any commands that access a database created by the +version of Berkeley DB that shipped with your Linux distribution. + + +Solaris Notes +------------- + +If you are running Solaris 2.5, and you get this error when you run the +DB_File test harness: + + libc internal error: _rmutex_unlock: rmutex not held. + +you probably need to install a Sun patch. It has been reported that +Sun patch 103187-25 (or later revisions) fixes this problem. + +To find out if you have the patch installed, the command "showrev -p" +will display the patches that are currently installed on your system. + + +HP-UX Notes +----------- + +Some people running HP-UX 10 have reported getting an error like this +when building DB_File with the native HP-UX compiler. + + ld: (Warning) At least one PA 2.0 object file (DB_File.o) was detected. + The linked output may not run on a PA 1.x system. + ld: Invalid loader fixup for symbol "$000000A5". + +If this is the case for you, Berkeley DB needs to be recompiled with +the +z or +Z option and the resulting library placed in a .sl file. The +following steps should do the trick: + + 1: Configure the Berkeley DB distribution with the +z or +Z C compiler + flag: + + env "CFLAGS=+z" ../dist/configure ... + + 2: Edit the Berkeley DB Makefile and change: + + "libdb= libdb.a" to "libdb= libdb.sl". + + + 3: Build and install the Berkeley DB distribution as usual. + + +IRIX NOTES +---------- + +If you are running IRIX, and want to use Berkeley DB version 1, you can +get it from http://reality.sgi.com/ariel. It has the patches necessary +to compile properly on IRIX 5.3. + + +FEEDBACK +======== + +How to report a problem with DB_File. + +To help me help you, I need the following information: + + 1. The version of Perl and the operating system name and version you + are running. The *complete* output from running "perl -V" will + tell me all I need to know. Don't edit the output in any way. Note, + I want you to run "perl -V" and NOT "perl -v". + + If your perl does not understand the "-V" option it is too old. DB_File + needs Perl version 5.004 or better. + + 2. The version of DB_File you have. + If you have successfully installed DB_File, this one-liner will + tell you: + + perl -e 'use DB_File; print "DB_File ver $DB_File::VERSION\n"' + + If you haven't installed DB_File then search DB_File.pm for a line + like this: + + $VERSION = "1.20" ; + + 3. The version of Berkeley DB you are using. + If you are using a version older than 1.85, think about upgrading. One + point to note if you are considering upgrading Berkeley DB - the + file formats for 1.85, 1.86, 2.0, 3.0 & 3.1 are all different. + + If you have successfully installed DB_File, this command will display + the version of Berkeley DB it was built with: + + perl -e 'use DB_File; print "Berkeley DB ver $DB_File::db_ver\n"' + + 4. If you are having problems building DB_File, send me a complete log + of what happened. + + 5. Now the difficult one. If you think you have found a bug in DB_File + and you want me to fix it, you will *greatly* enhance the chances + of me being able to track it down by sending me a small + self-contained Perl script that illustrates the problem you are + encountering. Include a summary of what you think the problem is + and a log of what happens when you run the script, in case I can't + reproduce your problem on my system. If possible, don't have the + script dependent on an existing 20Meg database. If the script you + send me can create the database itself then that is preferred. + + I realise that in some cases this is easier said than done, so if + you can only reproduce the problem in your existing script, then + you can post me that if you want. Just don't expect me to find your + problem in a hurry, or at all. :-) + + +CHANGES +------- + +See the Changes file. + +Paul Marquess <Paul.Marquess@btinternet.com> diff --git a/bdb/perl.DB_File/config.in b/bdb/perl.DB_File/config.in new file mode 100644 index 00000000000..5bda4a66762 --- /dev/null +++ b/bdb/perl.DB_File/config.in @@ -0,0 +1,99 @@ +# Filename: config.in +# +# written by Paul Marquess <Paul.Marquess@btinternet.com> +# last modified 9th Sept 1997 +# version 1.55 + +# 1. Where is the file db.h? +# +# Change the path below to point to the directory where db.h is +# installed on your system. + +#INCLUDE = /usr/local/include +#INCLUDE = /usr/local/BerkeleyDB/include +#INCLUDE = /usr/include +INCLUDE = ./libraries/3.2.7 + +# 2. Where is libdb? +# +# Change the path below to point to the directory where libdb is +# installed on your system. + +#LIB = /usr/local/lib +#LIB = /usr/local/BerkeleyDB/lib +#LIB = /usr/lib +LIB = ./libraries/3.2.7 + +# 3. What version of Berkely DB have you got? +# +# If you have version 2.0 or greater, you can skip this question. +# +# If you have Berkeley DB 1.78 or greater you shouldn't have to +# change the definitions for PREFIX and HASH below. +# +# For older versions of Berkeley DB change both PREFIX and HASH to int. +# Version 1.71, 1.72 and 1.73 are known to need this change. +# +# If you don't know what version you have have a look in the file db.h. +# +# Search for the string "DB_VERSION_MAJOR". If it is present, you +# have Berkeley DB version 2 (or greater). +# +# If that didn't work, find the definition of the BTREEINFO typedef. +# Check the return type from the prefix element. It should look like +# this in an older copy of db.h: +# +# int (*prefix) __P((const DBT *, const DBT *)); +# +# and like this in a more recent copy: +# +# size_t (*prefix) /* prefix function */ +# __P((const DBT *, const DBT *)); +# +# Change the definition of PREFIX, below, to reflect the return type +# of the prefix function in your db.h. +# +# Now find the definition of the HASHINFO typedef. Check the return +# type of the hash element. Older versions look like this: +# +# int (*hash) __P((const void *, size_t)); +# +# newer like this: +# +# u_int32_t /* hash function */ +# (*hash) __P((const void *, size_t)); +# +# Change the definition of HASH, below, to reflect the return type of +# the hash function in your db.h. +# + +PREFIX = size_t +HASH = u_int32_t + +# 4. Is the library called libdb? +# +# If you have copies of both 1.x and 2.x Berkeley DB installed on +# your system it can sometimes be tricky to make sure you are using +# the correct one. Renaming one (or creating a symbolic link) to +# include the version number of the library can help. +# +# For example, if you have both Berkeley DB 2.3.12 and 1.85 on your +# system and you want to use the Berkeley DB version 2 library you +# could rename the version 2 library from libdb.a to libdb-2.3.12.a and +# change the DBNAME line below to look like this: +# +# DBNAME = -ldb-2.3.12 +# +# That will ensure you are linking the correct version of the DB +# library. +# +# Note: If you are building this module with Win32, -llibdb will be +# used by default. +# +# If you have changed the name of the library, uncomment the line +# below (by removing the leading #) and edit the line to use the name +# you have picked. + +#DBNAME = -ldb-2.4.10 + +# end of file config.in diff --git a/bdb/perl.DB_File/dbinfo b/bdb/perl.DB_File/dbinfo new file mode 100644 index 00000000000..5a4df15907e --- /dev/null +++ b/bdb/perl.DB_File/dbinfo @@ -0,0 +1,109 @@ +#!/usr/local/bin/perl + +# Name: dbinfo -- identify berkeley DB version used to create +# a database file +# +# Author: Paul Marquess <Paul.Marquess@btinternet.com> +# Version: 1.03 +# Date 17th September 2000 +# +# Copyright (c) 1998-2000 Paul Marquess. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +# Todo: Print more stats on a db file, e.g. no of records +# add log/txn/lock files + +use strict ; + +my %Data = + ( + 0x053162 => { + Type => "Btree", + Versions => + { + 1 => "Unknown (older than 1.71)", + 2 => "Unknown (older than 1.71)", + 3 => "1.71 -> 1.85, 1.86", + 4 => "Unknown", + 5 => "2.0.0 -> 2.3.0", + 6 => "2.3.1 -> 2.7.7", + 7 => "3.0.x", + 8 => "3.1.x or greater", + } + }, + 0x061561 => { + Type => "Hash", + Versions => + { + 1 => "Unknown (older than 1.71)", + 2 => "1.71 -> 1.85", + 3 => "1.86", + 4 => "2.0.0 -> 2.1.0", + 5 => "2.2.6 -> 2.7.7", + 6 => "3.0.x", + 7 => "3.1.x or greater", + } + }, + 0x042253 => { + Type => "Queue", + Versions => + { + 1 => "3.0.x", + 2 => "3.1.x", + 3 => "3.2.x or greater", + } + }, + ) ; + +die "Usage: dbinfo file\n" unless @ARGV == 1 ; + +print "testing file $ARGV[0]...\n\n" ; +open (F, "<$ARGV[0]") or die "Cannot open file $ARGV[0]: $!\n" ; + +my $buff ; +read F, $buff, 20 ; + +my (@info) = unpack("NNNNN", $buff) ; +my (@info1) = unpack("VVVVV", $buff) ; +my ($magic, $version, $endian) ; + +if ($Data{$info[0]}) # first try DB 1.x format +{ + $magic = $info[0] ; + $version = $info[1] ; + $endian = "Unknown" ; +} +elsif ($Data{$info[3]}) # next DB 2.x big endian +{ + $magic = $info[3] ; + $version = $info[4] ; + $endian = "Big Endian" ; +} +elsif ($Data{$info1[3]}) # next DB 2.x little endian +{ + $magic = $info1[3] ; + $version = $info1[4] ; + $endian = "Little Endian" ; +} +else + { die "not a Berkeley DB database file.\n" } + +my $type = $Data{$magic} ; +$magic = sprintf "%06X", $magic ; + +my $ver_string = "Unknown" ; +$ver_string = $type->{Versions}{$version} + if defined $type->{Versions}{$version} ; + +print <<EOM ; +File Type: Berkeley DB $type->{Type} file. +File Version ID: $version +Built with Berkeley DB: $ver_string +Byte Order: $endian +Magic: $magic +EOM + +close F ; + +exit ; diff --git a/bdb/perl.DB_File/hints/dynixptx.pl b/bdb/perl.DB_File/hints/dynixptx.pl new file mode 100644 index 00000000000..bb5ffa56e6b --- /dev/null +++ b/bdb/perl.DB_File/hints/dynixptx.pl @@ -0,0 +1,3 @@ +# Need to add an extra '-lc' to the end to work around a DYNIX/ptx bug + +$self->{LIBS} = ['-lm -lc']; diff --git a/bdb/perl.DB_File/hints/sco.pl b/bdb/perl.DB_File/hints/sco.pl new file mode 100644 index 00000000000..ff604409496 --- /dev/null +++ b/bdb/perl.DB_File/hints/sco.pl @@ -0,0 +1,2 @@ +# osr5 needs to explicitly link against libc to pull in some static symbols +$self->{LIBS} = ['-ldb -lc'] if $Config{'osvers'} =~ '3\.2v5\.0\..' ; diff --git a/bdb/perl.DB_File/patches/5.004 b/bdb/perl.DB_File/patches/5.004 new file mode 100644 index 00000000000..143ec95afbc --- /dev/null +++ b/bdb/perl.DB_File/patches/5.004 @@ -0,0 +1,44 @@ +diff perl5.004.orig/Configure perl5.004/Configure +190a191 +> perllibs='' +9904a9906,9913 +> : Remove libraries needed only for extensions +> : The appropriate ext/Foo/Makefile.PL will add them back in, if +> : necessary. +> set X `echo " $libs " | +> sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` +> shift +> perllibs="$*" +> +10372a10382 +> perllibs='$perllibs' +diff perl5.004.orig/Makefile.SH perl5.004/Makefile.SH +122c122 +< libs = $libs $cryptlib +--- +> libs = $perllibs $cryptlib +Common subdirectories: perl5.004.orig/Porting and perl5.004/Porting +Common subdirectories: perl5.004.orig/cygwin32 and perl5.004/cygwin32 +Common subdirectories: perl5.004.orig/eg and perl5.004/eg +Common subdirectories: perl5.004.orig/emacs and perl5.004/emacs +Common subdirectories: perl5.004.orig/ext and perl5.004/ext +Common subdirectories: perl5.004.orig/h2pl and perl5.004/h2pl +Common subdirectories: perl5.004.orig/hints and perl5.004/hints +Common subdirectories: perl5.004.orig/lib and perl5.004/lib +diff perl5.004.orig/myconfig perl5.004/myconfig +38c38 +< libs=$libs +--- +> libs=$perllibs +Common subdirectories: perl5.004.orig/os2 and perl5.004/os2 +diff perl5.004.orig/patchlevel.h perl5.004/patchlevel.h +40a41 +> ,"NODB-1.0 - remove -ldb from core perl binary." +Common subdirectories: perl5.004.orig/plan9 and perl5.004/plan9 +Common subdirectories: perl5.004.orig/pod and perl5.004/pod +Common subdirectories: perl5.004.orig/qnx and perl5.004/qnx +Common subdirectories: perl5.004.orig/t and perl5.004/t +Common subdirectories: perl5.004.orig/utils and perl5.004/utils +Common subdirectories: perl5.004.orig/vms and perl5.004/vms +Common subdirectories: perl5.004.orig/win32 and perl5.004/win32 +Common subdirectories: perl5.004.orig/x2p and perl5.004/x2p diff --git a/bdb/perl.DB_File/patches/5.004_01 b/bdb/perl.DB_File/patches/5.004_01 new file mode 100644 index 00000000000..1b05eb4e02b --- /dev/null +++ b/bdb/perl.DB_File/patches/5.004_01 @@ -0,0 +1,217 @@ +diff -rc perl5.004_01.orig/Configure perl5.004_01/Configure +*** perl5.004_01.orig/Configure Wed Jun 11 00:28:03 1997 +--- perl5.004_01/Configure Sun Nov 12 22:12:35 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9907,9912 **** +--- 9908,9921 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10375,10380 **** +--- 10384,10390 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_01.orig/Makefile.SH perl5.004_01/Makefile.SH +*** perl5.004_01.orig/Makefile.SH Thu Jun 12 23:27:56 1997 +--- perl5.004_01/Makefile.SH Sun Nov 12 22:12:35 2000 +*************** +*** 126,132 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 126,132 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_01.orig/lib/ExtUtils/Embed.pm perl5.004_01/lib/ExtUtils/Embed.pm +*** perl5.004_01.orig/lib/ExtUtils/Embed.pm Wed Apr 2 22:12:04 1997 +--- perl5.004_01/lib/ExtUtils/Embed.pm Sun Nov 12 22:12:35 2000 +*************** +*** 170,176 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 170,176 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_01.orig/lib/ExtUtils/Liblist.pm perl5.004_01/lib/ExtUtils/Liblist.pm +*** perl5.004_01.orig/lib/ExtUtils/Liblist.pm Sat Jun 7 01:19:44 1997 +--- perl5.004_01/lib/ExtUtils/Liblist.pm Sun Nov 12 22:13:27 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $Verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $Verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 186,196 **** + my($self, $potential_libs, $Verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 186,196 ---- + my($self, $potential_libs, $Verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{perllibs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 540,546 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 540,546 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_01.orig/lib/ExtUtils/MM_Unix.pm perl5.004_01/lib/ExtUtils/MM_Unix.pm +*** perl5.004_01.orig/lib/ExtUtils/MM_Unix.pm Thu Jun 12 22:06:18 1997 +--- perl5.004_01/lib/ExtUtils/MM_Unix.pm Sun Nov 12 22:12:35 2000 +*************** +*** 2137,2143 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2137,2143 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_01.orig/myconfig perl5.004_01/myconfig +*** perl5.004_01.orig/myconfig Sat Dec 21 01:13:20 1996 +--- perl5.004_01/myconfig Sun Nov 12 22:12:35 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_01.orig/patchlevel.h perl5.004_01/patchlevel.h +*** perl5.004_01.orig/patchlevel.h Wed Jun 11 03:06:10 1997 +--- perl5.004_01/patchlevel.h Sun Nov 12 22:12:35 2000 +*************** +*** 38,43 **** +--- 38,44 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl.DB_File/patches/5.004_02 b/bdb/perl.DB_File/patches/5.004_02 new file mode 100644 index 00000000000..238f8737941 --- /dev/null +++ b/bdb/perl.DB_File/patches/5.004_02 @@ -0,0 +1,217 @@ +diff -rc perl5.004_02.orig/Configure perl5.004_02/Configure +*** perl5.004_02.orig/Configure Thu Aug 7 15:08:44 1997 +--- perl5.004_02/Configure Sun Nov 12 22:06:24 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9911,9916 **** +--- 9912,9925 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10379,10384 **** +--- 10388,10394 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_02.orig/Makefile.SH perl5.004_02/Makefile.SH +*** perl5.004_02.orig/Makefile.SH Thu Aug 7 13:10:53 1997 +--- perl5.004_02/Makefile.SH Sun Nov 12 22:06:24 2000 +*************** +*** 126,132 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 126,132 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_02.orig/lib/ExtUtils/Embed.pm perl5.004_02/lib/ExtUtils/Embed.pm +*** perl5.004_02.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_02/lib/ExtUtils/Embed.pm Sun Nov 12 22:06:24 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_02.orig/lib/ExtUtils/Liblist.pm perl5.004_02/lib/ExtUtils/Liblist.pm +*** perl5.004_02.orig/lib/ExtUtils/Liblist.pm Fri Aug 1 19:36:58 1997 +--- perl5.004_02/lib/ExtUtils/Liblist.pm Sun Nov 12 22:06:24 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 186,196 **** + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 186,196 ---- + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{perllibs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 540,546 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 540,546 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_02.orig/lib/ExtUtils/MM_Unix.pm perl5.004_02/lib/ExtUtils/MM_Unix.pm +*** perl5.004_02.orig/lib/ExtUtils/MM_Unix.pm Tue Aug 5 14:28:08 1997 +--- perl5.004_02/lib/ExtUtils/MM_Unix.pm Sun Nov 12 22:06:25 2000 +*************** +*** 2224,2230 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2224,2230 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_02.orig/myconfig perl5.004_02/myconfig +*** perl5.004_02.orig/myconfig Sat Dec 21 01:13:20 1996 +--- perl5.004_02/myconfig Sun Nov 12 22:06:25 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_02.orig/patchlevel.h perl5.004_02/patchlevel.h +*** perl5.004_02.orig/patchlevel.h Fri Aug 1 15:07:34 1997 +--- perl5.004_02/patchlevel.h Sun Nov 12 22:06:25 2000 +*************** +*** 38,43 **** +--- 38,44 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl.DB_File/patches/5.004_03 b/bdb/perl.DB_File/patches/5.004_03 new file mode 100644 index 00000000000..06331eac922 --- /dev/null +++ b/bdb/perl.DB_File/patches/5.004_03 @@ -0,0 +1,223 @@ +diff -rc perl5.004_03.orig/Configure perl5.004_03/Configure +*** perl5.004_03.orig/Configure Wed Aug 13 16:09:46 1997 +--- perl5.004_03/Configure Sun Nov 12 21:56:18 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9911,9916 **** +--- 9912,9925 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10379,10384 **** +--- 10388,10394 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +Only in perl5.004_03: Configure.orig +diff -rc perl5.004_03.orig/Makefile.SH perl5.004_03/Makefile.SH +*** perl5.004_03.orig/Makefile.SH Mon Aug 18 19:24:29 1997 +--- perl5.004_03/Makefile.SH Sun Nov 12 21:56:18 2000 +*************** +*** 126,132 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 126,132 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +Only in perl5.004_03: Makefile.SH.orig +diff -rc perl5.004_03.orig/lib/ExtUtils/Embed.pm perl5.004_03/lib/ExtUtils/Embed.pm +*** perl5.004_03.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_03/lib/ExtUtils/Embed.pm Sun Nov 12 21:56:18 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_03.orig/lib/ExtUtils/Liblist.pm perl5.004_03/lib/ExtUtils/Liblist.pm +*** perl5.004_03.orig/lib/ExtUtils/Liblist.pm Fri Aug 1 19:36:58 1997 +--- perl5.004_03/lib/ExtUtils/Liblist.pm Sun Nov 12 21:57:17 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + print STDOUT "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 186,196 **** + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{libs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 186,196 ---- + my($self, $potential_libs, $verbose) = @_; + + # If user did not supply a list, we punt. +! # (caller should probably use the list in $Config{perllibs}) + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 540,546 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 540,546 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +Only in perl5.004_03/lib/ExtUtils: Liblist.pm.orig +Only in perl5.004_03/lib/ExtUtils: Liblist.pm.rej +diff -rc perl5.004_03.orig/lib/ExtUtils/MM_Unix.pm perl5.004_03/lib/ExtUtils/MM_Unix.pm +*** perl5.004_03.orig/lib/ExtUtils/MM_Unix.pm Mon Aug 18 19:16:12 1997 +--- perl5.004_03/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:56:19 2000 +*************** +*** 2224,2230 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2224,2230 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +Only in perl5.004_03/lib/ExtUtils: MM_Unix.pm.orig +diff -rc perl5.004_03.orig/myconfig perl5.004_03/myconfig +*** perl5.004_03.orig/myconfig Sat Dec 21 01:13:20 1996 +--- perl5.004_03/myconfig Sun Nov 12 21:56:19 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_03.orig/patchlevel.h perl5.004_03/patchlevel.h +*** perl5.004_03.orig/patchlevel.h Wed Aug 13 11:42:01 1997 +--- perl5.004_03/patchlevel.h Sun Nov 12 21:56:19 2000 +*************** +*** 38,43 **** +--- 38,44 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + +Only in perl5.004_03: patchlevel.h.orig diff --git a/bdb/perl.DB_File/patches/5.004_04 b/bdb/perl.DB_File/patches/5.004_04 new file mode 100644 index 00000000000..a227dc700d9 --- /dev/null +++ b/bdb/perl.DB_File/patches/5.004_04 @@ -0,0 +1,209 @@ +diff -rc perl5.004_04.orig/Configure perl5.004_04/Configure +*** perl5.004_04.orig/Configure Fri Oct 3 18:57:39 1997 +--- perl5.004_04/Configure Sun Nov 12 21:50:51 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 9910,9915 **** +--- 9911,9924 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10378,10383 **** +--- 10387,10393 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_04.orig/Makefile.SH perl5.004_04/Makefile.SH +*** perl5.004_04.orig/Makefile.SH Wed Oct 15 10:33:16 1997 +--- perl5.004_04/Makefile.SH Sun Nov 12 21:50:51 2000 +*************** +*** 129,135 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 129,135 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_04.orig/lib/ExtUtils/Embed.pm perl5.004_04/lib/ExtUtils/Embed.pm +*** perl5.004_04.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_04/lib/ExtUtils/Embed.pm Sun Nov 12 21:50:51 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_04.orig/lib/ExtUtils/Liblist.pm perl5.004_04/lib/ExtUtils/Liblist.pm +*** perl5.004_04.orig/lib/ExtUtils/Liblist.pm Tue Sep 9 17:41:32 1997 +--- perl5.004_04/lib/ExtUtils/Liblist.pm Sun Nov 12 21:51:33 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 189,195 **** + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +--- 189,195 ---- + return ("", "", "", "") unless $potential_libs; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my($libpth) = $Config{'libpth'}; + my($libext) = $Config{'lib_ext'} || ".lib"; + +*************** +*** 539,545 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 539,545 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_04.orig/lib/ExtUtils/MM_Unix.pm perl5.004_04/lib/ExtUtils/MM_Unix.pm +*** perl5.004_04.orig/lib/ExtUtils/MM_Unix.pm Wed Oct 8 14:13:51 1997 +--- perl5.004_04/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:50:51 2000 +*************** +*** 2229,2235 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2229,2235 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_04.orig/myconfig perl5.004_04/myconfig +*** perl5.004_04.orig/myconfig Mon Oct 6 18:26:49 1997 +--- perl5.004_04/myconfig Sun Nov 12 21:50:51 2000 +*************** +*** 35,41 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 35,41 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_04.orig/patchlevel.h perl5.004_04/patchlevel.h +*** perl5.004_04.orig/patchlevel.h Wed Oct 15 10:55:19 1997 +--- perl5.004_04/patchlevel.h Sun Nov 12 21:50:51 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + /* The following line and terminating '};' are read by perlbug.PL. Don't alter. */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl.DB_File/patches/5.004_05 b/bdb/perl.DB_File/patches/5.004_05 new file mode 100644 index 00000000000..51c8bf35009 --- /dev/null +++ b/bdb/perl.DB_File/patches/5.004_05 @@ -0,0 +1,209 @@ +diff -rc perl5.004_05.orig/Configure perl5.004_05/Configure +*** perl5.004_05.orig/Configure Thu Jan 6 22:05:49 2000 +--- perl5.004_05/Configure Sun Nov 12 21:36:25 2000 +*************** +*** 188,193 **** +--- 188,194 ---- + mv='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 10164,10169 **** +--- 10165,10178 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 10648,10653 **** +--- 10657,10663 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.004_05.orig/Makefile.SH perl5.004_05/Makefile.SH +*** perl5.004_05.orig/Makefile.SH Thu Jan 6 22:05:49 2000 +--- perl5.004_05/Makefile.SH Sun Nov 12 21:36:25 2000 +*************** +*** 151,157 **** + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 151,157 ---- + ext = \$(dynamic_ext) \$(static_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.004_05.orig/lib/ExtUtils/Embed.pm perl5.004_05/lib/ExtUtils/Embed.pm +*** perl5.004_05.orig/lib/ExtUtils/Embed.pm Fri Aug 1 15:08:44 1997 +--- perl5.004_05/lib/ExtUtils/Embed.pm Sun Nov 12 21:36:25 2000 +*************** +*** 178,184 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 178,184 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.004_05.orig/lib/ExtUtils/Liblist.pm perl5.004_05/lib/ExtUtils/Liblist.pm +*** perl5.004_05.orig/lib/ExtUtils/Liblist.pm Thu Jan 6 22:05:54 2000 +--- perl5.004_05/lib/ExtUtils/Liblist.pm Sun Nov 12 21:45:31 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 196,202 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 196,202 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 590,596 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 590,596 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.004_05.orig/lib/ExtUtils/MM_Unix.pm perl5.004_05/lib/ExtUtils/MM_Unix.pm +*** perl5.004_05.orig/lib/ExtUtils/MM_Unix.pm Thu Jan 6 22:05:54 2000 +--- perl5.004_05/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:36:25 2000 +*************** +*** 2246,2252 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2246,2252 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.004_05.orig/myconfig perl5.004_05/myconfig +*** perl5.004_05.orig/myconfig Thu Jan 6 22:05:55 2000 +--- perl5.004_05/myconfig Sun Nov 12 21:43:54 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so + useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: +diff -rc perl5.004_05.orig/patchlevel.h perl5.004_05/patchlevel.h +*** perl5.004_05.orig/patchlevel.h Thu Jan 6 22:05:48 2000 +--- perl5.004_05/patchlevel.h Sun Nov 12 21:36:25 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + /* The following line and terminating '};' are read by perlbug.PL. Don't alter. */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl.DB_File/patches/5.005 b/bdb/perl.DB_File/patches/5.005 new file mode 100644 index 00000000000..effee3e8275 --- /dev/null +++ b/bdb/perl.DB_File/patches/5.005 @@ -0,0 +1,209 @@ +diff -rc perl5.005.orig/Configure perl5.005/Configure +*** perl5.005.orig/Configure Wed Jul 15 08:05:44 1998 +--- perl5.005/Configure Sun Nov 12 21:30:40 2000 +*************** +*** 234,239 **** +--- 234,240 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11279,11284 **** +--- 11280,11293 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 11804,11809 **** +--- 11813,11819 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.005.orig/Makefile.SH perl5.005/Makefile.SH +*** perl5.005.orig/Makefile.SH Sun Jul 19 08:06:35 1998 +--- perl5.005/Makefile.SH Sun Nov 12 21:30:40 2000 +*************** +*** 150,156 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 150,156 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.005.orig/lib/ExtUtils/Embed.pm perl5.005/lib/ExtUtils/Embed.pm +*** perl5.005.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998 +--- perl5.005/lib/ExtUtils/Embed.pm Sun Nov 12 21:30:40 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005.orig/lib/ExtUtils/Liblist.pm perl5.005/lib/ExtUtils/Liblist.pm +*** perl5.005.orig/lib/ExtUtils/Liblist.pm Wed Jul 22 07:09:42 1998 +--- perl5.005/lib/ExtUtils/Liblist.pm Sun Nov 12 21:30:40 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 290,296 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 290,296 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 598,604 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 598,604 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.005.orig/lib/ExtUtils/MM_Unix.pm perl5.005/lib/ExtUtils/MM_Unix.pm +*** perl5.005.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998 +--- perl5.005/lib/ExtUtils/MM_Unix.pm Sun Nov 12 21:30:41 2000 +*************** +*** 2281,2287 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2281,2287 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.005.orig/myconfig perl5.005/myconfig +*** perl5.005.orig/myconfig Fri Apr 3 01:20:35 1998 +--- perl5.005/myconfig Sun Nov 12 21:30:41 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -rc perl5.005.orig/patchlevel.h perl5.005/patchlevel.h +*** perl5.005.orig/patchlevel.h Wed Jul 22 19:22:01 1998 +--- perl5.005/patchlevel.h Sun Nov 12 21:30:41 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl.DB_File/patches/5.005_01 b/bdb/perl.DB_File/patches/5.005_01 new file mode 100644 index 00000000000..2a05dd545f6 --- /dev/null +++ b/bdb/perl.DB_File/patches/5.005_01 @@ -0,0 +1,209 @@ +diff -rc perl5.005_01.orig/Configure perl5.005_01/Configure +*** perl5.005_01.orig/Configure Wed Jul 15 08:05:44 1998 +--- perl5.005_01/Configure Sun Nov 12 20:55:58 2000 +*************** +*** 234,239 **** +--- 234,240 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11279,11284 **** +--- 11280,11293 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 11804,11809 **** +--- 11813,11819 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.005_01.orig/Makefile.SH perl5.005_01/Makefile.SH +*** perl5.005_01.orig/Makefile.SH Sun Jul 19 08:06:35 1998 +--- perl5.005_01/Makefile.SH Sun Nov 12 20:55:58 2000 +*************** +*** 150,156 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 150,156 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.005_01.orig/lib/ExtUtils/Embed.pm perl5.005_01/lib/ExtUtils/Embed.pm +*** perl5.005_01.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998 +--- perl5.005_01/lib/ExtUtils/Embed.pm Sun Nov 12 20:55:58 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005_01.orig/lib/ExtUtils/Liblist.pm perl5.005_01/lib/ExtUtils/Liblist.pm +*** perl5.005_01.orig/lib/ExtUtils/Liblist.pm Wed Jul 22 07:09:42 1998 +--- perl5.005_01/lib/ExtUtils/Liblist.pm Sun Nov 12 20:55:58 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 290,296 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 290,296 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 598,604 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 598,604 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +diff -rc perl5.005_01.orig/lib/ExtUtils/MM_Unix.pm perl5.005_01/lib/ExtUtils/MM_Unix.pm +*** perl5.005_01.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998 +--- perl5.005_01/lib/ExtUtils/MM_Unix.pm Sun Nov 12 20:55:58 2000 +*************** +*** 2281,2287 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2281,2287 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -rc perl5.005_01.orig/myconfig perl5.005_01/myconfig +*** perl5.005_01.orig/myconfig Fri Apr 3 01:20:35 1998 +--- perl5.005_01/myconfig Sun Nov 12 20:55:58 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -rc perl5.005_01.orig/patchlevel.h perl5.005_01/patchlevel.h +*** perl5.005_01.orig/patchlevel.h Mon Jan 3 11:07:45 2000 +--- perl5.005_01/patchlevel.h Sun Nov 12 20:55:58 2000 +*************** +*** 39,44 **** +--- 39,45 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl.DB_File/patches/5.005_02 b/bdb/perl.DB_File/patches/5.005_02 new file mode 100644 index 00000000000..5dd57ddc03f --- /dev/null +++ b/bdb/perl.DB_File/patches/5.005_02 @@ -0,0 +1,264 @@ +diff -rc perl5.005_02.orig/Configure perl5.005_02/Configure +*** perl5.005_02.orig/Configure Mon Jan 3 11:12:20 2000 +--- perl5.005_02/Configure Sun Nov 12 20:50:51 2000 +*************** +*** 234,239 **** +--- 234,240 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11334,11339 **** +--- 11335,11348 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 11859,11864 **** +--- 11868,11874 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +Only in perl5.005_02: Configure.orig +diff -rc perl5.005_02.orig/Makefile.SH perl5.005_02/Makefile.SH +*** perl5.005_02.orig/Makefile.SH Sun Jul 19 08:06:35 1998 +--- perl5.005_02/Makefile.SH Sun Nov 12 20:50:51 2000 +*************** +*** 150,156 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 150,156 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +Only in perl5.005_02: Makefile.SH.orig +diff -rc perl5.005_02.orig/lib/ExtUtils/Embed.pm perl5.005_02/lib/ExtUtils/Embed.pm +*** perl5.005_02.orig/lib/ExtUtils/Embed.pm Wed Jul 22 07:45:02 1998 +--- perl5.005_02/lib/ExtUtils/Embed.pm Sun Nov 12 20:50:51 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005_02.orig/lib/ExtUtils/Liblist.pm perl5.005_02/lib/ExtUtils/Liblist.pm +*** perl5.005_02.orig/lib/ExtUtils/Liblist.pm Mon Jan 3 11:12:21 2000 +--- perl5.005_02/lib/ExtUtils/Liblist.pm Sun Nov 12 20:50:51 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 196,202 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 196,202 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 333,339 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 333,339 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 623,629 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +--- 623,629 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs> + as well as in C<$Config{libpth}>. For each library that is found, a +*************** +*** 666,672 **** + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{libs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +--- 666,672 ---- + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +*************** +*** 676,682 **** + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{libs}>. + + =item * + +--- 676,682 ---- + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{perllibs}>. + + =item * + +Only in perl5.005_02/lib/ExtUtils: Liblist.pm.orig +diff -rc perl5.005_02.orig/lib/ExtUtils/MM_Unix.pm perl5.005_02/lib/ExtUtils/MM_Unix.pm +*** perl5.005_02.orig/lib/ExtUtils/MM_Unix.pm Tue Jul 14 04:39:12 1998 +--- perl5.005_02/lib/ExtUtils/MM_Unix.pm Sun Nov 12 20:50:51 2000 +*************** +*** 2281,2287 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2281,2287 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +Only in perl5.005_02/lib/ExtUtils: MM_Unix.pm.orig +diff -rc perl5.005_02.orig/myconfig perl5.005_02/myconfig +*** perl5.005_02.orig/myconfig Fri Apr 3 01:20:35 1998 +--- perl5.005_02/myconfig Sun Nov 12 20:50:51 2000 +*************** +*** 34,40 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 34,40 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -rc perl5.005_02.orig/patchlevel.h perl5.005_02/patchlevel.h +*** perl5.005_02.orig/patchlevel.h Mon Jan 3 11:12:19 2000 +--- perl5.005_02/patchlevel.h Sun Nov 12 20:50:51 2000 +*************** +*** 40,45 **** +--- 40,46 ---- + */ + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl.DB_File/patches/5.005_03 b/bdb/perl.DB_File/patches/5.005_03 new file mode 100644 index 00000000000..115f9f5b909 --- /dev/null +++ b/bdb/perl.DB_File/patches/5.005_03 @@ -0,0 +1,250 @@ +diff -rc perl5.005_03.orig/Configure perl5.005_03/Configure +*** perl5.005_03.orig/Configure Sun Mar 28 17:12:57 1999 +--- perl5.005_03/Configure Sun Sep 17 22:19:16 2000 +*************** +*** 208,213 **** +--- 208,214 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 11642,11647 **** +--- 11643,11656 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 12183,12188 **** +--- 12192,12198 ---- + patchlevel='$patchlevel' + path_sep='$path_sep' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -rc perl5.005_03.orig/Makefile.SH perl5.005_03/Makefile.SH +*** perl5.005_03.orig/Makefile.SH Thu Mar 4 02:35:25 1999 +--- perl5.005_03/Makefile.SH Sun Sep 17 22:21:01 2000 +*************** +*** 58,67 **** + shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp" + case "$osvers" in + 3*) +! shrpldflags="$shrpldflags -e _nostart $ldflags $libs $cryptlib" + ;; + *) +! shrpldflags="$shrpldflags -b noentry $ldflags $libs $cryptlib" + ;; + esac + aixinstdir=`pwd | sed 's/\/UU$//'` +--- 58,67 ---- + shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp" + case "$osvers" in + 3*) +! shrpldflags="$shrpldflags -e _nostart $ldflags $perllibs $cryptlib" + ;; + *) +! shrpldflags="$shrpldflags -b noentry $ldflags $perllibs $cryptlib" + ;; + esac + aixinstdir=`pwd | sed 's/\/UU$//'` +*************** +*** 155,161 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 155,161 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +diff -rc perl5.005_03.orig/lib/ExtUtils/Embed.pm perl5.005_03/lib/ExtUtils/Embed.pm +*** perl5.005_03.orig/lib/ExtUtils/Embed.pm Wed Jan 6 02:17:50 1999 +--- perl5.005_03/lib/ExtUtils/Embed.pm Sun Sep 17 22:19:16 2000 +*************** +*** 194,200 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 194,200 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -rc perl5.005_03.orig/lib/ExtUtils/Liblist.pm perl5.005_03/lib/ExtUtils/Liblist.pm +*** perl5.005_03.orig/lib/ExtUtils/Liblist.pm Wed Jan 6 02:17:47 1999 +--- perl5.005_03/lib/ExtUtils/Liblist.pm Sun Sep 17 22:19:16 2000 +*************** +*** 16,33 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 16,33 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 196,202 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 196,202 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 336,342 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 336,342 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 626,632 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +--- 626,632 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +*************** +*** 670,676 **** + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{libs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +--- 670,676 ---- + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +*************** +*** 680,686 **** + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{libs}>. + + =item * + +--- 680,686 ---- + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{perllibs}>. + + =item * + +diff -rc perl5.005_03.orig/lib/ExtUtils/MM_Unix.pm perl5.005_03/lib/ExtUtils/MM_Unix.pm +*** perl5.005_03.orig/lib/ExtUtils/MM_Unix.pm Fri Mar 5 00:34:20 1999 +--- perl5.005_03/lib/ExtUtils/MM_Unix.pm Sun Sep 17 22:19:16 2000 +*************** +*** 2284,2290 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2284,2290 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { diff --git a/bdb/perl.DB_File/patches/5.6.0 b/bdb/perl.DB_File/patches/5.6.0 new file mode 100644 index 00000000000..1f9b3b620de --- /dev/null +++ b/bdb/perl.DB_File/patches/5.6.0 @@ -0,0 +1,294 @@ +diff -cr perl-5.6.0.orig/Configure perl-5.6.0/Configure +*** perl-5.6.0.orig/Configure Wed Mar 22 20:36:37 2000 +--- perl-5.6.0/Configure Sun Sep 17 23:40:15 2000 +*************** +*** 217,222 **** +--- 217,223 ---- + nm='' + nroff='' + perl='' ++ perllibs='' + pg='' + pmake='' + pr='' +*************** +*** 14971,14976 **** +--- 14972,14985 ---- + shift + extensions="$*" + ++ : Remove libraries needed only for extensions ++ : The appropriate ext/Foo/Makefile.PL will add them back in, if ++ : necessary. ++ set X `echo " $libs " | ++ sed -e 's@ -lndbm @ @' -e 's@ -lgdbm @ @' -e 's@ -ldbm @ @' -e 's@ -ldb @ @'` ++ shift ++ perllibs="$*" ++ + : Remove build directory name from cppstdin so it can be used from + : either the present location or the final installed location. + echo " " +*************** +*** 15640,15645 **** +--- 15649,15655 ---- + path_sep='$path_sep' + perl5='$perl5' + perl='$perl' ++ perllibs='$perllibs' + perladmin='$perladmin' + perlpath='$perlpath' + pg='$pg' +diff -cr perl-5.6.0.orig/Makefile.SH perl-5.6.0/Makefile.SH +*** perl-5.6.0.orig/Makefile.SH Sat Mar 11 16:05:24 2000 +--- perl-5.6.0/Makefile.SH Sun Sep 17 23:40:15 2000 +*************** +*** 70,76 **** + *) shrpldflags="$shrpldflags -b noentry" + ;; + esac +! shrpldflags="$shrpldflags $ldflags $libs $cryptlib" + linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl" + ;; + hpux*) +--- 70,76 ---- + *) shrpldflags="$shrpldflags -b noentry" + ;; + esac +! shrpldflags="$shrpldflags $ldflags $perllibs $cryptlib" + linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl" + ;; + hpux*) +*************** +*** 176,182 **** + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $libs $cryptlib + + public = perl $suidperl utilities translators + +--- 176,182 ---- + ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext) + DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT) + +! libs = $perllibs $cryptlib + + public = perl $suidperl utilities translators + +*************** +*** 333,339 **** + case "$osname" in + aix) + $spitshell >>Makefile <<!GROK!THIS! +! LIBS = $libs + # In AIX we need to change this for building Perl itself from + # its earlier definition (which is for building external + # extensions *after* Perl has been built and installed) +--- 333,339 ---- + case "$osname" in + aix) + $spitshell >>Makefile <<!GROK!THIS! +! LIBS = $perllibs + # In AIX we need to change this for building Perl itself from + # its earlier definition (which is for building external + # extensions *after* Perl has been built and installed) +diff -cr perl-5.6.0.orig/lib/ExtUtils/Embed.pm perl-5.6.0/lib/ExtUtils/Embed.pm +*** perl-5.6.0.orig/lib/ExtUtils/Embed.pm Sun Jan 23 12:08:32 2000 +--- perl-5.6.0/lib/ExtUtils/Embed.pm Sun Sep 17 23:40:15 2000 +*************** +*** 193,199 **** + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + +--- 193,199 ---- + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; +! push(@potential_libs, $Config{perllibs}) if defined $std; + + push(@mods, static_ext()) if $std; + +diff -cr perl-5.6.0.orig/lib/ExtUtils/Liblist.pm perl-5.6.0/lib/ExtUtils/Liblist.pm +*** perl-5.6.0.orig/lib/ExtUtils/Liblist.pm Wed Mar 22 16:16:31 2000 +--- perl-5.6.0/lib/ExtUtils/Liblist.pm Sun Sep 17 23:40:15 2000 +*************** +*** 17,34 **** + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{libs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{libs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'libs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +--- 17,34 ---- + + sub _unix_os2_ext { + my($self,$potential_libs, $verbose) = @_; +! if ($^O =~ 'os2' and $Config{perllibs}) { + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll again. + + $potential_libs .= " " if $potential_libs; +! $potential_libs .= $Config{perllibs}; + } + return ("", "", "", "") unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my($so) = $Config{'so'}; +! my($libs) = $Config{'perllibs'}; + my $Config_libext = $Config{lib_ext} || ".a"; + + +*************** +*** 198,204 **** + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'libs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +--- 198,204 ---- + my $BC = 1 if $cc =~ /^bcc/i; + my $GC = 1 if $cc =~ /^gcc/i; + my $so = $Config{'so'}; +! my $libs = $Config{'perllibs'}; + my $libpth = $Config{'libpth'}; + my $libext = $Config{'lib_ext'} || ".lib"; + +*************** +*** 338,344 **** + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +--- 338,344 ---- + $self->{CCFLAS} || $Config{'ccflags'}; + @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') + . 'PerlShr/Share' ); +! push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and +*************** +*** 624,630 **** + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +--- 624,630 ---- + =item * + + If C<$potential_libs> is empty, the return value will be empty. +! Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. +*************** +*** 668,674 **** + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{libs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +--- 668,674 ---- + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C</:nodefault/i> disables the appending of default +! libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + + An entry that matches C</:nosearch/i> disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and +*************** +*** 678,684 **** + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{libs}>. + + =item * + +--- 678,684 ---- + + An entry that matches C</:search/i> reenables searching for + the libraries specified after it. You can put it at the end to +! enable searching for default libraries specified by C<$Config{perllibs}>. + + =item * + +diff -cr perl-5.6.0.orig/lib/ExtUtils/MM_Unix.pm perl-5.6.0/lib/ExtUtils/MM_Unix.pm +*** perl-5.6.0.orig/lib/ExtUtils/MM_Unix.pm Thu Mar 2 17:52:52 2000 +--- perl-5.6.0/lib/ExtUtils/MM_Unix.pm Sun Sep 17 23:40:15 2000 +*************** +*** 2450,2456 **** + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +--- 2450,2456 ---- + MAP_STATIC = ", + join(" \\\n\t", reverse sort keys %static), " + +! MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} + "; + + if (defined $libperl) { +diff -cr perl-5.6.0.orig/myconfig.SH perl-5.6.0/myconfig.SH +*** perl-5.6.0.orig/myconfig.SH Sat Feb 26 06:34:49 2000 +--- perl-5.6.0/myconfig.SH Sun Sep 17 23:41:17 2000 +*************** +*** 48,54 **** + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$libs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +--- 48,54 ---- + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth +! libs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' +diff -cr perl-5.6.0.orig/patchlevel.h perl-5.6.0/patchlevel.h +*** perl-5.6.0.orig/patchlevel.h Wed Mar 22 20:23:11 2000 +--- perl-5.6.0/patchlevel.h Sun Sep 17 23:40:15 2000 +*************** +*** 70,75 **** +--- 70,76 ---- + #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT) + static char *local_patches[] = { + NULL ++ ,"NODB-1.0 - remove -ldb from core perl binary." + ,NULL + }; + diff --git a/bdb/perl.DB_File/t/db-btree.t b/bdb/perl.DB_File/t/db-btree.t new file mode 100644 index 00000000000..377cfe45c9b --- /dev/null +++ b/bdb/perl.DB_File/t/db-btree.t @@ -0,0 +1,1306 @@ +#!./perl -w + +use warnings; +use strict; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bDB_File\b/ ) { + print "1..157\n"; + exit 0; + } + } +} + +use DB_File; +use Fcntl; + +print "1..157\n"; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +sub lexical +{ + my(@a) = unpack ("C*", $a) ; + my(@b) = unpack ("C*", $b) ; + + my $len = (@a > @b ? @b : @a) ; + my $i = 0 ; + + foreach $i ( 0 .. $len -1) { + return $a[$i] - $b[$i] if $a[$i] != $b[$i] ; + } + + return @a - @b ; +} + +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat +{ + my $file = shift; + #local $/ = undef unless wantarray ; + open(CAT,$file) || die "Cannot open $file: $!"; + my @result = <CAT>; + close(CAT); + wantarray ? @result : join("", @result) ; +} + +sub docat_del +{ + my $file = shift; + #local $/ = undef unless wantarray ; + open(CAT,$file) || die "Cannot open $file: $!"; + my @result = <CAT>; + close(CAT); + unlink $file ; + wantarray ? @result : join("", @result) ; +} + + +my $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; +my $null_keys_allowed = ($DB_File::db_ver < 2.004010 + || $DB_File::db_ver >= 3.1 ); + +my $Dfile = "dbbtree.tmp"; +unlink $Dfile; + +umask(0); + +# Check the interface to BTREEINFO + +my $dbh = new DB_File::BTREEINFO ; +ok(1, ! defined $dbh->{flags}) ; +ok(2, ! defined $dbh->{cachesize}) ; +ok(3, ! defined $dbh->{psize}) ; +ok(4, ! defined $dbh->{lorder}) ; +ok(5, ! defined $dbh->{minkeypage}) ; +ok(6, ! defined $dbh->{maxkeypage}) ; +ok(7, ! defined $dbh->{compare}) ; +ok(8, ! defined $dbh->{prefix}) ; + +$dbh->{flags} = 3000 ; +ok(9, $dbh->{flags} == 3000) ; + +$dbh->{cachesize} = 9000 ; +ok(10, $dbh->{cachesize} == 9000); + +$dbh->{psize} = 400 ; +ok(11, $dbh->{psize} == 400) ; + +$dbh->{lorder} = 65 ; +ok(12, $dbh->{lorder} == 65) ; + +$dbh->{minkeypage} = 123 ; +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/ ) ; +eval 'my $q = $dbh->{fred}' ; +ok(18, $@ =~ /^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 )) ; + +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32'); + +my ($key, $value, $i); +while (($key,$value) = each(%h)) { + $i++; +} +ok(21, !$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'} ) ; + +$h{'def'} = 'DEF'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; + +#$h{'b'} = 'B'; +$X->STORE('b', 'B') ; + +$h{'c'} = 'C'; + +#$h{'d'} = 'D'; +$X->put('d', 'D') ; + +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'X'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + + +# IMPORTANT - $X must be undefined before the untie otherwise the +# underlying DB close routine will not get called. +undef $X ; +untie(%h); + +# tie to the same file again +ok(26, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ; + +# Modify an entry from the previous tie +$h{'g'} = 'G'; + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +$X->DELETE('goner3'); + +my @keys = keys(%h); +my @values = values(%h); + +ok(27, $#keys == 29 && $#values == 29) ; + +$i = 0 ; +while (($key,$value) = each(%h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +ok(28, $i == 30) ; + +@keys = ('blurfl', keys(%h), 'dyick'); +ok(29, $#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)) ; + +$h{'foo'} = ''; +ok(31, $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. +my $result = 0 ; +if ($null_keys_allowed) { + $h{''} = 'bar'; + $result = ( $h{''} eq 'bar' ); +} +else + { $result = 1 } +ok(32, $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); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +ok(34, $size > 0 ); + +@h{0..200} = 200..400; +my @foo = @h{0..200}; +ok(35, join(':',200..400) eq join(':',@foo) ); + +# Now check all the non-tie specific stuff + + +# Check R_NOOVERWRITE flag will make put fail when attempting to overwrite +# an existing record. + +my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; +ok(36, $status == 1 ); + +# check that the value of the key 'x' has not been changed by the +# previous test +ok(37, $h{'x'} eq 'X' ); + +# standard put +$status = $X->put('key', 'value') ; +ok(38, $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' ); + +# Attempting to delete an existing key should work + +$status = $X->del('q') ; +ok(41, $status == 0 ); +if ($null_keys_allowed) { + $status = $X->del('') ; +} else { + $status = 0 ; +} +ok(42, $status == 0 ); + +# Make sure that the key deleted, cannot be retrieved +ok(43, ! defined $h{'q'}) ; +ok(44, ! defined $h{''}) ; + +undef $X ; +untie %h ; + +ok(45, $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 ); + +# Check the get interface + +# First a non-existing key +$status = $X->get('aaaa', $value) ; +ok(47, $status == 1 ); + +# Next an existing key +$status = $X->get('a', $value) ; +ok(48, $status == 0 ); +ok(49, $value eq 'A' ); + +# seq +# ### + +# use seq to find an approximate match +$key = 'ke' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +ok(50, $status == 0 ); +ok(51, $key eq 'key' ); +ok(52, $value eq 'value' ); + +# seq when the key does not match +$key = 'zzz' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +ok(53, $status == 1 ); + + +# use seq to set the cursor, then delete the record @ the cursor. + +$key = 'x' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +ok(54, $status == 0 ); +ok(55, $key eq 'x' ); +ok(56, $value eq 'X' ); +$status = $X->del(0, R_CURSOR) ; +ok(57, $status == 0 ); +$status = $X->get('x', $value) ; +ok(58, $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' ); + +$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' ); +$status = $X->get('y', $value) ; +ok(65, 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 ); +my $previous = $key ; + +$ok = 1 ; +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 ); + +# use seq to walk backwards through a file +$status = $X->seq($key, $value, R_LAST) ; +ok(69, $status == 0 ); +$previous = $key ; + +$ok = 1 ; +while (($status = $X->seq($key, $value, R_PREV)) == 0) +{ + ($ok = 0), last if ($previous cmp $key) == -1 ; + #print "key = [$key] value = [$value]\n" ; +} + +ok(70, $status == 1 ); +ok(71, $ok == 1 ); + + +# check seq FIRST/LAST + +# sync +# #### + +$status = $X->sync ; +ok(72, $status == 0 ); + + +# fd +# ## + +$status = $X->fd ; +ok(73, $status != 0 ); + + +undef $X ; +untie %h ; + +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 )); + +# fd with an in memory file should return failure +$status = $Y->fd ; +ok(75, $status == -1 ); + + +undef $Y ; +untie %h ; + +# Duplicate keys +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 )) ; + +$hh{'Wall'} = 'Larry' ; +$hh{'Wall'} = 'Stone' ; # Note the duplicate key +$hh{'Wall'} = 'Brick' ; # Note the duplicate key +$hh{'Wall'} = 'Brick' ; # Note the duplicate key and value +$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 ); + +# now in list context +my @unknown = $YY->get_dup('Unknown') ; +ok(80, "@unknown" eq "" ); + +my @smith = $YY->get_dup('Smith') ; +ok(81, "@smith" eq "John" ); + +{ +my @wall = $YY->get_dup('Wall') ; +my %wall ; +@wall{@wall} = @wall ; +ok(82, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ); +} + +# hash +my %unknown = $YY->get_dup('Unknown', 1) ; +ok(83, keys %unknown == 0 ); + +my %smith = $YY->get_dup('Smith', 1) ; +ok(84, keys %smith == 1 && $smith{'John'}) ; + +my %wall = $YY->get_dup('Wall', 1) ; +ok(85, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 + && $wall{'Brick'} == 2); + +undef $YY ; +untie %hh ; +unlink $Dfile; + + +# test multiple callbacks +my $Dfile1 = "btree1" ; +my $Dfile2 = "btree2" ; +my $Dfile3 = "btree3" ; + +my $dbh1 = new DB_File::BTREEINFO ; +$dbh1->{compare} = sub { + no warnings 'numeric' ; + $_[0] <=> $_[1] } ; + +my $dbh2 = new DB_File::BTREEINFO ; +$dbh2->{compare} = sub { $_[0] cmp $_[1] } ; + +my $dbh3 = new DB_File::BTREEINFO ; +$dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ; + + +my (%g, %k); +tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ; +tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ; +tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ; + +my @Keys = qw( 0123 12 -1234 9 987654321 def ) ; +my (@srt_1, @srt_2, @srt_3); +{ + no warnings 'numeric' ; + @srt_1 = sort { $a <=> $b } @Keys ; +} +@srt_2 = sort { $a cmp $b } @Keys ; +@srt_3 = sort { length $a <=> length $b } @Keys ; + +foreach (@Keys) { + $h{$_} = 1 ; + $g{$_} = 1 ; + $k{$_} = 1 ; +} + +sub ArrayCompare +{ + my($a, $b) = @_ ; + + return 0 if @$a != @$b ; + + foreach (1 .. length @$a) + { + return 0 unless $$a[$_] eq $$b[$_] ; + } + + 1 ; +} + +ok(86, ArrayCompare (\@srt_1, [keys %h]) ); +ok(87, ArrayCompare (\@srt_2, [keys %g]) ); +ok(88, ArrayCompare (\@srt_3, [keys %k]) ); + +untie %h ; +untie %g ; +untie %k ; +unlink $Dfile1, $Dfile2, $Dfile3 ; + +# clear +# ##### + +ok(89, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); +foreach (1 .. 10) + { $h{$_} = $_ * 100 } + +# check that there are 10 elements in the hash +$i = 0 ; +while (($key,$value) = each(%h)) { + $i++; +} +ok(90, $i == 10); + +# now clear the hash +%h = () ; + +# check it is empty +$i = 0 ; +while (($key,$value) = each(%h)) { + $i++; +} +ok(91, $i == 0); + +untie %h ; +unlink $Dfile1 ; + +{ + # check that attempting to tie an array to a DB_BTREE will fail + + 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/) ; + unlink $filename ; +} + +{ + # sub-class test + + package Another ; + + use warnings ; + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use warnings ; + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(93, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE ); + ' ; + + main::ok(94, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(95, $@ eq "") ; + main::ok(96, $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) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(99, $@ eq "" ) ; + main::ok(100, $ret == 1) ; + + $ret = eval '$X->A_new_method("joe") ' ; + main::ok(101, $@ eq "") ; + main::ok(102, $ret eq "[[11]]") ; + + undef $X; + untie(%h); + unlink "SubDB.pm", "dbbtree.tmp" ; + +} + +{ + # DBM Filter tests + use warnings ; + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(103, $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 = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(104, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(105, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(106, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(107, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(108, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(109, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(110, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(111, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(112, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(113, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(114, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(115, $h{"fred"} eq "joe"); + ok(116, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(117, $db->FIRSTKEY() eq "fred") ; + ok(118, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(119, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(120, $h{"fred"} eq "joe"); + ok(121, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(122, $db->FIRSTKEY() eq "fred") ; + ok(123, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use warnings ; + use strict ; + my (%h, $db) ; + + unlink $Dfile; + ok(124, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "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") ; + + $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") ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use warnings ; + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(147, $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/ ); + + undef $db ; + untie %h; + unlink $Dfile; +} + + +{ + # Examples from the POD + + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + # BTREE example 1 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + my %h ; + + sub Compare + { + my ($key1, $key2) = @_ ; + "\L$key1" cmp "\L$key2" ; + } + + # specify the Perl sub that will do the comparison + $DB_BTREE->{'compare'} = \&Compare ; + + unlink "tree" ; + tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open file 'tree': $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; + + unlink "tree" ; + } + + delete $DB_BTREE->{'compare'} ; + + ok(149, docat_del($file) eq <<'EOM') ; +mouse +Smith +Wall +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 2 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + use vars qw($filename %h ) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the associative array + # and print each key/value pair. + foreach (keys %h) + { print "$_ -> $h{$_}\n" } + + untie %h ; + + unlink $filename ; + } + + ok(150, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ; +Smith -> John +Wall -> Brick +Wall -> Brick +Wall -> Brick +mouse -> mickey +EOM +Smith -> John +Wall -> Larry +Wall -> Larry +Wall -> Larry +mouse -> mickey +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 3 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + use vars qw($filename $x %h $status $key $value) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # 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) ) + { print "$key -> $value\n" } + + + undef $x ; + untie %h ; + } + + ok(151, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ; +Smith -> John +Wall -> Brick +Wall -> Brick +Wall -> Larry +mouse -> mickey +EOM +Smith -> John +Wall -> Larry +Wall -> Brick +Wall -> Brick +mouse -> mickey +EOM + + + { + my $redirect = new Redirect $file ; + + # BTREE example 4 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + use vars qw($filename $x %h ) ; + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + my $cnt = $x->get_dup("Wall") ; + print "Wall occurred $cnt times\n" ; + + my %hash = $x->get_dup("Wall", 1) ; + print "Larry is there\n" if $hash{'Larry'} ; + print "There are $hash{'Brick'} Brick Walls\n" ; + + my @list = sort $x->get_dup("Wall") ; + print "Wall => [@list]\n" ; + + @list = $x->get_dup("Smith") ; + print "Smith => [@list]\n" ; + + @list = $x->get_dup("Dog") ; + print "Dog => [@list]\n" ; + + undef $x ; + untie %h ; + } + + ok(152, docat_del($file) eq <<'EOM') ; +Wall occurred 3 times +Larry is there +There are 2 Brick Walls +Wall => [Brick Brick Larry] +Smith => [John] +Dog => [] +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 5 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + use vars qw($filename $x %h $found) ; + + my $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; + print "Harry Wall is $found there\n" ; + + undef $x ; + untie %h ; + } + + ok(153, docat_del($file) eq <<'EOM') ; +Larry Wall is there +Harry Wall is not there +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 6 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + use vars qw($filename $x %h $found) ; + + my $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $x->del_dup("Wall", "Larry") ; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + undef $x ; + untie %h ; + + unlink $filename ; + } + + ok(154, docat_del($file) eq <<'EOM') ; +Larry Wall is not there +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 7 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + use Fcntl ; + + use vars qw($filename $x %h $st $key $value) ; + + sub match + { + my $key = shift ; + my $value = 0; + my $orig_key = $key ; + $x->seq($key, $value, R_CURSOR) ; + print "$orig_key\t-> $key\t-> $value\n" ; + } + + $filename = "tree" ; + unlink $filename ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'mouse'} = 'mickey' ; + $h{'Wall'} = 'Larry' ; + $h{'Walls'} = 'Brick' ; + $h{'Smith'} = 'John' ; + + + $key = $value = 0 ; + print "IN ORDER\n" ; + for ($st = $x->seq($key, $value, R_FIRST) ; + $st == 0 ; + $st = $x->seq($key, $value, R_NEXT) ) + + { print "$key -> $value\n" } + + print "\nPARTIAL MATCH\n" ; + + match "Wa" ; + match "A" ; + match "a" ; + + undef $x ; + untie %h ; + + unlink $filename ; + + } + + ok(155, docat_del($file) eq <<'EOM') ; +IN ORDER +Smith -> John +Wall -> Larry +Walls -> Brick +mouse -> mickey + +PARTIAL MATCH +Wa -> Wall -> Larry +A -> Smith -> John +a -> mouse -> mickey +EOM + +} + +#{ +# # R_SETCURSOR +# use strict ; +# my (%h, $db) ; +# unlink $Dfile; +# +# ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); +# +# $h{abc} = 33 ; +# my $k = "newest" ; +# my $v = 44 ; +# my $status = $db->put($k, $v, R_SETCURSOR) ; +# print "status = [$status]\n" ; +# ok(157, $status == 0) ; +# $status = $db->del($k, R_CURSOR) ; +# print "status = [$status]\n" ; +# ok(158, $status == 0) ; +# $k = "newest" ; +# ok(159, $db->get($k, $v, R_CURSOR)) ; +# +# ok(160, keys %h == 1) ; +# +# undef $db ; +# untie %h; +# unlink $Dfile; +#} + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + 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 "") ; + untie %h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE + or die "Can't open file: $!\n" ; + %h = (); ; + ok(157, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +exit ; diff --git a/bdb/perl.DB_File/t/db-hash.t b/bdb/perl.DB_File/t/db-hash.t new file mode 100644 index 00000000000..a6efd981004 --- /dev/null +++ b/bdb/perl.DB_File/t/db-hash.t @@ -0,0 +1,753 @@ +#!./perl + +use warnings ; +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bDB_File\b/ ) { + print "1..111\n"; + exit 0; + } + } +} + +use DB_File; +use Fcntl; + +print "1..111\n"; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat_del +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file: $!"; + my $result = <CAT>; + close(CAT); + unlink $file ; + return $result; +} + +my $Dfile = "dbhash.tmp"; +my $null_keys_allowed = ($DB_File::db_ver < 2.004010 + || $DB_File::db_ver >= 3.1 ); + +unlink $Dfile; + +umask(0); + +# Check the interface to HASHINFO + +my $dbh = new DB_File::HASHINFO ; + +ok(1, ! defined $dbh->{bsize}) ; +ok(2, ! defined $dbh->{ffactor}) ; +ok(3, ! defined $dbh->{nelem}) ; +ok(4, ! defined $dbh->{cachesize}) ; +ok(5, ! defined $dbh->{hash}) ; +ok(6, ! defined $dbh->{lorder}) ; + +$dbh->{bsize} = 3000 ; +ok(7, $dbh->{bsize} == 3000 ); + +$dbh->{ffactor} = 9000 ; +ok(8, $dbh->{ffactor} == 9000 ); + +$dbh->{nelem} = 400 ; +ok(9, $dbh->{nelem} == 400 ); + +$dbh->{cachesize} = 65 ; +ok(10, $dbh->{cachesize} == 65 ); + +$dbh->{hash} = "abc" ; +ok(11, $dbh->{hash} eq "abc" ); + +$dbh->{lorder} = 1234 ; +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 'my $q = $dbh->{fred}' ; +ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ ); + + +# Now check the interface to HASH +my ($X, %h); +ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32'); + +my ($key, $value, $i); +while (($key,$value) = each(%h)) { + $i++; +} +ok(17, !$i ); + +$h{'goner1'} = 'snork'; + +$h{'abc'} = 'ABC'; +ok(18, $h{'abc'} eq 'ABC' ); +ok(19, !defined $h{'jimmy'} ); +ok(20, !exists $h{'jimmy'} ); +ok(21, exists $h{'abc'} ); + +$h{'def'} = 'DEF'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; + +#$h{'b'} = 'B'; +$X->STORE('b', 'B') ; + +$h{'c'} = 'C'; + +#$h{'d'} = 'D'; +$X->put('d', 'D') ; + +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'X'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + + +# IMPORTANT - $X must be undefined before the untie otherwise the +# underlying DB close routine will not get called. +undef $X ; +untie(%h); + + +# tie to the same file again, do not supply a type - should default to HASH +ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) ); + +# Modify an entry from the previous tie +$h{'g'} = 'G'; + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +$X->DELETE('goner3'); + +my @keys = keys(%h); +my @values = values(%h); + +ok(23, $#keys == 29 && $#values == 29) ; + +$i = 0 ; +while (($key,$value) = each(%h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +ok(24, $i == 30) ; + +@keys = ('blurfl', keys(%h), 'dyick'); +ok(25, $#keys == 31) ; + +$h{'foo'} = ''; +ok(26, $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. +my $result = 0 ; +if ($null_keys_allowed) { + $h{''} = 'bar'; + $result = ( $h{''} eq 'bar' ); +} +else + { $result = 1 } +ok(27, $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(28, $ok ); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +ok(29, $size > 0 ); + +@h{0..200} = 200..400; +my @foo = @h{0..200}; +ok(30, join(':',200..400) eq join(':',@foo) ); + + +# Now check all the non-tie specific stuff + +# Check NOOVERWRITE will make put fail when attempting to overwrite +# an existing record. + +my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; +ok(31, $status == 1 ); + +# check that the value of the key 'x' has not been changed by the +# previous test +ok(32, $h{'x'} eq 'X' ); + +# standard put +$status = $X->put('key', 'value') ; +ok(33, $status == 0 ); + +#check that previous put can be retrieved +$value = 0 ; +$status = $X->get('key', $value) ; +ok(34, $status == 0 ); +ok(35, $value eq 'value' ); + +# Attempting to delete an existing key should work + +$status = $X->del('q') ; +ok(36, $status == 0 ); + +# Make sure that the key deleted, cannot be retrieved +{ + no warnings 'uninitialized' ; + ok(37, $h{'q'} eq undef ); +} + +# Attempting to delete a non-existant key should fail + +$status = $X->del('joe') ; +ok(38, $status == 1 ); + +# Check the get interface + +# First a non-existing key +$status = $X->get('aaaa', $value) ; +ok(39, $status == 1 ); + +# Next an existing key +$status = $X->get('a', $value) ; +ok(40, $status == 0 ); +ok(41, $value eq 'A' ); + +# seq +# ### + +# ditto, but use put to replace the key/value pair. + +# use seq to walk backwards through a file - check that this reversed is + +# check seq FIRST/LAST + +# sync +# #### + +$status = $X->sync ; +ok(42, $status == 0 ); + + +# fd +# ## + +$status = $X->fd ; +ok(43, $status != 0 ); + +undef $X ; +untie %h ; + +unlink $Dfile; + +# clear +# ##### + +ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); +foreach (1 .. 10) + { $h{$_} = $_ * 100 } + +# check that there are 10 elements in the hash +$i = 0 ; +while (($key,$value) = each(%h)) { + $i++; +} +ok(45, $i == 10); + +# now clear the hash +%h = () ; + +# check it is empty +$i = 0 ; +while (($key,$value) = each(%h)) { + $i++; +} +ok(46, $i == 0); + +untie %h ; +unlink $Dfile ; + + +# Now try an in memory file +ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + +# fd with an in memory file should return fail +$status = $X->fd ; +ok(48, $status == -1 ); + +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) ; +} + +{ + # check that attempting to tie an array to a DB_HASH will fail + + my $filename = "xyz" ; + my @x ; + eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ; + ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ; + unlink $filename ; +} + +{ + # sub-class test + + package Another ; + + use warnings ; + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use warnings ; + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(53, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH ); + ' ; + + main::ok(54, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(55, $@ eq "") ; + main::ok(56, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; + main::ok(57, $@ eq "") ; + main::ok(58, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(59, $@ eq "" ) ; + main::ok(60, $ret == 1) ; + + $ret = eval '$X->A_new_method("joe") ' ; + main::ok(61, $@ eq "") ; + main::ok(62, $ret eq "[[11]]") ; + + undef $X; + untie(%h); + unlink "SubDB.pm", "dbhash.tmp" ; + +} + +{ + # DBM Filter tests + use warnings ; + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(64, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(65, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(66, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(67, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(68, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(69, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(70, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(71, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(72, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(73, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(74, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(75, $h{"fred"} eq "joe"); + ok(76, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(77, $db->FIRSTKEY() eq "fred") ; + ok(78, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(79, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(80, $h{"fred"} eq "joe"); + ok(81, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(82, $db->FIRSTKEY() eq "fred") ; + ok(83, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use warnings ; + use strict ; + my (%h, $db) ; + + unlink $Dfile; + ok(84, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "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") ; + + $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") ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use warnings ; + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(107, $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/ ); + + undef $db ; + untie %h; + unlink $Dfile; +} + + +{ + # Examples from the POD + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + use warnings FATAL => qw(all); + use strict ; + use DB_File ; + use vars qw( %h $k $v ) ; + + unlink "fruit" ; + tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH + or die "Cannot open file 'fruit': $!\n"; + + # Add a few key/value pairs to the file + $h{"apple"} = "red" ; + $h{"orange"} = "orange" ; + $h{"banana"} = "yellow" ; + $h{"tomato"} = "red" ; + + # Check for existence of a key + print "Banana Exists\n\n" if $h{"banana"} ; + + # Delete a key/value pair. + delete $h{"apple"} ; + + # print the contents of the file + while (($k, $v) = each %h) + { print "$k -> $v\n" } + + untie %h ; + + unlink "fruit" ; + } + + ok(109, docat_del($file) eq <<'EOM') ; +Banana Exists + +orange -> orange +tomato -> red +banana -> yellow +EOM + +} + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; + $h{ABC} = undef; + ok(110, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; + %h = (); ; + ok(111, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +exit ; diff --git a/bdb/perl.DB_File/t/db-recno.t b/bdb/perl.DB_File/t/db-recno.t new file mode 100644 index 00000000000..c64d83b5916 --- /dev/null +++ b/bdb/perl.DB_File/t/db-recno.t @@ -0,0 +1,899 @@ +#!./perl -w + +use warnings; +use strict ; + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bDB_File\b/ ) { + print "1..128\n"; + exit 0; + } + } +} + +use DB_File; +use Fcntl; +use vars qw($dbh $Dfile $bad_ones $FA) ; + +# full tied array support started in Perl 5.004_57 +# Double check to see if it is available. + +{ + sub try::TIEARRAY { bless [], "try" } + sub try::FETCHSIZE { $FA = 1 } + $FA = 0 ; + my @a ; + tie @a, 'try' ; + my $a = @a ; +} + + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; + + return $result ; +} + +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file:$!"; + my $result = <CAT>; + close(CAT); + return $result; +} + +sub docat_del +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file: $!"; + my $result = <CAT>; + close(CAT); + unlink $file ; + return $result; +} + +sub bad_one +{ + print STDERR <<EOM unless $bad_ones++ ; +# +# Some older versions of Berkeley DB version 1 will fail tests 51, +# 53 and 55. +# +# You can safely ignore the errors if you're never going to use the +# broken functionality (recno databases with a modified bval). +# Otherwise you'll have to upgrade your DB library. +# +# If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the +# last versions that were released. Berkeley DB version 2 is continually +# being updated -- Check out http://www.sleepycat.com/ for more details. +# +EOM +} + +print "1..128\n"; + +my $Dfile = "recno.tmp"; +unlink $Dfile ; + +umask(0); + +# Check the interface to RECNOINFO + +my $dbh = new DB_File::RECNOINFO ; +ok(1, ! defined $dbh->{bval}) ; +ok(2, ! defined $dbh->{cachesize}) ; +ok(3, ! defined $dbh->{psize}) ; +ok(4, ! defined $dbh->{flags}) ; +ok(5, ! defined $dbh->{lorder}) ; +ok(6, ! defined $dbh->{reclen}) ; +ok(7, ! defined $dbh->{bfname}) ; + +$dbh->{bval} = 3000 ; +ok(8, $dbh->{bval} == 3000 ); + +$dbh->{cachesize} = 9000 ; +ok(9, $dbh->{cachesize} == 9000 ); + +$dbh->{psize} = 400 ; +ok(10, $dbh->{psize} == 400 ); + +$dbh->{flags} = 65 ; +ok(11, $dbh->{flags} == 65 ); + +$dbh->{lorder} = 123 ; +ok(12, $dbh->{lorder} == 123 ); + +$dbh->{reclen} = 1234 ; +ok(13, $dbh->{reclen} == 1234 ); + +$dbh->{bfname} = 1234 ; +ok(14, $dbh->{bfname} == 1234 ); + + +# Check that an invalid entry is caught both for store & fetch +eval '$dbh->{fred} = 1234' ; +ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ ); +eval 'my $q = $dbh->{fred}' ; +ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ ); + +# Now check the interface to RECNOINFO + +my $X ; +my @h ; +ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; + +ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640) + || $^O eq 'MSWin32' || $^O eq 'amigaos') ; + +#my $l = @h ; +my $l = $X->length ; +ok(19, ($FA ? @h == 0 : !$l) ); + +my @data = qw( a b c d ever f g h i j k longername m n o p) ; + +$h[0] = shift @data ; +ok(20, $h[0] eq 'a' ); + +my $ i; +foreach (@data) + { $h[++$i] = $_ } + +unshift (@data, 'a') ; + +ok(21, defined $h[1] ); +ok(22, ! defined $h[16] ); +ok(23, $FA ? @h == @data : $X->length == @data ); + + +# Overwrite an entry & check fetch it +$h[3] = 'replaced' ; +$data[3] = 'replaced' ; +ok(24, $h[3] eq 'replaced' ); + +#PUSH +my @push_data = qw(added to the end) ; +($FA ? push(@h, @push_data) : $X->push(@push_data)) ; +push (@data, @push_data) ; +ok(25, $h[++$i] eq 'added' ); +ok(26, $h[++$i] eq 'to' ); +ok(27, $h[++$i] eq 'the' ); +ok(28, $h[++$i] eq 'end' ); + +# POP +my $popped = pop (@data) ; +my $value = ($FA ? pop @h : $X->pop) ; +ok(29, $value eq $popped) ; + +# SHIFT +$value = ($FA ? shift @h : $X->shift) ; +my $shifted = shift @data ; +ok(30, $value eq $shifted ); + +# UNSHIFT + +# empty list +($FA ? unshift @h : $X->unshift) ; +ok(31, ($FA ? @h == @data : $X->length == @data )); + +my @new_data = qw(add this to the start of the array) ; +$FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ; +unshift (@data, @new_data) ; +ok(32, $FA ? @h == @data : $X->length == @data ); +ok(33, $h[0] eq "add") ; +ok(34, $h[1] eq "this") ; +ok(35, $h[2] eq "to") ; +ok(36, $h[3] eq "the") ; +ok(37, $h[4] eq "start") ; +ok(38, $h[5] eq "of") ; +ok(39, $h[6] eq "the") ; +ok(40, $h[7] eq "array") ; +ok(41, $h[8] eq $data[8]) ; + +# SPLICE + +# Now both arrays should be identical + +my $ok = 1 ; +my $j = 0 ; +foreach (@data) +{ + $ok = 0, last if $_ ne $h[$j ++] ; +} +ok(42, $ok ); + +# Neagtive subscripts + +# get the last element of the array +ok(43, $h[-1] eq $data[-1] ); +ok(44, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] ); + +# get the first element using a negative subscript +eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ; +ok(45, $@ eq "" ); +ok(46, $h[0] eq "abcd" ); + +# now try to read before the start of the array +eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ; +ok(47, $@ =~ '^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); + +unlink $Dfile; + + +{ + # Check bval defaults to \n + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + ok(48, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + untie @h ; + my $x = docat($Dfile) ; + unlink $Dfile; + ok(49, $x eq "abc\ndef\n\nghi\n") ; +} + +{ + # Change bval + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + $dbh->{bval} = "-" ; + ok(50, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + untie @h ; + my $x = docat($Dfile) ; + unlink $Dfile; + my $ok = ($x eq "abc-def--ghi-") ; + bad_one() unless $ok ; + ok(51, $ok) ; +} + +{ + # Check R_FIXEDLEN with default bval (space) + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + $dbh->{flags} = R_FIXEDLEN ; + $dbh->{reclen} = 5 ; + ok(52, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + untie @h ; + my $x = docat($Dfile) ; + unlink $Dfile; + my $ok = ($x eq "abc def ghi ") ; + bad_one() unless $ok ; + ok(53, $ok) ; +} + +{ + # Check R_FIXEDLEN with user-defined bval + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + $dbh->{flags} = R_FIXEDLEN ; + $dbh->{bval} = "-" ; + $dbh->{reclen} = 5 ; + ok(54, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + untie @h ; + my $x = docat($Dfile) ; + unlink $Dfile; + my $ok = ($x eq "abc--def-------ghi--") ; + bad_one() unless $ok ; + ok(55, $ok) ; +} + +{ + # check that attempting to tie an associative array to a DB_RECNO will fail + + my $filename = "xyz" ; + my %x ; + eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ; + ok(56, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ; + unlink $filename ; +} + +{ + # sub-class test + + package Another ; + + use warnings ; + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use warnings ; + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(57, $@ eq "") ; + my @h ; + my $X ; + eval ' + $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); + ' ; + + main::ok(58, $@ eq "") ; + + my $ret = eval '$h[3] = 3 ; return $h[3] ' ; + main::ok(59, $@ eq "") ; + main::ok(60, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ; + main::ok(61, $@ eq "") ; + main::ok(62, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(63, $@ eq "" ) ; + main::ok(64, $ret == 1) ; + + $ret = eval '$X->A_new_method(1) ' ; + main::ok(65, $@ eq "") ; + main::ok(66, $ret eq "[[11]]") ; + + undef $X; + untie(@h); + unlink "SubDB.pm", "recno.tmp" ; + +} + +{ + + # test $# + my $self ; + unlink $Dfile; + ok(67, $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(68, $FA ? $#h == 3 : $self->length() == 4) ; + undef $self ; + untie @h ; + my $x = docat($Dfile) ; + ok(69, $x eq "abc\ndef\nghi\njkl\n") ; + + # $# sets array to same length + ok(70, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + if ($FA) + { $#h = 3 } + else + { $self->STORESIZE(4) } + ok(71, $FA ? $#h == 3 : $self->length() == 4) ; + undef $self ; + untie @h ; + $x = docat($Dfile) ; + ok(72, $x eq "abc\ndef\nghi\njkl\n") ; + + # $# sets array to bigger + ok(73, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + if ($FA) + { $#h = 6 } + else + { $self->STORESIZE(7) } + ok(74, $FA ? $#h == 6 : $self->length() == 7) ; + undef $self ; + untie @h ; + $x = docat($Dfile) ; + ok(75, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ; + + # $# sets array smaller + ok(76, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + if ($FA) + { $#h = 2 } + else + { $self->STORESIZE(3) } + ok(77, $FA ? $#h == 2 : $self->length() == 3) ; + undef $self ; + untie @h ; + $x = docat($Dfile) ; + ok(78, $x eq "abc\ndef\nghi\n") ; + + unlink $Dfile; + + +} + +{ + # DBM Filter tests + use warnings ; + use strict ; + my (@h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(79, $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 = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h[0] = "joe" ; + # fk sk fv sv + ok(80, checkOutput( "", 0, "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(81, $h[0] eq "joe"); + # fk sk fv sv + ok(82, checkOutput( "", 0, "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(83, $db->FIRSTKEY() == 0) ; + # fk sk fv sv + ok(84, checkOutput( 0, "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { ++ $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ *= 2 ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[1] = "Joe" ; + # fk sk fv sv + ok(85, checkOutput( "", 2, "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(86, $h[1] eq "[Jxe]"); + # fk sk fv sv + ok(87, checkOutput( "", 2, "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(88, $db->FIRSTKEY() == 1) ; + # fk sk fv sv + ok(89, checkOutput( 1, "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[0] = "joe" ; + ok(90, checkOutput( "", 0, "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(91, $h[0] eq "joe"); + ok(92, checkOutput( "", 0, "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(93, $db->FIRSTKEY() == 0) ; + ok(94, checkOutput( 0, "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[0] = "joe" ; + ok(95, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(96, $h[0] eq "joe"); + ok(97, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(98, $db->FIRSTKEY() == 0) ; + ok(99, checkOutput( "", "", "", "")) ; + + undef $db ; + untie @h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use warnings ; + use strict ; + my (@h, $db) ; + + unlink $Dfile; + ok(100, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h[0] = "joe" ; + ok(101, $result{"store key"} eq "store key - 1: [0]"); + ok(102, $result{"store value"} eq "store value - 1: [joe]"); + ok(103, ! defined $result{"fetch key"} ); + ok(104, ! defined $result{"fetch value"} ); + ok(105, $_ eq "original") ; + + ok(106, $db->FIRSTKEY() == 0 ) ; + ok(107, $result{"store key"} eq "store key - 1: [0]"); + ok(108, $result{"store value"} eq "store value - 1: [joe]"); + ok(109, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(110, ! defined $result{"fetch value"} ); + ok(111, $_ eq "original") ; + + $h[7] = "john" ; + ok(112, $result{"store key"} eq "store key - 2: [0 7]"); + ok(113, $result{"store value"} eq "store value - 2: [joe john]"); + ok(114, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(115, ! defined $result{"fetch value"} ); + ok(116, $_ eq "original") ; + + ok(117, $h[0] eq "joe"); + ok(118, $result{"store key"} eq "store key - 3: [0 7 0]"); + ok(119, $result{"store value"} eq "store value - 2: [joe john]"); + ok(120, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(121, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(122, $_ eq "original") ; + + undef $db ; + untie @h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use warnings ; + use strict ; + my (@h, $db) ; + unlink $Dfile; + + ok(123, $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(124, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie @h; + unlink $Dfile; +} + + +{ + # Examples from the POD + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + use warnings FATAL => qw(all); + use strict ; + use DB_File ; + + my $filename = "text" ; + unlink $filename ; + + my @h ; + my $x = tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file 'text': $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + $FA ? push @h, "green", "black" + : $x->push("green", "black") ; + + my $elements = $FA ? scalar @h : $x->length ; + print "The array contains $elements entries\n" ; + + my $last = $FA ? pop @h : $x->pop ; + print "popped $last\n" ; + + $FA ? unshift @h, "white" + : $x->unshift("white") ; + my $first = $FA ? shift @h : $x->shift ; + print "shifted $first\n" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + # use a negative index + print "The last element is $h[-1]\n" ; + print "The 2nd last element is $h[-2]\n" ; + + undef $x ; + untie @h ; + + unlink $filename ; + } + + ok(125, docat_del($file) eq <<'EOM') ; +The array contains 5 entries +popped black +shifted white +Element 1 Exists with value blue +The last element is green +The 2nd last element is yellow +EOM + + my $save_output = "xyzt" ; + { + my $redirect = new Redirect $save_output ; + + use warnings FATAL => qw(all); + use strict ; + use vars qw(@h $H $file $i) ; + use DB_File ; + use Fcntl ; + + $file = "text" ; + + unlink $file ; + + $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file $file: $!\n" ; + + # first create a text file to play with + $h[0] = "zero" ; + $h[1] = "one" ; + $h[2] = "two" ; + $h[3] = "three" ; + $h[4] = "four" ; + + + # Print the records in order. + # + # The length method is needed here because evaluating a tied + # array in a scalar context does not return the number of + # elements in the array. + + print "\nORIGINAL\n" ; + foreach $i (0 .. $H->length - 1) { + print "$i: $h[$i]\n" ; + } + + # use the push & pop methods + $a = $H->pop ; + $H->push("last") ; + print "\nThe last record was [$a]\n" ; + + # and the shift & unshift methods + $a = $H->shift ; + $H->unshift("first") ; + print "The first record was [$a]\n" ; + + # Use the API to add a new record after record 2. + $i = 2 ; + $H->put($i, "Newbie", R_IAFTER) ; + + # and a new record before record 1. + $i = 1 ; + $H->put($i, "New One", R_IBEFORE) ; + + # delete record 3 + $H->del(3) ; + + # now print the records in reverse order + print "\nREVERSE\n" ; + for ($i = $H->length - 1 ; $i >= 0 ; -- $i) + { print "$i: $h[$i]\n" } + + # same again, but use the API functions instead + print "\nREVERSE again\n" ; + my ($s, $k, $v) = (0, 0, 0) ; + for ($s = $H->seq($k, $v, R_LAST) ; + $s == 0 ; + $s = $H->seq($k, $v, R_PREV)) + { print "$k: $v\n" } + + undef $H ; + untie @h ; + + unlink $file ; + } + + ok(126, docat_del($save_output) eq <<'EOM') ; + +ORIGINAL +0: zero +1: one +2: two +3: three +4: four + +The last record was [four] +The first record was [zero] + +REVERSE +5: last +4: three +3: Newbie +2: one +1: New One +0: first + +REVERSE again +5: last +4: three +3: Newbie +2: one +1: New One +0: first +EOM + +} + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my @h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + $h[0] = undef; + ok(127, $a eq "") ; + untie @h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + unlink $Dfile; + my @h ; + + tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + @h = (); ; + ok(128, $a eq "") ; + untie @h ; + unlink $Dfile; +} + +exit ; diff --git a/bdb/perl.DB_File/typemap b/bdb/perl.DB_File/typemap new file mode 100644 index 00000000000..55439ee76d9 --- /dev/null +++ b/bdb/perl.DB_File/typemap @@ -0,0 +1,44 @@ +# typemap for Perl 5 interface to Berkeley +# +# written by Paul Marquess <Paul.Marquess@btinternet.com> +# last modified 10th December 2000 +# version 1.74 +# +#################################### DB SECTION +# +# + +u_int T_U_INT +DB_File T_PTROBJ +DBT T_dbtdatum +DBTKEY T_dbtkeydatum + +INPUT +T_dbtkeydatum + 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); + } +T_dbtdatum + ckFilter($arg, filter_store_value, \"filter_store_value\"); + DBT_clear($var) ; + if (SvOK($arg)) { + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + } + +OUTPUT + +T_dbtkeydatum + OutputKey($arg, $var) +T_dbtdatum + OutputValue($arg, $var) +T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/bdb/perl.DB_File/version.c b/bdb/perl.DB_File/version.c new file mode 100644 index 00000000000..82b3e8b27b9 --- /dev/null +++ b/bdb/perl.DB_File/version.c @@ -0,0 +1,81 @@ +/* + + version.c -- Perl 5 interface to Berkeley DB + + written by Paul Marquess <Paul.Marquess@btinternet.com> + last modified 16th January 2000 + version 1.73 + + All comments/suggestions/problems are welcome + + Copyright (c) 1995-2001 Paul Marquess. All rights reserved. + This program is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + + Changes: + 1.71 - Support for Berkeley DB version 3. + Support for Berkeley DB 2/3's backward compatability mode. + 1.72 - No change. + 1.73 - Added support for threading + 1.74 - Added Perl core patch 7801. + + +*/ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <db.h> + +void +#ifdef CAN_PROTOTYPE +__getBerkeleyDBInfo(void) +#else +__getBerkeleyDBInfo() +#endif +{ +#ifdef dTHX + dTHX; +#endif + SV * version_sv = perl_get_sv("DB_File::db_version", GV_ADD|GV_ADDMULTI) ; + SV * ver_sv = perl_get_sv("DB_File::db_ver", GV_ADD|GV_ADDMULTI) ; + SV * compat_sv = perl_get_sv("DB_File::db_185_compat", GV_ADD|GV_ADDMULTI) ; + +#ifdef DB_VERSION_MAJOR + int Major, Minor, Patch ; + + (void)db_version(&Major, &Minor, &Patch) ; + + /* Check that the versions of db.h and libdb.a are the same */ + if (Major != DB_VERSION_MAJOR || Minor != DB_VERSION_MINOR + || Patch != DB_VERSION_PATCH) + croak("\nDB_File needs compatible versions of libdb & db.h\n\tyou have db.h version %d.%d.%d and libdb version %d.%d.%d\n", + DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH, + Major, Minor, Patch) ; + + /* check that libdb is recent enough -- we need 2.3.4 or greater */ + if (Major == 2 && (Minor < 3 || (Minor == 3 && Patch < 4))) + croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n", + Major, Minor, Patch) ; + + { + char buffer[40] ; + sprintf(buffer, "%d.%d", Major, Minor) ; + sv_setpv(version_sv, buffer) ; + sprintf(buffer, "%d.%03d%03d", Major, Minor, Patch) ; + sv_setpv(ver_sv, buffer) ; + } + +#else /* ! DB_VERSION_MAJOR */ + sv_setiv(version_sv, 1) ; + sv_setiv(ver_sv, 1) ; +#endif /* ! DB_VERSION_MAJOR */ + +#ifdef COMPAT185 + sv_setiv(compat_sv, 1) ; +#else /* ! COMPAT185 */ + sv_setiv(compat_sv, 0) ; +#endif /* ! COMPAT185 */ + +} |