./perl -I../lib harness

This method pinpoints failed tests automatically.

if ($#ARGV == -1) {

@ARGV = split(/[ \n]/,

}

_testprogs('perl', @ARGV);

_testprogs('compile', @ARGV) if (-e "../testcompile");

open(RESULTS,"./perl$switch $test |") or print "can't run.\n";

}

else {

or print "can't compile.\n";

}

$ok = 0;

if ($type eq 'perl') {

open(RESULTS, "./$test |") || (print "can't run.\n"); }

else {

}

}

else {

#!./perl

$x = 'x';

print "# $@\nnot ok $test\n" if $@;

T '^main:plink:53$', $test++;

}

$teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n";

# Create our test datafile

open TESTFILE, ">./foo" or die "error $! $^E opening";

binmode TESTFILE;

print TESTFILE $teststring;

BEGIN {

chdir 't' if -d 't';

}

use Config;

die "/dev/null IS NOT A CHARACTER SPECIAL FILE!!!!\n" unless -c '/dev/null';

}

if (<try> ne '') {print "ok 7\n";} else {print "not ok 7\n";}

BEGIN {

chdir 't' if -d 't';

}

print "1..10\n";

BEGIN {

chdir 't' if -d 't';

}

use strict;

BEGIN {

chdir 't' if -d 't';

}

use Config;

BEGIN {

chdir 't' if -d 't';

}

use strict;

my $i = 1;

##

##

testing \&sub_aref, '&\@';

sub sub_aref (&\@) {

sreftest($helem{$i}, $i++);

sreftest $aelem[0], $i++;

}

BEGIN {

chdir 't' if -d 't';

}

# don't make this lexical

$i = 1;

sub do_require {

%INC = ();

sub write_file {

my $f = shift;

open(REQ,">$f") or die "Can't write '$f': $!";

print REQ @_;

close REQ;

}

dofile();

sub dofile { do "bleah.do"; };

print $x;

END { 1 while unlink 'bleah.pm'; 1 while unlink 'bleah.do'; }

BEGIN {

chdir 't' if -d 't';

}

print "1..27\n";

Test::Harness::runtests @tests;

exit(0) unless -e "../testcompile";

my $dhwrapper = <<'EOT';

open DATA,"<".__FILE__;

BEGIN {

chdir 't' if -d 't';

}

use File::Spec;

local $/;

open F, 'Io_argv1.tmp' or die;

<F>; # set $. = 1

open F, $devnull or die;

print "not " unless defined(<F>);

print "ok 17\n";

print "not " if defined(<F>);

print "ok 18\n";

open F, $devnull or die; # restart cycle again

print "not " unless defined(<F>);

print "ok 20\n";

close F;

}

BEGIN {

chdir 't' if -d 't';

}

use Config;

{print "ok 18 # skipped: granularity of the filetime\n";}

elsif ($atime == 500000000 && $mtime == 500000000 + $delta)

{print "ok 18\n";}

{print "not ok 18 $atime $mtime\n";}

if ((unlink 'b') == 1) {print "ok 19\n";} else {print "not ok 19\n";}

unlink 'c';

if ($^O ne 'MSWin32' and `ls -l perl 2>/dev/null` =~ /^l.*->/) {

# we have symbolic links

if ($foo) {print "ok 22\n";} else {print "not ok 22\n";}

unlink 'c';

}

else {

print "ok 21\nok 22\n";

BEGIN {

chdir 't' if -d 't';

}

# $RCSfile$

$| = 1;

use warnings;

$Is_VMS = $^O eq 'VMS';

print "1..66\n";

{

local *F;

for (1..2) {

print <F>;

close F;

}

ok;

for (1..2) {

print <F>;

close F;

}

BEGIN {

chdir 't' if -d 't';

if ($^O eq 'dos') {

print "1..0 # Skip: no multitasking\n";

exit 0;

}

}

use Config;

$SIG{PIPE} = 'IGNORE';

print "1..10\n";

# the other reader reads one line, waits a few seconds and then

# exits to test the waitpid function.

#

$cmd3 = qq/$perl -e "print <>;"/; # hangs waiting for end of STDIN

$cmd4 = qq/$perl -e "print scalar <>;"/;

print "ok 8\n";

# send one expected line of text to child process and then wait for it

print FH4 "ok 9\n";

print "# waiting for process $pid4 to exit\n";

$reap_pid = waitpid $pid4, 0;

print "# reaped pid $reap_pid != $pid4\nnot "

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

unless ($Config{'d_fork'}) {

print "1..0 # Skip: no fork\n";

# $RCSfile: tell.t,v $$Revision$$Date$

$TST = 'tst';

$Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or

$^O eq 'os2' or $^O eq 'mint' or $^O eq 'cygwin');

binmode $TST if $Is_Dosish;

if (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; }

if ($. == 0) { print "not ok 14\n"; } else { print "ok 14\n"; }

$curline = $.;

binmode other if $^O eq 'MSWin32';

{

tell other;

if ($. == 7) { print "ok 21\n"; } else { print "not ok 21\n"; }

}

BEGIN {

chdir 't' if -d 't';

}

use Text::Abbrev;

BEGIN {

chdir 't' if -d 't';

}

# Test suite for the Term::ANSIColor Perl module. Before `make install' is

# Ensure module can be loaded

############################################################################

END { print "not ok 1\n" unless $loaded }

use Term::ANSIColor qw(:constants color colored);

$loaded = 1;

} else {

print "not ok 7\n";

}

BEGIN {

chdir 't' if -d 't';

}

require AnyDBM_File;

use Fcntl;

print "1..12\n";

BEGIN {

chdir 't' if -d 't';

eval 'require attrs; 1' or do {

print "1..0\n";

exit 0;

BEGIN {

chdir 't' if -d 't';

$dir = "auto-$$";

}

print "1..11\n";

BEGIN {

chdir 't' if -d 't';

}

use File::Basename qw(fileparse basename dirname);

# import correctly?

print +(defined(&basename) && !defined(&fileparse_set_fstype) ?

'' : 'not '),"ok 25\n";

print +(dirname(':arma:virumque:cano.trojae') eq ':arma:virumque:' ?

'' : 'not '),"ok 26\n";

# Check quoting of metacharacters in suffix arg by basename()

print +(basename(':arma:virumque:cano.trojae','.trojae') eq 'cano' ?

print +(basename(':arma:virumque:cano_trojae','.trojae') eq 'cano_trojae' ?

# extra tests for a few specific bugs

File::Basename::fileparse_set_fstype 'MSDOS';

# perl5.003_18 gives C:/perl/.\

# perl5.003_18 gives C:\perl\

File::Basename::fileparse_set_fstype 'UNIX';

# perl5.003_18 gives '.'

# perl5.003_18 gives '/perl/lib'

# The empty tainted value, for tainting strings

my $TAINT = substr($^X, 0, 0);

1;

}

print +(all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+'))

$test = 0;

$| = 1;

while (<DATA>) {

chop;

if (s/^&//) {

$try .= "\$x * \$y;";

} elsif ($f eq "fdiv") {

$try .= "\$x / \$y;";

} else { warn "Unknown op"; }

}

#print ">>>",$try,"<<<\n";

print "# '$try' expected: /$pat/ got: '$ans1'\n";

}

}

}

__END__

&fnorm

0:0.

+0:0.

+00:0.

-001:-1.

-123456789:-123456789.

-00000100000:-100000.

123.456:123.456

0.01:.01

.002:.002

-3e111:-3000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000.

-4e-1111:-.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004

&fneg

+0:0.

+1:-1.

-1:1.

+123.456789:-123.456789

-123456.789:123456.789

&fabs

+0:0.

+1:1.

-1:1.

-6.23:-1:/-6.2(?:0{5}\d+)?

+6.27:-1:/6.(?:3|29{5}\d+)

-6.27:-1:/-6.(?:3|29{5}\d+)

-0.0065:-1:0

-0.0065:-2:/-0\.01|-1e-02

-0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03

-0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03

&fcmp

-123:-124:1

-124:-123:-1

&fadd

+0:+0:0.

+1:+0:1.

+0:+1:1.

-123456789:-987654321:-1111111110.

+123456789:-987654321:-864197532.

&fsub

+0:+0:0.

+1:+0:1.

+0:+1:-1.

-123456789:-987654321:864197532.

+123456789:-987654321:1111111110.

&fmul

+0:+0:0.

+0:+1:0.

+1:+0:0.

+88888888888:+9:799999999992.

+99999999999:+9:899999999991.

&fdiv

+0:+1:0.

+0:-1:0.

+1:+1:1.

-1:-1:1.

+1:-1:-1.

+100:10.

+123.456:11.11107555549866648462149404118219234119

+15241.383936:123.456

#!./perl

require "bigint.pl";

$test = 0;

BEGIN {

chdir 't' if -d 't';

}

use Math::BigInt;

BEGIN {

}

BEGIN {$| = 1; print "1..17\n"; }

END {print "not ok 1\n" unless $loaded;}

use CGI (':standard','-no_debug');

print($true ? "ok $num\n" : "not ok $num $msg\n");

}

# Set up a CGI environment

$ENV{REQUEST_METHOD}='GET';

$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull';

$ENV{SERVER_PORT} = 8080;

$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';

"start_form()");

"textfield({-name,-value,-override})");

"checkbox()");

test(10,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast') eq

"checkbox()");

test(11,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast',-checked=>1,-override=>1) eq

"checkbox()");

test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq

"checkbox()");

test(13,radio_group(-name=>'game') eq

'radio_group()');

test(14,radio_group(-name=>'game',-labels=>{'chess'=>'ping pong'}) eq

'radio_group()');

test(15, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/]) eq

'checkbox_group()');

'checkbox_group()');

END

BEGIN {

}

END {print "not ok 1\n" unless $loaded;}

use Config;

use CGI (':standard','keywords');

print($true ? "ok $num\n" : "not ok $num $msg\n");

}

# Set up a CGI environment

$ENV{REQUEST_METHOD}='GET';

$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull';

$ENV{HTTP_LOVE} = 'true';

test(2,request_method() eq 'GET',"CGI::request_method()");

test(4,param() == 2,"CGI::param()");

test(5,join(' ',sort {$a cmp $b} param()) eq 'game weather',"CGI::param()");

test(6,param('game') eq 'chess',"CGI::param()");

test(8,join(' ',param('game')) eq 'chess checkers',"CGI::param()");

test(9,param(-name=>'foo',-value=>'bar'),'CGI::param() put');

test(10,param(-name=>'foo') eq 'bar','CGI::param() get');

test(12,http('love') eq 'true',"CGI::http()");

test(13,script_name() eq '/cgi-bin/foo.cgi',"CGI::script_name()");

test(14,url() eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()");

test(15,self_url() eq

"CGI::url()");

test(16,url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)');

test(17,url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)');

test(18,url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)');

test(19,url(-relative=>1,-path=>1,-query=>1) eq

'CGI::url(-relative=>1,-path=>1,-query=>1)');

Delete('foo');

test(20,!param('foo'),'CGI::delete()');

test(21,join(' ',keywords()) eq 'mary had a little lamb','CGI::keywords');

test(22,join(' ',param('keywords')) eq 'mary had a little lamb','CGI::keywords');

}

BEGIN {

}

END {print "not ok 1\n" unless $loaded;}

use CGI (':standard','-no_debug','*h3','start_table');

$loaded = 1;

######################### End of black magic.

# util

sub test {

}

# all the automatic tags

test(7,h1({-align=>'CENTER'},['fred','agnes']) eq

"distributive tag with attribute");

{

local($") = '-';

}

test(13,start_html() ."\n" eq <<END,"start_html()");

END

;

test(14,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR") ."\n" eq <<END,"start_html()");

END

;

test(15,start_html(-Title=>'The world of foo') ."\n" eq <<END,"start_html()");

END

;

BEGIN {

}

END {print "not ok 1\n" unless $loaded;}

use CGI ();

$loaded = 1;

print "ok 1\n";

$q = new CGI;

test(2,$q,"CGI::new()");

test(3,$q->request_method eq 'GET',"CGI::request_method()");

test(5,$q->param() == 2,"CGI::param()");

test(6,join(' ',sort $q->param()) eq 'game weather',"CGI::param()");

test(7,$q->param('game') eq 'chess',"CGI::param()");

test(9,join(' ',$q->param('game')) eq 'chess checkers',"CGI::param()");

test(10,$q->param(-name=>'foo',-value=>'bar'),'CGI::param() put');

test(11,$q->param(-name=>'foo') eq 'bar','CGI::param() get');

test(13,$q->http('love') eq 'true',"CGI::http()");

test(14,$q->script_name eq '/cgi-bin/foo.cgi',"CGI::script_name()");

test(15,$q->url eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()");

test(16,$q->self_url eq

"CGI::url()");

test(17,$q->url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)');

test(18,$q->url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)');

test(19,$q->url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)');

test(20,$q->url(-relative=>1,-path=>1,-query=>1) eq

'CGI::url(-relative=>1,-path=>1,-query=>1)');

$q->delete('foo');

test(21,!$q->param('foo'),'CGI::delete()');

test(27,$q=new CGI({'foo'=>'bar','bar'=>'froz'}),"CGI::new() redux 2");

test(28,$q->param('bar') eq 'froz',"CGI::param() redux 2");

}

BEGIN {

unless(grep /blib/, @INC) {

chdir 't' if -d 't';

}

}

$| = 1;

use charnames ':full';

$encoded_be = "\320\261";

$encoded_alpha = "\316\261";

$encoded_bet = "\327\221";

{

use charnames ':full';

print "ok 4\n";

use charnames qw(cyrillic greek :short);

eq "$encoded_be,$encoded_alpha,$encoded_bet";

print "ok 5\n";

}

print "not " unless sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}") eq "ff.263a";

print "ok 12\n";

}

BEGIN {

chdir 't' if -d 't';

}

print "1..1\n";

BEGIN {

chdir 't' if -d 't';

}

use Math::Complex;

my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val);

my $eps = 1e-13;

if ($^O eq 'unicos') { # For some reason root() produces very inaccurate

} # cos(), sin(), cosh(), sinh(). The division

# of doubles is the current suspect.

'acsch(0)',

'asec(0)',

'asech(0)',

'atan($i)',

# 'atanh(-1)', # Log of zero.

'atanh(+1)',

'cot(0)',

'coth(0)',

'csc(0)',

'csch(0)',

);

test_loz(

'log($zero)',

'acot(-$i)',

'atanh(-1)',

'acoth(-1)',

eval 'root(2, $op)';

(\$bad) = (\$@ =~ /(.+)/);

print "# $test op = $op badroot? \$bad...\n";

EOT

push(@script, qq(print "ok $test\\n";\n));

}

test_broot(qw(-3 -2.1 0 0.99));

sub test_display_format {

push @script, <<EOS;

my \$j = (root(1,3))[1];

$test++;

push @script, <<EOS;

print "not " unless \$j->display_format eq 'polar';

print "ok $test\n";

EOS

$test++;

push @script, <<EOS;

print "# j = \$j\n";

print "ok $test\n";

\$j->display_format('style' => 'polar', 'polar_pretty_print' => 0);

\$j->display_format('style' => 'cartesian', 'format' => '(%.5g)');

EOS

$test++;

push @script, <<EOS;

print "# j = \$j\n";

print "not " unless "\$j" eq "(-0.5)+(0.86603)i";

print "ok $test\n";

EOS

}

test_display_format();

( 2,-3):( 1.96863792579310, -0.96465850440760)

&acosh

(-1.0,0):( 0, 3.14159265358979)

(-0.5,0):( 0, 2.09439510239320)

( 0.0,0):( 0, 1.57079632679490)

&acosh

( 2, 3):( 1.98338702991654, 1.00014354247380)

( 2,-3):( 1.98338702991654, -1.00014354247380)

&atanh

&asech

(-2.0,0):( 0 , 2.09439510239320)

(-1.0,0):( 0 , 3.14159265358979)

( 0.5,0):( 1.31695789692482, 0 )

( 1.0,0):( 0 , 0 )

( 2.0,0):( 0 , 1.04719755119660)

&asech

( 2, 3):( 0.23133469857397, -1.42041072246703)

( 2,-3):( 0.23133469857397, 1.42041072246703)

&acsch

#!./perl -w

BEGIN {

require Config; import Config;

if ($Config{'extensions'} !~ /\bDB_File\b/) {

print "1..0 # Skip: DB_File was not built\n";

}

}

use DB_File;

use Fcntl;

sub ok

{

}

my $Dfile = "dbbtree.tmp";

unlink $Dfile;

# Check that an invalid entry is caught both for store & fetch

eval '$dbh->{fred} = 1234' ;

ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ;

ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ;

# Now check the interface to BTREE

ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ;

$blksize,$blocks) = stat($Dfile);

ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');

while (($key,$value) = each(%h)) {

$i++;

}

delete $h{'goner1'};

$X->DELETE('goner3');

ok(27, $#keys == 29 && $#values == 29) ;

$h{'foo'} = '';

ok(31, $h{'foo'} eq '' ) ;

# check cache overflow and numeric keys and contents

for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }

for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }

ok(33, $ok);

ok(34, $size > 0 );

@h{0..200} = 200..400;

ok(35, join(':',200..400) eq join(':',@foo) );

# Now check all the non-tie specific stuff

# Check R_NOOVERWRITE flag will make put fail when attempting to overwrite

# an existing record.

ok(36, $status == 1 );

# check that the value of the key 'x' has not been changed by the

$status = $X->del('q') ;

ok(41, $status == 0 );

# Make sure that the key deleted, cannot be retrieved

ok(43, ! defined $h{'q'}) ;

$status = $X->seq($key, $value, R_FIRST) ;

ok(66, $status == 0 );

$ok = 1 ;

while (($status = $X->seq($key, $value, R_NEXT)) == 0)

unlink $Dfile;

# Now try an in memory file

ok(74, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE ));

# fd with an in memory file should return failure

# Duplicate keys

my $bt = new DB_File::BTREEINFO ;

$bt->{flags} = R_DUP ;

ok(76, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ;

$hh{'Wall'} = 'Larry' ;

# test multiple callbacks

$dbh2->{compare} = sub { $_[0] cmp $_[1] } ;

$dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;

tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ;

tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ;

@srt_2 = sort { $a cmp $b } @Keys ;

@srt_3 = sort { length $a <=> length $b } @Keys ;

foreach (@Keys) {

$g{$_} = 1 ;

$k{$_} = 1 ;

}

package Another ;

use strict ;

open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;

package SubDB ;

use strict ;

use vars qw( @ISA @EXPORT) ;

{

# DBM Filter tests

use strict ;

my (%h, $db) ;

my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;

{

# DBM Filter with a closure

use strict ;

my (%h, $db) ;

{

# DBM Filter recursion detection

use strict ;

my (%h, $db) ;

unlink $Dfile;

# BTREE example 1

###

use strict ;

use DB_File ;

# BTREE example 2

###

use strict ;

use DB_File ;

# BTREE example 3

###

use strict ;

use DB_File ;

# BTREE example 4

###

use strict ;

use DB_File ;

# BTREE example 5

###

use strict ;

use DB_File ;

# BTREE example 6

###

use strict ;

use DB_File ;

# BTREE example 7

###

use strict ;

use DB_File ;

use Fcntl ;

# unlink $Dfile;

#}

exit ;

#!./perl -w

BEGIN {

require Config; import Config;

if ($Config{'extensions'} !~ /\bDB_File\b/) {

print "1..0 # Skip: DB_File was not built\n";

}

}

use DB_File;

use Fcntl;

sub ok

{

}

my $Dfile = "dbhash.tmp";

unlink $Dfile;

umask(0);

# Now check the interface to HASH

ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );

$blksize,$blocks) = stat($Dfile);

ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');

while (($key,$value) = each(%h)) {

$i++;

}

delete $h{'goner1'};

$X->DELETE('goner3');

ok(23, $#keys == 29 && $#values == 29) ;

$h{'foo'} = '';

ok(26, $h{'foo'} eq '' );

# check cache overflow and numeric keys and contents

for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }

for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }

ok(28, $ok );

ok(29, $size > 0 );

@h{0..200} = 200..400;

ok(30, join(':',200..400) eq join(':',@foo) );

# Check NOOVERWRITE will make put fail when attempting to overwrite

# an existing record.

ok(31, $status == 1 );

# check that the value of the key 'x' has not been changed by the

ok(36, $status == 0 );

# Make sure that the key deleted, cannot be retrieved

# Attempting to delete a non-existant key should fail

package Another ;

use strict ;

open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;

package SubDB ;

use strict ;

use vars qw( @ISA @EXPORT) ;

{

# DBM Filter tests

use strict ;

my (%h, $db) ;

my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;

{

# DBM Filter with a closure

use strict ;

my (%h, $db) ;

{

# DBM Filter recursion detection

use strict ;

my (%h, $db) ;

unlink $Dfile;

{

my $redirect = new Redirect $file ;

use strict ;

use DB_File ;

use vars qw( %h $k $v ) ;

}

exit ;

#!./perl -w

BEGIN {

require Config; import Config;

if ($Config{'extensions'} !~ /\bDB_File\b/) {

print "1..0 # Skip: DB_File was not built\n";

use DB_File;

use Fcntl;

use strict ;

use vars qw($dbh $Dfile $bad_ones $FA) ;

# full tied array support started in Perl 5.004_57

EOM

}

my $Dfile = "recno.tmp";

unlink $Dfile ;

package Another ;

use strict ;

open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;

package SubDB ;

use strict ;

use vars qw( @ISA @EXPORT) ;

{

# DBM Filter tests

use strict ;

my (@h, $db) ;

my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;

{

# DBM Filter with a closure

use strict ;

my (@h, $db) ;

{

# DBM Filter recursion detection

use strict ;

my (@h, $db) ;

unlink $Dfile;

{

my $redirect = new Redirect $file ;

use strict ;

use DB_File ;

{

my $redirect = new Redirect $save_output ;

use strict ;

use vars qw(@h $H $file $i) ;

use DB_File ;

}

exit ;

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if (not $Config{'d_readdir'}) {

print "1..0\n";

BEGIN {

chdir 't' if -d 't';

}

print "1..10\n";

print "not " if @r != $r;

print "ok 4\n";

@r = ();

for (<*/a*.t>) {

print "# $_\n";

BEGIN {

chdir( 't' ) if -d 't';

}

END {

}

use Benchmark qw( timediff timestr );

use Getopt::Std 'getopts';

getopts('vI:p:');

# -v Verbose

# -I Add to @INC

# -p Name of perl binary

$path_sep = $Config{path_sep} || ':';

$perl5lib = $opt_I || join( $path_sep, @INC );

my $opt_d = '-d:DProf';

my $t_start = new Benchmark;

@results = <R>;

close R;

my $t_total = timediff( new Benchmark, $t_start );

print @results

}

}

sub verify {

my $test = shift;

}

print "1..18\n";

while( @tests ){

$test = shift @tests;

if( $test =~ /_t$/i ){

print "# $test" . '.' x (20 - length $test);

profile $test;

$results = $expected = '';

$perl = $opt_p || $^X;

$dpp = $opt_d || '../utils/dprofpp';

print "\nperl: $perl\n" if $opt_v;

if( ! -f $perl ){ die "Where's Perl?" }

sub dprofpp {

my $switches = shift;

@results = <D>;

close D;

BEGIN {

chdir 't' if -d 't';

}

use Data::Dumper;

BEGIN {

chdir 't' if -d 't';

}

use Data::Dumper;

##

$WANT = <<'EOT';

#$VAR1 = {

#};

EOT

{

local $Data::Dumper::Useqq = 1;

TEST q(Dumper($foo));

$WANT = <<"EOT";

#\$VAR1 = {

#};

EOT

package main;

use Data::Dumper;

$foo = 5;

%foo = (a=>1,b=>\$foo,c=>\@foo);

$foo{d} = \%foo;

$foo[2] = \%foo;

#*::foo = \5;

#*::foo = [

# #0

# #1

# do{my $o},

# #2

#$foo = \*::foo;

#*::foo = \5;

#*::foo = [

# do{my $o},

# {

# 'a' => 1,

##

$WANT = <<'EOT';

#@bar = (

# \*::foo,

# {}

#);

##

$WANT = <<'EOT';

#$bar = [

# \*::foo,

# {}

#];

$WANT = <<'EOT';

#$foo = \*::foo;

#@bar = (

# $foo,

# {

# a => 1,

$WANT = <<'EOT';

#$foo = \*::foo;

#$bar = [

# $foo,

# {

# a => 1,

print "1..16\n";

use English;

use Config;

my $threads = $Config{'use5005threads'} || 0;

print $EUID == $> ? "ok 13\n" : "not ok 13\n";

print $EGID == $) ? "ok 14\n" : "not ok 14\n";

print $BASETIME == $^T ? "ok 16\n" : "not ok 16\n";

BEGIN {

chdir 't' if -d 't';

}

if ($^O eq 'VMS') {

BEGIN {

chdir 't' if -d 't';

}

BEGIN {

BEGIN {

unless(grep /blib/, @INC) {

chdir 't' if -d 't';

}

}

BEGIN {

chdir 't' if -d 't';

print "1..15\n";

}

BEGIN {

chdir 't' if -d 't';

$SIG{__WARN__} = sub {

if ($_[0] =~ /^Hides field 'b1' in base class/) {

$w++;

BEGIN {

chdir 't' if -d 't';

}

print "1..1\n";

BEGIN {

chdir 't' if -d 't';

}

$| = 1;

BEGIN {

chdir 't' if -d 't';

}

if ( $symlink_exists ) { print "1..117\n"; }

my $case = 2;

END {

unlink 'fa/fa_ord','fa/fsl','fa/faa/faa_ord',

print "# '$_' => 1\n";

s#\.$## if ($^O eq 'VMS' && $_ ne '.');

Check( $Expect{$_} );

$File::Find::prune=1 if $_ eq 'faba';

}

sub dn_wanted {

%Expect = ('.' => 1, 'fsl' => 1, 'fa_ord' => 1, 'fab' => 1, 'fab_ord' => 1,

'faba' => 1, 'faa' => 1, 'faa_ord' => 1);

delete $Expect{'fsl'} unless $symlink_exists;

File::Find::find( {wanted => \&wanted, },'fa' );

Check( scalar(keys %Expect) == 0 );

'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1,

'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1);

delete $Expect{'fa/fsl'} unless $symlink_exists;

File::Find::find( {wanted => \&wanted, no_chdir => 1},'fa' );

Check( scalar(keys %Expect) == 0 );

'./fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1,

'./fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1);

delete $Expect{'./fa/fsl'} unless $symlink_exists;

File::Find::finddepth( {wanted => \&dn_wanted },'.' );

Check( scalar(keys %Expect) == 0 );

'./fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1,

'./fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1);

delete $Expect{'./fa/fsl'} unless $symlink_exists;

File::Find::finddepth( {wanted => \&d_wanted, no_chdir => 1 },'.' );

Check( scalar(keys %Expect) == 0 );

if ( $symlink_exists ) {

%Expect=('.' => 1, 'fa_ord' => 1, 'fsl' => 1, 'fb_ord' => 1, 'fba' => 1,

'fba_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faa' => 1,

'faa_ord' => 1);

File::Find::find( {wanted => \&wanted, follow_fast => 1},'fa' );

Check( scalar(keys %Expect) == 0 );

'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1,

'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1,

'fa/faa' => 1, 'fa/faa/faa_ord' => 1);

File::Find::find( {wanted => \&wanted, follow_fast => 1, no_chdir => 1},'fa' );

Check( scalar(keys %Expect) == 0 );

'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1,

'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1,

'fa/faa' => 1, 'fa/faa/faa_ord' => 1);

File::Find::finddepth( {wanted => \&dn_wanted, follow_fast => 1},'fa' );

Check( scalar(keys %Expect) == 0 );

'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1,

'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1,

'fa/faa' => 1, 'fa/faa/faa_ord' => 1);

File::Find::finddepth( {wanted => \&d_wanted, follow_fast => 1, no_chdir => 1},'fa' );

Check( scalar(keys %Expect) == 0 );

BEGIN {

$^O = '';

chdir 't' if -d 't';

}

print "1..1\n";

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {

print "1..0\n";

autoflush $mystdout;

print "1..11\n";

$fh = (new FileHandle "./TEST", O_RDONLY

or new FileHandle "TEST", O_RDONLY)

BEGIN {

chdir 't' if -d 't';

}

use File::Path;

BEGIN {

$^O = '';

chdir 't' if -d 't';

}

# Each element in this array is a single test. Storing them this way makes

BEGIN {

chdir 't' if -d 't';

}

print "1..1\n";

# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $

BEGIN {

require Config; import Config;

if ($Config{'extensions'} !~ /\bGDBM_File\b/) {

print "1..0 # Skip: GDBM_File was not built\n";

}

}

use GDBM_File;

unlink <Op.dbmx*>;

umask(0);

if (! -e $Dfile) {

($Dfile) = <Op.dbmx*>;

}

print "ok 2 # Skipped: different file permission semantics\n";

}

else {

$blksize,$blocks) = stat($Dfile);

print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");

}

$i++;

}

print (!$i ? "ok 3\n" : "not ok 3\n");

delete $h{'goner2'};

untie(%h);

$h{'j'} = 'J';

$h{'k'} = 'K';

delete $h{'goner1'};

delete $h{'goner3'};

if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}

if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {

$key =~ y/a-z/A-Z/;

$i++ if $key eq $value;

$h{''} = 'bar';

# check cache overflow and numeric keys and contents

for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }

for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }

print ($ok ? "ok 8\n" : "not ok 8\n");

$blksize,$blocks) = stat($Dfile);

print ($size > 0 ? "ok 9\n" : "not ok 9\n");

@h{0..200} = 200..400;

print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";

print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");

package Another ;

use strict ;

open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;

print FILE <<'EOM' ;

close FILE ;

BEGIN { push @INC, '.'; }

eval 'use SubDB ; ';

main::ok(13, $@ eq "") ;

{

# DBM Filter tests

use strict ;

my (%h, $db) ;

my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;

# DBM Filter with a closure

use strict ;

my (%h, $db) ;

unlink <Op.dbmx*>;

ok(54, $result{"store key"} eq "store key - 2: [fred jim]");

ok(55, $result{"store value"} eq "store value - 2: [joe john]");

ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]");

ok(58, $_ eq "original") ;

ok(59, $h{"fred"} eq "joe");

{

# DBM Filter recursion detection

use strict ;

my (%h, $db) ;

unlink <Op.dbmx*>;

untie %h;

unlink <Op.dbmx*>;

}

BEGIN {

chdir 't' if -d 't';

}

print "1..11\n";

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) {

print "1..0\n";

$ENV{PATH} = "/bin";

delete @ENV{BASH_ENV, CDPATH, ENV, IFS};

@correct = ();

closedir D;

}

@a = File::Glob::glob("*", 0);

# look up the user's home directory

# should return a list with one item, and not set ERROR

eval {

($name, $home) = (getpwuid($>))[0,7];

1;

} and do {

if (scalar(@a) != 1 || $a[0] ne $home || GLOB_ERROR) {

print "not ";

}

# check backslashing

# should return a list with one item, and not set ERROR

if (scalar @a != 1 || $a[0] ne 'TEST' || GLOB_ERROR) {

local $/ = "][";

print "# [@a]\n";

# check nonexistent checks

# should return an empty list

# XXX since errfunc is NULL on win32, this test is not valid there

if ($^O ne 'MSWin32' and scalar @a != 0) {

print "# |@a|\nnot ";

}

else {

$dir = "PtEeRsLt.dir";

mkdir $dir, 0;

#print "\@a = ", array(@a);

rmdir $dir;

if (scalar(@a) != 0 || GLOB_ERROR == 0) {

}

# check for csh style globbing

unless (@a == 2 and $a[0] eq 'a' and $a[1] eq 'b') {

print "not ";

}

print "ok 7\n";

'{TES*,doesntexist*,a,b}',

);

unless (@a == 3

and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST')

and $a[1] eq 'a'

# "~" should expand to $ENV{HOME}

$ENV{HOME} = "sweet home";

print "not ";

}

print "ok 9\n";

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) {

print "1..0\n";

$loaded = 1;

print "ok 1\n";

# Test the actual use of the case sensitivity tags, via csh_glob()

import File::Glob ':nocase';

print "not " unless @a >= 3;

print "ok 2\n";

# This may fail on systems which are not case-PRESERVING

import File::Glob ':case';

print "not " unless @a == 0;

print "ok 3\n";

# Test the explicit use of the GLOB_NOCASE flag

print "not " unless @a >= 3;

print "ok 4\n";

rmdir "[]";

print "# returned @a\nnot " unless @a == 1;

print "ok 6\n";

print "not " if @a == 0;

print "ok 7\n";

}

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) {

print "1..0\n";

$loaded = 1;

print "ok 1\n";

my @r = glob;

print "ok 2\n";

# we should have at least basic.t, global.t, taint.t

print "ok 3\n";

# check if <*/*> works

# at least t/global.t t/basic.t, t/taint.t

print "not " if @r < 3;

print "ok 4\n";

# check if scalar context works

@r = ();

}

print "not " if @r != $r;

print "ok 5\n";

@r = ();

}

print "not " if @r != $r;

print "ok 6\n";

# test if implicit assign to $_ in while() works

@r = ();

}

print "not " if @r != $r;

print "ok 7\n";

# test if explicit glob() gets assign magic too

my @s = ();

#print "# $_\n";

push @s, $_;

}

package Foo;

use File::Glob ':globally';

@s = ();

#print "# $_\n";

push @s, $_;

}

# test if different glob ops maintain independent contexts

@s = ();

my $i = 0;

}

}

print "not " if "@r" ne "@s" or not $i;

print "ok 10\n";

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) {

print "1..0\n";

print "ok 1\n";

# all filenames should be tainted

eval { $a = join("",@a), kill 0; 1 };

unless ($@ =~ /Insecure dependency/) {

print "not ";

#!./perl -w

BEGIN {

}

print "1..9\n";

@ARGV = qw(-Foo -baR --foo bar);

undef $opt_baR;

undef $opt_bar;

print "ok 1\n" if GetOptions ("foo", "Foo=s");

#!./perl -w

BEGIN {

}

require "newgetopt.pl";

#!./perl -w

BEGIN {

}

use Getopt::Long;

BEGIN {

chdir 't' if -d 't';

}

print "1..2\n";

BEGIN {

chdir 't' if -d 't';

}

use Sys::Hostname;

BEGIN {

unless(grep /blib/, @INC) {

chdir 't' if -d 't';

}

}

BEGIN {

unless(grep /blib/, @INC) {

chdir 't' if -d 't';

}

require Config; import Config;

if ($] < 5.00326 || not $Config{'d_readdir'}) {

BEGIN {

unless(grep /blib/, @INC) {

chdir 't' if -d 't';

}

}

chdir 't';

$File =~ s/^t\W+//; # Remove first directory

}

require strict; import strict;

}

BEGIN {

unless(grep /blib/, @INC) {

chdir 't' if -d 't';

}

}

BEGIN {

unless(grep /blib/, @INC) {

chdir 't' if -d 't';

}

}

BEGIN {

unless(grep /blib/, @INC) {

chdir 't' if -d 't';

}

}

select(STDERR); $| = 1;

select(STDOUT); $| = 1;

use IO::Handle;

use IO::Poll qw(/POLL/);

print "not "

if $poll->events($stdout);

print "ok 8\n";

BEGIN {

unless(grep /blib/, @INC) {

chdir 't' if -d 't';

}

}

BEGIN {

unless(grep /blib/, @INC) {

chdir 't' if -d 't';

}

}

} elsif(defined $pid) {

$sock = IO::Socket::INET->new(PeerPort => $port,

Proto => 'tcp',

PeerAddr => 'localhost'

)

$sock->autoflush(1);

$listen->close;

} elsif (defined $pid) {

# child, try various ways to connect

if ($sock) {

print "not " unless $sock->connected;

print "ok 6\n";

sleep(1);

$sock = IO::Socket->new(Domain => AF_INET,

if ($sock) {

$sock->print("ok 11\n");

$sock->print("quit\n");

# Then test UDP sockets

$server = IO::Socket->new(Domain => AF_INET,

Proto => 'udp',

$port = $server->sockport;

if ($^O eq 'mpeix') {

} elsif (defined($pid)) {

#child

$sock = IO::Socket::INET->new(Proto => 'udp',

$sock->send("ok 12\n");

sleep(1);

$sock->send("ok 12\n"); # send another one to be sure

BEGIN {

unless(grep /blib/, @INC) {

chdir 't' if -d 't';

}

}

BEGIN {

unless(grep /blib/, @INC) {

chdir 't' if -d 't';

$tell_file = "TEST";

}

else {

BEGIN {

unless(grep /blib/, @INC) {

chdir 't' if -d 't';

}

}

use Socket;

use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY);

$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')

print "ok 1\n";

$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')

print "ok 2\n";

BEGIN {

unless(grep /blib/, @INC) {

chdir 't' if -d 't';

}

}

BEGIN {

unless(grep /blib/, @INC) {

chdir 't' if -d 't';

}

}

$! = 0;

$x->setpos(undef);

print $! ? "ok 4 # $!\n" : "not ok 4\n";

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

my $reason;

$reason = '$Config{d_sem} undefined';

} elsif ($Config{'d_msg'} ne 'define') {

$reason = '$Config{d_msg} undefined';

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if ($Config{'extensions'} !~ /\bNDBM_File\b/) {

print "1..0 # Skip: NDBM_File was not built\n";

}

}

require NDBM_File;

#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT

use Fcntl;

unlink <Op.dbmx*>;

umask(0);

if (! -e $Dfile) {

($Dfile) = <Op.dbmx*>;

}

print "ok 2 # Skipped: different file permission semantics\n";

}

else {

$blksize,$blocks) = stat($Dfile);

print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");

}

$i++;

}

print (!$i ? "ok 3\n" : "not ok 3\n");

delete $h{'goner2'};

untie(%h);

$h{'j'} = 'J';

$h{'k'} = 'K';

delete $h{'goner1'};

delete $h{'goner3'};

if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}

if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {

$key =~ y/a-z/A-Z/;

$i++ if $key eq $value;

$h{''} = 'bar';

# check cache overflow and numeric keys and contents

for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }

for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }

print ($ok ? "ok 8\n" : "not ok 8\n");

$blksize,$blocks) = stat($Dfile);

print ($size > 0 ? "ok 9\n" : "not ok 9\n");

@h{0..200} = 200..400;

print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";

print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");

untie %h;

unlink 'Op.dbmx.dir', $Dfile;

{

# sub-class test

package Another ;

use strict ;

open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;

print FILE <<'EOM' ;

package SubDB ;

use strict ;

use vars qw(@ISA @EXPORT) ;

require Exporter ;

{

# DBM Filter tests

use strict ;

my (%h, $db) ;

my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;

# DBM Filter with a closure

use strict ;

my (%h, $db) ;

unlink <Op.dbmx*>;

ok(52, $result{"store key"} eq "store key - 2: [fred jim]");

ok(53, $result{"store value"} eq "store value - 2: [joe john]");

ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]");

ok(56, $_ eq "original") ;

ok(57, $h{"fred"} eq "joe");

{

# DBM Filter recursion detection

use strict ;

my (%h, $db) ;

unlink <Op.dbmx*>;

untie %h;

unlink <Op.dbmx*>;

}

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if ($Config{'extensions'} !~ /\bODBM_File\b/) {

print "1..0 # Skip: ODBM_File was not built\n";

}

}

require ODBM_File;

#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT

use Fcntl;

unlink <Op.dbmx*>;

umask(0);

if (! -e $Dfile) {

($Dfile) = <Op.dbmx*>;

}

print "ok 2 # Skipped: different file permission semantics\n";

}

else {

$blksize,$blocks) = stat($Dfile);

print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");

}

$i++;

}

print (!$i ? "ok 3\n" : "not ok 3\n");

delete $h{'goner2'};

untie(%h);

$h{'j'} = 'J';

$h{'k'} = 'K';

delete $h{'goner1'};

delete $h{'goner3'};

if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}

if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {

$key =~ y/a-z/A-Z/;

$i++ if $key eq $value;

$h{''} = 'bar';

# check cache overflow and numeric keys and contents

for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }

for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }

print ($ok ? "ok 8\n" : "not ok 8\n");

$blksize,$blocks) = stat($Dfile);

print ($size > 0 ? "ok 9\n" : "not ok 9\n");

@h{0..200} = 200..400;

print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";

print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");

untie %h;

unlink 'Op.dbmx.dir', $Dfile;

{

# sub-class test

package Another ;

use strict ;

open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;

print FILE <<'EOM' ;

package SubDB ;

use strict ;

use vars qw(@ISA @EXPORT) ;

require Exporter ;

{

# DBM Filter tests

use strict ;

my (%h, $db) ;

my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;

# DBM Filter with a closure

use strict ;

my (%h, $db) ;

unlink <Op.dbmx*>;

ok(52, $result{"store key"} eq "store key - 2: [fred jim]");

ok(53, $result{"store value"} eq "store value - 2: [joe john]");

ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]");

ok(56, $_ eq "original") ;

ok(57, $h{"fred"} eq "joe");

{

# DBM Filter recursion detection

use strict ;

my (%h, $db) ;

unlink <Op.dbmx*>;

unlink <Op.dbmx*>;

}

if ($^O eq 'hpux') {

print <<EOM;

#

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {

print "1..0\n";

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if (!$Config{'d_fork'}

# open2/3 supported on win32 (but not Borland due to CRT bugs)

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if (!$Config{'d_fork'}

# open2/3 supported on win32 (but not Borland due to CRT bugs)

use IPC::Open3;

#require 'open3.pl'; use subs 'open3';

sub ok {

my ($n, $result, $info) = @_;

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {

print "1..0\n";

BEGIN {

chdir 't' if -d 't';

}

use warnings;

BEGIN {

chdir 't' if -d 't';

}

# All the constants which Socket.pm tries to make available:

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if ($^O ne 'VMS' and $Config{'extensions'} !~ /\bPOSIX\b/) {

print "1..0\n";

print "1..27\n";

$Is_W32 = $^O eq 'MSWin32';

$testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n";

read($testfd, $buffer, 9) if $testfd > 2;

write(1,"ok 3\nnot ok 3\n", 5);

@fds = POSIX::pipe();

print $fds[0] > $testfd ? "ok 4\n" : "not ok 4\n";

CORE::open($reader = \*READER, "<&=".$fds[0]);

close $writer;

print <$reader>;

close $reader;

for (6..11) {

}

}

else {

$|=1;

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {

print "1..0\n";

$|=1;

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {

print "1..0\n";

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if (($Config{'extensions'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){

print "1..0\n";

exit 0;

}

}

require SDBM_File;

#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT

use Fcntl;

unlink <Op_dbmx.*>;

umask(0);

if (! -e $Dfile) {

($Dfile) = <Op_dbmx.*>;

}

print "ok 2 # Skipped: different file permission semantics\n";

}

else {

$blksize,$blocks) = stat($Dfile);

print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");

}

$i++;

}

print (!$i ? "ok 3\n" : "not ok 3\n");

delete $h{'goner2'};

untie(%h);

$h{'j'} = 'J';

$h{'k'} = 'K';

delete $h{'goner1'};

delete $h{'goner3'};

if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}

if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {

$key =~ y/a-z/A-Z/;

$i++ if $key eq $value;

$h{''} = 'bar';

# check cache overflow and numeric keys and contents

for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }

for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }

print ($ok ? "ok 8\n" : "not ok 8\n");

$blksize,$blocks) = stat($Dfile);

print ($size > 0 ? "ok 9\n" : "not ok 9\n");

@h{0..200} = 200..400;

print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";

print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");

print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");

{

# sub-class test

package Another ;

use strict ;

open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;

print FILE <<'EOM' ;

package SubDB ;

use strict ;

use vars qw( @ISA @EXPORT) ;

require Exporter ;

{

# DBM Filter tests

use strict ;

my (%h, $db) ;

my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;

# DBM Filter with a closure

use strict ;

my (%h, $db) ;

unlink <Op_dbmx*>;

ok(54, $result{"store key"} eq "store key - 2: [fred jim]");

ok(55, $result{"store value"} eq "store value - 2: [joe john]");

ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]");

ok(58, $_ eq "original") ;

ok(59, $h{"fred"} eq "joe");

{

# DBM Filter recursion detection

use strict ;

my (%h, $db) ;

unlink <Op_dbmx*>;

unlink <Op_dbmx*>;

}

BEGIN {

chdir 't' if -d 't';

}

print "1..4\n";

BEGIN {

chdir 't' if -d 't';

}

print "1..3\n";

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

if ($Config{'extensions'} !~ /\bSocket\b/ &&

!(($^O eq 'VMS') && $Config{d_socket})) {

if (connect(T,pack_sockaddr_in(7,inet_aton("localhost")))){

print "ok 2\n";

syswrite(T,"hello",5);

$read = sysread(T,$buff,10); # Connection may be granted, then closed!

if (connect(S,pack_sockaddr_in(7,INADDR_LOOPBACK))){

print "ok 5\n";

syswrite(S,"olleh",5);

$read = sysread(S,$buff,10); # Connection may be granted, then closed!

BEGIN {

chdir 't' if -d 't';

}

use Text::Soundex;

BEGIN {

chdir 't' if -d 't';

}

print "1..8\n";

BEGIN {

chdir 't' if -d 't';

require Config; import Config;

# Don't bother if there are no quad offsets.

if ($Config{lseeksize} < 8) {

exit(0);

}

require Fcntl; import Fcntl qw(/^O_/ /^SEEK_/);

}

sub zap {

close(BIG);

unlink("big");

exit(0);

}

sub explain {

#

#

# Perl may still be able to support large files, once you have

# such a process, enough quota, and such a (file) system.

#

EOM

}

print "# checking whether we have sparse files...\n";

# Known have-nots.

bye();

}

# Known haves that have problems running this test

# (for example because they do not support sparse files, like UNICOS)

if ($^O eq 'unicos') {

bye();

}

unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 &&

$s1[11] == $s2[11] && $s1[12] == $s2[12]) {

bye;

}

# By now we better be sure that we do have sparse files:

# if we are not, the following will hog 5 gigabytes of disk. Ooops.

$ENV{LC_ALL} = "C";

sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or

do { warn "sysopen 'big' failed: $!\n"; bye };

my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET);

bye();

}

print "# close failed: $!\n" unless $close;

unless($syswrite && $close) {

if ($! =~/too large/i) {

} elsif ($! =~ /quota/i) {

}

bye();

}

print "# @s\n";

unless ($s[7] == 5_000_000_003) {

bye();

}

$fail++;

}

print "1..17\n";

fail unless $s[7] == 5_000_000_003; # exercizes pp_stat

print "ok 1\n";

sysopen(BIG, "big", O_RDONLY) or do { warn "sysopen failed: $!\n"; bye };

print "ok 5\n";

print "ok 6\n";

print "ok 7\n";

print "ok 8\n";

print "ok 9\n";

print "ok 10\n";

print "ok 11\n";

print "ok 12\n";

my $big;

print "ok 14\n";

# 705_032_704 = (I32)5_000_000_000

print "ok 15\n";

my $zero;

fail unless $zero eq "\0\0\0";

print "ok 17\n";

bye(); # does the necessary cleanup

BEGIN {

chdir 't' if -d 't';

}

use Text::Wrap qw(&fill);

BEGIN {

chdir 't' if -d 't';

}