Win32 counterpart of change #19065
[p5sagit/p5-mst-13.2.git] / ext / DB_File / DB_File.pm
index 1df9876..2e5d85e 100644 (file)
@@ -1,17 +1,17 @@
 # DB_File.pm -- Perl 5 interface to Berkeley DB 
 #
 # written by Paul Marquess (Paul.Marquess@btinternet.com)
-# last modified 30th July 2001
-# version 1.78
+# last modified 22nd October 2002
+# version 1.806
 #
-#     Copyright (c) 1995-2001 Paul Marquess. All rights reserved.
+#     Copyright (c) 1995-2002 Paul Marquess. All rights reserved.
 #     This program is free software; you can redistribute it and/or
 #     modify it under the same terms as Perl itself.
 
 
 package DB_File::HASHINFO ;
 
-require 5.003 ;
+require 5.00404;
 
 use warnings;
 use strict;
@@ -32,8 +32,13 @@ sub TIEHASH
 {
     my $pkg = shift ;
 
-    bless { VALID => { map {$_, 1} 
-                      qw( bsize ffactor nelem cachesize hash lorder)
+    bless { VALID => { 
+                       bsize     => 1,
+                       ffactor   => 1,
+                       nelem     => 1,
+                       cachesize => 1,
+                       hash      => 2,
+                       lorder    => 1,
                     }, 
            GOT   => {}
           }, $pkg ;
@@ -58,8 +63,12 @@ sub STORE
     my $key   = shift ;
     my $value = shift ;
 
-    if ( exists $self->{VALID}{$key} )
+    my $type = $self->{VALID}{$key};
+
+    if ( $type )
     {
+       croak "Key '$key' not associated with a code reference" 
+           if $type == 2 && !ref $value && ref $value ne 'CODE';
         $self->{GOT}{$key} = $value ;
         return ;
     }
@@ -132,9 +141,15 @@ sub TIEHASH
 {
     my $pkg = shift ;
 
-    bless { VALID => { map {$_, 1} 
-                      qw( flags cachesize maxkeypage minkeypage psize 
-                          compare prefix lorder )
+    bless { VALID => { 
+                       flags      => 1,
+                       cachesize  => 1,
+                       maxkeypage => 1,
+                       minkeypage => 1,
+                       psize      => 1,
+                       compare    => 2,
+                       prefix     => 2,
+                       lorder     => 1,
                     },
            GOT   => {},
           }, $pkg ;
@@ -145,13 +160,19 @@ package DB_File ;
 
 use warnings;
 use strict;
-use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO 
-            $db_version $use_XSLoader
-           ) ;
+our ($VERSION, @ISA, @EXPORT, $AUTOLOAD, $DB_BTREE, $DB_HASH, $DB_RECNO);
+our ($db_version, $use_XSLoader, $splice_end_array);
 use Carp;
 
 
-$VERSION = "1.78" ;
+$VERSION = "1.806" ;
+
+{
+    local $SIG{__WARN__} = sub {$splice_end_array = "@_";};
+    my @a =(1); splice(@a, 3);
+    $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 ;
@@ -163,7 +184,7 @@ require Exporter;
 use AutoLoader;
 BEGIN {
     $use_XSLoader = 1 ;
-    eval { require XSLoader } ;
+    { local $SIG{__DIE__} ; eval { require XSLoader } ; }
 
     if ($@) {
         $use_XSLoader = 0 ;
@@ -210,21 +231,12 @@ push @ISA, qw(Tie::Hash Exporter);
 sub AUTOLOAD {
     my($constname);
     ($constname = $AUTOLOAD) =~ s/.*:://;
-    my $val = constant($constname, @_ ? $_[0] : 0);
-    if ($! != 0) {
-       if ($! =~ /Invalid/ || $!{EINVAL}) {
-           $AutoLoader::AUTOLOAD = $AUTOLOAD;
-           goto &AutoLoader::AUTOLOAD;
-       }
-       else {
-           my($pack,$file,$line) = caller;
-           croak "Your vendor has not defined DB macro $constname, used at $file line $line.
-";
-       }
-    }
-    eval "sub $AUTOLOAD { $val }";
-    goto &$AUTOLOAD;
-}
+    my ($error, $val) = constant($constname);
+    Carp::croak $error if $error;
+    no strict 'refs';
+    *{$AUTOLOAD} = sub { $val };
+    goto &{$AUTOLOAD};
+}           
 
 
 eval {
@@ -251,6 +263,9 @@ sub tie_hash_or_array
     $arg[4] = tied %{ $arg[4] } 
        if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ;
 
+    $arg[2] = O_CREAT()|O_RDWR() if @arg >=3 && ! defined $arg[2];
+    $arg[3] = 0666               if @arg >=4 && ! defined $arg[3];
+
     # make recno in Berkeley DB version 2 work like recno in version 1.
     if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and 
        $arg[1] and ! -e $arg[1]) {
@@ -313,7 +328,7 @@ sub SPLICE
     my $self = shift;
     my $offset = shift;
     if (not defined $offset) {
-       carp 'Use of uninitialized value in splice';
+       warnings::warnif('uninitialized', 'Use of uninitialized value in splice');
        $offset = 0;
     }
 
@@ -338,15 +353,17 @@ sub SPLICE
        $offset = $new_offset;
     }
 
-    if ($offset > $size) {
-       $offset = $size;
-    }
-
     if (not defined $length) {
-       carp 'Use of uninitialized value in splice';
+       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')
+            if $splice_end_array;
+    }
+
     # 'If LENGTH is omitted, removes everything from OFFSET onward.'
     if (not defined $length) {
        $length = $size - $offset;
@@ -594,7 +611,7 @@ DB_File - Perl5 access to Berkeley DB version 1.x
 
 B<DB_File> is a module which allows Perl programs to make use of the
 facilities provided by Berkeley DB version 1.x (if you have a newer
-version of DB, see L<Using DB_File with Berkeley DB version 2 or 3>).
+version of DB, see L<Using DB_File with Berkeley DB version 2 or greater>).
 It is assumed that you have a copy of the Berkeley DB manual pages at
 hand when reading this documentation. The interface defined here
 mirrors the Berkeley DB interface closely.
@@ -638,27 +655,27 @@ number.
 
 =back
 
-=head2 Using DB_File with Berkeley DB version 2 or 3
+=head2 Using DB_File with Berkeley DB version 2 or greater
 
 Although B<DB_File> is intended to be used with Berkeley DB version 1,
-it can also be used with version 2 or 3. In this case the interface is
+it can also be used with version 2, 3 or 4. In this case the interface is
 limited to the functionality provided by Berkeley DB 1.x. Anywhere the
-version 2 or 3 interface differs, B<DB_File> arranges for it to work
+version 2 or greater interface differs, B<DB_File> arranges for it to work
 like version 1. This feature allows B<DB_File> scripts that were built
-with version 1 to be migrated to version 2 or 3 without any changes.
+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.
 
-B<Note:> The database file format has changed in both Berkeley DB
-version 2 and 3. If you cannot recreate your databases, you must dump
-any existing databases with either the C<db_dump> or the C<db_dump185>
-utility that comes with Berkeley DB.
-Once you have rebuilt DB_File to use Berkeley DB version 2 or 3, your
-databases can be recreated using C<db_load>. Refer to the Berkeley DB
+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
+must dump any existing databases with either the C<db_dump> or the
+C<db_dump185> utility that comes with Berkeley DB.
+Once you have rebuilt DB_File to use Berkeley DB version 2 or greater,
+your databases can be recreated using C<db_load>. Refer to the Berkeley DB
 documentation for further details.
 
-Please read L<"COPYRIGHT"> before using version 2.x or 3.x of Berkeley
+Please read L<"COPYRIGHT"> before using version 2.x or greater of Berkeley
 DB with DB_File.
 
 =head2 Interface to Berkeley DB
@@ -838,7 +855,7 @@ contents of the database.
     use warnings ;
     use strict ;
     use DB_File ;
-    use vars qw( %h $k $v ) ;
+    our (%h, $k, $v) ;
 
     unlink "fruit" ;
     tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0666, $DB_HASH 
@@ -988,7 +1005,7 @@ code:
     use strict ;
     use DB_File ;
 
-    use vars qw($filename %h ) ;
+    my ($filename, %h) ;
 
     $filename = "tree" ;
     unlink $filename ;
@@ -1043,7 +1060,7 @@ Here is the script above rewritten using the C<seq> API method.
     use strict ;
     use DB_File ;
 
-    use vars qw($filename $x %h $status $key $value) ;
+    my ($filename, $x, %h, $status, $key, $value) ;
 
     $filename = "tree" ;
     unlink $filename ;
@@ -1115,7 +1132,7 @@ this:
     use strict ;
     use DB_File ;
 
-    use vars qw($filename $x %h ) ;
+    my ($filename, $x, %h) ;
 
     $filename = "tree" ;
 
@@ -1165,9 +1182,9 @@ Assuming the database from the previous example:
     use strict ;
     use DB_File ;
 
-    use vars qw($filename $x %h $found) ;
+    my ($filename, $x, %h, $found) ;
 
-    my $filename = "tree" ;
+    $filename = "tree" ;
 
     # Enable duplicate records
     $DB_BTREE->{'flags'} = R_DUP ;
@@ -1204,9 +1221,9 @@ Again assuming the existence of the C<tree> database
     use strict ;
     use DB_File ;
 
-    use vars qw($filename $x %h $found) ;
+    my ($filename, $x, %h, $found) ;
 
-    my $filename = "tree" ;
+    $filename = "tree" ;
 
     # Enable duplicate records
     $DB_BTREE->{'flags'} = R_DUP ;
@@ -1250,7 +1267,7 @@ and print the first matching key/value pair given a partial key.
     use DB_File ;
     use Fcntl ;
 
-    use vars qw($filename $x %h $st $key $value) ;
+    my ($filename, $x, %h, $st, $key, $value) ;
 
     sub match
     {
@@ -1345,7 +1362,7 @@ still have bval default to C<"\n"> for variable length records, and
 space for fixed length records.
 
 Also note that the bval option only allows you to specify a single byte
-as a delimeter.
+as a delimiter.
 
 =head2 A Simple Example
 
@@ -1437,7 +1454,7 @@ Returns the number of elements in the array.
 
 =item B<$X-E<gt>splice(offset, length, elements);>
 
-Returns a splice of the the array.
+Returns a splice of the array.
 
 =back
 
@@ -1449,7 +1466,7 @@ L<THE API INTERFACE>).
 
     use warnings ;
     use strict ;
-    use vars qw(@h $H $file $i) ;
+    my (@h, $H, $file, $i) ;
     use DB_File ;
     use Fcntl ;
 
@@ -2014,7 +2031,7 @@ F<authors/id/TOMC/scripts/nshist.gz>).
     use DB_File ;
     use Fcntl ;
 
-    use vars qw( $dotdir $HISTORY %hist_db $href $binary_time $date ) ;
+    my ($dotdir, $HISTORY, %hist_db, $href, $binary_time, $date) ;
     $dotdir = $ENV{HOME} || $ENV{LOGNAME};
 
     $HISTORY = "$dotdir/.netscape/history.db";
@@ -2169,7 +2186,7 @@ Consider this script:
     use warnings ;
     use strict ;
     use DB_File ;
-    use vars qw(%x) ;
+    my %x ;
     tie %x, DB_File, "filename" ;
 
 Running it produces the error in question:
@@ -2235,7 +2252,7 @@ compile properly on IRIX 5.3.
 
 =head1 COPYRIGHT
 
-Copyright (c) 1995-2001 Paul Marquess. All rights reserved. This program
+Copyright (c) 1995-2002 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.