dslinux/user/perl/t/run exit.t fresh_perl.t noswitch.t runenv.t switch0.t switchC.t switchF.t switchF1.t switchI.t switchPx.aux switchPx.t switcha.t switchd.t switches.t switchn.t switchp.t switcht.t switchx.aux switchx.t
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:02:13 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/t/run
In directory antilope:/tmp/cvs-serv17422/t/run
Added Files:
exit.t fresh_perl.t noswitch.t runenv.t switch0.t switchC.t
switchF.t switchF1.t switchI.t switchPx.aux switchPx.t
switcha.t switchd.t switches.t switchn.t switchp.t switcht.t
switchx.aux switchx.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: runenv.t ---
#!./perl
#
# Tests for Perl run-time environment variable settings
#
# $PERL5OPT, $PERL5LIB, etc.
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
unless ($Config{'d_fork'}) {
print "1..0 # Skip: no fork\n";
exit 0;
}
}
use Test;
plan tests => 17;
my $STDOUT = './results-0';
my $STDERR = './results-1';
my $PERL = $ENV{PERL} || './perl';
my $FAILURE_CODE = 119;
delete $ENV{PERLLIB};
delete $ENV{PERL5LIB};
delete $ENV{PERL5OPT};
# Run perl with specified environment and arguments returns a list.
# First element is true if Perl's stdout and stderr match the
# supplied $stdout and $stderr argument strings exactly.
# second element is an explanation of the failure
sub runperl {
local *F;
my ($env, $args, $stdout, $stderr) = @_;
unshift @$args, '-I../lib';
$stdout = '' unless defined $stdout;
$stderr = '' unless defined $stderr;
local %ENV = %ENV;
delete $ENV{PERLLIB};
delete $ENV{PERL5LIB};
delete $ENV{PERL5OPT};
my $pid = fork;
return (0, "Couldn't fork: $!") unless defined $pid; # failure
if ($pid) { # parent
my ($actual_stdout, $actual_stderr);
wait;
return (0, "Failure in child.\n") if ($?>>8) == $FAILURE_CODE;
open F, "< $STDOUT" or return (0, "Couldn't read $STDOUT file");
{ local $/; $actual_stdout = <F> }
open F, "< $STDERR" or return (0, "Couldn't read $STDERR file");
{ local $/; $actual_stderr = <F> }
if ($actual_stdout ne $stdout) {
return (0, "Stdout mismatch: expected [$stdout], saw [$actual_stdout]");
} elsif ($actual_stderr ne $stderr) {
return (0, "Stderr mismatch: expected [$stderr], saw [$actual_stderr]");
} else {
return 1; # success
}
} else { # child
for my $k (keys %$env) {
$ENV{$k} = $env->{$k};
}
open STDOUT, "> $STDOUT" or exit $FAILURE_CODE;
open STDERR, "> $STDERR" or it_didnt_work();
{ exec $PERL, @$args }
it_didnt_work();
}
}
sub it_didnt_work {
print STDOUT "IWHCWJIHCI\cNHJWCJQWKJQJWCQW\n";
exit $FAILURE_CODE;
}
sub try {
my ($success, $reason) = runperl(@_);
$reason =~ s/\n/\\n/g if defined $reason;
ok( !!$success, 1, $reason );
}
# PERL5OPT Command-line options (switches). Switches in
# this variable are taken as if they were on
# every Perl command line. Only the -[DIMUdmtw]
# switches are allowed. When running taint
# checks (because the program was running setuid
# or setgid, or the -T switch was used), this
# variable is ignored. If PERL5OPT begins with
# -T, tainting will be enabled, and any
# subsequent options ignored.
try({PERL5OPT => '-w'}, ['-e', 'print $::x'],
"",
qq{Name "main::x" used only once: possible typo at -e line 1.\nUse of uninitialized value in print at -e line 1.\n});
try({PERL5OPT => '-Mstrict'}, ['-e', 'print $::x'],
"", "");
try({PERL5OPT => '-Mstrict'}, ['-e', 'print $x'],
"",
qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
# Fails in 5.6.0
try({PERL5OPT => '-Mstrict -w'}, ['-e', 'print $x'],
"",
qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
# Fails in 5.6.0
try({PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'],
"",
<<ERROR
Name "main::x" used only once: possible typo at -e line 1.
Use of uninitialized value in print at -e line 1.
ERROR
);
# Fails in 5.6.0
try({PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'],
"",
<<ERROR
Name "main::x" used only once: possible typo at -e line 1.
Use of uninitialized value in print at -e line 1.
ERROR
);
try({PERL5OPT => '-MExporter'}, ['-e0'],
"",
"");
# Fails in 5.6.0
try({PERL5OPT => '-MExporter -MExporter'}, ['-e0'],
"",
"");
try({PERL5OPT => '-Mstrict -Mwarnings'},
['-e', 'print "ok" if $INC{"strict.pm"} and $INC{"warnings.pm"}'],
"ok",
"");
try({PERL5OPT => '-w -w'},
['-e', 'print $ENV{PERL5OPT}'],
'-w -w',
'');
try({PERL5OPT => '-t'},
['-e', 'print ${^TAINT}'],
'-1',
'');
try({PERLLIB => "foobar$Config{path_sep}42"},
['-e', 'print grep { $_ eq "foobar" } @INC'],
'foobar',
'');
try({PERLLIB => "foobar$Config{path_sep}42"},
['-e', 'print grep { $_ eq "42" } @INC'],
'42',
'');
try({PERL5LIB => "foobar$Config{path_sep}42"},
['-e', 'print grep { $_ eq "foobar" } @INC'],
'foobar',
'');
try({PERL5LIB => "foobar$Config{path_sep}42"},
['-e', 'print grep { $_ eq "42" } @INC'],
'42',
'');
try({PERL5LIB => "foo",
PERLLIB => "bar"},
['-e', 'print grep { $_ eq "foo" } @INC'],
'foo',
'');
try({PERL5LIB => "foo",
PERLLIB => "bar"},
['-e', 'print grep { $_ eq "bar" } @INC'],
'',
'');
# PERL5LIB tests with included arch directories still missing
END {
1 while unlink $STDOUT;
1 while unlink $STDERR;
}
--- NEW FILE: switchp.t ---
#!./perl -p
BEGIN {
print "1..2\n";
*ARGV = *DATA;
}
__DATA__
ok 1
ok 2
--- NEW FILE: switchC.t ---
#!./perl -w
# Tests for the command-line switches
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
unless (find PerlIO::Layer 'perlio') {
print "1..0 # Skip: not perlio\n";
exit 0;
}
}
require "./test.pl";
plan(tests => 6);
my $r;
my @tmpfiles = ();
END { unlink @tmpfiles }
my $b = pack("C*", unpack("U0C*", pack("U",256)));
$r = runperl( switches => [ '-CO', '-w' ],
prog => 'print chr(256)',
stderr => 1 );
like( $r, qr/^$b(?:\r?\n)?$/s, '-CO: no warning on UTF-8 output' );
SKIP: {
if (exists $ENV{PERL_UNICODE} &&
($ENV{PERL_UNICODE} eq "" || $ENV{PERL_UNICODE} =~ /[SO]/)) {
skip(qq[cannot test with PERL_UNICODE locale "" or /[SO]/], 1);
}
$r = runperl( switches => [ '-CI', '-w' ],
prog => 'print ord(<STDIN>)',
stderr => 1,
stdin => $b );
like( $r, qr/^256(?:\r?\n)?$/s, '-CI: read in UTF-8 input' );
}
$r = runperl( switches => [ '-CE', '-w' ],
prog => 'warn chr(256), qq(\n)',
stderr => 1 );
like( $r, qr/^$b(?:\r?\n)?$/s, '-CE: UTF-8 stderr' );
$r = runperl( switches => [ '-Co', '-w' ],
prog => 'open(F, q(>out)); print F chr(256); close F',
stderr => 1 );
like( $r, qr/^$/s, '-Co: auto-UTF-8 open for output' );
push @tmpfiles, "out";
$r = runperl( switches => [ '-Ci', '-w' ],
prog => 'open(F, q(<out)); print ord(<F>); close F',
stderr => 1 );
like( $r, qr/^256(?:\r?\n)?$/s, '-Ci: auto-UTF-8 open for input' );
$r = runperl( switches => [ '-CA', '-w' ],
prog => 'print ord shift',
stderr => 1,
args => [ chr(256) ] );
like( $r, qr/^256(?:\r?\n)?$/s, '-CA: @ARGV' );
--- NEW FILE: fresh_perl.t ---
#!./perl
# ** DO NOT ADD ANY MORE TESTS HERE **
# Instead, put the test in the appropriate test file and use the
# fresh_perl_is()/fresh_perl_like() functions in t/test.pl.
# This is for tests that used to abnormally cause segfaults, and other nasty
# errors that might kill the interpreter and for some reason you can't
# use an eval().
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl'; # for which_perl() etc
}
use strict;
my $Perl = which_perl();
$|=1;
my @prgs = ();
while(<DATA>) {
if(m/^#{8,}\s*(.*)/) {
push @prgs, ['', $1];
}
else {
$prgs[-1][0] .= $_;
}
}
plan tests => scalar @prgs;
foreach my $prog (@prgs) {
my($raw_prog, $name) = @$prog;
my $switch;
if ($raw_prog =~ s/^\s*(-\w.*)\n//){
$switch = $1;
}
my($prog,$expected) = split(/\nEXPECT\n/, $raw_prog);
$prog .= "\n";
$expected = '' unless defined $expected;
if ($prog =~ /^\# SKIP: (.+)/m) {
if (eval $1) {
ok(1, "Skip: $1");
next;
}
}
$expected =~ s/\n+$//;
fresh_perl_is($prog, $expected, { switches => [$switch || ''] }, $name);
}
__END__
########
$a = ":="; split /($a)/o, "a:=b:=c"; print "@_"
EXPECT
a := b := c
########
$cusp = ~0 ^ (~0 >> 1);
use integer;
$, = " ";
print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n";
EXPECT
7 0 0 8 !
########
$foo=undef; $foo->go;
EXPECT
Can't call method "go" on an undefined value at - line 1.
########
BEGIN
{
"foo";
}
########
$array[128]=1
########
$x=0x0eabcd; print $x->ref;
EXPECT
Can't call method "ref" without a package or object reference at - line 1.
########
chop ($str .= <DATA>);
########
close ($banana);
########
$x=2;$y=3;$x<$y ? $x : $y += 23;print $x;
EXPECT
25
########
eval 'sub bar {print "In bar"}';
########
system './perl -ne "print if eof" /dev/null' unless $^O eq 'MacOS'
########
chop($file = <DATA>);
########
package N;
sub new {my ($obj,$n)=@_; bless \$n}
$aa=new N 1;
$aa=12345;
print $aa;
EXPECT
12345
########
$_="foo";
printf(STDOUT "%s\n", $_);
EXPECT
foo
########
push(@a, 1, 2, 3,)
########
quotemeta ""
########
for ("ABCDE") {
⊂
s/./&sub($&)/eg;
print;}
sub sub {local($_) = @_;
$_ x 4;}
EXPECT
Modification of a read-only value attempted at - line 3.
########
package FOO;sub new {bless {FOO => BAR}};
package main;
use strict vars;
my $self = new FOO;
print $$self{FOO};
EXPECT
BAR
########
$_="foo";
s/.{1}//s;
print;
EXPECT
oo
########
print scalar ("foo","bar")
EXPECT
bar
########
sub by_number { $a <=> $b; };# inline function for sort below
$as_ary{0}="a0";
@ordered_array=sort by_number keys(%as_ary);
########
sub NewShell
{
local($Host) = @_;
my($m2) = $#Shells++;
$Shells[$m2]{HOST} = $Host;
return $m2;
}
sub ShowShell
{
local($i) = @_;
}
&ShowShell(&NewShell(beach,Work,"+0+0"));
&ShowShell(&NewShell(beach,Work,"+0+0"));
&ShowShell(&NewShell(beach,Work,"+0+0"));
########
{
package FAKEARRAY;
sub TIEARRAY
{ print "TIEARRAY @_\n";
die "bomb out\n" unless $count ++ ;
bless ['foo']
}
sub FETCH { print "fetch @_\n"; $_[0]->[$_[1]] }
sub STORE { print "store @_\n"; $_[0]->[$_[1]] = $_[2] }
sub DESTROY { print "DESTROY \n"; undef @{$_[0]}; }
}
eval 'tie @h, FAKEARRAY, fred' ;
tie @h, FAKEARRAY, fred ;
EXPECT
TIEARRAY FAKEARRAY fred
TIEARRAY FAKEARRAY fred
DESTROY
########
BEGIN { die "phooey\n" }
EXPECT
phooey
BEGIN failed--compilation aborted at - line 1.
########
BEGIN { 1/$zero }
EXPECT
Illegal division by zero at - line 1.
BEGIN failed--compilation aborted at - line 1.
########
BEGIN { undef = 0 }
EXPECT
Modification of a read-only value attempted at - line 1.
BEGIN failed--compilation aborted at - line 1.
########
{
package foo;
sub PRINT {
shift;
print join(' ', reverse @_)."\n";
}
sub PRINTF {
shift;
my $fmt = shift;
print sprintf($fmt, @_)."\n";
}
sub TIEHANDLE {
bless {}, shift;
}
sub READLINE {
"Out of inspiration";
}
sub DESTROY {
print "and destroyed as well\n";
}
sub READ {
shift;
print STDOUT "foo->can(READ)(@_)\n";
return 100;
}
sub GETC {
shift;
print STDOUT "Don't GETC, Get Perl\n";
return "a";
}
}
{
local(*FOO);
tie(*FOO,'foo');
print FOO "sentence.", "reversed", "a", "is", "This";
print "-- ", <FOO>, " --\n";
my($buf,$len,$offset);
$buf = "string";
$len = 10; $offset = 1;
read(FOO, $buf, $len, $offset) == 100 or die "foo->READ failed";
getc(FOO) eq "a" or die "foo->GETC failed";
printf "%s is number %d\n", "Perl", 1;
}
EXPECT
This is a reversed sentence.
-- Out of inspiration --
foo->can(READ)(string 10 1)
Don't GETC, Get Perl
Perl is number 1
and destroyed as well
########
my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n"
EXPECT
2 2 2
########
# used to attach defelem magic to all immortal values,
# which made restore of local $_ fail.
foo(2>1);
sub foo { bar() for @_; }
sub bar { local $_; }
print "ok\n";
EXPECT
ok
########
@a = ($a, $b, $c, $d) = (5, 6);
print "ok\n"
if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]);
EXPECT
ok
########
print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000);
EXPECT
ok
########
print "ok\n" if ("\0" lt "\xFF");
EXPECT
ok
########
open(H,$^O eq 'MacOS' ? ':run:fresh_perl.t' : 'run/fresh_perl.t'); # must be in the 't' directory
stat(H);
print "ok\n" if (-e _ and -f _ and -r _);
EXPECT
ok
########
sub thing { 0 || return qw(now is the time) }
print thing(), "\n";
EXPECT
nowisthetime
########
$ren = 'joy';
$stimpy = 'happy';
{ local $main::{ren} = *stimpy; print $ren, ' ' }
print $ren, "\n";
EXPECT
happy joy
########
$stimpy = 'happy';
{ local $main::{ren} = *stimpy; print ${'ren'}, ' ' }
print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n";
EXPECT
happy joy
########
package p;
sub func { print 'really ' unless wantarray; 'p' }
sub groovy { 'groovy' }
package main;
print p::func()->groovy(), "\n"
EXPECT
really groovy
########
@list = ([ 'one', 1 ], [ 'two', 2 ]);
sub func { $num = shift; (grep $_->[1] == $num, @list)[0] }
print scalar(map &func($_), 1 .. 3), " ",
scalar(map scalar &func($_), 1 .. 3), "\n";
EXPECT
2 3
########
($k, $s) = qw(x 0);
@{$h{$k}} = qw(1 2 4);
for (@{$h{$k}}) { $s += $_; delete $h{$k} if ($_ == 2) }
print "bogus\n" unless $s == 7;
########
my $a = 'outer';
eval q[ my $a = 'inner'; eval q[ print "$a " ] ];
eval { my $x = 'peace'; eval q[ print "$x\n" ] }
EXPECT
inner peace
########
-w
$| = 1;
sub foo {
print "In foo1\n";
eval 'sub foo { print "In foo2\n" }';
print "Exiting foo1\n";
}
foo;
foo;
EXPECT
In foo1
Subroutine foo redefined at (eval 1) line 1.
Exiting foo1
In foo2
########
$s = 0;
map {#this newline here tickles the bug
$s += $_} (1,2,4);
print "eat flaming death\n" unless ($s == 7);
########
sub foo { local $_ = shift; split; @_ }
@x = foo(' x y z ');
print "you die joe!\n" unless "@x" eq 'x y z';
########
/(?{"{"})/ # Check it outside of eval too
EXPECT
Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE in m/(?{ <-- HERE "{"})/ at - line 1.
########
/(?{"{"}})/ # Check it outside of eval too
EXPECT
Unmatched right curly bracket at (re_eval 1) line 1, at end of line
syntax error at (re_eval 1) line 1, near ""{"}"
Compilation failed in regexp at - line 1.
########
BEGIN { @ARGV = qw(a b c d e) }
BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" }
END { print "end <",shift,">\nargv <@ARGV>\n" }
INIT { print "init <",shift,">\n" }
CHECK { print "check <",shift,">\n" }
EXPECT
argv <a b c d e>
begin <a>
check <b>
init <c>
end <d>
argv <e>
########
-l
# fdopen from a system descriptor to a system descriptor used to close
# the former.
open STDERR, '>&=STDOUT' or die $!;
select STDOUT; $| = 1; print fileno STDOUT or die $!;
select STDERR; $| = 1; print fileno STDERR or die $!;
EXPECT
1
2
########
-w
sub testme { my $a = "test"; { local $a = "new test"; print $a }}
EXPECT
Can't localize lexical variable $a at - line 1.
########
package X;
sub ascalar { my $r; bless \$r }
sub DESTROY { print "destroyed\n" };
package main;
*s = ascalar X;
EXPECT
destroyed
########
package X;
sub anarray { bless [] }
sub DESTROY { print "destroyed\n" };
package main;
*a = anarray X;
EXPECT
destroyed
########
package X;
sub ahash { bless {} }
sub DESTROY { print "destroyed\n" };
package main;
*h = ahash X;
EXPECT
destroyed
########
package X;
sub aclosure { my $x; bless sub { ++$x } }
sub DESTROY { print "destroyed\n" };
package main;
*c = aclosure X;
EXPECT
destroyed
########
package X;
sub any { bless {} }
my $f = "FH000"; # just to thwart any future optimisations
sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r }
sub DESTROY { print "destroyed\n" }
package main;
$x = any X; # to bump sv_objcount. IO objs aren't counted??
*f = afh X;
EXPECT
destroyed
destroyed
########
BEGIN {
$| = 1;
$SIG{__WARN__} = sub {
eval { print $_[0] };
die "bar\n";
};
warn "foo\n";
}
EXPECT
foo
bar
BEGIN failed--compilation aborted at - line 8.
########
package X;
@ISA='Y';
sub new {
my $class = shift;
my $self = { };
bless $self, $class;
my $init = shift;
$self->foo($init);
print "new", $init;
return $self;
}
sub DESTROY {
my $self = shift;
print "DESTROY", $self->foo;
}
package Y;
sub attribute {
my $self = shift;
my $var = shift;
if (@_ == 0) {
return $self->{$var};
} elsif (@_ == 1) {
$self->{$var} = shift;
}
}
sub AUTOLOAD {
$AUTOLOAD =~ /::([^:]+)$/;
my $method = $1;
splice @_, 1, 0, $method;
goto &attribute;
}
package main;
my $x = X->new(1);
for (2..3) {
my $y = X->new($_);
print $y->foo;
}
print $x->foo;
EXPECT
new1new22DESTROY2new33DESTROY31DESTROY1
########
re();
sub re {
my $re = join '', eval 'qr/(??{ $obj->method })/';
$re;
}
EXPECT
########
use strict;
my $foo = "ZZZ\n";
END { print $foo }
EXPECT
ZZZ
########
eval '
use strict;
my $foo = "ZZZ\n";
END { print $foo }
';
EXPECT
ZZZ
########
-w
if (@ARGV) { print "" }
else {
if ($x == 0) { print "" } else { print $x }
}
EXPECT
Use of uninitialized value in numeric eq (==) at - line 3.
########
$x = sub {};
foo();
sub foo { eval { return }; }
print "ok\n";
EXPECT
ok
########
# moved to op/lc.t
EXPECT
########
sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next }
my $x = "foo";
{ f } continue { print $x, "\n" }
EXPECT
foo
########
sub C () { 1 }
sub M { $_[0] = 2; }
eval "C";
M(C);
EXPECT
Modification of a read-only value attempted at - line 2.
########
print qw(ab a\b a\\b);
EXPECT
aba\ba\b
########
# lexicals declared after the myeval() definition should not be visible
# within it
sub myeval { eval $_[0] }
my $foo = "ok 2\n";
myeval('sub foo { local $foo = "ok 1\n"; print $foo; }');
die $@ if $@;
foo();
print $foo;
EXPECT
ok 1
ok 2
########
# lexicals outside an eval"" should be visible inside subroutine definitions
# within it
eval <<'EOT'; die $@ if $@;
{
my $X = "ok\n";
eval 'sub Y { print $X }'; die $@ if $@;
Y();
}
EOT
EXPECT
ok
########
# This test is here instead of lib/locale.t because
# the bug depends on in the internal state of the locale
# settings and pragma/locale messes up that state pretty badly.
# We need a "fresh run".
BEGIN {
eval { require POSIX };
if ($@) {
exit(0); # running minitest?
}
}
use Config;
my $have_setlocale = $Config{d_setlocale} eq 'define';
$have_setlocale = 0 if $@;
# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1"
# and mingw32 uses said silly CRT
$have_setlocale = 0 if (($^O eq 'MSWin32' || $^O eq 'NetWare') && $Config{cc} =~ /^(cl|gcc)/i);
exit(0) unless $have_setlocale;
my @locales;
if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) {
while(<LOCALES>) {
chomp;
push(@locales, $_);
}
close(LOCALES);
}
exit(0) unless @locales;
for (@locales) {
use POSIX qw(locale_h);
use locale;
setlocale(LC_NUMERIC, $_) or next;
my $s = sprintf "%g %g", 3.1, 3.1;
next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/;
print "$_ $s\n";
}
EXPECT
########
# [ID 20001202.002] and change #8066 added 'at -e line 1';
# reversed again as a result of [perl #17763]
die qr(x)
EXPECT
(?-xism:x)
########
# 20001210.003 mjd at plover.com
format REMITOUT_TOP =
FOO
.
format REMITOUT =
BAR
.
# This loop causes a segv in 5.6.0
for $lineno (1..61) {
write REMITOUT;
}
print "It's OK!";
EXPECT
It's OK!
########
# Inaba Hiroto
reset;
if (0) {
if ("" =~ //) {
}
}
########
# Nicholas Clark
$ENV{TERM} = 0;
reset;
// if 0;
########
# Vadim Konovalov
use strict;
sub new_pmop($) {
my $pm = shift;
return eval "sub {shift=~/$pm/}";
}
new_pmop "abcdef"; reset;
new_pmop "abcdef"; reset;
new_pmop "abcdef"; reset;
new_pmop "abcdef"; reset;
########
# David Dyck
# coredump in 5.7.1
close STDERR; die;
EXPECT
########
# core dump in 20000716.007
-w
"x" =~ /(\G?x)?/;
########
# Bug 20010515.004
my @h = 1 .. 10;
bad(@h);
sub bad {
undef @h;
print "O";
print for @_;
print "K";
}
EXPECT
OK
########
# Bug 20010506.041
"abcd\x{1234}" =~ /(a)(b[c])(d+)?/i and print "ok\n";
EXPECT
ok
########
my $foo = Bar->new();
my @dst;
END {
($_ = "@dst") =~ s/\(0x.+?\)/(0x...)/;
print $_, "\n";
}
package Bar;
sub new {
my Bar $self = bless [], Bar;
eval '$self';
return $self;
}
sub DESTROY {
push @dst, "$_[0]";
}
EXPECT
Bar=ARRAY(0x...)
######## (?{...}) compilation bounces on PL_rs
-0
{
/(?{ $x })/;
# {
}
BEGIN { print "ok\n" }
EXPECT
ok
######## scalar ref to file test operator segfaults on 5.6.1 [ID 20011127.155]
# This only happens if the filename is 11 characters or less.
$foo = \-f "blah";
print "ok" if ref $foo && !$$foo;
EXPECT
ok
######## [ID 20011128.159] 'X' =~ /\X/ segfault in 5.6.1
print "ok" if 'X' =~ /\X/;
EXPECT
ok
######## segfault in 5.6.1 within peep()
@a = (1..9);
@b = sort { @c = sort { @d = sort { 0 } @a; @d; } @a; } @a;
print join '', @a, "\n";
EXPECT
123456789
######## [ID 20020104.007] "coredump on dbmclose"
package Foo;
eval { require AnyDBM_File }; # not all places have dbm* functions
if ($@) {
print "ok\n";
exit 0;
}
package Foo;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = {};
bless($self,$class);
my %LT;
dbmopen(%LT, "dbmtest", 0666) ||
die "Can't open dbmtest because of $!\n";
$self->{'LT'} = \%LT;
return $self;
}
sub DESTROY {
my $self = shift;
dbmclose(%{$self->{'LT'}});
1 while unlink 'dbmtest';
1 while unlink <dbmtest.*>;
print "ok\n";
}
package main;
$test = Foo->new(); # must be package var
EXPECT
ok
######## example from Camel 5, ch. 15, pp.406 (with my)
# SKIP: ord "A" == 193 # EBCDIC
use strict;
use utf8;
my $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
$人++; # a child is born
print $人, "\n";
EXPECT
3
######## example from Camel 5, ch. 15, pp.406 (with our)
# SKIP: ord "A" == 193 # EBCDIC
use strict;
use utf8;
our $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
$人++; # a child is born
print $人, "\n";
EXPECT
3
######## example from Camel 5, ch. 15, pp.406 (with package vars)
# SKIP: ord "A" == 193 # EBCDIC
use utf8;
$人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
$人++; # a child is born
print $人, "\n";
EXPECT
3
######## example from Camel 5, ch. 15, pp.406 (with use vars)
# SKIP: ord "A" == 193 # EBCDIC
use strict;
use utf8;
use vars qw($人);
$人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
$人++; # a child is born
print $人, "\n";
EXPECT
3
########
# test that closures generated by eval"" hold on to the CV of the eval""
# for their entire lifetime
$code = eval q[
sub { eval '$x = "ok 1\n"'; }
];
&{$code}();
print $x;
EXPECT
ok 1
######## [ID 20020623.009] nested eval/sub segfaults
$eval = eval 'sub { eval "sub { %S }" }';
$eval->({});
######## [perl #17951] Strange UTF error
-W
# From: "John Kodis" <kodis at mail630.gsfc.nasa.gov>
# Newsgroups: comp.lang.perl.moderated
# Subject: Strange UTF error
# Date: Fri, 11 Oct 2002 16:19:58 -0400
# Message-ID: <pan.2002.10.11.20.19.48.407190 at mail630.gsfc.nasa.gov>
$_ = "foobar\n";
utf8::upgrade($_); # the original code used a UTF-8 locale (affects STDIN)
# matching is actually irrelevant: avoiding several dozen of these
# Illegal hexadecimal digit ' ' ignored at /usr/lib/perl5/5.8.0/utf8_heavy.pl line 152
# is what matters.
/^([[:digit:]]+)/;
EXPECT
######## [perl #20667] unicode regex vs non-unicode regex
$toto = 'Hello';
$toto =~ /\w/; # this line provokes the problem!
$name = 'A B';
# utf8::upgrade($name) if @ARGV;
if ($name =~ /(\p{IsUpper}) (\p{IsUpper})/){
print "It's good! >$1< >$2<\n";
} else {
print "It's not good...\n";
}
EXPECT
It's good! >A< >B<
######## [perl #8760] strangness with utf8 and warn
$_="foo";utf8::upgrade($_);/bar/i,warn$_;
EXPECT
foo at - line 1.
######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <200309010925.h819Pf0X011457 at smtp3.ActiveState.com>
-lw
BEGIN {
eval 'require Fcntl';
if ($@) { print qq[./"TEST"\n./"TEST"\n]; exit 0 } # running minitest?
}
if ($^O eq 'VMS') { # VMS is not *that* kind of a glob.
print qq[./"TEST"\n./"TEST"\n];
} else {
print glob(q(./"TEST"));
use File::Glob;
print glob(q(./"TEST"));
}
EXPECT
./"TEST"
./"TEST"
######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <200309010925.h819Pf0X011457 at smtp3.ActiveState.com>
-lw
BEGIN {
eval 'require Fcntl';
if ($@) { print qq[./"TEST"\n./"TEST"\n]; exit 0 } # running minitest?
}
if ($^O eq 'VMS') { # VMS is not *that* kind of a glob.
print qq[./"TEST"\n./"TEST"\n];
} else {
use File::Glob;
print glob(q(./"TEST"));
use File::Glob;
print glob(q(./"TEST"));
}
EXPECT
./"TEST"
./"TEST"
######## "Segfault using HTML::Entities", Richard Jolly <richardjolly at mac.com>, <A3C7D27E-C9F4-11D8-B294-003065AE00B6 at mac.com> in perl-unicode at perl.org
-lw
# SKIP: use Config; $ENV{PERL_CORE_MINITEST} or " $Config::Config{'extensions'} " !~ m[ Encode ] # Perl configured without Encode module
BEGIN {
eval 'require Encode';
if ($@) { exit 0 } # running minitest?
}
# Test case cut down by jhi
$SIG{__WARN__} = sub { $@ = shift };
use Encode;
my $t = "\xE9";
Encode::_utf8_on($t);
$t =~ s/([^a])//ge;
$@ =~ s/ at .*/ at/;
print $@
EXPECT
Malformed UTF-8 character (unexpected end of string) in substitution (s///) at
--- NEW FILE: switchF1.t ---
#!perl -w
print "1..5\n";
my $file = "F-Pathological.pl";
open F, ">$file" or die "Open $file: $!";
my $prog = <<'EOT';
#!./perl -anF[~#QQ\\xq']
BEGIN {
*ARGV = *DATA;
}
print "@F";
__DATA__
okx1
okq2
ok\3
ok'4
EOT
# 2 of the characters toke.c used to use to quote the split parameter:
$prog =~ s/QQ/\x01\x80/;
# These 2 plus ~ # and ' were enough to make perl choke
print F $prog;
close F or die "Close $file: $!";
print system ($^X, $file) ? "not ok 5\n" : "ok 5\n";
unlink $file or die "Unlink $file: $!";
--- NEW FILE: exit.t ---
#!./perl
#
# Tests for perl exit codes, playing with $?, etc...
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
}
# VMS and Windows need -e "...", most everything else works better with '
my $quote = $^O =~ /^(VMS|MSWin\d+)$/ ? q{"} : q{'};
# Run some code, return its wait status.
sub run {
my($code) = shift;
my $cmd = "$^X -e ";
return system($cmd.$quote.$code.$quote);
}
BEGIN {
# MacOS system() doesn't have good return value
$numtests = ($^O eq 'VMS') ? 7 : ($^O eq 'MacOS') ? 0 : 3;
}
require "test.pl";
plan(tests => $numtests);
if ($^O ne 'MacOS') {
my $exit, $exit_arg;
$exit = run('exit');
is( $exit >> 8, 0, 'Normal exit' );
if ($^O ne 'VMS') {
$exit = run('exit 42');
is( $exit >> 8, 42, 'Non-zero exit' );
} else {
# On VMS, successful returns from system() are always 0, warnings are 1,
# errors are 2, and fatal errors are 4.
$exit = run("exit 196609"); # %CLI-S-NORMAL
is( $exit >> 8, 0, 'success exit' );
$exit = run("exit 196611"); # %CLI-I-NORMAL
is( $exit >> 8, 0, 'informational exit' );
$exit = run("exit 196608"); # %CLI-W-NORMAL
is( $exit >> 8, 1, 'warning exit' );
$exit = run("exit 196610"); # %CLI-E-NORMAL
is( $exit >> 8, 2, 'error exit' );
$exit = run("exit 196612"); # %CLI-F-NORMAL
is( $exit >> 8, 4, 'fatal error exit' );
}
$exit_arg = 42;
$exit = run("END { \$? = $exit_arg }");
# On VMS, in the child process the actual exit status will be SS$_ABORT,
# which is what you get from any non-zero value of $? that has been
# dePOSIXified by STATUS_POSIX_SET. In the parent process, all we'll
# see are the severity bits (0-2) shifted left by 8.
$exit_arg = (44 & 7) if $^O eq 'VMS';
is( $exit >> 8, $exit_arg, 'Changing $? in END block' );
}
--- NEW FILE: switches.t ---
#!./perl -w
# Tests for the command-line switches:
# -0, -c, -l, -s, -m, -M, -V, -v, -h, -z, -i
# Some switches have their own tests, see MANIFEST.
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
require "./test.pl";
plan(tests => 26);
use Config;
# due to a bug in VMS's piping which makes it impossible for runperl()
# to emulate echo -n (ie. stdin always winds up with a newline), these
# tests almost totally fail.
$TODO = "runperl() unable to emulate echo -n due to pipe bug" if $^O eq 'VMS';
my $r;
my @tmpfiles = ();
END { unlink @tmpfiles }
# Tests for -0
$r = runperl(
switches => [ '-0', ],
stdin => 'foo\0bar\0baz\0',
prog => 'print qq(<$_>) while <>',
);
is( $r, "<foo\0><bar\0><baz\0>", "-0" );
$r = runperl(
switches => [ '-l', '-0', '-p' ],
stdin => 'foo\0bar\0baz\0',
prog => '1',
);
is( $r, "foo\nbar\nbaz\n", "-0 after a -l" );
$r = runperl(
switches => [ '-0', '-l', '-p' ],
stdin => 'foo\0bar\0baz\0',
prog => '1',
);
is( $r, "foo\0bar\0baz\0", "-0 before a -l" );
$r = runperl(
switches => [ sprintf("-0%o", ord 'x') ],
stdin => 'fooxbarxbazx',
prog => 'print qq(<$_>) while <>',
);
is( $r, "<foox><barx><bazx>", "-0 with octal number" );
$r = runperl(
switches => [ '-00', '-p' ],
stdin => 'abc\ndef\n\nghi\njkl\nmno\n\npq\n',
prog => 's/\n/-/g;$_.=q(/)',
);
is( $r, 'abc-def--/ghi-jkl-mno--/pq-/', '-00 (paragraph mode)' );
$r = runperl(
switches => [ '-0777', '-p' ],
stdin => 'abc\ndef\n\nghi\njkl\nmno\n\npq\n',
prog => 's/\n/-/g;$_.=q(/)',
);
is( $r, 'abc-def--ghi-jkl-mno--pq-/', '-0777 (slurp mode)' );
$r = runperl(
switches => [ '-066' ],
prog => 'BEGIN { print qq{($/)} } print qq{[$/]}',
);
is( $r, "(\066)[\066]", '$/ set at compile-time' );
# Tests for -c
my $filename = 'swctest.tmp';
SKIP: {
local $TODO = ''; # this one works on VMS
open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" );
print $f <<'SWTEST';
BEGIN { print "block 1\n"; }
CHECK { print "block 2\n"; }
INIT { print "block 3\n"; }
print "block 4\n";
END { print "block 5\n"; }
SWTEST
close $f or die "Could not close: $!";
$r = runperl(
switches => [ '-c' ],
progfile => $filename,
stderr => 1,
);
# Because of the stderr redirection, we can't tell reliably the order
# in which the output is given
ok(
$r =~ /$filename syntax OK/
&& $r =~ /\bblock 1\b/
&& $r =~ /\bblock 2\b/
&& $r !~ /\bblock 3\b/
&& $r !~ /\bblock 4\b/
&& $r !~ /\bblock 5\b/,
'-c'
);
push @tmpfiles, $filename;
}
# Tests for -l
$r = runperl(
switches => [ sprintf("-l%o", ord 'x') ],
prog => 'print for qw/foo bar/'
);
is( $r, 'fooxbarx', '-l with octal number' );
# Tests for -s
$r = runperl(
switches => [ '-s' ],
prog => 'for (qw/abc def ghi/) {print defined $$_ ? $$_ : q(-)}',
args => [ '--', '-abc=2', '-def', ],
);
is( $r, '21-', '-s switch parsing' );
# Bug ID 20011106.084
$filename = 'swstest.tmp';
SKIP: {
open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" );
print $f <<'SWTEST';
#!perl -sn
BEGIN { print $x; exit }
SWTEST
close $f or die "Could not close: $!";
$r = runperl(
progfile => $filename,
args => [ '-x=foo' ],
);
is( $r, 'foo', '-s on the shebang line' );
push @tmpfiles, $filename;
}
# Tests for -m and -M
$filename = 'swtest.pm';
SKIP: {
open my $f, ">$filename" or skip( "Can't write temp file $filename: $!",4 );
print $f <<'SWTESTPM';
package swtest;
sub import { print map "<$_>", @_ }
1;
SWTESTPM
close $f or die "Could not close: $!";
$r = runperl(
switches => [ '-Mswtest' ],
prog => '1',
);
is( $r, '<swtest>', '-M' );
$r = runperl(
switches => [ '-Mswtest=foo' ],
prog => '1',
);
is( $r, '<swtest><foo>', '-M with import parameter' );
$r = runperl(
switches => [ '-mswtest' ],
prog => '1',
);
{
local $TODO = ''; # this one works on VMS
is( $r, '', '-m' );
}
$r = runperl(
switches => [ '-mswtest=foo,bar' ],
prog => '1',
);
is( $r, '<swtest><foo><bar>', '-m with import parameters' );
push @tmpfiles, $filename;
}
# Tests for -V
{
local $TODO = ''; # these ones should work on VMS
# basic perl -V should generate significant output.
# we don't test actual format too much since it could change
like( runperl( switches => ['-V'] ), qr/(\n.*){20}/,
'-V generates 20+ lines' );
like( runperl( switches => ['-V'] ),
qr/\ASummary of my perl5 .*configuration:/,
'-V looks okay' );
# lookup a known config var
chomp( $r=runperl( switches => ['-V:osname'] ) );
is( $r, "osname='$^O';", 'perl -V:osname');
# lookup a nonexistent var
chomp( $r=runperl( switches => ['-V:this_var_makes_switches_test_fail'] ) );
is( $r, "this_var_makes_switches_test_fail='UNKNOWN';",
'perl -V:unknown var');
# regexp lookup
# platforms that don't like this quoting can either skip this test
# or fix test.pl _quote_args
$r = runperl( switches => ['"-V:i\D+size"'] );
# should be unlike( $r, qr/^$|not found|UNKNOWN/ );
like( $r, qr/^(?!.*(not found|UNKNOWN))./, 'perl -V:re got a result' );
# make sure each line we got matches the re
ok( !( grep !/^i\D+size=/, split /^/, $r ), '-V:re correct' );
}
# Tests for -v
{
local $TODO = ''; # these ones should work on VMS
my $v = sprintf "%vd", $^V;
like( runperl( switches => ['-v'] ),
qr/This is perl, v$v built for $Config{archname}.+Copyright.+Larry Wall.+Artistic License.+GNU General Public License/s,
'-v looks okay' );
}
# Tests for -h
{
local $TODO = ''; # these ones should work on VMS
like( runperl( switches => ['-h'] ),
qr/Usage: .+(?i:perl(?:$Config{_exe})?).+switches.+programfile.+arguments/,
'-h looks okay' );
}
# Tests for -z (which does not exist)
{
local $TODO = ''; # these ones should work on VMS
like( runperl( switches => ['-z'], stderr => 1 ),
qr/\QUnrecognized switch: -z (-h will show valid options)./,
'-z correctly unknown' );
}
# Tests for -i
{
local $TODO = ''; # these ones should work on VMS
sub do_i_unlink { 1 while unlink("file", "file.bak") }
open(FILE, ">file") or die "$0: Failed to create 'file': $!";
print FILE <<__EOF__;
foo yada dada
bada foo bing
king kong foo
__EOF__
close FILE;
END { do_i_unlink() }
runperl( switches => ['-pi.bak'], prog => 's/foo/bar/', args => ['file'] );
open(FILE, "file") or die "$0: Failed to open 'file': $!";
chomp(my @file = <FILE>);
close FILE;
open(BAK, "file.bak") or die "$0: Failed to open 'file': $!";
chomp(my @bak = <BAK>);
close BAK;
is(join(":", @file),
"bar yada dada:bada bar bing:king kong bar",
"-i new file");
is(join(":", @bak),
"foo yada dada:bada foo bing:king kong foo",
"-i backup file");
}
--- NEW FILE: noswitch.t ---
#!./perl
BEGIN {
print "1..3\n";
*ARGV = *DATA;
}
print "ok 1\n";
print <>;
print "ok 3\n";
__DATA__
ok 2 - read from aliased DATA filehandle
--- NEW FILE: switchI.t ---
#!./perl -IFoo::Bar -IBla
BEGIN {
chdir 't' if -d 't';
unshift @INC, '../lib';
require './test.pl'; # for which_perl() etc
}
BEGIN {
plan(4);
}
my $Is_MacOS = $^O eq 'MacOS';
my $Is_VMS = $^O eq 'VMS';
my $lib;
$lib = $Is_MacOS ? ':Bla:' : 'Bla';
ok(grep { $_ eq $lib } @INC);
SKIP: {
skip 'Double colons not allowed in dir spec', 1 if $Is_VMS;
$lib = $Is_MacOS ? 'Foo::Bar:' : 'Foo::Bar';
ok(grep { $_ eq $lib } @INC);
}
$lib = $Is_MacOS ? ':Bla2:' : 'Bla2';
fresh_perl_is("print grep { \$_ eq '$lib' } \@INC", $lib,
{ switches => ['-IBla2'] }, '-I');
SKIP: {
skip 'Double colons not allowed in dir spec', 1 if $Is_VMS;
$lib = $Is_MacOS ? 'Foo::Bar2:' : 'Foo::Bar2';
fresh_perl_is("print grep { \$_ eq '$lib' } \@INC", $lib,
{ switches => ['-IFoo::Bar2'] }, '-I with colons');
}
--- NEW FILE: switchd.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = qw(../lib lib);
}
require "./test.pl";
plan(tests => 1);
my $r;
my @tmpfiles = ();
END { unlink @tmpfiles }
my $filename = 'swdtest.tmp';
SKIP: {
open my $f, ">$filename"
or skip( "Can't write temp file $filename: $!" );
print $f <<'__SWDTEST__';
package Bar;
sub bar { $_[0] * $_[0] }
package Foo;
sub foo {
my $s;
$s += Bar::bar($_) for 1..$_[0];
}
package main;
Foo::foo(3);
__SWDTEST__
close $f;
push @tmpfiles, $filename;
$| = 1; # Unbufferize.
$r = runperl(
switches => [ '-Ilib', '-d:switchd' ],
progfile => $filename,
);
like($r, qr/^main,swdtest.tmp,9;Foo,swdtest.tmp,5;Foo,swdtest.tmp,6;Foo,swdtest.tmp,6;Bar,swdtest.tmp,2;Bar,swdtest.tmp,2;Bar,swdtest.tmp,2;$/i);
}
--- NEW FILE: switchPx.t ---
#!./perl
# Ensure that the -P and -x flags work together.
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
$ENV{PERL5LIB} = '../lib';
use Config;
if ( $^O eq 'MacOS' || ($Config{'cppstdin'} =~ /\bcppstdin\b/) &&
! -x $Config{'binexp'} . "/cppstdin" ) {
print "1..0 # Skip: \$Config{cppstdin} unavailable\n";
exit; # Cannot test till after install, alas.
}
}
require './test.pl';
print runperl( switches => ['-Px'],
nolib => 1, # for some reason this is necessary under VMS
progfile => 'run/switchPx.aux' );
--- NEW FILE: switch0.t ---
#!./perl -0
print "1..1\n";
print ord $/ == 0 ? "ok 1\n" : "not ok 1\n";
--- NEW FILE: switchx.aux ---
Some stuff that's not Perl
This CPP directive should not be read.
#define BARMAR 1
#perl
Still not perl.
#!
still not perl
#!/something/else
still not perl
#!/some/path/that/leads/to/perl -l
print "1..1";
print "ok 1";
--- NEW FILE: switchn.t ---
#!./perl -n
BEGIN {
print "1..2\n";
*ARGV = *DATA;
}
print;
__DATA__
ok 1
ok 2
--- NEW FILE: switcha.t ---
#!./perl -na
BEGIN {
print "1..2\n";
*ARGV = *DATA;
$i = 0;
}
print "$F[1] ",++$i,"\n";
__DATA__
not ok
not ok 3
--- NEW FILE: switchx.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
require './test.pl';
use File::Spec::Functions;
print runperl( switches => ['-x'], progfile => catfile(curdir(), 'run', 'switchx.aux') );
--- NEW FILE: switchPx.aux ---
Some stuff that's not Perl
This CPP directive should not be read.
#define BARMAR 1
#perl
Still not perl.
#!
still not perl
#!/something/else
still not perl
#!/some/path/that/leads/to/perl -l
# The -l switch should be applied from the #! line.
# Unfortunately, -P has a bug whereby the #! line is ignored.
# If this test suddenly starts printing blank lines that bug is fixed.
#define FOO "ok 1\n"
#ifdef BARMAR
# define YAR "not ok 2\n"
#else
# define YAR "ok 2\n"
#endif
print "1..2\n";
print FOO;
print YAR;
--- NEW FILE: switchF.t ---
#!./perl -anFx+
BEGIN {
print "1..2\n";
*ARGV = *DATA;
}
print "@F";
__DATA__
okx1
okxxx2
--- NEW FILE: switcht.t ---
#!./perl -t
BEGIN {
chdir 't';
@INC = '../lib';
require './test.pl';
}
plan tests => 11;
my $Perl = which_perl();
my $warning;
local $SIG{__WARN__} = sub { $warning = join "\n", @_; };
my $Tmsg = 'while running with -t switch';
is( ${^TAINT}, -1, '${^TAINT} == -1' );
my $out = `$Perl -le "print q(Hello)"`;
is( $out, "Hello\n", '`` worked' );
like( $warning, qr/^Insecure .* $Tmsg/, ' taint warn' );
{
no warnings 'taint';
$warning = '';
my $out = `$Perl -le "print q(Hello)"`;
is( $out, "Hello\n", '`` worked' );
is( $warning, '', ' no warnings "taint"' );
}
# Get ourselves a tainted variable.
$file = $0;
$file =~ s/.*/some.tmp/;
ok( open(FILE, ">$file"), 'open >' ) or DIE $!;
print FILE "Stuff\n";
close FILE;
like( $warning, qr/^Insecure dependency in open $Tmsg/, 'open > taint warn' );
ok( -e $file, ' file written' );
unlink($file);
like( $warning, qr/^Insecure dependency in unlink $Tmsg/,
'unlink() taint warn' );
ok( !-e $file, 'unlink worked' );
ok( !$^W, "-t doesn't enable regular warnings" );
More information about the dslinux-commit
mailing list