diff options
| author | Todd Rinaldo <toddr@cpan.org> | 2020-09-16 10:01:31 -0500 |
|---|---|---|
| committer | ℕicolas ℝ <nicolas@atoomic.org> | 2020-09-16 10:33:54 -0600 |
| commit | 114a1f36b0fda316047d5b5853e6731ba3192768 (patch) | |
| tree | 532a8f6f640c6f45a250fba3fe9f487d41151778 /cpan/DB_File | |
| parent | 6ef4979f7b783b5115cfd418f20c43c5d743b374 (diff) | |
| download | perl-114a1f36b0fda316047d5b5853e6731ba3192768.tar.gz | |
Update DB_File to CPAN version 1.854
[DELTA]
1.854 16 September 2020
* Prefer direct notation over indirect (#4)
* Make hint/BS snippets strict compliant.
* trim whitespace
Diffstat (limited to 'cpan/DB_File')
| -rw-r--r-- | cpan/DB_File/DB_File.pm | 198 | ||||
| -rw-r--r-- | cpan/DB_File/DB_File.xs | 5 | ||||
| -rw-r--r-- | cpan/DB_File/DB_File_BS | 1 | ||||
| -rw-r--r-- | cpan/DB_File/Makefile.PL | 60 | ||||
| -rw-r--r-- | cpan/DB_File/config.in | 8 | ||||
| -rw-r--r-- | cpan/DB_File/dbinfo | 4 | ||||
| -rw-r--r-- | cpan/DB_File/hints/bitrig.pl | 1 | ||||
| -rw-r--r-- | cpan/DB_File/hints/dynixptx.pl | 2 | ||||
| -rw-r--r-- | cpan/DB_File/hints/minix.pl | 1 | ||||
| -rw-r--r-- | cpan/DB_File/hints/netbsd.pl | 1 | ||||
| -rw-r--r-- | cpan/DB_File/hints/openbsd.pl | 1 | ||||
| -rw-r--r-- | cpan/DB_File/hints/sco.pl | 1 | ||||
| -rw-r--r-- | cpan/DB_File/t/db-btree.t | 260 | ||||
| -rw-r--r-- | cpan/DB_File/t/db-hash.t | 132 | ||||
| -rw-r--r-- | cpan/DB_File/t/db-recno.t | 206 | ||||
| -rw-r--r-- | cpan/DB_File/t/db-threads.t | 2 | ||||
| -rw-r--r-- | cpan/DB_File/version.c | 22 |
17 files changed, 454 insertions, 451 deletions
diff --git a/cpan/DB_File/DB_File.pm b/cpan/DB_File/DB_File.pm index a732ff41e0..e5e0d866f4 100644 --- a/cpan/DB_File/DB_File.pm +++ b/cpan/DB_File/DB_File.pm @@ -1,4 +1,4 @@ -# DB_File.pm -- Perl 5 interface to Berkeley DB +# DB_File.pm -- Perl 5 interface to Berkeley DB # # Written by Paul Marquess (pmqs@cpan.org) # @@ -30,21 +30,21 @@ sub TIEHASH { my $pkg = shift ; - bless { VALID => { + bless { VALID => { bsize => 1, ffactor => 1, nelem => 1, cachesize => 1, hash => 2, lorder => 1, - }, + }, GOT => {} }, $pkg ; } -sub FETCH -{ +sub FETCH +{ my $self = shift ; my $key = shift ; @@ -55,7 +55,7 @@ sub FETCH } -sub STORE +sub STORE { my $self = shift ; my $key = shift ; @@ -65,17 +65,17 @@ sub STORE if ( $type ) { - croak "Key '$key' not associated with a code reference" + croak "Key '$key' not associated with a code reference" if $type == 2 && !ref $value && ref $value ne 'CODE'; $self->{GOT}{$key} = $value ; return ; } - + my $pkg = ref $self ; croak "${pkg}::STORE - Unknown element '$key'" ; } -sub DELETE +sub DELETE { my $self = shift ; my $key = shift ; @@ -85,7 +85,7 @@ sub DELETE delete $self->{GOT}{$key} ; return ; } - + my $pkg = ref $self ; croak "DB_File::HASHINFO::DELETE - Unknown element '$key'" ; } @@ -121,7 +121,7 @@ sub TIEHASH { my $pkg = shift ; - bless { VALID => { map {$_, 1} + bless { VALID => { map {$_, 1} qw( bval cachesize psize flags lorder reclen bfname ) }, GOT => {}, @@ -139,7 +139,7 @@ sub TIEHASH { my $pkg = shift ; - bless { VALID => { + bless { VALID => { flags => 1, cachesize => 1, maxkeypage => 1, @@ -163,28 +163,28 @@ our ($db_version, $use_XSLoader, $splice_end_array_no_length, $splice_end_array, use Carp; # Module not thread safe, so don't clone -sub CLONE_SKIP { 1 } +sub CLONE_SKIP { 1 } -$VERSION = "1.853" ; +$VERSION = "1.854" ; $VERSION = eval $VERSION; # needed for dev releases { local $SIG{__WARN__} = sub {$splice_end_array_no_length = join(" ",@_);}; my @a =(1); splice(@a, 3); - $splice_end_array_no_length = + $splice_end_array_no_length = ($splice_end_array_no_length =~ /^splice\(\) offset past end of array at /); -} +} { local $SIG{__WARN__} = sub {$splice_end_array = join(" ", @_);}; my @a =(1); splice(@a, 3, 1); - $splice_end_array = + $splice_end_array = ($splice_end_array =~ /^splice\(\) offset past end of array at /); -} +} #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 ; +$DB_BTREE = DB_File::BTREEINFO->new(); +$DB_HASH = DB_File::HASHINFO->new(); +$DB_RECNO = DB_File::RECNOINFO->new(); require Tie::Hash; require Exporter; @@ -201,7 +201,7 @@ BEGIN { push @ISA, qw(Tie::Hash Exporter); @EXPORT = qw( - $DB_BTREE $DB_HASH $DB_RECNO + $DB_BTREE $DB_HASH $DB_RECNO BTREEMAGIC BTREEVERSION @@ -242,7 +242,7 @@ sub AUTOLOAD { no strict 'refs'; *{$AUTOLOAD} = sub { $val }; goto &{$AUTOLOAD}; -} +} eval { @@ -256,7 +256,7 @@ eval { if ($use_XSLoader) { XSLoader::load("DB_File", $VERSION)} else - { bootstrap DB_File $VERSION } + { DB_File->bootstrap( $VERSION ) } sub tie_hash_or_array { @@ -264,22 +264,22 @@ sub tie_hash_or_array my $tieHASH = ( (caller(1))[3] =~ /TIEHASH/ ) ; use File::Spec; - $arg[1] = File::Spec->rel2abs($arg[1]) + $arg[1] = File::Spec->rel2abs($arg[1]) if defined $arg[1] ; - $arg[4] = tied %{ $arg[4] } + $arg[4] = tied %{ $arg[4] } if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ; $arg[2] = O_CREAT()|O_RDWR() if @arg >=3 && ! defined $arg[2]; $arg[3] = 0666 if @arg >=4 && ! defined $arg[3]; - # make recno in Berkeley DB version 2 (or better) work like + # make recno in Berkeley DB version 2 (or better) work like # recno in version 1. if ($db_version >= 4 and ! $tieHASH) { $arg[2] |= O_CREAT(); } - if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and + 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 ; @@ -299,20 +299,20 @@ sub TIEARRAY tie_hash_or_array(@_) ; } -sub CLEAR +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); + my $s = $self->del($key); } } @@ -333,7 +333,7 @@ sub STORESIZE $self->put($length-1, "") ; } } - + sub SPLICE { @@ -348,15 +348,15 @@ sub SPLICE my $length = @_ ? shift : 0; # Carping about definedness comes _after_ the OFFSET sanity check. # This is so we get the same error messages as Perl's splice(). - # + # my @list = @_; my $size = $self->FETCHSIZE(); - + # 'If OFFSET is negative then it start that far from the end of # the array.' - # + # if ($offset < 0) { my $new_offset = $size + $offset; if ($new_offset < 0) { @@ -384,7 +384,7 @@ sub SPLICE # 'If LENGTH is negative, leave that many elements off the end of # the array.' - # + # if ($length < 0) { $length = $size - $offset + $length; @@ -392,7 +392,7 @@ sub SPLICE # The user must have specified a length bigger than the # length of the array passed in. But perl's splice() # doesn't catch this, it just behaves as for length=0. - # + # $length = 0; } } @@ -406,7 +406,7 @@ sub SPLICE # 'Removes the elements designated by OFFSET and LENGTH from an # array,'... - # + # my @removed = (); foreach (0 .. $length - 1) { my $old; @@ -480,13 +480,13 @@ sub SPLICE if (wantarray) { # 'In list context, returns the elements removed from the # array.' - # + # return @removed; } elsif (defined wantarray and not wantarray) { # 'In scalar context, returns the last element removed, or # undef if no elements are removed.' - # + # if (@removed) { my $last = pop @removed; return "$last"; @@ -506,7 +506,7 @@ 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); @@ -526,7 +526,7 @@ 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) ; @@ -540,7 +540,7 @@ sub get_dup { croak "Usage: \$db->get_dup(key [,flag])\n" unless @_ == 2 or @_ == 3 ; - + my $db = shift ; my $key = shift ; my $flag = shift ; @@ -551,13 +551,13 @@ sub get_dup 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) @@ -567,9 +567,9 @@ sub get_dup } else { ++ $counter } - + } - + return ($wantarray ? ($flag ? %values : @values) : $counter) ; } @@ -723,7 +723,7 @@ 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, + 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 @@ -749,7 +749,7 @@ 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>. +C<ffactor>, C<hash>, C<lorder> and C<nelem>. To change one of these elements, just assign to it like this: @@ -763,7 +763,7 @@ 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 = DB_File::HASHINFO->new(); $a->{'bsize'} ; $a->{'cachesize'} ; $a->{'ffactor'}; @@ -771,7 +771,7 @@ for DB_HASH, DB_BTREE and DB_RECNO respectively. $a->{'lorder'} ; $a->{'nelem'} ; - $b = new DB_File::BTREEINFO ; + $b = DB_File::BTREEINFO->new(); $b->{'flags'} ; $b->{'cachesize'} ; $b->{'maxkeypage'} ; @@ -781,7 +781,7 @@ for DB_HASH, DB_BTREE and DB_RECNO respectively. $b->{'prefix'} ; $b->{'lorder'} ; - $c = new DB_File::RECNOINFO ; + $c = DB_File::RECNOINFO->new(); $c->{'bval'} ; $c->{'cachesize'} ; $c->{'psize'} ; @@ -795,7 +795,7 @@ 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 = DB_File::HASHINFO->new(); $a->{'cachesize'} = 12345 ; tie %y, 'DB_File', "filename", $flags, 0777, $a ; @@ -826,7 +826,7 @@ to Perl subs. Below are templates for each of the subs: { my ($key, $key2) = @_ ; ... - # return number of bytes of $key2 which are + # return number of bytes of $key2 which are # necessary to determine that it is greater than $key1 return $bytes ; } @@ -885,7 +885,7 @@ contents of the database. our (%h, $k, $v) ; unlink "fruit" ; - tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0666, $DB_HASH + tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0666, $DB_HASH or die "Cannot open file 'fruit': $!\n"; # Add a few key/value pairs to the file @@ -946,7 +946,7 @@ insensitive compare function will be used. $DB_BTREE->{'compare'} = \&Compare ; unlink "tree" ; - tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0666, $DB_BTREE + tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0666, $DB_BTREE or die "Cannot open file 'tree': $!\n" ; # Add a key/value pair to the file @@ -1016,9 +1016,9 @@ possible to recover the original keys in sets of keys that compared as equal). -=back +=back -=head2 Handling Duplicate Keys +=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 @@ -1040,7 +1040,7 @@ code: # Enable duplicate records $DB_BTREE->{'flags'} = R_DUP ; - tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE or die "Cannot open $filename: $!\n"; # Add some key/value pairs to the file @@ -1095,7 +1095,7 @@ Here is the script above rewritten using the C<seq> API method. # Enable duplicate records $DB_BTREE->{'flags'} = R_DUP ; - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE or die "Cannot open $filename: $!\n"; # Add some key/value pairs to the file @@ -1127,7 +1127,7 @@ that prints: 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 +To make life easier when dealing with duplicate keys, B<DB_File> comes with a few utility methods. =head2 The get_dup() Method @@ -1166,7 +1166,7 @@ this: # Enable duplicate records $DB_BTREE->{'flags'} = R_DUP ; - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE or die "Cannot open $filename: $!\n"; my $cnt = $x->get_dup("Wall") ; @@ -1200,7 +1200,7 @@ and it will print: $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 +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: @@ -1216,13 +1216,13 @@ Assuming the database from the previous example: # Enable duplicate records $DB_BTREE->{'flags'} = R_DUP ; - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE or die "Cannot open $filename: $!\n"; - $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; print "Larry Wall is $found there\n" ; - $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; + $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; print "Harry Wall is $found there\n" ; undef $x ; @@ -1255,12 +1255,12 @@ Again assuming the existence of the C<tree> database # Enable duplicate records $DB_BTREE->{'flags'} = R_DUP ; - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE or die "Cannot open $filename: $!\n"; $x->del_dup("Wall", "Larry") ; - $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; print "Larry Wall is $found there\n" ; undef $x ; @@ -1270,7 +1270,7 @@ prints this Larry Wall is not there -=head2 Matching Partial Keys +=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 @@ -1314,7 +1314,7 @@ and print the first matching key/value pair given a partial key. # Add some key/value pairs to the file $h{'mouse'} = 'mickey' ; $h{'Wall'} = 'Larry' ; - $h{'Walls'} = 'Brick' ; + $h{'Walls'} = 'Brick' ; $h{'Smith'} = 'John' ; @@ -1393,8 +1393,8 @@ as a delimiter. =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 +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 ; @@ -1405,7 +1405,7 @@ L<Extra RECNO Methods> for a workaround). unlink $filename ; my @h ; - tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_RECNO + tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_RECNO or die "Cannot open file 'text': $!\n" ; # Add a few key/value pairs to the file @@ -1488,7 +1488,7 @@ Returns a splice of the array. =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 +described above. It also makes use of the API interface directly (see L<THE API INTERFACE>). use warnings ; @@ -1501,7 +1501,7 @@ L<THE API INTERFACE>). unlink $file ; - $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0666, $DB_RECNO + $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0666, $DB_RECNO or die "Cannot open file $file: $!\n" ; # first create a text file to play with @@ -1516,7 +1516,7 @@ L<THE API INTERFACE>). # # 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. + # elements in the array. print "\nORIGINAL\n" ; foreach $i (0 .. $H->length - 1) { @@ -1552,8 +1552,8 @@ L<THE API INTERFACE>). # 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 ; + for ($s = $H->seq($k, $v, R_LAST) ; + $s == 0 ; $s = $H->seq($k, $v, R_PREV)) { print "$k: $v\n" } @@ -1600,7 +1600,7 @@ Rather than iterating through the array, C<@h> like this: it is necessary to use either this: - foreach $i (0 .. $H->length - 1) + foreach $i (0 .. $H->length - 1) or this: @@ -1635,10 +1635,10 @@ as B<DB_File> methods directly like this: 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. +destroyed. use DB_File ; - $db = tie %hash, "DB_File", "filename" + $db = tie %hash, "DB_File", "filename" or die "Cannot tie filename: $!" ; ... undef $db ; @@ -1685,7 +1685,7 @@ code will probably not do what you expect: $X->seq($key, $value, R_FIRST) ; # this line will modify the cursor - $count = scalar keys %x ; + $count = scalar keys %x ; # Get the second key/value pair. # oops, it didn't, it got the last key/value pair! @@ -1697,7 +1697,7 @@ The code above can be rearranged to get around the problem, like this: or die "Cannot tie $filename: $!" ; # this line will modify the cursor - $count = scalar keys %x ; + $count = scalar keys %x ; # Get the first key/value pair and set the cursor $X->seq($key, $value, R_FIRST) ; @@ -1788,7 +1788,7 @@ Using the low-level API defined below. =item 2. -Using the L<DBM_Filter> module. +Using the L<DBM_Filter> module. This module hides the complexity of the API defined below and comes with a number of "canned" filters that cover some of the common use-cases. @@ -1872,7 +1872,7 @@ fix very easily. my $filename = "filt" ; unlink $filename ; - my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH + my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH or die "Cannot open $filename: $!\n" ; # Install DBM Filters @@ -1915,7 +1915,7 @@ Here is a DBM Filter that does it: unlink $filename ; - my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH + 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", $_) } ) ; @@ -1929,7 +1929,7 @@ 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 +=head1 HINTS AND TIPS =head2 Locking: The Trouble with fd @@ -1940,7 +1940,7 @@ 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. +The locking technique went like this. $db = tie(%db, 'DB_File', 'foo.db', O_CREAT|O_RDWR, 0644) || die "dbcreat foo.db $!"; @@ -2031,7 +2031,7 @@ 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> +=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 @@ -2041,7 +2041,7 @@ 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> +=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 @@ -2113,7 +2113,7 @@ F<authors/id/TOMC/scripts/nshist.gz>). =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>. +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. @@ -2215,12 +2215,12 @@ B<DBM_Filter> (see L<DBM_Filter>) that was designed to deal with this situation. The example below shows what you need if I<both> the key and value are -expected to be in UTF-8. +expected to be in UTF-8. use DB_File; - use DBM_Filter; + use DBM_Filter; - my $db = tie %h, 'DB_File', '/tmp/try.db', O_CREAT|O_RDWR, 0666, $DB_BTREE; + my $db = tie %h, 'DB_File', '/tmp/try.db', O_CREAT|O_RDWR, 0666, $DB_BTREE; $db->Filter_Key_Push('utf8'); $db->Filter_Value_Push('utf8'); @@ -2240,7 +2240,7 @@ Here are a couple of possibilities: =item 1. -Attempting to reopen a database without closing it. +Attempting to reopen a database without closing it. =item 2. @@ -2248,7 +2248,7 @@ Using the O_WRONLY flag. =back -=head2 What does "Bareword 'DB_File' not allowed" mean? +=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. @@ -2262,7 +2262,7 @@ Consider this script: Running it produces the error in question: - Bareword "DB_File" not allowed while "strict subs" in use + 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: @@ -2300,7 +2300,7 @@ suggest any enhancements, I would welcome your comments. =head1 SUPPORT -General feedback/questions/bug reports should be sent to +General feedback/questions/bug reports should be sent to L<https://github.com/pmqs/DB_File/issues> (preferred) or L<https://rt.cpan.org/Public/Dist/Display.html?Name=DB_File>. @@ -2336,7 +2336,7 @@ copyright and its own license. Please take the time to read it. Here are a few words taken from the Berkeley DB FAQ (at L<http://www.oracle.com/technology/products/berkeley-db/db/index.html>) regarding the license: - Do I have to license DB to use it in Perl scripts? + 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 diff --git a/cpan/DB_File/DB_File.xs b/cpan/DB_File/DB_File.xs index ab95369b25..7b473958ee 100644 --- a/cpan/DB_File/DB_File.xs +++ b/cpan/DB_File/DB_File.xs @@ -1527,12 +1527,12 @@ SV * sv ; status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, Flags, mode) ; #endif - Trace(("open returned %d %s\n", status, db_strerror(status))) ; + Trace(("open returned %d %s\n", status, db_strerror(status))) ; if (status == 0) { status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, 0) ; - Trace(("cursor returned %d %s\n", status, db_strerror(status))) ; + Trace(("cursor returned %d %s\n", status, db_strerror(status))) ; } if (status) @@ -2066,4 +2066,3 @@ filter_store_value(db, code) SV * RETVAL = &PL_sv_undef ; CODE: DBM_setFilter(db->filter_store_value, code) ; - diff --git a/cpan/DB_File/DB_File_BS b/cpan/DB_File/DB_File_BS index 9282c49881..5d870684cf 100644 --- a/cpan/DB_File/DB_File_BS +++ b/cpan/DB_File/DB_File_BS @@ -1,4 +1,5 @@ # NeXT needs /usr/lib/libposix.a to load along with DB_File.so +no strict 'vars'; if ( $dlsrc eq "dl_next.xs" ) { @DynaLoader::dl_resolve_using = ( '/usr/lib/libposix.a' ); } diff --git a/cpan/DB_File/Makefile.PL b/cpan/DB_File/Makefile.PL index 774c219f5a..b149268295 100644 --- a/cpan/DB_File/Makefile.PL +++ b/cpan/DB_File/Makefile.PL @@ -4,8 +4,8 @@ use strict ; use ExtUtils::MakeMaker 5.16 ; use Config ; -die "DB_File needs Perl 5.8.3 or better. This is $]\n" - if $] < 5.008003; +die "DB_File needs Perl 5.8.3 or better. This is $]\n" + if $] < 5.008003; my $VER_INFO ; my $LIB_DIR ; @@ -41,7 +41,7 @@ $OS2 = "-DOS2" if $Config{'osname'} eq 'os2' ; my $WALL = '' ; #$WALL = ' -Wall '; -# Only want ppport.h t to be used by DB_File.xs when not +# Only want ppport.h t to be used by DB_File.xs when not # building this module with the perl source distribution. my $CORE = $ENV{PERL_CORE} ? '' : '-D_NOT_CORE'; @@ -54,8 +54,8 @@ WriteMakefile( XSPROTOARG => '-noprototypes', DEFINE => "$CORE $OS2 $VER_INFO $COMPAT185 $WALL", OBJECT => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)', - ((ExtUtils::MakeMaker->VERSION() gt '6.30') - ? ('LICENSE' => 'perl') + ((ExtUtils::MakeMaker->VERSION() gt '6.30') + ? ('LICENSE' => 'perl') : () ), ( @@ -64,9 +64,9 @@ WriteMakefile( AUTHOR => 'Paul Marquess <pmqs@cpan.org>') : () ), - - ($] < 5.008 || $] > 5.011) - ? (INSTALLDIRS => 'site') + + ($] < 5.008 || $] > 5.011) + ? (INSTALLDIRS => 'site') : (INSTALLDIRS => 'perl'), #OPTIMIZE => '-g', @@ -77,13 +77,13 @@ WriteMakefile( 'dist' => { COMPRESS => 'gzip', SUFFIX => 'gz', DIST_DEFAULT => 'MyDoubleCheck tardist'}, - ( eval { ExtUtils::MakeMaker->VERSION(6.46) } + ( eval { ExtUtils::MakeMaker->VERSION(6.46) } ? ( META_MERGE => { - + "meta-spec" => { version => 2 }, - + resources => { - + bugtracker => { web => 'https://github.com/pmqs/DB_File/issues' }, @@ -94,10 +94,10 @@ WriteMakefile( type => 'git', url => 'git://github.com/pmqs/DB_File.git', web => 'https://github.com/pmqs/DB_File', - }, + }, }, - } - ) + } + ) : () ), @@ -159,16 +159,16 @@ if (eval {require ExtUtils::Constant; 1}) { die "The following names are missing from \@EXPORT in DB_File.pm\n" . "\t$missing\n" ; } - + ExtUtils::Constant::WriteConstants( NAME => 'DB_File', NAMES => \@names, C_FILE => 'constants.h', XS_FILE => 'constants.xs', - + ); -} +} else { use File::Copy; copy ('fallback.h', 'constants.h') @@ -186,10 +186,10 @@ sub MY::libscan my $path = shift ; return undef - if $path =~ /(~|\.bak)$/ || + if $path =~ /(~|\.bak)$/ || $path =~ /^\..*\.swp$/ ; - return $path; + return $path; } @@ -202,27 +202,27 @@ MyDoubleCheck: grep "^#DBNAME.*" config.in) >/dev/null || \ (echo config.in needs fixing ; exit 1) @echo config.in is ok - @echo + @echo @echo Checking DB_File.xs is ok for a release. @(perl -ne ' exit 1 if /^\s*#\s*define\s+TRACE/ ; ' DB_File.xs || \ (echo DB_File.xs needs fixing ; exit 1)) @echo DB_File.xs is ok - @echo + @echo @echo Checking for $$^W in files: $(my_files) @perl -ne ' \ exit 1 if /^\s*local\s*\(\s*\$$\^W\s*\)/;' $(my_files) || \ (echo found unexpected $$^W ; exit 1) @echo No $$^W found. - @echo + @echo @echo Checking for 'use vars' in files: $(my_files) @perl -ne ' \ exit 0 if /^__(DATA|END)__/; \ exit 1 if /^\s*use\s+vars/;' $(my_files) || \ (echo found unexpected "use vars"; exit 1) @echo No 'use vars' found. - @echo + @echo @echo All files are OK for a release. - @echo + @echo EOM @@ -240,7 +240,7 @@ sub ParseCONFIG print "Parsing $CONFIG...\n" ; - # DBNAME & COMPAT185 are optional, so pretend they have + # DBNAME & COMPAT185 are optional, so pretend they have # been parsed. delete $Parsed{'DBNAME'} ; delete $Parsed{'COMPAT185'} ; @@ -270,16 +270,16 @@ sub ParseCONFIG # check parsed values my @missing = () ; - die "The following keys are missing from $CONFIG file: [@missing]\n" + 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 = $ENV{'DB_FILE_NAME'} || $Info{'DBNAME'} ; - $COMPAT185 = "-DCOMPAT185 -DDB_LIBRARY_COMPATIBILITY_API" - if (defined $ENV{'DB_FILE_COMPAT185'} && + $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 ; + $Info{'COMPAT185'} =~ /^\s*(on|true|1)\s*$/i ; my $PREFIX = $Info{'PREFIX'} ; my $HASH = $Info{'HASH'} ; diff --git a/cpan/DB_File/config.in b/cpan/DB_File/config.in index d79a9505e9..1fc28e3845 100644 --- a/cpan/DB_File/config.in +++ b/cpan/DB_File/config.in @@ -32,7 +32,7 @@ LIB = /usr/local/BerkeleyDB/lib # 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. +# 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). @@ -41,7 +41,7 @@ LIB = /usr/local/BerkeleyDB/lib # 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 *)); +# int (*prefix) __P((const DBT *, const DBT *)); # # and like this in a more recent copy: # @@ -54,7 +54,7 @@ LIB = /usr/local/BerkeleyDB/lib # 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)); +# int (*hash) __P((const void *, size_t)); # # newer like this: # @@ -91,7 +91,7 @@ HASH = u_int32_t # 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/cpan/DB_File/dbinfo b/cpan/DB_File/dbinfo index c2842f6cfa..e6ba7fdefa 100644 --- a/cpan/DB_File/dbinfo +++ b/cpan/DB_File/dbinfo @@ -1,10 +1,10 @@ #!/usr/bin/perl -# Name: dbinfo -- identify berkeley DB version used to create +# Name: dbinfo -- identify berkeley DB version used to create # a database file # # Author: Paul Marquess <pmqs@cpan.org> -# Version: 1.07 +# Version: 1.07 # Date 2nd April 2011 # # Copyright (c) 1998-2020 Paul Marquess. All rights reserved. diff --git a/cpan/DB_File/hints/bitrig.pl b/cpan/DB_File/hints/bitrig.pl index 53703a0cb6..75b2e36319 100644 --- a/cpan/DB_File/hints/bitrig.pl +++ b/cpan/DB_File/hints/bitrig.pl @@ -1 +1,2 @@ +no strict 'vars'; $self->{LIBS} = ['']; diff --git a/cpan/DB_File/hints/dynixptx.pl b/cpan/DB_File/hints/dynixptx.pl index bb5ffa56e6..a2dc253da6 100644 --- a/cpan/DB_File/hints/dynixptx.pl +++ b/cpan/DB_File/hints/dynixptx.pl @@ -1,3 +1,3 @@ # Need to add an extra '-lc' to the end to work around a DYNIX/ptx bug - +no strict 'vars'; $self->{LIBS} = ['-lm -lc']; diff --git a/cpan/DB_File/hints/minix.pl b/cpan/DB_File/hints/minix.pl index 53703a0cb6..75b2e36319 100644 --- a/cpan/DB_File/hints/minix.pl +++ b/cpan/DB_File/hints/minix.pl @@ -1 +1,2 @@ +no strict 'vars'; $self->{LIBS} = ['']; diff --git a/cpan/DB_File/hints/netbsd.pl b/cpan/DB_File/hints/netbsd.pl index 53703a0cb6..75b2e36319 100644 --- a/cpan/DB_File/hints/netbsd.pl +++ b/cpan/DB_File/hints/netbsd.pl @@ -1 +1,2 @@ +no strict 'vars'; $self->{LIBS} = ['']; diff --git a/cpan/DB_File/hints/openbsd.pl b/cpan/DB_File/hints/openbsd.pl index 53703a0cb6..75b2e36319 100644 --- a/cpan/DB_File/hints/openbsd.pl +++ b/cpan/DB_File/hints/openbsd.pl @@ -1 +1,2 @@ +no strict 'vars'; $self->{LIBS} = ['']; diff --git a/cpan/DB_File/hints/sco.pl b/cpan/DB_File/hints/sco.pl index ff60440949..0bcded6559 100644 --- a/cpan/DB_File/hints/sco.pl +++ b/cpan/DB_File/hints/sco.pl @@ -1,2 +1,3 @@ # osr5 needs to explicitly link against libc to pull in some static symbols +no strict 'vars'; $self->{LIBS} = ['-ldb -lc'] if $Config{'osvers'} =~ '3\.2v5\.0\..' ; diff --git a/cpan/DB_File/t/db-btree.t b/cpan/DB_File/t/db-btree.t index 86cfb0c627..fc19e997bf 100644 --- a/cpan/DB_File/t/db-btree.t +++ b/cpan/DB_File/t/db-btree.t @@ -3,7 +3,7 @@ use warnings; use strict; use Config; - + BEGIN { if(-d "lib" && -f "TEST") { if ($Config{'extensions'} !~ /\bDB_File\b/ ) { @@ -29,7 +29,7 @@ EOM } } -use DB_File; +use DB_File; use Fcntl; use File::Temp qw(tempdir) ; @@ -41,7 +41,7 @@ sub ok { my $no = shift ; my $result = shift ; - + print "not " unless $result ; print "ok $no\n" ; } @@ -84,7 +84,7 @@ sub lexical } sub docat -{ +{ my $file = shift; local $/ = undef ; open(CAT,$file) || die "Cannot open $file: $!"; @@ -92,20 +92,20 @@ sub docat close(CAT); $result = normalise($result) ; return $result ; -} +} sub docat_del -{ +{ my $file = shift; my $result = docat($file); unlink $file ; return $result ; -} +} sub normalise { my $data = shift ; - $data =~ s#\r\n#\n#g + $data =~ s#\r\n#\n#g if $^O eq 'cygwin' ; return $data ; @@ -123,7 +123,7 @@ sub safeUntie my $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; -my $null_keys_allowed = ($DB_File::db_ver < 2.004010 +my $null_keys_allowed = ($DB_File::db_ver < 2.004010 || $DB_File::db_ver >= 3.1 ); my $TEMPDIR = tempdir( CLEANUP => 1 ); @@ -136,7 +136,7 @@ umask(0); # Check the interface to BTREEINFO -my $dbh = new DB_File::BTREEINFO ; +my $dbh = DB_File::BTREEINFO->new(); ok(1, ! defined $dbh->{flags}) ; ok(2, ! defined $dbh->{cachesize}) ; ok(3, ! defined $dbh->{psize}) ; @@ -311,11 +311,11 @@ ok(33, join(':',200..400) eq join(':',@foo) ); # Check R_NOOVERWRITE flag will make put fail when attempting to overwrite # an existing record. - + my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; ok(34, $status == 1 ); - -# check that the value of the key 'x' has not been changed by the + +# check that the value of the key 'x' has not been changed by the # previous test ok(35, $h{'x'} eq 'X' ); @@ -414,7 +414,7 @@ $status = $X->get('y', $value) ; ok(63, 1) ; # hard-wire to always pass. the previous test ($status == 1) # only worked because of a bug in 1.85/6 -# use seq to walk forwards through a file +# use seq to walk forwards through a file $status = $X->seq($key, $value, R_FIRST) ; ok(64, $status == 0 ); @@ -429,7 +429,7 @@ while (($status = $X->seq($key, $value, R_NEXT)) == 0) ok(65, $status == 1 ); ok(66, $ok == 1 ); -# use seq to walk backwards through a file +# use seq to walk backwards through a file $status = $X->seq($key, $value, R_LAST) ; ok(67, $status == 0 ); $previous = $key ; @@ -480,7 +480,7 @@ undef $Y ; untie %h ; # Duplicate keys -my $bt = new DB_File::BTREEINFO ; +my $bt = DB_File::BTREEINFO->new(); $bt->{flags} = R_DUP ; my ($YY, %hh); ok(74, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ; @@ -519,7 +519,7 @@ my %smith = $YY->get_dup('Smith', 1) ; ok(82, keys %smith == 1 && $smith{'John'}) ; my %wall = $YY->get_dup('Wall', 1) ; -ok(83, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 +ok(83, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 && $wall{'Brick'} == 2); undef $YY ; @@ -531,53 +531,53 @@ unlink $Dfile; my $Dfile1 = "btree1" ; my $Dfile2 = "btree2" ; my $Dfile3 = "btree3" ; - -my $dbh1 = new DB_File::BTREEINFO ; -$dbh1->{compare} = sub { + +my $dbh1 = DB_File::BTREEINFO->new(); +$dbh1->{compare} = sub { no warnings 'numeric' ; - $_[0] <=> $_[1] } ; - -my $dbh2 = new DB_File::BTREEINFO ; + $_[0] <=> $_[1] } ; + +my $dbh2 = DB_File::BTREEINFO->new(); $dbh2->{compare} = sub { $_[0] cmp $_[1] } ; - -my $dbh3 = new DB_File::BTREEINFO ; + +my $dbh3 = DB_File::BTREEINFO->new(); $dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ; - - + + my (%g, %k); tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) or die $!; tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) or die $!; tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) or die $!; - + 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_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 (0 .. @$a - 1) { return 0 unless $$a[$_] eq $$b[$_]; } - + 1 ; } - + ok(84, ArrayCompare (\@srt_1, [keys %h]) ); ok(85, ArrayCompare (\@srt_2, [keys %g]) ); ok(86, ArrayCompare (\@srt_3, [keys %k]) ); @@ -646,27 +646,27 @@ unlink $Dfile1 ; @ISA=qw(DB_File); @EXPORT = @DB_File::EXPORT ; - sub STORE { + sub STORE { my $self = shift ; my $key = shift ; my $value = shift ; $self->SUPER::STORE($key, $value * 2) ; } - sub FETCH { + sub FETCH { my $self = shift ; my $key = shift ; $self->SUPER::FETCH($key) - 1 ; } - sub put { + sub put { my $self = shift ; my $key = shift ; my $value = shift ; $self->SUPER::put($key, $value * 3) ; } - sub get { + sub get { my $self = shift ; $self->SUPER::get($_[0], $_[1]) ; $_[1] -= 2 ; @@ -685,7 +685,7 @@ EOM close FILE ; - BEGIN { push @INC, '.'; } + BEGIN { push @INC, '.'; } eval 'use SubDB ; '; main::ok(91, $@ eq "") ; my %h ; @@ -731,11 +731,11 @@ EOM { my($fk, $sk, $fv, $sv) = @_ ; return - $fetch_key eq $fk && $store_key eq $sk && + $fetch_key eq $fk && $store_key eq $sk && $fetch_value eq $fv && $store_value eq $sv && $_ eq 'original' ; } - + ok(101, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); $db->filter_fetch_key (sub { $fetch_key = $_ }) ; @@ -760,15 +760,15 @@ EOM ok(106, checkOutput( "fred", "", "", "")) ; # replace the filters, but remember the previous set - my ($old_fk) = $db->filter_fetch_key + my ($old_fk) = $db->filter_fetch_key (sub { $_ = uc $_ ; $fetch_key = $_ }) ; - my ($old_sk) = $db->filter_store_key + my ($old_sk) = $db->filter_store_key (sub { $_ = lc $_ ; $store_key = $_ }) ; - my ($old_fv) = $db->filter_fetch_value + my ($old_fv) = $db->filter_fetch_value (sub { $_ = "[$_]"; $fetch_value = $_ }) ; - my ($old_sv) = $db->filter_store_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 @@ -825,7 +825,7 @@ EOM unlink $Dfile; } -{ +{ # DBM Filter with a closure use warnings ; @@ -843,8 +843,8 @@ EOM my $count = 0 ; my @kept = () ; - return sub { ++$count ; - push @kept, $_ ; + return sub { ++$count ; + push @kept, $_ ; $result{$name} = "$name - $count: [@kept]" ; } } @@ -887,7 +887,7 @@ EOM undef $db ; untie %h; unlink $Dfile; -} +} { # DBM Filter recursion detection @@ -902,7 +902,7 @@ EOM eval '$h{1} = 1234' ; ok(146, $@ =~ /^recursion detected in filter_store_key at/ ); - + undef $db ; untie %h; unlink $Dfile; @@ -915,7 +915,7 @@ EOM my $file = "xyzt" ; { - my $redirect = new Redirect $file ; + my $redirect = Redirect->new( $file ); # BTREE example 1 ### @@ -936,7 +936,7 @@ EOM $DB_BTREE->{'compare'} = \&Compare ; unlink "tree" ; - tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE + 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 @@ -957,7 +957,7 @@ EOM untie %h ; unlink "tree" ; - } + } delete $DB_BTREE->{'compare'} ; @@ -966,9 +966,9 @@ mouse Smith Wall EOM - + { - my $redirect = new Redirect $file ; + my $redirect = Redirect->new( $file ); # BTREE example 2 ### @@ -981,13 +981,13 @@ EOM $filename = "tree" ; unlink $filename ; - + # Enable duplicate records $DB_BTREE->{'flags'} = R_DUP ; - - tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + + 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 @@ -1003,7 +1003,7 @@ EOM untie %h ; unlink $filename ; - } + } ok(148, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ; Smith -> John @@ -1020,7 +1020,7 @@ mouse -> mickey EOM { - my $redirect = new Redirect $file ; + my $redirect = Redirect->new( $file ); # BTREE example 3 ### @@ -1028,25 +1028,25 @@ EOM use warnings FATAL => qw(all) ; use strict ; use DB_File ; - + my ($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 + + $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 ; @@ -1054,8 +1054,8 @@ EOM $status == 0 ; $status = $x->seq($key, $value, R_NEXT) ) { print "$key -> $value\n" } - - + + undef $x ; untie %h ; } @@ -1076,7 +1076,7 @@ EOM { - my $redirect = new Redirect $file ; + my $redirect = Redirect->new( $file ); # BTREE example 4 ### @@ -1084,17 +1084,17 @@ EOM use warnings FATAL => qw(all) ; use strict ; use DB_File ; - + my ($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 + + $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" ; @@ -1107,10 +1107,10 @@ EOM @list = $x->get_dup("Smith") ; print "Smith => [@list]\n" ; - + @list = $x->get_dup("Dog") ; - print "Dog => [@list]\n" ; - + print "Dog => [@list]\n" ; + undef $x ; untie %h ; } @@ -1125,7 +1125,7 @@ Dog => [] EOM { - my $redirect = new Redirect $file ; + my $redirect = Redirect->new( $file ); # BTREE example 5 ### @@ -1133,23 +1133,23 @@ EOM use warnings FATAL => qw(all) ; use strict ; use DB_File ; - + my ($filename, $x, %h, $found); $filename = "tree" ; - + # Enable duplicate records $DB_BTREE->{'flags'} = R_DUP ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + + $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") ; + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; print "Larry Wall is $found there\n" ; - - $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; + + $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; print "Harry Wall is $found there\n" ; - + undef $x ; untie %h ; } @@ -1160,7 +1160,7 @@ Harry Wall is not there EOM { - my $redirect = new Redirect $file ; + my $redirect = Redirect->new( $file ); # BTREE example 6 ### @@ -1168,22 +1168,22 @@ EOM use warnings FATAL => qw(all) ; use strict ; use DB_File ; - + my ($filename, $x, %h, $found); $filename = "tree" ; - + # Enable duplicate records $DB_BTREE->{'flags'} = R_DUP ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + + $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") ; + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; print "Larry Wall is $found there\n" ; - + undef $x ; untie %h ; @@ -1195,7 +1195,7 @@ Larry Wall is not there EOM { - my $redirect = new Redirect $file ; + my $redirect = Redirect->new( $file ); # BTREE example 7 ### @@ -1221,22 +1221,22 @@ EOM $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{'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" ; @@ -1269,7 +1269,7 @@ EOM # Bug ID 20001013.009 # # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation + # Use of uninitialized value in null operation use warnings ; use strict ; use DB_File ; @@ -1278,7 +1278,7 @@ EOM 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; @@ -1298,7 +1298,7 @@ EOM 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 = (); ; @@ -1351,7 +1351,7 @@ EOM { # now an error to pass 'compare' a non-code reference - my $dbh = new DB_File::BTREEINFO ; + my $dbh = DB_File::BTREEINFO->new(); eval { $dbh->{compare} = 2 }; ok(162, $@ =~ /^Key 'compare' not associated with a code reference at/); @@ -1366,10 +1366,10 @@ EOM # # recursion detection in btree # my %hash ; # unlink $Dfile; -# my $dbh = new DB_File::BTREEINFO ; +# my $dbh = DB_File::BTREEINFO->new(); # $dbh->{compare} = sub { $hash{3} = 4 ; length $_[0] } ; -# -# +# +# # my (%h); # ok(164, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ); # @@ -1394,14 +1394,14 @@ ok(165,1); my $h1_count = 0; my $h2_count = 0; unlink $Dfile, $Dfile2; - my $dbh1 = new DB_File::BTREEINFO ; - $dbh1->{compare} = sub { ++ $h1_count ; $_[0] cmp $_[1] } ; - - my $dbh2 = new DB_File::BTREEINFO ; - $dbh2->{compare} = sub { ;++ $h2_count ; $_[0] cmp $_[1] } ; - - - + my $dbh1 = DB_File::BTREEINFO->new(); + $dbh1->{compare} = sub { ++ $h1_count ; $_[0] cmp $_[1] } ; + + my $dbh2 = DB_File::BTREEINFO->new(); + $dbh2->{compare} = sub { ;++ $h2_count ; $_[0] cmp $_[1] } ; + + + my (%h); ok(166, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) ); ok(167, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ); @@ -1457,7 +1457,7 @@ ok(165,1); ok(175, $h{"fred"} eq "joe"); ok(176, $db->FIRSTKEY() eq "fred") ; - + eval { my @r= grep { $h{$_} } (1, 2, 3) }; ok (177, ! $@); @@ -1518,7 +1518,7 @@ ok(165,1); # Regression Test for bug 30237 # Check that substr can be used in the key to db_put # and that db_put does not trigger the warning - # + # # Use of uninitialized value in subroutine entry @@ -1543,7 +1543,7 @@ ok(165,1); $db->put(substr($key,0), $value) ; } - ok 189, $warned eq '' + ok 189, $warned eq '' or print "# Caught warning [$warned]\n" ; # db-put with substr of value @@ -1556,7 +1556,7 @@ ok(165,1); $db->put($key, substr($value,0)) ; } - ok 190, $warned eq '' + ok 190, $warned eq '' or print "# Caught warning [$warned]\n" ; # via the tied hash is not a problem, but check anyway @@ -1570,7 +1570,7 @@ ok(165,1); $h{substr($key,0)} = $value ; } - ok 191, $warned eq '' + ok 191, $warned eq '' or print "# Caught warning [$warned]\n" ; # via the tied hash is not a problem, but check anyway @@ -1584,7 +1584,7 @@ ok(165,1); $h{$key} = substr($value,0) ; } - ok 192, $warned eq '' + ok 192, $warned eq '' or print "# Caught warning [$warned]\n" ; my %bad = () ; @@ -1594,7 +1594,7 @@ ok(165,1); $status = $db->seq($key, $value, R_NEXT ) ) { #print "# key [$key] value [$value]\n" ; - if (defined $remember{$key} && defined $value && + if (defined $remember{$key} && defined $value && $remember{$key} eq $value) { delete $remember{$key} ; } @@ -1602,7 +1602,7 @@ ok(165,1); $bad{$key} = $value ; } } - + ok 193, keys %bad == 0 ; ok 194, keys %remember == 0 ; @@ -1610,11 +1610,11 @@ ok(165,1); print "# bad -- $key $value\n" while ($key, $value) = each %bad; # Make sure this fix does not break code to handle an undef key - # Berkeley DB undef key is bron between versions 2.3.16 and + # Berkeley DB undef key is bron between versions 2.3.16 and my $value = 'fred'; $warned = ''; $db->put(undef, $value) ; - ok 195, $warned eq '' + ok 195, $warned eq '' or print "# Caught warning [$warned]\n" ; $warned = ''; @@ -1623,7 +1623,7 @@ ok(165,1); $value = '' ; $db->get(undef, $value) ; ok 196, $no_NULL || $value eq 'fred' or print "# got [$value]\n" ; - ok 197, $warned eq '' + ok 197, $warned eq '' or print "# Caught warning [$warned]\n" ; $warned = ''; @@ -1658,7 +1658,7 @@ ok(165,1); # ok(204, $db->get($k, $v, R_CURSOR)) ; # # ok(205, keys %h == 1) ; -# +# # undef $db ; # untie %h; # unlink $Dfile; diff --git a/cpan/DB_File/t/db-hash.t b/cpan/DB_File/t/db-hash.t index 79ffe93a89..cc10bfcbbb 100644 --- a/cpan/DB_File/t/db-hash.t +++ b/cpan/DB_File/t/db-hash.t @@ -1,10 +1,10 @@ -#!./perl +#!./perl use warnings; use strict; use Config; use File::Temp qw(tempdir) ; - + BEGIN { if(-d "lib" && -f "TEST") { if ($Config{'extensions'} !~ /\bDB_File\b/ ) { @@ -14,7 +14,7 @@ BEGIN { } } -use DB_File; +use DB_File; use Fcntl; print "1..166\n"; @@ -25,7 +25,7 @@ sub ok { my $no = shift ; my $result = shift ; - + print "not " unless $result ; print "ok $no\n" ; @@ -55,7 +55,7 @@ sub ok } sub docat_del -{ +{ my $file = shift; local $/ = undef; open(CAT,$file) || die "Cannot open $file: $!"; @@ -64,12 +64,12 @@ sub docat_del $result = normalise($result) ; unlink $file ; return $result; -} +} sub normalise { my $data = shift ; - $data =~ s#\r\n#\n#g + $data =~ s#\r\n#\n#g if $^O eq 'cygwin' ; return $data ; } @@ -88,7 +88,7 @@ chdir $TEMPDIR; my $Dfile = "dbhash.tmp"; my $Dfile2 = "dbhash2.tmp"; -my $null_keys_allowed = ($DB_File::db_ver < 2.004010 +my $null_keys_allowed = ($DB_File::db_ver < 2.004010 || $DB_File::db_ver >= 3.1 ); unlink $Dfile; @@ -97,7 +97,7 @@ umask(0); # Check the interface to HASHINFO -my $dbh = new DB_File::HASHINFO ; +my $dbh = DB_File::HASHINFO->new(); ok(1, ! defined $dbh->{bsize}) ; ok(2, ! defined $dbh->{ffactor}) ; @@ -268,11 +268,11 @@ ok(30, join(':',200..400) eq join(':',@foo) ); # 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 + +# check that the value of the key 'x' has not been changed by the # previous test ok(32, $h{'x'} eq 'X' ); @@ -383,7 +383,7 @@ untie %h ; # check ability to override the default hashing my %x ; my $filename = "xyz" ; - my $hi = new DB_File::HASHINFO ; + my $hi = DB_File::HASHINFO->new(); $::count = 0 ; $hi->{hash} = sub { ++$::count ; length $_[0] } ; ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ; @@ -426,27 +426,27 @@ untie %h ; @ISA=qw(DB_File); @EXPORT = @DB_File::EXPORT ; - sub STORE { + sub STORE { my $self = shift ; my $key = shift ; my $value = shift ; $self->SUPER::STORE($key, $value * 2) ; } - sub FETCH { + sub FETCH { my $self = shift ; my $key = shift ; $self->SUPER::FETCH($key) - 1 ; } - sub put { + sub put { my $self = shift ; my $key = shift ; my $value = shift ; $self->SUPER::put($key, $value * 3) ; } - sub get { + sub get { my $self = shift ; $self->SUPER::get($_[0], $_[1]) ; $_[1] -= 2 ; @@ -465,7 +465,7 @@ EOM close FILE ; - BEGIN { push @INC, '.'; } + BEGIN { push @INC, '.'; } eval 'use SubDB ; '; main::ok(53, $@ eq "") ; my %h ; @@ -512,23 +512,23 @@ EOM no warnings 'uninitialized'; my($fk, $sk, $fv, $sv) = @_ ; - print "# Fetch Key : expected '$fk' got '$fetch_key'\n" + print "# Fetch Key : expected '$fk' got '$fetch_key'\n" if $fetch_key ne $fk ; - print "# Fetch Value : expected '$fv' got '$fetch_value'\n" + print "# Fetch Value : expected '$fv' got '$fetch_value'\n" if $fetch_value ne $fv ; - print "# Store Key : expected '$sk' got '$store_key'\n" + print "# Store Key : expected '$sk' got '$store_key'\n" if $store_key ne $sk ; - print "# Store Value : expected '$sv' got '$store_value'\n" + print "# Store Value : expected '$sv' got '$store_value'\n" if $store_value ne $sv ; - print "# \$_ : expected 'original' got '$_'\n" + print "# \$_ : expected 'original' got '$_'\n" if $_ ne 'original' ; return - $fetch_key eq $fk && $store_key eq $sk && + $fetch_key eq $fk && $store_key eq $sk && $fetch_value eq $fv && $store_value eq $sv && $_ eq 'original' ; } - + ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); $db->filter_fetch_key (sub { $fetch_key = $_ }) ; @@ -557,15 +557,15 @@ EOM ok(70, checkOutput( "fred", "fred", "joe", "")) ; # replace the filters, but remember the previous set - my ($old_fk) = $db->filter_fetch_key + my ($old_fk) = $db->filter_fetch_key (sub { $_ = uc $_ ; $fetch_key = $_ }) ; - my ($old_sk) = $db->filter_store_key + my ($old_sk) = $db->filter_store_key (sub { $_ = lc $_ ; $store_key = $_ }) ; - my ($old_fv) = $db->filter_fetch_value + my ($old_fv) = $db->filter_fetch_value (sub { $_ = "[$_]"; $fetch_value = $_ }) ; - my ($old_sv) = $db->filter_store_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 @@ -579,7 +579,7 @@ EOM ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $k = 'Fred'; $v =''; ok(74, ! $db->seq($k, $v, R_FIRST) ) ; - ok(75, $k eq "FRED") or + ok(75, $k eq "FRED") or print "# k [$k]\n" ; ok(76, $v eq "[Jxe]") ; # fk sk fv sv @@ -634,7 +634,7 @@ EOM unlink $Dfile; } -{ +{ # DBM Filter with a closure use warnings ; @@ -652,8 +652,8 @@ EOM my $count = 0 ; my @kept = () ; - return sub { ++$count ; - push @kept, $_ ; + return sub { ++$count ; + push @kept, $_ ; $result{$name} = "$name - $count: [@kept]" ; } } @@ -696,7 +696,7 @@ EOM undef $db ; untie %h; unlink $Dfile; -} +} { # DBM Filter recursion detection @@ -711,7 +711,7 @@ EOM eval '$h{1} = 1234' ; ok(116, $@ =~ /^recursion detected in filter_store_key at/ ); - + undef $db ; untie %h; unlink $Dfile; @@ -723,7 +723,7 @@ EOM my $file = "xyzt" ; { - my $redirect = new Redirect $file ; + my $redirect = Redirect->new( $file ); use warnings FATAL => qw(all); use strict ; @@ -731,7 +731,7 @@ EOM our (%h, $k, $v); unlink "fruit" ; - tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH + 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 @@ -753,7 +753,7 @@ EOM untie %h ; unlink "fruit" ; - } + } ok(117, docat_del($file) eq <<'EOM') ; Banana Exists @@ -762,14 +762,14 @@ 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 of uninitialized value in null operation use warnings ; use strict ; use DB_File ; @@ -778,7 +778,7 @@ EOM 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(118, $a eq "") ; @@ -797,7 +797,7 @@ EOM my %h ; my $a = ""; local $SIG{__WARN__} = sub {$a = $_[0]} ; - + tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; %h = (); ; ok(119, $a eq "") ; @@ -849,7 +849,7 @@ EOM { # now an error to pass 'hash' a non-code reference - my $dbh = new DB_File::HASHINFO ; + my $dbh = DB_File::HASHINFO->new(); eval { $dbh->{hash} = 2 }; ok(126, $@ =~ /^Key 'hash' not associated with a code reference at/); @@ -862,10 +862,10 @@ EOM # my %hash ; # my $Dfile = "xxx.db"; # unlink $Dfile; -# my $dbh = new DB_File::HASHINFO ; +# my $dbh = DB_File::HASHINFO->new(); # $dbh->{hash} = sub { $hash{3} = 4 ; length $_[0] } ; -# -# +# +# # ok(127, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ); # # eval { $hash{1} = 2; @@ -890,14 +890,14 @@ EOM my $h1_count = 0; my $h2_count = 0; unlink $Dfile, $Dfile2; - my $dbh1 = new DB_File::HASHINFO ; + my $dbh1 = DB_File::HASHINFO->new(); $dbh1->{hash} = sub { ++ $h1_count ; length $_[0] } ; - my $dbh2 = new DB_File::HASHINFO ; + my $dbh2 = DB_File::HASHINFO->new(); $dbh2->{hash} = sub { ++ $h2_count ; length $_[0] } ; - - - + + + my (%h); ok(127, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) ); ok(128, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ); @@ -919,9 +919,9 @@ EOM } { - # Passing undef for flags and/or mode when calling tie could cause + # Passing undef for flags and/or mode when calling tie could cause # Use of uninitialized value in subroutine entry - + my $warn_count = 0 ; #local $SIG{__WARN__} = sub { ++ $warn_count }; @@ -981,7 +981,7 @@ EOM ok(139, $h{"fred"} eq "joe"); ok(140, $db->FIRSTKEY() eq "fred") ; - + eval { my @r= grep { $h{$_} } (1, 2, 3) }; ok (141, ! $@); @@ -1041,7 +1041,7 @@ EOM # Regression Test for bug 30237 # Check that substr can be used in the key to db_put # and that db_put does not trigger the warning - # + # # Use of uninitialized value in subroutine entry @@ -1066,7 +1066,7 @@ EOM $db->put(substr($key,0), $value) ; } - ok 153, $warned eq '' + ok 153, $warned eq '' or print "# Caught warning [$warned]\n" ; # db-put with substr of value @@ -1079,7 +1079,7 @@ EOM $db->put($key, substr($value,0)) ; } - ok 154, $warned eq '' + ok 154, $warned eq '' or print "# Caught warning [$warned]\n" ; # via the tied hash is not a problem, but check anyway @@ -1093,7 +1093,7 @@ EOM $h{substr($key,0)} = $value ; } - ok 155, $warned eq '' + ok 155, $warned eq '' or print "# Caught warning [$warned]\n" ; # via the tied hash is not a problem, but check anyway @@ -1107,7 +1107,7 @@ EOM $h{$key} = substr($value,0) ; } - ok 156, $warned eq '' + ok 156, $warned eq '' or print "# Caught warning [$warned]\n" ; my %bad = () ; @@ -1117,7 +1117,7 @@ EOM $status = $db->seq(substr($key,0), substr($value,0), R_NEXT ) ) { #print "# key [$key] value [$value]\n" ; - if (defined $remember{$key} && defined $value && + if (defined $remember{$key} && defined $value && $remember{$key} eq $value) { delete $remember{$key} ; } @@ -1125,7 +1125,7 @@ EOM $bad{$key} = $value ; } } - + ok 157, keys %bad == 0 ; ok 158, keys %remember == 0 ; @@ -1137,7 +1137,7 @@ EOM my $value = 'fred'; $warned = ''; $db->put(undef, $value) ; - ok 159, $warned eq '' + ok 159, $warned eq '' or print "# Caught warning [$warned]\n" ; $warned = ''; @@ -1146,7 +1146,7 @@ EOM $value = '' ; $db->get(undef, $value) ; ok 160, $no_NULL || $value eq 'fred' or print "# got [$value]\n" ; - ok 161, $warned eq '' + ok 161, $warned eq '' or print "# Caught warning [$warned]\n" ; $warned = ''; @@ -1205,7 +1205,7 @@ EOM $status = $db->seq($key, $value, R_NEXT ) ) { #print "# key [$key] value [$value]\n" ; - if (defined $remember{$key} && defined $value && + if (defined $remember{$key} && defined $value && $remember{$key} eq $value) { delete $remember{$key} ; } @@ -1213,7 +1213,7 @@ EOM $bad{$key} = $value ; } } - + ok 164, $_ eq 'fred'; ok 165, keys %bad == 0 ; ok 166, keys %remember == 0 ; diff --git a/cpan/DB_File/t/db-recno.t b/cpan/DB_File/t/db-recno.t index 08a89fff22..4b80e93b50 100644 --- a/cpan/DB_File/t/db-recno.t +++ b/cpan/DB_File/t/db-recno.t @@ -2,7 +2,7 @@ use strict; use Config; - + BEGIN { if(-d "lib" && -f "TEST") { if ($Config{'extensions'} !~ /\bDB_File\b/ ) { @@ -12,7 +12,7 @@ BEGIN { } } -use DB_File; +use DB_File; use Fcntl; use File::Temp qw(tempdir) ; @@ -25,7 +25,7 @@ our ($dbh, $Dfile, $bad_ones, $FA); sub try::TIEARRAY { bless [], "try" } sub try::FETCHSIZE { $FA = 1 } $FA = 0 ; - my @a ; + my @a ; tie @a, 'try' ; my $a = @a ; } @@ -76,12 +76,12 @@ sub docat } sub docat_del -{ +{ my $file = shift; my $result = docat($file); unlink $file ; return $result; -} +} sub safeUntie { @@ -114,7 +114,7 @@ EOM print STDERR <<EOM ; # # You can safely ignore the errors if you're never going to use the -# broken functionality (recno databases with a modified bval). +# 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 @@ -129,25 +129,25 @@ sub normalise { return unless $^O eq 'cygwin' ; foreach (@_) - { s#\r\n#\n#g } + { s#\r\n#\n#g } } -BEGIN -{ - { - local $SIG{__DIE__} ; - eval { require Data::Dumper ; import Data::Dumper } ; +BEGIN +{ + { + local $SIG{__DIE__} ; + eval { require Data::Dumper; Data::Dumper->import(); } ; } - + if ($@) { *Dumper = sub { my $a = shift; return "[ @{ $a } ]" } ; - } + } } my $splice_tests = 10 + 12 + 1; # ten regressions, plus the randoms my $total_tests = 181 ; $total_tests += $splice_tests if $FA ; -print "1..$total_tests\n"; +print "1..$total_tests\n"; my $TEMPDIR = tempdir( CLEANUP => 1 ); chdir $TEMPDIR; @@ -159,7 +159,7 @@ umask(0); # Check the interface to RECNOINFO -$dbh = new DB_File::RECNOINFO ; +$dbh = DB_File::RECNOINFO->new(); ok(1, ! defined $dbh->{bval}) ; ok(2, ! defined $dbh->{cachesize}) ; ok(3, ! defined $dbh->{psize}) ; @@ -297,7 +297,7 @@ my $ok = 1 ; my $j = 0 ; foreach (@data) { - $ok = 0, last if $_ ne $h[$j ++] ; + $ok = 0, last if $_ ne $h[$j ++] ; } ok(52, $ok ); @@ -328,7 +328,7 @@ unlink $Dfile; # Check bval defaults to \n my @h = () ; - my $dbh = new DB_File::RECNOINFO ; + my $dbh = DB_File::RECNOINFO->new(); ok(59, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; $h[0] = "abc" ; $h[1] = "def" ; @@ -343,7 +343,7 @@ unlink $Dfile; # Change bval my @h = () ; - my $dbh = new DB_File::RECNOINFO ; + my $dbh = DB_File::RECNOINFO->new(); $dbh->{bval} = "-" ; ok(62, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; $h[0] = "abc" ; @@ -361,7 +361,7 @@ unlink $Dfile; # Check R_FIXEDLEN with default bval (space) my @h = () ; - my $dbh = new DB_File::RECNOINFO ; + my $dbh = DB_File::RECNOINFO->new(); $dbh->{flags} = R_FIXEDLEN ; $dbh->{reclen} = 5 ; ok(65, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; @@ -380,7 +380,7 @@ unlink $Dfile; # Check R_FIXEDLEN with user-defined bval my @h = () ; - my $dbh = new DB_File::RECNOINFO ; + my $dbh = DB_File::RECNOINFO->new(); $dbh->{flags} = R_FIXEDLEN ; $dbh->{bval} = "-" ; $dbh->{reclen} = 5 ; @@ -428,27 +428,27 @@ unlink $Dfile; @ISA=qw(DB_File); @EXPORT = @DB_File::EXPORT ; - sub STORE { + sub STORE { my $self = shift ; my $key = shift ; my $value = shift ; $self->SUPER::STORE($key, $value * 2) ; } - sub FETCH { + sub FETCH { my $self = shift ; my $key = shift ; $self->SUPER::FETCH($key) - 1 ; } - sub put { + sub put { my $self = shift ; my $key = shift ; my $value = shift ; $self->SUPER::put($key, $value * 3) ; } - sub get { + sub get { my $self = shift ; $self->SUPER::get($_[0], $_[1]) ; $_[1] -= 2 ; @@ -467,7 +467,7 @@ EOM close FILE or die "Could not close: $!"; - BEGIN { push @INC, '.'; } + BEGIN { push @INC, '.'; } eval 'use SubDB ; '; main::ok(72, $@ eq "") ; my @h ; @@ -520,11 +520,11 @@ EOM # $# sets array to same length $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ; - ok(87, $self) + ok(87, $self) or warn "# $DB_File::Error\n"; if ($FA) { $#h = 3 } - else + else { $self->STORESIZE(4) } ok(88, $FA ? $#h == 3 : $self->length() == 4) ; undef $self ; @@ -536,7 +536,7 @@ EOM ok(91, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; if ($FA) { $#h = 6 } - else + else { $self->STORESIZE(7) } ok(92, $FA ? $#h == 6 : $self->length() == 7) ; undef $self ; @@ -548,7 +548,7 @@ EOM ok(95, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; if ($FA) { $#h = 2 } - else + else { $self->STORESIZE(3) } ok(96, $FA ? $#h == 2 : $self->length() == 3) ; undef $self ; @@ -573,23 +573,23 @@ EOM { my($fk, $sk, $fv, $sv) = @_ ; - print "# Fetch Key : expected '$fk' got '$fetch_key'\n" + print "# Fetch Key : expected '$fk' got '$fetch_key'\n" if $fetch_key ne $fk ; - print "# Fetch Value : expected '$fv' got '$fetch_value'\n" + print "# Fetch Value : expected '$fv' got '$fetch_value'\n" if $fetch_value ne $fv ; - print "# Store Key : expected '$sk' got '$store_key'\n" + print "# Store Key : expected '$sk' got '$store_key'\n" if $store_key ne $sk ; - print "# Store Value : expected '$sv' got '$store_value'\n" + print "# Store Value : expected '$sv' got '$store_value'\n" if $store_value ne $sv ; - print "# \$_ : expected 'original' got '$_'\n" + print "# \$_ : expected 'original' got '$_'\n" if $_ ne 'original' ; return - $fetch_key eq $fk && $store_key eq $sk && + $fetch_key eq $fk && $store_key eq $sk && $fetch_value eq $fv && $store_value eq $sv && $_ eq 'original' ; } - + ok(99, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); $db->filter_fetch_key (sub { $fetch_key = $_ }) ; @@ -614,15 +614,15 @@ EOM ok(104, checkOutput( 0, "", "", "")) ; # replace the filters, but remember the previous set - my ($old_fk) = $db->filter_fetch_key + my ($old_fk) = $db->filter_fetch_key (sub { ++ $_ ; $fetch_key = $_ }) ; - my ($old_sk) = $db->filter_store_key + my ($old_sk) = $db->filter_store_key (sub { $_ *= 2 ; $store_key = $_ }) ; - my ($old_fv) = $db->filter_fetch_value + my ($old_fv) = $db->filter_fetch_value (sub { $_ = "[$_]"; $fetch_value = $_ }) ; - my ($old_sv) = $db->filter_store_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 @@ -637,7 +637,7 @@ EOM ok(108, $db->FIRSTKEY() == 1) ; # fk sk fv sv ok(109, checkOutput( 1, "", "", "")) ; - + # put the original filters back $db->filter_fetch_key ($old_fk); $db->filter_store_key ($old_sk); @@ -679,7 +679,7 @@ EOM unlink $Dfile; } -{ +{ # DBM Filter with a closure use warnings ; @@ -697,8 +697,8 @@ EOM my $count = 0 ; my @kept = () ; - return sub { ++$count ; - push @kept, $_ ; + return sub { ++$count ; + push @kept, $_ ; $result{$name} = "$name - $count: [@kept]" ; } } @@ -741,7 +741,7 @@ EOM undef $db ; ok(144, safeUntie \@h); unlink $Dfile; -} +} { # DBM Filter recursion detection @@ -756,7 +756,7 @@ EOM eval '$h[1] = 1234' ; ok(146, $@ =~ /^recursion detected in filter_store_key at/ ); - + undef $db ; ok(147, safeUntie \@h); unlink $Dfile; @@ -768,7 +768,7 @@ EOM my $file = "xyzt" ; { - my $redirect = new Redirect $file ; + my $redirect = Redirect->new( $file ); use warnings FATAL => qw(all); use strict ; @@ -778,7 +778,7 @@ EOM unlink $filename ; my @h ; - my $x = tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO + 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 @@ -786,7 +786,7 @@ EOM $h[1] = "blue" ; $h[2] = "yellow" ; - $FA ? push @h, "green", "black" + $FA ? push @h, "green", "black" : $x->push("green", "black") ; my $elements = $FA ? scalar @h : $x->length ; @@ -795,7 +795,7 @@ EOM my $last = $FA ? pop @h : $x->pop ; print "popped $last\n" ; - $FA ? unshift @h, "white" + $FA ? unshift @h, "white" : $x->unshift("white") ; my $first = $FA ? shift @h : $x->shift ; print "shifted $first\n" ; @@ -811,7 +811,7 @@ EOM untie @h ; unlink $filename ; - } + } ok(148, docat_del($file) eq <<'EOM') ; The array contains 5 entries @@ -824,21 +824,21 @@ EOM my $save_output = "xyzt" ; { - my $redirect = new Redirect $save_output ; + my $redirect = Redirect->new( $save_output ); use warnings FATAL => qw(all); use strict ; our (@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 + $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" ; @@ -846,12 +846,12 @@ EOM $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. + # elements in the array. print "\nORIGINAL\n" ; foreach $i (0 .. $H->length - 1) { @@ -887,16 +887,16 @@ EOM # 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 ; + 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 ; + untie @h ; unlink $file ; - } + } ok(149, docat_del($save_output) eq <<'EOM') ; @@ -926,14 +926,14 @@ REVERSE again 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 of uninitialized value in null operation use warnings ; use strict ; use DB_File ; @@ -942,8 +942,8 @@ EOM my @h ; my $a = ""; local $SIG{__WARN__} = sub {$a = $_[0]} ; - - tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + + tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO or die "Can't open file: $!\n" ; $h[0] = undef; ok(150, $a eq "") ; @@ -962,8 +962,8 @@ EOM unlink $Dfile; my @h ; - - tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + + tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO or die "Can't open file: $!\n" ; @h = (); ; ok(152, $a eq "") ; @@ -1064,7 +1064,7 @@ EOM # Regression Test for bug 30237 # Check that substr can be used in the key to db_put # and that db_put does not trigger the warning - # + # # Use of uninitialized value in subroutine entry @@ -1090,7 +1090,7 @@ EOM $db->put(substr($key,0, 1), $value) ; } - ok 170, $warned eq '' + ok 170, $warned eq '' or print "# Caught warning [$warned]\n" ; # db-put with substr of value @@ -1103,7 +1103,7 @@ EOM $db->put($ix, substr($value,0)) ; } - ok 171, $warned eq '' + ok 171, $warned eq '' or print "# Caught warning [$warned]\n" ; # via the tied array is not a problem, but check anyway @@ -1117,7 +1117,7 @@ EOM $h[substr($key,0,1)] = $value ; } - ok 172, $warned eq '' + ok 172, $warned eq '' or print "# Caught warning [$warned]\n" ; # via the tied array is not a problem, but check anyway @@ -1131,7 +1131,7 @@ EOM $h[$ix] = substr($value,0) ; } - ok 173, $warned eq '' + ok 173, $warned eq '' or print "# Caught warning [$warned]\n" ; my %bad = () ; @@ -1141,7 +1141,7 @@ EOM $status = $db->seq($key, $value, R_NEXT ) ) { #print "# key [$key] value [$value]\n" ; - if (defined $remember{$key} && defined $value && + if (defined $remember{$key} && defined $value && $remember{$key} eq $value) { delete $remember{$key} ; } @@ -1149,7 +1149,7 @@ EOM $bad{$key} = $value ; } } - + ok 174, keys %bad == 0 ; ok 175, keys %remember == 0 ; @@ -1162,7 +1162,7 @@ EOM $status = $db->put(undef, $value) ; ok 176, $status == 0 or print "# put failed - status $status\n"; - ok 177, $warned eq '' + ok 177, $warned eq '' or print "# Caught warning [$warned]\n" ; $warned = ''; @@ -1173,7 +1173,7 @@ EOM or print "# get failed - status $status\n" ; ok(179, $db->get(undef, $value) == 0) or print "# get failed\n" ; ok 180, $value eq 'fred' or print "# got [$value]\n" ; - ok 181, $warned eq '' + ok 181, $warned eq '' or print "# Caught warning [$warned]\n" ; $warned = ''; @@ -1200,8 +1200,8 @@ exit unless $FA ; unlink $Dfile; my @tied ; - - tie @tied, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + + tie @tied, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO or die "Can't open file: $!\n" ; # uninitialized offset @@ -1261,15 +1261,15 @@ exit unless $FA ; unlink $Dfile; } -# +# # These are a few regression tests: bundles of five arguments to pass # to test_splice(). The first four arguments correspond to those # given to splice(), and the last says which context to call it in # (scalar, list or void). -# +# # The expected result is not needed because we get that by running # Perl's built-in splice(). -# +# my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion', 'rarely', 'paleness' ], -4, -2, @@ -1309,7 +1309,7 @@ my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion', undef, undef, [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ], 'scalar' ], - + [ [ 'riheb' ], -8, undef, [], 'void' ], [ [ 'uft', 'qnxs', '' ], @@ -1355,7 +1355,7 @@ else { ok($testnum++, not $failed); } -die "testnum ($testnum) != total_tests ($total_tests) + 1" +die "testnum ($testnum) != total_tests ($total_tests) + 1" if $testnum != $total_tests + 1; exit ; @@ -1363,21 +1363,21 @@ exit ; # Subroutines for SPLICE testing # test_splice() -# +# # Test the new splice() against Perl's built-in one. The first four # parameters are those passed to splice(), except that the lists must # be (explicitly) passed by reference, and are not actually modified. # (It's just a test!) The last argument specifies the context in # which to call the functions: 'list', 'scalar', or 'void'. -# +# # Returns: # undef, if the two splices give the same results for the given # arguments and context; -# +# # an error message showing the difference, otherwise. -# +# # Reads global variable $tmp. -# +# sub test_splice { die 'usage: test_splice(array, offset, length, list, context)' if @_ != 5; my ($array, $offset, $length, $list, $context) = @_; @@ -1385,20 +1385,20 @@ sub test_splice { my @list = @$list; unlink $tmp; - + my @h; my $H = tie @h, 'DB_File', $tmp, O_CREAT|O_RDWR, 0644, $DB_RECNO or die "cannot open $tmp: $!"; my $i = 0; foreach ( @array ) { $h[$i++] = $_ } - + return "basic DB_File sanity check failed" if list_diff(\@array, \@h); # Output from splice(): # Returned value (munged a bit), error msg, warnings - # + # my ($s_r, $s_error, @s_warnings); my $gather_warning = sub { push @s_warnings, $_[0] }; @@ -1491,7 +1491,7 @@ sub test_splice { while (@s_warnings) { my $sw = shift @s_warnings; my $msw = shift @ms_warnings; - + if (defined $sw and defined $msw) { $msw =~ s/ \(.+\)$//; $msw =~ s/ in splice$// if $] < 5.006; @@ -1506,10 +1506,10 @@ sub test_splice { return "one warning defined, another undef"; } } - + undef $H; untie @h; - + open(TEXT, $tmp) or die "cannot open $tmp: $!"; @h = <TEXT>; normalise @h; chomp @h; close TEXT or die "cannot close $tmp: $!"; @@ -1532,10 +1532,10 @@ sub test_splice { # reference to second list # # Returns true iff they differ. Only works for lists of (string or -# undef). -# +# undef). +# # Surely there is a better way to do this? -# +# sub list_diff { die 'usage: list_diff(ref to first list, ref to second list)' if @_ != 2; @@ -1555,15 +1555,15 @@ sub list_diff { } } return 0; -} +} # rand_test() -# +# # Think up a random ARRAY, OFFSET, LENGTH, LIST, and context. # ARRAY or LIST might be empty, and OFFSET or LENGTH might be # undefined. Return a 'test' - a listref of these five things. -# +# sub rand_test { die 'usage: rand_test()' if @_; my @contexts = qw<list scalar void>; @@ -1596,5 +1596,3 @@ sub rand_word { } return $r; } - - diff --git a/cpan/DB_File/t/db-threads.t b/cpan/DB_File/t/db-threads.t index f9bce95356..95bffa02bc 100644 --- a/cpan/DB_File/t/db-threads.t +++ b/cpan/DB_File/t/db-threads.t @@ -1,4 +1,4 @@ -#!./perl +#!./perl use warnings; use strict; diff --git a/cpan/DB_File/version.c b/cpan/DB_File/version.c index ecf73de4e1..7df0d5a425 100644 --- a/cpan/DB_File/version.c +++ b/cpan/DB_File/version.c @@ -1,6 +1,6 @@ -/* +/* - version.c -- Perl 5 interface to Berkeley DB + version.c -- Perl 5 interface to Berkeley DB written by Paul Marquess <pmqs@cpan.org> last modified 2nd Jan 2002 @@ -23,7 +23,7 @@ */ #define PERL_NO_GET_CONTEXT -#include "EXTERN.h" +#include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -36,9 +36,9 @@ __getBerkeleyDBInfo(void) __getBerkeleyDBInfo() #endif { -#ifdef dTHX +#ifdef dTHX dTHX; -#endif +#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) ; @@ -53,22 +53,22 @@ __getBerkeleyDBInfo() /* || Patch != DB_VERSION_PATCH) */ croak("\nDB_File was build with libdb version %d.%d.%d,\nbut you are attempting to run it with libdb version %d.%d.%d\n", - DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH, + 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) ; + sv_setpv(version_sv, buffer) ; sprintf(buffer, "%d.%03d%03d", Major, Minor, Patch) ; - sv_setpv(ver_sv, buffer) ; + sv_setpv(ver_sv, buffer) ; } - + #else /* ! DB_VERSION_MAJOR */ sv_setiv(version_sv, 1) ; sv_setiv(ver_sv, 1) ; |