#!./perl -w
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bDB_File\b/) {
- print "1..0 # Skip: DB_File was not built\n";
- exit 0;
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
}
}
-
+
use warnings;
use strict;
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bDB_File\b/ ) {
+ print "1..0 # Skip: DB_File was not built\n";
+ exit 0;
+ }
+ }
+ if ($^O eq 'darwin'
+ && $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.1.3 (or earlier)
+# because of the buggy Berkeley DB version included with the OS.
+#
+EOM
+ }
+}
+
use DB_File;
use Fcntl;
sub docat
{
my $file = shift;
- #local $/ = undef unless wantarray ;
+ local $/ = undef ;
open(CAT,$file) || die "Cannot open $file: $!";
- my @result = <CAT>;
+ my $result = <CAT>;
close(CAT);
- wantarray ? @result : join("", @result) ;
+ $result = normalise($result) ;
+ return $result ;
}
sub docat_del
{
my $file = shift;
- #local $/ = undef unless wantarray ;
- open(CAT,$file) || die "Cannot open $file: $!";
- my @result = <CAT>;
- close(CAT);
+ my $result = docat($file);
unlink $file ;
- wantarray ? @result : join("", @result) ;
+ return $result ;
}
+sub normalise
+{
+ my $data = shift ;
+ $data =~ s#\r\n#\n#g
+ if $^O eq 'cygwin' ;
+
+ return $data ;
+}
+
+
my $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ;
my $null_keys_allowed = ($DB_File::db_ver < 2.004010
my ($X, %h) ;
ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ;
+die "Could not tie: $!" unless $X;
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat($Dfile);
+
+my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ;
+
ok(20, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640)
- || $^O eq 'amigaos' || $^O eq 'MSWin32' || $^O eq 'cygwin' || $^O eq 'NetWare');
+ || $noMode{$^O} );
my ($key, $value, $i);
while (($key,$value) = each(%h)) {
my (%g, %k);
-tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ;
-tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ;
-tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ;
+tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) or die $!;
+tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) or die $!;
+tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) or die $!;
my @Keys = qw( 0123 12 -1234 9 987654321 def ) ;
my (@srt_1, @srt_2, @srt_3);
use warnings ;
use strict ;
- use vars qw( @ISA @EXPORT) ;
+ our (@ISA, @EXPORT);
require Exporter ;
use DB_File;
use strict ;
use DB_File ;
- use vars qw($filename %h ) ;
+ my ($filename, %h);
$filename = "tree" ;
unlink $filename ;
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 ;
use strict ;
use DB_File ;
- use vars qw($filename $x %h ) ;
+ my ($filename, $x, %h);
$filename = "tree" ;
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 ;
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 ;
use DB_File ;
use Fcntl ;
- use vars qw($filename $x %h $st $key $value) ;
+ my ($filename, $x, %h, $st, $key, $value);
sub match
{