X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FDB_File%2FDB_File.pm;h=3bdadede043e118cfec1ca43c09acb7fb0d7cf8d;hb=6ff38c2790dea060035b4175aa870de4adce00c9;hp=b00b5008841c645b4aa0ef5d42ec2921796ed68e;hpb=07200f1b93ada43b41fbed10c30b4e657f5b0c60;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm
index b00b500..3bdaded 100644
--- a/ext/DB_File/DB_File.pm
+++ b/ext/DB_File/DB_File.pm
@@ -1,10 +1,10 @@
 # DB_File.pm -- Perl 5 interface to Berkeley DB 
 #
-# written by Paul Marquess (Paul.Marquess@btinternet.com)
-# last modified 23rd Nov 2001
-# version 1.800
+# written by Paul Marquess (pmqs@cpan.org)
+# last modified 11th November 2005
+# version 1.814
 #
-#     Copyright (c) 1995-2001 Paul Marquess. All rights reserved.
+#     Copyright (c) 1995-2005 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.
 
@@ -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 ;
@@ -146,11 +161,18 @@ package DB_File ;
 use warnings;
 use strict;
 our ($VERSION, @ISA, @EXPORT, $AUTOLOAD, $DB_BTREE, $DB_HASH, $DB_RECNO);
-our ($db_version, $use_XSLoader);
+our ($db_version, $use_XSLoader, $splice_end_array, $Error);
 use Carp;
 
 
-$VERSION = "1.800" ;
+$VERSION = "1.814" ;
+
+{
+    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 ;
@@ -241,7 +263,15 @@ sub tie_hash_or_array
     $arg[4] = tied %{ $arg[4] } 
 	if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ;
 
-    # make recno in Berkeley DB version 2 work like recno in version 1.
+    $arg[2] = O_CREAT()|O_RDWR() if @arg >=3 && ! defined $arg[2];
+    $arg[3] = 0666               if @arg >=4 && ! defined $arg[3];
+
+    # make recno in Berkeley DB version 2 (or better) work like 
+    # recno in version 1.
+    if ($db_version >= 4 and ! $tieHASH) {
+        $arg[2] |= O_CREAT();
+    }
+
     if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and 
 	$arg[1] and ! -e $arg[1]) {
 	open(FH, ">$arg[1]") or return undef ;
@@ -303,7 +333,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;
     }
 
@@ -328,15 +358,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;
@@ -939,7 +971,7 @@ Duplicate keys are entirely defined by the comparison function.
 In the case-insensitive example above, the keys: 'KEY' and 'key'
 would be considered duplicates, and assigning to the second one
 would overwrite the first. If duplicates are allowed for (with the
-R_DUPS flag discussed below), only a single copy of duplicate keys
+R_DUP flag discussed below), only a single copy of duplicate keys
 is stored in the database --- so (again with example above) assigning
 three values to the keys: 'KEY', 'Key', and 'key' would leave just
 the first key: 'KEY' in the database with three values. For some
@@ -978,7 +1010,7 @@ code:
     use strict ;
     use DB_File ;
 
-    our ($filename, %h) ;
+    my ($filename, %h) ;
 
     $filename = "tree" ;
     unlink $filename ;
@@ -1033,7 +1065,7 @@ Here is the script above rewritten using the C<seq> API method.
     use strict ;
     use DB_File ;
 
-    our ($filename, $x, %h, $status, $key, $value) ;
+    my ($filename, $x, %h, $status, $key, $value) ;
 
     $filename = "tree" ;
     unlink $filename ;
@@ -1105,7 +1137,7 @@ this:
     use strict ;
     use DB_File ;
 
-    our ($filename, $x, %h) ;
+    my ($filename, $x, %h) ;
 
     $filename = "tree" ;
 
@@ -1155,7 +1187,7 @@ Assuming the database from the previous example:
     use strict ;
     use DB_File ;
 
-    our ($filename, $x, %h, $found) ;
+    my ($filename, $x, %h, $found) ;
 
     $filename = "tree" ;
 
@@ -1194,7 +1226,7 @@ Again assuming the existence of the C<tree> database
     use strict ;
     use DB_File ;
 
-    our ($filename, $x, %h, $found) ;
+    my ($filename, $x, %h, $found) ;
 
     $filename = "tree" ;
 
@@ -1240,7 +1272,7 @@ and print the first matching key/value pair given a partial key.
     use DB_File ;
     use Fcntl ;
 
-    our ($filename, $x, %h, $st, $key, $value) ;
+    my ($filename, $x, %h, $st, $key, $value) ;
 
     sub match
     {
@@ -1335,7 +1367,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
 
@@ -1427,7 +1459,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
 
@@ -1439,7 +1471,7 @@ L<THE API INTERFACE>).
 
     use warnings ;
     use strict ;
-    our (@h, $H, $file, $i) ;
+    my (@h, $H, $file, $i) ;
     use DB_File ;
     use Fcntl ;
 
@@ -1794,7 +1826,7 @@ fix very easily.
     use DB_File ;
 
     my %hash ;
-    my $filename = "/tmp/filt" ;
+    my $filename = "filt" ;
     unlink $filename ;
 
     my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH 
@@ -1823,7 +1855,7 @@ Here is another real-life example. By default, whenever Perl writes to
 a DBM database it always writes the key and value as strings. So when
 you use this:
 
-    $hash{12345} = "soemthing" ;
+    $hash{12345} = "something" ;
 
 the key 12345 will get stored in the DBM database as the 5 byte string
 "12345". If you actually want the key to be stored in the DBM database
@@ -1836,7 +1868,7 @@ Here is a DBM Filter that does it:
     use strict ;
     use DB_File ;
     my %hash ;
-    my $filename = "/tmp/filt" ;
+    my $filename = "filt" ;
     unlink $filename ;
 
 
@@ -1867,8 +1899,8 @@ peril!
 
 The locking technique went like this. 
 
-    $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0666)
-        || die "dbcreat /tmp/foo.db $!";
+    $db = tie(%db, 'DB_File', 'foo.db', O_CREAT|O_RDWR, 0644)
+        || die "dbcreat foo.db $!";
     $fd = $db->fd;
     open(DB_FH, "+<&=$fd") || die "dup $!";
     flock (DB_FH, LOCK_EX) || die "flock: $!";
@@ -2004,7 +2036,7 @@ F<authors/id/TOMC/scripts/nshist.gz>).
     use DB_File ;
     use Fcntl ;
 
-    our ($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";
@@ -2206,7 +2238,7 @@ B<DB_File> comes with the standard Perl source distribution. Look in
 the directory F<ext/DB_File>. Given the amount of time between releases
 of Perl the version that ships with Perl is quite likely to be out of
 date, so the most recent version can always be found on CPAN (see
-L<perlmod/CPAN> for details), in the directory
+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
@@ -2225,7 +2257,7 @@ compile properly on IRIX 5.3.
 
 =head1 COPYRIGHT
 
-Copyright (c) 1995-2001 Paul Marquess. All rights reserved. This program
+Copyright (c) 1995-2005 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.
 
@@ -2251,14 +2283,14 @@ Berkeley DB authors or the author of DB_File. See L<"AUTHOR"> for details.
 
 =head1 SEE ALSO
 
-L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>,
-L<dbmfilter>
+L<perl>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>,
+L<perldbmfilter>
 
 =head1 AUTHOR
 
 The DB_File interface was written by Paul Marquess
-E<lt>Paul.Marquess@btinternet.comE<gt>.
+E<lt>pmqs@cpan.orgE<gt>.
 Questions about the DB system itself may be addressed to
-E<lt>db@sleepycat.com<gt>.
+E<lt>db@sleepycat.comE<gt>.
 
 =cut