diff options
Diffstat (limited to 'gnu/usr.bin/perl/t')
46 files changed, 5986 insertions, 0 deletions
diff --git a/gnu/usr.bin/perl/t/lib/io_dup.t b/gnu/usr.bin/perl/t/lib/io_dup.t new file mode 100644 index 00000000000..6b0caf14fad --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/io_dup.t @@ -0,0 +1,61 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +use IO::Handle; +use IO::File; + +select(STDERR); $| = 1; +select(STDOUT); $| = 1; + +print "1..6\n"; + +print "ok 1\n"; + +$dupout = IO::Handle->new->fdopen( \*STDOUT ,"w"); +$duperr = IO::Handle->new->fdopen( \*STDERR ,"w"); + +$stdout = \*STDOUT; bless $stdout, "IO::File"; # "IO::Handle"; +$stderr = \*STDERR; bless $stderr, "IO::Handle"; + +$stdout->open( "Io.dup","w") || die "Can't open stdout"; +$stderr->fdopen($stdout,"w"); + +print $stdout "ok 2\n"; +print $stderr "ok 3\n"; +if ($^O eq 'MSWin32') { + print `echo ok 4`; + print `echo ok 5 1>&2`; # does this *really* work? +} +else { + system 'echo ok 4'; + system 'echo ok 5 1>&2'; +} + +$stderr->close; +$stdout->close; + +$stdout->fdopen($dupout,"w"); +$stderr->fdopen($duperr,"w"); + +if ($^O eq 'MSWin32') { print `type Io.dup` } +else { system 'cat Io.dup' } +unlink 'Io.dup'; + +print STDOUT "ok 6\n"; diff --git a/gnu/usr.bin/perl/t/lib/io_pipe.t b/gnu/usr.bin/perl/t/lib/io_pipe.t new file mode 100644 index 00000000000..eee374149ca --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/io_pipe.t @@ -0,0 +1,109 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if (! $Config{'d_fork'} || + ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS')) + { + print "1..0\n"; + exit 0; + } + } +} + +use IO::Pipe; + +my $perl = './perl'; + +$| = 1; +print "1..10\n"; + +$pipe = new IO::Pipe->reader($perl, '-e', 'print "not ok 1\n"'); +while (<$pipe>) { + s/^not //; + print; +} +$pipe->close or print "# \$!=$!\nnot "; +print "ok 2\n"; + +$cmd = 'BEGIN{$SIG{ALRM} = sub {print "not ok 4\n"; exit}; alarm 10} s/not //'; +$pipe = new IO::Pipe->writer($perl, '-pe', $cmd); +print $pipe "not ok 3\n" ; +$pipe->close or print "# \$!=$!\nnot "; +print "ok 4\n"; + +$pipe = new IO::Pipe; + +$pid = fork(); + +if($pid) + { + $pipe->writer; + print $pipe "Xk 5\n"; + print $pipe "oY 6\n"; + $pipe->close; + wait; + } +elsif(defined $pid) + { + $pipe->reader; + $stdin = bless \*STDIN, "IO::Handle"; + $stdin->fdopen($pipe,"r"); + exec 'tr', 'YX', 'ko'; + } +else + { + die "# error = $!"; + } + +$pipe = new IO::Pipe; +$pid = fork(); + +if($pid) + { + $pipe->reader; + while(<$pipe>) { + s/^not //; + print; + } + $pipe->close; + wait; + } +elsif(defined $pid) + { + $pipe->writer; + + $stdout = bless \*STDOUT, "IO::Handle"; + $stdout->fdopen($pipe,"w"); + print STDOUT "not ok 7\n"; + exec 'echo', 'not ok 8'; + } +else + { + die; + } + +$pipe = new IO::Pipe; +$pipe->writer; + +$SIG{'PIPE'} = 'broken_pipe'; + +sub broken_pipe { + print "ok 9\n"; +} + +print $pipe "not ok 9\n"; +$pipe->close; + + +print "ok 10\n"; + diff --git a/gnu/usr.bin/perl/t/lib/io_sel.t b/gnu/usr.bin/perl/t/lib/io_sel.t new file mode 100644 index 00000000000..b9c10974040 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/io_sel.t @@ -0,0 +1,116 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +select(STDERR); $| = 1; +select(STDOUT); $| = 1; + +print "1..21\n"; + +use IO::Select 1.09; + +my $sel = new IO::Select(\*STDIN); +$sel->add(4, 5) == 2 or print "not "; +print "ok 1\n"; + +$sel->add([\*STDOUT, 'foo']) == 1 or print "not "; +print "ok 2\n"; + +@handles = $sel->handles; +print "not " unless $sel->count == 4 && @handles == 4; +print "ok 3\n"; +#print $sel->as_string, "\n"; + +$sel->remove(\*STDIN) == 1 or print "not "; +print "ok 4\n", +; +$sel->remove(\*STDIN, 5, 6) == 1 # two of there are not present + or print "not "; +print "ok 5\n"; + +print "not " unless $sel->count == 2; +print "ok 6\n"; +#print $sel->as_string, "\n"; + +$sel->remove(1, 4); +print "not " unless $sel->count == 0 && !defined($sel->bits); +print "ok 7\n"; + +$sel = new IO::Select; +print "not " unless $sel->count == 0 && !defined($sel->bits); +print "ok 8\n"; + +$sel->remove([\*STDOUT, 5]); +print "not " unless $sel->count == 0 && !defined($sel->bits); +print "ok 9\n"; + +if ($^O eq 'MSWin32') { # 4-arg select is only valid on sockets + print "# skipping tests 10..15\n"; + for (10 .. 15) { print "ok $_\n" } + $sel->add(\*STDOUT); # update + goto POST_SOCKET; +} + +@a = $sel->can_read(); # should return imediately +print "not " unless @a == 0; +print "ok 10\n"; + +# we assume that we can write to STDOUT :-) +$sel->add([\*STDOUT, "ok 12\n"]); + +@a = $sel->can_write; +print "not " unless @a == 1; +print "ok 11\n"; + +my($fd, $msg) = @{shift @a}; +print $fd $msg; + +$sel->add(\*STDOUT); # update + +@a = IO::Select::select(undef, $sel, undef, 1); +print "not " unless @a == 3; +print "ok 13\n"; + +($r, $w, $e) = @a; + +print "not " unless @$r == 0 && @$w == 1 && @$e == 0; +print "ok 14\n"; + +$fd = $w->[0]; +print $fd "ok 15\n"; + +POST_SOCKET: +# Test new exists() method +$sel->exists(\*STDIN) and print "not "; +print "ok 16\n"; + +($sel->exists(0) || $sel->exists([\*STDERR])) and print "not "; +print "ok 17\n"; + +$fd = $sel->exists(\*STDOUT); +if ($fd) { + print $fd "ok 18\n"; +} else { + print "not ok 18\n"; +} + +$fd = $sel->exists([1, 'foo']); +if ($fd) { + print $fd "ok 19\n"; +} else { + print "not ok 19\n"; +} + +# Try self clearing +$sel->add(5,6,7,8,9,10); +print "not " unless $sel->count == 7; +print "ok 20\n"; + +$sel->remove($sel->handles); +print "not " unless $sel->count == 0 && !defined($sel->bits); +print "ok 21\n"; diff --git a/gnu/usr.bin/perl/t/lib/io_sock.t b/gnu/usr.bin/perl/t/lib/io_sock.t new file mode 100644 index 00000000000..0971e7803f0 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/io_sock.t @@ -0,0 +1,81 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if (-d "lib" && -f "TEST") { + if (!$Config{'d_fork'} || + (($Config{'extensions'} !~ /\bSocket\b/ || + $Config{'extensions'} !~ /\bIO\b/) && + !(($^O eq 'VMS') && $Config{d_socket}))) { + print "1..0\n"; + exit 0; + } + } +} + +$| = 1; +print "1..5\n"; + +use IO::Socket; + +$listen = IO::Socket::INET->new(Listen => 2, + Proto => 'tcp', + ) or die "$!"; + +print "ok 1\n"; + +$port = $listen->sockport; + +if($pid = fork()) { + + $sock = $listen->accept(); + print "ok 2\n"; + + $sock->autoflush(1); + print $sock->getline(); + + print $sock "ok 4\n"; + + $sock->close; + + waitpid($pid,0); + + print "ok 5\n"; + +} elsif(defined $pid) { + + # This can fail if localhost is undefined or the + # special 'loopback' address 127.0.0.1 is not configured + # on your system. (/etc/rc.config.d/netconfig on HP-UX.) + + $sock = IO::Socket::INET->new(PeerPort => $port, + Proto => 'tcp', + PeerAddr => 'localhost' + ) or die "$!"; + + $sock->autoflush(1); + + print $sock "ok 3\n"; + + print $sock->getline(); + + $sock->close; + + exit; +} else { + die; +} + + + + + + diff --git a/gnu/usr.bin/perl/t/lib/io_taint.t b/gnu/usr.bin/perl/t/lib/io_taint.t new file mode 100644 index 00000000000..0ef2cfd63f5 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/io_taint.t @@ -0,0 +1,48 @@ +#!./perl -T + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +END { unlink "./__taint__$$" } + +print "1..3\n"; +use IO::File; +$x = new IO::File "> ./__taint__$$" || die("Cannot open ./__taint__$$\n"); +print $x "$$\n"; +$x->close; + +$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n"); +chop($unsafe = <$x>); +eval { kill 0 * $unsafe }; +print "not " if $^O ne 'MSWin32' and ($@ !~ /^Insecure/o); +print "ok 1\n"; +$x->close; + +# We could have just done a seek on $x, but technically we haven't tested +# seek yet... +$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n"); +$x->untaint; +print "not " if ($?); +print "ok 2\n"; # Calling the method worked +chop($unsafe = <$x>); +eval { kill 0 * $unsafe }; +print "not " if ($@ =~ /^Insecure/o); +print "ok 3\n"; # No Insecure message from using the data +$x->close; + +exit 0; diff --git a/gnu/usr.bin/perl/t/lib/io_tell.t b/gnu/usr.bin/perl/t/lib/io_tell.t new file mode 100644 index 00000000000..d8ebae24fd0 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/io_tell.t @@ -0,0 +1,64 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + $tell_file = "TEST"; + } + else { + $tell_file = "Makefile"; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +print "1..13\n"; + +use IO::File; + +$tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file"); +binmode $tst if $^O eq 'MSWin32'; +if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; } + +$firstline = <$tst>; +$secondpos = tell; + +$x = 0; +while (<$tst>) { + if (eof) {$x++;} +} +if ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; } + +$lastpos = tell; + +unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; } + +if ($tst->seek(0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; } + +if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; } + +if ($firstline eq <$tst>) { print "ok 6\n"; } else { print "not ok 6\n"; } + +if ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; } + +if ($tst->seek(0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; } + +if ($tst->eof) { print "not ok 9\n"; } else { print "ok 9\n"; } + +if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; } + +if ($tst->seek(0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; } + +if ($lastpos == $tst->tell) { print "ok 12\n"; } else { print "not ok 12\n"; } + +unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; } diff --git a/gnu/usr.bin/perl/t/lib/io_udp.t b/gnu/usr.bin/perl/t/lib/io_udp.t new file mode 100644 index 00000000000..3e167141182 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/io_udp.t @@ -0,0 +1,44 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ( ($Config{'extensions'} !~ /\bSocket\b/ || + $Config{'extensions'} !~ /\bIO\b/ || + $^O eq 'os2') && + !(($^O eq 'VMS') && $Config{d_socket})) { + print "1..0\n"; + exit 0; + } + } +} + +$| = 1; +print "1..3\n"; + +use Socket; +use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); + + # This can fail if localhost is undefined or the + # special 'loopback' address 127.0.0.1 is not configured + # on your system. (/etc/rc.config.d/netconfig on HP-UX.) + +$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost'); +$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost'); + +print "ok 1\n"; + +$udpa->send("ok 2\n",0,$udpb->sockname); +$udpb->recv($buf="",5); +print $buf; +$udpb->send("ok 3\n"); +$udpa->recv($buf="",5); +print $buf; diff --git a/gnu/usr.bin/perl/t/lib/io_xs.t b/gnu/usr.bin/perl/t/lib/io_xs.t new file mode 100644 index 00000000000..1a6fd381a30 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/io_xs.t @@ -0,0 +1,42 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +use IO::File; +use IO::Seekable; + +print "1..4\n"; + +$x = new_tmpfile IO::File or print "not "; +print "ok 1\n"; +print $x "ok 2\n"; +$x->seek(0,SEEK_SET); +print <$x>; + +$x->seek(0,SEEK_SET); +print $x "not ok 3\n"; +$p = $x->getpos; +print $x "ok 3\n"; +$x->flush; +$x->setpos($p); +print scalar <$x>; + +$! = 0; +$x->setpos(undef); +print $! ? "ok 4 # $!\n" : "not ok 4\n"; diff --git a/gnu/usr.bin/perl/t/lib/opcode.t b/gnu/usr.bin/perl/t/lib/opcode.t new file mode 100644 index 00000000000..a785fce48b6 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/opcode.t @@ -0,0 +1,115 @@ +#!./perl -w + +$|=1; + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { + print "1..0\n"; + exit 0; + } +} + +use Opcode qw( + opcodes opdesc opmask verify_opset + opset opset_to_ops opset_to_hex invert_opset + opmask_add full_opset empty_opset define_optag +); + +use strict; + +my $t = 1; +my $last_test; # initalised at end +print "1..$last_test\n"; + +my($s1, $s2, $s3); +my(@o1, @o2, @o3); + +# --- opset_to_ops and opset + +my @empty_l = opset_to_ops(empty_opset); +print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++; + +my @full_l1 = opset_to_ops(full_opset); +print @full_l1 == opcodes() ? "ok $t\n" : "not ok $t\n"; $t++; +my @full_l2 = @full_l1; # = opcodes(); # XXX to be fixed +print "@full_l1" eq "@full_l2" ? "ok $t\n" : "not ok $t\n"; $t++; + +@empty_l = opset_to_ops(opset(':none')); +print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++; + +my @full_l3 = opset_to_ops(opset(':all')); +print @full_l1 == @full_l3 ? "ok $t\n" : "not ok $t\n"; $t++; +print "@full_l1" eq "@full_l3" ? "ok $t\n" : "not ok $t\n"; $t++; + +die $t unless $t == 7; +$s1 = opset( 'padsv'); +$s2 = opset($s1, 'padav'); +$s3 = opset($s2, '!padav'); +print $s1 eq $s2 ? "not ok $t\n" : "ok $t\n"; ++$t; +print $s1 eq $s3 ? "ok $t\n" : "not ok $t\n"; ++$t; + +# --- define_optag + +print eval { opset(':_tst_') } ? "not ok $t\n" : "ok $t\n"; ++$t; +define_optag(":_tst_", opset(qw(padsv padav padhv))); +print eval { opset(':_tst_') } ? "ok $t\n" : "not ok $t\n"; ++$t; + +# --- opdesc and opcodes + +die $t unless $t == 11; +print opdesc("gv") eq "glob value" ? "ok $t\n" : "not ok $t\n"; $t++; +my @desc = opdesc(':_tst_','stub'); +print "@desc" eq "private variable private array private hash stub" + ? "ok $t\n" : "not ok $t\n#@desc\n"; $t++; +print opcodes() ? "ok $t\n" : "not ok $t\n"; $t++; +print "ok $t\n"; ++$t; + +# --- invert_opset + +$s1 = opset(qw(fileno padsv padav)); +@o2 = opset_to_ops(invert_opset($s1)); +print @o2 == opcodes-3 ? "ok $t\n" : "not ok $t\n"; $t++; + +# --- opmask + +die $t unless $t == 16; +print opmask() eq empty_opset() ? "ok $t\n" : "not ok $t\n"; $t++; # work +print length opmask() == int((opcodes()+7)/8) ? "ok $t\n" : "not ok $t\n"; $t++; + +# --- verify_opset + +print verify_opset($s1) && !verify_opset(42) ? "ok $t\n":"not ok $t\n"; $t++; + +# --- opmask_add + +opmask_add(opset(qw(fileno))); # add to global op_mask +print eval 'fileno STDOUT' ? "not ok $t\n" : "ok $t\n"; $t++; # fail +print $@ =~ /fileno trapped/ ? "ok $t\n" : "not ok $t\n# $@\n"; $t++; + +# --- check use of bit vector ops on opsets + +$s1 = opset('padsv'); +$s2 = opset('padav'); +$s3 = opset('padsv', 'padav', 'padhv'); + +# Non-negated +print (($s1 | $s2) eq opset($s1,$s2) ? "ok $t\n":"not ok $t\n"); $t++; +print (($s2 & $s3) eq opset($s2) ? "ok $t\n":"not ok $t\n"); $t++; +print (($s2 ^ $s3) eq opset('padsv','padhv') ? "ok $t\n":"not ok $t\n"); $t++; + +# Negated, e.g., with possible extra bits in last byte beyond last op bit. +# The extra bits mean we can't just say ~mask eq invert_opset(mask). + +@o1 = opset_to_ops( ~ $s3); +@o2 = opset_to_ops(invert_opset $s3); +print "@o1" eq "@o2" ? "ok $t\n":"not ok $t\n"; $t++; + +# --- finally, check some opname assertions + +foreach(@full_l1) { die "bad opname: $_" if /\W/ or /^\d/ } + +print "ok $last_test\n"; +BEGIN { $last_test = 25 } diff --git a/gnu/usr.bin/perl/t/lib/open2.t b/gnu/usr.bin/perl/t/lib/open2.t new file mode 100644 index 00000000000..a2e6a07a7b0 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/open2.t @@ -0,0 +1,46 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + unless ($Config{'d_fork'}) { + print "1..0\n"; + exit 0; + } + # make warnings fatal + $SIG{__WARN__} = sub { die @_ }; +} + +use strict; +use IO::Handle; +use IPC::Open2; +#require 'open2.pl'; use subs 'open2'; + +my $perl = './perl'; + +sub ok { + my ($n, $result, $info) = @_; + if ($result) { + print "ok $n\n"; + } + else { + print "not ok $n\n"; + print "# $info\n" if $info; + } +} + +my ($pid, $reaped_pid); +STDOUT->autoflush; +STDERR->autoflush; + +print "1..7\n"; + +ok 1, $pid = open2 'READ', 'WRITE', $perl, '-e', 'print scalar <STDIN>'; +ok 2, print WRITE "hi kid\n"; +ok 3, <READ> eq "hi kid\n"; +ok 4, close(WRITE), $!; +ok 5, close(READ), $!; +$reaped_pid = waitpid $pid, 0; +ok 6, $reaped_pid == $pid, $reaped_pid; +ok 7, $? == 0, $?; diff --git a/gnu/usr.bin/perl/t/lib/open3.t b/gnu/usr.bin/perl/t/lib/open3.t new file mode 100644 index 00000000000..4258eec4018 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/open3.t @@ -0,0 +1,121 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + unless ($Config{'d_fork'}) { + print "1..0\n"; + exit 0; + } + # make warnings fatal + $SIG{__WARN__} = sub { die @_ }; +} + +use strict; +use IO::Handle; +use IPC::Open3; +#require 'open3.pl'; use subs 'open3'; + +my $perl = './perl'; + +sub ok { + my ($n, $result, $info) = @_; + if ($result) { + print "ok $n\n"; + } + else { + print "not ok $n\n"; + print "# $info\n" if $info; + } +} + +my ($pid, $reaped_pid); +STDOUT->autoflush; +STDERR->autoflush; + +print "1..21\n"; + +# basic +ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', <<'EOF'; + $| = 1; + print scalar <STDIN>; + print STDERR "hi error\n"; +EOF +ok 2, print WRITE "hi kid\n"; +ok 3, <READ> eq "hi kid\n"; +ok 4, <ERROR> eq "hi error\n"; +ok 5, close(WRITE), $!; +ok 6, close(READ), $!; +ok 7, close(ERROR), $!; +$reaped_pid = waitpid $pid, 0; +ok 8, $reaped_pid == $pid, $reaped_pid; +ok 9, $? == 0, $?; + +# read and error together, both named +$pid = open3 'WRITE', 'READ', 'READ', $perl, '-e', <<'EOF'; + $| = 1; + print scalar <STDIN>; + print STDERR scalar <STDIN>; +EOF +print WRITE "ok 10\n"; +print scalar <READ>; +print WRITE "ok 11\n"; +print scalar <READ>; +waitpid $pid, 0; + +# read and error together, error empty +$pid = open3 'WRITE', 'READ', '', $perl, '-e', <<'EOF'; + $| = 1; + print scalar <STDIN>; + print STDERR scalar <STDIN>; +EOF +print WRITE "ok 12\n"; +print scalar <READ>; +print WRITE "ok 13\n"; +print scalar <READ>; +waitpid $pid, 0; + +# dup writer +ok 14, pipe PIPE_READ, PIPE_WRITE; +$pid = open3 '<&PIPE_READ', 'READ', '', + $perl, '-e', 'print scalar <STDIN>'; +close PIPE_READ; +print PIPE_WRITE "ok 15\n"; +close PIPE_WRITE; +print scalar <READ>; +waitpid $pid, 0; + +# dup reader +$pid = open3 'WRITE', '>&STDOUT', 'ERROR', + $perl, '-e', 'print scalar <STDIN>'; +print WRITE "ok 16\n"; +waitpid $pid, 0; + +# dup error: This particular case, duping stderr onto the existing +# stdout but putting stdout somewhere else, is a good case because it +# used not to work. +$pid = open3 'WRITE', 'READ', '>&STDOUT', + $perl, '-e', 'print STDERR scalar <STDIN>'; +print WRITE "ok 17\n"; +waitpid $pid, 0; + +# dup reader and error together, both named +$pid = open3 'WRITE', '>&STDOUT', '>&STDOUT', $perl, '-e', <<'EOF'; + $| = 1; + print STDOUT scalar <STDIN>; + print STDERR scalar <STDIN>; +EOF +print WRITE "ok 18\n"; +print WRITE "ok 19\n"; +waitpid $pid, 0; + +# dup reader and error together, error empty +$pid = open3 'WRITE', '>&STDOUT', '', $perl, '-e', <<'EOF'; + $| = 1; + print STDOUT scalar <STDIN>; + print STDERR scalar <STDIN>; +EOF +print WRITE "ok 20\n"; +print WRITE "ok 21\n"; +waitpid $pid, 0; diff --git a/gnu/usr.bin/perl/t/lib/ops.t b/gnu/usr.bin/perl/t/lib/ops.t new file mode 100644 index 00000000000..56b1bacabb0 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/ops.t @@ -0,0 +1,29 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { + print "1..0\n"; + exit 0; + } +} + +print "1..2\n"; + +eval <<'EOP'; + no ops 'fileno'; # equiv to "perl -M-ops=fileno" + $a = fileno STDIN; +EOP + +print $@ =~ /trapped/ ? "ok 1\n" : "not ok 1\n# $@\n"; + +eval <<'EOP'; + use ops ':default'; # equiv to "perl -M(as above) -Mops=:default" + eval 1; +EOP + +print $@ =~ /trapped/ ? "ok 2\n" : "not ok 2\n# $@\n"; + +1; diff --git a/gnu/usr.bin/perl/t/lib/parsewords.t b/gnu/usr.bin/perl/t/lib/parsewords.t new file mode 100644 index 00000000000..47a75881dc7 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/parsewords.t @@ -0,0 +1,28 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..4\n"; + +use Text::ParseWords; + +@words = shellwords(qq(foo "bar quiz" zoo)); +#print join(";", @words), "\n"; + +print "not " if $words[0] ne 'foo'; +print "ok 1\n"; + +print "not " if $words[1] ne 'bar quiz'; +print "ok 2\n"; + +print "not " if $words[2] ne 'zoo'; +print "ok 3\n"; + +# Test quotewords() with other parameters +@words = quotewords(":+", 1, qq(foo:::"bar:foo":zoo zoo:)); +#print join(";", @words), "\n"; +print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo); +print "ok 4\n"; diff --git a/gnu/usr.bin/perl/t/lib/safe1.t b/gnu/usr.bin/perl/t/lib/safe1.t new file mode 100644 index 00000000000..27993d95c9f --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/safe1.t @@ -0,0 +1,68 @@ +#!./perl -w +$|=1; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { + print "1..0\n"; + exit 0; + } +} + +# Tests Todo: +# 'main' as root + +package test; # test from somewhere other than main + +use vars qw($bar); + +use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex + opmask_add full_opset empty_opset opcodes opmask define_optag); + +use Safe 1.00; + +my $last_test; # initalised at end +print "1..$last_test\n"; + +my $t = 1; +my $cpt; +# create and destroy some automatic Safe compartments first +$cpt = new Safe or die; +$cpt = new Safe or die; +$cpt = new Safe or die; + +$cpt = new Safe "Root" or die; + +foreach(1..3) { + $foo = 42; + + $cpt->share(qw($foo)); + + print ${$cpt->varglob('foo')} == 42 ? "ok $t\n" : "not ok $t\n"; $t++; + + ${$cpt->varglob('foo')} = 9; + + print $foo == 9 ? "ok $t\n" : "not ok $t\n"; $t++; + + print $cpt->reval('$foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; + # check 'main' has been changed: + print $cpt->reval('$::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; + print $cpt->reval('$main::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; + # check we can't see our test package: + print $cpt->reval('$test::foo') ? "not ok $t\n" : "ok $t\n"; $t++; + print $cpt->reval('${"test::foo"}') ? "not ok $t\n" : "ok $t\n"; $t++; + + $cpt->erase; # erase the compartment, e.g., delete all variables + + print $cpt->reval('$foo') ? "not ok $t\n" : "ok $t\n"; $t++; + + # Note that we *must* use $cpt->varglob here because if we used + # $Root::foo etc we would still see the original values! + # This seems to be because the compiler has created an extra ref. + + print ${$cpt->varglob('foo')} ? "not ok $t\n" : "ok $t\n"; $t++; +} + +print "ok $last_test\n"; +BEGIN { $last_test = 28 } diff --git a/gnu/usr.bin/perl/t/lib/safe2.t b/gnu/usr.bin/perl/t/lib/safe2.t new file mode 100644 index 00000000000..40c50980580 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/safe2.t @@ -0,0 +1,144 @@ +#!./perl -w +$|=1; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { + print "1..0\n"; + exit 0; + } + # test 30 rather naughtily expects English error messages + $ENV{'LC_ALL'} = 'C'; +} + +# Tests Todo: +# 'main' as root + +use vars qw($bar); + +use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex + opmask_add full_opset empty_opset opcodes opmask define_optag); + +use Safe 1.00; + +my $last_test; # initalised at end +print "1..$last_test\n"; + +# Set up a package namespace of things to be visible to the unsafe code +$Root::foo = "visible"; +$bar = "invisible"; + +# Stop perl from moaning about identifies which are apparently only used once +$Root::foo .= ""; + +my $cpt; +# create and destroy a couple of automatic Safe compartments first +$cpt = new Safe or die; +$cpt = new Safe or die; + +$cpt = new Safe "Root"; + +$cpt->reval(q{ system("echo not ok 1"); }); +if ($@ =~ /^system trapped by operation mask/) { + print "ok 1\n"; +} else { + print "#$@" if $@; + print "not ok 1\n"; +} + +$cpt->reval(q{ + print $foo eq 'visible' ? "ok 2\n" : "not ok 2\n"; + print $main::foo eq 'visible' ? "ok 3\n" : "not ok 3\n"; + print defined($bar) ? "not ok 4\n" : "ok 4\n"; + print defined($::bar) ? "not ok 5\n" : "ok 5\n"; + print defined($main::bar) ? "not ok 6\n" : "ok 6\n"; +}); +print $@ ? "not ok 7\n#$@" : "ok 7\n"; + +$foo = "ok 8\n"; +%bar = (key => "ok 9\n"); +@baz = (); push(@baz, "o", "10"); $" = 'k '; +$glob = "ok 11\n"; +@glob = qw(not ok 16); + +sub sayok { print "ok @_\n" } + +$cpt->share(qw($foo %bar @baz *glob sayok $")); + +$cpt->reval(q{ + package other; + sub other_sayok { print "ok @_\n" } + package main; + print $foo ? $foo : "not ok 8\n"; + print $bar{key} ? $bar{key} : "not ok 9\n"; + (@baz) ? print "@baz\n" : print "not ok 10\n"; + print $glob; + other::other_sayok(12); + $foo =~ s/8/14/; + $bar{new} = "ok 15\n"; + @glob = qw(ok 16); +}); +print $@ ? "not ok 13\n#$@" : "ok 13\n"; +$" = ' '; +print $foo, $bar{new}, "@glob\n"; + +$Root::foo = "not ok 17"; +@{$cpt->varglob('bar')} = qw(not ok 18); +${$cpt->varglob('foo')} = "ok 17"; +@Root::bar = "ok"; +push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..." + +print "$Root::foo\n"; +print "@{$cpt->varglob('bar')}\n"; + +use strict; + +print 1 ? "ok 19\n" : "not ok 19\n"; +print 1 ? "ok 20\n" : "not ok 20\n"; + +my $m1 = $cpt->mask; +$cpt->trap("negate"); +my $m2 = $cpt->mask; +my @masked = opset_to_ops($m1); +print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n"; + +print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n"; + +print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n"; + +$cpt->mask(empty_opset); +my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"'); +print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n"; +my @t_array = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)'); +print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n"; + +my $t_scalar2 = $cpt->reval('die "foo bar"; 1'); +print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n"; +print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n"; + +# --- rdo + +my $t = 30; +$cpt->rdo('/non/existant/file.name'); +print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) || + $! =~ /A file or directory in the path name does not exist/ || + $! =~ /Device not configured/ ? + "ok $t\n" : "not ok $t # $!\n"); $t++; +print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++; + +#my $rdo_file = "tmp_rdo.tpl"; +#if (open X,">$rdo_file") { +# print X "999\n"; +# close X; +# $cpt->permit_only('const', 'leaveeval'); +# print $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++; +# unlink $rdo_file; +#} +#else { +# print "# test $t skipped, can't open file: $!\nok $t\n"; $t++; +#} + + +print "ok $last_test\n"; +BEGIN { $last_test = 32 } diff --git a/gnu/usr.bin/perl/t/lib/searchdict.t b/gnu/usr.bin/perl/t/lib/searchdict.t new file mode 100644 index 00000000000..447c425b276 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/searchdict.t @@ -0,0 +1,65 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..3\n"; + +$DICT = <<EOT; +Aarhus +Aaron +Ababa +aback +abaft +abandon +abandoned +abandoning +abandonment +abandons +abase +abased +abasement +abasements +abases +abash +abashed +abashes +abashing +abasing +abate +abated +abatement +abatements +abater +abates +abating +Abba +EOT + +use Search::Dict; + +open(DICT, "+>dict-$$") or die "Can't create dict-$$: $!"; +binmode DICT; # To make length expected one. +print DICT $DICT; + +my $pos = look *DICT, "abash"; +chomp($word = <DICT>); +print "not " if $pos < 0 || $word ne "abash"; +print "ok 1\n"; + +$pos = look *DICT, "foo"; +chomp($word = <DICT>); + +print "not " if $pos != length($DICT); # will search to end of file +print "ok 2\n"; + +$pos = look *DICT, "aarhus", 1, 1; +chomp($word = <DICT>); + +print "not " if $pos < 0 || $word ne "Aarhus"; +print "ok 3\n"; + +close DICT or die "cannot close"; +unlink "dict-$$"; diff --git a/gnu/usr.bin/perl/t/lib/selectsaver.t b/gnu/usr.bin/perl/t/lib/selectsaver.t new file mode 100644 index 00000000000..3b58d709ab3 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/selectsaver.t @@ -0,0 +1,28 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..3\n"; + +use SelectSaver; + +open(FOO, ">foo-$$") || die; + +print "ok 1\n"; +{ + my $saver = new SelectSaver(FOO); + print "foo\n"; +} + +# Get data written to file +open(FOO, "foo-$$") || die; +chomp($foo = <FOO>); +close FOO; +unlink "foo-$$"; + +print "ok 2\n" if $foo eq "foo"; + +print "ok 3\n"; diff --git a/gnu/usr.bin/perl/t/lib/symbol.t b/gnu/usr.bin/perl/t/lib/symbol.t new file mode 100644 index 00000000000..03449a3ed74 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/symbol.t @@ -0,0 +1,52 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..8\n"; + +BEGIN { $_ = 'foo'; } # because Symbol used to clobber $_ + +use Symbol; + +# First check $_ clobbering +print "not " if $_ ne 'foo'; +print "ok 1\n"; + + +# First test gensym() +$sym1 = gensym; +print "not " if ref($sym1) ne 'GLOB'; +print "ok 2\n"; + +$sym2 = gensym; + +print "not " if $sym1 eq $sym2; +print "ok 3\n"; + +ungensym $sym1; + +$sym1 = $sym2 = undef; + + +# Test qualify() +package foo; + +use Symbol qw(qualify); # must import into this package too + +qualify("x") eq "foo::x" or print "not "; +print "ok 4\n"; + +qualify("x", "FOO") eq "FOO::x" or print "not "; +print "ok 5\n"; + +qualify("BAR::x") eq "BAR::x" or print "not "; +print "ok 6\n"; + +qualify("STDOUT") eq "main::STDOUT" or print "not "; +print "ok 7\n"; + +qualify("ARGV", "FOO") eq "main::ARGV" or print "not "; +print "ok 8\n"; diff --git a/gnu/usr.bin/perl/t/lib/texttabs.t b/gnu/usr.bin/perl/t/lib/texttabs.t new file mode 100644 index 00000000000..ea9012c6526 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/texttabs.t @@ -0,0 +1,28 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..3\n"; + +use Text::Tabs; + +$tabstop = 4; + +$s1 = "foo\tbar\tb\tb"; +$s2 = expand $s1; +$s3 = unexpand $s2; + +print "not " unless $s2 eq "foo bar b b"; +print "ok 1\n"; + +print "not " unless $s3 eq "foo bar b\tb"; +print "ok 2\n"; + + +$tabstop = 8; + +print "not " unless unexpand(" foo") eq "\t\t foo"; +print "ok 3\n"; diff --git a/gnu/usr.bin/perl/t/lib/textwrap.t b/gnu/usr.bin/perl/t/lib/textwrap.t new file mode 100644 index 00000000000..9c8d1b49756 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/textwrap.t @@ -0,0 +1,40 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..5\n"; + +use Text::Wrap qw(wrap $columns); + +$columns = 30; + +$text = <<'EOT'; +Text::Wrap is a very simple paragraph formatter. It formats a +single paragraph at a time by breaking lines at word boundries. +Indentation is controlled for the first line ($initial_tab) and +all subsquent lines ($subsequent_tab) independently. $Text::Wrap::columns +should be set to the full width of your output device. +EOT + +$text =~ s/\n/ /g; +$_ = wrap "| ", "|", $text; + +#print "$_\n"; + +print "not " unless /^\| Text::Wrap is/; # start is ok +print "ok 1\n"; + +print "not " if /^.{31,}$/m; # no line longer than 30 chars +print "ok 2\n"; + +print "not " unless /^\|\w/m; # other lines start with +print "ok 3\n"; + +print "not " unless /\bsubsquent\b/; # look for a random word +print "ok 4\n"; + +print "not " unless /\bdevice\./; # look for last word +print "ok 5\n"; diff --git a/gnu/usr.bin/perl/t/lib/timelocal.t b/gnu/usr.bin/perl/t/lib/timelocal.t new file mode 100644 index 00000000000..adc1b1b0615 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/timelocal.t @@ -0,0 +1,87 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Time::Local; + +# Set up time values to test +@time = + ( + #year,mon,day,hour,min,sec + [1970, 1, 1, 00, 00, 00], + [1980, 2, 28, 12, 00, 00], + [1980, 2, 29, 12, 00, 00], + [1999, 12, 31, 23, 59, 59], + [2000, 1, 1, 00, 00, 00], + [2010, 10, 12, 14, 13, 12], + ); + +print "1..", @time * 2 + 5, "\n"; + +$count = 1; +for (@time) { + my($year, $mon, $mday, $hour, $min, $sec) = @$_; + $year -= 1900; + $mon --; + my $time = timelocal($sec,$min,$hour,$mday,$mon,$year); + # print scalar(localtime($time)), "\n"; + my($s,$m,$h,$D,$M,$Y) = localtime($time); + + if ($s == $sec && + $m == $min && + $h == $hour && + $D == $mday && + $M == $mon && + $Y == $year + ) { + print "ok $count\n"; + } else { + print "not ok $count\n"; + } + $count++; + + # Test gmtime function + $time = timegm($sec,$min,$hour,$mday,$mon,$year); + ($s,$m,$h,$D,$M,$Y) = gmtime($time); + + if ($s == $sec && + $m == $min && + $h == $hour && + $D == $mday && + $M == $mon && + $Y == $year + ) { + print "ok $count\n"; + } else { + print "not ok $count\n"; + } + $count++; +} + +#print "Testing that the differences between a few dates makes sence...\n"; + +timelocal(0,0,1,1,0,90) - timelocal(0,0,0,1,0,90) == 3600 + or print "not "; +print "ok ", $count++, "\n"; + +timelocal(1,2,3,1,0,100) - timelocal(1,2,3,31,11,99) == 24 * 3600 + or print "not "; +print "ok ", $count++, "\n"; + +# Diff beween Jan 1, 1970 and Mar 1, 1970 = (31 + 28 = 59 days) +timegm(0,0,0, 1, 2, 70) - timegm(0,0,0, 1, 0, 70) == 59 * 24 * 3600 + or print "not "; +print "ok ", $count++, "\n"; + + +#print "Testing timelocal.pl module too...\n"; +package test; +require 'timelocal.pl'; +timegm(0,0,0,1,0,70) == main::timegm(0,0,0,1,0,70) or print "not "; +print "ok ", $main::count++, "\n"; + +timelocal(1,2,3,4,5,78) == main::timelocal(1,2,3,4,5,78) or print "not "; +print "ok ", $main::count++, "\n"; diff --git a/gnu/usr.bin/perl/t/lib/trig.t b/gnu/usr.bin/perl/t/lib/trig.t new file mode 100644 index 00000000000..c2bc2a8b5bc --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/trig.t @@ -0,0 +1,57 @@ +#!./perl + +# +# Regression tests for the Math::Trig package +# +# The tests are quite modest as the Math::Complex tests exercise +# these quite vigorously. +# +# -- Jarkko Hietaniemi, April 1997 + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Math::Trig; + +use strict; + +use vars qw($x $y $z); + +my $eps = 1e-11; + +sub near ($$;$) { + abs($_[0] - $_[1]) < (defined $_[2] ? $_[2] : $eps); +} + +print "1..7\n"; + +$x = 0.9; +print 'not ' unless (near(tan($x), sin($x) / cos($x))); +print "ok 1\n"; + +print 'not ' unless (near(sinh(2), 3.62686040784702)); +print "ok 2\n"; + +print 'not ' unless (near(acsch(0.1), 2.99822295029797)); +print "ok 3\n"; + +$x = asin(2); +print 'not ' unless (ref $x eq 'Math::Complex'); +print "ok 4\n"; + +# avoid using Math::Complex here +$x =~ /^([^-]+)(-[^i]+)i$/; +($y, $z) = ($1, $2); +print 'not ' unless (near($y, 1.5707963267949) and + near($z, -1.31695789692482)); +print "ok 5\n"; + +print 'not ' unless (near(deg2rad(90), pi/2)); +print "ok 6\n"; + +print 'not ' unless (near(rad2deg(pi), 180)); +print "ok 7\n"; + +# eof diff --git a/gnu/usr.bin/perl/t/op/arith.t b/gnu/usr.bin/perl/t/op/arith.t new file mode 100644 index 00000000000..43af807b8b4 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/arith.t @@ -0,0 +1,12 @@ +#!./perl + +print "1..4\n"; + +sub try ($$) { + print +($_[1] ? "ok" : "not ok"), " $_[0]\n"; +} + +try 1, 13 % 4 == 1; +try 2, -13 % 4 == 3; +try 3, 13 % -4 == -3; +try 4, -13 % -4 == -1; diff --git a/gnu/usr.bin/perl/t/op/assignwarn.t b/gnu/usr.bin/perl/t/op/assignwarn.t new file mode 100644 index 00000000000..57e89c45e04 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/assignwarn.t @@ -0,0 +1,61 @@ +#!./perl + +# +# Verify which OP= operators warn if their targets are undefined. +# Based on redef.t, contributed by Graham Barr <Graham.Barr@tiuk.ti.com> +# -- Robin Barker <rmb@cise.npl.co.uk> +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict; + +$^W = 1; +my $warn = ""; +$SIG{q(__WARN__)} = sub { print $warn; $warn .= join("",@_) }; + +sub ok { print $_[1] ? "ok " : "not ok ", $_[0], "\n"; } + +sub uninitialized { $warn =~ s/Use of uninitialized value[^\n]+\n//s; } + +print "1..23\n"; + +{ my $x; $x ++; ok 1, ! uninitialized; } +{ my $x; $x --; ok 2, ! uninitialized; } +{ my $x; ++ $x; ok 3, ! uninitialized; } +{ my $x; -- $x; ok 4, ! uninitialized; } + +{ my $x; $x **= 1; ok 5, uninitialized; } + +{ my $x; $x += 1; ok 6, ! uninitialized; } +{ my $x; $x -= 1; ok 7, ! uninitialized; } + +{ my $x; $x .= 1; ok 8, ! uninitialized; } + +{ my $x; $x *= 1; ok 9, uninitialized; } +{ my $x; $x /= 1; ok 10, uninitialized; } +{ my $x; $x %= 1; ok 11, uninitialized; } + +{ my $x; $x x= 1; ok 12, uninitialized; } + +{ my $x; $x &= 1; ok 13, uninitialized; } +{ my $x; $x |= 1; ok 14, ! uninitialized; } +{ my $x; $x ^= 1; ok 15, ! uninitialized; } + +{ my $x; $x &&= 1; ok 16, ! uninitialized; } +{ my $x; $x ||= 1; ok 17, ! uninitialized; } + +{ my $x; $x <<= 1; ok 18, uninitialized; } +{ my $x; $x >>= 1; ok 19, uninitialized; } + +{ my $x; $x &= "x"; ok 20, uninitialized; } +{ my $x; $x |= "x"; ok 21, ! uninitialized; } +{ my $x; $x ^= "x"; ok 22, ! uninitialized; } + +ok 23, $warn eq ''; + +# If we got any errors that we were not expecting, then print them +print map "#$_\n", split /\n/, $warn if length $warn; diff --git a/gnu/usr.bin/perl/t/op/bop.t b/gnu/usr.bin/perl/t/op/bop.t new file mode 100644 index 00000000000..0c55029b931 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/bop.t @@ -0,0 +1,55 @@ +#!./perl + +# +# test the bit operators '&', '|', '^', '~', '<<', and '>>' +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..18\n"; + +# numerics +print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n"); +print ((0xdead | 0xbeef) == 0xfeef ? "ok 2\n" : "not ok 2\n"); +print ((0xdead ^ 0xbeef) == 0x6042 ? "ok 3\n" : "not ok 3\n"); +print ((~0xdead & 0xbeef) == 0x2042 ? "ok 4\n" : "not ok 4\n"); + +# shifts +print ((257 << 7) == 32896 ? "ok 5\n" : "not ok 5\n"); +print ((33023 >> 7) == 257 ? "ok 6\n" : "not ok 6\n"); + +# signed vs. unsigned +print ((~0 > 0 && do { use integer; ~0 } == -1) + ? "ok 7\n" : "not ok 7\n"); + +my $bits = 0; +for (my $i = ~0; $i; $i >>= 1) { ++$bits; } +my $cusp = 1 << ($bits - 1); + +print ((($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0) + ? "ok 8\n" : "not ok 8\n"); +print ((($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0) + ? "ok 9\n" : "not ok 9\n"); +print ((($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0) + ? "ok 10\n" : "not ok 10\n"); +print (((1 << ($bits - 1)) == $cusp && + do { use integer; 1 << ($bits - 1) } == -$cusp) + ? "ok 11\n" : "not ok 11\n"); +print ((($cusp >> 1) == ($cusp / 2) && + do { use integer; $cusp >> 1 } == -($cusp / 2)) + ? "ok 12\n" : "not ok 12\n"); + +# short strings +print (("AAAAA" & "zzzzz") eq '@@@@@' ? "ok 13\n" : "not ok 13\n"); +print (("AAAAA" | "zzzzz") eq '{{{{{' ? "ok 14\n" : "not ok 14\n"); +print (("AAAAA" ^ "zzzzz") eq ';;;;;' ? "ok 15\n" : "not ok 15\n"); + +# long strings +$foo = "A" x 150; +$bar = "z" x 75; +print (($foo & $bar) eq ('@'x75 ) ? "ok 16\n" : "not ok 16\n"); +print (($foo | $bar) eq ('{'x75 . 'A'x75) ? "ok 17\n" : "not ok 17\n"); +print (($foo ^ $bar) eq (';'x75 . 'A'x75) ? "ok 18\n" : "not ok 18\n"); diff --git a/gnu/usr.bin/perl/t/op/closure.t b/gnu/usr.bin/perl/t/op/closure.t new file mode 100644 index 00000000000..1220998b6b6 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/closure.t @@ -0,0 +1,454 @@ +#!./perl +# -*- Mode: Perl -*- +# closure.t: +# Original written by Ulrich Pfeifer on 2 Jan 1997. +# Greatly extended by Tom Phoenix <rootbeer@teleport.com> on 28 Jan 1997. +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Config; + +print "1..167\n"; + +my $test = 1; +sub test (&) { + print ((&{$_[0]})?"ok $test\n":"not ok $test\n"); + $test++; +} + +my $i = 1; +sub foo { $i = shift if @_; $i } + +# no closure +test { foo == 1 }; +foo(2); +test { foo == 2 }; + +# closure: lexical outside sub +my $foo = sub {$i = shift if @_; $i }; +my $bar = sub {$i = shift if @_; $i }; +test {&$foo() == 2 }; +&$foo(3); +test {&$foo() == 3 }; +# did the lexical change? +test { foo == 3 and $i == 3}; +# did the second closure notice? +test {&$bar() == 3 }; + +# closure: lexical inside sub +sub bar { + my $i = shift; + sub { $i = shift if @_; $i } +} + +$foo = bar(4); +$bar = bar(5); +test {&$foo() == 4 }; +&$foo(6); +test {&$foo() == 6 }; +test {&$bar() == 5 }; + +# nested closures +sub bizz { + my $i = 7; + if (@_) { + my $i = shift; + sub {$i = shift if @_; $i }; + } else { + my $i = $i; + sub {$i = shift if @_; $i }; + } +} +$foo = bizz(); +$bar = bizz(); +test {&$foo() == 7 }; +&$foo(8); +test {&$foo() == 8 }; +test {&$bar() == 7 }; + +$foo = bizz(9); +$bar = bizz(10); +test {&$foo(11)-1 == &$bar()}; + +my @foo; +for (qw(0 1 2 3 4)) { + my $i = $_; + $foo[$_] = sub {$i = shift if @_; $i }; +} + +test { + &{$foo[0]}() == 0 and + &{$foo[1]}() == 1 and + &{$foo[2]}() == 2 and + &{$foo[3]}() == 3 and + &{$foo[4]}() == 4 + }; + +for (0 .. 4) { + &{$foo[$_]}(4-$_); +} + +test { + &{$foo[0]}() == 4 and + &{$foo[1]}() == 3 and + &{$foo[2]}() == 2 and + &{$foo[3]}() == 1 and + &{$foo[4]}() == 0 + }; + +sub barf { + my @foo; + for (qw(0 1 2 3 4)) { + my $i = $_; + $foo[$_] = sub {$i = shift if @_; $i }; + } + @foo; +} + +@foo = barf(); +test { + &{$foo[0]}() == 0 and + &{$foo[1]}() == 1 and + &{$foo[2]}() == 2 and + &{$foo[3]}() == 3 and + &{$foo[4]}() == 4 + }; + +for (0 .. 4) { + &{$foo[$_]}(4-$_); +} + +test { + &{$foo[0]}() == 4 and + &{$foo[1]}() == 3 and + &{$foo[2]}() == 2 and + &{$foo[3]}() == 1 and + &{$foo[4]}() == 0 + }; + +# Additional tests by Tom Phoenix <rootbeer@teleport.com>. + +{ + use strict; + + use vars qw!$test!; + my($debugging, %expected, $inner_type, $where_declared, $within); + my($nc_attempt, $call_outer, $call_inner, $undef_outer); + my($code, $inner_sub_test, $expected, $line, $errors, $output); + my(@inners, $sub_test, $pid); + $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug'; + + # The expected values for these tests + %expected = ( + 'global_scalar' => 1001, + 'global_array' => 2101, + 'global_hash' => 3004, + 'fs_scalar' => 4001, + 'fs_array' => 5101, + 'fs_hash' => 6004, + 'sub_scalar' => 7001, + 'sub_array' => 8101, + 'sub_hash' => 9004, + 'foreach' => 10011, + ); + + # Our innermost sub is either named or anonymous + for $inner_type (qw!named anon!) { + # And it may be declared at filescope, within a named + # sub, or within an anon sub + for $where_declared (qw!filescope in_named in_anon!) { + # And that, in turn, may be within a foreach loop, + # a naked block, or another named sub + for $within (qw!foreach naked other_sub!) { + + # Here are a number of variables which show what's + # going on, in a way. + $nc_attempt = 0+ # Named closure attempted + ( ($inner_type eq 'named') || + ($within eq 'other_sub') ) ; + $call_inner = 0+ # Need to call &inner + ( ($inner_type eq 'anon') && + ($within eq 'other_sub') ) ; + $call_outer = 0+ # Need to call &outer or &$outer + ( ($inner_type eq 'anon') && + ($within ne 'other_sub') ) ; + $undef_outer = 0+ # $outer is created but unused + ( ($where_declared eq 'in_anon') && + (not $call_outer) ) ; + + $code = "# This is a test script built by t/op/closure.t\n\n"; + + $code .= <<"DEBUG_INFO" if $debugging; +# inner_type: $inner_type +# where_declared: $where_declared +# within: $within +# nc_attempt: $nc_attempt +# call_inner: $call_inner +# call_outer: $call_outer +# undef_outer: $undef_outer +DEBUG_INFO + + $code .= <<"END_MARK_ONE"; + +BEGIN { \$SIG{__WARN__} = sub { + my \$msg = \$_[0]; +END_MARK_ONE + + $code .= <<"END_MARK_TWO" if $nc_attempt; + return if index(\$msg, 'will not stay shared') != -1; + return if index(\$msg, 'may be unavailable') != -1; +END_MARK_TWO + + $code .= <<"END_MARK_THREE"; # Backwhack a lot! + print "not ok: got unexpected warning \$msg\\n"; +} } + +{ + my \$test = $test; + sub test (&) { + my \$result = &{\$_[0]}; + print "not " unless \$result; + print "ok \$test\\n"; + \$test++; + } +} + +# some of the variables which the closure will access +\$global_scalar = 1000; +\@global_array = (2000, 2100, 2200, 2300); +%global_hash = 3000..3009; + +my \$fs_scalar = 4000; +my \@fs_array = (5000, 5100, 5200, 5300); +my %fs_hash = 6000..6009; + +END_MARK_THREE + + if ($where_declared eq 'filescope') { + # Nothing here + } elsif ($where_declared eq 'in_named') { + $code .= <<'END'; +sub outer { + my $sub_scalar = 7000; + my @sub_array = (8000, 8100, 8200, 8300); + my %sub_hash = 9000..9009; +END + # } + } elsif ($where_declared eq 'in_anon') { + $code .= <<'END'; +$outer = sub { + my $sub_scalar = 7000; + my @sub_array = (8000, 8100, 8200, 8300); + my %sub_hash = 9000..9009; +END + # } + } else { + die "What was $where_declared?" + } + + if ($within eq 'foreach') { + $code .= " + my \$foreach = 12000; + my \@list = (10000, 10010); + foreach \$foreach (\@list) { + " # } + } elsif ($within eq 'naked') { + $code .= " { # naked block\n" # } + } elsif ($within eq 'other_sub') { + $code .= " sub inner_sub {\n" # } + } else { + die "What was $within?" + } + + $sub_test = $test; + @inners = ( qw!global_scalar global_array global_hash! , + qw!fs_scalar fs_array fs_hash! ); + push @inners, 'foreach' if $within eq 'foreach'; + if ($where_declared ne 'filescope') { + push @inners, qw!sub_scalar sub_array sub_hash!; + } + for $inner_sub_test (@inners) { + + if ($inner_type eq 'named') { + $code .= " sub named_$sub_test " + } elsif ($inner_type eq 'anon') { + $code .= " \$anon_$sub_test = sub " + } else { + die "What was $inner_type?" + } + + # Now to write the body of the test sub + if ($inner_sub_test eq 'global_scalar') { + $code .= '{ ++$global_scalar }' + } elsif ($inner_sub_test eq 'fs_scalar') { + $code .= '{ ++$fs_scalar }' + } elsif ($inner_sub_test eq 'sub_scalar') { + $code .= '{ ++$sub_scalar }' + } elsif ($inner_sub_test eq 'global_array') { + $code .= '{ ++$global_array[1] }' + } elsif ($inner_sub_test eq 'fs_array') { + $code .= '{ ++$fs_array[1] }' + } elsif ($inner_sub_test eq 'sub_array') { + $code .= '{ ++$sub_array[1] }' + } elsif ($inner_sub_test eq 'global_hash') { + $code .= '{ ++$global_hash{3002} }' + } elsif ($inner_sub_test eq 'fs_hash') { + $code .= '{ ++$fs_hash{6002} }' + } elsif ($inner_sub_test eq 'sub_hash') { + $code .= '{ ++$sub_hash{9002} }' + } elsif ($inner_sub_test eq 'foreach') { + $code .= '{ ++$foreach }' + } else { + die "What was $inner_sub_test?" + } + + # Close up + if ($inner_type eq 'anon') { + $code .= ';' + } + $code .= "\n"; + $sub_test++; # sub name sequence number + + } # End of foreach $inner_sub_test + + # Close up $within block # { + $code .= " }\n\n"; + + # Close up $where_declared block + if ($where_declared eq 'in_named') { # { + $code .= "}\n\n"; + } elsif ($where_declared eq 'in_anon') { # { + $code .= "};\n\n"; + } + + # We may need to do something with the sub we just made... + $code .= "undef \$outer;\n" if $undef_outer; + $code .= "&inner_sub;\n" if $call_inner; + if ($call_outer) { + if ($where_declared eq 'in_named') { + $code .= "&outer;\n\n"; + } elsif ($where_declared eq 'in_anon') { + $code .= "&\$outer;\n\n" + } + } + + # Now, we can actually prep to run the tests. + for $inner_sub_test (@inners) { + $expected = $expected{$inner_sub_test} or + die "expected $inner_sub_test missing"; + + # Named closures won't access the expected vars + if ( $nc_attempt and + substr($inner_sub_test, 0, 4) eq "sub_" ) { + $expected = 1; + } + + # If you make a sub within a foreach loop, + # what happens if it tries to access the + # foreach index variable? If it's a named + # sub, it gets the var from "outside" the loop, + # but if it's anon, it gets the value to which + # the index variable is aliased. + # + # Of course, if the value was set only + # within another sub which was never called, + # the value has not been set yet. + # + if ($inner_sub_test eq 'foreach') { + if ($inner_type eq 'named') { + if ($call_outer || ($where_declared eq 'filescope')) { + $expected = 12001 + } else { + $expected = 1 + } + } + } + + # Here's the test: + if ($inner_type eq 'anon') { + $code .= "test { &\$anon_$test == $expected };\n" + } else { + $code .= "test { &named_$test == $expected };\n" + } + $test++; + } + + if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32') { + # Fork off a new perl to run the tests. + # (This is so we can catch spurious warnings.) + $| = 1; print ""; $| = 0; # flush output before forking + pipe READ, WRITE or die "Can't make pipe: $!"; + pipe READ2, WRITE2 or die "Can't make second pipe: $!"; + die "Can't fork: $!" unless defined($pid = open PERL, "|-"); + unless ($pid) { + # Child process here. We're going to send errors back + # through the extra pipe. + close READ; + close READ2; + open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!"; + open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!"; + exec './perl', '-w', '-' + or die "Can't exec ./perl: $!"; + } else { + # Parent process here. + close WRITE; + close WRITE2; + print PERL $code; + close PERL; + { local $/; + $output = join '', <READ>; + $errors = join '', <READ2>; } + close READ; + close READ2; + } + } else { + # No fork(). Do it the hard way. + my $cmdfile = "tcmd$$"; $cmdfile++ while -e $cmdfile; + my $errfile = "terr$$"; $errfile++ while -e $errfile; + my @tmpfiles = ($cmdfile, $errfile); + open CMD, ">$cmdfile"; print CMD $code; close CMD; + my $cmd = (($^O eq 'VMS') ? "MCR $^X" + : ($^O eq 'MSWin32') ? '.\perl' + : './perl'); + $cmd .= " -w $cmdfile 2>$errfile"; + if ($^O eq 'VMS' or $^O eq 'MSWin32') { + # Use pipe instead of system so we don't inherit STD* from + # this process, and then foul our pipe back to parent by + # redirecting output in the child. + open PERL,"$cmd |" or die "Can't open pipe: $!\n"; + { local $/; $output = join '', <PERL> } + close PERL; + } else { + my $outfile = "tout$$"; $outfile++ while -e $outfile; + push @tmpfiles, $outfile; + system "$cmd >$outfile"; + { local $/; open IN, $outfile; $output = <IN>; close IN } + } + if ($?) { + printf "not ok: exited with error code %04X\n", $?; + $debugging or do { 1 while unlink @tmpfiles }; + exit; + } + { local $/; open IN, $errfile; $errors = <IN>; close IN } + 1 while unlink @tmpfiles; + } + print $output; + print STDERR $errors; + if ($debugging && ($errors || $? || ($output =~ /not ok/))) { + my $lnum = 0; + for $line (split '\n', $code) { + printf "%3d: %s\n", ++$lnum, $line; + } + } + printf "not ok: exited with error code %04X\n", $? if $?; + print "-" x 30, "\n" if $debugging; + + } # End of foreach $within + } # End of foreach $where_declared + } # End of foreach $inner_type + +} diff --git a/gnu/usr.bin/perl/t/op/cmp.t b/gnu/usr.bin/perl/t/op/cmp.t new file mode 100644 index 00000000000..4a7e68d4487 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/cmp.t @@ -0,0 +1,35 @@ +#!./perl + +@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1); + +$expect = ($#FOO+2) * ($#FOO+1); +print "1..$expect\n"; + +my $ok = 0; +for my $i (0..$#FOO) { + for my $j ($i..$#FOO) { + $ok++; + my $cmp = $FOO[$i] <=> $FOO[$j]; + if (!defined($cmp) || + $cmp == -1 && $FOO[$i] < $FOO[$j] || + $cmp == 0 && $FOO[$i] == $FOO[$j] || + $cmp == 1 && $FOO[$i] > $FOO[$j]) + { + print "ok $ok\n"; + } + else { + print "not ok $ok ($FOO[$i] <=> $FOO[$j]) gives: '$cmp'\n"; + } + $ok++; + $cmp = $FOO[$i] cmp $FOO[$j]; + if ($cmp == -1 && $FOO[$i] lt $FOO[$j] || + $cmp == 0 && $FOO[$i] eq $FOO[$j] || + $cmp == 1 && $FOO[$i] gt $FOO[$j]) + { + print "ok $ok\n"; + } + else { + print "not ok $ok ($FOO[$i] cmp $FOO[$j]) gives '$cmp'\n"; + } + } +} diff --git a/gnu/usr.bin/perl/t/op/gv.t b/gnu/usr.bin/perl/t/op/gv.t new file mode 100644 index 00000000000..ece32d936cd --- /dev/null +++ b/gnu/usr.bin/perl/t/op/gv.t @@ -0,0 +1,59 @@ +#!./perl + +# +# various typeglob tests +# + +print "1..11\n"; + +# type coersion on assignment +$foo = 'foo'; +$bar = *main::foo; +$bar = $foo; +print ref(\$bar) eq 'SCALAR' ? "ok 1\n" : "not ok 1\n"; +$foo = *main::bar; + +# type coersion (not) on misc ops + +if ($foo) { + print ref(\$foo) eq 'GLOB' ? "ok 2\n" : "not ok 2\n"; +} + +unless ($foo =~ /abcd/) { + print ref(\$foo) eq 'GLOB' ? "ok 3\n" : "not ok 3\n"; +} + +if ($foo eq '*main::bar') { + print ref(\$foo) eq 'GLOB' ? "ok 4\n" : "not ok 4\n"; +} + +# type coersion on substitutions that match +$a = *main::foo; +$b = $a; +$a =~ s/^X//; +print ref(\$a) eq 'GLOB' ? "ok 5\n" : "not ok 5\n"; +$a =~ s/^\*//; +print $a eq 'main::foo' ? "ok 6\n" : "not ok 6\n"; +print ref(\$b) eq 'GLOB' ? "ok 7\n" : "not ok 7\n"; + +# typeglobs as lvalues +substr($foo, 0, 1) = "XXX"; +print ref(\$foo) eq 'SCALAR' ? "ok 8\n" : "not ok 8\n"; +print $foo eq 'XXXmain::bar' ? "ok 9\n" : "not ok 9\n"; + +# returning glob values +sub foo { + local($bar) = *main::foo; + $foo = *main::bar; + return ($foo, $bar); +} + +($fuu, $baa) = foo(); +if (defined $fuu) { + print ref(\$fuu) eq 'GLOB' ? "ok 10\n" : "not ok 10\n"; +} + +if (defined $baa) { + print ref(\$baa) eq 'GLOB' ? "ok 11\n" : "not ok 11\n"; +} + diff --git a/gnu/usr.bin/perl/t/op/inc.t b/gnu/usr.bin/perl/t/op/inc.t new file mode 100644 index 00000000000..e5a2a921b3f --- /dev/null +++ b/gnu/usr.bin/perl/t/op/inc.t @@ -0,0 +1,52 @@ +#!./perl + + +# $RCSfile$ + +print "1..6\n"; + +# Verify that addition/subtraction properly upgrade to doubles. +# These tests are only significant on machines with 32 bit longs, +# and two's complement negation, but shouldn't fail anywhere. + +$a = 2147483647; +$c=$a++; +if ($a == 2147483648) + {print "ok 1\n"} +else + {print "not ok 1\n";} + +$a = 2147483647; +$c=++$a; +if ($a == 2147483648) + {print "ok 2\n"} +else + {print "not ok 2\n";} + +$a = 2147483647; +$a=$a+1; +if ($a == 2147483648) + {print "ok 3\n"} +else + {print "not ok 3\n";} + +$a = -2147483648; +$c=$a--; +if ($a == -2147483649) + {print "ok 4\n"} +else + {print "not ok 4\n";} + +$a = -2147483648; +$c=--$a; +if ($a == -2147483649) + {print "ok 5\n"} +else + {print "not ok 5\n";} + +$a = -2147483648; +$a=$a-1; +if ($a == -2147483649) + {print "ok 6\n"} +else + {print "not ok 6\n";} diff --git a/gnu/usr.bin/perl/t/op/method.t b/gnu/usr.bin/perl/t/op/method.t new file mode 100644 index 00000000000..d955705d1a1 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/method.t @@ -0,0 +1,122 @@ +#!./perl + +# +# test method calls and autoloading. +# + +print "1..24\n"; + +@A::ISA = 'B'; +@B::ISA = 'C'; + +sub C::d {"C::d"} +sub D::d {"D::d"} + +my $cnt = 0; +sub test { + print "# got `$_[0]', expected `$_[1]'\nnot " unless $_[0] eq $_[1]; + # print "not " unless shift eq shift; + print "ok ", ++$cnt, "\n" +} + +test( A->d, "C::d"); # Update hash table; + +*B::d = \&D::d; # Import now. +test (A->d, "D::d"); # Update hash table; + +{ + local @A::ISA = qw(C); # Update hash table with split() assignment + test (A->d, "C::d"); + $#A::ISA = -1; + test (eval { A->d } || "fail", "fail"); +} +test (A->d, "D::d"); + +{ + local *B::d; + eval 'sub B::d {"B::d1"}'; # Import now. + test (A->d, "B::d1"); # Update hash table; + undef &B::d; + test ((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1); +} + +test (A->d, "D::d"); # Back to previous state + +eval 'sub B::d {"B::d2"}'; # Import now. +test (A->d, "B::d2"); # Update hash table; + +# What follows is hardly guarantied to work, since the names in scripts +# are already linked to "pruned" globs. Say, `undef &B::d' if it were +# after `delete $B::{d}; sub B::d {}' would reach an old subroutine. + +undef &B::d; +delete $B::{d}; +test (A->d, "C::d"); # Update hash table; + +eval 'sub B::d {"B::d3"}'; # Import now. +test (A->d, "B::d3"); # Update hash table; + +delete $B::{d}; +*dummy::dummy = sub {}; # Mark as updated +test (A->d, "C::d"); + +eval 'sub B::d {"B::d4"}'; # Import now. +test (A->d, "B::d4"); # Update hash table; + +delete $B::{d}; # Should work without any help too +test (A->d, "C::d"); + +*A::x = *A::d; # See if cache incorrectly follows synonyms +A->d; +test (eval { A->x } || "nope", "nope"); + +eval <<'EOF'; +sub C::e; +BEGIN { *B::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg +sub Y::f; +$counter = 0; + +@X::ISA = 'Y'; +@Y::ISA = 'B'; + +sub B::AUTOLOAD { + my $c = ++$counter; + my $method = $B::AUTOLOAD; + my $msg = "B: In $method, $c"; + eval "sub $method { \$msg }"; + goto &$method; +} +sub C::AUTOLOAD { + my $c = ++$counter; + my $method = $C::AUTOLOAD; + my $msg = "C: In $method, $c"; + eval "sub $method { \$msg }"; + goto &$method; +} +EOF + +test(A->e(), "C: In C::e, 1"); # We get a correct autoload +test(A->e(), "C: In C::e, 1"); # Which sticks + +test(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top +test(A->ee(), "B: In A::ee, 2"); # Which sticks + +test(Y->f(), "B: In Y::f, 3"); # We vivify a correct method +test(Y->f(), "B: In Y::f, 3"); # Which sticks + +# This test is not intended to be reasonable. It is here just to let you +# know that you broke some old construction. Feel free to rewrite the test +# if your patch breaks it. + +*B::AUTOLOAD = sub { + my $c = ++$counter; + my $method = $AUTOLOAD; + *$AUTOLOAD = sub { "new B: In $method, $c" }; + goto &$AUTOLOAD; +}; + +test(A->eee(), "new B: In A::eee, 4"); # We get a correct $autoload +test(A->eee(), "new B: In A::eee, 4"); # Which sticks + +# this test added due to bug discovery +test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined"); diff --git a/gnu/usr.bin/perl/t/op/recurse.t b/gnu/usr.bin/perl/t/op/recurse.t new file mode 100644 index 00000000000..6594940a903 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/recurse.t @@ -0,0 +1,86 @@ +#!./perl + +# +# test recursive functions. +# + +print "1..23\n"; + +sub gcd ($$) { + return gcd($_[0] - $_[1], $_[1]) if ($_[0] > $_[1]); + return gcd($_[0], $_[1] - $_[0]) if ($_[0] < $_[1]); + $_[0]; +} + +sub factorial ($) { + $_[0] < 2 ? 1 : $_[0] * factorial($_[0] - 1); +} + +sub fibonacci ($) { + $_[0] < 2 ? 1 : fibonacci($_[0] - 2) + fibonacci($_[0] - 1); +} + +# Highly recursive, highly aggressive. +# Kids, don't try this at home. +# +# For example ackermann(4,1) will take quite a long time. +# It will simply eat away your memory. Trust me. + +sub ackermann ($$) { + return $_[1] + 1 if ($_[0] == 0); + return ackermann($_[0] - 1, 1) if ($_[1] == 0); + ackermann($_[0] - 1, ackermann($_[0], $_[1] - 1)); +} + +# Highly recursive, highly boring. + +sub takeuchi ($$$) { + $_[1] < $_[0] ? + takeuchi(takeuchi($_[0] - 1, $_[1], $_[2]), + takeuchi($_[1] - 1, $_[2], $_[0]), + takeuchi($_[2] - 1, $_[0], $_[1])) + : $_[2]; +} + +print 'not ' unless (($d = gcd(1147, 1271)) == 31); +print "ok 1\n"; +print "# gcd(1147, 1271) = $d\n"; + +print 'not ' unless (($d = gcd(1908, 2016)) == 36); +print "ok 2\n"; +print "# gcd(1908, 2016) = $d\n"; + +print 'not ' unless (($f = factorial(10)) == 3628800); +print "ok 3\n"; +print "# factorial(10) = $f\n"; + +print 'not ' unless (($f = factorial(factorial(3))) == 720); +print "ok 4\n"; +print "# factorial(factorial(3)) = $f\n"; + +print 'not ' unless (($f = fibonacci(10)) == 89); +print "ok 5\n"; +print "# fibonacci(10) = $f\n"; + +print 'not ' unless (($f = fibonacci(fibonacci(7))) == 17711); +print "ok 6\n"; +print "# fibonacci(fibonacci(7)) = $f\n"; + +$i = 7; + +@ack = qw(1 2 3 4 2 3 4 5 3 5 7 9 5 13 29 61); + +for $x (0..3) { + for $y (0..3) { + $a = ackermann($x, $y); + print 'not ' unless ($a == shift(@ack)); + print "ok ", $i++, "\n"; + print "# ackermann($x, $y) = $a\n"; + } +} + +($x, $y, $z) = (18, 12, 6); + +print 'not ' unless (($t = takeuchi($x, $y, $z)) == $z + 1); +print "ok ", $i++, "\n"; +print "# takeuchi($x, $y, $z) = $t\n"; diff --git a/gnu/usr.bin/perl/t/op/runlevel.t b/gnu/usr.bin/perl/t/op/runlevel.t new file mode 100644 index 00000000000..6693a829a88 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/runlevel.t @@ -0,0 +1,317 @@ +#!./perl + +## +## all of these tests are from Michael Schroeder +## <Michael.Schroeder@informatik.uni-erlangen.de> +## +## The more esoteric failure modes require Michael's +## stack-of-stacks patch (so we don't test them here, +## and they are commented out before the __END__). +## +## The remaining tests pass with a simpler fix +## intended for 5.004 +## +## Gurusamy Sarathy <gsar@umich.edu> 97-02-24 +## + +chdir 't' if -d 't'; +@INC = "../lib"; +$Is_VMS = $^O eq 'VMS'; +$Is_MSWin32 = $^O eq 'MSWin32'; +$ENV{PERL5LIB} = "../lib" unless $Is_VMS; + +$|=1; + +undef $/; +@prgs = split "\n########\n", <DATA>; +print "1..", scalar @prgs, "\n"; + +$tmpfile = "runltmp000"; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile; } } + +for (@prgs){ + my $switch; + if (s/^\s*(-\w+)//){ + $switch = $1; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + open TEST, ">$tmpfile"; + print TEST "$prog\n"; + close TEST; + my $results = $Is_VMS ? + `MCR $^X "-I[-.lib]" $switch $tmpfile` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + `sh -c './perl $switch $tmpfile' 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/runltmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg + $expected =~ s/\n+$//; + if ($results ne $expected) { + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; +} + +=head2 stay out of here (the real tests are after __END__) + +## +## these tests don't pass yet (need the full stack-of-stacks patch) +## GSAR 97-02-24 +## + +######## +# sort within sort +sub sortfn { + (split(/./, 'x'x10000))[0]; + my (@y) = ( 4, 6, 5); + @y = sort { $a <=> $b } @y; + print "sortfn ".join(', ', @y)."\n"; + return $_[0] <=> $_[1]; +} +@x = ( 3, 2, 1 ); +@x = sort { &sortfn($a, $b) } @x; +print "---- ".join(', ', @x)."\n"; +EXPECT +sortfn 4, 5, 6 +---- 1, 2, 3 +######## +# trapping eval within sort (doesn't work currently because +# die does a SWITCHSTACK()) +@a = (3, 2, 1); +@a = sort { eval('die("no way")') , $a <=> $b} @a; +print join(", ", @a)."\n"; +EXPECT +1, 2, 3 +######## +# this actually works fine, but results in a poor error message +@a = (1, 2, 3); +foo: +{ + @a = sort { last foo; } @a; +} +EXPECT +cannot reach destination block at - line 2. +######## +package TEST; + +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + next; + return "ZZZ"; +} +sub STORE { +} + +package main; + +tie $bar, TEST; +{ + print "- $bar\n"; +} +print "OK\n"; +EXPECT +cannot reach destination block at - line 8. +######## +package TEST; + +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + goto bbb; + return "ZZZ"; +} + +package main; + +tie $bar, TEST; +print "- $bar\n"; +exit; +bbb: +print "bbb\n"; +EXPECT +bbb +######## +# trapping eval within sort (doesn't work currently because +# die does a SWITCHSTACK()) +sub foo { + $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)'); +} +@a = (3, 2, 0, 1); +@a = sort foo @a; +print join(', ', @a)."\n"; +EXPECT +0, 1, 2, 3 +######## +package TEST; +sub TIESCALAR { + my $foo; + next; + return bless \$foo; +} +package main; +{ +tie $bar, TEST; +} +EXPECT +cannot reach destination block at - line 4. +######## +# large stack extension causes realloc, and segfault +package TEST; +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + return "fetch"; +} +sub STORE { +(split(/./, 'x'x10000))[0]; +} +package main; +tie $bar, TEST; +$bar = "x"; + +=cut + +## +## +## The real tests begin here +## +## + +__END__ +@a = (1, 2, 3); +{ + @a = sort { last ; } @a; +} +EXPECT +Can't "last" outside a block at - line 3. +######## +package TEST; + +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + eval 'die("test")'; + print "still in fetch\n"; + return ">$@<"; +} +package main; + +tie $bar, TEST; +print "- $bar\n"; +EXPECT +still in fetch +- >test at (eval 1) line 1. +< +######## +package TEST; + +sub TIESCALAR { + my $foo; + eval('die("foo\n")'); + print "after eval\n"; + return bless \$foo; +} +sub FETCH { + return "ZZZ"; +} + +package main; + +tie $bar, TEST; +print "- $bar\n"; +print "OK\n"; +EXPECT +after eval +- ZZZ +OK +######## +package TEST; + +sub TIEHANDLE { + my $foo; + return bless \$foo; +} +sub PRINT { +print STDERR "PRINT CALLED\n"; +(split(/./, 'x'x10000))[0]; +eval('die("test\n")'); +} + +package main; + +open FH, ">&STDOUT"; +tie *FH, TEST; +print FH "OK\n"; +print STDERR "DONE\n"; +EXPECT +PRINT CALLED +DONE +######## +sub warnhook { + print "WARNHOOK\n"; + eval('die("foooo\n")'); +} +$SIG{'__WARN__'} = 'warnhook'; +warn("dfsds\n"); +print "END\n"; +EXPECT +WARNHOOK +END +######## +package TEST; + +use overload + "\"\"" => \&str +; + +sub str { + eval('die("test\n")'); + return "STR"; +} + +package main; + +$bar = bless {}, TEST; +print "$bar\n"; +print "OK\n"; +EXPECT +STR +OK +######## +sub foo { + $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)'); +} +@a = (3, 2, 0, 1); +@a = sort foo @a; +print join(', ', @a)."\n"; +EXPECT +0, 1, 2, 3 +######## +sub foo { + goto bar if $a == 0 || $b == 0; + $a <=> $b; +} +@a = (3, 2, 0, 1); +@a = sort foo @a; +print join(', ', @a)."\n"; +exit; +bar: +print "bar reached\n"; +EXPECT +Can't "goto" outside a block at - line 2. diff --git a/gnu/usr.bin/perl/t/op/sysio.t b/gnu/usr.bin/perl/t/op/sysio.t new file mode 100644 index 00000000000..0af333db848 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/sysio.t @@ -0,0 +1,194 @@ +#!./perl + +print "1..36\n"; + +chdir('op') || die "sysio.t: cannot look for myself: $!"; + +open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!"; + +$reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32'); + +$x = 'abc'; + +# should not be able to do negative lengths +eval { sysread(I, $x, -1) }; +print 'not ' unless ($@ =~ /^Negative length /); +print "ok 1\n"; + +# $x should be intact +print 'not ' unless ($x eq 'abc'); +print "ok 2\n"; + +# should not be able to read before the buffer +eval { sysread(I, $x, 1, -4) }; +print 'not ' unless ($x eq 'abc'); +print "ok 3\n"; + +# $x should be intact +print 'not ' unless ($x eq 'abc'); +print "ok 4\n"; + +$a ='0123456789'; + +# default offset 0 +print 'not ' unless(sysread(I, $a, 3) == 3); +print "ok 5\n"; + +# $a should be as follows +print 'not ' unless ($a eq '#!.'); +print "ok 6\n"; + +# reading past the buffer should zero pad +print 'not ' unless(sysread(I, $a, 2, 5) == 2); +print "ok 7\n"; + +# the zero pad should be seen now +print 'not ' unless ($a eq "#!.\0\0/p"); +print "ok 8\n"; + +# try changing the last two characters of $a +print 'not ' unless(sysread(I, $a, 3, -2) == 3); +print "ok 9\n"; + +# the last two characters of $a should have changed (into three) +print 'not ' unless ($a eq "#!.\0\0erl"); +print "ok 10\n"; + +$outfile = 'sysio.out'; + +open(O, ">$outfile") || die "sysio.t: cannot write $outfile: $!"; + +select(O); $|=1; select(STDOUT); + +# cannot write negative lengths +eval { syswrite(O, $x, -1) }; +print 'not ' unless ($@ =~ /^Negative length /); +print "ok 11\n"; + +# $x still intact +print 'not ' unless ($x eq 'abc'); +print "ok 12\n"; + +# $outfile still intact +print 'not ' if (-s $outfile); +print "ok 13\n"; + +# should not be able to write from after the buffer +eval { syswrite(O, $x, 1, 3) }; +print 'not ' unless ($@ =~ /^Offset outside string /); +print "ok 14\n"; + +# $x still intact +print 'not ' unless ($x eq 'abc'); +print "ok 15\n"; + +# $outfile still intact +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' if (-s $outfile); +print "ok 16\n"; + +# should not be able to write from before the buffer + +eval { syswrite(O, $x, 1, -4) }; +print 'not ' unless ($@ =~ /^Offset outside string /); +print "ok 17\n"; + +# $x still intact +print 'not ' unless ($x eq 'abc'); +print "ok 18\n"; + +# $outfile still intact +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' if (-s $outfile); +print "ok 19\n"; + +# default offset 0 +print 'not ' unless (syswrite(O, $a, 2) == 2); +print "ok 20\n"; + +# $a still intact +print 'not ' unless ($a eq "#!.\0\0erl"); +print "ok 21\n"; + +# $outfile should have grown now +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' unless (-s $outfile == 2); +print "ok 22\n"; + +# with offset +print 'not ' unless (syswrite(O, $a, 2, 5) == 2); +print "ok 23\n"; + +# $a still intact +print 'not ' unless ($a eq "#!.\0\0erl"); +print "ok 24\n"; + +# $outfile should have grown now +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' unless (-s $outfile == 4); +print "ok 25\n"; + +# with negative offset and a bit too much length +print 'not ' unless (syswrite(O, $a, 5, -3) == 3); +print "ok 26\n"; + +# $a still intact +print 'not ' unless ($a eq "#!.\0\0erl"); +print "ok 27\n"; + +# $outfile should have grown now +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' unless (-s $outfile == 7); +print "ok 28\n"; + +close(O); + +open(I, $outfile) || die "sysio.t: cannot read $outfile: $!"; + +$b = 'xyz'; + +# reading too much only return as much as available +print 'not ' unless (sysread(I, $b, 100) == 7); +print "ok 29\n"; +# this we should have +print 'not ' unless ($b eq '#!ererl'); +print "ok 30\n"; + +# test sysseek + +print 'not ' unless sysseek(I, 2, 0) == 2; +print "ok 31\n"; +sysread(I, $b, 3); +print 'not ' unless $b eq 'ere'; +print "ok 32\n"; + +print 'not ' unless sysseek(I, -2, 1) == 3; +print "ok 33\n"; +sysread(I, $b, 4); +print 'not ' unless $b eq 'rerl'; +print "ok 34\n"; + +print 'not ' unless sysseek(I, 0, 0) eq '0 but true'; +print "ok 35\n"; +print 'not ' if defined sysseek(I, -1, 1); +print "ok 36\n"; + +close(I); + +unlink $outfile; + +chdir('..'); + +1; + +# eof diff --git a/gnu/usr.bin/perl/t/op/taint.t b/gnu/usr.bin/perl/t/op/taint.t new file mode 100644 index 00000000000..8437c43c453 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/taint.t @@ -0,0 +1,574 @@ +#!./perl -T +# +# Taint tests by Tom Phoenix <rootbeer@teleport.com>. +# +# I don't claim to know all about tainting. If anyone sees +# tests that I've missed here, please add them. But this is +# better than having no tests at all, right? +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +use strict; +use Config; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MSWin32 = $^O eq 'MSWin32'; +my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.' : + $Is_MSWin32 ? '.\perl' : './perl'; +my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/; + +if ($Is_VMS) { + my (%old, $x); + for $x ('DCL$PATH', @MoreEnv) { + ($old{$x}) = $ENV{$x} =~ /^(.*)$/ if exists $ENV{$x}; + } + eval <<EndOfCleanup; + END { + \$ENV{PATH} = ''; + warn "# Note: logical name 'PATH' may have been deleted\n"; + @ENV{keys %old} = values %old; + } +EndOfCleanup +} + +# Sources of taint: +# The empty tainted value, for tainting strings +my $TAINT = substr($^X, 0, 0); +# A tainted zero, useful for tainting numbers +my $TAINT0 = 0 + $TAINT; + +# This taints each argument passed. All must be lvalues. +# Side effect: It also stringifies them. :-( +sub taint_these (@) { + for (@_) { $_ .= $TAINT } +} + +# How to identify taint when you see it +sub any_tainted (@) { + not eval { join("",@_), kill 0; 1 }; +} +sub tainted ($) { + any_tainted @_; +} +sub all_tainted (@) { + for (@_) { return 0 unless tainted $_ } + 1; +} + +sub test ($$;$) { + my($serial, $boolean, $diag) = @_; + if ($boolean) { + print "ok $serial\n"; + } else { + print "not ok $serial\n"; + for (split m/^/m, $diag) { + print "# $_"; + } + print "\n" unless + $diag eq '' + or substr($diag, -1) eq "\n"; + } +} + +# We need an external program to call. +my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : "./echo$$"); +END { unlink $ECHO } +open PROG, "> $ECHO" or die "Can't create $ECHO: $!"; +print PROG 'print "@ARGV\n"', "\n"; +close PROG; +my $echo = "$Invoke_Perl $ECHO"; + +print "1..140\n"; + +# First, let's make sure that Perl is checking the dangerous +# environment variables. Maybe they aren't set yet, so we'll +# taint them ourselves. +{ + $ENV{'DCL$PATH'} = '' if $Is_VMS; + + $ENV{PATH} = ''; + delete @ENV{@MoreEnv}; + $ENV{TERM} = 'dumb'; + + test 1, eval { `$echo 1` } eq "1\n"; + + if ($Is_MSWin32 || $Is_VMS) { + print "# Environment tainting tests skipped\n"; + for (2..5) { print "ok $_\n" } + } + else { + my @vars = ('PATH', @MoreEnv); + while (my $v = $vars[0]) { + local $ENV{$v} = $TAINT; + last if eval { `$echo 1` }; + last unless $@ =~ /^Insecure \$ENV{$v}/; + shift @vars; + } + test 2, !@vars, "\$$vars[0]"; + + # tainted $TERM is unsafe only if it contains metachars + local $ENV{TERM}; + $ENV{TERM} = 'e=mc2'; + test 3, eval { `$echo 1` } eq "1\n"; + $ENV{TERM} = 'e=mc2' . $TAINT; + test 4, eval { `$echo 1` } eq ''; + test 5, $@ =~ /^Insecure \$ENV{TERM}/, $@; + } + + my $tmp; + if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32) { + print "# all directories are writeable\n"; + } + else { + $tmp = (grep { defined and -d and (stat _)[2] & 2 } + qw(/tmp /var/tmp /usr/tmp /sys$scratch), + @ENV{qw(TMP TEMP)})[0] + or print "# can't find world-writeable directory to test PATH\n"; + } + + if ($tmp) { + local $ENV{PATH} = $tmp; + test 6, eval { `$echo 1` } eq ''; + test 7, $@ =~ /^Insecure directory in \$ENV{PATH}/, $@; + } + else { + for (6..7) { print "ok $_\n" } + } + + if ($Is_VMS) { + $ENV{'DCL$PATH'} = $TAINT; + test 8, eval { `$echo 1` } eq ''; + test 9, $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@; + if ($tmp) { + $ENV{'DCL$PATH'} = $tmp; + test 10, eval { `$echo 1` } eq ''; + test 11, $@ =~ /^Insecure directory in \$ENV{DCL\$PATH}/, $@; + } + else { + print "# can't find world-writeable directory to test DCL\$PATH\n"; + for (10..11) { print "ok $_\n" } + } + $ENV{'DCL$PATH'} = ''; + } + else { + print "# This is not VMS\n"; + for (8..11) { print "ok $_\n"; } + } +} + +# Let's see that we can taint and untaint as needed. +{ + my $foo = $TAINT; + test 12, tainted $foo; + + # That was a sanity check. If it failed, stop the insanity! + die "Taint checks don't seem to be enabled" unless tainted $foo; + + $foo = "foo"; + test 13, not tainted $foo; + + taint_these($foo); + test 14, tainted $foo; + + my @list = 1..10; + test 15, not any_tainted @list; + taint_these @list[1,3,5,7,9]; + test 16, any_tainted @list; + test 17, all_tainted @list[1,3,5,7,9]; + test 18, not any_tainted @list[0,2,4,6,8]; + + ($foo) = $foo =~ /(.+)/; + test 19, not tainted $foo; + + $foo = $1 if ('bar' . $TAINT) =~ /(.+)/; + test 20, not tainted $foo; + test 21, $foo eq 'bar'; + + my $pi = 4 * atan2(1,1) + $TAINT0; + test 22, tainted $pi; + + ($pi) = $pi =~ /(\d+\.\d+)/; + test 23, not tainted $pi; + test 24, sprintf("%.5f", $pi) eq '3.14159'; +} + +# How about command-line arguments? The problem is that we don't +# always get some, so we'll run another process with some. +{ + my $arg = "./arg$$"; + open PROG, "> $arg" or die "Can't create $arg: $!"; + print PROG q{ + eval { join('', @ARGV), kill 0 }; + exit 0 if $@ =~ /^Insecure dependency/; + print "# Oops: \$@ was [$@]\n"; + exit 1; + }; + close PROG; + print `$Invoke_Perl "-T" $arg and some suspect arguments`; + test 25, !$?, "Exited with status $?"; + unlink $arg; +} + +# Reading from a file should be tainted +{ + my $file = './TEST'; + test 26, open(FILE, $file), "Couldn't open '$file': $!"; + + my $block; + sysread(FILE, $block, 100); + my $line = <FILE>; + close FILE; + test 27, tainted $block; + test 28, tainted $line; +} + +# Globs should be forbidden, except under VMS, +# which doesn't spawn an external program. +if ($Is_VMS) { + for (29..30) { print "ok $_\n"; } +} +else { + my @globs = eval { <*> }; + test 29, @globs == 0 && $@ =~ /^Insecure dependency/; + + @globs = eval { glob '*' }; + test 30, @globs == 0 && $@ =~ /^Insecure dependency/; +} + +# Output of commands should be tainted +{ + my $foo = `$echo abc`; + test 31, tainted $foo; +} + +# Certain system variables should be tainted +{ + test 32, all_tainted $^X, $0; +} + +# Results of matching should all be untainted +{ + my $foo = "abcdefghi" . $TAINT; + test 33, tainted $foo; + + $foo =~ /def/; + test 34, not any_tainted $`, $&, $'; + + $foo =~ /(...)(...)(...)/; + test 35, not any_tainted $1, $2, $3, $+; + + my @bar = $foo =~ /(...)(...)(...)/; + test 36, not any_tainted @bar; + + test 37, tainted $foo; # $foo should still be tainted! + test 38, $foo eq "abcdefghi"; +} + +# Operations which affect files can't use tainted data. +{ + test 39, eval { chmod 0, $TAINT } eq '', 'chmod'; + test 40, $@ =~ /^Insecure dependency/, $@; + + # There is no feature test in $Config{} for truncate, + # so we allow for the possibility that it's missing. + test 41, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate'; + test 42, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@; + + test 43, eval { rename '', $TAINT } eq '', 'rename'; + test 44, $@ =~ /^Insecure dependency/, $@; + + test 45, eval { unlink $TAINT } eq '', 'unlink'; + test 46, $@ =~ /^Insecure dependency/, $@; + + test 47, eval { utime $TAINT } eq '', 'utime'; + test 48, $@ =~ /^Insecure dependency/, $@; + + if ($Config{d_chown}) { + test 49, eval { chown -1, -1, $TAINT } eq '', 'chown'; + test 50, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# chown() is not available\n"; + for (49..50) { print "ok $_\n" } + } + + if ($Config{d_link}) { + test 51, eval { link $TAINT, '' } eq '', 'link'; + test 52, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# link() is not available\n"; + for (51..52) { print "ok $_\n" } + } + + if ($Config{d_symlink}) { + test 53, eval { symlink $TAINT, '' } eq '', 'symlink'; + test 54, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# symlink() is not available\n"; + for (53..54) { print "ok $_\n" } + } +} + +# Operations which affect directories can't use tainted data. +{ + test 55, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir'; + test 56, $@ =~ /^Insecure dependency/, $@; + + test 57, eval { rmdir $TAINT } eq '', 'rmdir'; + test 58, $@ =~ /^Insecure dependency/, $@; + + test 59, eval { chdir $TAINT } eq '', 'chdir'; + test 60, $@ =~ /^Insecure dependency/, $@; + + if ($Config{d_chroot}) { + test 61, eval { chroot $TAINT } eq '', 'chroot'; + test 62, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# chroot() is not available\n"; + for (61..62) { print "ok $_\n" } + } +} + +# Some operations using files can't use tainted data. +{ + my $foo = "imaginary library" . $TAINT; + test 63, eval { require $foo } eq '', 'require'; + test 64, $@ =~ /^Insecure dependency/, $@; + + my $filename = "./taintB$$"; # NB: $filename isn't tainted! + END { unlink $filename if defined $filename } + $foo = $filename . $TAINT; + unlink $filename; # in any case + + test 65, eval { open FOO, $foo } eq '', 'open for read'; + test 66, $@ eq '', $@; # NB: This should be allowed + test 67, $! == 2; # File not found + + test 68, eval { open FOO, "> $foo" } eq '', 'open for write'; + test 69, $@ =~ /^Insecure dependency/, $@; +} + +# Commands to the system can't use tainted data +{ + my $foo = $TAINT; + + if ($^O eq 'amigaos') { + print "# open(\"|\") is not available\n"; + for (70..73) { print "ok $_\n" } + } + else { + test 70, eval { open FOO, "| $foo" } eq '', 'popen to'; + test 71, $@ =~ /^Insecure dependency/, $@; + + test 72, eval { open FOO, "$foo |" } eq '', 'popen from'; + test 73, $@ =~ /^Insecure dependency/, $@; + } + + test 74, eval { exec $TAINT } eq '', 'exec'; + test 75, $@ =~ /^Insecure dependency/, $@; + + test 76, eval { system $TAINT } eq '', 'system'; + test 77, $@ =~ /^Insecure dependency/, $@; + + $foo = "*"; + taint_these $foo; + + test 78, eval { `$echo 1$foo` } eq '', 'backticks'; + test 79, $@ =~ /^Insecure dependency/, $@; + + if ($Is_VMS) { # wildcard expansion doesn't invoke shell, so is safe + test 80, join('', eval { glob $foo } ) ne '', 'globbing'; + test 81, $@ eq '', $@; + } + else { + for (80..81) { print "ok $_\n"; } + } +} + +# Operations which affect processes can't use tainted data. +{ + test 82, eval { kill 0, $TAINT } eq '', 'kill'; + test 83, $@ =~ /^Insecure dependency/, $@; + + if ($Config{d_setpgrp}) { + test 84, eval { setpgrp 0, $TAINT } eq '', 'setpgrp'; + test 85, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# setpgrp() is not available\n"; + for (84..85) { print "ok $_\n" } + } + + if ($Config{d_setprior}) { + test 86, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority'; + test 87, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# setpriority() is not available\n"; + for (86..87) { print "ok $_\n" } + } +} + +# Some miscellaneous operations can't use tainted data. +{ + if ($Config{d_syscall}) { + test 88, eval { syscall $TAINT } eq '', 'syscall'; + test 89, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# syscall() is not available\n"; + for (88..89) { print "ok $_\n" } + } + + { + my $foo = "x" x 979; + taint_these $foo; + local *FOO; + my $temp = "./taintC$$"; + END { unlink $temp } + test 90, open(FOO, "> $temp"), "Couldn't open $temp for write: $!"; + + test 91, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl'; + test 92, $@ =~ /^Insecure dependency/, $@; + + if ($Config{d_fcntl}) { + test 93, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl'; + test 94, $@ =~ /^Insecure dependency/, $@; + } + else { + print "# fcntl() is not available\n"; + for (93..94) { print "ok $_\n" } + } + + close FOO; + } +} + +# Some tests involving references +{ + my $foo = 'abc' . $TAINT; + my $fooref = \$foo; + test 95, not tainted $fooref; + test 96, tainted $$fooref; + test 97, tainted $foo; +} + +# Some tests involving assignment +{ + my $foo = $TAINT0; + my $bar = $foo; + test 98, all_tainted $foo, $bar; + test 99, tainted($foo = $bar); + test 100, tainted($bar = $bar); + test 101, tainted($bar += $bar); + test 102, tainted($bar -= $bar); + test 103, tainted($bar *= $bar); + test 104, tainted($bar++); + test 105, tainted($bar /= $bar); + test 106, tainted($bar += 0); + test 107, tainted($bar -= 2); + test 108, tainted($bar *= -1); + test 109, tainted($bar /= 1); + test 110, tainted($bar--); + test 111, $bar == 0; +} + +# Test assignment and return of lists +{ + my @foo = ("A", "tainted" . $TAINT, "B"); + test 112, not tainted $foo[0]; + test 113, tainted $foo[1]; + test 114, not tainted $foo[2]; + my @bar = @foo; + test 115, not tainted $bar[0]; + test 116, tainted $bar[1]; + test 117, not tainted $bar[2]; + my @baz = eval { "A", "tainted" . $TAINT, "B" }; + test 118, not tainted $baz[0]; + test 119, tainted $baz[1]; + test 120, not tainted $baz[2]; + my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ]; + test 121, not tainted $plugh[0]; + test 122, tainted $plugh[1]; + test 123, not tainted $plugh[2]; + my $nautilus = sub { "A", "tainted" . $TAINT, "B" }; + test 124, not tainted ((&$nautilus)[0]); + test 125, tainted ((&$nautilus)[1]); + test 126, not tainted ((&$nautilus)[2]); + my @xyzzy = &$nautilus; + test 127, not tainted $xyzzy[0]; + test 128, tainted $xyzzy[1]; + test 129, not tainted $xyzzy[2]; + my $red_october = sub { return "A", "tainted" . $TAINT, "B" }; + test 130, not tainted ((&$red_october)[0]); + test 131, tainted ((&$red_october)[1]); + test 132, not tainted ((&$red_october)[2]); + my @corge = &$red_october; + test 133, not tainted $corge[0]; + test 134, tainted $corge[1]; + test 135, not tainted $corge[2]; +} + +# Test for system/library calls returning string data of dubious origin. +{ + # No reliable %Config check for getpw* + if (eval { setpwent(); getpwent(); 1 }) { + setpwent(); + my @getpwent = getpwent(); + die "getpwent: $!\n" unless (@getpwent); + test 136,( not tainted $getpwent[0] + and not tainted $getpwent[1] + and not tainted $getpwent[2] + and not tainted $getpwent[3] + and not tainted $getpwent[4] + and not tainted $getpwent[5] + and tainted $getpwent[6] # gecos + and not tainted $getpwent[7] + and not tainted $getpwent[8]); + endpwent(); + } else { + print "# getpwent() is not available\n"; + print "ok 136\n"; + } + + if ($Config{d_readdir}) { # pretty hard to imagine not + local(*D); + opendir(D, "op") or die "opendir: $!\n"; + my $readdir = readdir(D); + test 137, tainted $readdir; + closedir(OP); + } else { + print "# readdir() is not available\n"; + print "ok 137\n"; + } + + if ($Config{d_readlink} && $Config{d_symlink}) { + my $symlink = "sl$$"; + unlink($symlink); + symlink("/something/naughty", $symlink) or die "symlink: $!\n"; + my $readlink = readlink($symlink); + test 138, tainted $readlink; + unlink($symlink); + } else { + print "# readlink() or symlink() is not available\n"; + print "ok 138\n"; + } +} + +# test bitwise ops (regression bug) +{ + my $why = "y"; + my $j = "x" | $why; + test 139, not tainted $j; + $why = $TAINT."y"; + $j = "x" | $why; + test 140, tainted $j; +} + diff --git a/gnu/usr.bin/perl/t/op/tie.t b/gnu/usr.bin/perl/t/op/tie.t new file mode 100644 index 00000000000..77e74db4e2c --- /dev/null +++ b/gnu/usr.bin/perl/t/op/tie.t @@ -0,0 +1,155 @@ +#!./perl + +# This test harness will (eventually) test the "tie" functionality +# without the need for a *DBM* implementation. + +# Currently it only tests the untie warning + +chdir 't' if -d 't'; +@INC = "../lib"; +$ENV{PERL5LIB} = "../lib"; + +$|=1; + +# catch warnings into fatal errors +$SIG{__WARN__} = sub { die "WARNING: @_" } ; + +undef $/; +@prgs = split "\n########\n", <DATA>; +print "1..", scalar @prgs, "\n"; + +for (@prgs){ + my($prog,$expected) = split(/\nEXPECT\n/, $_); + eval "$prog" ; + $status = $?; + $results = $@ ; + $results =~ s/\n+$//; + $expected =~ s/\n+$//; + if ( $status or $results and $results !~ /^WARNING: $expected/){ + print STDERR "STATUS: $status\n"; + print STDERR "PROG: $prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; +} + +__END__ + +# standard behaviour, without any extra references +use Tie::Hash ; +tie %h, Tie::StdHash; +untie %h; +EXPECT +######## + +# standard behaviour, with 1 extra reference +use Tie::Hash ; +$a = tie %h, Tie::StdHash; +untie %h; +EXPECT +######## + +# standard behaviour, with 1 extra reference via tied +use Tie::Hash ; +tie %h, Tie::StdHash; +$a = tied %h; +untie %h; +EXPECT +######## + +# standard behaviour, with 1 extra reference which is destroyed +use Tie::Hash ; +$a = tie %h, Tie::StdHash; +$a = 0 ; +untie %h; +EXPECT +######## + +# standard behaviour, with 1 extra reference via tied which is destroyed +use Tie::Hash ; +tie %h, Tie::StdHash; +$a = tied %h; +$a = 0 ; +untie %h; +EXPECT +######## + +# strict behaviour, without any extra references +#use warning 'untie'; +local $^W = 1 ; +use Tie::Hash ; +tie %h, Tie::StdHash; +untie %h; +EXPECT +######## + +# strict behaviour, with 1 extra references generating an error +#use warning 'untie'; +local $^W = 1 ; +use Tie::Hash ; +$a = tie %h, Tie::StdHash; +untie %h; +EXPECT +untie attempted while 1 inner references still exist +######## + +# strict behaviour, with 1 extra references via tied generating an error +#use warning 'untie'; +local $^W = 1 ; +use Tie::Hash ; +tie %h, Tie::StdHash; +$a = tied %h; +untie %h; +EXPECT +untie attempted while 1 inner references still exist +######## + +# strict behaviour, with 1 extra references which are destroyed +#use warning 'untie'; +local $^W = 1 ; +use Tie::Hash ; +$a = tie %h, Tie::StdHash; +$a = 0 ; +untie %h; +EXPECT +######## + +# strict behaviour, with extra 1 references via tied which are destroyed +#use warning 'untie'; +local $^W = 1 ; +use Tie::Hash ; +tie %h, Tie::StdHash; +$a = tied %h; +$a = 0 ; +untie %h; +EXPECT +######## + +# strict error behaviour, with 2 extra references +#use warning 'untie'; +local $^W = 1 ; +use Tie::Hash ; +$a = tie %h, Tie::StdHash; +$b = tied %h ; +untie %h; +EXPECT +untie attempted while 2 inner references still exist +######## + +# strict behaviour, check scope of strictness. +#no warning 'untie'; +local $^W = 0 ; +use Tie::Hash ; +$A = tie %H, Tie::StdHash; +$C = $B = tied %H ; +{ + #use warning 'untie'; + local $^W = 1 ; + use Tie::Hash ; + tie %h, Tie::StdHash; + untie %h; +} +untie %H; +EXPECT diff --git a/gnu/usr.bin/perl/t/op/universal.t b/gnu/usr.bin/perl/t/op/universal.t new file mode 100644 index 00000000000..bd6c73afe99 --- /dev/null +++ b/gnu/usr.bin/perl/t/op/universal.t @@ -0,0 +1,96 @@ +#!./perl +# +# check UNIVERSAL +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +print "1..72\n"; + +$a = {}; +bless $a, "Bob"; +print "not " unless $a->isa("Bob"); +print "ok 1\n"; + +package Human; +sub eat {} + +package Female; +@ISA=qw(Human); + +package Alice; +@ISA=qw(Bob Female); +sub drink {} +sub new { bless {} } + +$Alice::VERSION = 2.718; + +package main; + +my $i = 2; +sub test { print "not " unless shift; print "ok $i\n"; $i++; } + +$a = new Alice; + +test $a->isa("Alice"); + +test $a->isa("Bob"); + +test $a->isa("Female"); + +test $a->isa("Human"); + +test ! $a->isa("Male"); + +test $a->can("drink"); + +test $a->can("eat"); + +test ! $a->can("sleep"); + +my $b = 'abc'; +my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE); +my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} ); +for ($p=0; $p < @refs; $p++) { + for ($q=0; $q < @vals; $q++) { + test UNIVERSAL::isa($vals[$p], $refs[$q]) eq ($p==$q or $p+$q==1); + }; +}; + +test ! UNIVERSAL::can(23, "can"); + +test $a->can("VERSION"); + +test $a->can("can"); +test ! $a->can("export_tags"); # a method in Exporter + +test (eval { $a->VERSION }) == 2.718; + +test ! (eval { $a->VERSION(2.719) }) && + $@ =~ /^Alice version 2.719 required--this is only version 2.718 at /; + +test (eval { $a->VERSION(2.718) }) && ! $@; + +my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; +test $subs eq "VERSION can isa"; + +test $a->isa("UNIVERSAL"); + +# now use UNIVERSAL.pm and see what changes +eval "use UNIVERSAL"; + +test $a->isa("UNIVERSAL"); + +my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; +# XXX import being here is really a bug +test $sub2 eq "VERSION can import isa"; + +eval 'sub UNIVERSAL::sleep {}'; +test $a->can("sleep"); + +test ! UNIVERSAL::can($b, "can"); + +test ! $a->can("export_tags"); # a method in Exporter diff --git a/gnu/usr.bin/perl/t/pragma/constant.t b/gnu/usr.bin/perl/t/pragma/constant.t new file mode 100644 index 00000000000..0095f3b627b --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/constant.t @@ -0,0 +1,141 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +BEGIN {$^W |= 1} # Insist upon warnings +use vars qw{ @warnings }; +BEGIN { # ...and save 'em for later + $SIG{'__WARN__'} = sub { push @warnings, @_ } +} +END { print @warnings } + +######################### We start with some black magic to print on failure. + +BEGIN { $| = 1; print "1..39\n"; } +END {print "not ok 1\n" unless $loaded;} +use constant; +$loaded = 1; +#print "# Version: $constant::VERSION\n"; +print "ok 1\n"; + +######################### End of black magic. + +use strict; + +sub test ($$;$) { + my($num, $bool, $diag) = @_; + if ($bool) { + print "ok $num\n"; + return; + } + print "not ok $num\n"; + return unless defined $diag; + $diag =~ s/\Z\n?/\n/; # unchomp + print map "# $num : $_", split m/^/m, $diag; +} + +use constant PI => 4 * atan2 1, 1; + +test 2, substr(PI, 0, 7) eq '3.14159'; +test 3, defined PI; + +sub deg2rad { PI * $_[0] / 180 } + +my $ninety = deg2rad 90; + +test 4, $ninety > 1.5707; +test 5, $ninety < 1.5708; + +use constant UNDEF1 => undef; # the right way +use constant UNDEF2 => ; # the weird way +use constant 'UNDEF3' ; # the 'short' way +use constant EMPTY => ( ) ; # the right way for lists + +test 6, not defined UNDEF1; +test 7, not defined UNDEF2; +test 8, not defined UNDEF3; +my @undef = UNDEF1; +test 9, @undef == 1; +test 10, not defined $undef[0]; +@undef = UNDEF2; +test 11, @undef == 0; +@undef = UNDEF3; +test 12, @undef == 0; +@undef = EMPTY; +test 13, @undef == 0; + +use constant COUNTDOWN => scalar reverse 1, 2, 3, 4, 5; +use constant COUNTLIST => reverse 1, 2, 3, 4, 5; +use constant COUNTLAST => (COUNTLIST)[-1]; + +test 14, COUNTDOWN eq '54321'; +my @cl = COUNTLIST; +test 15, @cl == 5; +test 16, COUNTDOWN eq join '', @cl; +test 17, COUNTLAST == 1; +test 18, (COUNTLIST)[1] == 4; + +use constant ABC => 'ABC'; +test 19, "abc${\( ABC )}abc" eq "abcABCabc"; + +use constant DEF => 'D', "\x45", chr 70; +test 20, "d e f @{[ DEF ]} d e f" eq "d e f D E F d e f"; + +use constant SINGLE => "'"; +use constant DOUBLE => '"'; +use constant BACK => '\\'; +my $tt = BACK . SINGLE . DOUBLE ; +test 21, $tt eq q(\\'"); + +use constant MESS => q('"'\\"'"\\); +test 22, MESS eq q('"'\\"'"\\); +test 23, length(MESS) == 8; + +use constant TRAILING => '12 cats'; +{ + my $save_warn; + local $^W; + BEGIN { $save_warn = $^W; $^W = 0 } + test 24, TRAILING == 12; + BEGIN { $^W = $save_warn } +} +test 25, TRAILING eq '12 cats'; + +use constant LEADING => " \t1234"; +test 26, LEADING == 1234; +test 27, LEADING eq " \t1234"; + +use constant ZERO1 => 0; +use constant ZERO2 => 0.0; +use constant ZERO3 => '0.0'; +test 28, ZERO1 eq '0'; +test 29, ZERO2 eq '0'; +test 30, ZERO3 eq '0.0'; + +{ + package Other; + use constant PI => 3.141; +} + +test 31, (PI > 3.1415 and PI < 3.1416); +test 32, Other::PI == 3.141; + +use constant E2BIG => $! = 7; +test 33, E2BIG == 7; +# This is something like "Arg list too long", but the actual message +# text may vary, so we can't test much better than this. +test 34, length(E2BIG) > 6; +test 35, index(E2BIG, " ") > 0; + +test 36, @warnings == 0, join "\n", "unexpected warning", @warnings; +@warnings = (); # just in case +undef &PI; +test 37, @warnings && + ($warnings[0] =~ /Constant sub.* undefined/), + shift @warnings; + +test 38, @warnings == 0, "unexpected warning"; +test 39, $^W & 1, "Who disabled the warnings?"; diff --git a/gnu/usr.bin/perl/t/pragma/locale.t b/gnu/usr.bin/perl/t/pragma/locale.t new file mode 100644 index 00000000000..8e296db8a7c --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/locale.t @@ -0,0 +1,475 @@ +#!./perl -wT + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) { + print "1..0\n"; + exit; + } +} + +use strict; + +my $have_setlocale = 0; +eval { + require POSIX; + import POSIX ':locale_h'; + $have_setlocale++; +}; + +print "1..", ($have_setlocale ? 102 : 98), "\n"; + +use vars qw($a + $English $German $French $Spanish + @C @English @German @French @Spanish + $Locale @Locale %iLocale %UPPER %lower @Neoalpha); + +$a = 'abc %'; + +sub ok { + my ($n, $result) = @_; + + print 'not ' unless ($result); + print "ok $n\n"; +} + +# First we'll do a lot of taint checking for locales. +# This is the easiest to test, actually, as any locale, +# even the default locale will taint under 'use locale'. + +sub is_tainted { # hello, camel two. + local $^W; # no warnings 'undef' + my $dummy; + not eval { $dummy = join("", @_), kill 0; 1 } +} + +sub check_taint ($$) { + ok $_[0], is_tainted($_[1]); +} + +sub check_taint_not ($$) { + ok $_[0], not is_tainted($_[1]); +} + +use locale; # engage locale and therefore locale taint. + +check_taint_not 1, $a; + +check_taint 2, uc($a); +check_taint 3, "\U$a"; +check_taint 4, ucfirst($a); +check_taint 5, "\u$a"; +check_taint 6, lc($a); +check_taint 7, "\L$a"; +check_taint 8, lcfirst($a); +check_taint 9, "\l$a"; + +check_taint 10, sprintf('%e', 123.456); +check_taint 11, sprintf('%f', 123.456); +check_taint 12, sprintf('%g', 123.456); +check_taint_not 13, sprintf('%d', 123.456); +check_taint_not 14, sprintf('%x', 123.456); + +$_ = $a; # untaint $_ + +$_ = uc($a); # taint $_ + +check_taint 15, $_; + +/(\w)/; # taint $&, $`, $', $+, $1. +check_taint 16, $&; +check_taint 17, $`; +check_taint 18, $'; +check_taint 19, $+; +check_taint 20, $1; +check_taint_not 21, $2; + +/(.)/; # untaint $&, $`, $', $+, $1. +check_taint_not 22, $&; +check_taint_not 23, $`; +check_taint_not 24, $'; +check_taint_not 25, $+; +check_taint_not 26, $1; +check_taint_not 27, $2; + +/(\W)/; # taint $&, $`, $', $+, $1. +check_taint 28, $&; +check_taint 29, $`; +check_taint 30, $'; +check_taint 31, $+; +check_taint 32, $1; +check_taint_not 33, $2; + +/(\s)/; # taint $&, $`, $', $+, $1. +check_taint 34, $&; +check_taint 35, $`; +check_taint 36, $'; +check_taint 37, $+; +check_taint 38, $1; +check_taint_not 39, $2; + +/(\S)/; # taint $&, $`, $', $+, $1. +check_taint 40, $&; +check_taint 41, $`; +check_taint 42, $'; +check_taint 43, $+; +check_taint 44, $1; +check_taint_not 45, $2; + +$_ = $a; # untaint $_ + +check_taint_not 46, $_; + +/(b)/; # this must not taint +check_taint_not 47, $&; +check_taint_not 48, $`; +check_taint_not 49, $'; +check_taint_not 50, $+; +check_taint_not 51, $1; +check_taint_not 52, $2; + +$_ = $a; # untaint $_ + +check_taint_not 53, $_; + +$b = uc($a); # taint $b +s/(.+)/$b/; # this must taint only the $_ + +check_taint 54, $_; +check_taint_not 55, $&; +check_taint_not 56, $`; +check_taint_not 57, $'; +check_taint_not 58, $+; +check_taint_not 59, $1; +check_taint_not 60, $2; + +$_ = $a; # untaint $_ + +s/(.+)/b/; # this must not taint +check_taint_not 61, $_; +check_taint_not 62, $&; +check_taint_not 63, $`; +check_taint_not 64, $'; +check_taint_not 65, $+; +check_taint_not 66, $1; +check_taint_not 67, $2; + +$b = $a; # untaint $b + +($b = $a) =~ s/\w/$&/; +check_taint 68, $b; # $b should be tainted. +check_taint_not 69, $a; # $a should be not. + +$_ = $a; # untaint $_ + +s/(\w)/\l$1/; # this must taint +check_taint 70, $_; +check_taint 71, $&; +check_taint 72, $`; +check_taint 73, $'; +check_taint 74, $+; +check_taint 75, $1; +check_taint_not 76, $2; + +$_ = $a; # untaint $_ + +s/(\w)/\L$1/; # this must taint +check_taint 77, $_; +check_taint 78, $&; +check_taint 79, $`; +check_taint 80, $'; +check_taint 81, $+; +check_taint 82, $1; +check_taint_not 83, $2; + +$_ = $a; # untaint $_ + +s/(\w)/\u$1/; # this must taint +check_taint 84, $_; +check_taint 85, $&; +check_taint 86, $`; +check_taint 87, $'; +check_taint 88, $+; +check_taint 89, $1; +check_taint_not 90, $2; + +$_ = $a; # untaint $_ + +s/(\w)/\U$1/; # this must taint +check_taint 91, $_; +check_taint 92, $&; +check_taint 93, $`; +check_taint 94, $'; +check_taint 95, $+; +check_taint 96, $1; +check_taint_not 97, $2; + +# After all this tainting $a should be cool. + +check_taint_not 98, $a; + +# I think we've seen quite enough of taint. +# Let us do some *real* locale work now, +# unless setlocale() is missing (i.e. minitest). + +exit unless $have_setlocale; + +sub getalnum { + sort grep /\w/, map { chr } 0..255 +} + +sub locatelocale ($$@) { + my ($lcall, $alnum, @try) = @_; + + undef $$lcall; + + for (@try) { + local $^W = 0; # suppress "Subroutine LC_ALL redefined" + if (setlocale(&LC_ALL, $_)) { + $$lcall = $_; + @$alnum = &getalnum; + last; + } + } + + @$alnum = () unless (defined $$lcall); +} + +# Find some default locale + +locatelocale(\$Locale, \@Locale, qw(C POSIX)); + +# Find some English locale + +locatelocale(\$English, \@English, + qw(en_US.ISO8859-1 en_GB.ISO8859-1 + en en_US en_UK en_IE en_CA en_AU en_NZ + english english.iso88591 + american american.iso88591 + british british.iso88591 + )); + +# Find some German locale + +locatelocale(\$German, \@German, + qw(de_DE.ISO8859-1 de_AT.ISO8859-1 de_CH.ISO8859-1 + de de_DE de_AT de_CH + german german.iso88591)); + +# Find some French locale + +locatelocale(\$French, \@French, + qw(fr_FR.ISO8859-1 fr_BE.ISO8859-1 fr_CA.ISO8859-1 fr_CH.ISO8859-1 + fr fr_FR fr_BE fr_CA fr_CH + french french.iso88591)); + +# Find some Spanish locale + +locatelocale(\$Spanish, \@Spanish, + qw(es_AR.ISO8859-1 es_BO.ISO8859-1 es_CL.ISO8859-1 + es_CO.ISO8859-1 es_CR.ISO8859-1 es_EC.ISO8859-1 + es_ES.ISO8859-1 es_GT.ISO8859-1 es_MX.ISO8859-1 + es_NI.ISO8859-1 es_PA.ISO8859-1 es_PE.ISO8859-1 + es_PY.ISO8859-1 es_SV.ISO8859-1 es_UY.ISO8859-1 es_VE.ISO8859-1 + es es_AR es_BO es_CL + es_CO es_CR es_EC + es_ES es_GT es_MX + es_NI es_PA es_PE + es_PY es_SV es_UY es_VE + spanish spanish.iso88591)); + +# Select the largest of the alpha(num)bets. + +($Locale, @Locale) = ($English, @English) + if (length(@English) > length(@Locale)); +($Locale, @Locale) = ($German, @German) + if (length(@German) > length(@Locale)); +($Locale, @Locale) = ($French, @French) + if (length(@French) > length(@Locale)); +($Locale, @Locale) = ($Spanish, @Spanish) + if (length(@Spanish) > length(@Locale)); + +print "# Locale = $Locale\n"; +print "# Alnum_ = @Locale\n"; + +{ + local $^W = 0; + setlocale(&LC_ALL, $Locale); +} + +{ + my $i = 0; + + for (@Locale) { + $iLocale{$_} = $i++; + } +} + +# Sieve the uppercase and the lowercase. + +for (@Locale) { + if (/[^\d_]/) { # skip digits and the _ + if (lc eq $_) { + $UPPER{$_} = uc; + } else { + $lower{$_} = lc; + } + } +} + +# Find the alphabets that are not alphabets in the default locale. + +{ + no locale; + + for (keys %UPPER, keys %lower) { + push(@Neoalpha, $_) if (/\W/); + } +} + +@Neoalpha = sort @Neoalpha; + +# Test \w. + +{ + my $word = join('', @Neoalpha); + + $word =~ /^(\w*)$/; + + print 'not ' if ($1 ne $word); +} +print "ok 99\n"; + +# Find places where the collation order differs from the default locale. + +print "# testing 100\n"; +{ + my (@k, $i, $j, @d); + + { + no locale; + + @k = sort (keys %UPPER, keys %lower); + } + + for ($i = 0; $i < @k; $i++) { + for ($j = $i + 1; $j < @k; $j++) { + if ($iLocale{$k[$j]} < $iLocale{$k[$i]}) { + push(@d, [$k[$j], $k[$i]]); + } + } + } + + # Cross-check those places. + + for (@d) { + ($i, $j) = @$_; + if ($i gt $j) { + print "# failed 100 at:\n"; + print "# i = $i, j = $j, i ", + $i le $j ? 'le' : 'gt', " j\n"; + print 'not '; + last; + } + } +} +print "ok 100\n"; + +# Cross-check whole character set. + +print "# testing 101\n"; +for (map { chr } 0..255) { + if (/\w/ and /\W/) { print 'not '; last } + if (/\d/ and /\D/) { print 'not '; last } + if (/\s/ and /\S/) { print 'not '; last } + if (/\w/ and /\D/ and not /_/ and + not (exists $UPPER{$_} or exists $lower{$_})) { + print "# failed 101 at:\n"; + print "# ", ord($_), " '$_'\n"; + print 'not '; + last; + } +} +print "ok 101\n"; + +# Test for read-onlys. + +{ + no locale; + $a = "qwerty"; + { + use locale; + print "not " if $a cmp "qwerty"; + } +} +print "ok 102\n"; + +# This test must be the last one because its failure is not fatal. +# The @Locale should be internally consistent. +# Thanks to Hallvard Furuseth <h.b.furuseth@usit.uio.no> +# for inventing a way to test for ordering consistency +# without requiring any particular order. +# ++$jhi;#@iki.fi + +print "# testing 103\n"; +{ + my ($from, $to, $lesser, $greater, @test, %test, $test, $yes, $no, $sign); + + for (0..9) { + # Select a slice. + $from = int(($_*@Locale)/10); + $to = $from + int(@Locale/10); + $to = $#Locale if ($to > $#Locale); + $lesser = join('', @Locale[$from..$to]); + # Select a slice one character on. + $from++; $to++; + $to = $#Locale if ($to > $#Locale); + $greater = join('', @Locale[$from..$to]); + ($yes, $no, $sign) = ($lesser lt $greater + ? (" ", "not ", 1) + : ("not ", " ", -1)); + # all these tests should FAIL (return 0). + @test = + ( + $no.' ($lesser lt $greater)', # 0 + $no.' ($lesser le $greater)', # 1 + 'not ($lesser ne $greater)', # 2 + ' ($lesser eq $greater)', # 3 + $yes.' ($lesser ge $greater)', # 4 + $yes.' ($lesser gt $greater)', # 5 + $yes.' ($greater lt $lesser )', # 6 + $yes.' ($greater le $lesser )', # 7 + 'not ($greater ne $lesser )', # 8 + ' ($greater eq $lesser )', # 9 + $no.' ($greater ge $lesser )', # 10 + $no.' ($greater gt $lesser )', # 11 + 'not (($lesser cmp $greater) == -$sign)' # 12 + ); + @test{@test} = 0 x @test; + $test = 0; + for my $ti (@test) { $test{$ti} = eval $ti ; $test ||= $test{$ti} } + if ($test) { + print "# failed 103 at:\n"; + print "# lesser = '$lesser'\n"; + print "# greater = '$greater'\n"; + print "# lesser cmp greater = ", $lesser cmp $greater, "\n"; + print "# greater cmp lesser = ", $greater cmp $lesser, "\n"; + print "# (greater) from = $from, to = $to\n"; + for my $ti (@test) { + printf("# %-40s %-4s", $ti, + $test{$ti} ? 'FAIL' : 'ok'); + if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) { + printf("(%s == %4d)", $1, eval $1); + } + print "\n"; + } + + warn "The locale definition on your system may have errors.\n"; + last; + } + } +} + +# eof diff --git a/gnu/usr.bin/perl/t/pragma/overload.t b/gnu/usr.bin/perl/t/pragma/overload.t new file mode 100644 index 00000000000..42d045741de --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/overload.t @@ -0,0 +1,363 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Config; + +package Oscalar; +use overload ( + # Anonymous subroutines: +'+' => sub {new Oscalar $ {$_[0]}+$_[1]}, +'-' => sub {new Oscalar + $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, +'<=>' => sub {new Oscalar + $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, +'cmp' => sub {new Oscalar + $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])}, +'*' => sub {new Oscalar ${$_[0]}*$_[1]}, +'/' => sub {new Oscalar + $_[2]? $_[1]/${$_[0]} : + ${$_[0]}/$_[1]}, +'%' => sub {new Oscalar + $_[2]? $_[1]%${$_[0]} : ${$_[0]}%$_[1]}, +'**' => sub {new Oscalar + $_[2]? $_[1]**${$_[0]} : ${$_[0]}-$_[1]}, + +qw( +"" stringify +0+ numify) # Order of arguments unsignificant +); + +sub new { + my $foo = $_[1]; + bless \$foo, $_[0]; +} + +sub stringify { "${$_[0]}" } +sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead + # comparing to direct compilation based on + # stringify + +package main; + +$test = 0; +$| = 1; +print "1..",&last,"\n"; + +sub test { + $test++; if (shift) {print "ok $test\n";1} else {print "not ok $test\n";0} +} + +$a = new Oscalar "087"; +$b= "$a"; + +# All test numbers in comments are off by 1. +# So much for hard-wiring them in :-) To fix this: +test(1); # 1 + +test ($b eq $a); # 2 +test ($b eq "087"); # 3 +test (ref $a eq "Oscalar"); # 4 +test ($a eq $a); # 5 +test ($a eq "087"); # 6 + +$c = $a + 7; + +test (ref $c eq "Oscalar"); # 7 +test (!($c eq $a)); # 8 +test ($c eq "94"); # 9 + +$b=$a; + +test (ref $a eq "Oscalar"); # 10 + +$b++; + +test (ref $b eq "Oscalar"); # 11 +test ( $a eq "087"); # 12 +test ( $b eq "88"); # 13 +test (ref $a eq "Oscalar"); # 14 + +$c=$b; +$c-=$a; + +test (ref $c eq "Oscalar"); # 15 +test ( $a eq "087"); # 16 +test ( $c eq "1"); # 17 +test (ref $a eq "Oscalar"); # 18 + +$b=1; +$b+=$a; + +test (ref $b eq "Oscalar"); # 19 +test ( $a eq "087"); # 20 +test ( $b eq "88"); # 21 +test (ref $a eq "Oscalar"); # 22 + +eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ]; + +$b=$a; + +test (ref $a eq "Oscalar"); # 23 + +$b++; + +test (ref $b eq "Oscalar"); # 24 +test ( $a eq "087"); # 25 +test ( $b eq "88"); # 26 +test (ref $a eq "Oscalar"); # 27 + +package Oscalar; +$dummy=bless \$dummy; # Now cache of method should be reloaded +package main; + +$b=$a; +$b++; + +test (ref $b eq "Oscalar"); # 28 +test ( $a eq "087"); # 29 +test ( $b eq "88"); # 30 +test (ref $a eq "Oscalar"); # 31 + + +eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ]; + +$b=$a; + +test (ref $a eq "Oscalar"); # 32 + +$b++; + +test (ref $b eq "Oscalar"); # 33 +test ( $a eq "087"); # 34 +test ( $b eq "88"); # 35 +test (ref $a eq "Oscalar"); # 36 + +package Oscalar; +$dummy=bless \$dummy; # Now cache of method should be reloaded +package main; + +$b++; + +test (ref $b eq "Oscalar"); # 37 +test ( $a eq "087"); # 38 +test ( $b eq "90"); # 39 +test (ref $a eq "Oscalar"); # 40 + +$b=$a; +$b++; + +test (ref $b eq "Oscalar"); # 41 +test ( $a eq "087"); # 42 +test ( $b eq "89"); # 43 +test (ref $a eq "Oscalar"); # 44 + + +test ($b? 1:0); # 45 + +eval q[ package Oscalar; use overload ('=' => sub {$main::copies++; + package Oscalar; + local $new=$ {$_[0]}; + bless \$new } ) ]; + +$b=new Oscalar "$a"; + +test (ref $b eq "Oscalar"); # 46 +test ( $a eq "087"); # 47 +test ( $b eq "087"); # 48 +test (ref $a eq "Oscalar"); # 49 + +$b++; + +test (ref $b eq "Oscalar"); # 50 +test ( $a eq "087"); # 51 +test ( $b eq "89"); # 52 +test (ref $a eq "Oscalar"); # 53 +test ($copies == 0); # 54 + +$b+=1; + +test (ref $b eq "Oscalar"); # 55 +test ( $a eq "087"); # 56 +test ( $b eq "90"); # 57 +test (ref $a eq "Oscalar"); # 58 +test ($copies == 0); # 59 + +$b=$a; +$b+=1; + +test (ref $b eq "Oscalar"); # 60 +test ( $a eq "087"); # 61 +test ( $b eq "88"); # 62 +test (ref $a eq "Oscalar"); # 63 +test ($copies == 0); # 64 + +$b=$a; +$b++; + +test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65 +test ( $a eq "087"); # 66 +test ( $b eq "89"); # 67 +test (ref $a eq "Oscalar"); # 68 +test ($copies == 1); # 69 + +eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1]; + $_[0] } ) ]; +$c=new Oscalar; # Cause rehash + +$b=$a; +$b+=1; + +test (ref $b eq "Oscalar"); # 70 +test ( $a eq "087"); # 71 +test ( $b eq "90"); # 72 +test (ref $a eq "Oscalar"); # 73 +test ($copies == 2); # 74 + +$b+=$b; + +test (ref $b eq "Oscalar"); # 75 +test ( $b eq "360"); # 76 +test ($copies == 2); # 77 +$b=-$b; + +test (ref $b eq "Oscalar"); # 78 +test ( $b eq "-360"); # 79 +test ($copies == 2); # 80 + +$b=abs($b); + +test (ref $b eq "Oscalar"); # 81 +test ( $b eq "360"); # 82 +test ($copies == 2); # 83 + +$b=abs($b); + +test (ref $b eq "Oscalar"); # 84 +test ( $b eq "360"); # 85 +test ($copies == 2); # 86 + +eval q[package Oscalar; + use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]} + : "_.${$_[0]}._" x $_[1])}) ]; + +$a=new Oscalar "yy"; +$a x= 3; +test ($a eq "_.yy.__.yy.__.yy._"); # 87 + +eval q[package Oscalar; + use overload ('.' => sub {new Oscalar ( $_[2] ? + "_.$_[1].__.$ {$_[0]}._" + : "_.$ {$_[0]}.__.$_[1]._")}) ]; + +$a=new Oscalar "xx"; + +test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88 + +# Check inheritance of overloading; +{ + package OscalarI; + @ISA = 'Oscalar'; +} + +$aI = new OscalarI "$a"; +test (ref $aI eq "OscalarI"); # 89 +test ("$aI" eq "xx"); # 90 +test ($aI eq "xx"); # 91 +test ("b${aI}c" eq "_._.b.__.xx._.__.c._"); # 92 + +# Here we test blessing to a package updates hash + +eval "package Oscalar; no overload '.'"; + +test ("b${a}" eq "_.b.__.xx._"); # 93 +$x="1"; +bless \$x, Oscalar; +test ("b${a}c" eq "bxxc"); # 94 +new Oscalar 1; +test ("b${a}c" eq "bxxc"); # 95 + +# Negative overloading: + +$na = eval { ~$a }; +test($@ =~ /no method found/); # 96 + +# Check AUTOLOADING: + +*Oscalar::AUTOLOAD = + sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ; + goto &{"Oscalar::$AUTOLOAD"}}; + +eval "package Oscalar; sub comple; use overload '~' => 'comple'"; + +$na = eval { ~$a }; # Hash was not updated +test($@ =~ /no method found/); # 97 + +bless \$x, Oscalar; + +$na = eval { ~$a }; # Hash updated +warn "`$na', $@" if $@; +test !$@; # 98 +test($na eq '_!_xx_!_'); # 99 + +$na = 0; + +$na = eval { ~$aI }; # Hash was not updated +test($@ =~ /no method found/); # 100 + +bless \$x, OscalarI; + +$na = eval { ~$aI }; +print $@; + +test !$@; # 101 +test($na eq '_!_xx_!_'); # 102 + +eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'"; + +$na = eval { $aI >> 1 }; # Hash was not updated +test($@ =~ /no method found/); # 103 + +bless \$x, OscalarI; + +$na = 0; + +$na = eval { $aI >> 1 }; +print $@; + +test !$@; # 104 +test($na eq '_!_xx_!_'); # 105 + +# warn overload::Method($a, '0+'), "\n"; +test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106 +test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107 +test (overload::Overloaded($aI)); # 108 +test (!overload::Overloaded('overload')); # 109 + +test (! defined overload::Method($aI, '<<')); # 110 +test (! defined overload::Method($a, '<')); # 111 + +test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112 +test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113 + +# Check overloading by methods (specified deep in the ISA tree). +{ + package OscalarII; + @ISA = 'OscalarI'; + sub Oscalar::lshft {"_<<_" . shift() . "_<<_"} + eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'"; +} + +$aaII = "087"; +$aII = \$aaII; +bless $aII, 'OscalarII'; +bless \$fake, 'OscalarI'; # update the hash +test(($aI | 3) eq '_<<_xx_<<_'); # 114 +# warn $aII << 3; +test(($aII << 3) eq '_<<_087_<<_'); # 115 + +# Last test is: +sub last {115} diff --git a/gnu/usr.bin/perl/t/pragma/strict-refs b/gnu/usr.bin/perl/t/pragma/strict-refs new file mode 100644 index 00000000000..7bf1556e10a --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/strict-refs @@ -0,0 +1,295 @@ +Check strict refs functionality + +__END__ + +# no strict, should build & run ok. +my $fred ; +$b = "fred" ; +$a = $$b ; +$c = ${"def"} ; +$c = @{"def"} ; +$c = %{"def"} ; +$c = *{"def"} ; +$c = \&{"def"} ; +$c = def->[0]; +$c = def->{xyz}; +EXPECT + +######## + +# strict refs - error +use strict ; +my $fred ; +my $a = ${"fred"} ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $fred ; +my $a = ${"fred"} ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $fred ; +my $b = "fred" ; +my $a = $$b ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 6. +######## + +# strict refs - error +use strict 'refs' ; +my $b ; +my $a = $$b ; +EXPECT +Can't use an undefined value as a SCALAR reference at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $b ; +my $a = @$b ; +EXPECT +Can't use an undefined value as an ARRAY reference at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $b ; +my $a = %$b ; +EXPECT +Can't use an undefined value as a HASH reference at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $b ; +my $a = *$b ; +EXPECT +Can't use an undefined value as a symbol reference at - line 5. +######## + +# strict refs - error +use strict 'refs' ; +my $a = fred->[0] ; +EXPECT +Can't use bareword ("fred") as an ARRAY ref while "strict refs" in use at - line 4. +######## + +# strict refs - error +use strict 'refs' ; +my $a = fred->{barney} ; +EXPECT +Can't use bareword ("fred") as a HASH ref while "strict refs" in use at - line 4. +######## + +# strict refs - no error +use strict ; +no strict 'refs' ; +my $fred ; +my $b = "fred" ; +my $a = $$b ; +use strict 'refs' ; +EXPECT + +######## + +# strict refs - no error +use strict qw(subs vars) ; +my $fred ; +my $b = "fred" ; +my $a = $$b ; +use strict 'refs' ; +EXPECT + +######## + +# strict refs - no error +my $fred ; +my $b = "fred" ; +my $a = $$b ; +use strict 'refs' ; +EXPECT + +######## + +# strict refs - no error +use strict 'refs' ; +my $fred ; +my $b = \$fred ; +my $a = $$b ; +EXPECT + +######## + +# Check runtime scope of strict refs pragma +use strict 'refs'; +my $fred ; +my $b = "fred" ; +{ + no strict ; + my $a = $$b ; +} +my $a = $$b ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10. +######## + +# Check runtime scope of strict refs pragma +no strict ; +my $fred ; +my $b = "fred" ; +{ + use strict 'refs' ; + my $a = $$b ; +} +my $a = $$b ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. +######## + +# Check runtime scope of strict refs pragma +no strict ; +my $fred ; +my $b = "fred" ; +{ + use strict 'refs' ; + $a = sub { my $c = $$b ; } +} +&$a ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. +######## + + +--FILE-- abc +my $a = ${"Fred"} ; +1; +--FILE-- +use strict 'refs' ; +require "./abc"; +EXPECT + +######## + +--FILE-- abc +use strict 'refs' ; +1; +--FILE-- +require "./abc"; +my $a = ${"Fred"} ; +EXPECT + +######## + +--FILE-- abc +use strict 'refs' ; +my $a = ${"Fred"} ; +1; +--FILE-- +${"Fred"} ; +require "./abc"; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at ./abc line 2. +######## + +--FILE-- abc.pm +use strict 'refs' ; +my $a = ${"Fred"} ; +1; +--FILE-- +my $a = ${"Fred"} ; +use abc; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at abc.pm line 2. +BEGIN failed--compilation aborted at - line 2. +######## + +# Check scope of pragma with eval +no strict ; +eval { + my $a = ${"Fred"} ; +}; +print STDERR $@ ; +my $a = ${"Fred"} ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval { + use strict 'refs' ; + my $a = ${"Fred"} ; +}; +print STDERR $@ ; +my $a = ${"Fred"} ; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 6. +######## + +# Check scope of pragma with eval +use strict 'refs' ; +eval { + my $a = ${"Fred"} ; +}; +print STDERR $@ ; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 5. +######## + +# Check scope of pragma with eval +use strict 'refs' ; +eval { + no strict ; + my $a = ${"Fred"} ; +}; +print STDERR $@ ; +my $a = ${"Fred"} ; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 9. +######## + +# Check scope of pragma with eval +no strict ; +eval ' + my $a = ${"Fred"} ; +'; print STDERR $@ ; +my $a = ${"Fred"} ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval q[ + use strict 'refs' ; + my $a = ${"Fred"} ; +]; print STDERR $@; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 3. +######## + +# Check scope of pragma with eval +use strict 'refs' ; +eval ' + my $a = ${"Fred"} ; +'; print STDERR $@ ; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 2. +######## + +# Check scope of pragma with eval +use strict 'refs' ; +eval ' + no strict ; + my $a = ${"Fred"} ; +'; print STDERR $@; +my $a = ${"Fred"} ; +EXPECT +Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 8. diff --git a/gnu/usr.bin/perl/t/pragma/strict-subs b/gnu/usr.bin/perl/t/pragma/strict-subs new file mode 100644 index 00000000000..43fce712d57 --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/strict-subs @@ -0,0 +1,279 @@ +Check strict subs functionality + +__END__ + +# no strict, should build & run ok. +Fred ; +my $fred ; +$b = "fred" ; +$a = $$b ; +EXPECT + +######## + +use strict qw(refs vars); +Fred ; +EXPECT + +######## + +use strict ; +no strict 'subs' ; +Fred ; +EXPECT + +######## + +# strict subs - error +use strict 'subs' ; +Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict subs - error +use strict ; +Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict subs - no error +use strict 'subs' ; +sub Fred {} +Fred ; +EXPECT + +######## + +# Check compile time scope of strict subs pragma +use strict 'subs' ; +{ + no strict ; + my $a = Fred ; +} +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 8. +Execution of - aborted due to compilation errors. +######## + +# Check compile time scope of strict subs pragma +no strict; +{ + use strict 'subs' ; + my $a = Fred ; +} +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 6. +Execution of - aborted due to compilation errors. +######## + +# Check compile time scope of strict vars pragma +use strict 'vars' ; +{ + no strict ; + $joe = 1 ; +} +$joe = 1 ; +EXPECT +Variable "$joe" is not imported at - line 8. +Global symbol "joe" requires explicit package name at - line 8. +Execution of - aborted due to compilation errors. +######## + +# Check compile time scope of strict vars pragma +no strict; +{ + use strict 'vars' ; + $joe = 1 ; +} +$joe = 1 ; +EXPECT +Global symbol "joe" requires explicit package name at - line 6. +Execution of - aborted due to compilation errors. +######## + +# Check runtime scope of strict refs pragma +use strict 'refs'; +my $fred ; +my $b = "fred" ; +{ + no strict ; + my $a = $$b ; +} +my $a = $$b ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10. +######## + +# Check runtime scope of strict refs pragma +no strict ; +my $fred ; +my $b = "fred" ; +{ + use strict 'refs' ; + my $a = $$b ; +} +my $a = $$b ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. +######## + +# Check runtime scope of strict refs pragma +no strict ; +my $fred ; +my $b = "fred" ; +{ + use strict 'refs' ; + $a = sub { my $c = $$b ; } +} +&$a ; +EXPECT +Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. +######## + +use strict 'subs' ; +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 3. +Execution of - aborted due to compilation errors. +######## + +--FILE-- abc +my $a = Fred ; +1; +--FILE-- +use strict 'subs' ; +require "./abc"; +EXPECT + +######## + +--FILE-- abc +use strict 'subs' ; +1; +--FILE-- +require "./abc"; +my $a = Fred ; +EXPECT + +######## + +--FILE-- abc +use strict 'subs' ; +my $a = Fred ; +1; +--FILE-- +Fred ; +require "./abc"; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at ./abc line 2. +Compilation failed in require at - line 2. +######## + +--FILE-- abc.pm +use strict 'subs' ; +my $a = Fred ; +1; +--FILE-- +Fred ; +use abc; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at abc.pm line 2. +Compilation failed in require at - line 2. +BEGIN failed--compilation aborted at - line 2. +######## + +# Check scope of pragma with eval +no strict ; +eval { + my $a = Fred ; +}; +print STDERR $@; +my $a = Fred ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval { + use strict 'subs' ; + my $a = Fred ; +}; +print STDERR $@; +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 6. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +use strict 'subs' ; +eval { + my $a = Fred ; +}; +print STDERR $@; +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 5. +Bareword "Fred" not allowed while "strict subs" in use at - line 8. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +use strict 'subs' ; +eval { + no strict ; + my $a = Fred ; +}; +print STDERR $@; +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 9. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +no strict ; +eval ' + Fred ; +'; print STDERR $@ ; +Fred ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval q[ + use strict 'subs' ; + Fred ; +]; print STDERR $@; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 3. +######## + +# Check scope of pragma with eval +use strict 'subs' ; +eval ' + Fred ; +'; print STDERR $@ ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 2. +######## + +# Check scope of pragma with eval +use strict 'subs' ; +eval ' + no strict ; + my $a = Fred ; +'; print STDERR $@; +my $a = Fred ; +EXPECT +Bareword "Fred" not allowed while "strict subs" in use at - line 8. +Execution of - aborted due to compilation errors. diff --git a/gnu/usr.bin/perl/t/pragma/strict-vars b/gnu/usr.bin/perl/t/pragma/strict-vars new file mode 100644 index 00000000000..7ca9843c2c0 --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/strict-vars @@ -0,0 +1,223 @@ +Check strict vars functionality + +__END__ + +# no strict, should build & run ok. +Fred ; +my $fred ; +$b = "fred" ; +$a = $$b ; +EXPECT + +######## + +use strict qw(subs refs) ; +$fred ; +EXPECT + +######## + +use strict ; +no strict 'vars' ; +$fred ; +EXPECT + +######## + +# strict vars - no error +use strict 'vars' ; +use vars qw( $freddy) ; +local $abc::joe ; +my $fred ; +my $b = \$fred ; +$Fred::ABC = 1 ; +$freddy = 2 ; +EXPECT + +######## + +# strict vars - error +use strict ; +$fred ; +EXPECT +Global symbol "fred" requires explicit package name at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict vars - error +use strict 'vars' ; +$fred ; +EXPECT +Global symbol "fred" requires explicit package name at - line 4. +Execution of - aborted due to compilation errors. +######## + +# strict vars - error +use strict 'vars' ; +local $fred ; +EXPECT +Global symbol "fred" requires explicit package name at - line 4. +Execution of - aborted due to compilation errors. +######## + +# Check compile time scope of strict vars pragma +use strict 'vars' ; +{ + no strict ; + $joe = 1 ; +} +$joe = 1 ; +EXPECT +Variable "$joe" is not imported at - line 8. +Global symbol "joe" requires explicit package name at - line 8. +Execution of - aborted due to compilation errors. +######## + +# Check compile time scope of strict vars pragma +no strict; +{ + use strict 'vars' ; + $joe = 1 ; +} +$joe = 1 ; +EXPECT +Global symbol "joe" requires explicit package name at - line 6. +Execution of - aborted due to compilation errors. +######## + +--FILE-- abc +$joe = 1 ; +1; +--FILE-- +use strict 'vars' ; +require "./abc"; +EXPECT + +######## + +--FILE-- abc +use strict 'vars' ; +1; +--FILE-- +require "./abc"; +$joe = 1 ; +EXPECT + +######## + +--FILE-- abc +use strict 'vars' ; +$joe = 1 ; +1; +--FILE-- +$joe = 1 ; +require "./abc"; +EXPECT +Variable "$joe" is not imported at ./abc line 2. +Global symbol "joe" requires explicit package name at ./abc line 2. +Compilation failed in require at - line 2. +######## + +--FILE-- abc.pm +use strict 'vars' ; +$joe = 1 ; +1; +--FILE-- +$joe = 1 ; +use abc; +EXPECT +Variable "$joe" is not imported at abc.pm line 2. +Global symbol "joe" requires explicit package name at abc.pm line 2. +Compilation failed in require at - line 2. +BEGIN failed--compilation aborted at - line 2. +######## + +# Check scope of pragma with eval +no strict ; +eval { + $joe = 1 ; +}; +print STDERR $@; +$joe = 1 ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval { + use strict 'vars' ; + $joe = 1 ; +}; +print STDERR $@; +$joe = 1 ; +EXPECT +Global symbol "joe" requires explicit package name at - line 6. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +use strict 'vars' ; +eval { + $joe = 1 ; +}; +print STDERR $@; +$joe = 1 ; +EXPECT +Global symbol "joe" requires explicit package name at - line 5. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +use strict 'vars' ; +eval { + no strict ; + $joe = 1 ; +}; +print STDERR $@; +$joe = 1 ; +EXPECT +Variable "$joe" is not imported at - line 9. +Global symbol "joe" requires explicit package name at - line 9. +Execution of - aborted due to compilation errors. +######## + +# Check scope of pragma with eval +no strict ; +eval ' + $joe = 1 ; +'; print STDERR $@ ; +$joe = 1 ; +EXPECT + +######## + +# Check scope of pragma with eval +no strict ; +eval q[ + use strict 'vars' ; + $joe = 1 ; +]; print STDERR $@; +EXPECT +Global symbol "joe" requires explicit package name at (eval 1) line 3. +######## + +# Check scope of pragma with eval +use strict 'vars' ; +eval ' + $joe = 1 ; +'; print STDERR $@ ; +EXPECT +Global symbol "joe" requires explicit package name at (eval 1) line 2. +######## + +# Check scope of pragma with eval +use strict 'vars' ; +eval ' + no strict ; + $joe = 1 ; +'; print STDERR $@; +$joe = 1 ; +EXPECT +Global symbol "joe" requires explicit package name at - line 8. +Execution of - aborted due to compilation errors. diff --git a/gnu/usr.bin/perl/t/pragma/strict.t b/gnu/usr.bin/perl/t/pragma/strict.t new file mode 100644 index 00000000000..fc3282089fa --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/strict.t @@ -0,0 +1,93 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + $ENV{PERL5LIB} = '../lib'; +} + +$| = 1; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MSWin32 = $^O eq 'MSWin32'; +my $tmpfile = "tmp0000"; +my $i = 0 ; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile; } } + +my @prgs = () ; + +foreach (sort glob("pragma/strict-*")) { + + next if /(~|\.orig)$/; + + open F, "<$_" or die "Cannot open $_: $!\n" ; + while (<F>) { + last if /^__END__/ ; + } + + { + local $/ = undef; + @prgs = (@prgs, split "\n########\n", <F>) ; + } + close F ; +} + +undef $/; + +print "1..", scalar @prgs, "\n"; + + +for (@prgs){ + my $switch = ""; + my @temps = () ; + if (s/^\s*-\w+//){ + $switch = $&; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + if ( $prog =~ /--FILE--/) { + my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; + shift @files ; + die "Internal error test $i didn't split into pairs, got " . + scalar(@files) . "[" . join("%%%%", @files) ."]\n" + if @files % 2 ; + while (@files > 2) { + my $filename = shift @files ; + my $code = shift @files ; + push @temps, $filename ; + open F, ">$filename" or die "Cannot open $filename: $!\n" ; + print F $code ; + close F ; + } + shift @files ; + $prog = shift @files ; + } + open TEST, ">$tmpfile"; + print TEST $prog,"\n"; + close TEST; + my $results = $Is_VMS ? + `MCR $^X $switch $tmpfile` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + `sh -c './perl $switch $tmpfile' 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/tmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg + $expected =~ s/\n+$//; + my $prefix = ($results =~ s/^PREFIX\n//) ; + if ( $results =~ s/^SKIPPED\n//) { + print "$results\n" ; + } + elsif (($prefix and $results !~ /^\Q$expected/) or + (!$prefix and $results ne $expected)){ + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; + foreach (@temps) + { unlink $_ if $_ } +} diff --git a/gnu/usr.bin/perl/t/pragma/subs.t b/gnu/usr.bin/perl/t/pragma/subs.t new file mode 100644 index 00000000000..056c4bd7cf4 --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/subs.t @@ -0,0 +1,132 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + $ENV{PERL5LIB} = '../lib'; +} + +$| = 1; +undef $/; +my @prgs = split "\n########\n", <DATA>; +print "1..", scalar @prgs, "\n"; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MSWin32 = $^O eq 'MSWin32'; +my $tmpfile = "tmp0000"; +my $i = 0 ; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile} } + +for (@prgs){ + my $switch = ""; + my @temps = () ; + if (s/^\s*-\w+//){ + $switch = $&; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + if ( $prog =~ /--FILE--/) { + my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; + shift @files ; + die "Internal error test $i didn't split into pairs, got " . + scalar(@files) . "[" . join("%%%%", @files) ."]\n" + if @files % 2 ; + while (@files > 2) { + my $filename = shift @files ; + my $code = shift @files ; + push @temps, $filename ; + open F, ">$filename" or die "Cannot open $filename: $!\n" ; + print F $code ; + close F ; + } + shift @files ; + $prog = shift @files ; + } + open TEST, ">$tmpfile"; + print TEST $prog,"\n"; + close TEST; + my $results = $Is_VMS ? + `MCR $^X $switch $tmpfile` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + `sh -c './perl $switch $tmpfile' 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/tmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg + $expected =~ s/\n+$//; + my $prefix = ($results =~ s/^PREFIX\n//) ; + if ( $results =~ s/^SKIPPED\n//) { + print "$results\n" ; + } + elsif (($prefix and $results !~ /^\Q$expected/) or + (!$prefix and $results ne $expected)){ + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; + foreach (@temps) + { unlink $_ if $_ } +} + +__END__ + +# Error - not predeclaring a sub +Fred 1,2 ; +sub Fred {} +EXPECT +Number found where operator expected at - line 3, near "Fred 1" + (Do you need to predeclare Fred?) +syntax error at - line 3, near "Fred 1" +Execution of - aborted due to compilation errors. +######## + +# Error - not predeclaring a sub in time +Fred 1,2 ; +use subs qw( Fred ) ; +sub Fred {} +EXPECT +Number found where operator expected at - line 3, near "Fred 1" + (Do you need to predeclare Fred?) +syntax error at - line 3, near "Fred 1" +BEGIN not safe after errors--compilation aborted at - line 4. +######## + +# AOK +use subs qw( Fred) ; +Fred 1,2 ; +sub Fred { print $_[0] + $_[1], "\n" } +EXPECT +3 +######## + +# override a built-in function +use subs qw( open ) ; +open 1,2 ; +sub open { print $_[0] + $_[1], "\n" } +EXPECT +3 +######## + +--FILE-- abc +Fred 1,2 ; +1; +--FILE-- +use subs qw( Fred ) ; +require "./abc" ; +sub Fred { print $_[0] + $_[1], "\n" } +EXPECT +3 +######## + +# check that it isn't affected by block scope +{ + use subs qw( Fred ) ; +} +Fred 1, 2; +sub Fred { print $_[0] + $_[1], "\n" } +EXPECT +3 diff --git a/gnu/usr.bin/perl/t/pragma/warn-1global b/gnu/usr.bin/perl/t/pragma/warn-1global new file mode 100644 index 00000000000..33252731b0e --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/warn-1global @@ -0,0 +1,146 @@ +Check existing $^W functionality + +__END__ + +# warnable code, warnings disabled +$a =+ 3 ; +EXPECT + +######## +-w +# warnable code, warnings enabled via command line switch +$a =+ 3 ; +EXPECT +Reversed += operator at - line 3. +######## +#! perl -w +# warnable code, warnings enabled via #! line +$a =+ 3 ; +EXPECT +Reversed += operator at - line 3. +######## + +# warnable code, warnings enabled via compile time $^W +BEGIN { $^W = 1 } +$a =+ 3 ; +EXPECT +Reversed += operator at - line 4. +######## + +# compile-time warnable code, warnings enabled via runtime $^W +# so no warning printed. +$^W = 1 ; +$a =+ 3 ; +EXPECT + +######## + +# warnable code, warnings enabled via runtime $^W +$^W = 1 ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value at - line 4. +######## + +# warnings enabled at compile time, disabled at run time +BEGIN { $^W = 1 } +$^W = 0 ; +my $b ; chop $b ; +EXPECT + +######## + +# warnings disabled at compile time, enabled at run time +BEGIN { $^W = 0 } +$^W = 1 ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value at - line 5. +######## +-w +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +require "./abcd"; +EXPECT +Use of uninitialized value at ./abcd line 1. +######## + +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +#! perl -w +require "./abcd"; +EXPECT +Use of uninitialized value at ./abcd line 1. +######## + +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +$^W =1 ; +require "./abcd"; +EXPECT +Use of uninitialized value at ./abcd line 1. +######## + +--FILE-- abcd +$^W = 0; +my $b ; chop $b ; +1 ; +--FILE-- +$^W =1 ; +require "./abcd"; +EXPECT + +######## + +--FILE-- abcd +$^W = 1; +1 ; +--FILE-- +$^W =0 ; +require "./abcd"; +my $b ; chop $b ; +EXPECT +Use of uninitialized value at - line 3. +######## + +$^W = 1; +eval "my $b ; chop $b ;" ; +EXPECT +Use of uninitialized value at - line 3. +Use of uninitialized value at - line 3. +######## + +eval "$^W = 1;" ; +my $b ; chop $b ; +EXPECT + +######## + +eval {$^W = 1;} ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value at - line 3. +######## + +{ + local ($^W) = 1; +} +my $b ; chop $b ; +EXPECT + +######## + +my $a ; chop $a ; +{ + local ($^W) = 1; + my $b ; chop $b ; +} +my $c ; chop $c ; +EXPECT +Use of uninitialized value at - line 5. diff --git a/gnu/usr.bin/perl/t/pragma/warning.t b/gnu/usr.bin/perl/t/pragma/warning.t new file mode 100644 index 00000000000..fa0301ea6a6 --- /dev/null +++ b/gnu/usr.bin/perl/t/pragma/warning.t @@ -0,0 +1,94 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + $ENV{PERL5LIB} = '../lib'; +} + +$| = 1; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MSWin32 = $^O eq 'MSWin32'; +my $tmpfile = "tmp0000"; +my $i = 0 ; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile} } + +my @prgs = () ; + +foreach (sort glob("pragma/warn-*")) { + + next if /(~|\.orig)$/; + + open F, "<$_" or die "Cannot open $_: $!\n" ; + while (<F>) { + last if /^__END__/ ; + } + + { + local $/ = undef; + @prgs = (@prgs, split "\n########\n", <F>) ; + } + close F ; +} + +undef $/; + +print "1..", scalar @prgs, "\n"; + + +for (@prgs){ + my $switch = ""; + my @temps = () ; + if (s/^\s*-\w+//){ + $switch = $&; + $switch =~ s/(-\S*[A-Z]\S*)/"-$1"/ if $Is_VMS; # protect uc switches + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + if ( $prog =~ /--FILE--/) { + my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; + shift @files ; + die "Internal error test $i didn't split into pairs, got " . + scalar(@files) . "[" . join("%%%%", @files) ."]\n" + if @files % 2 ; + while (@files > 2) { + my $filename = shift @files ; + my $code = shift @files ; + push @temps, $filename ; + open F, ">$filename" or die "Cannot open $filename: $!\n" ; + print F $code ; + close F ; + } + shift @files ; + $prog = shift @files ; + } + open TEST, ">$tmpfile"; + print TEST $prog,"\n"; + close TEST; + my $results = $Is_VMS ? + `MCR $^X $switch $tmpfile` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + `sh -c './perl $switch $tmpfile' 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/tmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg + $expected =~ s/\n+$//; + my $prefix = ($results =~ s/^PREFIX\n//) ; + if ( $results =~ s/^SKIPPED\n//) { + print "$results\n" ; + } + elsif (($prefix and $results !~ /^\Q$expected/) or + (!$prefix and $results ne $expected)){ + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; + foreach (@temps) + { unlink $_ if $_ } +} |