This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update DB_File to CPAN version 1.853
authorChris 'BinGOs' Williams <chris@bingosnet.co.uk>
Tue, 7 Jan 2020 11:54:15 +0000 (11:54 +0000)
committerChris 'BinGOs' Williams <chris@bingosnet.co.uk>
Tue, 7 Jan 2020 11:54:15 +0000 (11:54 +0000)
  [DELTA]

1.853 5 January 2020

   * Memory leak if ParseOpenInfo calls croak_and_free
     https://github.com/pmqs/DB_File/issues/3
     9e2c8d6c3a35acb71358f440c93defa3d8339420

   * Add Address Sanatizer suppressions file
     a6a26f4878d6be13aad69a3f5b6019e7482a8992

   * Add prereq test
     a631884b3ca11919142c6be8a64e668730b83469

   * Documemtation updates
     4c53b38531b547ae293967c852ff21412eb6d840

   * clang warning in ppport.h
     update to latest ppport.h
     https://github.com/pmqs/DB_File/issues/2
     36d6ae54edfc1df872f5e66c93bda05cbfefefa7

   * #125853 - RT links in Changes file are wrong
     Changes entry for 1.842 has both CPAN & Perl RT links.
     Use the full URL to avoid ambiguity.
     f06a9235373747d0f5c6a95caf504174ffb19c44

Porting/Maintainers.pl
cpan/DB_File/DB_File.pm
cpan/DB_File/DB_File.xs
cpan/DB_File/Makefile.PL
cpan/DB_File/config.in
cpan/DB_File/dbinfo
cpan/DB_File/t/db-btree.t
cpan/DB_File/t/db-hash.t
cpan/DB_File/t/db-recno.t
cpan/DB_File/typemap
cpan/DB_File/version.c

index 1f58da1..5980d8a 100755 (executable)
@@ -333,12 +333,13 @@ use File::Glob qw(:case);
     },
 
     'DB_File' => {
-        'DISTRIBUTION' => 'PMQS/DB_File-1.852.tar.gz',
+        'DISTRIBUTION' => 'PMQS/DB_File-1.853.tar.gz',
         'FILES'        => q[cpan/DB_File],
         'EXCLUDED'     => [
             qr{^patches/},
             qr{^t/meta},
             qw( t/pod.t
+                t/000prereq.t
                 fallback.h
                 fallback.xs
                 ),
index 97fcc4a..a732ff4 100644 (file)
@@ -2,7 +2,7 @@
 #
 # Written by Paul Marquess (pmqs@cpan.org)
 #
-#     Copyright (c) 1995-2019 Paul Marquess. All rights reserved.
+#     Copyright (c) 1995-2020 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.
 
@@ -31,14 +31,14 @@ sub TIEHASH
     my $pkg = shift ;
 
     bless { VALID => { 
-                       bsize     => 1,
-                       ffactor   => 1,
-                       nelem     => 1,
-                       cachesize => 1,
-                       hash      => 2,
-                       lorder    => 1,
-                    }, 
-           GOT   => {}
+                        bsize     => 1,
+                        ffactor   => 1,
+                        nelem     => 1,
+                        cachesize => 1,
+                        hash      => 2,
+                        lorder    => 1,
+                     }, 
+            GOT   => {}
           }, $pkg ;
 }
 
@@ -65,8 +65,8 @@ sub STORE
 
     if ( $type )
     {
-       croak "Key '$key' not associated with a code reference" 
-           if $type == 2 && !ref $value && ref $value ne 'CODE';
+        croak "Key '$key' not associated with a code reference" 
+            if $type == 2 && !ref $value && ref $value ne 'CODE';
         $self->{GOT}{$key} = $value ;
         return ;
     }
@@ -122,9 +122,9 @@ sub TIEHASH
     my $pkg = shift ;
 
     bless { VALID => { map {$_, 1} 
-                      qw( bval cachesize psize flags lorder reclen bfname )
-                    },
-           GOT   => {},
+                       qw( bval cachesize psize flags lorder reclen bfname )
+                     },
+            GOT   => {},
           }, $pkg ;
 }
 
@@ -140,16 +140,16 @@ sub TIEHASH
     my $pkg = shift ;
 
     bless { VALID => { 
-                       flags      => 1,
-                       cachesize  => 1,
-                       maxkeypage => 1,
-                       minkeypage => 1,
-                       psize      => 1,
-                       compare    => 2,
-                       prefix     => 2,
-                       lorder     => 1,
-                    },
-           GOT   => {},
+                        flags      => 1,
+                        cachesize  => 1,
+                        maxkeypage => 1,
+                        minkeypage => 1,
+                        psize      => 1,
+                        compare    => 2,
+                        prefix     => 2,
+                        lorder     => 1,
+                     },
+            GOT   => {},
           }, $pkg ;
 }
 
@@ -165,7 +165,7 @@ use Carp;
 # Module not thread safe, so don't clone
 sub CLONE_SKIP { 1 } 
 
-$VERSION = "1.852" ;
+$VERSION = "1.853" ;
 $VERSION = eval $VERSION; # needed for dev releases
 
 {
@@ -203,34 +203,34 @@ 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
+        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
 
 );
 
@@ -268,7 +268,7 @@ sub tie_hash_or_array
         if defined $arg[1] ;
 
     $arg[4] = tied %{ $arg[4] } 
-       if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && 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];
@@ -280,10 +280,10 @@ sub tie_hash_or_array
     }
 
     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] ;
+        $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) ;
@@ -325,9 +325,9 @@ sub STORESIZE
     my $current_length = $self->length() ;
 
     if ($length < $current_length) {
-       my $key ;
+        my $key ;
         for ($key = $current_length - 1 ; $key >= $length ; -- $key)
-         { $self->del($key) }
+          { $self->del($key) }
     }
     elsif ($length > $current_length) {
         $self->put($length-1, "") ;
@@ -340,8 +340,8 @@ sub SPLICE
     my $self = shift;
     my $offset = shift;
     if (not defined $offset) {
-       warnings::warnif('uninitialized', 'Use of uninitialized value in splice');
-       $offset = 0;
+        warnings::warnif('uninitialized', 'Use of uninitialized value in splice');
+        $offset = 0;
     }
 
     my $has_length = @_;
@@ -358,47 +358,47 @@ sub SPLICE
     # the array.'
     # 
     if ($offset < 0) {
-       my $new_offset = $size + $offset;
-       if ($new_offset < 0) {
-           die "Modification of non-creatable array value attempted, "
-             . "subscript $offset";
-       }
-       $offset = $new_offset;
+        my $new_offset = $size + $offset;
+        if ($new_offset < 0) {
+            die "Modification of non-creatable array value attempted, "
+              . "subscript $offset";
+        }
+        $offset = $new_offset;
     }
 
     if (not defined $length) {
-       warnings::warnif('uninitialized', 'Use of uninitialized value in splice');
-       $length = 0;
+        warnings::warnif('uninitialized', 'Use of uninitialized value in splice');
+        $length = 0;
     }
 
     if ($offset > $size) {
-       $offset = $size;
-       warnings::warnif('misc', 'splice() offset past end of array')
+        $offset = $size;
+        warnings::warnif('misc', 'splice() offset past end of array')
             if $has_length ? $splice_end_array : $splice_end_array_no_length;
     }
 
     # 'If LENGTH is omitted, removes everything from OFFSET onward.'
     if (not defined $length) {
-       $length = $size - $offset;
+        $length = $size - $offset;
     }
 
     # 'If LENGTH is negative, leave that many elements off the end of
     # the array.'
     # 
     if ($length < 0) {
-       $length = $size - $offset + $length;
-
-       if ($length < 0) {
-           # 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;
-       }
+        $length = $size - $offset + $length;
+
+        if ($length < 0) {
+            # 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;
+        }
     }
 
     if ($length > $size - $offset) {
-       $length = $size - $offset;
+        $length = $size - $offset;
     }
 
     # $num_elems holds the current number of elements in the database.
@@ -409,94 +409,94 @@ sub SPLICE
     # 
     my @removed = ();
     foreach (0 .. $length - 1) {
-       my $old;
-       my $status = $self->get($offset, $old);
-       if ($status != 0) {
-           my $msg = "error from Berkeley DB on get($offset, \$old)";
-           if ($status == 1) {
-               $msg .= ' (no such element?)';
-           }
-           else {
-               $msg .= ": error status $status";
-               if (defined $! and $! ne '') {
-                   $msg .= ", message $!";
-               }
-           }
-           die $msg;
-       }
-       push @removed, $old;
-
-       $status = $self->del($offset);
-       if ($status != 0) {
-           my $msg = "error from Berkeley DB on del($offset)";
-           if ($status == 1) {
-               $msg .= ' (no such element?)';
-           }
-           else {
-               $msg .= ": error status $status";
-               if (defined $! and $! ne '') {
-                   $msg .= ", message $!";
-               }
-           }
-           die $msg;
-       }
-
-       -- $num_elems;
+        my $old;
+        my $status = $self->get($offset, $old);
+        if ($status != 0) {
+            my $msg = "error from Berkeley DB on get($offset, \$old)";
+            if ($status == 1) {
+                $msg .= ' (no such element?)';
+            }
+            else {
+                $msg .= ": error status $status";
+                if (defined $! and $! ne '') {
+                    $msg .= ", message $!";
+                }
+            }
+            die $msg;
+        }
+        push @removed, $old;
+
+        $status = $self->del($offset);
+        if ($status != 0) {
+            my $msg = "error from Berkeley DB on del($offset)";
+            if ($status == 1) {
+                $msg .= ' (no such element?)';
+            }
+            else {
+                $msg .= ": error status $status";
+                if (defined $! and $! ne '') {
+                    $msg .= ", message $!";
+                }
+            }
+            die $msg;
+        }
+
+        -- $num_elems;
     }
 
     # ...'and replaces them with the elements of LIST, if any.'
     my $pos = $offset;
     while (defined (my $elem = shift @list)) {
-       my $old_pos = $pos;
-       my $status;
-       if ($pos >= $num_elems) {
-           $status = $self->put($pos, $elem);
-       }
-       else {
-           $status = $self->put($pos, $elem, $self->R_IBEFORE);
-       }
-
-       if ($status != 0) {
-           my $msg = "error from Berkeley DB on put($pos, $elem, ...)";
-           if ($status == 1) {
-               $msg .= ' (no such element?)';
-           }
-           else {
-               $msg .= ", error status $status";
-               if (defined $! and $! ne '') {
-                   $msg .= ", message $!";
-               }
-           }
-           die $msg;
-       }
-
-       die "pos unexpectedly changed from $old_pos to $pos with R_IBEFORE"
-         if $old_pos != $pos;
-
-       ++ $pos;
-       ++ $num_elems;
+        my $old_pos = $pos;
+        my $status;
+        if ($pos >= $num_elems) {
+            $status = $self->put($pos, $elem);
+        }
+        else {
+            $status = $self->put($pos, $elem, $self->R_IBEFORE);
+        }
+
+        if ($status != 0) {
+            my $msg = "error from Berkeley DB on put($pos, $elem, ...)";
+            if ($status == 1) {
+                $msg .= ' (no such element?)';
+            }
+            else {
+                $msg .= ", error status $status";
+                if (defined $! and $! ne '') {
+                    $msg .= ", message $!";
+                }
+            }
+            die $msg;
+        }
+
+        die "pos unexpectedly changed from $old_pos to $pos with R_IBEFORE"
+          if $old_pos != $pos;
+
+        ++ $pos;
+        ++ $num_elems;
     }
 
     if (wantarray) {
-       # 'In list context, returns the elements removed from the
-       # array.'
-       # 
-       return @removed;
+        # '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";
-       }
-       else {
-           return undef;
-       }
+        # 'In scalar context, returns the last element removed, or
+        # undef if no elements are removed.'
+        
+        if (@removed) {
+            my $last = pop @removed;
+            return "$last";
+        }
+        else {
+            return undef;
+        }
     }
     elsif (not defined wantarray) {
-       # Void context
+        # Void context
     }
     else { die }
 }
@@ -543,11 +543,11 @@ sub get_dup
  
     my $db        = shift ;
     my $key       = shift ;
-    my $flag     = shift ;
-    my $value    = 0 ;
+    my $flag      = shift ;
+    my $value     = 0 ;
     my $origkey   = $key ;
     my $wantarray = wantarray ;
-    my %values   = () ;
+    my %values    = () ;
     my @values    = () ;
     my $counter   = 0 ;
     my $status    = 0 ;
@@ -555,16 +555,16 @@ sub get_dup
     # 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 == 0 and $key eq $origkey ;
          $status = $db->seq($key, $value, R_NEXT()) ) {
  
         # save the value or count number of matches
         if ($wantarray) {
-           if ($flag)
+            if ($flag)
                 { ++ $values{$value} }
-           else
+            else
                 { push (@values, $value) }
-       }
+        }
         else
             { ++ $counter }
      
@@ -692,7 +692,7 @@ like version 1. This feature allows B<DB_File> scripts that were built
 with version 1 to be migrated to version 2 or greater 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.
+2.x or greater, use the Perl module L<BerkeleyDB|https://metacpan.org/pod/BerkeleyDB> instead.
 
 B<Note:> The database file format has changed multiple times in Berkeley
 DB version 2, 3 and 4. If you cannot recreate your databases, you
@@ -753,7 +753,7 @@ 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 ;
+        $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
@@ -809,12 +809,12 @@ to Perl subs. Below are templates for each of the subs:
         my ($data) = @_ ;
         ...
         # return the hash value for $data
-       return $hash ;
+        return $hash ;
     }
 
     sub compare
     {
-       my ($key, $key2) = @_ ;
+        my ($key, $key2) = @_ ;
         ...
         # return  0 if $key1 eq $key2
         #        -1 if $key1 lt $key2
@@ -824,7 +824,7 @@ to Perl subs. Below are templates for each of the subs:
 
     sub prefix
     {
-       my ($key, $key2) = @_ ;
+        my ($key, $key2) = @_ ;
         ...
         # return number of bytes of $key2 which are 
         # necessary to determine that it is greater than $key1
@@ -1041,7 +1041,7 @@ code:
     $DB_BTREE->{'flags'} = R_DUP ;
 
     tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE 
-       or die "Cannot open $filename: $!\n";
+        or die "Cannot open $filename: $!\n";
 
     # Add some key/value pairs to the file
     $h{'Wall'} = 'Larry' ;
@@ -1096,7 +1096,7 @@ Here is the script above rewritten using the C<seq> API method.
     $DB_BTREE->{'flags'} = R_DUP ;
 
     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE 
-       or die "Cannot open $filename: $!\n";
+        or die "Cannot open $filename: $!\n";
 
     # Add some key/value pairs to the file
     $h{'Wall'} = 'Larry' ;
@@ -1167,7 +1167,7 @@ this:
     $DB_BTREE->{'flags'} = R_DUP ;
 
     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE 
-       or die "Cannot open $filename: $!\n";
+        or die "Cannot open $filename: $!\n";
 
     my $cnt  = $x->get_dup("Wall") ;
     print "Wall occurred $cnt times\n" ;
@@ -1177,13 +1177,13 @@ this:
     print "There are $hash{'Brick'} Brick Walls\n" ;
 
     my @list = sort $x->get_dup("Wall") ;
-    print "Wall =>     [@list]\n" ;
+    print "Wall =>      [@list]\n" ;
 
     @list = $x->get_dup("Smith") ;
-    print "Smith =>    [@list]\n" ;
+    print "Smith =>     [@list]\n" ;
 
     @list = $x->get_dup("Dog") ;
-    print "Dog =>      [@list]\n" ;
+    print "Dog =>       [@list]\n" ;
 
 
 and it will print:
@@ -1191,9 +1191,9 @@ and it will print:
     Wall occurred 3 times
     Larry is there
     There are 2 Brick Walls
-    Wall =>    [Brick Brick Larry]
-    Smith =>   [John]
-    Dog =>     []
+    Wall =>     [Brick Brick Larry]
+    Smith =>    [John]
+    Dog =>      []
 
 =head2 The find_dup() Method
 
@@ -1217,7 +1217,7 @@ Assuming the database from the previous example:
     $DB_BTREE->{'flags'} = R_DUP ;
 
     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE 
-       or die "Cannot open $filename: $!\n";
+        or die "Cannot open $filename: $!\n";
 
     $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; 
     print "Larry Wall is $found there\n" ;
@@ -1256,7 +1256,7 @@ Again assuming the existence of the C<tree> database
     $DB_BTREE->{'flags'} = R_DUP ;
 
     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE 
-       or die "Cannot open $filename: $!\n";
+        or die "Cannot open $filename: $!\n";
 
     $x->del_dup("Wall", "Larry") ;
 
@@ -1321,10 +1321,10 @@ and print the first matching key/value pair given a partial key.
     $key = $value = 0 ;
     print "IN ORDER\n" ;
     for ($st = $x->seq($key, $value, R_FIRST) ;
-        $st == 0 ;
+         $st == 0 ;
          $st = $x->seq($key, $value, R_NEXT) )
 
-      {  print "$key   -> $value\n" }
+      {  print "$key    -> $value\n" }
 
     print "\nPARTIAL MATCH\n" ;
 
@@ -1625,12 +1625,12 @@ 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" ;
+        $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) ;
+        $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
@@ -2012,11 +2012,11 @@ 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
+The companion module to this one, L<BerkeleyDB|https://metacpan.org/pod/BerkeleyDB>, provides an interface
 to this locking functionality. If you are serious about locking
-Berkeley DB databases, I strongly recommend using B<BerkeleyDB>.
+Berkeley DB databases, I strongly recommend using L<BerkeleyDB|https://metacpan.org/pod/BerkeleyDB>.
 
-If using B<BerkeleyDB> isn't an option, there are a number of modules
+If using L<BerkeleyDB|https://metacpan.org/pod/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
@@ -2298,6 +2298,12 @@ 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 SUPPORT
+
+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>.
+
 =head1 AVAILABILITY
 
 B<DB_File> comes with the standard Perl source distribution. Look in
@@ -2307,11 +2313,11 @@ date, so the most recent version can always be found on CPAN (see
 L<perlmodlib/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.
+B<DB_File> is designed to work with any version of Berkeley DB, but is limited to the functionality provided by
+version 1. If you want to make use of the new features available in Berkeley DB
+2.x, or greater, use the Perl module L<BerkeleyDB|https://metacpan.org/pod/BerkeleyDB> instead.
 
-The official web site for Berkeley DB is F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>.
+The official web site for Berkeley DB is L<http://www.oracle.com/technology/products/berkeley-db/db/index.html>.
 All versions of Berkeley DB are available there.
 
 Alternatively, Berkeley DB version 1 is available at your nearest CPAN
@@ -2319,7 +2325,7 @@ archive in F<src/misc/db.1.85.tar.gz>.
 
 =head1 COPYRIGHT
 
-Copyright (c) 1995-2016 Paul Marquess. All rights reserved. This program
+Copyright (c) 1995-2020 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.
 
@@ -2328,7 +2334,7 @@ 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 a few words taken from the Berkeley DB FAQ (at
-F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>) regarding the license:
+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? 
 
index b6db8d6..ab95369 100644 (file)
@@ -6,7 +6,7 @@
 
  All comments/suggestions/problems are welcome
 
-     Copyright (c) 1995-2019 Paul Marquess. All rights reserved.
+     Copyright (c) 1995-2020 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.
 
@@ -462,13 +462,21 @@ typedef DBT DBTKEY ;
       }                                                               \
     }
 
+/* Macro err_close only for use in croak_and_free */
+#ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1  or 2 */
+#  define err_close(r)
+#else
+#  define err_close(r) db_close(r)
+#endif
+
 /* Macro croak_and_free only for use in ParseOpenInfo */
-#define croak_and_free(x)                                                                                        \
-       do                                                                                                                                \
-       {                                                                                                                                 \
-               Safefree(RETVAL);                                                                                         \
-               croak(x);                                                                                                         \
-       } while (0)
+#define croak_and_free(x)                                             \
+    do                                                                \
+    {                                                                 \
+        if (RETVAL->dbp) err_close(RETVAL) ;                           \
+        Safefree(RETVAL);                                             \
+        croak(x);                                                     \
+    } while (0)
 
 #define my_SvUV32(sv) ((u_int32_t)SvUV(sv))
 
@@ -1284,7 +1292,8 @@ SV *   sv ;
     int     status ;
     dMY_CXT;
 
-/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ;  */
+    Trace(("In ParseOpenInfo name=[%s] flags=[%d] mode=[%d] SV NULL=[%d]\n",\
+            name, flags, mode, sv == NULL)) ;
     Zero(RETVAL, 1, DB_File_type) ;
 
     /* Default to HASH */
@@ -1301,7 +1310,7 @@ SV *   sv ;
     RETVAL->in_memory = (name == NULL) ;
 
     status = db_create(&RETVAL->dbp, NULL,0) ;
-    /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */
+    Trace(("db_create returned %d %s\n", status, db_strerror(status))) ;
     if (status) {
         RETVAL->dbp = NULL ;
         return (RETVAL) ;
@@ -1518,12 +1527,12 @@ SV *   sv ;
         status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type,
                     Flags, mode) ;
 #endif
-        /* printf("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) ;
-            /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */
+            Trace(("cursor returned %d %s\n", status, db_strerror(status))) ; 
         }
 
         if (status)
@@ -1578,6 +1587,7 @@ db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_H
         char *  name = (char *) NULL ;
         SV *    sv = (SV *) NULL ;
         STRLEN  n_a;
+        Trace(("In db_DoTie_\n"));
 
         if (items >= 3 && SvOK(ST(2)))
             name = (char*) SvPV(ST(2), n_a) ;
index b7bfbb8..774c219 100644 (file)
@@ -46,14 +46,14 @@ my $WALL = '' ;
 my $CORE = $ENV{PERL_CORE} ? '' : '-D_NOT_CORE';
 
 WriteMakefile(
-       NAME            => 'DB_File',
-       LIBS            => ["-L${LIB_DIR} $LIBS"],
-       INC                 => "-I$INC_DIR",
-    VERSION_FROM       => 'DB_File.pm',
-       XS_VERSION      => eval MM->parse_version('DB_File.pm'),
-       XSPROTOARG      => '-noprototypes',
-       DEFINE          => "$CORE $OS2 $VER_INFO $COMPAT185 $WALL",
-       OBJECT          => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)',
+        NAME            => 'DB_File',
+        LIBS            => ["-L${LIB_DIR} $LIBS"],
+        INC             => "-I$INC_DIR",
+        VERSION_FROM    => 'DB_File.pm',
+        XS_VERSION      => eval MM->parse_version('DB_File.pm'),
+        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')         
         : ()
@@ -69,13 +69,13 @@ WriteMakefile(
         ? (INSTALLDIRS => 'site') 
         : (INSTALLDIRS => 'perl'),
 
-       #OPTIMIZE       => '-g',
-       'depend'        => { 'Makefile'          => 'config.in',
+        #OPTIMIZE       => '-g',
+        'depend'        => { 'Makefile'          => 'config.in',
                              'version$(OBJ_EXT)' => 'version.c'},
-       'clean'         => { FILES => 'constants.h constants.xs DB_File.pm.bak t/db-btree.t.bak t/db-hash.t.bak t/db-recno.t.bak t/pod.t.bak' },
-       'macro'         => { my_files => "@files" },
-    'dist'      => { COMPRESS => 'gzip', SUFFIX => 'gz',
-                                DIST_DEFAULT => 'MyDoubleCheck tardist'},
+        'clean'         => { FILES => 'constants.h constants.xs DB_File.pm.bak t/db-btree.t.bak t/db-hash.t.bak t/db-recno.t.bak t/pod.t.bak' },
+        'macro'         => { my_files => "@files" },
+        'dist'          => { COMPRESS => 'gzip', SUFFIX => 'gz',
+                             DIST_DEFAULT => 'MyDoubleCheck tardist'},
 
      ( eval { ExtUtils::MakeMaker->VERSION(6.46) }  
         ? ( META_MERGE  => {
@@ -102,39 +102,39 @@ WriteMakefile(
     ),
 
 
-       );
+        );
 
 
 my @names = qw(
-       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
-       );
+        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
+        );
 
 if (eval {require ExtUtils::Constant; 1}) {
     # Check the constants above all appear in @EXPORT in DB_File.pm
@@ -197,9 +197,9 @@ sub MY::postamble { <<'EOM' } ;
 
 MyDoubleCheck:
        @echo Checking config.in is setup for a release
-       @(grep "^LIB.*/usr/local/BerkeleyDB" config.in &&       \
-       grep "^INCLUDE.*/usr/local/BerkeleyDB" config.in &&     \
-       grep "^#DBNAME.*" config.in) >/dev/null ||              \
+       @(grep "^LIB.*/usr/local/BerkeleyDB" config.in &&       \
+       grep "^INCLUDE.*/usr/local/BerkeleyDB" config.in &&     \
+       grep "^#DBNAME.*" config.in) >/dev/null ||              \
            (echo config.in needs fixing ; exit 1)
        @echo config.in is ok
        @echo 
@@ -209,16 +209,16 @@ MyDoubleCheck:
        @echo DB_File.xs is ok
        @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)
+       @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 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)
+       @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 All files are OK for a release.
@@ -249,24 +249,24 @@ sub ParseCONFIG
 
     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) ;
-       }
+        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 ;
+        if @badkey ;
 
     # check parsed values
     my @missing = () ;
@@ -278,18 +278,18 @@ sub ParseCONFIG
     $DB_NAME = $ENV{'DB_FILE_NAME'} || $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 ; 
+                $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]
+    INCLUDE     [$INC_DIR]
+    LIB         [$LIB_DIR]
+    HASH        [$HASH]
+    PREFIX      [$PREFIX]
     DBNAME      [$DB_NAME]
 
 EOM
@@ -321,10 +321,10 @@ sub UpDowngrade
         # From: warnings::warnif(x,y);
         # To:   $^W && carp(y); # warnif -- x
         $warn_sub = sub {
-           s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ;
-           s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ;
+            s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ;
+            s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ;
 
-           s/^(\s*)warnings::warnif\s*\((.*?)\s*,\s*(.*?)\)\s*;/${1}\$^W && carp($3); # warnif - $2/ ;
+            s/^(\s*)warnings::warnif\s*\((.*?)\s*,\s*(.*?)\)\s*;/${1}\$^W && carp($3); # warnif - $2/ ;
           };
     }
     else {
@@ -336,14 +336,14 @@ sub UpDowngrade
         # From: $^W && carp(y); # warnif -- x
         # To:   warnings::warnif(x,y);
         $warn_sub = sub {
-           s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ;
-           s/^(\s*)\$\^W\s+\&\&\s*carp\s*\((.*?)\)\s*;\s*#\s*warnif\s*-\s*(.*)/${1}warnings::warnif($3, $2);/ ;
+            s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ;
+            s/^(\s*)\$\^W\s+\&\&\s*carp\s*\((.*?)\)\s*;\s*#\s*warnif\s*-\s*(.*)/${1}warnings::warnif($3, $2);/ ;
           };
     }
 
     if ($] < 5.006000) {
         $our_sub = sub {
-           if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) {
+            if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) {
                 my $indent = $1;
                 my $vars = join ' ', split /\s*,\s*/, $2;
                 $_ = "${indent}use vars qw($vars);\n";
@@ -352,7 +352,7 @@ sub UpDowngrade
     }
     else {
         $our_sub = sub {
-           if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) {
+            if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) {
                 my $indent = $1;
                 my $vars = join ', ', split ' ', $2;
                 $_ = "${indent}our ($vars);\n";
@@ -375,11 +375,11 @@ sub doUpDown
 
     while (<>)
     {
-       print, last if /^__(END|DATA)__/ ;
+        print, last if /^__(END|DATA)__/ ;
 
-       &{ $our_sub }();
-       &{ $warn_sub }();
-       print ;
+        &{ $our_sub }();
+        &{ $warn_sub }();
+        print ;
     }
 
     return if eof ;
index 292b09a..d79a950 100644 (file)
@@ -1,6 +1,6 @@
 # Filename:    config.in
 #
-# written by Paul Marquess <Paul.Marquess@btinternet.com>
+# written by Paul Marquess <pmqs@cpan.org>
 # last modified 9th Sept 1997
 # version 1.55
 
index e8abc97..c2842f6 100644 (file)
@@ -1,13 +1,13 @@
-#!/usr/local/bin/perl
+#!/usr/bin/perl
 
-# Name:                dbinfo -- identify berkeley DB version used to create 
-#                        a database file
+# Name:         dbinfo -- identify berkeley DB version used to create 
+#                         a database file
 #
-# Author:      Paul Marquess  <Paul.Marquess@btinternet.com>
-# Version:     1.06 
-# Date         27th March 2008
+# Author:       Paul Marquess  <pmqs@cpan.org>
+# Version:      1.07 
+# Date          2nd April 2011
 #
-#     Copyright (c) 1998-2012 Paul Marquess. All rights reserved.
+#     Copyright (c) 1998-2020 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.
 
 use strict ;
 
 my %Data =
-       (
-       0x053162 =>     # DB_BTREEMAGIC
+        (
+        0x053162 =>     # DB_BTREEMAGIC
             {
-                         Type     => "Btree",
-                         Versions => # DB_BTREEVERSION
-                               {
-                                 1     => [0, "Unknown (older than 1.71)"],
-                                 2     => [0, "Unknown (older than 1.71)"],
-                                 3     => [0, "1.71 -> 1.85, 1.86"],
-                                 4     => [0, "Unknown"],
-                                 5     => [0, "2.0.0 -> 2.3.0"],
-                                 6     => [0, "2.3.1 -> 2.7.7"],
-                                 7     => [0, "3.0.x"],
-                                 8     => [0, "3.1.x -> 4.0.x"],
-                                 9     => [1, "4.1.x or greater"],
-                               }
-                       },
-       0x061561 =>     # DB_HASHMAGIC
+                          Type     => "Btree",
+                          Versions => # DB_BTREEVERSION
+                                {
+                                  1     => [0, "Unknown (older than 1.71)"],
+                                  2     => [0, "Unknown (older than 1.71)"],
+                                  3     => [0, "1.71 -> 1.85, 1.86"],
+                                  4     => [0, "Unknown"],
+                                  5     => [0, "2.0.0 -> 2.3.0"],
+                                  6     => [0, "2.3.1 -> 2.7.7"],
+                                  7     => [0, "3.0.x"],
+                                  8     => [0, "3.1.x -> 4.0.x"],
+                                  9     => [1, "4.1.x or greater"],
+                                }
+                        },
+        0x061561 =>     # DB_HASHMAGIC
             {
-                         Type     => "Hash",
-                         Versions => # DB_HASHVERSION
-                               {
-                                 1     => [0, "Unknown (older than 1.71)"],
-                                 2     => [0, "1.71 -> 1.85"],
-                                 3     => [0, "1.86"],
-                                 4     => [0, "2.0.0 -> 2.1.0"],
-                                 5     => [0, "2.2.6 -> 2.7.7"],
-                                 6     => [0, "3.0.x"],
-                                 7     => [0, "3.1.x -> 4.0.x"],
-                                 8     => [1, "4.1.x or greater"],
-                                 9     => [1, "4.6.x or greater"],
-                               }
-                       },
-       0x042253 =>     # DB_QAMMAGIC
+                          Type     => "Hash",
+                          Versions => # DB_HASHVERSION
+                                {
+                                  1     => [0, "Unknown (older than 1.71)"],
+                                  2     => [0, "1.71 -> 1.85"],
+                                  3     => [0, "1.86"],
+                                  4     => [0, "2.0.0 -> 2.1.0"],
+                                  5     => [0, "2.2.6 -> 2.7.7"],
+                                  6     => [0, "3.0.x"],
+                                  7     => [0, "3.1.x -> 4.0.x"],
+                                  8     => [1, "4.1.x or greater"],
+                                  9     => [1, "4.6.x or greater"],
+                                }
+                        },
+        0x042253 =>     # DB_QAMMAGIC
             {
-                         Type     => "Queue",
-                         Versions => # DB_QAMVERSION
-                               {
-                                 1     => [0, "3.0.x"],
-                                 2     => [0, "3.1.x"],
-                                 3     => [0, "3.2.x -> 4.0.x"],
-                                 4     => [1, "4.1.x or greater"],
-                               }
-                       },
-       ) ;
+                          Type     => "Queue",
+                          Versions => # DB_QAMVERSION
+                                {
+                                  1     => [0, "3.0.x"],
+                                  2     => [0, "3.1.x"],
+                                  3     => [0, "3.2.x -> 4.0.x"],
+                                  4     => [1, "4.1.x or greater"],
+                                }
+                        },
+        0x074582 =>      # DB_HEAPMAGIC
+            {
+                          Type     => "Heap",
+                          Versions => # DB_HEAPVERSION
+                                {
+                                  1        => [1, "5.2.x"],
+                                }
+                        },
+        ) ;
 
 die "Usage: dbinfo file\n" unless @ARGV == 1 ;
 
@@ -120,11 +128,11 @@ 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
+File Type:              Berkeley DB $type->{Type} file.
+File Version ID:        $version
+Built with Berkeley DB: $ver_string
+Byte Order:             $endian
+Magic:                  $magic
 Encryption:             $encrypt
 EOM
 
index 4ff405e..86cfb0c 100644 (file)
@@ -16,11 +16,11 @@ BEGIN {
 BEGIN
 {
     if ($^O eq 'darwin'
-       && (split(/\./, $Config{osvers}))[0] < 7 # Mac OS X 10.3 == Darwin 7
-       && $Config{db_version_major} == 1
-       && $Config{db_version_minor} == 0
-       && $Config{db_version_patch} == 0) {
-       warn <<EOM;
+        && (split(/\./, $Config{osvers}))[0] < 7 # Mac OS X 10.3 == Darwin 7
+        && $Config{db_version_major} == 1
+        && $Config{db_version_minor} == 0
+        && $Config{db_version_patch} == 0) {
+        warn <<EOM;
 #
 # This test is known to crash in Mac OS X versions 10.2 (or earlier)
 # because of the buggy Berkeley DB version included with the OS.
@@ -69,17 +69,17 @@ sub lexical
     {
         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 ] ;
+        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]) ;
+        close $self->[0] ;
+        select($self->[1]) ;
     }
 }
 
@@ -124,7 +124,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 
-                               || $DB_File::db_ver >= 3.1 );
+                                || $DB_File::db_ver >= 3.1 );
 
 my $TEMPDIR = tempdir( CLEANUP => 1 );
 chdir $TEMPDIR;
@@ -263,8 +263,8 @@ ok(25, $#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;
+        $key =~ y/a-z/A-Z/;
+        $i++ if $key eq $value;
     }
 }
 
@@ -412,7 +412,7 @@ ok(61, $key eq 'replace key' );
 ok(62, $value eq 'replace value' );
 $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
+            # only worked because of a bug in 1.85/6
 
 # use seq to walk forwards through a file 
 
@@ -520,7 +520,7 @@ 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 
-               && $wall{'Brick'} == 2);
+                && $wall{'Brick'} == 2);
 
 undef $YY ;
 untie %hh ;
@@ -534,8 +534,8 @@ my $Dfile3 = "btree3" ;
  
 my $dbh1 = new DB_File::BTREEINFO ;
 $dbh1->{compare} = sub { 
-       no warnings 'numeric' ;
-       $_[0] <=> $_[1] } ; 
+        no warnings 'numeric' ;
+        $_[0] <=> $_[1] } ; 
  
 my $dbh2 = new DB_File::BTREEINFO ;
 $dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
@@ -647,37 +647,37 @@ unlink $Dfile1 ;
    @EXPORT = @DB_File::EXPORT ;
 
    sub STORE { 
-       my $self = shift ;
+        my $self = shift ;
         my $key = shift ;
         my $value = shift ;
         $self->SUPER::STORE($key, $value * 2) ;
    }
 
    sub FETCH { 
-       my $self = shift ;
+        my $self = shift ;
         my $key = shift ;
         $self->SUPER::FETCH($key) - 1 ;
    }
 
    sub put { 
-       my $self = shift ;
+        my $self = shift ;
         my $key = shift ;
         my $value = shift ;
         $self->SUPER::put($key, $value * 3) ;
    }
 
    sub get { 
-       my $self = shift ;
+        my $self = shift ;
         $self->SUPER::get($_[0], $_[1]) ;
-       $_[1] -= 2 ;
+        $_[1] -= 2 ;
    }
 
    sub A_new_method
    {
-       my $self = shift ;
+        my $self = shift ;
         my $key = shift ;
         my $value = $self->FETCH($key) ;
-       return "[[$value]]" ;
+        return "[[$value]]" ;
    }
 
    1 ;
@@ -691,8 +691,8 @@ EOM
     my %h ;
     my $X ;
     eval '
-       $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE );
-       ' ;
+        $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE );
+        ' ;
 
     main::ok(92, $@ eq "") ;
 
@@ -732,8 +732,8 @@ EOM
        my($fk, $sk, $fv, $sv) = @_ ;
        return
            $fetch_key eq $fk && $store_key eq $sk && 
-          $fetch_value eq $fv && $store_value eq $sv &&
-          $_ eq 'original' ;
+           $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 ) );
@@ -761,13 +761,13 @@ EOM
 
    # replace the filters, but remember the previous set
    my ($old_fk) = $db->filter_fetch_key   
-                       (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+                        (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
    my ($old_sk) = $db->filter_store_key   
-                       (sub { $_ = lc $_ ; $store_key = $_ }) ;
+                        (sub { $_ = lc $_ ; $store_key = $_ }) ;
    my ($old_fv) = $db->filter_fetch_value 
-                       (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+                        (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
    my ($old_sv) = $db->filter_store_value 
-                       (sub { s/o/x/g; $store_value = $_ }) ;
+                        (sub { s/o/x/g; $store_value = $_ }) ;
    
    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
    $h{"Fred"} = "Joe" ;
@@ -840,13 +840,13 @@ EOM
     sub Closure
     {
         my ($name) = @_ ;
-       my $count = 0 ;
-       my @kept = () ;
+        my $count = 0 ;
+        my @kept = () ;
 
-       return sub { ++$count ; 
-                    push @kept, $_ ; 
-                    $result{$name} = "$name - $count: [@kept]" ;
-                  }
+        return sub { ++$count ; 
+                     push @kept, $_ ; 
+                     $result{$name} = "$name - $count: [@kept]" ;
+                   }
     }
 
     $db->filter_store_key(Closure("store key")) ;
@@ -887,7 +887,7 @@ EOM
     undef $db ;
     untie %h;
     unlink $Dfile;
-}              
+}               
 
 {
    # DBM Filter recursion detection
@@ -986,7 +986,7 @@ EOM
     $DB_BTREE->{'flags'} = R_DUP ;
  
     tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
-       or die "Cannot open $filename: $!\n";
+        or die "Cannot open $filename: $!\n";
  
     # Add some key/value pairs to the file
     $h{'Wall'} = 'Larry' ;
@@ -998,7 +998,7 @@ EOM
     # iterate through the associative array
     # and print each key/value pair.
     foreach (keys %h)
-      { print "$_      -> $h{$_}\n" }
+      { print "$_ -> $h{$_}\n" }
 
     untie %h ;
 
@@ -1006,17 +1006,17 @@ EOM
   }  
 
   ok(148, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ;
-Smith  -> John
-Wall   -> Brick
-Wall   -> Brick
-Wall   -> Brick
-mouse  -> mickey
+Smith -> John
+Wall -> Brick
+Wall -> Brick
+Wall -> Brick
+mouse -> mickey
 EOM
-Smith  -> John
-Wall   -> Larry
-Wall   -> Larry
-Wall   -> Larry
-mouse  -> mickey
+Smith -> John
+Wall -> Larry
+Wall -> Larry
+Wall -> Larry
+mouse -> mickey
 EOM
 
   {
@@ -1038,7 +1038,7 @@ EOM
     $DB_BTREE->{'flags'} = R_DUP ;
  
     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
-       or die "Cannot open $filename: $!\n";
+        or die "Cannot open $filename: $!\n";
  
     # Add some key/value pairs to the file
     $h{'Wall'} = 'Larry' ;
@@ -1053,7 +1053,7 @@ EOM
     for ($status = $x->seq($key, $value, R_FIRST) ;
          $status == 0 ;
          $status = $x->seq($key, $value, R_NEXT) )
-      {  print "$key   -> $value\n" }
+      {  print "$key -> $value\n" }
  
  
     undef $x ;
@@ -1061,17 +1061,17 @@ EOM
   }
 
   ok(149, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ;
-Smith  -> John
-Wall   -> Brick
-Wall   -> Brick
-Wall   -> Larry
-mouse  -> mickey
+Smith -> John
+Wall -> Brick
+Wall -> Brick
+Wall -> Larry
+mouse -> mickey
 EOM
-Smith  -> John
-Wall   -> Larry
-Wall   -> Brick
-Wall   -> Brick
-mouse  -> mickey
+Smith -> John
+Wall -> Larry
+Wall -> Brick
+Wall -> Brick
+mouse -> mickey
 EOM
 
 
@@ -1093,7 +1093,7 @@ EOM
     $DB_BTREE->{'flags'} = R_DUP ;
  
     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
-       or die "Cannot open $filename: $!\n";
+        or die "Cannot open $filename: $!\n";
  
     my $cnt  = $x->get_dup("Wall") ;
     print "Wall occurred $cnt times\n" ;
@@ -1103,13 +1103,13 @@ EOM
     print "There are $hash{'Brick'} Brick Walls\n" ;
 
     my @list = sort $x->get_dup("Wall") ;
-    print "Wall =>     [@list]\n" ;
+    print "Wall => [@list]\n" ;
 
     @list = $x->get_dup("Smith") ;
-    print "Smith =>    [@list]\n" ;
+    print "Smith => [@list]\n" ;
  
     @list = $x->get_dup("Dog") ;
-    print "Dog =>      [@list]\n" ; 
+    print "Dog => [@list]\n" ; 
  
     undef $x ;
     untie %h ;
@@ -1119,9 +1119,9 @@ EOM
 Wall occurred 3 times
 Larry is there
 There are 2 Brick Walls
-Wall =>        [Brick Brick Larry]
-Smith =>       [John]
-Dog => []
+Wall => [Brick Brick Larry]
+Smith => [John]
+Dog => []
 EOM
 
   {
@@ -1142,7 +1142,7 @@ EOM
     $DB_BTREE->{'flags'} = R_DUP ;
  
     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
-       or die "Cannot open $filename: $!\n";
+        or die "Cannot open $filename: $!\n";
 
     $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; 
     print "Larry Wall is $found there\n" ;
@@ -1177,7 +1177,7 @@ EOM
     $DB_BTREE->{'flags'} = R_DUP ;
  
     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
-       or die "Cannot open $filename: $!\n";
+        or die "Cannot open $filename: $!\n";
 
     $x->del_dup("Wall", "Larry") ;
 
@@ -1213,7 +1213,7 @@ EOM
         my $value = 0;
         my $orig_key = $key ;
         $x->seq($key, $value, R_CURSOR) ;
-        print "$orig_key\t-> $key\t-> $value\n" ;
+        print "$orig_key -> $key -> $value\n" ;
     }
 
     $filename = "tree" ;
@@ -1232,10 +1232,10 @@ EOM
     $key = $value = 0 ;
     print "IN ORDER\n" ;
     for ($st = $x->seq($key, $value, R_FIRST) ;
-        $st == 0 ;
+         $st == 0 ;
          $st = $x->seq($key, $value, R_NEXT) )
-       
-      {  print "$key   -> $value\n" }
+        
+      {  print "$key -> $value\n" }
  
     print "\nPARTIAL MATCH\n" ;
 
@@ -1252,15 +1252,15 @@ EOM
 
   ok(153, docat_del($file) eq <<'EOM') ;
 IN ORDER
-Smith  -> John
-Wall   -> Larry
-Walls  -> Brick
-mouse  -> mickey
+Smith -> John
+Wall -> Larry
+Walls -> Brick
+mouse -> mickey
 
 PARTIAL MATCH
-Wa     -> Wall -> Larry
-A      -> Smith        -> John
-a      -> mouse        -> mickey
+Wa -> Wall -> Larry
+A -> Smith -> John
+a -> mouse -> mickey
 EOM
 
 }
@@ -1280,7 +1280,7 @@ EOM
     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" ;
+        or die "Can't open file: $!\n" ;
     $h{ABC} = undef;
     ok(154, $a eq "") ;
     untie %h ;
@@ -1300,7 +1300,7 @@ EOM
     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" ;
+        or die "Can't open file: $!\n" ;
     %h = (); ;
     ok(155, $a eq "") ;
     untie %h ;
@@ -1373,9 +1373,9 @@ EOM
 #    my (%h);
 #    ok(164, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) );
 #
-#    eval {    $hash{1} = 2;
-#              $hash{4} = 5;
-#       };
+#    eval {     $hash{1} = 2;
+#               $hash{4} = 5;
+#        };
 #
 #    ok(165, $@ =~ /^DB_File btree_compare: recursion detected/);
 #    {
index 97b77fc..79ffe93 100644 (file)
@@ -40,17 +40,17 @@ sub ok
     {
         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 ] ;
+        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]) ;
+        close $self->[0] ;
+        select($self->[1]) ;
     }
 }
 
@@ -89,7 +89,7 @@ chdir $TEMPDIR;
 my $Dfile = "dbhash.tmp";
 my $Dfile2 = "dbhash2.tmp";
 my $null_keys_allowed = ($DB_File::db_ver < 2.004010 
-                               || $DB_File::db_ver >= 3.1 );
+                                || $DB_File::db_ver >= 3.1 );
 
 unlink $Dfile;
 
@@ -225,8 +225,8 @@ 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;
+        $key =~ y/a-z/A-Z/;
+        $i++ if $key eq $value;
     }
 }
 
@@ -427,37 +427,37 @@ untie %h ;
    @EXPORT = @DB_File::EXPORT ;
 
    sub STORE { 
-       my $self = shift ;
+        my $self = shift ;
         my $key = shift ;
         my $value = shift ;
         $self->SUPER::STORE($key, $value * 2) ;
    }
 
    sub FETCH { 
-       my $self = shift ;
+        my $self = shift ;
         my $key = shift ;
         $self->SUPER::FETCH($key) - 1 ;
    }
 
    sub put { 
-       my $self = shift ;
+        my $self = shift ;
         my $key = shift ;
         my $value = shift ;
         $self->SUPER::put($key, $value * 3) ;
    }
 
    sub get { 
-       my $self = shift ;
+        my $self = shift ;
         $self->SUPER::get($_[0], $_[1]) ;
-       $_[1] -= 2 ;
+        $_[1] -= 2 ;
    }
 
    sub A_new_method
    {
-       my $self = shift ;
+        my $self = shift ;
         my $key = shift ;
         my $value = $self->FETCH($key) ;
-       return "[[$value]]" ;
+        return "[[$value]]" ;
    }
 
    1 ;
@@ -471,8 +471,8 @@ EOM
     my %h ;
     my $X ;
     eval '
-       $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH );
-       ' ;
+        $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH );
+        ' ;
 
     main::ok(54, $@ eq "") ;
 
@@ -525,8 +525,8 @@ EOM
 
        return
            $fetch_key   eq $fk && $store_key   eq $sk && 
-          $fetch_value eq $fv && $store_value eq $sv &&
-          $_ eq 'original' ;
+           $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 ) );
@@ -558,13 +558,13 @@ EOM
 
    # replace the filters, but remember the previous set
    my ($old_fk) = $db->filter_fetch_key   
-                       (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+                        (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
    my ($old_sk) = $db->filter_store_key   
-                       (sub { $_ = lc $_ ; $store_key = $_ }) ;
+                        (sub { $_ = lc $_ ; $store_key = $_ }) ;
    my ($old_fv) = $db->filter_fetch_value 
-                       (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+                        (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
    my ($old_sv) = $db->filter_store_value 
-                       (sub { s/o/x/g; $store_value = $_ }) ;
+                        (sub { s/o/x/g; $store_value = $_ }) ;
    
    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
    $h{"Fred"} = "Joe" ;
@@ -649,13 +649,13 @@ EOM
     sub Closure
     {
         my ($name) = @_ ;
-       my $count = 0 ;
-       my @kept = () ;
+        my $count = 0 ;
+        my @kept = () ;
 
-       return sub { ++$count ; 
-                    push @kept, $_ ; 
-                    $result{$name} = "$name - $count: [@kept]" ;
-                  }
+        return sub { ++$count ; 
+                     push @kept, $_ ; 
+                     $result{$name} = "$name - $count: [@kept]" ;
+                   }
     }
 
     $db->filter_store_key(Closure("store key")) ;
@@ -696,7 +696,7 @@ EOM
     undef $db ;
     untie %h;
     unlink $Dfile;
-}              
+}               
 
 {
    # DBM Filter recursion detection
@@ -868,9 +868,9 @@ EOM
 # 
 #    ok(127, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) );
 #
-#    eval {    $hash{1} = 2;
-#              $hash{4} = 5;
-#       };
+#    eval {     $hash{1} = 2;
+#               $hash{4} = 5;
+#        };
 #
 #    ok(128, $@ =~ /^DB_File hash callback: recursion detected/);
 #    {
index 18b7e9e..08a89ff 100644 (file)
@@ -50,17 +50,17 @@ sub ok
     {
         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 ] ;
+        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]) ;
+        close $self->[0] ;
+        select($self->[1]) ;
     }
 }
 
@@ -95,23 +95,23 @@ sub safeUntie
 sub bad_one
 {
     unless ($bad_ones++) {
-       print STDERR <<EOM ;
+        print STDERR <<EOM ;
 #
 # Some older versions of Berkeley DB version 1 will fail db-recno
 # tests 61, 63, 64 and 65.
 EOM
         if ($^O eq 'darwin'
-           && $Config{db_version_major} == 1
-           && $Config{db_version_minor} == 0
-           && $Config{db_version_patch} == 0) {
-           print STDERR <<EOM ;
+            && $Config{db_version_major} == 1
+            && $Config{db_version_minor} == 0
+            && $Config{db_version_patch} == 0) {
+            print STDERR <<EOM ;
 #
 # For example Mac OS X 10.2 (or earlier) has such an old
 # version of Berkeley DB.
 EOM
-       }
+        }
 
-       print STDERR <<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). 
@@ -205,7 +205,7 @@ ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
 my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ;
 
 ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640)
-       ||  $noMode{$^O} );
+        ||  $noMode{$^O} );
 
 #my $l = @h ;
 my $l = $X->length ;
@@ -429,37 +429,37 @@ unlink $Dfile;
    @EXPORT = @DB_File::EXPORT ;
 
    sub STORE { 
-       my $self = shift ;
+        my $self = shift ;
         my $key = shift ;
         my $value = shift ;
         $self->SUPER::STORE($key, $value * 2) ;
    }
 
    sub FETCH { 
-       my $self = shift ;
+        my $self = shift ;
         my $key = shift ;
         $self->SUPER::FETCH($key) - 1 ;
    }
 
    sub put { 
-       my $self = shift ;
+        my $self = shift ;
         my $key = shift ;
         my $value = shift ;
         $self->SUPER::put($key, $value * 3) ;
    }
 
    sub get { 
-       my $self = shift ;
+        my $self = shift ;
         $self->SUPER::get($_[0], $_[1]) ;
-       $_[1] -= 2 ;
+        $_[1] -= 2 ;
    }
 
    sub A_new_method
    {
-       my $self = shift ;
+        my $self = shift ;
         my $key = shift ;
         my $value = $self->FETCH($key) ;
-       return "[[$value]]" ;
+        return "[[$value]]" ;
    }
 
    1 ;
@@ -473,8 +473,8 @@ EOM
     my @h ;
     my $X ;
     eval '
-       $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO );
-       ' ;
+        $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO );
+        ' ;
     die "Could not tie: $!" unless $X;
 
     main::ok(73, $@ eq "") ;
@@ -586,8 +586,8 @@ EOM
 
        return
            $fetch_key   eq $fk && $store_key   eq $sk && 
-          $fetch_value eq $fv && $store_value eq $sv &&
-          $_ eq 'original' ;
+           $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 ) );
@@ -615,13 +615,13 @@ EOM
 
    # replace the filters, but remember the previous set
    my ($old_fk) = $db->filter_fetch_key   
-                       (sub { ++ $_ ; $fetch_key = $_ }) ;
+                        (sub { ++ $_ ; $fetch_key = $_ }) ;
    my ($old_sk) = $db->filter_store_key   
-                       (sub { $_ *= 2 ; $store_key = $_ }) ;
+                        (sub { $_ *= 2 ; $store_key = $_ }) ;
    my ($old_fv) = $db->filter_fetch_value 
-                       (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+                        (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
    my ($old_sv) = $db->filter_store_value 
-                       (sub { s/o/x/g; $store_value = $_ }) ;
+                        (sub { s/o/x/g; $store_value = $_ }) ;
    
    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
    $h[1] = "Joe" ;
@@ -694,13 +694,13 @@ EOM
     sub Closure
     {
         my ($name) = @_ ;
-       my $count = 0 ;
-       my @kept = () ;
+        my $count = 0 ;
+        my @kept = () ;
 
-       return sub { ++$count ; 
-                    push @kept, $_ ; 
-                    $result{$name} = "$name - $count: [@kept]" ;
-                  }
+        return sub { ++$count ; 
+                     push @kept, $_ ; 
+                     $result{$name} = "$name - $count: [@kept]" ;
+                   }
     }
 
     $db->filter_store_key(Closure("store key")) ;
@@ -741,7 +741,7 @@ EOM
     undef $db ;
     ok(144, safeUntie \@h);
     unlink $Dfile;
-}              
+}               
 
 {
    # DBM Filter recursion detection
@@ -944,7 +944,7 @@ EOM
     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" ;
+        or die "Can't open file: $!\n" ;
     $h[0] = undef;
     ok(150, $a eq "") ;
     ok(151, safeUntie \@h);
@@ -964,7 +964,7 @@ EOM
     my @h ;
     
     tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO 
-       or die "Can't open file: $!\n" ;
+        or die "Can't open file: $!\n" ;
     @h = (); ;
     ok(152, $a eq "") ;
     ok(153, safeUntie \@h);
@@ -1170,7 +1170,7 @@ EOM
     $value = '' ;
     $status = $db->get(undef, $value) ;
     ok 178, $status == 0
-       or print "# get failed - status $status\n" ;
+        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 '' 
@@ -1202,7 +1202,7 @@ exit unless $FA ;
     my @tied ;
     
     tie @tied, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO 
-       or die "Can't open file: $!\n" ;
+        or die "Can't open file: $!\n" ;
 
     # uninitialized offset
     use warnings;
@@ -1271,52 +1271,52 @@ exit unless $FA ;
 # Perl's built-in splice().
 # 
 my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion',
-                'rarely', 'paleness' ],
-              -4, -2,
-              [ 'redoubled', 'Taylorize', 'Zoe', 'halogen' ],
-              'void' ],
-
-            [ [ 'a' ], -2, 1, [ 'B' ], 'void' ],
-
-            [ [ 'Hartley', 'Islandia', 'assents', 'wishful' ],
-              0, -4,
-              [ 'maids' ],
-              'void' ],
-
-            [ [ 'visibility', 'pocketful', 'rectangles' ],
-              -10, 0,
-              [ 'garbages' ],
-              'void' ],
-
-            [ [ 'sleeplessly' ],
-              8, -4,
-              [ 'Margery', 'clearing', 'repercussion', 'clubs',
-                'arise' ],
-              'void' ],
-
-            [ [ 'chastises', 'recalculates' ],
-              0, 0,
-              [ 'momentariness', 'mediates', 'accents', 'toils',
-                'regaled' ],
-              'void' ],
-
-            [ [ 'b', '' ],
-              9, 8,
-              [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ],
-              'scalar' ],
-
-            [ [ 'b', '' ],
-              undef, undef,
-              [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ],
-              'scalar' ],
-            
-            [ [ 'riheb' ], -8, undef, [], 'void' ],
-
-            [ [ 'uft', 'qnxs', '' ],
-              6, -2,
-              [ 'znp', 'mhnkh', 'bn' ],
-              'void' ],
-           );
+                 'rarely', 'paleness' ],
+               -4, -2,
+               [ 'redoubled', 'Taylorize', 'Zoe', 'halogen' ],
+               'void' ],
+
+             [ [ 'a' ], -2, 1, [ 'B' ], 'void' ],
+
+             [ [ 'Hartley', 'Islandia', 'assents', 'wishful' ],
+               0, -4,
+               [ 'maids' ],
+               'void' ],
+
+             [ [ 'visibility', 'pocketful', 'rectangles' ],
+               -10, 0,
+               [ 'garbages' ],
+               'void' ],
+
+             [ [ 'sleeplessly' ],
+               8, -4,
+               [ 'Margery', 'clearing', 'repercussion', 'clubs',
+                 'arise' ],
+               'void' ],
+
+             [ [ 'chastises', 'recalculates' ],
+               0, 0,
+               [ 'momentariness', 'mediates', 'accents', 'toils',
+                 'regaled' ],
+               'void' ],
+
+             [ [ 'b', '' ],
+               9, 8,
+               [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ],
+               'scalar' ],
+
+             [ [ 'b', '' ],
+               undef, undef,
+               [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ],
+               'scalar' ],
+             
+             [ [ 'riheb' ], -8, undef, [], 'void' ],
+
+             [ [ 'uft', 'qnxs', '' ],
+               6, -2,
+               [ 'znp', 'mhnkh', 'bn' ],
+               'void' ],
+            );
 
 my $testnum = 194;
 my $failed = 0;
@@ -1324,10 +1324,10 @@ my $tmp = "dbr$$";
 foreach my $test (@tests) {
     my $err = test_splice(@$test);
     if (defined $err) {
-       print STDERR "# failed: ", Dumper($test);
-       print STDERR "# error: $err\n";
-       $failed = 1;
-       ok($testnum++, 0);
+        print STDERR "# failed: ", Dumper($test);
+        print STDERR "# error: $err\n";
+        $failed = 1;
+        ok($testnum++, 0);
     }
     else { ok($testnum++, 1) }
 }
@@ -1341,15 +1341,15 @@ else {
     $failed = 0;
     srand(0);
     foreach (0 .. 1000 - 1) {
-       my $test = rand_test();
-       my $err = test_splice(@$test);
-       if (defined $err) {
-           print STDERR "# failed: ", Dumper($test);
-           print STDERR "# error: $err\n";
-           $failed = 1;
-           print STDERR "# skipping any remaining random tests\n";
-           last;
-       }
+        my $test = rand_test();
+        my $err = test_splice(@$test);
+        if (defined $err) {
+            print STDERR "# failed: ", Dumper($test);
+            print STDERR "# error: $err\n";
+            $failed = 1;
+            print STDERR "# skipping any remaining random tests\n";
+            last;
+        }
     }
 
     ok($testnum++, not $failed);
@@ -1403,77 +1403,77 @@ sub test_splice {
 
     my $gather_warning = sub { push @s_warnings, $_[0] };
     if ($context eq 'list') {
-       my @r;
-       eval {
-           local $SIG{__WARN__} = $gather_warning;
-           @r = splice @array, $offset, $length, @list;
-       };
-       $s_error = $@;
-       $s_r = \@r;
+        my @r;
+        eval {
+            local $SIG{__WARN__} = $gather_warning;
+            @r = splice @array, $offset, $length, @list;
+        };
+        $s_error = $@;
+        $s_r = \@r;
     }
     elsif ($context eq 'scalar') {
-       my $r;
-       eval {
-           local $SIG{__WARN__} = $gather_warning;
-           $r = splice @array, $offset, $length, @list;
-       };
-       $s_error = $@;
-       $s_r = [ $r ];
+        my $r;
+        eval {
+            local $SIG{__WARN__} = $gather_warning;
+            $r = splice @array, $offset, $length, @list;
+        };
+        $s_error = $@;
+        $s_r = [ $r ];
     }
     elsif ($context eq 'void') {
-       eval {
-           local $SIG{__WARN__} = $gather_warning;
-           splice @array, $offset, $length, @list;
-       };
-       $s_error = $@;
-       $s_r = [];
+        eval {
+            local $SIG{__WARN__} = $gather_warning;
+            splice @array, $offset, $length, @list;
+        };
+        $s_error = $@;
+        $s_r = [];
     }
     else {
-       die "bad context $context";
+        die "bad context $context";
     }
 
     foreach ($s_error, @s_warnings) {
-       chomp;
-       s/ at \S+ line \d+\.$//;
-       # only built-in splice identifies name of uninit value
-       s/(uninitialized value) \$\w+/$1/;
+        chomp;
+        s/ at \S+ line \d+\.$//;
+        # only built-in splice identifies name of uninit value
+        s/(uninitialized value) \$\w+/$1/;
     }
 
     # Now do the same for DB_File's version of splice
     my ($ms_r, $ms_error, @ms_warnings);
     $gather_warning = sub { push @ms_warnings, $_[0] };
     if ($context eq 'list') {
-       my @r;
-       eval {
-           local $SIG{__WARN__} = $gather_warning;
-           @r = splice @h, $offset, $length, @list;
-       };
-       $ms_error = $@;
-       $ms_r = \@r;
+        my @r;
+        eval {
+            local $SIG{__WARN__} = $gather_warning;
+            @r = splice @h, $offset, $length, @list;
+        };
+        $ms_error = $@;
+        $ms_r = \@r;
     }
     elsif ($context eq 'scalar') {
-       my $r;
-       eval {
-           local $SIG{__WARN__} = $gather_warning;
-           $r = splice @h, $offset, $length, @list;
-       };
-       $ms_error = $@;
-       $ms_r = [ $r ];
+        my $r;
+        eval {
+            local $SIG{__WARN__} = $gather_warning;
+            $r = splice @h, $offset, $length, @list;
+        };
+        $ms_error = $@;
+        $ms_r = [ $r ];
     }
     elsif ($context eq 'void') {
-       eval {
-           local $SIG{__WARN__} = $gather_warning;
-           splice @h, $offset, $length, @list;
-       };
-       $ms_error = $@;
-       $ms_r = [];
+        eval {
+            local $SIG{__WARN__} = $gather_warning;
+            splice @h, $offset, $length, @list;
+        };
+        $ms_error = $@;
+        $ms_r = [];
     }
     else {
-       die "bad context $context";
+        die "bad context $context";
     }
 
     foreach ($ms_error, @ms_warnings) {
-       chomp;
+        chomp;
     s/ at \S+(\s+\S+)*? line \d+\.?.*//s;
     }
 
@@ -1485,26 +1485,26 @@ sub test_splice {
       if list_diff(\@array, \@h);
 
     if ((scalar @s_warnings) != (scalar @ms_warnings)) {
-       return 'different number of warnings';
+        return 'different number of warnings';
     }
 
     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;
-           if ($sw ne $msw) {
-               return "different warning: '$sw' vs '$msw'";
-           }
-       }
-       elsif (not defined $sw and not defined $msw) {
-           # Okay.
-       }
-       else {
-           return "one warning defined, another undef";
-       }
+        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;
+            if ($sw ne $msw) {
+                return "different warning: '$sw' vs '$msw'";
+            }
+        }
+        elsif (not defined $sw and not defined $msw) {
+            # Okay.
+        }
+        else {
+            return "one warning defined, another undef";
+        }
     }
     
     undef $H;
@@ -1514,7 +1514,7 @@ sub test_splice {
     @h = <TEXT>; normalise @h; chomp @h;
     close TEXT or die "cannot close $tmp: $!";
     return('list is different when re-read from disk: '
-          . Dumper(\@array) . ' vs ' . Dumper(\@h))
+           . Dumper(\@array) . ' vs ' . Dumper(\@h))
       if list_diff(\@array, \@h);
 
     unlink $tmp;
@@ -1543,16 +1543,16 @@ sub list_diff {
     my @a = @$a; my @b = @$b;
     return 1 if (scalar @a) != (scalar @b);
     for (my $i = 0; $i < @a; $i++) {
-       my ($ae, $be) = ($a[$i], $b[$i]);
-       if (defined $ae and defined $be) {
-           return 1 if $ae ne $be;
-       }
-       elsif (not defined $ae and not defined $be) {
-           # Two undefined values are 'equal'
-       }
-       else {
-           return 1;
-       }
+        my ($ae, $be) = ($a[$i], $b[$i]);
+        if (defined $ae and defined $be) {
+            return 1 if $ae ne $be;
+        }
+        elsif (not defined $ae and not defined $be) {
+            # Two undefined values are 'equal'
+        }
+        else {
+            return 1;
+        }
     }
     return 0;
 } 
@@ -1569,10 +1569,10 @@ sub rand_test {
     my @contexts = qw<list scalar void>;
     my $context = $contexts[int(rand @contexts)];
     return [ rand_list(),
-            (rand() < 0.5) ? (int(rand(20)) - 10) : undef,
-            (rand() < 0.5) ? (int(rand(20)) - 10) : undef,
-            rand_list(),
-            $context ];
+             (rand() < 0.5) ? (int(rand(20)) - 10) : undef,
+             (rand() < 0.5) ? (int(rand(20)) - 10) : undef,
+             rand_list(),
+             $context ];
 }
 
 
@@ -1581,7 +1581,7 @@ sub rand_list {
     my @r;
 
     while (rand() > 0.1 * (scalar @r + 1)) {
-       push @r, rand_word();
+        push @r, rand_word();
     }
     return \@r;
 }
@@ -1592,7 +1592,7 @@ sub rand_word {
     my $r = '';
     my @chars = qw<a b c d e f g h i j k l m n o p q r s t u v w x y z>;
     while (rand() > 0.1 * (length($r) + 1)) {
-       $r .= $chars[int(rand(scalar @chars))];
+        $r .= $chars[int(rand(scalar @chars))];
     }
     return $r;
 }
index c46b685..2cfed97 100644 (file)
@@ -1,6 +1,6 @@
 # typemap for Perl 5 interface to Berkeley 
 #
-# written by Paul Marquess <Paul.Marquess@btinternet.com>
+# written by Paul Marquess <pmqs@cpan.org>
 # last modified 20th June 2004
 # version 1.809
 #
@@ -8,50 +8,50 @@
 #
 # 
 
-u_int                  T_U_INT
-DB_File                        T_PTROBJ
-DBT                    T_dbtdatum
-DBTKEY                 T_dbtkeydatum
+u_int                   T_U_INT
+DB_File                 T_PTROBJ
+DBT                     T_dbtdatum
+DBTKEY                  T_dbtkeydatum
 
 INPUT
 T_dbtkeydatum
     {
-       SV * my_sv = $arg;
-       DBM_ckFilter(my_sv, filter_store_key, \"filter_store_key\");
-       DBT_clear($var) ;
-       SvGETMAGIC(my_sv) ;
+        SV * my_sv = $arg;
+        DBM_ckFilter(my_sv, filter_store_key, \"filter_store_key\");
+        DBT_clear($var) ;
+        SvGETMAGIC(my_sv) ;
         if (db->type == DB_RECNO) {
-           if (SvOK(my_sv))
-               Value = GetRecnoKey(aTHX_ db, SvIV(my_sv)) ; 
+            if (SvOK(my_sv))
+                Value = GetRecnoKey(aTHX_ db, SvIV(my_sv)) ; 
             else
-               Value = 1 ;
-           $var.data = & Value; 
-           $var.size = (int)sizeof(recno_t);
+                Value = 1 ;
+            $var.data = & Value; 
+            $var.size = (int)sizeof(recno_t);
         }
         else if (SvOK(my_sv)) {
-           STRLEN len;
-           $var.data = SvPVbyte(my_sv, len);
-           $var.size = (int)len;
-       }
+            STRLEN len;
+            $var.data = SvPVbyte(my_sv, len);
+            $var.size = (int)len;
+        }
     }
 T_dbtdatum
     {
-       SV * my_sv = $arg;
-       DBM_ckFilter(my_sv, filter_store_value, \"filter_store_value\");
-       DBT_clear($var) ;
-       SvGETMAGIC(my_sv) ;
-       if (SvOK(my_sv)) {
-           STRLEN len;
-           $var.data = SvPVbyte(my_sv, len);
-           $var.size = (int)len;
-       }
+        SV * my_sv = $arg;
+        DBM_ckFilter(my_sv, filter_store_value, \"filter_store_value\");
+        DBT_clear($var) ;
+        SvGETMAGIC(my_sv) ;
+        if (SvOK(my_sv)) {
+            STRLEN len;
+            $var.data = SvPVbyte(my_sv, len);
+            $var.size = (int)len;
+        }
     }
 
 OUTPUT
 
 T_dbtkeydatum
-       OutputKey($arg, $var)
+        OutputKey($arg, $var)
 T_dbtdatum
-       OutputValue($arg, $var)
+        OutputValue($arg, $var)
 T_PTROBJ
         sv_setref_pv($arg, dbtype, (void*)$var);
index e01f6f6..ecf73de 100644 (file)
@@ -2,7 +2,7 @@
 
  version.c -- Perl 5 interface to Berkeley DB 
 
- written by Paul Marquess <Paul.Marquess@btinternet.com>
+ written by Paul Marquess <pmqs@cpan.org>
  last modified 2nd Jan 2002
  version 1.802
 
@@ -14,7 +14,7 @@
 
  Changes:
         1.71 -  Support for Berkeley DB version 3.
-               Support for Berkeley DB 2/3's backward compatibility mode.
+                Support for Berkeley DB 2/3's backward compatibility mode.
         1.72 -  No change.
         1.73 -  Added support for threading
         1.74 -  Added Perl core patch 7801.
@@ -36,7 +36,7 @@ __getBerkeleyDBInfo(void)
 __getBerkeleyDBInfo()
 #endif
 {
-#ifdef dTHX    
+#ifdef dTHX     
     dTHX;
 #endif    
     SV * version_sv = perl_get_sv("DB_File::db_version", GV_ADD|GV_ADDMULTI) ;
@@ -50,16 +50,16 @@ __getBerkeleyDBInfo()
 
     /* 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) */
+                /* || 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, 
-               Major, Minor, 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, 
+                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) ;
+        croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n",
+                 Major, Minor, Patch) ;
  
     {
         char buffer[40] ;