From 1c0eccc3fa1085a4c45950a37b9f538e2a9007f3 Mon Sep 17 00:00:00 2001 From: "Todd C. Miller" Date: Sun, 27 Oct 2002 22:15:14 +0000 Subject: stock perl 5.8.0 from CPAN --- gnu/usr.bin/perl/t/comp/hints.t | 267 +----- gnu/usr.bin/perl/t/io/crlf.t | 102 +-- gnu/usr.bin/perl/t/io/utf8.t | 323 +++---- gnu/usr.bin/perl/t/lib/1_compile.t | 47 +- gnu/usr.bin/perl/t/lib/strict/refs | 76 -- gnu/usr.bin/perl/t/lib/strict/subs | 117 +-- gnu/usr.bin/perl/t/lib/strict/vars | 156 +--- gnu/usr.bin/perl/t/lib/warnings/7fatal | 176 +--- gnu/usr.bin/perl/t/lib/warnings/doio | 209 +---- gnu/usr.bin/perl/t/lib/warnings/doop | 1 - gnu/usr.bin/perl/t/lib/warnings/mg | 17 +- gnu/usr.bin/perl/t/lib/warnings/op | 1271 ++++---------------------- gnu/usr.bin/perl/t/lib/warnings/perlio | 14 +- gnu/usr.bin/perl/t/lib/warnings/pp | 44 +- gnu/usr.bin/perl/t/lib/warnings/pp_hot | 91 +- gnu/usr.bin/perl/t/lib/warnings/pp_sys | 490 +--------- gnu/usr.bin/perl/t/lib/warnings/regcomp | 221 ++++- gnu/usr.bin/perl/t/lib/warnings/utf8 | 629 ++----------- gnu/usr.bin/perl/t/op/alarm.t | 33 +- gnu/usr.bin/perl/t/op/caller.t | 286 +----- gnu/usr.bin/perl/t/op/chdir.t | 119 +-- gnu/usr.bin/perl/t/op/gmagic.t | 196 +--- gnu/usr.bin/perl/t/op/inccode.t | 246 +----- gnu/usr.bin/perl/t/op/lc.t | 400 ++------- gnu/usr.bin/perl/t/op/loopctl.t | 390 +++----- gnu/usr.bin/perl/t/op/override.t | 162 +--- gnu/usr.bin/perl/t/op/srand.t | 33 +- gnu/usr.bin/perl/t/op/sub_lval.t | 803 ++++------------- gnu/usr.bin/perl/t/op/utfhash.t | 62 +- gnu/usr.bin/perl/t/run/exit.t | 157 +--- gnu/usr.bin/perl/t/run/fresh_perl.t | 285 +++--- gnu/usr.bin/perl/t/run/switches.t | 291 +----- gnu/usr.bin/perl/t/run/switcht.t | 27 +- gnu/usr.bin/perl/t/test.pl | 1473 ++++--------------------------- gnu/usr.bin/perl/t/uni/case.pl | 171 ++-- gnu/usr.bin/perl/t/uni/lower.t | 6 +- gnu/usr.bin/perl/t/uni/sprintf.t | 18 +- gnu/usr.bin/perl/t/uni/title.t | 5 +- gnu/usr.bin/perl/t/uni/upper.t | 6 +- gnu/usr.bin/perl/t/win32/system.t | 65 +- gnu/usr.bin/perl/t/win32/system_tests | 7 +- gnu/usr.bin/perl/t/x2p/s2p.t | 37 +- 42 files changed, 1787 insertions(+), 7742 deletions(-) (limited to 'gnu/usr.bin/perl/t') diff --git a/gnu/usr.bin/perl/t/comp/hints.t b/gnu/usr.bin/perl/t/comp/hints.t index 9a08854d86c..5911b77688f 100644 --- a/gnu/usr.bin/perl/t/comp/hints.t +++ b/gnu/usr.bin/perl/t/comp/hints.t @@ -1,285 +1,36 @@ -#!./perl - -# Tests the scoping of $^H and %^H +#!./perl -w -BEGIN { - @INC = qw(. ../lib); - chdir 't'; -} - -BEGIN { print "1..31\n"; } +BEGIN { print "1..7\n"; } BEGIN { print "not " if exists $^H{foo}; print "ok 1 - \$^H{foo} doesn't exist initially\n"; - if (${^OPEN}) { - print "not " unless $^H & 0x00020000; - print "ok 2 - \$^H contains HINT_LOCALIZE_HH initially with ${^OPEN}\n"; - } else { - print "not " if $^H & 0x00020000; - print "ok 2 - \$^H doesn't contain HINT_LOCALIZE_HH initially\n"; - } } { # simulate a pragma -- don't forget HINT_LOCALIZE_HH - BEGIN { $^H |= 0x04020000; $^H{foo} = "a"; } + BEGIN { $^H |= 0x00020000; $^H{foo} = "a"; } BEGIN { print "not " if $^H{foo} ne "a"; - print "ok 3 - \$^H{foo} is now 'a'\n"; - print "not " unless $^H & 0x00020000; - print "ok 4 - \$^H contains HINT_LOCALIZE_HH while compiling\n"; + print "ok 2 - \$^H{foo} is now 'a'\n"; } { BEGIN { $^H |= 0x00020000; $^H{foo} = "b"; } BEGIN { print "not " if $^H{foo} ne "b"; - print "ok 5 - \$^H{foo} is now 'b'\n"; + print "ok 3 - \$^H{foo} is now 'b'\n"; } } BEGIN { print "not " if $^H{foo} ne "a"; - print "ok 6 - \$^H{foo} restored to 'a'\n"; + print "ok 4 - \$H^{foo} restored to 'a'\n"; } - # The pragma settings disappear after compilation - # (test at CHECK-time and at run-time) CHECK { print "not " if exists $^H{foo}; - print "ok 9 - \$^H{foo} doesn't exist when compilation complete\n"; - if (${^OPEN}) { - print "not " unless $^H & 0x00020000; - print "ok 10 - \$^H contains HINT_LOCALIZE_HH when compilation complete with ${^OPEN}\n"; - } else { - print "not " if $^H & 0x00020000; - print "ok 10 - \$^H doesn't contain HINT_LOCALIZE_HH when compilation complete\n"; - } + print "ok 6 - \$^H{foo} doesn't exist when compilation complete\n"; } print "not " if exists $^H{foo}; - print "ok 11 - \$^H{foo} doesn't exist at runtime\n"; - if (${^OPEN}) { - print "not " unless $^H & 0x00020000; - print "ok 12 - \$^H contains HINT_LOCALIZE_HH at run-time with ${^OPEN}\n"; - } else { - print "not " if $^H & 0x00020000; - print "ok 12 - \$^H doesn't contain HINT_LOCALIZE_HH at run-time\n"; - } - # op_entereval should keep the pragmas it was compiled with - eval q* - BEGIN { - print "not " if $^H{foo} ne "a"; - print "ok 13 - \$^H{foo} is 'a' at eval-\"\" time\n"; - print "not " unless $^H & 0x00020000; - print "ok 14 - \$^H contains HINT_LOCALIZE_HH at eval\"\"-time\n"; - } - *; + print "ok 7 - \$^H{foo} doesn't exist at runtime\n"; } BEGIN { print "not " if exists $^H{foo}; - print "ok 7 - \$^H{foo} doesn't exist while finishing compilation\n"; - if (${^OPEN}) { - print "not " unless $^H & 0x00020000; - print "ok 8 - \$^H contains HINT_LOCALIZE_HH while finishing compilation with ${^OPEN}\n"; - } else { - print "not " if $^H & 0x00020000; - print "ok 8 - \$^H doesn't contain HINT_LOCALIZE_HH while finishing compilation\n"; - } + print "ok 5 - \$^H{foo} doesn't exist while finishing compilation\n"; } - -{ - BEGIN{$^H{x}=1}; - for my $tno (15..16) { - eval q( - BEGIN { - print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n"; - } - $^H{y} = 1; - ); - if ($@) { - (my $str = $@)=~s/^/# /gm; - print "not ok $tno\n$str\n"; - } - } -} - -{ - BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; } - - our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; } - print +($ri0 & 0x04000000 ? "" : "not "), "ok 17 - \$^H correct before require\n"; - print +($rf0 eq "z" ? "" : "not "), "ok 18 - \$^H{foo} correct before require\n"; - - our($ra1, $ri1, $rf1, $rfe1); - BEGIN { require "comp/hints.aux"; } - print +(!($ri1 & 0x04000000) ? "" : "not "), "ok 19 - \$^H cleared for require\n"; - print +(!defined($rf1) && !$rfe1 ? "" : "not "), "ok 20 - \$^H{foo} cleared for require\n"; - - our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; } - print +($ri2 & 0x04000000 ? "" : "not "), "ok 21 - \$^H correct after require\n"; - print +($rf2 eq "z" ? "" : "not "), "ok 22 - \$^H{foo} correct after require\n"; -} - -# [perl #73174] - -{ - my $res; - BEGIN { $^H{73174} = "foo" } - BEGIN { $res = ($^H{73174} // "") } - "" =~ /\x{100}/i; # forces loading of utf8.pm, which used to reset %^H - BEGIN { $res .= '-' . ($^H{73174} // "")} - $res .= '-' . ($^H{73174} // ""); - print $res eq "foo-foo-" ? "" : "not ", - "ok 23 - \$^H{foo} correct after /unicode/i (res=$res)\n"; -} - -# [perl #106282] Crash when tying %^H -# Tying %^H should not result in a crash when the hint hash is cloned. -# Hints should also be copied properly to inner scopes. See also -# [rt.cpan.org #73402]. -eval q` - # Do something naughty enough, and you get your module mentioned in the - # test suite. :-) - package namespace::clean::_TieHintHash; - - sub TIEHASH { bless[] } - sub STORE { $_[0][0]{$_[1]} = $_[2] } - sub FETCH { $_[0][0]{$_[1]} } - sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} } - sub NEXTKEY { each %{$_[0][0]} } - - package main; - - BEGIN { - $^H{foo} = "bar"; # activate localisation magic - tie( %^H, 'namespace::clean::_TieHintHash' ); # sabotage %^H - $^H{foo} = "bar"; # create an element in the tied hash - } - { # clone the tied hint hash on scope entry - BEGIN { - print "not " x ($^H{foo} ne 'bar'), - "ok 24 - tied hint hash is copied to inner scope\n"; - %^H = (); - tie( %^H, 'namespace::clean::_TieHintHash' ); - $^H{foo} = "bar"; - } - { - BEGIN{ - print - "not " x ($^H{foo} ne 'bar'), - "ok 25 - tied empty hint hash is copied to inner scope\n" - } - } - 1; - } - 1; -` or warn $@; -print "ok 26 - no crash when cloning a tied hint hash\n"; - -{ - my $w; - local $SIG{__WARN__} = sub { $w = shift }; - eval q` - package namespace::clean::_TieHintHasi; - - sub TIEHASH { bless[] } - sub STORE { $_[0][0]{$_[1]} = $_[2] } - sub FETCH { $_[0][0]{$_[1]} } - sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} } - # Intentionally commented out: - # sub NEXTKEY { each %{$_[0][0]} } - - package main; - - BEGIN { - $^H{foo} = "bar"; # activate localisation magic - tie( %^H, 'namespace::clean::_TieHintHasi' ); # sabotage %^H - $^H{foo} = "bar"; # create an element in the tied hash - } - { ; } # clone the tied hint hash - `; - print "not " if $w; - print "ok 27 - double-freeing explosive tied hints hash\n"; - print "# got: $w" if $w; -} - -# Setting ${^WARNING_HINTS} to its own value should not change things. -{ - my $w; - local $SIG{__WARN__} = sub { $w++ }; - BEGIN { - # should have no effect: - my $x = ${^WARNING_BITS}; - ${^WARNING_BITS} = $x; - } - { - local $^W = 1; - () = 1 + undef; - } - print "# ", $w//'no', " warnings\nnot " unless $w == 1; - print "ok 28 - ", - "setting \${^WARNING_BITS} to its own value has no effect\n"; -} - -# [perl #112326] -# this code could cause a crash, due to PL_hints continuing to point to th -# hints hash currently being freed - -{ - package Foo; - my @h = qw(a 1 b 2); - BEGIN { - $^H{FOO} = bless {}; - } - sub DESTROY { - @h = %^H; - delete $INC{strict}; require strict; # boom! - } - my $h = join ':', %h; - # this isn't the main point of the test; the main point is that - # it doesn't crash! - print "not " if $h ne ''; - print "ok 29 - #112326\n"; -} - - -# [perl #112444] -# A destructor called while %^H is freed should not be able to stop %^H -# from being magical (due to *^H{HASH} being undef). -{ - BEGIN { - # Make sure %^H is clear and not localised, to begin with - %^H = (); - $^H = 0; - } - DESTROY { %^H } - { - { - BEGIN { - $^H{foom} = bless[]; - } - } # scope exit triggers destructor, which autovivifies a non- - # magical %^H - BEGIN { - # Here we have the %^H created by DESTROY, which is - # not localised - $^H{112444} = 'baz'; - } - } # %^H leaks on scope exit - BEGIN { @keez = keys %^H } -} -print "not " if @keez; -print "ok 30 - %^H does not leak when autovivified in destructor\n"; -print "# keys are: @keez\n" if @keez; - - -# Add new tests above this require, in case it fails. -require './test.pl'; - -# bug #27040: hints hash was being double-freed -my $result = runperl( - prog => '$^H |= 0x20000; eval q{BEGIN { $^H |= 0x20000 }}', - stderr => 1 -); -print "not " if length $result; -print "ok 31 - double-freeing hints hash\n"; -print "# got: $result\n" if length $result; - -__END__ -# Add new tests above require 'test.pl' diff --git a/gnu/usr.bin/perl/t/io/crlf.t b/gnu/usr.bin/perl/t/io/crlf.t index f26ea0d85eb..08ab4fe3b09 100644 --- a/gnu/usr.bin/perl/t/io/crlf.t +++ b/gnu/usr.bin/perl/t/io/crlf.t @@ -3,92 +3,42 @@ BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); - require "test.pl"; - skip_all_without_perlio(); } use Config; +require "test.pl"; -my $file = tempfile(); - -my $ungetc_count = 8200; # Somewhat over the likely buffer size - -{ - plan(tests => 16 + 2 * $ungetc_count); - ok(open(FOO,">:crlf",$file)); - ok(print FOO 'a'.((('a' x 14).qq{\n}) x 2000) || close(FOO)); - ok(open(FOO,"<:crlf",$file)); - - my $text; - { local $/; $text = } - is(count_chars($text, "\015\012"), 0); - is(count_chars($text, "\n"), 2000); - - binmode(FOO); - seek(FOO,0,0); - { local $/; $text = } - is(count_chars($text, "\015\012"), 2000); - - SKIP: - { - skip_if_miniperl("miniperl can't rely on loading PerlIO::scalar", - 2 * $ungetc_count + 1); - skip("no PerlIO::scalar", 2 * $ungetc_count + 1) - unless $Config{extensions} =~ m!\bPerlIO/scalar\b!; - require PerlIO::scalar; - my $fcontents = join "", map {"$_\015\012"} "a".."zzz"; - open my $fh, "<:crlf", \$fcontents; - local $/ = "xxx"; - local $_ = <$fh>; - my $pos = tell $fh; # pos must be behind "xxx", before "\nxxy\n" - seek $fh, $pos, 0; - $/ = "\n"; - $s = <$fh>.<$fh>; - is($s, "\nxxy\n"); +my $file = "crlf$$.dat"; +END { + unlink($file); +} - for my $i (0 .. $ungetc_count - 1) { - my $j = $i % 256; - is($fh->ungetc($j), $j, "ungetc of $j returns itself"); - } +if (find PerlIO::Layer 'perlio') { + plan(tests => 7); + ok(open(FOO,">:crlf",$file)); + ok(print FOO 'a'.((('a' x 14).qq{\n}) x 2000) || close(FOO)); + ok(open(FOO,"<:crlf",$file)); - for (my $i = $ungetc_count - 1; $i >= 0; $i--) { - my $j = $i % 256; - is(ord($fh->getc()), $j, "getc gets back $j"); - } - } + my $text; + { local $/; $text = } + is(count_chars($text, "\015\012"), 0); + is(count_chars($text, "\n"), 2000); - ok(close(FOO)); + binmode(FOO); + seek(FOO,0,0); + { local $/; $text = } + is(count_chars($text, "\015\012"), 2000); - # binmode :crlf should not cumulate. - # Try it first once and then twice so that even UNIXy boxes - # get to exercise this, for DOSish boxes even once is enough. - # Try also pushing :utf8 first so that there are other layers - # in between (this should not matter: CRLF layers still should - # not accumulate). - for my $utf8 ('', ':utf8') { - for my $binmode (1..2) { - open(FOO, ">$file"); - # require PerlIO; print PerlIO::get_layers(FOO), "\n"; - binmode(FOO, "$utf8:crlf") for 1..$binmode; - # require PerlIO; print PerlIO::get_layers(FOO), "\n"; - print FOO "Hello\n"; - close FOO; - open(FOO, "<$file"); - binmode(FOO); - my $foo = scalar ; - close FOO; - print join(" ", "#", map { sprintf("%02x", $_) } unpack("C*", $foo)), - "\n"; - like($foo, qr/\x0d\x0a$/); - unlike($foo, qr/\x0d\x0d/); - } - } + ok(close(FOO)); +} +else { + skip_all("No perlio, so no :crlf"); } sub count_chars { - my($text, $chars) = @_; - my $seen = 0; - $seen++ while $text =~ /$chars/g; - return $seen; + my($text, $chars) = @_; + my $seen = 0; + $seen++ while $text =~ /$chars/g; + return $seen; } diff --git a/gnu/usr.bin/perl/t/io/utf8.t b/gnu/usr.bin/perl/t/io/utf8.t index acce07e900d..e1ecf1c4336 100644 --- a/gnu/usr.bin/perl/t/io/utf8.t +++ b/gnu/usr.bin/perl/t/io/utf8.t @@ -3,121 +3,144 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; - require './test.pl'; - skip_all_without_perlio(); + unless (find PerlIO::Layer 'perlio') { + print "1..0 # Skip: not perlio\n"; + exit 0; + } } no utf8; # needed for use utf8 not griping about the raw octets - -plan(tests => 63); - $| = 1; +print "1..31\n"; -my $a_file = tempfile(); - -open(F,"+>:utf8",$a_file); +open(F,"+>:utf8",'a'); print F chr(0x100).'£'; -cmp_ok( tell(F), '==', 4, tell(F) ); +print '#'.tell(F)."\n"; +print "not " unless tell(F) == 4; +print "ok 1\n"; print F "\n"; -cmp_ok( tell(F), '>=', 5, tell(F) ); +print '#'.tell(F)."\n"; +print "not " unless tell(F) >= 5; +print "ok 2\n"; seek(F,0,0); -is( getc(F), chr(0x100) ); -is( getc(F), "£" ); -is( getc(F), "\n" ); +print "not " unless getc(F) eq chr(0x100); +print "ok 3\n"; +print "not " unless getc(F) eq "£"; +print "ok 4\n"; +print "not " unless getc(F) eq "\n"; +print "ok 5\n"; seek(F,0,0); binmode(F,":bytes"); my $chr = chr(0xc4); -if (ord($a_file) == 193) { $chr = chr(0x8c); } # EBCDIC -is( getc(F), $chr ); +if (ord('A') == 193) { $chr = chr(0x8c); } # EBCDIC +print "not " unless getc(F) eq $chr; +print "ok 6\n"; $chr = chr(0x80); -if (ord($a_file) == 193) { $chr = chr(0x41); } # EBCDIC -is( getc(F), $chr ); +if (ord('A') == 193) { $chr = chr(0x41); } # EBCDIC +print "not " unless getc(F) eq $chr; +print "ok 7\n"; $chr = chr(0xc2); -if (ord($a_file) == 193) { $chr = chr(0x80); } # EBCDIC -is( getc(F), $chr ); +if (ord('A') == 193) { $chr = chr(0x80); } # EBCDIC +print "not " unless getc(F) eq $chr; +print "ok 8\n"; $chr = chr(0xa3); -if (ord($a_file) == 193) { $chr = chr(0x44); } # EBCDIC -is( getc(F), $chr ); -is( getc(F), "\n" ); +if (ord('A') == 193) { $chr = chr(0x44); } # EBCDIC +print "not " unless getc(F) eq $chr; +print "ok 9\n"; +print "not " unless getc(F) eq "\n"; +print "ok 10\n"; seek(F,0,0); binmode(F,":utf8"); -is( scalar(), "\x{100}£\n" ); +print "not " unless scalar() eq "\x{100}£\n"; +print "ok 11\n"; seek(F,0,0); $buf = chr(0x200); $count = read(F,$buf,2,1); -cmp_ok( $count, '==', 2 ); -is( $buf, "\x{200}\x{100}£" ); +print "not " unless $count == 2; +print "ok 12\n"; +print "not " unless $buf eq "\x{200}\x{100}£"; +print "ok 13\n"; close(F); { $a = chr(300); # This *is* UTF-encoded $b = chr(130); # This is not. - open F, ">:utf8", $a_file or die $!; + open F, ">:utf8", 'a' or die $!; print F $a,"\n"; close F; - open F, "<:utf8", $a_file or die $!; + open F, "<:utf8", 'a' or die $!; $x = ; chomp($x); - is( $x, chr(300) ); + print "not " unless $x eq chr(300); + print "ok 14\n"; - open F, $a_file or die $!; # Not UTF + open F, "a" or die $!; # Not UTF binmode(F, ":bytes"); $x = ; chomp($x); $chr = chr(196).chr(172); - if (ord($a_file) == 193) { $chr = chr(141).chr(83); } # EBCDIC - is( $x, $chr ); + if (ord('A') == 193) { $chr = chr(141).chr(83); } # EBCDIC + print "not " unless $x eq $chr; + print "ok 15\n"; close F; - open F, ">:utf8", $a_file or die $!; + open F, ">:utf8", 'a' or die $!; binmode(F); # we write a "\n" and then tell() - avoid CRLF issues. binmode(F,":utf8"); # turn UTF-8-ness back on print F $a; my $y; { my $x = tell(F); { use bytes; $y = length($a);} - cmp_ok( $x, '==', $y ); + print "not " unless $x == $y; + print "ok 16\n"; } { # Check byte length of $b use bytes; my $y = length($b); - cmp_ok( $y, '==', 1 ); + print "not " unless $y == 1; + print "ok 17\n"; } print F $b,"\n"; # Don't upgrades $b { # Check byte length of $b use bytes; my $y = length($b); - cmp_ok( $y, '==', 1 ); + print "not ($y) " unless $y == 1; + print "ok 18\n"; } { my $x = tell(F); { use bytes; if (ord('A')==193){$y += 2;}else{$y += 3;}} # EBCDIC ASCII - cmp_ok( $x, '==', $y ); + print "not ($x,$y) " unless $x == $y; + print "ok 19\n"; } close F; - open F, $a_file or die $!; # Not UTF + open F, "a" or die $!; # Not UTF binmode(F, ":bytes"); $x = ; chomp($x); $chr = v196.172.194.130; if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC - is( $x, $chr, sprintf('(%vd)', $x) ); + printf "not (%vd) ", $x unless $x eq $chr; + print "ok 20\n"; - open F, "<:utf8", $a_file or die $!; + open F, "<:utf8", "a" or die $!; $x = ; chomp($x); close F; - is( $x, chr(300).chr(130), sprintf('(%vd)', $x) ); + printf "not (%vd) ", $x unless $x eq chr(300).chr(130); + print "ok 21\n"; - open F, ">", $a_file or die $!; - binmode(F, ":bytes:"); + open F, ">", "a" or die $!; + if (${^OPEN} =~ /:utf8/) { + binmode(F, ":bytes:"); + } # Now let's make it suffer. my $w; @@ -125,63 +148,54 @@ close(F); use warnings 'utf8'; local $SIG{__WARN__} = sub { $w = $_[0] }; print F $a; - ok( (!$@)); - like($w, qr/Wide character in print/i ); + print "not " if ($@ || $w !~ /Wide character in print/i); } + print "ok 22\n"; } # Hm. Time to get more evil. -open F, ">:utf8", $a_file or die $!; +open F, ">:utf8", "a" or die $!; print F $a; binmode(F, ":bytes"); print F chr(130)."\n"; close F; -open F, "<", $a_file or die $!; +open F, "<", "a" or die $!; binmode(F, ":bytes"); $x = ; chomp $x; $chr = v196.172.130; if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC -is( $x, $chr ); +print "not " unless $x eq $chr; +print "ok 23\n"; # Right. -open F, ">:utf8", $a_file or die $!; +open F, ">:utf8", "a" or die $!; print F $a; close F; -open F, ">>", $a_file or die $!; -binmode(F, ":bytes"); +open F, ">>", "a" or die $!; print F chr(130)."\n"; close F; -open F, "<", $a_file or die $!; -binmode(F, ":bytes"); +open F, "<", "a" or die $!; $x = ; chomp $x; -SKIP: { - skip("Defaulting to UTF-8 output means that we can't generate a mangled file") - if $UTF8_OUTPUT; - is( $x, $chr ); -} +print "not " unless $x eq $chr; +print "ok 24\n"; # Now we have a deformed file. -SKIP: { - if (ord('A') == 193) { - skip("EBCDIC doesn't complain", 2); - } else { - my @warnings; - open F, "<:utf8", $a_file or die $!; - $x = ; chomp $x; - local $SIG{__WARN__} = sub { push @warnings, $_[0]; }; - eval { sprintf "%vd\n", $x }; - is (scalar @warnings, 1); - like ($warnings[0], qr/Malformed UTF-8 character \(unexpected continuation byte 0x82, with no preceding start byte/); - } +if (ord('A') == 193) { + print "ok 25 # Skip: EBCDIC\n"; # EBCDIC doesn't complain +} else { + open F, "<:utf8", "a" or die $!; + $x = ; chomp $x; + local $SIG{__WARN__} = sub { print "ok 25\n" }; + eval { sprintf "%vd\n", $x }; } close F; -unlink($a_file); +unlink('a'); -open F, ">:utf8", $a_file; +open F, ">:utf8", "a"; @a = map { chr(1 << ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000 unshift @a, chr(0); # ... and a null byte in front just for fun print F @a; @@ -190,9 +204,8 @@ close F; my $c; # read() should work on characters, not bytes -open F, "<:utf8", $a_file; +open F, "<:utf8", "a"; $a = 0; -my $failed; for (@a) { unless (($c = read(F, $b, 1) == 1) && length($b) == 1 && @@ -205,12 +218,12 @@ for (@a) { print '# tell(F) == ', tell(F), "\n"; print '# $a == ', $a, "\n"; print '# $c == ', $c, "\n"; - $failed++; + print "not "; last; } } close F; -is($failed, undef); +print "ok 26\n"; { # Check that warnings are on on I/O, and that they can be muffled. @@ -218,184 +231,52 @@ is($failed, undef); local $SIG{__WARN__} = sub { $@ = shift }; undef $@; - open F, ">$a_file"; + open F, ">a"; binmode(F, ":bytes"); print F chr(0x100); close(F); - like( $@, 'Wide character in print' ); + print $@ =~ /Wide character in print/ ? "ok 27\n" : "not ok 27\n"; undef $@; - open F, ">:utf8", $a_file; + open F, ">:utf8", "a"; print F chr(0x100); close(F); - isnt( defined $@, !0 ); + print defined $@ ? "not ok 28\n" : "ok 28\n"; undef $@; - open F, ">$a_file"; + open F, ">a"; binmode(F, ":utf8"); print F chr(0x100); close(F); - isnt( defined $@, !0 ); + print defined $@ ? "not ok 29\n" : "ok 29\n"; no warnings 'utf8'; undef $@; - open F, ">$a_file"; + open F, ">a"; print F chr(0x100); close(F); - isnt( defined $@, !0 ); + print defined $@ ? "not ok 30\n" : "ok 30\n"; use warnings 'utf8'; undef $@; - open F, ">$a_file"; + open F, ">a"; binmode(F, ":bytes"); print F chr(0x100); close(F); - like( $@, 'Wide character in print' ); -} - -{ - open F, ">:bytes",$a_file; print F "\xde"; close F; - - open F, "<:bytes", $a_file; - my $b = chr 0x100; - $b .= ; - is( $b, chr(0x100).chr(0xde), "21395 '.= <>' utf8 vs. bytes" ); - close F; -} - -{ - open F, ">:utf8",$a_file; print F chr 0x100; close F; - - open F, "<:utf8", $a_file; - my $b = "\xde"; - $b .= ; - is( $b, chr(0xde).chr(0x100), "21395 '.= <>' bytes vs. utf8" ); - close F; -} - -{ - my @a = ( [ 0x007F, "bytes" ], - [ 0x0080, "bytes" ], - [ 0x0080, "utf8" ], - [ 0x0100, "utf8" ] ); - my $t = 34; - for my $u (@a) { - for my $v (@a) { - # print "# @$u - @$v\n"; - open F, ">$a_file"; - binmode(F, ":" . $u->[1]); - print F chr($u->[0]); - close F; - - open F, "<$a_file"; - binmode(F, ":" . $u->[1]); - - my $s = chr($v->[0]); - utf8::upgrade($s) if $v->[1] eq "utf8"; - - $s .= ; - is( $s, chr($v->[0]) . chr($u->[0]), 'rcatline utf8' ); - close F; - $t++; - } - } - # last test here 49 -} - -{ - # [perl #23428] Somethings rotten in unicode semantics - open F, ">$a_file"; - binmode F, ":utf8"; - syswrite(F, $a = chr(0x100)); - close F; - is( ord($a), 0x100, '23428 syswrite should not downgrade scalar' ); - like( $a, qr/^\w+/, '23428 syswrite should not downgrade scalar' ); + print $@ =~ /Wide character in print/ ? "ok 31\n" : "not ok 31\n"; } -# sysread() and syswrite() tested in lib/open.t since Fcntl is used +# sysread() and syswrite() tested in lib/open.t since Fnctl is used -{ - # on a :utf8 stream should complain immediately with -w - # if it finds bad UTF-8 (:encoding(utf8) works this way) - use warnings 'utf8'; - undef $@; - local $SIG{__WARN__} = sub { $@ = shift }; - open F, ">$a_file"; - binmode F; - my ($chrE4, $chrF6) = (chr(0xE4), chr(0xF6)); - if (ord('A') == 193) # EBCDIC - { ($chrE4, $chrF6) = (chr(0x43), chr(0xEC)); } - print F "foo", $chrE4, "\n"; - print F "foo", $chrF6, "\n"; - close F; - open F, "<:utf8", $a_file; - undef $@; - my $line = ; - my ($chrE4, $chrF6) = ("E4", "F6"); - if (ord('A') == 193) { ($chrE4, $chrF6) = ("43", "EC"); } # EBCDIC - like( $@, qr/utf8 "\\x$chrE4" does not map to Unicode .+ line 1/, - "<:utf8 readline must warn about bad utf8"); - undef $@; - $line .= ; - like( $@, qr/utf8 "\\x$chrF6" does not map to Unicode .+ line 2/, - "<:utf8 rcatline must warn about bad utf8"); - close F; +END { + 1 while unlink "a"; + 1 while unlink "b"; } -{ - # fixed record reads - open F, ">:utf8", $a_file; - print F "foo\xE4"; - print F "bar\xFE"; - print F "\xC0\xC8\xCC\xD2"; - print F "a\xE4ab"; - print F "a\xE4a"; - close F; - open F, "<:utf8", $a_file; - local $/ = \4; - my $line = ; - is($line, "foo\xE4", "readline with \$/ = \\4"); - $line .= ; - is($line, "foo\xE4bar\xFE", "rcatline with \$/ = \\4"); - $line = ; - is($line, "\xC0\xC8\xCC\xD2", "readline with several encoded characters"); - $line = ; - is($line, "a\xE4ab", "readline with another boundary condition"); - $line = ; - is($line, "a\xE4a", "readline with boundary condition"); - close F; - - # badly encoded at EOF - open F, ">:raw", $a_file; - print F "foo\xEF\xAC"; # truncated \x{FB04} small ligature ffl - close F; - - use warnings 'utf8'; - open F, "<:utf8", $a_file; - undef $@; - local $SIG{__WARN__} = sub { $@ = shift }; - $line = ; - - like( $@, qr/utf8 "\\xEF" does not map to Unicode .+ chunk 1/, - "<:utf8 readline (fixed) must warn about bad utf8"); - close F; -} - -# getc should reset the utf8 flag and not be affected by previous -# return values -SKIP: { - skip "no PerlIO::scalar on miniperl", 2, if is_miniperl(); - open my $fh, "<:raw", \($buf = chr 255); - open my $uh, "<:utf8", \($uuf = "\xc4\x80"); - for([$uh,chr 256], [$fh,chr 255]) { - is getc $$_[0], $$_[1], - 'getc returning non-utf8 after utf8'; - } -} diff --git a/gnu/usr.bin/perl/t/lib/1_compile.t b/gnu/usr.bin/perl/t/lib/1_compile.t index 2802ae2ad64..45631dd5b8d 100644 --- a/gnu/usr.bin/perl/t/lib/1_compile.t +++ b/gnu/usr.bin/perl/t/lib/1_compile.t @@ -7,9 +7,9 @@ BEGIN { chdir 't'; @INC = '../lib'; - require './test.pl'; } +use strict; use warnings; use File::Spec::Functions; @@ -19,6 +19,7 @@ my @Core_Modules = grep /\S/, ; chomp @Core_Modules; if (eval { require Socket }) { + push @Core_Modules, qw(Net::Domain); # Two Net:: modules need the Convert::EBCDIC if in EBDCIC. if (ord("A") != 193 || eval { require Convert::EBCDIC }) { push @Core_Modules, qw(Net::Cmd Net::POP3); @@ -27,22 +28,24 @@ if (eval { require Socket }) { @Core_Modules = sort @Core_Modules; -plan tests => 1+@Core_Modules; +print "1..".(1+@Core_Modules)."\n"; -cmp_ok(@Core_Modules, '>', 0, "All modules should have tests"); -note("http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-04/msg01223.html"); -note("20010421230349.P2946\@blackrider.blackstar.co.uk"); +my $message + = "ok 1 - All modules should have tests # TODO Make Schwern Poorer\n"; +if (@Core_Modules) { + print "not $message"; +} else { + print $message; +} + +my $test_num = 2; foreach my $module (@Core_Modules) { - if ($module eq 'ByteLoader' && $^O eq 'VMS') { - TODO: { - local $TODO = "$module needs porting on $^O"; - ok(compile_module($module), "compile $module"); - } - } - else { - ok(compile_module($module), "compile $module"); - } + my $todo = ''; + $todo = "# TODO $module needs porting on $^O" if $module eq 'ByteLoader' && $^O eq 'VMS'; + print "# $module compile failed\nnot " unless compile_module($module); + print "ok $test_num $todo\n"; + $test_num++; } # We do this as a separate process else we'll blow the hell @@ -54,11 +57,25 @@ sub compile_module { my $lib = '-I' . catdir(updir(), 'lib'); my $out = scalar `$^X $lib $compmod $module`; + print "# $out"; return $out =~ /^ok/; } # These modules have no tests of their own. # Keep up to date with -# http://perl-qa.hexten.net/wiki/index.php/Untested_Core_Modules +# http://www.pobox.com/~schwern/cgi-bin/perl-qa-wiki.cgi?UntestedModules # and vice-versa. The list should only shrink. __DATA__ +B::C +B::CC +B::Stackobj +ByteLoader +CPAN +CPAN::FirstTime +DynaLoader +ExtUtils::MM_NW5 +ExtUtils::Install +ExtUtils::Liblist +ExtUtils::Mksymlists +Pod::Plainer +Test::Harness::Iterator diff --git a/gnu/usr.bin/perl/t/lib/strict/refs b/gnu/usr.bin/perl/t/lib/strict/refs index e74851220e7..10599b0bb28 100644 --- a/gnu/usr.bin/perl/t/lib/strict/refs +++ b/gnu/usr.bin/perl/t/lib/strict/refs @@ -17,37 +17,6 @@ EXPECT ######## -# strict refs - error -use strict ; -my $str="A::Really::Big::Package::Name::To::Use"; -$str->{foo}= 1; -EXPECT -Can't use string ("A::Really::Big::Package::Name::T"...) as a HASH ref while "strict refs" in use at - line 5. -######## - -# strict refs - error -use strict ; -"A::Really::Big::Package::Name::To::Use" =~ /(.*)/; -${$1}; -EXPECT -Can't use string ("A::Really::Big::Package::Name::T"...) as a SCALAR ref while "strict refs" in use at - line 5. -######## - -# strict refs - error -use strict ; -*{"A::Really::Big::Package::Name::To::Use"; } -EXPECT -Can't use string ("A::Really::Big::Package::Name::T"...) as a symbol ref while "strict refs" in use at - line 4. -######## - -# strict refs - error -use strict ; -"A::Really::Big::Package::Name::To::Use" =~ /(.*)/; -*{$1} -EXPECT -Can't use string ("A::Really::Big::Package::Name::T"...) as a symbol ref while "strict refs" in use at - line 5. -######## - # strict refs - error use strict ; my $fred ; @@ -326,48 +295,3 @@ eval ' my $a = ${"Fred"} ; EXPECT Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 8. -######## -# [perl #26910] hints not propagated into (?{...}) -use strict 'refs'; -/(?{${"foo"}++})/; -EXPECT -Can't use string ("foo") as a SCALAR ref while "strict refs" in use at - line 3. -######## -# [perl #37886] strict 'refs' doesn't apply inside defined -use strict 'refs'; -my $x = "foo"; -defined $$x; -EXPECT -Can't use string ("foo") as a SCALAR ref while "strict refs" in use at - line 4. -######## -# [perl #37886] strict 'refs' doesn't apply inside defined -use strict 'refs'; -my $x = "foo"; -defined @$x; -EXPECT -defined(@array) is deprecated at - line 4. - (Maybe you should just omit the defined()?) -Can't use string ("foo") as an ARRAY ref while "strict refs" in use at - line 4. -######## -# [perl #37886] strict 'refs' doesn't apply inside defined -use strict 'refs'; -my $x = "foo"; -defined %$x; -EXPECT -defined(%hash) is deprecated at - line 4. - (Maybe you should just omit the defined()?) -Can't use string ("foo") as a HASH ref while "strict refs" in use at - line 4. -######## -# [perl #74168] Assertion failed: (SvTYPE(_svcur) >= SVt_PV), function Perl_softref2xv, file pp.c, line 240. -use strict 'refs'; -my $o = 1 ; $o->{1} ; -EXPECT -Can't use string ("1") as a HASH ref while "strict refs" in use at - line 3. -######## -# pp_hot.c [pp_entersub] -use strict 'refs'; -use utf8; -use open qw( :utf8 :std ); -&{"Ｆ"}; -EXPECT -Can't use string ("Ｆ") as a subroutine ref while "strict refs" in use at - line 5. diff --git a/gnu/usr.bin/perl/t/lib/strict/subs b/gnu/usr.bin/perl/t/lib/strict/subs index 5fd0b03de7f..4a90809020f 100644 --- a/gnu/usr.bin/perl/t/lib/strict/subs +++ b/gnu/usr.bin/perl/t/lib/strict/subs @@ -45,8 +45,8 @@ Execution of - aborted due to compilation errors. use strict 'subs' ; my @a = (A..Z); EXPECT -Bareword "A" not allowed while "strict subs" in use at - line 4. Bareword "Z" not allowed while "strict subs" in use at - line 4. +Bareword "A" not allowed while "strict subs" in use at - line 4. Execution of - aborted due to compilation errors. ######## @@ -54,8 +54,8 @@ Execution of - aborted due to compilation errors. use strict 'subs' ; my $a = (B..Y); EXPECT -Bareword "B" not allowed while "strict subs" in use at - line 4. Bareword "Y" not allowed while "strict subs" in use at - line 4. +Bareword "B" not allowed while "strict subs" in use at - line 4. Execution of - aborted due to compilation errors. ######## @@ -345,116 +345,3 @@ print "$abc\n"; EXPECT Bareword "XYZ" not allowed while "strict subs" in use at - line 5. Execution of - aborted due to compilation errors. -######## - -# [perl #10021] -use strict; -use warnings; -print "" if BAREWORD; -EXPECT -Bareword "BAREWORD" not allowed while "strict subs" in use at - line 5. -Execution of - aborted due to compilation errors. -######## -# Ticket: 18927 -use strict 'subs'; -print 1..1, bad; -EXPECT -Bareword "bad" not allowed while "strict subs" in use at - line 3. -Execution of - aborted due to compilation errors. -######## -eval q{ use strict; no strict refs; }; -print $@; -EXPECT -Bareword "refs" not allowed while "strict subs" in use at (eval 1) line 1. -######## -# [perl #25147] -use strict; -print "" if BAREWORD; -EXPECT -Bareword "BAREWORD" not allowed while "strict subs" in use at - line 3. -Execution of - aborted due to compilation errors. -######## -# [perl #26910] hints not propagated into (?{...}) -use strict 'subs'; -qr/(?{my $x=foo})/; -EXPECT -Bareword "foo" not allowed while "strict subs" in use at - line 3. -Execution of - aborted due to compilation errors. -######## -# Regexp compilation errors weren't UTF-8 clean -use strict 'subs'; -use utf8; -use open qw( :utf8 :std ); -qr/(?{my $x=fòò})/; -EXPECT -Bareword "fòò" not allowed while "strict subs" in use at - line 5. -Execution of - aborted due to compilation errors. -######## -# [perl #27628] strict 'subs' didn't warn on bareword array index -use strict 'subs'; -my $x=$a[FOO]; -EXPECT -Bareword "FOO" not allowed while "strict subs" in use at - line 3. -Execution of - aborted due to compilation errors. -######## -use strict 'subs'; -my @a;my $x=$a[FOO]; -EXPECT -Bareword "FOO" not allowed while "strict subs" in use at - line 2. -Execution of - aborted due to compilation errors. -######## -# [perl #53806] No complain about bareword -use strict 'subs'; -print FOO . "\n"; -EXPECT -Bareword "FOO" not allowed while "strict subs" in use at - line 3. -Execution of - aborted due to compilation errors. -######## -# [perl #53806] No complain about bareword -use strict 'subs'; -$ENV{PATH} = ""; -system(FOO . "\n"); -EXPECT -Bareword "FOO" not allowed while "strict subs" in use at - line 4. -Execution of - aborted due to compilation errors. -######## -use strict 'subs'; -my @players; -eval { @players = sort(_rankCompare @players) }; -sub _rankCompare2 { } -@players = sort(_rankCompare2 @players); -EXPECT - -######## -use strict; -readline(FOO); -EXPECT - -######## -use strict 'subs'; -sub sayfoo { print "foo:@_\n" ; "ret\n" } -print sayfoo "bar"; -print sayfoo . "bar\n"; -EXPECT -foo:bar -ret -foo: -ret -bar -######## -# infinite loop breaks some strict checking -use strict 'subs'; -sub foo { - 1 while 1; - kill FOO, 1; -} -EXPECT -Bareword "FOO" not allowed while "strict subs" in use at - line 5. -Execution of - aborted due to compilation errors. -######## -# make sure checks are done within (?{}) -use strict 'subs'; -/(?{FOO})/ -EXPECT -Bareword "FOO" not allowed while "strict subs" in use at - line 3. -Execution of - aborted due to compilation errors. diff --git a/gnu/usr.bin/perl/t/lib/strict/vars b/gnu/usr.bin/perl/t/lib/strict/vars index c6cb0679396..de517078be1 100644 --- a/gnu/usr.bin/perl/t/lib/strict/vars +++ b/gnu/usr.bin/perl/t/lib/strict/vars @@ -82,21 +82,6 @@ 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 -use strict 'vars' ; -use utf8; -use open qw( :utf8 :std ); -{ - no strict ; - $jòè = 1 ; -} -$jòè = 1 ; -EXPECT -Variable "$jòè" is not imported at - line 10. -Global symbol "$jòè" requires explicit package name at - line 10. -Execution of - aborted due to compilation errors. -######## - # Check compile time scope of strict vars pragma no strict; { @@ -142,23 +127,6 @@ Global symbol "$joe" requires explicit package name at ./abc line 2. Compilation failed in require at - line 2. ######## ---FILE-- abc -use strict 'vars' ; -use utf8; -use open qw( :utf8 :std ); -$jòè = 1 ; -1; ---FILE-- -use utf8; -use open qw( :utf8 :std ); -$jòè = 1 ; -require "./abc"; -EXPECT -Variable "$jòè" is not imported at ./abc line 4. -Global symbol "$jòè" requires explicit package name at ./abc line 4. -Compilation failed in require at - line 4. -######## - --FILE-- abc.pm use strict 'vars' ; $joe = 1 ; @@ -173,24 +141,6 @@ Compilation failed in require at - line 2. BEGIN failed--compilation aborted at - line 2. ######## ---FILE-- abc.pm -use strict 'vars' ; -use utf8; -use open qw( :utf8 :std ); -$jòè = 1 ; -1; ---FILE-- -use utf8; -use open qw( :utf8 :std ); -$jòè = 1 ; -use abc; -EXPECT -Variable "$jòè" is not imported at abc.pm line 4. -Global symbol "$jòè" requires explicit package name at abc.pm line 4. -Compilation failed in require at - line 4. -BEGIN failed--compilation aborted at - line 4. -######## - --FILE-- abc.pm package Burp; use strict; @@ -274,22 +224,6 @@ Global symbol "$joe" requires explicit package name at - line 9. Execution of - aborted due to compilation errors. ######## -# Check scope of pragma with eval -use strict 'vars' ; -use utf8; -use open qw( :utf8 :std ); -eval { - no strict ; - $jòè = 1 ; -}; -print STDERR $@; -$jòè = 1 ; -EXPECT -Variable "$jòè" is not imported at - line 11. -Global symbol "$jòè" requires explicit package name at - line 11. -Execution of - aborted due to compilation errors. -######## - # Check scope of pragma with eval no strict ; eval ' @@ -403,21 +337,6 @@ Global symbol "$fred" requires explicit package name at - line 8. Execution of - aborted due to compilation errors. ######## -# strict vars with elapsed our - error -use strict 'vars' ; -use utf8; -use open qw( :utf8 :std ); -sub fòò { - our $frèd; - $frèd; -} -$frèd ; -EXPECT -Variable "$frèd" is not imported at - line 10. -Global symbol "$frèd" requires explicit package name at - line 10. -Execution of - aborted due to compilation errors. -######## - # nested our with local - no error $fred = 1; use strict 'vars'; @@ -460,7 +379,7 @@ our $foo; ${foo} = 10; our $foo; EXPECT -"our" variable $foo redeclared at - line 7. +"our" variable $foo masks earlier declaration in same scope at - line 7. ######## # multiple our declarations in same scope, same package, warning @@ -470,7 +389,6 @@ use warnings; { our $x = 0 } our $foo; { - our $foo; our $foo; package Foo; our $foo; @@ -478,7 +396,6 @@ our $foo; EXPECT "our" variable $foo redeclared at - line 9. (Did you mean "local" instead of "our"?) -"our" variable $foo redeclared at - line 10. ######## --FILE-- abc @@ -496,7 +413,7 @@ ok ######## # Make sure the strict vars failure still occurs -# now that the '@i should be written as \@i' failure does not occur +# now that the `@i should be written as \@i' failure does not occur # 20000522 mjd@plover.com (MJD) use strict 'vars'; no warnings; @@ -504,72 +421,3 @@ no warnings; EXPECT Global symbol "@i_like_crackers" requires explicit package name at - line 7. Execution of - aborted due to compilation errors. -######## - -# [perl #21914] New bug > 5.8.0. Used to dump core. -use strict 'vars'; -@k = <$k>; -EXPECT -Global symbol "@k" requires explicit package name at - line 4. -Global symbol "$k" requires explicit package name at - line 4. -Execution of - aborted due to compilation errors. -######## -# [perl #26910] hints not propagated into (?{...}) -use strict 'vars'; -qr/(?{$foo++})/; -EXPECT -Global symbol "$foo" requires explicit package name at - line 3. -Execution of - aborted due to compilation errors. -######## -# Regex compilation errors weren't UTF-8 clean. -use strict 'vars'; -use utf8; -use open qw( :utf8 :std ); -qr/(?{$fòò++})/; -EXPECT -Global symbol "$fòò" requires explicit package name at - line 5. -Execution of - aborted due to compilation errors. -######## -# [perl #73712] 'Variable is not imported' should be suppressible -$dweck; -use strict 'vars'; -no warnings; -eval q/$dweck/; -EXPECT -######## -# [perl #112316] strict vars getting confused by nulls -# Assigning to a package whose name contains a null -BEGIN { *Foo:: = *{"foo\0bar::"} } -package foo; -*Foo::bar = []; -use strict; -eval 'package Foo; @bar = 1' or die; -EXPECT -######## -# [perl #112316] strict vars getting confused by nulls -# Assigning from within a package whose name contains a null -BEGIN { *Foo:: = *{"foo\0bar::"} } -package Foo; -*foo::bar = []; -use strict; -eval 'package foo; @bar = 1' or die; -EXPECT -######## -# [perl #112316] strict vars getting confused by nulls -# Assigning from one null package to another, with a common prefix -BEGIN { *Foo:: = *{"foo\0foo::"}; - *Bar:: = *{"foo\0bar::"} } -package Foo; -*Bar::bar = []; -use strict; -eval 'package Bar; @bar = 1' or die; -EXPECT -######## -# UTF8 and Latin1 package names equivalent at the byte level -use utf8; -# ĵ in UTF-8 is the same as ĵ in Latin-1 -package ĵ; -*ĵ::bar = []; -use strict; -eval 'package ĵ; @bar = 1' or die; -EXPECT diff --git a/gnu/usr.bin/perl/t/lib/warnings/7fatal b/gnu/usr.bin/perl/t/lib/warnings/7fatal index 32d2f19a361..a3e70f8d50f 100644 --- a/gnu/usr.bin/perl/t/lib/warnings/7fatal +++ b/gnu/usr.bin/perl/t/lib/warnings/7fatal @@ -35,7 +35,7 @@ use warnings FATAL => 'uninitialized' ; my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value $b in scalar chop at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check runtime scope of pragma @@ -47,7 +47,7 @@ use warnings FATAL => 'all' ; my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value $b in scalar chop at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check runtime scope of pragma @@ -59,7 +59,7 @@ no warnings ; &$a ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value $b in scalar chop at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## # Check runtime scope of pragma @@ -71,7 +71,7 @@ no warnings ; &$a ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value $b in scalar chop at - line 6. +Use of uninitialized value in scalar chop at - line 6. ######## --FILE-- abc @@ -105,7 +105,7 @@ my $a ; chop $a ; print STDERR "The End.\n" ; EXPECT Reversed += operator at ./abc line 2. -Use of uninitialized value $a in scalar chop at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## --FILE-- abc.pm @@ -119,7 +119,7 @@ my $a ; chop $a ; print STDERR "The End.\n" ; EXPECT Reversed += operator at abc.pm line 2. -Use of uninitialized value $a in scalar chop at - line 3. +Use of uninitialized value in scalar chop at - line 3. ######## # Check scope of pragma with eval @@ -131,7 +131,7 @@ eval { my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT --- Use of uninitialized value $b in scalar chop at - line 6. +-- Use of uninitialized value in scalar chop at - line 6. The End. ######## @@ -143,8 +143,8 @@ eval { my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT --- Use of uninitialized value $b in scalar chop at - line 5. -Use of uninitialized value $b in scalar chop at - line 7. +-- Use of uninitialized value in scalar chop at - line 5. +Use of uninitialized value in scalar chop at - line 7. ######## # Check scope of pragma with eval @@ -156,7 +156,7 @@ eval { my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value $b in scalar chop at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check scope of pragma with eval @@ -214,7 +214,7 @@ eval q[ my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT --- Use of uninitialized value $b in scalar chop at (eval 1) line 3. +-- Use of uninitialized value in scalar chop at (eval 1) line 3. The End. ######## @@ -226,8 +226,8 @@ eval ' my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT --- Use of uninitialized value $b in scalar chop at (eval 1) line 2. -Use of uninitialized value $b in scalar chop at - line 7. +-- Use of uninitialized value in scalar chop at (eval 1) line 2. +Use of uninitialized value in scalar chop at - line 7. ######## # Check scope of pragma with eval @@ -239,7 +239,7 @@ eval ' my $b ; chop $b ; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value $b in scalar chop at - line 8. +Use of uninitialized value in scalar chop at - line 8. ######## # Check scope of pragma with eval @@ -277,7 +277,6 @@ print STDERR "The End.\n" ; EXPECT Reversed += operator at - line 8. ######## -# TODO ? !$Config{usethreads} && $::UTF8 && ($ENV{PERL_DESTRUCT_LEVEL} || 0) > 1 ? "Parser leaks OPs, which leak shared hash keys" : '' use warnings 'void' ; @@ -285,8 +284,7 @@ time ; { use warnings FATAL => qw(void) ; - $a = "abc"; - length $a ; + length "abc" ; } join "", 1,2,3 ; @@ -294,9 +292,8 @@ join "", 1,2,3 ; print "done\n" ; EXPECT Useless use of time in void context at - line 4. -Useless use of length in void context at - line 9. +Useless use of length in void context at - line 8. ######## -# TODO ? !$Config{usethreads} && $::UTF8 && ($ENV{PERL_DESTRUCT_LEVEL} || 0) > 1 ? "Parser leaks OPs, which leak shared hash keys" : '' use warnings ; @@ -304,8 +301,7 @@ time ; { use warnings FATAL => qw(void) ; - $a = "abc"; - length $a ; + length "abc" ; } join "", 1,2,3 ; @@ -313,7 +309,7 @@ join "", 1,2,3 ; print "done\n" ; EXPECT Useless use of time in void context at - line 4. -Useless use of length in void context at - line 9. +Useless use of length in void context at - line 8. ######## use warnings FATAL => 'all'; @@ -328,8 +324,8 @@ use warnings FATAL => 'all'; my $b ; chop $b; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value $b in scalar chop at - line 8. -Use of uninitialized value $b in scalar chop at - line 11. +Use of uninitialized value in scalar chop at - line 8. +Use of uninitialized value in scalar chop at - line 11. ######## use warnings FATAL => 'all'; @@ -344,8 +340,8 @@ use warnings FATAL => 'all'; my $b ; chop $b; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value $b in scalar chop at - line 8. -Use of uninitialized value $b in scalar chop at - line 11. +Use of uninitialized value in scalar chop at - line 8. +Use of uninitialized value in scalar chop at - line 11. ######## use warnings FATAL => 'all'; @@ -359,54 +355,49 @@ use warnings FATAL => 'all'; my $b ; chop $b; print STDERR "The End.\n" ; EXPECT -Use of uninitialized value $b in scalar chop at - line 7. +Use of uninitialized value in scalar chop at - line 7. ######## use warnings FATAL => 'syntax', NONFATAL => 'void' ; -$a = "abc"; -length $a; +length "abc"; print STDERR "The End.\n" ; EXPECT -Useless use of length in void context at - line 5. +Useless use of length in void context at - line 4. The End. ######## use warnings FATAL => 'all', NONFATAL => 'void' ; -$a = "abc"; -length $a; +length "abc"; print STDERR "The End.\n" ; EXPECT -Useless use of length in void context at - line 5. +Useless use of length in void context at - line 4. The End. ######## use warnings FATAL => 'all', NONFATAL => 'void' ; my $a ; chomp $a; - -$b = "abc" ; -length $b; +length "abc"; print STDERR "The End.\n" ; EXPECT -Useless use of length in void context at - line 7. -Use of uninitialized value $a in scalar chomp at - line 4. +Useless use of length in void context at - line 5. +Use of uninitialized value in scalar chomp at - line 4. ######## use warnings FATAL => 'void', NONFATAL => 'void' ; -$a = "abc"; -length $a; + +length "abc"; print STDERR "The End.\n" ; EXPECT Useless use of length in void context at - line 4. The End. ######## -# TODO ? !$Config{usethreads} && $::UTF8 && ($ENV{PERL_DESTRUCT_LEVEL} || 0) > 1 ? "Parser leaks OPs, which leak shared hash keys" : '' use warnings NONFATAL => 'void', FATAL => 'void' ; -$a = "abc"; -length $a; + +length "abc"; print STDERR "The End.\n" ; EXPECT Useless use of length in void context at - line 4. @@ -433,102 +424,3 @@ print STDERR "The End.\n" ; EXPECT Unsuccessful open on filename containing newline at - line 5. close() on unopened filehandle fred at - line 6. -######## - -# 'use warnings' test as the basis for the following tests -use warnings ; -my $a = oct "7777777777777777777777777777777777778" ; -my $b =+ 1 ; -my $c ; chop $c ; -print STDERR "The End.\n" ; -EXPECT -Reversed += operator at - line 5. -Integer overflow in octal number at - line 4. -Illegal octal digit '8' ignored at - line 4. -Octal number > 037777777777 non-portable at - line 4. -Use of uninitialized value $c in scalar chop at - line 6. -The End. -######## - -# 'use warnings NONFATAL=>"all"' should be the same as 'use warnings' -use warnings NONFATAL=>"all" ; -my $a = oct "7777777777777777777777777777777777778" ; -my $b =+ 1 ; -my $c ; chop $c ; -print STDERR "The End.\n" ; -EXPECT -Reversed += operator at - line 5. -Integer overflow in octal number at - line 4. -Illegal octal digit '8' ignored at - line 4. -Octal number > 037777777777 non-portable at - line 4. -Use of uninitialized value $c in scalar chop at - line 6. -The End. -######## - -# 'use warnings "NONFATAL"' should be the same as 'use warnings' [perl #120977] -use warnings "NONFATAL" ; -my $a = oct "7777777777777777777777777777777777778" ; -my $b =+ 1 ; -my $c ; chop $c ; -print STDERR "The End.\n" ; -EXPECT -Reversed += operator at - line 5. -Integer overflow in octal number at - line 4. -Illegal octal digit '8' ignored at - line 4. -Octal number > 037777777777 non-portable at - line 4. -Use of uninitialized value $c in scalar chop at - line 6. -The End. -######## - -# 'use warnings "FATAL"' should be the same as 'use warnings FATAL=>"all"' [perl #120977] -use warnings "FATAL" ; -{ - no warnings ; - my $a =+ 1 ; -} -my $a =+ 1 ; -print STDERR "The End.\n" ; -EXPECT -Reversed += operator at - line 8. -######## - -# 'use warnings "FATAL"' should be the same as 'use warnings FATAL=>"all"' [perl #120977] -use warnings "FATAL" ; -{ - no warnings ; - my $a = oct "7777777777777777777777777777777777778" ; -} -my $a = oct "7777777777777777777777777777777777778" ; -print STDERR "The End.\n" ; -EXPECT -Integer overflow in octal number at - line 8. -######## - -# 'no warnings FATAL=>"all"' should be the same as 'no warnings' -use warnings ; -{ - no warnings FATAL=>"all" ; - my $a = oct "7777777777777777777777777777777777778" ; - my $b =+ 1 ; - my $c ; chop $c ; -} -my $a =+ 1 ; -print STDERR "The End.\n" ; -EXPECT -Reversed += operator at - line 10. -The End. -######## - -# 'no warnings "FATAL"' should be the same as 'no warnings' [perl #120977] -use warnings ; -{ - no warnings "FATAL" ; - my $a = oct "7777777777777777777777777777777777778" ; - my $b =+ 1 ; - my $c ; chop $c ; -} -my $a =+ 1 ; -print STDERR "The End.\n" ; -EXPECT -Reversed += operator at - line 10. -The End. diff --git a/gnu/usr.bin/perl/t/lib/warnings/doio b/gnu/usr.bin/perl/t/lib/warnings/doio index 63250e156c0..bb09aa85520 100644 --- a/gnu/usr.bin/perl/t/lib/warnings/doio +++ b/gnu/usr.bin/perl/t/lib/warnings/doio @@ -60,10 +60,10 @@ __END__ # doio.c [Perl_do_open9] use warnings 'io' ; -open(F, '|'."$^X -e 1|"); +open(F, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); close(F); no warnings 'io' ; -open(G, '|'."$^X -e 1|"); +open(G, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); close(G); EXPECT Can't open bidirectional pipe at - line 3. @@ -143,7 +143,7 @@ print $a ; no warnings 'uninitialized' ; print $b ; EXPECT -Use of uninitialized value $a in print at - line 3. +Use of uninitialized value in print at - line 3. ######## # doio.c [Perl_my_stat Perl_my_lstat] use warnings 'io' ; @@ -170,84 +170,83 @@ EXPECT Use of -l on filehandle STDIN at - line 3. Use of -l on filehandle $fh at - line 6. ######## -# doio.c [Perl_my_stat] -use utf8; -use open qw( :utf8 :std ); -use warnings 'io'; --l ᶠᚻ; -no warnings 'io'; --l ᶠᚻ; -EXPECT -Use of -l on filehandle ᶠᚻ at - line 5. -######## # doio.c [Perl_do_aexec5] +BEGIN { + if ($^O eq 'MacOS') { + print < ; } { no warnings 'inplace' ; - local (@ARGV) = ($filename, $dir0, $file3) ; + local (@ARGV) = ($filename) ; local ($^I) = "" ; my $x = <> ; } { use warnings 'inplace' ; - local (@ARGV) = ($filename, $dir0, $file3) ; + local (@ARGV) = ($filename) ; local ($^I) = "" ; my $x = <> ; } rmdir $filename ; -chmod 0777, $dir0 ; -rmdir $dir0 ; EXPECT -OPTION regex -Can't do inplace edit: \./temp\.dir is not a regular file at - line 17\. -Can't do inplace edit: \./zero\.dir is not a regular file at - line 17\. -Can't open date\|: .*? at - line 17\. -Can't do inplace edit: \./temp\.dir is not a regular file at - line 29\. -Can't do inplace edit: \./zero\.dir is not a regular file at - line 29\. -Can't open date\|: .*? at - line 29\. +Can't do inplace edit: ./temp.dir is not a regular file at - line 9. +Can't do inplace edit: ./temp.dir is not a regular file at - line 21. + ######## # doio.c [Perl_do_eof] use warnings 'io' ; @@ -276,139 +275,3 @@ no warnings 'io'; open FOO, '>', \$x; EXPECT Can't open a reference at - line 14. -######## -# doio.c [Perl_do_openn] -use Config; -BEGIN { - if (!$Config{useperlio}) { - print <doiowarn.tmp"; close $fh1; -no warnings 'io' ; -open my $fh2, ">doiowarn.tmp"; close $fh2; -unlink "doiowarn.tmp"; -EXPECT -Filehandle STDIN reopened as $fh1 only for output at - line 14. -######## -# doio.c [Perl_do_openn] -use Config; -use utf8; -use open qw( :utf8 :std ); -BEGIN { - if (!$Config{useperlio}) { - print <doiowarn.tmp"; close $ᶠᚻ1; -no warnings 'io' ; -open my $ᶠᚻ2, ">doiowarn.tmp"; close $ᶠᚻ2; -unlink "doiowarn.tmp"; -EXPECT -Filehandle STDIN reopened as $ᶠᚻ1 only for output at - line 16. -######## -# doio.c [Perl_do_openn] -use Config; -use utf8; -use open qw( :utf8 :std ); -BEGIN { - if (!$Config{useperlio}) { - print <doiowarn.tmp"; close ᶠᚻ1; -no warnings 'io' ; -open ᶠᚻ2, ">doiowarn.tmp"; close ᶠᚻ2; -unlink "doiowarn.tmp"; -EXPECT -Filehandle STDIN reopened as ᶠᚻ1 only for output at - line 16. -######## -open(my $i, "foo\0bar"); -use warnings 'io'; -open(my $i, "foo\0bar"); -EXPECT -Invalid \0 character in pathname for open: foo\0bar at - line 3. -######## -chmod(0, "foo\0bar"); -use warnings 'io'; -chmod(0, "foo\0bar"); -EXPECT -Invalid \0 character in pathname for chmod: foo\0bar at - line 3. -######## -unlink("foo\0bar", "foo\0bar2"); -use warnings 'io'; -unlink("foo\0bar", "foo\0bar2"); -EXPECT -Invalid \0 character in pathname for unlink: foo\0bar at - line 3. -Invalid \0 character in pathname for unlink: foo\0bar2 at - line 3. -######## -utime(-1, -1, "foo\0bar", "foo\0bar2"); -use warnings 'io'; -utime(-1, -1, "foo\0bar", "foo\0bar2"); -EXPECT -Invalid \0 character in pathname for utime: foo\0bar at - line 3. -Invalid \0 character in pathname for utime: foo\0bar2 at - line 3. -######## -my @foo = glob "foo\0bar"; -use warnings 'io'; -my @bar = glob "foo\0bar"; -EXPECT -Invalid \0 character in pattern for glob: foo\0bar at - line 3. diff --git a/gnu/usr.bin/perl/t/lib/warnings/doop b/gnu/usr.bin/perl/t/lib/warnings/doop index 74c3e907fea..5803b445812 100644 --- a/gnu/usr.bin/perl/t/lib/warnings/doop +++ b/gnu/usr.bin/perl/t/lib/warnings/doop @@ -1,4 +1,3 @@ -__END__ # doop.c use utf8 ; $_ = "\x80 \xff" ; diff --git a/gnu/usr.bin/perl/t/lib/warnings/mg b/gnu/usr.bin/perl/t/lib/warnings/mg index 9e3652b71e1..f7c3ebf435c 100644 --- a/gnu/usr.bin/perl/t/lib/warnings/mg +++ b/gnu/usr.bin/perl/t/lib/warnings/mg @@ -25,7 +25,7 @@ EXPECT ######## # mg.c use warnings 'signal' ; -if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { +if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS' || $^O eq 'MacOS') { print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit; } $|=1; @@ -35,7 +35,7 @@ SIGINT handler "fred" not defined. ######## # mg.c no warnings 'signal' ; -if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { +if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS' || $^O eq 'MacOS') { print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit; } $|=1; @@ -46,17 +46,12 @@ EXPECT # mg.c use warnings 'uninitialized'; 'foo' =~ /(foo)/; -oct $3; +length $3; EXPECT -Use of uninitialized value $3 in oct at - line 4. +Use of uninitialized value in length at - line 4. ######## # mg.c use warnings 'uninitialized'; -oct $3; -EXPECT -Use of uninitialized value $3 in oct at - line 3. -######## -# mg.c -use warnings 'uninitialized'; -$ENV{FOO} = undef; # should not warn +length $3; EXPECT +Use of uninitialized value in length at - line 3. diff --git a/gnu/usr.bin/perl/t/lib/warnings/op b/gnu/usr.bin/perl/t/lib/warnings/op index bca28186a2f..011fd17beb3 100644 --- a/gnu/usr.bin/perl/t/lib/warnings/op +++ b/gnu/usr.bin/perl/t/lib/warnings/op @@ -1,14 +1,33 @@ op.c AOK - Use of my $_ is experimental - my $_ ; + "my" variable %s masks earlier declaration in same scope + my $x; + my $x ; + + Variable "%s" may be unavailable + sub x { + my $x; + sub y { + $x + } + } + + Variable "%s" will not stay shared + sub x { + my $x; + sub y { + sub { $x } + } + } Found = in conditional, should be == 1 if $a = 1 ; - Scalar value %.*s better written as $%.*s" - @a[3] = 2; - @a{3} = 2; + Use of implicit split to @_ is deprecated + split ; + + Use of implicit split to @_ is deprecated + $a = split ; Useless use of time in void context Useless use of a variable in void context @@ -64,12 +83,6 @@ Array @%s missing the @ in argument %d of %s() push fred ; - push on reference is experimental [ck_fun] - pop on reference is experimental - shift on reference is experimental - unshift on reference is experimental - splice on reference is experimental - Hash %%%s missing the %% in argument %d of %s() keys joe ; @@ -85,18 +98,7 @@ defined(%hash) is deprecated (Maybe you should just omit the defined()?) my %h ; defined %h ; - - "my %s" used in sort comparison - - $[ used in comparison (did you mean $] ?) - - each on reference is experimental [ck_each] - keys on reference is experimental - values on reference is experimental - - length() used on @array (did you mean "scalar(@array)"?) - length() used on %hash (did you mean "scalar(keys %hash)"?) - + /---/ should probably be written as "---" join(/---/, @foo); @@ -104,11 +106,12 @@ fred() ; sub fred ($$) {} - Package '%s' not found (did you use the incorrect case?) + Use of "package" with no arguments is deprecated + package; - Use of /g modifier is meaningless in split + Package `%s' not found (did you use the incorrect case?) - Possible precedence problem on bitwise %c operator [Perl_ck_bitop] + Use of /g modifier is meaningless in split Mandatory Warnings ------------------ @@ -116,208 +119,106 @@ sub fred() ; sub fred($) {} + %s never introduced [pad_leavemy] TODO + Runaway prototype [newSUB] TODO oops: oopsAV [oopsAV] TODO oops: oopsHV [oopsHV] TODO + __END__ # op.c -use warnings 'experimental::lexical_topic' ; -my $_; -CORE::state $_; -no warnings 'experimental::lexical_topic' ; -my $_; -CORE::state $_; +use warnings 'misc' ; +my $x ; +my $x ; +my $y = my $y ; +no warnings 'misc' ; +my $x ; +my $y ; EXPECT -Use of my $_ is experimental at - line 3. -Use of state $_ is experimental at - line 4. +"my" variable $x masks earlier declaration in same scope at - line 4. +"my" variable $y masks earlier declaration in same statement at - line 5. ######## # op.c -use warnings 'syntax' ; -1 if $a = 1 ; -1 if $a - = 1 ; -no warnings 'syntax' ; -1 if $a = 1 ; -1 if $a - = 1 ; +use warnings 'closure' ; +sub x { + my $x; + sub y { + $x + } + } EXPECT -Found = in conditional, should be == at - line 3. -Found = in conditional, should be == at - line 4. +Variable "$x" will not stay shared at - line 7. ######## # op.c -use warnings 'syntax' ; -use constant foo => 1; -1 if $a = foo ; -no warnings 'syntax' ; -1 if $a = foo ; +no warnings 'closure' ; +sub x { + my $x; + sub y { + $x + } + } EXPECT + ######## # op.c -use warnings 'syntax' ; -@a[3]; -@a{3}; -@a["]"]; -@a{"]"}; -@a["}"]; -@a{"}"}; -@a{$_}; -@a{--$_}; -@a[$_]; -@a[--$_]; -no warnings 'syntax' ; -@a[3]; -@a{3}; +use warnings 'closure' ; +sub x { + our $x; + sub y { + $x + } + } EXPECT -Scalar value @a[3] better written as $a[3] at - line 3. -Scalar value @a{3} better written as $a{3} at - line 4. -Scalar value @a["]"] better written as $a["]"] at - line 5. -Scalar value @a{"]"} better written as $a{"]"} at - line 6. -Scalar value @a["}"] better written as $a["}"] at - line 7. -Scalar value @a{"}"} better written as $a{"}"} at - line 8. -Scalar value @a{...} better written as $a{...} at - line 9. -Scalar value @a{...} better written as $a{...} at - line 10. -Scalar value @a[...] better written as $a[...] at - line 11. -Scalar value @a[...] better written as $a[...] at - line 12. + ######## # op.c -use utf8; -use open qw( :utf8 :std ); -use warnings 'syntax' ; -@à[3]; -@à{3}; -no warnings 'syntax' ; -@à[3]; -@à{3}; +use warnings 'closure' ; +sub x { + my $x; + sub y { + sub { $x } + } + } EXPECT -Scalar value @à[3] better written as $à[3] at - line 5. -Scalar value @à{3} better written as $à{3} at - line 6. +Variable "$x" may be unavailable at - line 6. +######## +# op.c +no warnings 'closure' ; +sub x { + my $x; + sub y { + sub { $x } + } + } +EXPECT + ######## # op.c -use utf8; -use open qw( :utf8 :std ); use warnings 'syntax' ; -@ã[3]; -@ã{3}; +1 if $a = 1 ; no warnings 'syntax' ; -@ã[3]; -@ã{3}; +1 if $a = 1 ; EXPECT -Scalar value @ã[3] better written as $ã[3] at - line 5. -Scalar value @ã{3} better written as $ã{3} at - line 6. +Found = in conditional, should be == at - line 3. ######## # op.c -# "Scalar value better written as" false positives -# [perl #28380] and [perl #114024] -use warnings 'syntax'; - -# hashes -@h{qw"a b c"} = 1..3; -@h{qw'a b c'} = 1..3; -@h{qw$a b c$} = 1..3; -@h{qw-a b c-} = 1..3; -@h{qw#a b c#} = 1..3; -@h{ qw#a b c#} = 1..3; -@h{ qw#a b c#} = 1..3; # tab before qw -@h{qw "a"}; -@h{ qw "a"}; -@h{ qw "a"}; -sub foo() { qw/abc def ghi/ } -@X{+foo} = ( 1 .. 3 ); -$_ = "abc"; @X{split ""} = ( 1 .. 3 ); -my @s = @f{"}", "a"}; -my @s = @f{"]", "a"}; -@a{$],0}; -@_{0} = /(.*)/; -@h{m "$re"}; -@h{qx ""} if 0; -@h{glob ""}; -@h{readline ""}; -@h{m ""}; -use constant phoo => 1..3; -@h{+phoo}; # rv2av -{ - no warnings 'deprecated'; - @h{each H}; - @h{values H}; - @h{keys H}; -} -@h{sort foo}; -@h{reverse foo}; -@h{caller 0}; -@h{lstat ""}; -@h{stat ""}; -@h{readdir ""}; -@h{system ""} if 0; -@h{+times} if 0; -@h{localtime 0}; -@h{gmtime 0}; -@h{eval ""}; -{ - no warnings 'experimental::autoderef'; - @h{each $foo} if 0; - @h{keys $foo} if 0; - @h{values $foo} if 0; -} - -# arrays -@h[qw"a b c"] = 1..3; -@h[qw'a b c'] = 1..3; -@h[qw$a b c$] = 1..3; -@h[qw-a b c-] = 1..3; -@h[qw#a b c#] = 1..3; -@h[ qw#a b c#] = 1..3; -@h[ qw#a b c#] = 1..3; # tab before qw -@h[qw "a"]; -@h[ qw "a"]; -@h[ qw "a"]; -sub foo() { qw/abc def ghi/ } -@X[+foo] = ( 1 .. 3 ); -$_ = "abc"; @X[split ""] = ( 1 .. 3 ); -my @s = @f["}", "a"]; -my @s = @f["]", "a"]; -@a[$],0]; -@_[0] = /(.*)/; -@h[m "$re"]; -@h[qx ""] if 0; -@h[glob ""]; -@h[readline ""]; -@h[m ""]; -use constant phoo => 1..3; -@h[+phoo]; # rv2av -{ - no warnings 'deprecated'; - @h[each H]; - @h[values H]; - @h[keys H]; -} -@h[sort foo]; -@h[reverse foo]; -@h[caller 0]; -@h[lstat ""]; -@h[stat ""]; -@h[readdir ""]; -@h[system ""] if 0; -@h[+times] if 0; -@h[localtime 0]; -@h[gmtime 0]; -@h[eval ""]; -{ - no warnings 'experimental::autoderef'; - @h[each $foo] if 0; - @h[keys $foo] if 0; - @h[values $foo] if 0; -} +use warnings 'deprecated' ; +split ; +no warnings 'deprecated' ; +split ; EXPECT +Use of implicit split to @_ is deprecated at - line 3. ######## # op.c -# "Scalar value better written as" should not trigger for syntax errors -use warnings 'syntax'; -@a[] +use warnings 'deprecated' ; +$a = split ; +no warnings 'deprecated' ; +$a = split ; EXPECT -syntax error at - line 4, near "[]" -Execution of - aborted due to compilation errors. +Use of implicit split to @_ is deprecated at - line 3. ######## # op.c +use warnings 'deprecated'; my (@foo, %foo); %main::foo->{"bar"}; %foo->{"bar"}; @@ -337,20 +238,18 @@ $foo = {}; %$foo->{"bar"}; $main::foo = []; @$main::foo->[34]; $foo = []; @$foo->[34]; EXPECT -Using a hash as a reference is deprecated at - line 3. Using a hash as a reference is deprecated at - line 4. -Using an array as a reference is deprecated at - line 5. +Using a hash as a reference is deprecated at - line 5. Using an array as a reference is deprecated at - line 6. -Using a hash as a reference is deprecated at - line 7. +Using an array as a reference is deprecated at - line 7. Using a hash as a reference is deprecated at - line 8. -Using an array as a reference is deprecated at - line 9. +Using a hash as a reference is deprecated at - line 9. Using an array as a reference is deprecated at - line 10. +Using an array as a reference is deprecated at - line 11. ######## # op.c -use warnings 'void' ; no warnings 'experimental::smartmatch'; close STDIN ; -#line 2 -1 x 3 ; # OP_REPEAT (folded) -(1) x 3 ; # OP_REPEAT +use warnings 'void' ; close STDIN ; +1 x 3 ; # OP_REPEAT # OP_GVSV wantarray ; # OP_WANTARRAY # OP_GV @@ -401,16 +300,7 @@ eval { getgrnam 1 }; # OP_GGRNAM eval { getgrgid 1 }; # OP_GGRGID eval { getpwnam 1 }; # OP_GPWNAM eval { getpwuid 1 }; # OP_GPWUID -prototype "foo"; # OP_PROTOTYPE -$a ~~ $b; # OP_SMARTMATCH -$a <=> $b; # OP_NCMP -"dsatrewq"; -"diatrewq"; -"igatrewq"; -use 5.015; -__SUB__ # OP_RUNCV EXPECT -Useless use of a constant ("111") in void context at - line 2. Useless use of repeat (x) in void context at - line 3. Useless use of wantarray in void context at - line 5. Useless use of reference-type operator in void context at - line 12. @@ -448,13 +338,6 @@ Useless use of getgrnam in void context at - line 50. Useless use of getgrgid in void context at - line 51. Useless use of getpwnam in void context at - line 52. Useless use of getpwuid in void context at - line 53. -Useless use of subroutine prototype in void context at - line 54. -Useless use of smart match in void context at - line 55. -Useless use of numeric comparison (<=>) in void context at - line 56. -Useless use of a constant ("dsatrewq") in void context at - line 57. -Useless use of a constant ("diatrewq") in void context at - line 58. -Useless use of a constant ("igatrewq") in void context at - line 59. -Useless use of __SUB__ in void context at - line 61. ######## # op.c use warnings 'void' ; close STDIN ; @@ -517,7 +400,6 @@ eval { getgrnam 1 }; # OP_GGRNAM eval { getgrgid 1 }; # OP_GGRGID eval { getpwnam 1 }; # OP_GPWNAM eval { getpwuid 1 }; # OP_GPWUID -prototype "foo"; # OP_PROTOTYPE EXPECT ######## # op.c @@ -730,69 +612,32 @@ Useless use of a variable in void context at - line 6. use warnings 'void' ; "abc"; # OP_CONST 7 ; # OP_CONST -"x" . "y"; # optimized to OP_CONST -2 + 2; # optimized to OP_CONST -use constant U => undef; -U; -qq/" \n/; -5 || print "bad\n"; # test OPpCONST_SHORTCIRCUIT -print "boo\n" if U; # test OPpCONST_SHORTCIRCUIT -if($foo){}elsif(""){} # test OPpCONST_SHORTCIRCUIT no warnings 'void' ; "abc"; # OP_CONST 7 ; # OP_CONST -"x" . "y"; # optimized to OP_CONST -2 + 2; # optimized to OP_CONST -EXPECT -Useless use of a constant ("abc") in void context at - line 3. -Useless use of a constant (7) in void context at - line 4. -Useless use of a constant ("xy") in void context at - line 5. -Useless use of a constant (4) in void context at - line 6. -Useless use of a constant (undef) in void context at - line 8. -Useless use of a constant ("\"\t\n") in void context at - line 9. -######## -# op.c -use utf8; -use open qw( :utf8 :std ); -use warnings 'void' ; -"àḆc"; # OP_CONST -"Ẋ" . "Æ´"; # optimized to OP_CONST -ＦＯＯ; # Bareword optimized to OP_CONST -use constant ů => undef; -ů; -5 || print "bad\n"; # test OPpCONST_SHORTCIRCUIT -print "boo\n" if ů; # test OPpCONST_SHORTCIRCUIT -no warnings 'void' ; -"àḆc"; # OP_CONST -"Ẋ" . "Æ´"; # optimized to OP_CONST EXPECT -Useless use of a constant ("\340\x{1e06}c") in void context at - line 5. -Useless use of a constant ("\x{1e8a}\x{1b4}") in void context at - line 6. -Useless use of a constant ("\x{ff26}\x{ff2f}\x{ff2f}") in void context at - line 7. -Useless use of a constant (undef) in void context at - line 9. +Useless use of a constant in void context at - line 3. +Useless use of a constant in void context at - line 4. ######## # op.c # use warnings 'misc' ; -my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;my $d = 'test'; +my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; @a =~ /abc/ ; -@a2 =~ s/a/b/ ; -@a3 =~ tr/a/b/ ; +@a =~ s/a/b/ ; +@a =~ tr/a/b/ ; @$b =~ /abc/ ; @$b =~ s/a/b/ ; @$b =~ tr/a/b/ ; %a =~ /abc/ ; -%a2 =~ s/a/b/ ; -%a3 =~ tr/a/b/ ; +%a =~ s/a/b/ ; +%a =~ tr/a/b/ ; %$c =~ /abc/ ; %$c =~ s/a/b/ ; %$c =~ tr/a/b/ ; -$d =~ tr/a/b/d ; -$d2 =~ tr/a/bc/; -$d3 =~ tr//b/c; { no warnings 'misc' ; -my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; my $d = 'test'; +my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; @a =~ /abc/ ; @a =~ s/a/b/ ; @a =~ tr/a/b/ ; @@ -805,56 +650,38 @@ my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; my $d = 'test'; %$c =~ /abc/ ; %$c =~ s/a/b/ ; %$c =~ tr/a/b/ ; -$d =~ tr/a/b/d ; -$d =~ tr/a/bc/ ; -$d =~ tr//b/c; } EXPECT -Applying pattern match (m//) to @a will act on scalar(@a) at - line 5. -Applying substitution (s///) to @a2 will act on scalar(@a2) at - line 6. -Applying transliteration (tr///) to @a3 will act on scalar(@a3) at - line 7. +Applying pattern match (m//) to @array will act on scalar(@array) at - line 5. +Applying substitution (s///) to @array will act on scalar(@array) at - line 6. +Applying transliteration (tr///) to @array will act on scalar(@array) at - line 7. Applying pattern match (m//) to @array will act on scalar(@array) at - line 8. Applying substitution (s///) to @array will act on scalar(@array) at - line 9. Applying transliteration (tr///) to @array will act on scalar(@array) at - line 10. -Applying pattern match (m//) to %a will act on scalar(%a) at - line 11. -Applying substitution (s///) to %a2 will act on scalar(%a2) at - line 12. -Applying transliteration (tr///) to %a3 will act on scalar(%a3) at - line 13. +Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 11. +Applying substitution (s///) to %hash will act on scalar(%hash) at - line 12. +Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 13. Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 14. Applying substitution (s///) to %hash will act on scalar(%hash) at - line 15. Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 16. -Useless use of /d modifier in transliteration operator at - line 17. -Replacement list is longer than search list at - line 18. -Can't modify array dereference in substitution (s///) at - line 6, near "s/a/b/ ;" -BEGIN not safe after errors--compilation aborted at - line 21. +Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;" +BEGIN not safe after errors--compilation aborted at - line 18. ######## # op.c -use warnings 'parenthesis' ; +use warnings 'syntax' ; my $a, $b = (1,2); -my @foo,%bar, $quux; # there's a TAB here -my $x, $y or print; -no warnings 'parenthesis' ; +no warnings 'syntax' ; my $c, $d = (1,2); EXPECT Parentheses missing around "my" list at - line 3. -Parentheses missing around "my" list at - line 4. -######## -# op.c -use warnings 'parenthesis' ; -our $a, $b = (1,2); -no warnings 'parenthesis' ; -our $c, $d = (1,2); -EXPECT -Parentheses missing around "our" list at - line 3. ######## # op.c -use warnings 'parenthesis' ; +use warnings 'syntax' ; local $a, $b = (1,2); -local *f, *g; -no warnings 'parenthesis' ; +no warnings 'syntax' ; local $c, $d = (1,2); EXPECT Parentheses missing around "local" list at - line 3. -Parentheses missing around "local" list at - line 4. ######## # op.c use warnings 'bareword' ; @@ -871,43 +698,28 @@ Bareword found in conditional at - line 3. use warnings 'misc' ; open FH, " ; -$x = 1 if $x - = ; no warnings 'misc' ; $x = 1 if $x = ; -$x = 1 if $x - = ; EXPECT Value of construct can be "0"; test with defined() at - line 4. -Value of construct can be "0"; test with defined() at - line 5. ######## # op.c use warnings 'misc' ; opendir FH, "." ; $x = 1 if $x = readdir FH ; -$x = 1 if $x - = readdir FH ; no warnings 'misc' ; $x = 1 if $x = readdir FH ; -$x = 1 if $x - = readdir FH ; closedir FH ; EXPECT Value of readdir() operator can be "0"; test with defined() at - line 4. -Value of readdir() operator can be "0"; test with defined() at - line 5. ######## # op.c use warnings 'misc' ; $x = 1 if $x = <*> ; -$x = 1 if $x - = <*> ; no warnings 'misc' ; $x = 1 if $x = <*> ; -$x = 1 if $x - = <*> ; EXPECT Value of glob construct can be "0"; test with defined() at - line 3. -Value of glob construct can be "0"; test with defined() at - line 4. ######## # op.c use warnings 'misc' ; @@ -937,26 +749,13 @@ EXPECT Value of readdir() operator can be "0"; test with defined() at - line 4. ######## # op.c -use warnings 'misc'; -open FH, ") // ($_ = 1); -opendir DH, "."; -%a = (1,2,3,4) ; -EXPECT -######## -# op.c use warnings 'redefine' ; sub fred {} sub fred {} -sub fred { # warning should be for this line -} no warnings 'redefine' ; sub fred {} -sub fred { -} EXPECT Subroutine fred redefined at - line 4. -Subroutine fred redefined at - line 5. ######## # op.c use warnings 'redefine' ; @@ -968,50 +767,18 @@ EXPECT Constant subroutine fred redefined at - line 4. ######## # op.c -sub fred () { 1 } -sub fred () { 2 } -EXPECT -Constant subroutine fred redefined at - line 3. -######## -# op.c -sub fred () { 1 } -*fred = sub () { 2 }; -EXPECT -Constant subroutine main::fred redefined at - line 3. -######## -# op.c -use feature "lexical_subs", "state"; -my sub fred () { 1 } -sub fred { 2 }; -my sub george { 1 } -sub george () { 2 } # should *not* produce redef warnings by default -state sub phred () { 1 } -sub phred { 2 }; -state sub jorge { 1 } -sub jorge () { 2 } # should *not* produce redef warnings by default -EXPECT -The lexical_subs feature is experimental at - line 3. -Prototype mismatch: sub fred () vs none at - line 4. -Constant subroutine fred redefined at - line 4. -The lexical_subs feature is experimental at - line 5. -Prototype mismatch: sub george: none vs () at - line 6. -The lexical_subs feature is experimental at - line 7. -Prototype mismatch: sub phred () vs none at - line 8. -Constant subroutine phred redefined at - line 8. -The lexical_subs feature is experimental at - line 9. -Prototype mismatch: sub jorge: none vs () at - line 10. -######## -# op.c no warnings 'redefine' ; sub fred () { 1 } sub fred () { 2 } EXPECT +Constant subroutine fred redefined at - line 4. ######## # op.c no warnings 'redefine' ; sub fred () { 1 } *fred = sub () { 2 }; EXPECT +Constant subroutine main::fred redefined at - line 4. ######## # op.c use warnings 'redefine' ; @@ -1026,85 +793,70 @@ EXPECT Format FRED redefined at - line 5. ######## # op.c +use warnings 'deprecated' ; push FRED; no warnings 'deprecated' ; push FRED; EXPECT -Array @FRED missing the @ in argument 1 of push() at - line 2. -######## -# op.c [Perl_ck_fun] -$fred = []; -push $fred; -pop $fred; -shift $fred; -unshift $fred; -splice $fred; -no warnings 'experimental::autoderef' ; -push $fred; -pop $fred; -shift $fred; -unshift $fred; -splice $fred; -EXPECT -push on reference is experimental at - line 3. -pop on reference is experimental at - line 4. -shift on reference is experimental at - line 5. -unshift on reference is experimental at - line 6. -splice on reference is experimental at - line 7. +Array @FRED missing the @ in argument 1 of push() at - line 3. ######## # op.c +use warnings 'deprecated' ; @a = keys FRED ; no warnings 'deprecated' ; @a = keys FRED ; EXPECT -Hash %FRED missing the % in argument 1 of keys() at - line 2. +Hash %FRED missing the % in argument 1 of keys() at - line 3. ######## # op.c -use warnings 'exec' ; +BEGIN { + if ($^O eq 'MacOS') { + print <bar; sub foo(@); -use constant bav=>bar; sub bav(); # no warning -sub btu; sub btu(); EXPECT Prototype mismatch: sub main::fred () vs ($) at - line 3. -Prototype mismatch: sub foo () vs (@) at - line 4. -Prototype mismatch: sub btu: none vs () at - line 6. -######## -# op.c -use utf8; -use open qw( :utf8 :std ); -sub frèd(); -sub frèd($) {} -EXPECT -Prototype mismatch: sub main::frèd () vs ($) at - line 5. -######## -# op.c -use utf8; -use open qw( :utf8 :std ); -use warnings; -eval "sub fòò (@\$\0) {}"; -EXPECT -Prototype after '@' for main::fòò : @$\0 at (eval 1) line 1. -Illegal character in prototype for main::fòò : @$\0 at (eval 1) line 1. -######## -# op.c -use utf8; -use open qw( :utf8 :std ); -use warnings; -eval "sub foo (@\0) {}"; -EXPECT -Prototype after '@' for main::foo : @\0 at (eval 1) line 1. -Illegal character in prototype for main::foo : @\0 at (eval 1) line 1. -######## -# op.c -use utf8; -use open qw( :utf8 :std ); -use warnings; -BEGIN { $::{"foo"} = "\@\$\0L\351on" } -BEGIN { eval "sub foo (@\$\0L\x{c3}\x{a9}on) {}"; } -EXPECT -Prototype after '@' for main::foo : @$\x{0}L... at (eval 1) line 1. -Illegal character in prototype for main::foo : @$\x{0}L... at (eval 1) line 1. -######## -# op.c -use utf8; -use open qw( :utf8 :std ); -use warnings; -BEGIN { eval "sub foo (@\0) {}"; } -EXPECT -Prototype after '@' for main::foo : @\0 at (eval 1) line 1. -Illegal character in prototype for main::foo : @\0 at (eval 1) line 1. -######## -# op.c -use warnings; -eval "sub foo (@\xAB) {}"; -EXPECT -Prototype after '@' for main::foo : @\x{ab} at (eval 1) line 1. -Illegal character in prototype for main::foo : @\x{ab} at (eval 1) line 1. -######## -# op.c -use utf8; -use open qw( :utf8 :std ); -use warnings; -BEGIN { eval "sub foo (@\x{30cb}) {}"; } -EXPECT -Prototype after '@' for main::foo : @\x{30cb} at (eval 1) line 1. -Illegal character in prototype for main::foo : @\x{30cb} at (eval 1) line 1. -######## -# op.c -use utf8; -use open qw( :utf8 :std ); -use warnings; -BEGIN { $::{"foo"} = "\x{30cb}" } -BEGIN { eval "sub foo {}"; } -EXPECT -Prototype mismatch: sub main::foo (ニ) vs none at (eval 1) line 1. ######## # op.c $^W = 0 ; @@ -1210,217 +887,12 @@ Prototype mismatch: sub main::fred () vs ($) at - line 4. Prototype mismatch: sub main::freD () vs ($) at - line 11. Prototype mismatch: sub main::FRED () vs ($) at - line 14. ######## -# op.c [S_simplify_sort] -# [perl #86136] -my @tests = split /^/, ' - sort {$a <=> $b} @a; - sort {$a cmp $b} @a; - { use integer; sort {$a <=> $b} @a} - sort {$b <=> $a} @a; - sort {$b cmp $a} @a; - { use integer; sort {$b <=> $a} @a} -'; -for my $pragma ('use warnings "syntax";', '') { - for my $vars ('', 'my $a;', 'my $b;', 'my ($a,$b);') { - for my $inner_stmt ('', 'print;', 'func();') { - eval "#line " . ++$line . "01 -\n$pragma\n$vars" - . join "", map s/sort \{\K/$inner_stmt/r, @tests; - $@ and die; - } - } -} -sub func{} -use warnings 'syntax'; -my $a; -# These used to be errors! -sort { ; } $a <=> $b; -sort { ; } $a, "<=>"; -sort { ; } $a, $cmp; -sort $a, $b if $cmpany_name; -sort if $a + $cmp; -sort @t; $a + $cmp; -EXPECT -"my $a" used in sort comparison at - line 403. -"my $a" used in sort comparison at - line 404. -"my $a" used in sort comparison at - line 405. -"my $a" used in sort comparison at - line 406. -"my $a" used in sort comparison at - line 407. -"my $a" used in sort comparison at - line 408. -"my $a" used in sort comparison at - line 503. -"my $a" used in sort comparison at - line 504. -"my $a" used in sort comparison at - line 505. -"my $a" used in sort comparison at - line 506. -"my $a" used in sort comparison at - line 507. -"my $a" used in sort comparison at - line 508. -"my $a" used in sort comparison at - line 603. -"my $a" used in sort comparison at - line 604. -"my $a" used in sort comparison at - line 605. -"my $a" used in sort comparison at - line 606. -"my $a" used in sort comparison at - line 607. -"my $a" used in sort comparison at - line 608. -"my $b" used in sort comparison at - line 703. -"my $b" used in sort comparison at - line 704. -"my $b" used in sort comparison at - line 705. -"my $b" used in sort comparison at - line 706. -"my $b" used in sort comparison at - line 707. -"my $b" used in sort comparison at - line 708. -"my $b" used in sort comparison at - line 803. -"my $b" used in sort comparison at - line 804. -"my $b" used in sort comparison at - line 805. -"my $b" used in sort comparison at - line 806. -"my $b" used in sort comparison at - line 807. -"my $b" used in sort comparison at - line 808. -"my $b" used in sort comparison at - line 903. -"my $b" used in sort comparison at - line 904. -"my $b" used in sort comparison at - line 905. -"my $b" used in sort comparison at - line 906. -"my $b" used in sort comparison at - line 907. -"my $b" used in sort comparison at - line 908. -"my $a" used in sort comparison at - line 1003. -"my $b" used in sort comparison at - line 1003. -"my $a" used in sort comparison at - line 1004. -"my $b" used in sort comparison at - line 1004. -"my $a" used in sort comparison at - line 1005. -"my $b" used in sort comparison at - line 1005. -"my $b" used in sort comparison at - line 1006. -"my $a" used in sort comparison at - line 1006. -"my $b" used in sort comparison at - line 1007. -"my $a" used in sort comparison at - line 1007. -"my $b" used in sort comparison at - line 1008. -"my $a" used in sort comparison at - line 1008. -"my $a" used in sort comparison at - line 1103. -"my $b" used in sort comparison at - line 1103. -"my $a" used in sort comparison at - line 1104. -"my $b" used in sort comparison at - line 1104. -"my $a" used in sort comparison at - line 1105. -"my $b" used in sort comparison at - line 1105. -"my $b" used in sort comparison at - line 1106. -"my $a" used in sort comparison at - line 1106. -"my $b" used in sort comparison at - line 1107. -"my $a" used in sort comparison at - line 1107. -"my $b" used in sort comparison at - line 1108. -"my $a" used in sort comparison at - line 1108. -"my $a" used in sort comparison at - line 1203. -"my $b" used in sort comparison at - line 1203. -"my $a" used in sort comparison at - line 1204. -"my $b" used in sort comparison at - line 1204. -"my $a" used in sort comparison at - line 1205. -"my $b" used in sort comparison at - line 1205. -"my $b" used in sort comparison at - line 1206. -"my $a" used in sort comparison at - line 1206. -"my $b" used in sort comparison at - line 1207. -"my $a" used in sort comparison at - line 1207. -"my $b" used in sort comparison at - line 1208. -"my $a" used in sort comparison at - line 1208. -######## -# op.c [S_simplify_sort] -use warnings 'syntax'; use 5.01; -state $a; -sort { $a <=> $b } (); -EXPECT -"state $a" used in sort comparison at - line 4. -######## -# op.c [Perl_ck_cmp] -use warnings 'syntax' ; -no warnings 'deprecated'; -@a = $[ < 5; -@a = $[ > 5; -@a = $[ <= 5; -@a = $[ >= 5; -@a = 42 < $[; -@a = 42 > $[; -@a = 42 <= $[; -@a = 42 >= $[; -use integer; -@a = $[ < 5; -@a = $[ > 5; -@a = $[ <= 5; -@a = $[ >= 5; -@a = 42 < $[; -@a = 42 > $[; -@a = 42 <= $[; -@a = 42 >= $[; -no integer; -@a = $[ < $5; -@a = $[ > $5; -@a = $[ <= $5; -@a = $[ >= $5; -@a = $42 < $[; -@a = $42 > $[; -@a = $42 <= $[; -@a = $42 >= $[; -use integer; -@a = $[ < $5; -@a = $[ > $5; -@a = $[ <= $5; -@a = $[ >= $5; -@a = $42 < $[; -@a = $42 > $[; -@a = $42 <= $[; -@a = $42 >= $[; -EXPECT -$[ used in numeric lt (<) (did you mean $] ?) at - line 4. -$[ used in numeric gt (>) (did you mean $] ?) at - line 5. -$[ used in numeric le (<=) (did you mean $] ?) at - line 6. -$[ used in numeric ge (>=) (did you mean $] ?) at - line 7. -$[ used in numeric lt (<) (did you mean $] ?) at - line 8. -$[ used in numeric gt (>) (did you mean $] ?) at - line 9. -$[ used in numeric le (<=) (did you mean $] ?) at - line 10. -$[ used in numeric ge (>=) (did you mean $] ?) at - line 11. -$[ used in numeric lt (<) (did you mean $] ?) at - line 13. -$[ used in numeric gt (>) (did you mean $] ?) at - line 14. -$[ used in numeric le (<=) (did you mean $] ?) at - line 15. -$[ used in numeric ge (>=) (did you mean $] ?) at - line 16. -$[ used in numeric lt (<) (did you mean $] ?) at - line 17. -$[ used in numeric gt (>) (did you mean $] ?) at - line 18. -$[ used in numeric le (<=) (did you mean $] ?) at - line 19. -$[ used in numeric ge (>=) (did you mean $] ?) at - line 20. -######## -# op.c [Perl_ck_each] -$fred = {}; -keys $fred; -values $fred; -each $fred; -no warnings 'experimental::autoderef' ; -keys $fred; -values $fred; -each $fred; -EXPECT -keys on reference is experimental at - line 3. -values on reference is experimental at - line 4. -each on reference is experimental at - line 5. -######## -# op.c [Perl_ck_length] -use warnings 'syntax' ; -length(@a); -length(%b); -length(@$c); -length(%$d); -length($a); -length(my %h); -length(my @g); -EXPECT -length() used on @a (did you mean "scalar(@a)"?) at - line 3. -length() used on %b (did you mean "scalar(keys %b)"?) at - line 4. -length() used on @array (did you mean "scalar(@array)"?) at - line 5. -length() used on %hash (did you mean "scalar(keys %hash)"?) at - line 6. -length() used on %h (did you mean "scalar(keys %h)"?) at - line 8. -length() used on @g (did you mean "scalar(@g)"?) at - line 9. -######## # op.c use warnings 'syntax' ; join /---/, 'x', 'y', 'z'; EXPECT /---/ should probably be written as "---" at - line 3. ######## -# op.c -use utf8; -use open qw( :utf8 :std ); -use warnings 'syntax' ; -join /～～～/, 'x', 'y', 'z'; -EXPECT -/～～～/ should probably be written as "～～～" at - line 5. -######## # op.c [Perl_peep] use warnings 'prototype' ; fred() ; @@ -1495,6 +967,16 @@ Useless use of push with no values at - line 4. Useless use of unshift with no values at - line 5. ######## # op.c +use warnings 'deprecated' ; +package; +no warnings 'deprecated' ; +package; +EXPECT +Use of "package" with no arguments is deprecated at - line 3. +Global symbol "BEGIN" requires explicit package name at - line 4. +BEGIN not safe after errors--compilation aborted at - line 4. +######## +# op.c # 20020401 mjd@plover.com at suggestion of jfriedl@yahoo.com use warnings 'regexp'; split /blah/g, "blah"; @@ -1502,422 +984,3 @@ no warnings 'regexp'; split /blah/g, "blah"; EXPECT Use of /g modifier is meaningless in split at - line 4. -######## -# op.c -use warnings 'precedence'; -$a = $b & $c == $d; -$a = $b ^ $c != $d; -$a = $b | $c > $d; -$a = $b < $c & $d; -$a = $b >= $c ^ $d; -$a = $b <= $c | $d; -$a = $b <=> $c & $d; -$a &= $b == $c; $a |= $b == $c; $a ^= $b == $c; # shouldn't warn -no warnings 'precedence'; -$a = $b & $c == $d; -$a = $b ^ $c != $d; -$a = $b | $c > $d; -$a = $b < $c & $d; -$a = $b >= $c ^ $d; -$a = $b <= $c | $d; -$a = $b <=> $c & $d; -EXPECT -Possible precedence problem on bitwise & operator at - line 3. -Possible precedence problem on bitwise ^ operator at - line 4. -Possible precedence problem on bitwise | operator at - line 5. -Possible precedence problem on bitwise & operator at - line 6. -Possible precedence problem on bitwise ^ operator at - line 7. -Possible precedence problem on bitwise | operator at - line 8. -Possible precedence problem on bitwise & operator at - line 9. -######## -# op.c -use integer; -use warnings 'precedence'; -$a = $b & $c == $d; -$a = $b ^ $c != $d; -$a = $b | $c > $d; -$a = $b < $c & $d; -$a = $b >= $c ^ $d; -$a = $b <= $c | $d; -$a = $b <=> $c & $d; -no warnings 'precedence'; -$a = $b & $c == $d; -$a = $b ^ $c != $d; -$a = $b | $c > $d; -$a = $b < $c & $d; -$a = $b >= $c ^ $d; -$a = $b <= $c | $d; -$a = $b <=> $c & $d; -EXPECT -Possible precedence problem on bitwise & operator at - line 4. -Possible precedence problem on bitwise ^ operator at - line 5. -Possible precedence problem on bitwise | operator at - line 6. -Possible precedence problem on bitwise & operator at - line 7. -Possible precedence problem on bitwise ^ operator at - line 8. -Possible precedence problem on bitwise | operator at - line 9. -Possible precedence problem on bitwise & operator at - line 10. -######## -# op.c - -# ok => local() has desired effect; -# ignore=> local() silently ignored - -use warnings 'syntax'; - -local(undef); # OP_UNDEF ignore -sub lval : lvalue {}; -local(lval()); # OP_ENTERSUB -local($x **= 1); # OP_POW -local($x *= 1); # OP_MULTIPLY -local($x /= 1); # OP_DIVIDE -local($x %= 1); # OP_MODULO -local($x x= 1); # OP_REPEAT -local($x += 1); # OP_ADD -local($x -= 1); # OP_SUBTRACT -local($x .= 1); # OP_CONCAT -local($x <<= 1); # OP_LEFT_SHIFT -local($x >>= 1); # OP_RIGHT_SHIFT -local($x &= 1); # OP_BIT_AND -local($x ^= 1); # OP_BIT_XOR -local($x |= 1); # OP_BIT_OR -{ - use integer; - local($x *= 1); # OP_I_MULTIPLY - local($x /= 1); # OP_I_DIVIDE - local($x %= 1); # OP_I_MODULO - local($x += 1); # OP_I_ADD - local($x -= 1); # OP_I_SUBTRACT -} -local($x?$y:$z) = 1; # OP_COND_EXPR ok -# these two are fatal run-time errors instead -#local(@$a); # OP_RV2AV ok -#local(%$a); # OP_RV2HV ok -local(*a); # OP_RV2GV ok -local(@a[1,2]); # OP_ASLICE ok -local(@a{1,2}); # OP_HSLICE ok -local(@a = (1,2)); # OP_AASSIGN -local($$x); # OP_RV2SV ok -local($#a); # OP_AV2ARYLEN -local($x = 1); # OP_SASSIGN -local($x &&= 1); # OP_ANDASSIGN -local($x ||= 1); # OP_ORASSIGN -local($x //= 1); # OP_DORASSIGN -local($a[0]); # OP_AELEMFAST ok - -local(substr($x,0,1)); # OP_SUBSTR -local(pos($x)); # OP_POS -local(vec($x,0,1)); # OP_VEC -local($a[$b]); # OP_AELEM ok -local($a{$b}); # OP_HELEM ok - -no warnings 'syntax'; -EXPECT -Useless localization of subroutine entry at - line 10. -Useless localization of exponentiation (**) at - line 11. -Useless localization of multiplication (*) at - line 12. -Useless localization of division (/) at - line 13. -Useless localization of modulus (%) at - line 14. -Useless localization of repeat (x) at - line 15. -Useless localization of addition (+) at - line 16. -Useless localization of subtraction (-) at - line 17. -Useless localization of concatenation (.) or string at - line 18. -Useless localization of left bitshift (<<) at - line 19. -Useless localization of right bitshift (>>) at - line 20. -Useless localization of bitwise and (&) at - line 21. -Useless localization of bitwise xor (^) at - line 22. -Useless localization of bitwise or (|) at - line 23. -Useless localization of integer multiplication (*) at - line 26. -Useless localization of integer division (/) at - line 27. -Useless localization of integer modulus (%) at - line 28. -Useless localization of integer addition (+) at - line 29. -Useless localization of integer subtraction (-) at - line 30. -Useless localization of list assignment at - line 39. -Useless localization of array length at - line 41. -Useless localization of scalar assignment at - line 42. -Useless localization of logical and assignment (&&=) at - line 43. -Useless localization of logical or assignment (||=) at - line 44. -Useless localization of defined or assignment (//=) at - line 45. -Useless localization of substr at - line 48. -Useless localization of match position at - line 49. -Useless localization of vec at - line 50. -######## -# op.c -my $x1 if 0; -my @x2 if 0; -my %x3 if 0; -my ($x4) if 0; -my ($x5,@x6, %x7) if 0; -0 && my $z1; -0 && my (%z2); -# these shouldn't warn -our $x if 0; -our $x unless 0; -if (0) { my $w1 } -if (my $w2) { $a=1 } -if ($a && (my $w3 = 1)) {$a = 2} - -EXPECT -Deprecated use of my() in false conditional at - line 2. -Deprecated use of my() in false conditional at - line 3. -Deprecated use of my() in false conditional at - line 4. -Deprecated use of my() in false conditional at - line 5. -Deprecated use of my() in false conditional at - line 6. -Deprecated use of my() in false conditional at - line 7. -Deprecated use of my() in false conditional at - line 8. -######## -# op.c -$[ = 1; -($[) = 1; -use warnings 'deprecated'; -$[ = 2; -($[) = 2; -no warnings 'deprecated'; -$[ = 3; -($[) = 3; -EXPECT -Use of assignment to $[ is deprecated at - line 2. -Use of assignment to $[ is deprecated at - line 3. -Use of assignment to $[ is deprecated at - line 5. -Use of assignment to $[ is deprecated at - line 6. -######## -# op.c -use warnings 'void'; -@x = split /y/, "z"; -$x = split /y/, "z"; - split /y/, "z"; -no warnings 'void'; -@x = split /y/, "z"; -$x = split /y/, "z"; - split /y/, "z"; -EXPECT -Useless use of split in void context at - line 5. -######## -# op.c -use warnings 'redefine' ; -use utf8; -use open qw( :utf8 :std ); -sub frèd {} -sub frèd {} -no warnings 'redefine' ; -sub frèd {} -EXPECT -Subroutine frèd redefined at - line 6. -######## -# op.c -use warnings 'redefine' ; -use utf8; -use open qw( :utf8 :std ); -sub frèd () { 1 } -sub frèd () { 1 } -no warnings 'redefine' ; -sub frèd () { 1 } -EXPECT -Constant subroutine frèd redefined at - line 6. -######## -# op.c -use utf8; -use open qw( :utf8 :std ); -sub frèd () { 1 } -sub frèd () { 2 } -EXPECT -Constant subroutine frèd redefined at - line 5. -######## -# op.c -use utf8; -use open qw( :utf8 :std ); -sub frèd () { 1 } -*frèd = sub () { 2 }; -EXPECT -Constant subroutine main::frèd redefined at - line 5. -######## -# op.c -use warnings 'redefine' ; -use utf8; -use open qw( :utf8 :std ); -sub ᚠርƊ {} -sub ᚠርƊ {} -no warnings 'redefine' ; -sub ᚠርƊ {} -EXPECT -Subroutine ᚠርƊ redefined at - line 6. -######## -# op.c -use warnings 'redefine' ; -use utf8; -use open qw( :utf8 :std ); -sub ᚠርƊ () { 1 } -sub ᚠርƊ () { 1 } -no warnings 'redefine' ; -sub ᚠርƊ () { 1 } -EXPECT -Constant subroutine ᚠርƊ redefined at - line 6. -######## -# op.c -use utf8; -use open qw( :utf8 :std ); -sub ᚠርƊ () { 1 } -sub ᚠርƊ () { 2 } -EXPECT -Constant subroutine ᚠርƊ redefined at - line 5. -######## -# op.c -use utf8; -use open qw( :utf8 :std ); -sub ᚠርƊ () { 1 } -*ᚠርƊ = sub () { 2 }; -EXPECT -Constant subroutine main::ᚠርƊ redefined at - line 5. -######## -# OPTION regex -sub DynaLoader::dl_error {}; -use warnings; -# We're testing that the warnings report the same line number: -eval <<'EOC' or die $@; -{ - DynaLoader::boot_DynaLoader("DynaLoader"); -} -EOC -eval <<'EOC' or die $@; -BEGIN { - DynaLoader::boot_DynaLoader("DynaLoader"); -} -1 -EOC -EXPECT -OPTION regex -\ASubroutine DynaLoader::dl_error redefined at \(eval 1\) line 2\. -?(?s).* -Subroutine DynaLoader::dl_error redefined at \(eval 2\) line 2\. -######## -# op.c -use warnings; -sub do_warn_1 { return $a or $b; } -sub do_warn_2 { return $a and $b; } -sub do_warn_3 { return $a xor $b; } -sub do_warn_4 { die $a or $b; } -sub do_warn_5 { die $a and $b; } -sub do_warn_6 { die $a xor $b; } -sub do_warn_7 { exit $a or $b; } -sub do_warn_8 { exit $a and $b; } -sub do_warn_9 { exit $a xor $b; } - -# Since exit is an unary operator, it is even stronger than -# || and &&. -sub do_warn_10 { exit $a || $b; } -sub do_warn_11 { exit $a && $b; } - -sub do_warn_12 { goto $a or $b; } -sub do_warn_13 { goto $a and $b; } -sub do_warn_14 { goto $a xor $b; } -sub do_warn_15 { next $a or $b while(1); } -sub do_warn_16 { next $a and $b while(1); } -sub do_warn_17 { next $a xor $b while(1); } -sub do_warn_18 { last $a or $b while(1); } -sub do_warn_19 { last $a and $b while(1); } -sub do_warn_20 { last $a xor $b while(1); } -sub do_warn_21 { redo $a or $b while(1); } -sub do_warn_22 { redo $a and $b while(1); } -sub do_warn_23 { redo $a xor $b while(1); } -# These get re-written to "(return/die $a) and $b" -sub do_warn_24 { $b if return $a; } -sub do_warn_25 { $b if die $a; } -EXPECT -Possible precedence issue with control flow operator at - line 3. -Possible precedence issue with control flow operator at - line 4. -Possible precedence issue with control flow operator at - line 5. -Possible precedence issue with control flow operator at - line 6. -Possible precedence issue with control flow operator at - line 7. -Possible precedence issue with control flow operator at - line 8. -Possible precedence issue with control flow operator at - line 9. -Possible precedence issue with control flow operator at - line 10. -Possible precedence issue with control flow operator at - line 11. -Possible precedence issue with control flow operator at - line 15. -Possible precedence issue with control flow operator at - line 16. -Possible precedence issue with control flow operator at - line 18. -Possible precedence issue with control flow operator at - line 19. -Possible precedence issue with control flow operator at - line 20. -Possible precedence issue with control flow operator at - line 21. -Possible precedence issue with control flow operator at - line 22. -Possible precedence issue with control flow operator at - line 23. -Possible precedence issue with control flow operator at - line 24. -Possible precedence issue with control flow operator at - line 25. -Possible precedence issue with control flow operator at - line 26. -Possible precedence issue with control flow operator at - line 27. -Possible precedence issue with control flow operator at - line 28. -Possible precedence issue with control flow operator at - line 29. -Possible precedence issue with control flow operator at - line 31. -Possible precedence issue with control flow operator at - line 32. -######## -# op.c -# (same as above, except these should not warn) -use constant FEATURE => 1; -use constant MISSING_FEATURE => 0; - -sub dont_warn_1 { MISSING_FEATURE and return or dont_warn_3(); } -sub dont_warn_2 { FEATURE || return and dont_warn_3(); } -sub dont_warn_3 { not FEATURE and return or dont_warn_3(); } -sub dont_warn_4 { !MISSING_FEATURE || return and dont_warn_3(); } -sub dont_warn_5 { MISSING_FEATURE and die or dont_warn_3(); } -sub dont_warn_6 { FEATURE || die and dont_warn_3(); } -sub dont_warn_7 { not FEATURE and die or dont_warn_3(); } -sub dont_warn_8 { !MISSING_FEATURE || die and dont_warn_3(); } -sub dont_warn_9 { MISSING_FEATURE and goto $a or dont_warn_3(); } -sub dont_warn_10 { FEATURE || goto $a and dont_warn_3(); } -sub dont_warn_11 { not FEATURE and goto $a or dont_warn_3(); } -sub dont_warn_12 { !MISSING_FEATURE || goto $a and dont_warn_3(); } - -sub dont_warn_13 { MISSING_FEATURE and exit $a or dont_warn_3(); } -sub dont_warn_14 { FEATURE || exit $a and dont_warn_3(); } -sub dont_warn_15 { not FEATURE and exit $a or dont_warn_3(); } -sub dont_warn_16 { !MISSING_FEATURE || exit $a and dont_warn_3(); } - -sub dont_warn_17 { MISSING_FEATURE and next or dont_warn_3() while(1); } -sub dont_warn_18 { FEATURE || next and dont_warn_3() while(1); } -sub dont_warn_19 { not FEATURE and next or dont_warn_3() while(1); } -sub dont_warn_20 { !MISSING_FEATURE || next and dont_warn_3() while(1); } -sub dont_warn_21 { MISSING_FEATURE and redo or dont_warn_3() while(1); } -sub dont_warn_22 { FEATURE || redo and dont_warn_3() while(1); } -sub dont_warn_23 { not FEATURE and redo or dont_warn_3() while(1); } -sub dont_warn_24 { !MISSING_FEATURE || redo and dont_warn_3() while(1); } -sub dont_warn_25 { MISSING_FEATURE and last or dont_warn_3() while(1); } -sub dont_warn_26 { FEATURE || last and dont_warn_3() while(1); } -sub dont_warn_27 { not FEATURE and last or dont_warn_3() while(1); } -sub dont_warn_28 { !MISSING_FEATURE || last and dont_warn_3() while(1); } - -# These are weird, but at least not ambiguous. -sub dont_warn_29 { return ($a or $b); } -sub dont_warn_30 { return ($a and $b); } -sub dont_warn_31 { return ($a xor $b); } -sub dont_warn_32 { die ($a or $b); } -sub dont_warn_33 { die ($a and $b); } -sub dont_warn_34 { die ($a xor $b); } -sub dont_warn_35 { goto ($a or $b); } -sub dont_warn_36 { goto ($a and $b); } -sub dont_warn_37 { goto ($a xor $b); } -sub dont_warn_38 { next ($a or $b) while(1); } -sub dont_warn_39 { next ($a and $b) while(1); } -sub dont_warn_40 { next ($a xor $b) while(1); } -sub dont_warn_41 { last ($a or $b) while(1); } -sub dont_warn_42 { last ($a and $b) while(1); } -sub dont_warn_43 { last ($a xor $b) while(1); } -sub dont_warn_44 { redo ($a or $b) while(1); } -sub dont_warn_45 { redo ($a and $b) while(1); } -sub dont_warn_46 { redo ($a xor $b) while(1); } -EXPECT -######## -use feature "signatures"; -sub aaa { 2 } -sub bbb ($a) { 4 } -$aaa = sub { 2 }; -$bbb = sub ($a) { 4 }; -EXPECT -The signatures feature is experimental at - line 3. -The signatures feature is experimental at - line 5. -######## -no warnings "experimental::signatures"; -use feature "signatures"; -sub aaa { 2 } -sub bbb ($a) { 4 } -$aaa = sub { 2 }; -$bbb = sub ($a) { 4 }; -EXPECT diff --git a/gnu/usr.bin/perl/t/lib/warnings/perlio b/gnu/usr.bin/perl/t/lib/warnings/perlio index 0ccc5a884f4..63279ee0fe8 100644 --- a/gnu/usr.bin/perl/t/lib/warnings/perlio +++ b/gnu/usr.bin/perl/t/lib/warnings/perlio @@ -8,16 +8,16 @@ Setting cnt to %d, ptr implies %d -Invalid separator character %c%c%c in PerlIO layer specification %s +perlio: invalid separator character %c%c%c in layer specification list %s open(F, ">:-aa", "bb") -Argument list not closed for PerlIO layer \"%.*s\"" +perlio: argument list not closed for layer \"%.*s\"" open(F, ">:aa(", "bb") -Unknown PerlIO layer \"%.*s\" +perlio: unknown layer \"%.*s\" # PerlIO/xyz.pm has 1; open(F, ">xyz", "bb") @@ -31,7 +31,7 @@ use warnings 'layer'; open(F, ">:-aa", "bb"); close F; EXPECT -Invalid separator character '-' in PerlIO layer specification -aa at - line 6. +perlio: invalid separator character '-' in layer specification list -aa at - line 6. ######## # perlio [PerlIO_parse_layers] @@ -41,10 +41,10 @@ use warnings 'layer'; open(F, ">:aa(", "bb"); close F; EXPECT -Argument list not closed for PerlIO layer "aa(" at - line 6. +perlio: argument list not closed for layer "aa(" at - line 6. ######## ---FILE-- PerlIO_test_dir/xyz.pm +--FILE-- PerlIO/xyz.pm 1; --FILE-- # perlio [PerlIO_parse_layers] @@ -55,4 +55,4 @@ open(F, ">:xyz", "bb"); close F; END { 1 while unlink "bb" } # KEEP THIS WITH THE LAST TEST. EXPECT -Unknown PerlIO layer "xyz" at - line 5. +perlio: unknown layer "xyz". diff --git a/gnu/usr.bin/perl/t/lib/warnings/pp b/gnu/usr.bin/perl/t/lib/warnings/pp index ab8f9516518..5ed7aa08916 100644 --- a/gnu/usr.bin/perl/t/lib/warnings/pp +++ b/gnu/usr.bin/perl/t/lib/warnings/pp @@ -6,6 +6,9 @@ Attempt to use reference as lvalue in substr $a = "ab" ; $b = \$a ; substr($b, 1,1) = $b + Use of uninitialized value in ref-to-glob cast [pp_rv2gv()] + *b = *{ undef()} + Use of uninitialized value in scalar dereference [pp_rv2sv()] my $a = undef ; my $b = $$a @@ -37,35 +40,18 @@ use warnings 'substr' ; $a = "ab" ; $b = \$a ; substr($b, 1,1) = "ab" ; -$b = \$a; -substr($b, 1,1) = "\x{100}" ; no warnings 'substr' ; -$b = \$a; substr($b, 1,1) = "ab" ; -$b = \$a; -substr($b, 1,1) = "\x{100}" ; EXPECT Attempt to use reference as lvalue in substr at - line 5. -Attempt to use reference as lvalue in substr at - line 7. ######## # pp.c -use warnings 'misc' ; -@a = qw( a b c ); -splice(@a, 4, 0, 'e') ; -@a = qw( a b c ); -splice(@a, 4, 1) ; -@a = qw( a b c ); -splice(@a, 4) ; -no warnings 'misc' ; -@a = qw( a b c ); -splice(@a, 4, 0, 'e') ; -@a = qw( a b c ); -splice(@a, 4, 1) ; -@a = qw( a b c ); -splice(@a, 4) ; +use warnings 'uninitialized' ; +*x = *{ undef() }; +no warnings 'uninitialized' ; +*y = *{ undef() }; EXPECT -splice() offset past end of array at - line 4. -splice() offset past end of array at - line 6. +Use of uninitialized value in ref-to-glob cast at - line 3. ######## # pp.c use warnings 'uninitialized'; @@ -73,7 +59,7 @@ $x = undef; $y = $$x; no warnings 'uninitialized' ; $u = undef; $v = $$u; EXPECT -Use of uninitialized value $x in scalar dereference at - line 3. +Use of uninitialized value in scalar dereference at - line 3. ######## # pp.c use warnings 'misc' ; @@ -102,18 +88,6 @@ EXPECT Constant subroutine foo undefined at - line 4. ######## # pp.c -use utf8; -use open qw( :utf8 :std ); -use warnings 'misc'; -sub à¸á¶± () { 1 } -undef &à¸á¶±; -no warnings 'misc'; -sub Æš () { 2 } -undef &Æš; -EXPECT -Constant subroutine à¸á¶± undefined at - line 6. -######## -# pp.c use warnings 'misc'; $foo = sub () { 3 }; undef &$foo; diff --git a/gnu/usr.bin/perl/t/lib/warnings/pp_hot b/gnu/usr.bin/perl/t/lib/warnings/pp_hot index 4e63073bff8..c008dd5f106 100644 --- a/gnu/usr.bin/perl/t/lib/warnings/pp_hot +++ b/gnu/usr.bin/perl/t/lib/warnings/pp_hot @@ -44,6 +44,9 @@ Deep recursion on anonymous subroutine [Perl_sub_crush_depth] $a = sub { &$a if $a++ < 200} &$a + Possible Y2K bug: about to append an integer to '19' [pp_concat] + $x = "19$yy\n"; + Use of reference "%s" as array index [pp_aelem] $x[\1] @@ -54,22 +57,10 @@ $f = $a = "abc" ; print $f $a; no warnings 'unopened' ; print $f $a; -use warnings; -no warnings 'unopened' ; -print $f $a; EXPECT print() on unopened filehandle abc at - line 4. ######## # pp_hot.c [pp_print] -use warnings 'unopened' ; -$SIG{__WARN__} = sub { warn $_[0] =~ s/\0/\\0/rug; }; -print {"a\0b"} "anc"; -print {"\0b"} "anc"; -EXPECT -print() on unopened filehandle a\0b at - line 4. -print() on unopened filehandle \0b at - line 5. -######## -# pp_hot.c [pp_print] use warnings 'io' ; # There is no guarantee that STDOUT is output only, or STDIN input only. # Certainly on some BSDs (at least FreeBSD, Darwin, BSDi) file descriptors @@ -99,24 +90,6 @@ Filehandle FH opened only for input at - line 19. Filehandle FOO opened only for input at - line 20. ######## # pp_hot.c [pp_print] -$SIG{__WARN__} = sub { warn $_[0] =~ s/\0/\\0/rug; }; -use warnings 'io' ; -my $file = "./xcv" ; unlink $file ; -open (FH, ">$file") or die $! ; -close FH or die $! ; -die "There is no file $file" unless -f $file ; -open ("a\0b", "<$file") or die $! ; -print {"a\0b"} "anc" ; -open ("\0b", "<$file") or die $! ; -print {"\0b"} "anc" ; -close "a\0b" or die $! ; -close "\0b" or die $! ; -unlink $file ; -EXPECT -Filehandle a\0b opened only for input at - line 9. -Filehandle \0b opened only for input at - line 11. -######## -# pp_hot.c [pp_print] use warnings 'closed' ; close STDIN ; print STDIN "anc"; @@ -127,9 +100,6 @@ no warnings 'closed' ; print STDIN "anc"; opendir STDIN, "."; print STDIN "anc"; -use warnings; -no warnings 'closed' ; -print STDIN "anc"; EXPECT print() on closed filehandle STDIN at - line 4. print() on closed filehandle STDIN at - line 6. @@ -143,7 +113,7 @@ my $fh = *STDOUT{IO}; close STDOUT or die "Can't close STDOUT"; print $fh "Shouldn't print anything, but shouldn't SEGV either\n"; EXPECT -print() on closed filehandle __ANONIO__ at - line 7. +print() on closed filehandle at - line 7. ######## # pp_hot.c [pp_print] package foo; @@ -169,7 +139,7 @@ my @b = @$a; no warnings 'uninitialized' ; my @c = @$a; EXPECT -Use of uninitialized value $a in array dereference at - line 4. +Use of uninitialized value in array dereference at - line 4. ######## # pp_hot.c [pp_rv2hv] use warnings 'uninitialized' ; @@ -178,7 +148,7 @@ my %b = %$a; no warnings 'uninitialized' ; my %c = %$a; EXPECT -Use of uninitialized value $a in hash dereference at - line 4. +Use of uninitialized value in hash dereference at - line 4. ######## # pp_hot.c [pp_aassign] use warnings 'misc' ; @@ -210,19 +180,6 @@ readline() on closed filehandle STDIN at - line 4. (Are you trying to call readline() on dirhandle STDIN?) ######## # pp_hot.c [Perl_do_readline] -use warnings 'closed' ; -close STDIN ; $a .= ; -opendir STDIN, "." ; $a .= ; -closedir STDIN; -no warnings 'closed' ; -opendir STDIN, "." ; $a .= ; -$a = ; -EXPECT -readline() on closed filehandle STDIN at - line 3. -readline() on closed filehandle STDIN at - line 4. - (Are you trying to call readline() on dirhandle STDIN?) -######## -# pp_hot.c [Perl_do_readline] use warnings 'io' ; my $file = "./xcv" ; unlink $file ; open (FH, ">$file") or die $! ; @@ -306,11 +263,37 @@ a($x . $y); # should warn twice $x .= $y; # should warn once $y .= $y; # should warn once EXPECT -Use of uninitialized value $x in concatenation (.) or string at - line 5. -Use of uninitialized value $x in concatenation (.) or string at - line 6. -Use of uninitialized value $y in concatenation (.) or string at - line 6. -Use of uninitialized value $y in concatenation (.) or string at - line 7. -Use of uninitialized value $y in concatenation (.) or string at - line 8. +Use of uninitialized value in concatenation (.) or string at - line 5. +Use of uninitialized value in concatenation (.) or string at - line 6. +Use of uninitialized value in concatenation (.) or string at - line 6. +Use of uninitialized value in concatenation (.) or string at - line 7. +Use of uninitialized value in concatenation (.) or string at - line 8. +######## +# pp_hot.c [pp_concat] +use warnings 'y2k'; +use Config; +BEGIN { + unless ($Config{ccflags} =~ /Y2KWARN/) { + print "SKIPPED\n# perl not built with -DPERL_Y2KWARN"; + exit 0; + } +} +my $x; +my $yy = 78; +$x = "19$yy\n"; +$x = "19" . $yy . "\n"; +$x = "319$yy\n"; +$x = "319" . $yy . "\n"; +$yy = 19; +$x = "ok $yy\n"; +$yy = 9; +$x = 1 . $yy; +no warnings 'y2k'; +$x = "19$yy\n"; +$x = "19" . $yy . "\n"; +EXPECT +Possible Y2K bug: about to append an integer to '19' at - line 12. +Possible Y2K bug: about to append an integer to '19' at - line 13. ######## # pp_hot.c [pp_aelem] { diff --git a/gnu/usr.bin/perl/t/lib/warnings/pp_sys b/gnu/usr.bin/perl/t/lib/warnings/pp_sys index 69993275a2d..be8bb6244c2 100644 --- a/gnu/usr.bin/perl/t/lib/warnings/pp_sys +++ b/gnu/usr.bin/perl/t/lib/warnings/pp_sys @@ -103,12 +103,6 @@ getc() on closed filehandle [pp_getc] - Non-string passed as bitmask [pp_sselect] - - %s too large [pp_gmtime] - - %s failed [pp_gmtime] - __END__ # pp_sys.c [pp_untie] use warnings 'untie' ; @@ -135,57 +129,21 @@ Filehandle STDIN opened only for input at - line 5. use warnings 'closed' ; format STDIN = . -format FOO = -. close STDIN; write STDIN; -write FOO; opendir STDIN, "."; write STDIN; closedir STDIN; -opendir FOO, "."; -write FOO; -closedir FOO; no warnings 'closed' ; write STDIN; -write FOO; opendir STDIN, "."; -opendir FOO, "."; write STDIN; -write FOO; EXPECT +write() on closed filehandle STDIN at - line 6. write() on closed filehandle STDIN at - line 8. -write() on closed filehandle STDIN at - line 11. (Are you trying to call write() on dirhandle STDIN?) ######## # pp_sys.c [pp_leavewrite] -use warnings 'unopened'; -format STDIN = -. -format FOO = -. -close STDIN; -write STDIN; -write FOO; -opendir STDIN, "."; -write STDIN; -closedir STDIN; -opendir FOO, "."; -write FOO; -closedir FOO; -no warnings 'unopened'; -write STDIN; -write FOO; -opendir STDIN, "."; -opendir FOO, "."; -write STDIN; -write FOO; -EXPECT -write() on unopened filehandle FOO at - line 9. -write() on unopened filehandle FOO at - line 14. - (Are you trying to call write() on dirhandle FOO?) -######## -# pp_sys.c [pp_leavewrite] use warnings 'io' ; format STDOUT_TOP = abc @@ -237,14 +195,6 @@ EXPECT Filehandle STDIN opened only for input at - line 3. ######## # pp_sys.c [pp_send] -use warnings 'io' ; -syswrite STDIN, "fred"; -no warnings 'io' ; -syswrite STDIN, "fred"; -EXPECT -Filehandle STDIN opened only for input at - line 3. -######## -# pp_sys.c [pp_send] use warnings 'closed' ; close STDIN; syswrite STDIN, "fred", 1; @@ -294,7 +244,7 @@ flock() on unopened filehandle FOO at - line 19. flock() on unopened filehandle at - line 20. ######## # pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername] -use warnings 'closed'; +use warnings 'io' ; use Config; BEGIN { if ( $^O ne 'VMS' and ! $Config{d_socket}) { @@ -336,29 +286,7 @@ getsockopt STDIN, 1,2; getsockname STDIN; getpeername STDIN; closedir STDIN; -send FOO, "fred", 1; -bind FOO, "fred" ; -connect FOO, "fred" ; -listen FOO, 2; -accept "fred", FOO; -shutdown FOO, 0; -setsockopt FOO, 1,2,3; -getsockopt FOO, 1,2; -getsockname FOO; -getpeername FOO; -opendir FOO, "."; -send FOO, "fred", 1; -bind FOO, "fred" ; -connect FOO, "fred" ; -listen FOO, 2; -accept "fred", FOO; -shutdown FOO, 0; -setsockopt FOO, 1,2,3; -getsockopt FOO, 1,2; -getsockname FOO; -getpeername FOO; -closedir FOO; -no warnings 'closed'; +no warnings 'io' ; send STDIN, "fred", 1; bind STDIN, "fred" ; connect STDIN, "fred" ; @@ -380,27 +308,6 @@ setsockopt STDIN, 1,2,3; getsockopt STDIN, 1,2; getsockname STDIN; getpeername STDIN; -send FOO, "fred", 1; -bind FOO, "fred" ; -connect FOO, "fred" ; -listen FOO, 2; -accept FOO, "fred" ; -shutdown FOO, 0; -setsockopt FOO, 1,2,3; -getsockopt FOO, 1,2; -getsockname FOO; -getpeername FOO; -opendir FOO, "."; -send FOO, "fred", 1; -bind FOO, "fred" ; -connect FOO, "fred" ; -listen FOO, 2; -accept "fred", FOO; -shutdown FOO, 0; -setsockopt FOO, 1,2,3; -getsockopt FOO, 1,2; -getsockname FOO; -getpeername FOO; EXPECT send() on closed socket STDIN at - line 22. bind() on closed socket STDIN at - line 23. @@ -433,146 +340,6 @@ getsockname() on closed socket STDIN at - line 41. getpeername() on closed socket STDIN at - line 42. (Are you trying to call getpeername() on dirhandle STDIN?) ######## -# pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername] -use warnings 'unopened'; -use Config; -BEGIN { - if ( $^O ne 'VMS' and ! $Config{d_socket}) { - print < 'non_unicode'; -"\x{110000}" =~ /b?\p{Space}/; -EXPECT -Matched non-Unicode code point 0x110000 against Unicode property; may not be portable at - line 3. -######## -# NAME Matching POSIX class property against above-Unicode code point doesn't output a warning -use warnings 'non_unicode'; -use warnings FATAL => 'non_unicode'; -"\x{110000}" =~ /b?[[:space:]]/; -EXPECT +my $d7ff = chr(0xD7FF); +my $d800 = chr(0xD800); +my $dfff = chr(0xDFFF); +my $e000 = chr(0xE000); +my $feff = chr(0xFEFF); +my $fffd = chr(0xFFFD); +my $fffe = chr(0xFFFE); +my $ffff = chr(0xFFFF); +my $hex4 = chr(0x10000); +my $hex5 = chr(0x100000); +my $maxm1 = chr(0x10FFFE); +my $max = chr(0x10FFFF); +EXPECT +UTF-16 surrogate 0xd800 at - line 3. +UTF-16 surrogate 0xdfff at - line 4. +Unicode character 0xfffe is illegal at - line 8. +Unicode character 0xffff is illegal at - line 9. +Unicode character 0x10fffe is illegal at - line 12. +Unicode character 0x10ffff is illegal at - line 13. ######## use warnings 'utf8'; -chr(0x110000) =~ /\p{Any}/; -######## -# NAME utf8, non_unicode warnings categories work on Matched non-Unicode code point warning -use warnings qw(utf8 non_unicode); -chr(0x110000) =~ /^\p{Unassigned}/; -no warnings 'non_unicode'; -chr(0x110001) =~ /\p{Unassigned}/; -use warnings 'non_unicode'; +my $d7ff = pack("U", 0xD7FF); +my $d800 = pack("U", 0xD800); +my $dfff = pack("U", 0xDFFF); +my $e000 = pack("U", 0xE000); +my $feff = pack("U", 0xFEFF); +my $fffd = pack("U", 0xFFFD); +my $fffe = pack("U", 0xFFFE); +my $ffff = pack("U", 0xFFFF); +my $hex4 = pack("U", 0x10000); +my $hex5 = pack("U", 0x100000); +my $maxm1 = pack("U", 0x10FFFE); +my $max = pack("U", 0x10FFFF); no warnings 'utf8'; -chr(0x110002) =~ /\p{Unassigned}/; -EXPECT -Matched non-Unicode code point 0x110000 against Unicode property; may not be portable at - line 2. -######## -# NAME optimizable regnode should still give non_unicode warnings when fatalized -use warnings 'utf8'; -use warnings FATAL => 'non_unicode'; -chr(0x110000) =~ /\p{lb=cr}/; -EXPECT -Matched non-Unicode code point 0x110000 against Unicode property; may not be portable at - line 3. +my $d7ff = pack("U", 0xD7FF); +my $d800 = pack("U", 0xD800); +my $dfff = pack("U", 0xDFFF); +my $e000 = pack("U", 0xE000); +my $feff = pack("U", 0xFEFF); +my $fffd = pack("U", 0xFFFD); +my $fffe = pack("U", 0xFFFE); +my $ffff = pack("U", 0xFFFF); +my $hex4 = pack("U", 0x10000); +my $hex5 = pack("U", 0x100000); +my $maxm1 = pack("U", 0x10FFFE); +my $max = pack("U", 0x10FFFF); +EXPECT +UTF-16 surrogate 0xd800 at - line 3. +UTF-16 surrogate 0xdfff at - line 4. +Unicode character 0xfffe is illegal at - line 8. +Unicode character 0xffff is illegal at - line 9. +Unicode character 0x10fffe is illegal at - line 12. +Unicode character 0x10ffff is illegal at - line 13. ######## -# NAME optimizable regnode should not give non_unicode warnings when warnings are off -no warnings 'non_unicode'; -chr(0x110000) =~ /\p{lb=cr}/; -EXPECT -######## -# NAME 'All' matches above-Unicode without any warning -use warnings qw(utf8 non_unicode); -chr(0x110000) =~ /\p{All}/; -EXPECT -######## -require "../test.pl"; -use warnings 'utf8'; -sub Is_Super { return '!utf8::Any' } -# The extra char is to avoid an optimization that avoids the problem when the -# property is the only non-latin1 char in a class -print "\x{1100000}" =~ /^[\p{Is_Super}\x{100}]$/, "\n"; -EXPECT -1 -######## -require "../test.pl"; -use warnings 'utf8'; -my $file = tempfile(); -open(my $fh, "+>:utf8", $file); -print $fh "\x{D7FF}", "\n"; -print $fh "\x{D800}", "\n"; -print $fh "\x{DFFF}", "\n"; -print $fh "\x{E000}", "\n"; -print $fh "\x{FDCF}", "\n"; -print $fh "\x{FDD0}", "\n"; -print $fh "\x{FDEF}", "\n"; -print $fh "\x{FDF0}", "\n"; -print $fh "\x{FEFF}", "\n"; -print $fh "\x{FFFD}", "\n"; -print $fh "\x{FFFE}", "\n"; -print $fh "\x{FFFF}", "\n"; -print $fh "\x{10000}", "\n"; -print $fh "\x{1FFFE}", "\n"; -print $fh "\x{1FFFF}", "\n"; -print $fh "\x{2FFFE}", "\n"; -print $fh "\x{2FFFF}", "\n"; -print $fh "\x{3FFFE}", "\n"; -print $fh "\x{3FFFF}", "\n"; -print $fh "\x{4FFFE}", "\n"; -print $fh "\x{4FFFF}", "\n"; -print $fh "\x{5FFFE}", "\n"; -print $fh "\x{5FFFF}", "\n"; -print $fh "\x{6FFFE}", "\n"; -print $fh "\x{6FFFF}", "\n"; -print $fh "\x{7FFFE}", "\n"; -print $fh "\x{7FFFF}", "\n"; -print $fh "\x{8FFFE}", "\n"; -print $fh "\x{8FFFF}", "\n"; -print $fh "\x{9FFFE}", "\n"; -print $fh "\x{9FFFF}", "\n"; -print $fh "\x{AFFFE}", "\n"; -print $fh "\x{AFFFF}", "\n"; -print $fh "\x{BFFFE}", "\n"; -print $fh "\x{BFFFF}", "\n"; -print $fh "\x{CFFFE}", "\n"; -print $fh "\x{CFFFF}", "\n"; -print $fh "\x{DFFFE}", "\n"; -print $fh "\x{DFFFF}", "\n"; -print $fh "\x{EFFFE}", "\n"; -print $fh "\x{EFFFF}", "\n"; -print $fh "\x{FFFFE}", "\n"; -print $fh "\x{FFFFF}", "\n"; -print $fh "\x{100000}", "\n"; -print $fh "\x{10FFFE}", "\n"; -print $fh "\x{10FFFF}", "\n"; -print $fh "\x{110000}", "\n"; -close $fh; -EXPECT -Unicode surrogate U+D800 is illegal in UTF-8 at - line 6. -Unicode surrogate U+DFFF is illegal in UTF-8 at - line 7. -Unicode non-character U+FDD0 is illegal for open interchange at - line 10. -Unicode non-character U+FDEF is illegal for open interchange at - line 11. -Unicode non-character U+FFFE is illegal for open interchange at - line 15. -Unicode non-character U+FFFF is illegal for open interchange at - line 16. -Unicode non-character U+1FFFE is illegal for open interchange at - line 18. -Unicode non-character U+1FFFF is illegal for open interchange at - line 19. -Unicode non-character U+2FFFE is illegal for open interchange at - line 20. -Unicode non-character U+2FFFF is illegal for open interchange at - line 21. -Unicode non-character U+3FFFE is illegal for open interchange at - line 22. -Unicode non-character U+3FFFF is illegal for open interchange at - line 23. -Unicode non-character U+4FFFE is illegal for open interchange at - line 24. -Unicode non-character U+4FFFF is illegal for open interchange at - line 25. -Unicode non-character U+5FFFE is illegal for open interchange at - line 26. -Unicode non-character U+5FFFF is illegal for open interchange at - line 27. -Unicode non-character U+6FFFE is illegal for open interchange at - line 28. -Unicode non-character U+6FFFF is illegal for open interchange at - line 29. -Unicode non-character U+7FFFE is illegal for open interchange at - line 30. -Unicode non-character U+7FFFF is illegal for open interchange at - line 31. -Unicode non-character U+8FFFE is illegal for open interchange at - line 32. -Unicode non-character U+8FFFF is illegal for open interchange at - line 33. -Unicode non-character U+9FFFE is illegal for open interchange at - line 34. -Unicode non-character U+9FFFF is illegal for open interchange at - line 35. -Unicode non-character U+AFFFE is illegal for open interchange at - line 36. -Unicode non-character U+AFFFF is illegal for open interchange at - line 37. -Unicode non-character U+BFFFE is illegal for open interchange at - line 38. -Unicode non-character U+BFFFF is illegal for open interchange at - line 39. -Unicode non-character U+CFFFE is illegal for open interchange at - line 40. -Unicode non-character U+CFFFF is illegal for open interchange at - line 41. -Unicode non-character U+DFFFE is illegal for open interchange at - line 42. -Unicode non-character U+DFFFF is illegal for open interchange at - line 43. -Unicode non-character U+EFFFE is illegal for open interchange at - line 44. -Unicode non-character U+EFFFF is illegal for open interchange at - line 45. -Unicode non-character U+FFFFE is illegal for open interchange at - line 46. -Unicode non-character U+FFFFF is illegal for open interchange at - line 47. -Unicode non-character U+10FFFE is illegal for open interchange at - line 49. -Unicode non-character U+10FFFF is illegal for open interchange at - line 50. -Code point 0x110000 is not Unicode, may not be portable at - line 51. -######## -require "../test.pl"; -use warnings 'utf8'; -my $file = tempfile(); -open(my $fh, "+>:utf8", $file); -print $fh "\x{D800}", "\n"; -print $fh "\x{FFFF}", "\n"; -print $fh "\x{110000}", "\n"; -close $fh; -EXPECT -Unicode surrogate U+D800 is illegal in UTF-8 at - line 5. -Unicode non-character U+FFFF is illegal for open interchange at - line 6. -Code point 0x110000 is not Unicode, may not be portable at - line 7. -######## -require "../test.pl"; -use warnings 'utf8'; -no warnings 'surrogate'; -my $file = tempfile(); -open(my $fh, "+>:utf8", $file); -print $fh "\x{D800}", "\n"; -print $fh "\x{FFFF}", "\n"; -print $fh "\x{110000}", "\n"; -close $fh; -EXPECT -Unicode non-character U+FFFF is illegal for open interchange at - line 7. -Code point 0x110000 is not Unicode, may not be portable at - line 8. -######## -require "../test.pl"; use warnings 'utf8'; -no warnings 'nonchar'; -my $file = tempfile(); -open(my $fh, "+>:utf8", $file); -print $fh "\x{D800}", "\n"; -print $fh "\x{FFFF}", "\n"; -print $fh "\x{110000}", "\n"; -close $fh; -EXPECT -Unicode surrogate U+D800 is illegal in UTF-8 at - line 6. -Code point 0x110000 is not Unicode, may not be portable at - line 8. -######## -require "../test.pl"; -use warnings 'utf8'; -no warnings 'non_unicode'; -my $file = tempfile(); -open(my $fh, "+>:utf8", $file); -print $fh "\x{D800}", "\n"; -print $fh "\x{FFFF}", "\n"; -print $fh "\x{110000}", "\n"; -close $fh; -EXPECT -Unicode surrogate U+D800 is illegal in UTF-8 at - line 6. -Unicode non-character U+FFFF is illegal for open interchange at - line 7. -######## -# NAME C works in isolation -require "../test.pl"; -use warnings 'nonchar'; -my $file = tempfile(); -open(my $fh, "+>:utf8", $file); -print $fh "\x{FFFF}", "\n"; -close $fh; -EXPECT -Unicode non-character U+FFFF is illegal for open interchange at - line 5. -######## -# NAME C works in isolation -require "../test.pl"; -use warnings 'surrogate'; -my $file = tempfile(); -open(my $fh, "+>:utf8", $file); -print $fh "\x{D800}", "\n"; -close $fh; -EXPECT -Unicode surrogate U+D800 is illegal in UTF-8 at - line 5. -######## -# NAME C works in isolation -require "../test.pl"; -use warnings 'non_unicode'; -my $file = tempfile(); -open(my $fh, "+>:utf8", $file); -print $fh "\x{110000}", "\n"; -close $fh; -EXPECT -Code point 0x110000 is not Unicode, may not be portable at - line 5. -######## -require "../test.pl"; +my $d7ff = "\x{D7FF}"; +my $d800 = "\x{D800}"; +my $dfff = "\x{DFFF}"; +my $e000 = "\x{E000}"; +my $feff = "\x{FEFF}"; +my $fffd = "\x{FFFD}"; +my $fffe = "\x{FFFE}"; +my $ffff = "\x{FFFF}"; +my $hex4 = "\x{10000}"; +my $hex5 = "\x{100000}"; +my $maxm1 = "\x{10FFFE}"; +my $max = "\x{10FFFF}"; no warnings 'utf8'; -my $file = tempfile(); -open(my $fh, "+>:utf8", $file); -print $fh "\x{D7FF}", "\n"; -print $fh "\x{D800}", "\n"; -print $fh "\x{DFFF}", "\n"; -print $fh "\x{E000}", "\n"; -print $fh "\x{FDCF}", "\n"; -print $fh "\x{FDD0}", "\n"; -print $fh "\x{FDEF}", "\n"; -print $fh "\x{FDF0}", "\n"; -print $fh "\x{FEFF}", "\n"; -print $fh "\x{FFFD}", "\n"; -print $fh "\x{FFFE}", "\n"; -print $fh "\x{FFFF}", "\n"; -print $fh "\x{10000}", "\n"; -print $fh "\x{1FFFE}", "\n"; -print $fh "\x{1FFFF}", "\n"; -print $fh "\x{2FFFE}", "\n"; -print $fh "\x{2FFFF}", "\n"; -print $fh "\x{3FFFE}", "\n"; -print $fh "\x{3FFFF}", "\n"; -print $fh "\x{4FFFE}", "\n"; -print $fh "\x{4FFFF}", "\n"; -print $fh "\x{5FFFE}", "\n"; -print $fh "\x{5FFFF}", "\n"; -print $fh "\x{6FFFE}", "\n"; -print $fh "\x{6FFFF}", "\n"; -print $fh "\x{7FFFE}", "\n"; -print $fh "\x{7FFFF}", "\n"; -print $fh "\x{8FFFE}", "\n"; -print $fh "\x{8FFFF}", "\n"; -print $fh "\x{9FFFE}", "\n"; -print $fh "\x{9FFFF}", "\n"; -print $fh "\x{AFFFE}", "\n"; -print $fh "\x{AFFFF}", "\n"; -print $fh "\x{BFFFE}", "\n"; -print $fh "\x{BFFFF}", "\n"; -print $fh "\x{CFFFE}", "\n"; -print $fh "\x{CFFFF}", "\n"; -print $fh "\x{DFFFE}", "\n"; -print $fh "\x{DFFFF}", "\n"; -print $fh "\x{EFFFE}", "\n"; -print $fh "\x{EFFFF}", "\n"; -print $fh "\x{FFFFE}", "\n"; -print $fh "\x{FFFFF}", "\n"; -print $fh "\x{100000}", "\n"; -print $fh "\x{10FFFE}", "\n"; -print $fh "\x{10FFFF}", "\n"; -print $fh "\x{110000}", "\n"; -close $fh; -EXPECT +my $d7ff = "\x{D7FF}"; +my $d800 = "\x{D800}"; +my $dfff = "\x{DFFF}"; +my $e000 = "\x{E000}"; +my $feff = "\x{FEFF}"; +my $fffd = "\x{FFFD}"; +my $fffe = "\x{FFFE}"; +my $ffff = "\x{FFFF}"; +my $hex4 = "\x{10000}"; +my $hex5 = "\x{100000}"; +my $maxm1 = "\x{10FFFE}"; +my $max = "\x{10FFFF}"; +EXPECT +UTF-16 surrogate 0xd800 at - line 3. +UTF-16 surrogate 0xdfff at - line 4. +Unicode character 0xfffe is illegal at - line 8. +Unicode character 0xffff is illegal at - line 9. +Unicode character 0x10fffe is illegal at - line 12. +Unicode character 0x10ffff is illegal at - line 13. diff --git a/gnu/usr.bin/perl/t/op/alarm.t b/gnu/usr.bin/perl/t/op/alarm.t index 82691c5cf2d..8fb92964a3a 100644 --- a/gnu/usr.bin/perl/t/op/alarm.t +++ b/gnu/usr.bin/perl/t/op/alarm.t @@ -13,52 +13,39 @@ BEGIN { } } -plan tests => 5; +plan tests => 4; my $Perl = which_perl(); -my ($start_time, $end_time); - +my $start_time = time; eval { - local $SIG{ALRM} = sub { $end_time = time; die "ALARM!\n" }; - $start_time = time; + local $SIG{ALRM} = sub { die "ALARM!\n" }; alarm 3; # perlfunc recommends against using sleep in combination with alarm. - 1 while (($end_time = time) - $start_time < 6); - alarm 0; + 1 while (time - $start_time < 6); }; alarm 0; -my $diff = $end_time - $start_time; +my $diff = time - $start_time; # alarm time might be one second less than you said. is( $@, "ALARM!\n", 'alarm w/$SIG{ALRM} vs inf loop' ); -ok( abs($diff - 3) <= 1, " right time (waited $diff secs for 3-sec alarm)" ); +ok( abs($diff - 3) <= 1, " right time" ); +my $start_time = time; eval { - local $SIG{ALRM} = sub { $end_time = time; die "ALARM!\n" }; - $start_time = time; + local $SIG{ALRM} = sub { die "ALARM!\n" }; alarm 3; system(qq{$Perl -e "sleep 6"}); - $end_time = time; - alarm 0; }; alarm 0; -$diff = $end_time - $start_time; +$diff = time - $start_time; # alarm time might be one second less than you said. is( $@, "ALARM!\n", 'alarm w/$SIG{ALRM} vs system()' ); { local $TODO = "Why does system() block alarm() on $^O?" - if $^O eq 'VMS' || $^O eq 'dos'; + if $^O eq 'VMS' || $^O eq'MacOS' || $^O eq 'dos'; ok( abs($diff - 3) <= 1, " right time (waited $diff secs for 3-sec alarm)" ); } - - -{ - local $SIG{"ALRM"} = sub { die }; - eval { alarm(1); my $x = qx($Perl -e "sleep 3"); alarm(0); }; - chomp (my $foo = "foo\n"); - ok($foo eq "foo", '[perl #33928] chomp() fails after alarm(), `sleep`'); -} diff --git a/gnu/usr.bin/perl/t/op/caller.t b/gnu/usr.bin/perl/t/op/caller.t index 54a6bac0a73..751a161de2a 100644 --- a/gnu/usr.bin/perl/t/op/caller.t +++ b/gnu/usr.bin/perl/t/op/caller.t @@ -5,12 +5,13 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; - plan( tests => 95 ); } +plan( tests => 20 ); + my @c; -BEGIN { print "# Tests with caller(0)\n"; } +print "# Tests with caller(0)\n"; @c = caller(0); ok( (!@c), "caller(0) in main program" ); @@ -19,7 +20,7 @@ eval { @c = caller(0) }; is( $c[3], "(eval)", "subroutine name in an eval {}" ); ok( !$c[4], "hasargs false in an eval {}" ); -eval q{ @c = caller(0) }; +eval q{ @c = (Caller(0))[3] }; is( $c[3], "(eval)", "subroutine name in an eval ''" ); ok( !$c[4], "hasargs false in an eval ''" ); @@ -31,14 +32,8 @@ ok( $c[4], "hasargs true with anon sub" ); sub foo { @c = caller(0) } my $fooref = delete $::{foo}; $fooref -> (); -is( $c[3], "main::__ANON__", "deleted subroutine name" ); -ok( $c[4], "hasargs true with deleted sub" ); - -BEGIN { - require strict; - is +(caller 0)[1], __FILE__, - "[perl #68712] filenames after require in a BEGIN block" -} +is( $c[3], "(unknown)", "unknown subroutine name" ); +ok( $c[4], "hasargs true with unknown sub" ); print "# Tests with caller(1)\n"; @@ -66,270 +61,5 @@ ok( $c[4], "hasargs true with anon sub" ); sub foo2 { f() } my $fooref2 = delete $::{foo2}; $fooref2 -> (); -is( $c[3], "main::__ANON__", "deleted subroutine name" ); -ok( $c[4], "hasargs true with deleted sub" ); - -# See if caller() returns the correct warning mask - -sub show_bits -{ - my $in = shift; - my $out = ''; - foreach (unpack('W*', $in)) { - $out .= sprintf('\x%02x', $_); - } - return $out; -} - -sub check_bits -{ - local $Level = $Level + 2; - my ($got, $exp, $desc) = @_; - if (! ok($got eq $exp, $desc)) { - diag(' got: ' . show_bits($got)); - diag('expected: ' . show_bits($exp)); - } -} - -sub testwarn { - my $w = shift; - my $id = shift; - check_bits( (caller(0))[9], $w, "warnings match caller ($id)"); -} - -{ - no warnings; - # Build the warnings mask dynamically - my ($default, $registered); - BEGIN { - for my $i (0..$warnings::LAST_BIT/2 - 1) { - vec($default, $i, 2) = 1; - } - $registered = $default; - vec($registered, $warnings::LAST_BIT/2, 2) = 1; - } - - # The repetition number must be set to the value of $BYTES in - # lib/warnings.pm - BEGIN { check_bits( ${^WARNING_BITS}, "\0" x 15, 'all bits off via "no warnings"' ) } - testwarn("\0" x 15, 'no bits'); - - use warnings; - BEGIN { check_bits( ${^WARNING_BITS}, $default, - 'default bits on via "use warnings"' ); } - BEGIN { testwarn($default, 'all'); } - # run-time : - # the warning mask has been extended by warnings::register - testwarn($registered, 'ahead of w::r'); - - use warnings::register; - BEGIN { check_bits( ${^WARNING_BITS}, $registered, - 'warning bits on via "use warnings::register"' ) } - testwarn($registered, 'following w::r'); -} - - -# The next two cases test for a bug where caller ignored evals if -# the DB::sub glob existed but &DB::sub did not (for example, if -# $^P had been set but no debugger has been loaded). The tests -# thus assume that there is no &DB::sub: if there is one, they -# should both pass no matter whether or not this bug has been -# fixed. - -my $debugger_test = q< - my @stackinfo = caller(0); - return scalar @stackinfo; ->; - -sub pb { return (caller(0))[3] } - -my $i = eval $debugger_test; -is( $i, 11, "do not skip over eval (and caller returns 10 elements)" ); - -is( eval 'pb()', 'main::pb', "actually return the right function name" ); - -my $saved_perldb = $^P; -$^P = 16; -$^P = $saved_perldb; - -$i = eval $debugger_test; -is( $i, 11, 'do not skip over eval even if $^P had been on at some point' ); -is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' ); - -print "# caller can now return the compile time state of %^H\n"; - -sub hint_exists { - my $key = shift; - my $level = shift; - my @results = caller($level||0); - exists $results[10]->{$key}; -} - -sub hint_fetch { - my $key = shift; - my $level = shift; - my @results = caller($level||0); - $results[10]->{$key}; -} - -{ - my $tmpfile = tempfile(); - - open my $fh, '>', $tmpfile or die "open $tmpfile: $!"; - print $fh <<'EOP'; -#!perl -wl -use strict; - -{ - package KAZASH ; - - sub DESTROY { - print "DESTROY"; - } -} - -@DB::args = bless [], 'KAZASH'; - -print $^P; -print scalar @DB::args; - -{ - local $^P = shift; -} - -@DB::args = (); # At this point, the object should be freed. - -print $^P; -print scalar @DB::args; - -# It shouldn't leak. -EOP - close $fh; - - foreach (0, 1) { - my $got = runperl(progfile => $tmpfile, args => [$_]); - $got =~ s/\s+/ /gs; - like($got, qr/\s*0 1 DESTROY 0 0\s*/, - "\@DB::args doesn't leak with \$^P = $_"); - } -} - -# This also used to leak [perl #97010]: -{ - my $gone; - sub fwib::DESTROY { ++$gone } - package DB; - sub { () = caller(0) }->(); # initialise PL_dbargs - @args = bless[],'fwib'; - sub { () = caller(0) }->(); # clobber @args without initialisation - ::is $gone, 1, 'caller does not leak @DB::args elems when AvREAL'; -} - -# And this crashed [perl #93320]: -sub { - package DB; - ()=caller(0); - undef *DB::args; - ()=caller(0); -}->(); -pass 'No crash when @DB::args is freed between caller calls'; - -# This also crashed: -package glelp; -sub TIEARRAY { bless [] } -sub EXTEND { } -sub CLEAR { } -sub FETCH { $_[0][$_[1]] } -sub STORE { $_[0][$_[1]] = $_[2] } -package DB; -tie @args, 'glelp'; -eval { sub { () = caller 0; } ->(1..3) }; -::like $@, qr "^Cannot set tied \@DB::args at ", - 'caller dies with tie @DB::args'; -::ok tied @args, '@DB::args is still tied'; -untie @args; -package main; - -# [perl #113486] -fresh_perl_is <<'END', "ok\n", {}, - { package foo; sub bar { main::bar() } } - sub bar { - delete $::{"foo::"}; - my $x = \($1+2); - my $y = \($1+2); # this is the one that reuses the mem addr, but - my $z = \($1+2); # try the others just in case - s/2// for $$x, $$y, $$z; # now SvOOK - $x = caller; - print "ok\n"; -}; -foo::bar -END - "No crash when freed stash is reused for PV with offset hack"; - -is eval "(caller 0)[6]", "(caller 0)[6]", - 'eval text returned by caller does not include \n;'; - -if (1) { - is (sub { (caller)[2] }->(), __LINE__, - '[perl #115768] caller gets line numbers from nulled cops'); -} -# Test it at the end of the program, too. -fresh_perl_is(<<'115768', 2, {}, - if (1) { - foo(); - } - sub foo { print +(caller)[2] } -115768 - '[perl #115768] caller gets line numbers from nulled cops (2)'); - -# PL_linestr should not be modifiable -eval '"${;BEGIN{ ${\(caller 2)[6]} = *foo }}"'; -pass "no assertion failure after modifying eval text via caller"; - -is eval "<(); - my $w; - local $SIG{__WARN__} = sub { $w++ }; - eval ' - use warnings; - BEGIN { ${^WARNING_BITS} = $bits } - local $^W = 1; - () = 1 + undef; - $^W = 0; - () = 1 + undef; - '; - is $w, 1, 'value from (caller 0)[9] (bitmask) works in ${^WARNING_BITS}'; -} - -# This was fixed with commit d4d03940c58a0177, which fixed bug #78742 -fresh_perl_is <<'END', "__ANON__::doof\n", {}, -package foo; -BEGIN {undef %foo::} -sub doof { caller(0) } -print +(doof())[3]; -END - "caller should not SEGV when the current package is undefined"; - -# caller should not SEGV when the eval entry has been cleared #120998 -fresh_perl_is <<'END', 'main', {}, -$SIG{__DIE__} = \&dbdie; -eval '/x'; -sub dbdie { - @x = caller(1); - print $x[0]; -} -END - "caller should not SEGV for eval '' stack frames"; - -$::testing_caller = 1; - -do './op/caller.pl' or die $@; +is( $c[3], "(unknown)", "unknown subroutine name" ); +ok( $c[4], "hasargs true with unknown sub" ); diff --git a/gnu/usr.bin/perl/t/op/chdir.t b/gnu/usr.bin/perl/t/op/chdir.t index 2c6535bde93..2932b922ea6 100644 --- a/gnu/usr.bin/perl/t/op/chdir.t +++ b/gnu/usr.bin/perl/t/op/chdir.t @@ -5,35 +5,14 @@ BEGIN { # chdir() works! Instead, we'll hedge our bets and put both # possibilities into @INC. @INC = qw(t . lib ../lib); - require "test.pl"; - # Really want to know if chdir is working, as the build process will all go - # wrong if it is not. - if (is_miniperl() && !eval {require File::Spec::Functions; 1}) { - push @INC, qw(dist/Cwd/lib dist/Cwd ../dist/Cwd/lib ../dist/Cwd); - } - plan(tests => 48); } use Config; +require "test.pl"; +plan(tests => 31); my $IsVMS = $^O eq 'VMS'; - -my $vms_unix_rpt = 0; -my $vms_efs = 0; -if ($IsVMS) { - if (eval 'require VMS::Feature') { - $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); - $vms_efs = VMS::Feature::current("efs_charset"); - } else { - my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; - my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; - $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; - $vms_efs = $efs_charset =~ /^[ET1]/i; - } -} - -# For an op regression test, I don't want to rely on "use constant" working. -my $has_fchdir = ($Config{d_fchdir} || "") eq "define"; +my $IsMacOS = $^O eq 'MacOS'; # Might be a little early in the testing process to start using these, # but I can't think of a way to write this test without them. @@ -42,9 +21,7 @@ use File::Spec::Functions qw(:DEFAULT splitdir rel2abs splitpath); # Can't use Cwd::abs_path() because it has different ideas about # path separators than File::Spec. sub abs_path { - my $d = rel2abs(curdir); - $d = lc($d) if $^O =~ /^uwin/; - $d; + $IsVMS ? uc(rel2abs(curdir)) : rel2abs(curdir); } my $Cwd = abs_path; @@ -52,14 +29,8 @@ my $Cwd = abs_path; # Let's get to a known position SKIP: { my ($vol,$dir) = splitpath(abs_path,1); - my $test_dir = 't'; - my $compare_dir = (splitdir($dir))[-1]; - - # VMS is case insensitive but will preserve case in EFS mode. - # So we must normalize the case for the compare. - - $compare_dir = lc($compare_dir) if $IsVMS; - skip("Already in t/", 2) if $compare_dir eq $test_dir; + my $test_dir = $IsVMS ? 'T' : 't'; + skip("Already in t/", 2) if (splitdir($dir))[-1] eq $test_dir; ok( chdir($test_dir), 'chdir($test_dir)'); is( abs_path, catdir($Cwd, $test_dir), ' abs_path() agrees' ); @@ -67,70 +38,6 @@ SKIP: { $Cwd = abs_path; -SKIP: { - skip("no fchdir", 16) unless $has_fchdir; - my $has_dirfd = ($Config{d_dirfd} || $Config{d_dir_dd_fd} || "") eq "define"; - ok(opendir(my $dh, "."), "opendir ."); - ok(open(my $fh, "<", "op"), "open op"); - ok(chdir($fh), "fchdir op"); - ok(-f "chdir.t", "verify that we are in op"); - if ($has_dirfd) { - ok(chdir($dh), "fchdir back"); - } - else { - eval { chdir($dh); }; - like($@, qr/^The dirfd function is unimplemented at/, "dirfd is unimplemented"); - chdir ".." or die $!; - } - - # same with bareword file handles - no warnings 'once'; - *DH = $dh; - *FH = $fh; - ok(chdir FH, "fchdir op bareword"); - ok(-f "chdir.t", "verify that we are in op"); - if ($has_dirfd) { - ok(chdir DH, "fchdir back bareword"); - } - else { - eval { chdir(DH); }; - like($@, qr/^The dirfd function is unimplemented at/, "dirfd is unimplemented"); - chdir ".." or die $!; - } - ok(-d "op", "verify that we are back"); - - # And now the ambiguous case - { - no warnings qw; - ok(opendir(H, "op"), "opendir op") or diag $!; - ok(open(H, "<", "base"), "open base") or diag $!; - } - if ($has_dirfd) { - ok(chdir(H), "fchdir to op"); - ok(-f "chdir.t", "verify that we are in 'op'"); - chdir ".." or die $!; - } - else { - eval { chdir(H); }; - like($@, qr/^The dirfd function is unimplemented at/, - "dirfd is unimplemented"); - SKIP: { - skip("dirfd is unimplemented"); - } - } - ok(closedir(H), "closedir"); - ok(chdir(H), "fchdir to base"); - ok(-f "cond.t", "verify that we are in 'base'"); - chdir ".." or die $!; -} - -SKIP: { - skip("has fchdir", 1) if $has_fchdir; - opendir(my $dh, "op"); - eval { chdir($dh); }; - like($@, qr/^The fchdir function is unimplemented at/, "fchdir is unimplemented"); -} - # The environment variables chdir() pays attention to. my @magic_envs = qw(HOME LOGDIR SYS$LOGIN); @@ -138,7 +45,7 @@ sub check_env { my($key) = @_; # Make sure $ENV{'SYS$LOGIN'} is only honored on VMS. - if( $key eq 'SYS$LOGIN' && !$IsVMS ) { + if( $key eq 'SYS$LOGIN' && !$IsVMS && !$IsMacOS ) { ok( !chdir(), "chdir() on $^O ignores only \$ENV{$key} set" ); is( abs_path, $Cwd, ' abs_path() did not change' ); pass( " no need to test SYS\$LOGIN on $^O" ) for 1..7; @@ -186,8 +93,10 @@ sub clean_env { next if $IsVMS && $env eq 'SYS$LOGIN'; next if $IsVMS && $env eq 'HOME' && !$Config{'d_setenv'}; - # On VMS, %ENV is many layered. - delete $ENV{$env} while exists $ENV{$env}; + unless ($IsMacOS) { # ENV on MacOS is "special" :-) + # On VMS, %ENV is many layered. + delete $ENV{$env} while exists $ENV{$env}; + } } # The following means we won't really be testing for non-existence, @@ -201,10 +110,6 @@ END { # Restore the environment for VMS (and doesn't hurt for anyone else) @ENV{@magic_envs} = @Saved_Env{@magic_envs}; - - # On VMS this must be deleted or process table is wrong on exit - # when this script is run interactively. - delete $ENV{'SYS$LOGIN'} if $IsVMS; } @@ -220,7 +125,7 @@ foreach my $key (@magic_envs) { { clean_env; - if ($IsVMS && !$Config{'d_setenv'}) { + if (($IsVMS || $IsMacOS) && !$Config{'d_setenv'}) { pass("Can't reset HOME, so chdir() test meaningless"); } else { ok( !chdir(), 'chdir() w/o any ENV set' ); diff --git a/gnu/usr.bin/perl/t/op/gmagic.t b/gnu/usr.bin/perl/t/op/gmagic.t index bcf1322578c..ab6d2ee3e65 100644 --- a/gnu/usr.bin/perl/t/op/gmagic.t +++ b/gnu/usr.bin/perl/t/op/gmagic.t @@ -1,188 +1,54 @@ #!./perl -w BEGIN { + $| = 1; chdir 't' if -d 't'; @INC = '../lib'; - require './test.pl'; } -use strict; +print "1..18\n"; +my $t = 1; tie my $c => 'Tie::Monitor'; -sub expected_tie_calls { - my ($obj, $rexp, $wexp, $tn) = @_; - local $::Level = $::Level + 1; - my ($rgot, $wgot) = $obj->init(); - is ($rgot, $rexp, $tn ? "number of fetches when $tn" : ()); - is ($wgot, $wexp, $tn ? "number of stores when $tn" : ()); +sub ok { + my($ok, $got, $exp, $rexp, $wexp) = @_; + my($rgot, $wgot) = (tied $c)->init(0); + print $ok ? "ok $t\n" : "# expected $exp, got $got\nnot ok $t\n"; + ++$t; + if ($rexp == $rgot && $wexp == $wgot) { + print "ok $t\n"; + } else { + print "# read $rgot expecting $rexp\n" if $rgot != $rexp; + print "# wrote $wgot expecting $wexp\n" if $wgot != $wexp; + print "not ok $t\n"; + } + ++$t; } -# Use ok() instead of is(), cmp_ok() etc, to strictly control number of accesses +sub ok_undef { ok(!defined($_[0]), shift, "undef", @_) } +sub ok_numeric { ok($_[0] == $_[1], @_) } +sub ok_string { ok($_[0] eq $_[1], @_) } + my($r, $s); -ok($r = $c + 0 == 0, 'the thing itself'); -expected_tie_calls(tied $c, 1, 0); -ok($r = "$c" eq '0', 'the thing itself'); -expected_tie_calls(tied $c, 1, 0); +# the thing itself +ok_numeric($r = $c + 0, 0, 1, 0); +ok_string($r = "$c", '0', 1, 0); -ok($c . 'x' eq '0x', 'concat'); -expected_tie_calls(tied $c, 1, 0); -ok('x' . $c eq 'x0', 'concat'); -expected_tie_calls(tied $c, 1, 0); +# concat +ok_string($c . 'x', '0x', 1, 0); +ok_string('x' . $c, 'x0', 1, 0); $s = $c . $c; -ok($s eq '00', 'concat'); -expected_tie_calls(tied $c, 2, 0); +ok_string($s, '00', 2, 0); $r = 'x'; $s = $c = $r . 'y'; -ok($s eq 'xy', 'concat'); -expected_tie_calls(tied $c, 1, 1); +ok_string($s, 'xy', 1, 1); $s = $c = $c . 'x'; -ok($s eq '0x', 'concat'); -expected_tie_calls(tied $c, 2, 1); +ok_string($s, '0x', 2, 1); $s = $c = 'x' . $c; -ok($s eq 'x0', 'concat'); -expected_tie_calls(tied $c, 2, 1); +ok_string($s, 'x0', 2, 1); $s = $c = $c . $c; -ok($s eq '00', 'concat'); -expected_tie_calls(tied $c, 3, 1); - -$s = chop($c); -ok($s eq '0', 'multiple magic in core functions'); -expected_tie_calls(tied $c, 1, 1); - -$c = *strat; -$s = $c; -ok($s eq *strat, - 'Assignment should not ignore magic when the last thing assigned was a glob'); -expected_tie_calls(tied $c, 1, 1); - -package o { use overload '""' => sub { "foo\n" } } -$c = bless [], o::; -chomp $c; -expected_tie_calls(tied $c, 1, 2, 'chomping a ref'); - -{ - my $outfile = tempfile(); - open my $h, ">$outfile" or die "$0 cannot close $outfile: $!"; - print $h "bar\n"; - close $h or die "$0 cannot close $outfile: $!"; - - $c = *foo; # 1 write - open $h, $outfile; - sysread $h, $c, 3, 7; # 1 read; 1 write - is $c, "*main::bar", 'what sysread wrote'; # 1 read - expected_tie_calls(tied $c, 2, 2, 'calling sysread with tied buf'); - close $h or die "$0 cannot close $outfile: $!"; - - # Do this again, with a utf8 handle - $c = *foo; # 1 write - open $h, "<:utf8", $outfile; - sysread $h, $c, 3, 7; # 1 read; 1 write - is $c, "*main::bar", 'what sysread wrote'; # 1 read - expected_tie_calls(tied $c, 2, 2, 'calling sysread with tied buf'); - close $h or die "$0 cannot close $outfile: $!"; - - unlink_all $outfile; -} - -# autovivication of aelem, helem, of rv2sv combined with get-magic -{ - my $true = 1; - my $s; - tie $$s, "Tie::Monitor"; - $$s = undef; - $$s->[0] = 73; - is($$s->[0], 73); - expected_tie_calls(tied $$s, 3, 2); - - my @a; - tie $a[0], "Tie::Monitor"; - $a[0] = undef; - $a[0][0] = 73; - is($a[0][0], 73); - expected_tie_calls(tied $a[0], 3, 2); - - my %h; - tie $h{foo}, "Tie::Monitor"; - $h{foo} = undef; - $h{foo}{bar} = 73; - is($h{foo}{bar}, 73); - expected_tie_calls(tied $h{foo}, 3, 2); - - # Similar tests, but with obscured autovivication by using dummy list or "?:" operator - $$s = undef; - ${ (), $$s }[0] = 73; - is( $$s->[0], 73); - expected_tie_calls(tied $$s, 3, 2); - - $$s = undef; - ( ! $true ? undef : $$s )->[0] = 73; - is( $$s->[0], 73); - expected_tie_calls(tied $$s, 3, 2); - - $$s = undef; - ( $true ? $$s : undef )->[0] = 73; - is( $$s->[0], 73); - expected_tie_calls(tied $$s, 3, 2); -} - -# A plain *foo should not call get-magic on *foo. -# This method of scalar-tying an immutable glob relies on details of the -# current implementation that are subject to change. This test may need to -# be rewritten if they do change. -my $tyre = tie $::{gelp} => 'Tie::Monitor'; -# Compilation of this eval autovivifies the *gelp glob. -eval '$tyre->init(0); () = \*gelp'; -my($rgot, $wgot) = $tyre->init(0); -ok($rgot == 0, 'a plain *foo causes no get-magic'); -ok($wgot == 0, 'a plain *foo causes no set-magic'); - -# get-magic when exiting a non-lvalue sub in potentially autovivify- -# ing context -{ - no strict; - - my $tied_to = tie $_{elem}, "Tie::Monitor"; - () = sub { delete $_{elem} }->()->[3]; - expected_tie_calls $tied_to, 1, 0, - 'mortal magic var is implicitly returned in autoviv context'; - - $tied_to = tie $_{elem}, "Tie::Monitor"; - () = sub { return delete $_{elem} }->()->[3]; - expected_tie_calls $tied_to, 1, 0, - 'mortal magic var is explicitly returned in autoviv context'; - - $tied_to = tie $_{elem}, "Tie::Monitor"; - my $rsub; - $rsub = sub { if ($_[0]) { delete $_{elem} } else { &$rsub(1)->[3] } }; - &$rsub; - expected_tie_calls $tied_to, 1, 0, - 'mortal magic var is implicitly returned in recursive autoviv context'; - - $tied_to = tie $_{elem}, "Tie::Monitor"; - $rsub = sub { - if ($_[0]) { return delete $_{elem} } else { &$rsub(1)->[3] } - }; - &$rsub; - expected_tie_calls $tied_to, 1, 0, - 'mortal magic var is explicitly returned in recursive autoviv context'; - - $tied_to = tie $_{elem}, "Tie::Monitor"; - my $x = \sub { delete $_{elem} }->(); - expected_tie_calls $tied_to, 1, 0, - 'mortal magic var is implicitly returned to refgen'; - is tied $$x, undef, - 'mortal magic var is copied when implicitly returned'; - - $tied_to = tie $_{elem}, "Tie::Monitor"; - $x = \sub { return delete $_{elem} }->(); - expected_tie_calls $tied_to, 1, 0, - 'mortal magic var is explicitly returned to refgen'; - is tied $$x, undef, - 'mortal magic var is copied when explicitly returned'; -} - -done_testing(); +ok_string($s, '00', 3, 1); # adapted from Tie::Counter by Abigail package Tie::Monitor; diff --git a/gnu/usr.bin/perl/t/op/inccode.t b/gnu/usr.bin/perl/t/op/inccode.t index 1a0b9197cd3..1a3d3cf3e1a 100644 --- a/gnu/usr.bin/perl/t/op/inccode.t +++ b/gnu/usr.bin/perl/t/op/inccode.t @@ -5,34 +5,28 @@ BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); - require './test.pl'; } -use Config; +use File::Spec; -my $can_fork = 0; -my $has_perlio = $Config{useperlio}; +require "test.pl"; +plan(tests => 44); -unless (is_miniperl()) { - if ($Config{d_fork} && eval 'require POSIX; 1') { - $can_fork = 1; - } -} - -use strict; - -plan(tests => 68 + !is_miniperl() * (3 + 14 * $can_fork)); +my @tempfiles = (); sub get_temp_fh { - my $f = tempfile(); + my $f = "DummyModule0000"; + 1 while -e ++$f; + push @tempfiles, $f; open my $fh, ">$f" or die "Can't create $f: $!"; - print $fh "package ".substr($_[0],0,-3).";\n1;\n"; - print $fh $_[1] if @_ > 1; + print $fh "package ".substr($_[0],0,-3)."; 1;"; close $fh or die "Couldn't close: $!"; open $fh, $f or die "Can't open $f: $!"; return $fh; } +END { 1 while unlink @tempfiles } + sub fooinc { my ($self, $filename) = @_; if (substr($filename,0,3) eq 'Foo') { @@ -179,220 +173,10 @@ is( $INC{'Toto.pm'}, 'xyz', ' val Toto.pm is correct in %INC' ); pop @INC; -push @INC, sub { - my ($self, $filename) = @_; - if ($filename eq 'abc.pl') { - return get_temp_fh($filename, qq(return "abc";\n)); - } - else { - return undef; - } -}; - -my $ret = ""; -$ret ||= do 'abc.pl'; -is( $ret, 'abc', 'do "abc.pl" sees return value' ); - -{ - my $got; - #local @INC; # local fails on tied @INC - my @old_INC = @INC; # because local doesn't work on tied arrays - @INC = ('lib', 'lib/Devel', sub { $got = $_[1]; return undef; }); - foreach my $filename ('/test_require.pm', './test_require.pm', - '../test_require.pm') { - local %INC; - undef $got; - undef $test_require::loaded; - eval { require $filename; }; - is($got, $filename, "the coderef sees the pathname $filename"); - is($test_require::loaded, undef, 'no module is loaded' ); - } - - local %INC; - undef $got; - undef $test_require::loaded; - - eval { require 'test_require.pm'; }; - is($got, undef, 'the directory is scanned for test_require.pm'); - is($test_require::loaded, 1, 'the module is loaded'); - @INC = @old_INC; -} - -# this will segfault if it fails - -sub PVBM () { 'foo' } -{ my $dummy = index 'foo', PVBM } - -# I don't know whether these requires should succeed or fail. 5.8 failed -# all of them; 5.10 with an ordinary constant in place of PVBM lets the -# latter two succeed. For now I don't care, as long as they don't -# segfault :). - -unshift @INC, sub { PVBM }; -eval 'require foo'; -ok( 1, 'returning PVBM doesn\'t segfault require' ); -eval 'use foo'; -ok( 1, 'returning PVBM doesn\'t segfault use' ); -shift @INC; -unshift @INC, sub { \PVBM }; -eval 'require foo'; -ok( 1, 'returning PVBM ref doesn\'t segfault require' ); -eval 'use foo'; -ok( 1, 'returning PVBM ref doesn\'t segfault use' ); -shift @INC; - -# [perl #92252] -{ - my $die = sub { die }; - my $data = []; - unshift @INC, sub { $die, $data }; - - my $initial_sub_refcnt = &Internals::SvREFCNT($die); - my $initial_data_refcnt = &Internals::SvREFCNT($data); - - do "foo"; - is(&Internals::SvREFCNT($die), $initial_sub_refcnt, "no leaks"); - is(&Internals::SvREFCNT($data), $initial_data_refcnt, "no leaks"); - - do "bar"; - is(&Internals::SvREFCNT($die), $initial_sub_refcnt, "no leaks"); - is(&Internals::SvREFCNT($data), $initial_data_refcnt, "no leaks"); - - shift @INC; -} - -unshift @INC, sub { \(my $tmp = '$_ = "are temps freed prematurely?"') }; -eval { require foom }; -is $_||$@, "are temps freed prematurely?", - "are temps freed prematurely when returned from inc filters?"; -shift @INC; - -# [perl #120657] -sub fake_module { - my (undef,$module_file) = @_; - !1 -} +my $filename = $^O eq 'MacOS' ? ':Foo:Foo.pm' : './Foo.pm'; { - local @INC = @INC; - unshift @INC, (\&fake_module)x2; - eval { require "${\'bralbalhablah'}" }; - like $@, qr/^Can't locate/, - 'require PADTMP passing freed var when @INC has multiple subs'; -} - -SKIP: { - skip ("Not applicable when run from inccode-tie.t", 6) if tied @INC; - require Tie::Scalar; - package INCtie { - sub TIESCALAR { bless \my $foo } - sub FETCH { study; our $count++; ${$_[0]} } - } - local @INC = undef; - my $t = tie $INC[0], 'INCtie'; - my $called; - $$t = sub { $called ++; !1 }; - delete $INC{'foo.pm'}; # in case another test uses foo - eval { require foo }; - is $INCtie::count, 2, # 2nd time for "Can't locate" -- XXX correct? - 'FETCH is called once on undef scalar-tied @INC elem'; - is $called, 1, 'sub in scalar-tied @INC elem is called'; - () = "$INC[0]"; # force a fetch, so the SV is ROK - $INCtie::count = 0; - eval { require foo }; - is $INCtie::count, 2, - 'FETCH is called once on scalar-tied @INC elem holding ref'; - is $called, 2, 'sub in scalar-tied @INC elem holding ref is called'; - $$t = []; - $INCtie::count = 0; - eval { require foo }; - is $INCtie::count, 1, - 'FETCH called once on scalar-tied @INC elem returning array'; - $$t = "string"; - $INCtie::count = 0; - eval { require foo }; - is $INCtie::count, 2, - 'FETCH called once on scalar-tied @INC elem returning string'; -} - - -exit if is_miniperl(); - -SKIP: { - skip( "No PerlIO available", 3 ) unless $has_perlio; - pop @INC; - - push @INC, sub { - my ($cr, $filename) = @_; - my $module = $filename; $module =~ s,/,::,g; $module =~ s/\.pm$//; - open my $fh, '<', - \"package $module; sub complain { warn q() }; \$::file = __FILE__;" - or die $!; - $INC{$filename} = "/custom/path/to/$filename"; - return $fh; - }; - - require Publius::Vergilius::Maro; - is( $INC{'Publius/Vergilius/Maro.pm'}, - '/custom/path/to/Publius/Vergilius/Maro.pm', '%INC set correctly'); - is( our $file, '/custom/path/to/Publius/Vergilius/Maro.pm', - '__FILE__ set correctly' ); - { - my $warning; - local $SIG{__WARN__} = sub { $warning = shift }; - Publius::Vergilius::Maro::complain(); - like( $warning, qr{something's wrong at /custom/path/to/Publius/Vergilius/Maro.pm}, 'warn() reports correct file source' ); - } -} -pop @INC; - -if ($can_fork) { - require PerlIO::scalar; - # This little bundle of joy generates n more recursive use statements, - # with each module chaining the next one down to 0. If it works, then we - # can safely nest subprocesses - my $use_filter_too; - push @INC, sub { - return unless $_[1] =~ /^BBBLPLAST(\d+)\.pm/; - my $pid = open my $fh, "-|"; - if ($pid) { - # Parent - return $fh unless $use_filter_too; - # Try filters and state in addition. - return ($fh, sub {s/$_[1]/pass/; return}, "die") - } - die "Can't fork self: $!" unless defined $pid; - - # Child - my $count = $1; - # Lets force some fun with odd sized reads. - $| = 1; - print 'push @main::bbblplast, '; - print "$count;\n"; - if ($count--) { - print "use BBBLPLAST$count;\n"; - } - if ($use_filter_too) { - print "die('In $_[1]');"; - } else { - print "pass('In $_[1]');"; - } - print '"Truth"'; - POSIX::_exit(0); - die "Can't get here: $!"; - }; - - @::bbblplast = (); - require BBBLPLAST5; - is ("@::bbblplast", "0 1 2 3 4 5", "All ran"); - - foreach (keys %INC) { - delete $INC{$_} if /^BBBLPLAST/; - } - - @::bbblplast = (); - $use_filter_too = 1; - - require BBBLPLAST5; - - is ("@::bbblplast", "0 1 2 3 4 5", "All ran with a filter"); + local @INC; + @INC = sub { $filename = 'seen'; return undef; }; + eval { require $filename; }; + is( $filename, 'seen', 'the coderef sees fully-qualified pathnames' ); } diff --git a/gnu/usr.bin/perl/t/op/lc.t b/gnu/usr.bin/perl/t/op/lc.t index 38d2b6b6706..1fbb3e1afbf 100644 --- a/gnu/usr.bin/perl/t/op/lc.t +++ b/gnu/usr.bin/perl/t/op/lc.t @@ -1,128 +1,112 @@ #!./perl -# This file is intentionally encoded in latin-1. - -BEGIN { - chdir 't'; - @INC = '../lib'; - require Config; import Config; - require './test.pl'; - require './loc_tools.pl'; # Contains find_utf8_ctype_locale() -} - -use feature qw( fc ); - -plan tests => 134 + 4 * 256; - -is(lc(undef), "", "lc(undef) is ''"); -is(lcfirst(undef), "", "lcfirst(undef) is ''"); -is(uc(undef), "", "uc(undef) is ''"); -is(ucfirst(undef), "", "ucfirst(undef) is ''"); - -{ - no feature 'fc'; - is(CORE::fc(undef), "", "fc(undef) is ''"); - is(CORE::fc(''), "", "fc('') is ''"); - - local $@; - eval { fc("eeyup") }; - like($@, qr/Undefined subroutine &main::fc/, "fc() throws an exception,"); - - { - use feature 'fc'; - local $@; - eval { fc("eeyup") }; - ok(!$@, "...but works after requesting the feature"); +print "1..51\n"; + +my $test = 1; + +sub ok { + if ($_[0]) { + if ($_[1]) { + print "ok $test - $_[1]\n"; + } else { + print "ok $test\n"; + } + } else { + if ($_[1]) { + print "not ok $test - $_[1]\n"; + } else { + print "not ok $test\n"; + } } + $test++; } $a = "HELLO.* world"; $b = "hello.* WORLD"; -is("\Q$a\E." , "HELLO\\.\\*\\ world.", '\Q\E HELLO.* world'); -is("\u$a" , "HELLO\.\* world", '\u'); -is("\l$a" , "hELLO\.\* world", '\l'); -is("\U$a" , "HELLO\.\* WORLD", '\U'); -is("\L$a" , "hello\.\* world", '\L'); -is("\F$a" , "hello\.\* world", '\F'); - -is(quotemeta($a) , "HELLO\\.\\*\\ world", 'quotemeta'); -is(ucfirst($a) , "HELLO\.\* world", 'ucfirst'); -is(lcfirst($a) , "hELLO\.\* world", 'lcfirst'); -is(uc($a) , "HELLO\.\* WORLD", 'uc'); -is(lc($a) , "hello\.\* world", 'lc'); -is(fc($a) , "hello\.\* world", 'fc'); - -is("\Q$b\E." , "hello\\.\\*\\ WORLD.", '\Q\E hello.* WORLD'); -is("\u$b" , "Hello\.\* WORLD", '\u'); -is("\l$b" , "hello\.\* WORLD", '\l'); -is("\U$b" , "HELLO\.\* WORLD", '\U'); -is("\L$b" , "hello\.\* world", '\L'); -is("\F$b" , "hello\.\* world", '\F'); - -is(quotemeta($b) , "hello\\.\\*\\ WORLD", 'quotemeta'); -is(ucfirst($b) , "Hello\.\* WORLD", 'ucfirst'); -is(lcfirst($b) , "hello\.\* WORLD", 'lcfirst'); -is(uc($b) , "HELLO\.\* WORLD", 'uc'); -is(lc($b) , "hello\.\* world", 'lc'); -is(fc($b) , "hello\.\* world", 'fc'); +ok("\Q$a\E." eq "HELLO\\.\\*\\ world.", '\Q\E HELLO.* world'); +ok("\u$a" eq "HELLO\.\* world", '\u'); +ok("\l$a" eq "hELLO\.\* world", '\l'); +ok("\U$a" eq "HELLO\.\* WORLD", '\U'); +ok("\L$a" eq "hello\.\* world", '\L'); + +ok(quotemeta($a) eq "HELLO\\.\\*\\ world", 'quotemeta'); +ok(ucfirst($a) eq "HELLO\.\* world", 'ucfirst'); +ok(lcfirst($a) eq "hELLO\.\* world", 'lcfirst'); +ok(uc($a) eq "HELLO\.\* WORLD", 'uc'); +ok(lc($a) eq "hello\.\* world", 'lc'); + +ok("\Q$b\E." eq "hello\\.\\*\\ WORLD.", '\Q\E hello.* WORLD'); +ok("\u$b" eq "Hello\.\* WORLD", '\u'); +ok("\l$b" eq "hello\.\* WORLD", '\l'); +ok("\U$b" eq "HELLO\.\* WORLD", '\U'); +ok("\L$b" eq "hello\.\* world", '\L'); + +ok(quotemeta($b) eq "hello\\.\\*\\ WORLD", 'quotemeta'); +ok(ucfirst($b) eq "Hello\.\* WORLD", 'ucfirst'); +ok(lcfirst($b) eq "hello\.\* WORLD", 'lcfirst'); +ok(uc($b) eq "HELLO\.\* WORLD", 'uc'); +ok(lc($b) eq "hello\.\* world", 'lc'); # \x{100} is LATIN CAPITAL LETTER A WITH MACRON; its bijective lowercase is # \x{101}, LATIN SMALL LETTER A WITH MACRON. -# Which is also its foldcase. $a = "\x{100}\x{101}Aa"; $b = "\x{101}\x{100}aA"; -is("\Q$a\E." , "\x{100}\x{101}Aa.", '\Q\E \x{100}\x{101}Aa'); -is("\u$a" , "\x{100}\x{101}Aa", '\u'); -is("\l$a" , "\x{101}\x{101}Aa", '\l'); -is("\U$a" , "\x{100}\x{100}AA", '\U'); -is("\L$a" , "\x{101}\x{101}aa", '\L'); -is("\F$a" , "\x{101}\x{101}aa", '\F'); - -is(quotemeta($a) , "\x{100}\x{101}Aa", 'quotemeta'); -is(ucfirst($a) , "\x{100}\x{101}Aa", 'ucfirst'); -is(lcfirst($a) , "\x{101}\x{101}Aa", 'lcfirst'); -is(uc($a) , "\x{100}\x{100}AA", 'uc'); -is(lc($a) , "\x{101}\x{101}aa", 'lc'); -is(fc($a) , "\x{101}\x{101}aa", 'fc'); - -is("\Q$b\E." , "\x{101}\x{100}aA.", '\Q\E \x{101}\x{100}aA'); -is("\u$b" , "\x{100}\x{100}aA", '\u'); -is("\l$b" , "\x{101}\x{100}aA", '\l'); -is("\U$b" , "\x{100}\x{100}AA", '\U'); -is("\L$b" , "\x{101}\x{101}aa", '\L'); -is("\F$b" , "\x{101}\x{101}aa", '\F'); - -is(quotemeta($b) , "\x{101}\x{100}aA", 'quotemeta'); -is(ucfirst($b) , "\x{100}\x{100}aA", 'ucfirst'); -is(lcfirst($b) , "\x{101}\x{100}aA", 'lcfirst'); -is(uc($b) , "\x{100}\x{100}AA", 'uc'); -is(lc($b) , "\x{101}\x{101}aa", 'lc'); -is(fc($b) , "\x{101}\x{101}aa", 'fc'); +ok("\Q$a\E." eq "\x{100}\x{101}Aa.", '\Q\E \x{100}\x{101}Aa'); +ok("\u$a" eq "\x{100}\x{101}Aa", '\u'); +ok("\l$a" eq "\x{101}\x{101}Aa", '\l'); +ok("\U$a" eq "\x{100}\x{100}AA", '\U'); +ok("\L$a" eq "\x{101}\x{101}aa", '\L'); + +ok(quotemeta($a) eq "\x{100}\x{101}Aa", 'quotemeta'); +ok(ucfirst($a) eq "\x{100}\x{101}Aa", 'ucfirst'); +ok(lcfirst($a) eq "\x{101}\x{101}Aa", 'lcfirst'); +ok(uc($a) eq "\x{100}\x{100}AA", 'uc'); +ok(lc($a) eq "\x{101}\x{101}aa", 'lc'); + +ok("\Q$b\E." eq "\x{101}\x{100}aA.", '\Q\E \x{101}\x{100}aA'); +ok("\u$b" eq "\x{100}\x{100}aA", '\u'); +ok("\l$b" eq "\x{101}\x{100}aA", '\l'); +ok("\U$b" eq "\x{100}\x{100}AA", '\U'); +ok("\L$b" eq "\x{101}\x{101}aa", '\L'); + +ok(quotemeta($b) eq "\x{101}\x{100}aA", 'quotemeta'); +ok(ucfirst($b) eq "\x{100}\x{100}aA", 'ucfirst'); +ok(lcfirst($b) eq "\x{101}\x{100}aA", 'lcfirst'); +ok(uc($b) eq "\x{100}\x{100}AA", 'uc'); +ok(lc($b) eq "\x{101}\x{101}aa", 'lc'); # \x{DF} is LATIN SMALL LETTER SHARP S, its uppercase is SS or \x{53}\x{53}; # \x{149} is LATIN SMALL LETTER N PRECEDED BY APOSTROPHE, its uppercase is # \x{2BC}\x{E4} or MODIFIER LETTER APOSTROPHE and N. -is(latin1_to_native("\U\x{DF}aB\x{149}cD"), latin1_to_native("SSAB\x{2BC}NCD"), +# In EBCDIC \x{DF} is LATIN SMALL LETTER Y WITH DIAERESIS, +# and it's uppercase is \x{178}, LATIN CAPITAL LETTER Y WITH DIAERESIS. + +if (ord("A") == 193) { # EBCDIC + ok("\U\x{DF}aB\x{149}cD" eq "\x{178}AB\x{2BC}NCD", "multicharacter uppercase"); +} elsif (ord("A") == 65) { + ok("\U\x{DF}aB\x{149}cD" eq "SSAB\x{2BC}NCD", + "multicharacter uppercase"); +} else { + ok(0, "what is your encoding?"); +} # The \x{DF} is its own lowercase, ditto for \x{149}. # There are no single character -> multiple characters lowercase mappings. -is(latin1_to_native("\L\x{DF}aB\x{149}cD"), latin1_to_native("\x{DF}ab\x{149}cd"), +if (ord("A") == 193) { # EBCDIC + ok("\LaB\x{149}cD" eq "ab\x{149}cd", "multicharacter lowercase"); - -# \x{DF} is LATIN SMALL LETTER SHARP S, its foldcase is ss or \x{73}\x{73}; -# \x{149} is LATIN SMALL LETTER N PRECEDED BY APOSTROPHE, its foldcase is -# \x{2BC}\x{6E} or MODIFIER LETTER APOSTROPHE and n. -# Note that is this further tested in t/uni/fold.t - -is(latin1_to_native("\F\x{DF}aB\x{149}cD"), latin1_to_native("ssab\x{2BC}ncd"), - "multicharacter foldcase"); - +} elsif (ord("A") == 65) { + ok("\L\x{DF}aB\x{149}cD" eq "\x{DF}ab\x{149}cd", + "multicharacter lowercase"); +} else { + ok(0, "what is your encoding?"); +} # titlecase is used for \u / ucfirst. @@ -132,221 +116,23 @@ is(latin1_to_native("\F\x{DF}aB\x{149}cD"), latin1_to_native("ssab\x{2BC}ncd"), # \x{587} itself # and its uppercase is # \x{535}\x{552} ARMENIAN CAPITAL LETTER ECH + ARMENIAN CAPITAL LETTER YIWN -# The foldcase is \x{565}\x{582} ARMENIAN SMALL LETTER ECH + ARMENIAN SMALL LETTER YIWN $a = "\x{587}"; -is("\L\x{587}" , "\x{587}", "ligature lowercase"); -is("\u\x{587}" , "\x{535}\x{582}", "ligature titlecase"); -is("\U\x{587}" , "\x{535}\x{552}", "ligature uppercase"); -is("\F\x{587}" , "\x{565}\x{582}", "ligature foldcase"); +ok("\L\x{587}" eq "\x{587}", "ligature lowercase"); +ok("\u\x{587}" eq "\x{535}\x{582}", "ligature titlecase"); +ok("\U\x{587}" eq "\x{535}\x{552}", "ligature uppercase"); # mktables had problems where many-to-one case mappings didn't work right. -# The lib/uni/fold.t should give the fourth folding, "casefolding", a good +# The lib/unifold.t should give the fourth folding, "casefolding", a good # workout. -# \x{01C4} is LATIN CAPITAL LETTER DZ WITH CARON -# \x{01C5} is LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON -# \x{01C6} is LATIN SMALL LETTER DZ WITH CARON -# \x{03A3} is GREEK CAPITAL LETTER SIGMA -# \x{03C2} is GREEK SMALL LETTER FINAL SIGMA -# \x{03C3} is GREEK SMALL LETTER SIGMA - -is(lc("\x{1C4}") , "\x{1C6}", "U+01C4 lc is U+01C6"); -is(lc("\x{1C5}") , "\x{1C6}", "U+01C5 lc is U+01C6, too"); - -is(ucfirst("\x{3C2}") , "\x{3A3}", "U+03C2 ucfirst is U+03A3"); -is(ucfirst("\x{3C3}") , "\x{3A3}", "U+03C3 ucfirst is U+03A3, too"); - -is(uc("\x{1C5}") , "\x{1C4}", "U+01C5 uc is U+01C4"); -is(uc("\x{1C6}") , "\x{1C4}", "U+01C6 uc is U+01C4, too"); - -# #18107: A host of bugs involving [ul]c{,first}. AMS 20021106 -$a = "\x{3c3}foo.bar"; # \x{3c3} == GREEK SMALL LETTER SIGMA. -$b = "\x{3a3}FOO.BAR"; # \x{3a3} == GREEK CAPITAL LETTER SIGMA. - -($c = $b) =~ s/(\w+)/lc($1)/ge; -is($c , $a, "Using s///e to change case."); - -($c = $a) =~ s/(\p{IsWord}+)/uc($1)/ge; -is($c , $b, "Using s///e to change case."); - -($c = $a) =~ s/(\p{IsWord}+)/fc($1)/ge; -is($c , $a, "Using s///e to foldcase."); - -($c = $b) =~ s/(\p{IsWord}+)/lcfirst($1)/ge; -is($c , "\x{3c3}FOO.bAR", "Using s///e to change case."); - -($c = $a) =~ s/(\p{IsWord}+)/ucfirst($1)/ge; -is($c , "\x{3a3}foo.Bar", "Using s///e to change case."); - -# #18931: perl5.8.0 bug in \U..\E processing -# Test case from Nicholas Clark. -for my $a (0,1) { - $_ = 'abcdefgh'; - $_ .= chr 256; - chop; - /(.*)/; - is(uc($1), "ABCDEFGH", "[perl #18931]"); -} - -{ - foreach (0, 1) { - $a = v10.v257; - chop $a; - $a =~ s/^(\s*)(\w*)/$1\u$2/; - is($a, v10, "[perl #18857]"); - } -} - - -# [perl #38619] Bug in lc and uc (interaction between UTF-8, substr, and lc/uc) -for ("a\x{100}", "xyz\x{100}") { - is(substr(uc($_), 0), uc($_), "[perl #38619] uc"); -} -for ("A\x{100}", "XYZ\x{100}") { - is(substr(lc($_), 0), lc($_), "[perl #38619] lc"); -} -for ("a\x{100}", "ßyz\x{100}") { # ß to Ss (different length) - is(substr(ucfirst($_), 0), ucfirst($_), "[perl #38619] ucfirst"); -} - -#fc() didn't exist back then, but coverage is coverage. -for ("a\x{100}", "ßyz\x{100}", "xyz\x{100}", "XYZ\x{100}") { # ß to Ss (different length) - is(substr(fc($_), 0), fc($_), "[perl #38619] fc"); -} +ok(lc("\x{1C4}") eq "\x{1C6}", "U+01C4 lc is U+01C6"); +ok(lc("\x{1C5}") eq "\x{1C6}", "U+01C5 lc is U+01C6, too"); -# Related to [perl #38619] -# the original report concerns PERL_MAGIC_utf8. -# these cases concern PERL_MAGIC_regex_global. +ok(ucfirst("\x{3C2}") eq "\x{3A3}", "U+03C2 ucfirst is U+03A3"); +ok(ucfirst("\x{3C3}") eq "\x{3A3}", "U+03C3 ucfirst is U+03A3, too"); -for (map { $_ } "a\x{100}", "abc\x{100}", "\x{100}") { - chop; # get ("a", "abc", "") in utf8 - my $return = uc($_) =~ /\G(.?)/g; - my $result = $return ? $1 : "not"; - my $expect = (uc($_) =~ /(.?)/g)[0]; - is($return, 1, "[perl #38619]"); - is($result, $expect, "[perl #38619]"); -} - -for (map { $_ } "A\x{100}", "ABC\x{100}", "\x{100}") { - chop; # get ("A", "ABC", "") in utf8 - my $return = lc($_) =~ /\G(.?)/g; - my $result = $return ? $1 : "not"; - my $expect = (lc($_) =~ /(.?)/g)[0]; - is($return, 1, "[perl #38619]"); - is($result, $expect, "[perl #38619]"); -} - -for (map { $_ } "A\x{100}", "ABC\x{100}", "\x{100}") { - chop; # get ("A", "ABC", "") in utf8 - my $return = fc($_) =~ /\G(.?)/g; - my $result = $return ? $1 : "not"; - my $expect = (fc($_) =~ /(.?)/g)[0]; - is($return, 1, "[perl #38619]"); - is($result, $expect, "[perl #38619]"); -} +ok(uc("\x{1C5}") eq "\x{1C4}", "U+01C5 uc is U+01C4"); +ok(uc("\x{1C6}") eq "\x{1C4}", "U+01C6 uc is U+01C4, too"); -for (1, 4, 9, 16, 25) { - is(uc "\x{03B0}" x $_, "\x{3a5}\x{308}\x{301}" x $_, - 'uc U+03B0 grows threefold'); - - is(lc "\x{0130}" x $_, "i\x{307}" x $_, 'lc U+0130 grows'); - - is(fc "\x{03B0}" x $_, "\x{3C5}\x{308}\x{301}" x $_, - 'fc U+03B0 grows threefold'); -} - -# bug #43207 -my $temp = "HellO"; -for ("$temp") { - lc $_; - is($_, "HellO", '[perl #43207] lc($_) modifying $_'); -} -for ("$temp") { - fc $_; - is($_, "HellO", '[perl #43207] fc($_) modifying $_'); -} -for ("$temp") { - uc $_; - is($_, "HellO", '[perl #43207] uc($_) modifying $_'); -} -for ("$temp") { - ucfirst $_; - is($_, "HellO", '[perl #43207] ucfirst($_) modifying $_'); -} -for ("$temp") { - lcfirst $_; - is($_, "HellO", '[perl #43207] lcfirst($_) modifying $_'); -} - -# new in Unicode 5.1.0 -is(lc("\x{1E9E}"), "\x{df}", "lc(LATIN CAPITAL LETTER SHARP S)"); - -{ - use feature 'unicode_strings'; - use bytes; - is(lc("\xc0"), "\xc0", "lc of above-ASCII Latin1 is itself under use bytes"); - is(lcfirst("\xc0"), "\xc0", "lcfirst of above-ASCII Latin1 is itself under use bytes"); - is(uc("\xe0"), "\xe0", "uc of above-ASCII Latin1 is itself under use bytes"); - is(ucfirst("\xe0"), "\xe0", "ucfirst of above-ASCII Latin1 is itself under use bytes"); -} - -# Brought up in ticket #117855: Constant folding applied to uc() should use -# the right set of hints. -fresh_perl_like(<<'constantfolding', qr/^(\d+),\1\z/, {}, - my $function = "uc"; - my $char = "\xff"; - { - use feature 'unicode_strings'; - print ord uc($char), ",", - ord eval "$function('$char')", "\n"; - } -constantfolding - 'folded uc() in string eval uses the right hints'); - -# In-place lc/uc should not corrupt string buffers when given a non-utf8- -# flagged thingy that stringifies to utf8 -$h{k} = bless[], "\x{3b0}\x{3b0}\x{3b0}bcde"; # U+03B0 grows with uc() - # using delete marks it as TEMP, so uc-in-place is permitted -like uc delete $h{k}, qr "^(?:\x{3a5}\x{308}\x{301}){3}BCDE=ARRAY\(.*\)", - 'uc(TEMP ref) does not produce a corrupt string'; -$h{k} = bless[], "\x{130}bcde"; # U+0130 grows with lc() - # using delete marks it as TEMP, so uc-in-place is permitted -like lc delete $h{k}, qr "^i\x{307}bcde=array\(.*\)", - 'lc(TEMP ref) does not produce a corrupt string'; - - -my $utf8_locale = find_utf8_ctype_locale(); - -SKIP: { - skip 'Can\'t find a UTF-8 locale', 4*256 unless defined $utf8_locale; - - use feature qw( unicode_strings ); - - no locale; - - my @unicode_lc; - my @unicode_uc; - my @unicode_lcfirst; - my @unicode_ucfirst; - - # Get all the values outside of 'locale' - for my $i (0 .. 255) { - push @unicode_lc, lc(chr $i); - push @unicode_uc, uc(chr $i); - push @unicode_lcfirst, lcfirst(chr $i); - push @unicode_ucfirst, ucfirst(chr $i); - } - - use if $Config{d_setlocale}, qw(POSIX locale_h); - use locale; - setlocale(LC_CTYPE, $utf8_locale); - - for my $i (0 .. 255) { - is(lc(chr $i), $unicode_lc[$i], "In a UTF-8 locale, lc(chr $i) is the same as official Unicode"); - is(uc(chr $i), $unicode_uc[$i], "In a UTF-8 locale, uc(chr $i) is the same as official Unicode"); - is(lcfirst(chr $i), $unicode_lcfirst[$i], "In a UTF-8 locale, lcfirst(chr $i) is the same as official Unicode"); - is(ucfirst(chr $i), $unicode_ucfirst[$i], "In a UTF-8 locale, ucfirst(chr $i) is the same as official Unicode"); - } -} diff --git a/gnu/usr.bin/perl/t/op/loopctl.t b/gnu/usr.bin/perl/t/op/loopctl.t index d520a7fa313..2ed9df1432b 100644 --- a/gnu/usr.bin/perl/t/op/loopctl.t +++ b/gnu/usr.bin/perl/t/op/loopctl.t @@ -30,17 +30,14 @@ # Feel free to add more here. # # -- .robin. 2001-03-13 -BEGIN { - chdir 't' if -d 't'; - @INC = qw(. ../lib); - require "test.pl"; -} -plan( tests => 67 ); +print "1..41\n"; my $ok; -TEST1: { +## while() loop without a label + +TEST1: { # redo $ok = 0; @@ -62,9 +59,9 @@ TEST1: { } $ok = 0; } -cmp_ok($ok,'==',1,'no label on while()'); +print ($ok ? "ok 1\n" : "not ok 1\n"); -TEST2: { +TEST2: { # next (succesful) $ok = 0; @@ -86,9 +83,9 @@ TEST2: { } $ok = 0; } -cmp_ok($ok,'==',1,'no label on while() successful next'); +print ($ok ? "ok 2\n" : "not ok 2\n"); -TEST3: { +TEST3: { # next (unsuccesful) $ok = 0; @@ -112,9 +109,9 @@ TEST3: { } $ok = $been_in_loop && $been_in_continue; } -cmp_ok($ok,'==',1,'no label on while() unsuccessful next'); +print ($ok ? "ok 3\n" : "not ok 3\n"); -TEST4: { +TEST4: { # last $ok = 0; @@ -136,9 +133,12 @@ TEST4: { } $ok = 1; } -cmp_ok($ok,'==',1,'no label on while() last'); +print ($ok ? "ok 4\n" : "not ok 4\n"); + -TEST5: { +## until() loop without a label + +TEST5: { # redo $ok = 0; @@ -160,9 +160,9 @@ TEST5: { } $ok = 0; } -cmp_ok($ok,'==',1,'no label on until()'); +print ($ok ? "ok 5\n" : "not ok 5\n"); -TEST6: { +TEST6: { # next (succesful) $ok = 0; @@ -184,9 +184,9 @@ TEST6: { } $ok = 0; } -cmp_ok($ok,'==',1,'no label on until() successful next'); +print ($ok ? "ok 6\n" : "not ok 6\n"); -TEST7: { +TEST7: { # next (unsuccesful) $ok = 0; @@ -210,9 +210,9 @@ TEST7: { } $ok = $been_in_loop && $been_in_continue; } -cmp_ok($ok,'==',1,'no label on until() unsuccessful next'); +print ($ok ? "ok 7\n" : "not ok 7\n"); -TEST8: { +TEST8: { # last $ok = 0; @@ -234,9 +234,11 @@ TEST8: { } $ok = 1; } -cmp_ok($ok,'==',1,'no label on until() last'); +print ($ok ? "ok 8\n" : "not ok 8\n"); + +## for(@array) loop without a label -TEST9: { +TEST9: { # redo $ok = 0; @@ -257,9 +259,9 @@ TEST9: { } $ok = 0; } -cmp_ok($ok,'==',1,'no label on for(@array)'); +print ($ok ? "ok 9\n" : "not ok 9\n"); -TEST10: { +TEST10: { # next (succesful) $ok = 0; @@ -280,9 +282,9 @@ TEST10: { } $ok = 0; } -cmp_ok($ok,'==',1,'no label on for(@array) successful next'); +print ($ok ? "ok 10\n" : "not ok 10\n"); -TEST11: { +TEST11: { # next (unsuccesful) $ok = 0; @@ -305,9 +307,9 @@ TEST11: { } $ok = $been_in_loop && $been_in_continue; } -cmp_ok($ok,'==',1,'no label on for(@array) unsuccessful next'); +print ($ok ? "ok 11\n" : "not ok 11\n"); -TEST12: { +TEST12: { # last $ok = 0; @@ -328,9 +330,11 @@ TEST12: { } $ok = 1; } -cmp_ok($ok,'==',1,'no label on for(@array) last'); +print ($ok ? "ok 12\n" : "not ok 12\n"); -TEST13: { +## for(;;) loop without a label + +TEST13: { # redo $ok = 0; @@ -347,9 +351,9 @@ TEST13: { } $ok = 0; } -cmp_ok($ok,'==',1,'no label on for(;;)'); +print ($ok ? "ok 13\n" : "not ok 13\n"); -TEST14: { +TEST14: { # next (successful) $ok = 0; @@ -364,9 +368,9 @@ TEST14: { } $ok = 0; } -cmp_ok($ok,'==',1,'no label on for(;;) successful next'); +print ($ok ? "ok 14\n" : "not ok 14\n"); -TEST15: { +TEST15: { # next (unsuccesful) $ok = 0; @@ -385,9 +389,9 @@ TEST15: { } $ok = $been_in_loop; } -cmp_ok($ok,'==',1,'no label on for(;;) unsuccessful next'); +print ($ok ? "ok 15\n" : "not ok 15\n"); -TEST16: { +TEST16: { # last $ok = 0; @@ -403,9 +407,11 @@ TEST16: { } $ok = 1; } -cmp_ok($ok,'==',1,'no label on for(;;) last'); +print ($ok ? "ok 16\n" : "not ok 16\n"); + +## bare block without a label -TEST17: { +TEST17: { # redo $ok = 0; my $first_time = 1; @@ -427,9 +433,9 @@ TEST17: { } $ok = 0; } -cmp_ok($ok,'==',1,'no label on bare block'); +print ($ok ? "ok 17\n" : "not ok 17\n"); -TEST18: { +TEST18: { # next $ok = 0; { @@ -442,9 +448,9 @@ TEST18: { } $ok = 0; } -cmp_ok($ok,'==',1,'no label on bare block next'); +print ($ok ? "ok 18\n" : "not ok 18\n"); -TEST19: { +TEST19: { # last $ok = 0; { @@ -457,11 +463,14 @@ TEST19: { } $ok = 1; } -cmp_ok($ok,'==',1,'no label on bare block last'); +print ($ok ? "ok 19\n" : "not ok 19\n"); + ### Now do it all again with labels -TEST20: { +## while() loop with a label + +TEST20: { # redo $ok = 0; @@ -483,9 +492,9 @@ TEST20: { } $ok = 0; } -cmp_ok($ok,'==',1,'label on while()'); +print ($ok ? "ok 20\n" : "not ok 20\n"); -TEST21: { +TEST21: { # next (succesful) $ok = 0; @@ -507,9 +516,9 @@ TEST21: { } $ok = 0; } -cmp_ok($ok,'==',1,'label on while() successful next'); +print ($ok ? "ok 21\n" : "not ok 21\n"); -TEST22: { +TEST22: { # next (unsuccesful) $ok = 0; @@ -533,9 +542,9 @@ TEST22: { } $ok = $been_in_loop && $been_in_continue; } -cmp_ok($ok,'==',1,'label on while() unsuccessful next'); +print ($ok ? "ok 22\n" : "not ok 22\n"); -TEST23: { +TEST23: { # last $ok = 0; @@ -557,9 +566,12 @@ TEST23: { } $ok = 1; } -cmp_ok($ok,'==',1,'label on while() last'); +print ($ok ? "ok 23\n" : "not ok 23\n"); -TEST24: { + +## until() loop with a label + +TEST24: { # redo $ok = 0; @@ -581,9 +593,9 @@ TEST24: { } $ok = 0; } -cmp_ok($ok,'==',1,'label on until()'); +print ($ok ? "ok 24\n" : "not ok 24\n"); -TEST25: { +TEST25: { # next (succesful) $ok = 0; @@ -605,9 +617,9 @@ TEST25: { } $ok = 0; } -cmp_ok($ok,'==',1,'label on until() successful next'); +print ($ok ? "ok 25\n" : "not ok 25\n"); -TEST26: { +TEST26: { # next (unsuccesful) $ok = 0; @@ -631,9 +643,9 @@ TEST26: { } $ok = $been_in_loop && $been_in_continue; } -cmp_ok($ok,'==',1,'label on until() unsuccessful next'); +print ($ok ? "ok 26\n" : "not ok 26\n"); -TEST27: { +TEST27: { # last $ok = 0; @@ -655,9 +667,11 @@ TEST27: { } $ok = 1; } -cmp_ok($ok,'==',1,'label on until() last'); +print ($ok ? "ok 27\n" : "not ok 27\n"); -TEST28: { +## for(@array) loop with a label + +TEST28: { # redo $ok = 0; @@ -678,9 +692,9 @@ TEST28: { } $ok = 0; } -cmp_ok($ok,'==',1,'label on for(@array)'); +print ($ok ? "ok 28\n" : "not ok 28\n"); -TEST29: { +TEST29: { # next (succesful) $ok = 0; @@ -701,9 +715,9 @@ TEST29: { } $ok = 0; } -cmp_ok($ok,'==',1,'label on for(@array) successful next'); +print ($ok ? "ok 29\n" : "not ok 29\n"); -TEST30: { +TEST30: { # next (unsuccesful) $ok = 0; @@ -726,9 +740,9 @@ TEST30: { } $ok = $been_in_loop && $been_in_continue; } -cmp_ok($ok,'==',1,'label on for(@array) unsuccessful next'); +print ($ok ? "ok 30\n" : "not ok 30\n"); -TEST31: { +TEST31: { # last $ok = 0; @@ -749,9 +763,11 @@ TEST31: { } $ok = 1; } -cmp_ok($ok,'==',1,'label on for(@array) last'); +print ($ok ? "ok 31\n" : "not ok 31\n"); + +## for(;;) loop with a label -TEST32: { +TEST32: { # redo $ok = 0; @@ -768,9 +784,9 @@ TEST32: { } $ok = 0; } -cmp_ok($ok,'==',1,'label on for(;;)'); +print ($ok ? "ok 32\n" : "not ok 32\n"); -TEST33: { +TEST33: { # next (successful) $ok = 0; @@ -785,9 +801,9 @@ TEST33: { } $ok = 0; } -cmp_ok($ok,'==',1,'label on for(;;) successful next'); +print ($ok ? "ok 33\n" : "not ok 33\n"); -TEST34: { +TEST34: { # next (unsuccesful) $ok = 0; @@ -806,9 +822,9 @@ TEST34: { } $ok = $been_in_loop; } -cmp_ok($ok,'==',1,'label on for(;;) unsuccessful next'); +print ($ok ? "ok 34\n" : "not ok 34\n"); -TEST35: { +TEST35: { # last $ok = 0; @@ -824,9 +840,11 @@ TEST35: { } $ok = 1; } -cmp_ok($ok,'==',1,'label on for(;;) last'); +print ($ok ? "ok 35\n" : "not ok 35\n"); -TEST36: { +## bare block with a label + +TEST36: { # redo $ok = 0; my $first_time = 1; @@ -848,9 +866,9 @@ TEST36: { } $ok = 0; } -cmp_ok($ok,'==',1,'label on bare block'); +print ($ok ? "ok 36\n" : "not ok 36\n"); -TEST37: { +TEST37: { # next $ok = 0; LABEL37: { @@ -863,9 +881,9 @@ TEST37: { } $ok = 0; } -cmp_ok($ok,'==',1,'label on bare block next'); +print ($ok ? "ok 37\n" : "not ok 37\n"); -TEST38: { +TEST38: { # last $ok = 0; LABEL38: { @@ -878,7 +896,9 @@ TEST38: { } $ok = 1; } -cmp_ok($ok,'==',1,'label on bare block last'); +print ($ok ? "ok 38\n" : "not ok 38\n"); + +### Now test nested constructs TEST39: { $ok = 0; @@ -902,7 +922,10 @@ TEST39: { $ok = 0; } } -cmp_ok($ok,'==',1,'nested constructs'); +print ($ok ? "ok 39\n" : "not ok 39\n"); + + +### Test that loop control is dynamicly scoped. sub test_last_label { last TEST40 } @@ -911,7 +934,7 @@ TEST40: { test_last_label(); $ok = 0; } -cmp_ok($ok,'==',1,'dynamically scoped label'); +print ($ok ? "ok 40\n" : "not ok 40\n"); sub test_last { last } @@ -920,201 +943,4 @@ TEST41: { test_last(); $ok = 0; } -cmp_ok($ok,'==',1,'dynamically scoped'); - - -# [perl #27206] Memory leak in continue loop -# Ensure that the temporary object is freed each time round the loop, -# rather then all 10 of them all being freed right at the end - -{ - my $n=10; my $late_free = 0; - sub X::DESTROY { $late_free++ if $n < 0 }; - { - ($n-- && bless {}, 'X') && redo; - } - cmp_ok($late_free,'==',0,"bug 27206: redo memory leak"); - - $n = 10; $late_free = 0; - { - ($n-- && bless {}, 'X') && redo; - } - continue { } - cmp_ok($late_free,'==',0,"bug 27206: redo with continue memory leak"); -} - -# ensure that redo doesn't clear a lexical declared in the condition - -{ - my $i = 1; - while (my $x = $i) { - $i++; - redo if $i == 2; - cmp_ok($x,'==',1,"while/redo lexical life"); - last; - } - $i = 1; - until (! (my $x = $i)) { - $i++; - redo if $i == 2; - cmp_ok($x,'==',1,"until/redo lexical life"); - last; - } - for ($i = 1; my $x = $i; ) { - $i++; - redo if $i == 2; - cmp_ok($x,'==',1,"for/redo lexical life"); - last; - } - -} - -{ - $a37725[3] = 1; # use package var - $i = 2; - for my $x (reverse @a37725) { - $x = $i++; - } - cmp_ok("@a37725",'eq',"5 4 3 2",'bug 27725: reverse with empty slots bug'); -} - -# [perl #21469] bad things happened with for $x (...) { *x = *y } - -{ - my $i = 1; - $x_21469 = 'X'; - $y1_21469 = 'Y1'; - $y2_21469 = 'Y2'; - $y3_21469 = 'Y3'; - for $x_21469 (1,2,3) { - is($x_21469, $i, "bug 21469: correct at start of loop $i"); - *x_21469 = (*y1_21469, *y2_21469, *y3_21469)[$i-1]; - is($x_21469, "Y$i", "bug 21469: correct at tail of loop $i"); - $i++; - } - is($x_21469, 'X', "bug 21469: X okay at end of loop"); -} - -# [perl #112316] Wrong behavior regarding labels with same prefix -{ - my $fail; - CATCH: { - CATCHLOOP: { - last CATCH; - } - $fail = 1; - } - ok(!$fail, "perl 112316: Labels with the same prefix don't get mixed up."); -} - -# [perl #73618] -{ - sub foo_73618_0 { - while (0) { } - } - sub bar_73618_0 { - my $i = 0; - while ($i) { } - } - sub foo_73618_undef { - while (undef) { } - } - sub bar_73618_undef { - my $i = undef; - while ($i) { } - } - sub foo_73618_emptystring { - while ("") { } - } - sub bar_73618_emptystring { - my $i = ""; - while ($i) { } - } - sub foo_73618_0float { - while (0.0) { } - } - sub bar_73618_0float { - my $i = 0.0; - while ($i) { } - } - sub foo_73618_0string { - while ("0") { } - } - sub bar_73618_0string { - my $i = "0"; - while ($i) { } - } - sub foo_73618_until { - until (1) { } - } - sub bar_73618_until { - my $i = 1; - until ($i) { } - } - - is(scalar(foo_73618_0()), scalar(bar_73618_0()), - "constant optimization doesn't change return value"); - is(scalar(foo_73618_undef()), scalar(bar_73618_undef()), - "constant optimization doesn't change return value"); - is(scalar(foo_73618_emptystring()), scalar(bar_73618_emptystring()), - "constant optimization doesn't change return value"); - is(scalar(foo_73618_0float()), scalar(bar_73618_0float()), - "constant optimization doesn't change return value"); - is(scalar(foo_73618_0string()), scalar(bar_73618_0string()), - "constant optimization doesn't change return value"); - { local $TODO = "until is still wrongly optimized"; - is(scalar(foo_73618_until()), scalar(bar_73618_until()), - "constant optimization doesn't change return value"); - } -} - -# [perl #113684] -last_113684: -{ - label1: - { - my $label = "label1"; - eval { last $label }; - fail("last with non-constant label"); - last last_113684; - } - pass("last with non-constant label"); -} -next_113684: -{ - label2: - { - my $label = "label2"; - eval { next $label }; - fail("next with non-constant label"); - next next_113684; - } - pass("next with non-constant label"); -} -redo_113684: -{ - my $count; - label3: - { - if ($count++) { - pass("redo with non-constant label"); last redo_113684 - } - my $label = "label3"; - eval { redo $label }; - fail("redo with non-constant label"); - } -} - -# [perl #3112] -# The original report, which produced a Bizarre copy -@a = (); -eval { - for (1) { - push @a, last; - } -}; -is @a, 0, 'push @a, last; does not push'; -is $@, "", 'no error, either'; -# And my japh, which relied on the misbehaviour -is do{{&{sub{"Just another Perl hacker,\n"}},last}}, undef, - 'last returns nothing'; +print ($ok ? "ok 41\n" : "not ok 41\n"); diff --git a/gnu/usr.bin/perl/t/op/override.t b/gnu/usr.bin/perl/t/op/override.t index ce740eaf6cd..1a4e5e02f86 100644 --- a/gnu/usr.bin/perl/t/op/override.t +++ b/gnu/usr.bin/perl/t/op/override.t @@ -2,13 +2,11 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; - require './test.pl'; - require Config; # load these before we mess with *CORE::GLOBAL::require - require 'Config_heavy.pl'; # since runperl will need them + @INC = '.'; + push @INC, '../lib'; } -plan tests => 35; +print "1..17\n"; # # This file tries to test builtin override using CORE::GLOBAL @@ -17,12 +15,14 @@ my $dirsep = "/"; BEGIN { package Foo; *main::getlogin = sub { "kilroy"; } } -is( getlogin, "kilroy" ); +print "not " unless getlogin eq "kilroy"; +print "ok 1\n"; my $t = 42; BEGIN { *CORE::GLOBAL::time = sub () { $t; } } -is( 45, time + 3 ); +print "not " unless 45 == time + 3; +print "ok 2\n"; # # require has special behaviour @@ -31,56 +31,44 @@ my $r; BEGIN { *CORE::GLOBAL::require = sub { $r = shift; 1; } } require Foo; -is( $r, "Foo.pm" ); +print "not " unless $r eq "Foo.pm"; +print "ok 3\n"; require Foo::Bar; -is( $r, join($dirsep, "Foo", "Bar.pm") ); +print "not " unless $r eq join($dirsep, "Foo", "Bar.pm"); +print "ok 4\n"; require 'Foo'; -is( $r, "Foo" ); +print "not " unless $r eq "Foo"; +print "ok 5\n"; -require 5.006; -is( $r, "5.006" ); +require 5.6; +print "not " unless $r eq "5.6"; +print "ok 6\n"; require v5.6; -ok( abs($r - 5.006) < 0.001 && $r eq "\x05\x06" ); +print "not " unless abs($r - 5.006) < 0.001 && $r eq "\x05\x06"; +print "ok 7\n"; eval "use Foo"; -is( $r, "Foo.pm" ); +print "not " unless $r eq "Foo.pm"; +print "ok 8\n"; eval "use Foo::Bar"; -is( $r, join($dirsep, "Foo", "Bar.pm") ); +print "not " unless $r eq join($dirsep, "Foo", "Bar.pm"); +print "ok 9\n"; -{ - my @r; - local *CORE::GLOBAL::require = sub { push @r, shift; 1; }; - eval "use 5.006"; - like( " @r ", qr " 5\.006 " ); -} - -{ - local $_ = 'foo.pm'; - require; - is( $r, 'foo.pm' ); -} - -{ - BEGIN { - # Can’t do ‘no warnings’ with CORE::GLOBAL::require overridden. :-) - CORE::require warnings; - unimport warnings 'experimental::lexical_topic'; - } - my $_ = 'bar.pm'; - require; - is( $r, 'bar.pm' ); -} +eval "use 5.6"; +print "not " unless $r eq "5.6"; +print "ok 10\n"; # localizing *CORE::GLOBAL::foo should revert to finding CORE::foo { local(*CORE::GLOBAL::require); $r = ''; eval "require NoNeXiSt;"; - ok( ! ( $r or $@ !~ /^Can't locate NoNeXiSt/i ) ); + print "not " if $r or $@ !~ /^Can't locate NoNeXiSt/i; + print "ok 11\n"; } # @@ -89,96 +77,14 @@ is( $r, join($dirsep, "Foo", "Bar.pm") ); $r = 11; BEGIN { *CORE::GLOBAL::readline = sub (;*) { ++$r }; } -is( , 12 ); -is( <$fh> , 13 ); +print == 12 ? "ok 12\n" : "not ok 12\n"; +print <$fh> == 13 ? "ok 13\n" : "not ok 13\n"; my $pad_fh; -is( <$pad_fh> , 14 ); +print <$pad_fh> == 14 ? "ok 14\n" : "not ok 14\n"; # Non-global readline() override BEGIN { *Rgs::readline = sub (;*) { --$r }; } -{ - package Rgs; - ::is( , 13 ); - ::is( <$fh> , 12 ); - ::is( <$pad_fh> , 11 ); -} - -# Global readpipe() override -BEGIN { *CORE::GLOBAL::readpipe = sub ($) { "$_[0] " . --$r }; } -is( `rm`, "rm 10", '``' ); -is( qx/cp/, "cp 9", 'qx' ); - -# Non-global readpipe() override -BEGIN { *Rgs::readpipe = sub ($) { ++$r . " $_[0]" }; } -{ - package Rgs; - ::is( `rm`, "10 rm", '``' ); - ::is( qx/cp/, "11 cp", 'qx' ); -} - -# Verify that the parsing of overridden keywords isn't messed up -# by the indirect object notation -{ - local $SIG{__WARN__} = sub { - ::like( $_[0], qr/^ok overriden at/ ); - }; - BEGIN { *OverridenWarn::warn = sub { CORE::warn "@_ overriden"; }; } - package OverridenWarn; - sub foo { "ok" } - warn( OverridenWarn->foo() ); - warn OverridenWarn->foo(); -} -BEGIN { *OverridenPop::pop = sub { ::is( $_[0][0], "ok" ) }; } -{ - package OverridenPop; - sub foo { [ "ok" ] } - pop( OverridenPop->foo() ); - pop OverridenPop->foo(); -} - -{ - eval { - local *CORE::GLOBAL::require = sub { - CORE::require($_[0]); - }; - require 5; - require Text::ParseWords; - }; - is $@, ''; -} - -# Constant inlining should not countermand "use subs" overrides -BEGIN { package other; *::caller = \&::caller } -sub caller() { 42 } -caller; # inline the constant -is caller, 42, 'constant inlining does not undo "use subs" on keywords'; - -is runperl(prog => 'sub CORE::GLOBAL::do; do file; print qq-ok\n-'), - "ok\n", - 'no crash with CORE::GLOBAL::do stub'; -is runperl(prog => 'sub CORE::GLOBAL::glob; glob; print qq-ok\n-'), - "ok\n", - 'no crash with CORE::GLOBAL::glob stub'; -is runperl(prog => 'sub CORE::GLOBAL::require; require re; print qq-o\n-'), - "o\n", - 'no crash with CORE::GLOBAL::require stub'; - -like runperl(prog => 'use constant foo=>1; ' - .'BEGIN { *{q|CORE::GLOBAL::readpipe|} = \&{q|foo|};1}' - .'warn ``', - stderr => 1), - qr/Too many arguments/, - '`` does not ignore &CORE::GLOBAL::readpipe aliased to a constant'; -like runperl(prog => 'use constant foo=>1; ' - .'BEGIN { *{q|CORE::GLOBAL::readline|} = \&{q|foo|};1}' - .'warn ', - stderr => 1), - qr/Too many arguments/, - '<> does not ignore &CORE::GLOBAL::readline aliased to a constant'; - -is runperl(prog => 'use constant t=>42; ' - .'BEGIN { *{q|CORE::GLOBAL::time|} = \&{q|t|};1}' - .'print time, chr 10', - stderr => 1), - "42\n", - 'keywords respect global constant overrides'; +package Rgs; +print == 13 ? "ok 15\n" : "not ok 15\n"; +print <$fh> == 12 ? "ok 16\n" : "not ok 16\n"; +print <$pad_fh> == 11 ? "ok 17\n" : "not ok 17\n"; diff --git a/gnu/usr.bin/perl/t/op/srand.t b/gnu/usr.bin/perl/t/op/srand.t index 5321cde6568..5753a5d0eb8 100644 --- a/gnu/usr.bin/perl/t/op/srand.t +++ b/gnu/usr.bin/perl/t/op/srand.t @@ -10,7 +10,7 @@ BEGIN { use strict; require "test.pl"; -plan(tests => 10); +plan(tests => 4); # Generate a load of random numbers. # int() avoids possible floating point error. @@ -57,34 +57,3 @@ sleep(1); # in case our srand() is too time-dependent @second_run = `$^X -le "print int rand 100 for 1..100"`; ok( !eq_array(\@first_run, \@second_run), 'srand() called automatically'); - -# check srand's return value -my $seed = srand(1764); -is( $seed, 1764, "return value" ); - -$seed = srand(0); -ok( $seed, "true return value for srand(0)"); -cmp_ok( $seed, '==', 0, "numeric 0 return value for srand(0)"); - -{ - my @warnings; - my $b; - { - local $SIG{__WARN__} = sub { - push @warnings, "@_"; - warn @_; - }; - $b = $seed + 0; - } - is( $b, 0, "Quacks like a zero"); - is( "@warnings", "", "Does not warn"); -} - -# [perl #40605] -{ - use warnings; - my $w = ''; - local $SIG{__WARN__} = sub { $w .= $_[0] }; - srand(2**100); - like($w, qr/^Integer overflow in srand at /, "got a warning"); -} diff --git a/gnu/usr.bin/perl/t/op/sub_lval.t b/gnu/usr.bin/perl/t/op/sub_lval.t index 4bd96ee4778..308269eee93 100644 --- a/gnu/usr.bin/perl/t/op/sub_lval.t +++ b/gnu/usr.bin/perl/t/op/sub_lval.t @@ -1,18 +1,20 @@ +print "1..67\n"; + BEGIN { chdir 't' if -d 't'; @INC = '../lib'; - require './test.pl'; } -plan tests=>205; sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary sub b : lvalue { ${\shift} } my $out = a(b()); # Check that temporaries are allowed. -is(ref $out, 'main'); # Not reached if error. +print "# `$out'\nnot " unless ref $out eq 'main'; # Not reached if error. +print "ok 1\n"; my @out = grep /main/, a(b()); # Check that temporaries are allowed. -cmp_ok(scalar @out, '==', 1); # Not reached if error. +print "# `@out'\nnot " unless @out==1; # Not reached if error. +print "ok 2\n"; my $in; @@ -27,7 +29,8 @@ sub neg : lvalue { #(num_str) return num_str in(neg("+2")); -is($in, '-2'); +print "# `$in'\nnot " unless $in eq '-2'; +print "ok 3\n"; sub get_lex : lvalue { $in } sub get_st : lvalue { $blah } @@ -40,75 +43,93 @@ $blah = 3; get_st = 7; -cmp_ok($blah, '==', 7); +print "# `$blah' ne 7\nnot " unless $blah == 7; +print "ok 4\n"; get_lex = 7; -cmp_ok($in, '==', 7); +print "# `$in' ne 7\nnot " unless $in == 7; +print "ok 5\n"; ++get_st; -cmp_ok($blah, '==', 8); +print "# `$blah' ne 8\nnot " unless $blah == 8; +print "ok 6\n"; ++get_lex; -cmp_ok($in, '==', 8); +print "# `$in' ne 8\nnot " unless $in == 8; +print "ok 7\n"; id(get_st) = 10; -cmp_ok($blah, '==', 10); +print "# `$blah' ne 10\nnot " unless $blah == 10; +print "ok 8\n"; id(get_lex) = 10; -cmp_ok($in, '==', 10); +print "# `$in' ne 10\nnot " unless $in == 10; +print "ok 9\n"; ++id(get_st); -cmp_ok($blah, '==', 11); +print "# `$blah' ne 11\nnot " unless $blah == 11; +print "ok 10\n"; ++id(get_lex); -cmp_ok($in, '==', 11); +print "# `$in' ne 11\nnot " unless $in == 11; +print "ok 11\n"; id1(get_st) = 20; -cmp_ok($blah, '==', 20); +print "# `$blah' ne 20\nnot " unless $blah == 20; +print "ok 12\n"; id1(get_lex) = 20; -cmp_ok($in, '==', 20); +print "# `$in' ne 20\nnot " unless $in == 20; +print "ok 13\n"; ++id1(get_st); -cmp_ok($blah, '==', 21); +print "# `$blah' ne 21\nnot " unless $blah == 21; +print "ok 14\n"; ++id1(get_lex); -cmp_ok($in, '==', 21); +print "# `$in' ne 21\nnot " unless $in == 21; +print "ok 15\n"; inc(get_st); -cmp_ok($blah, '==', 22); +print "# `$blah' ne 22\nnot " unless $blah == 22; +print "ok 16\n"; inc(get_lex); -cmp_ok($in, '==', 22); +print "# `$in' ne 22\nnot " unless $in == 22; +print "ok 17\n"; inc(id(get_st)); -cmp_ok($blah, '==', 23); +print "# `$blah' ne 23\nnot " unless $blah == 23; +print "ok 18\n"; inc(id(get_lex)); -cmp_ok($in, '==', 23); +print "# `$in' ne 23\nnot " unless $in == 23; +print "ok 19\n"; ++inc(id1(id(get_st))); -cmp_ok($blah, '==', 25); +print "# `$blah' ne 25\nnot " unless $blah == 25; +print "ok 20\n"; ++inc(id1(id(get_lex))); -cmp_ok($in, '==', 25); +print "# `$in' ne 25\nnot " unless $in == 25; +print "ok 21\n"; @a = (1) x 3; @b = (undef) x 2; @@ -131,13 +152,13 @@ EOE #@out = ($x, a3, $y, b2, $z, c4, $t); #@in = (34 .. 41, (undef) x 4, 46); -#print "# '@out' ne '@in'\nnot " unless "@out" eq "@in"; - -like($_, qr/Can\'t return an uninitialized value from lvalue subroutine/); -print "ok 22\n"; +#print "# `@out' ne `@in'\nnot " unless "@out" eq "@in"; +print "# '$_'.\nnot " + unless /Can\'t return an uninitialized value from lvalue subroutine/; =cut +print "ok 22\n"; my $var; @@ -145,20 +166,23 @@ sub a::var : lvalue { $var } "a"->var = 45; -cmp_ok($var, '==', 45); +print "# `$var' ne 45\nnot " unless $var == 45; +print "ok 23\n"; my $oo; $o = bless \$oo, "a"; $o->var = 47; -cmp_ok($var, '==', 47); +print "# `$var' ne 47\nnot " unless $var == 47; +print "ok 24\n"; sub o : lvalue { $o } o->var = 49; -cmp_ok($var, '==', 49); +print "# `$var' ne 49\nnot " unless $var == 49; +print "ok 25\n"; sub nolv () { $x0, $x1 } # Not lvalue @@ -169,7 +193,9 @@ eval <<'EOE' or $_ = $@; 1; EOE -like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/); +print "not " + unless /Can\'t modify non-lvalue subroutine call in scalar assignment/; +print "ok 26\n"; $_ = ''; @@ -178,7 +204,9 @@ eval <<'EOE' or $_ = $@; 1; EOE -like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/); +print "not " + unless /Can\'t modify non-lvalue subroutine call in scalar assignment/; +print "ok 27\n"; $_ = ''; @@ -187,7 +215,9 @@ eval <<'EOE' or $_ = $@; 1; EOE -like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/); +print "not " + unless /Can\'t modify non-lvalue subroutine call in scalar assignment/; +print "ok 28\n"; $x0 = $x1 = $_ = undef; $nolv = \&nolv; @@ -197,7 +227,8 @@ eval <<'EOE' or $_ = $@; 1; EOE -ok(!defined $_) or diag "'$_', '$x0', '$x1'"; +print "# '$_', '$x0', '$x1'.\nnot " if defined $_; +print "ok 29\n"; $x0 = $x1 = $_ = undef; $nolv = \&nolv; @@ -207,11 +238,11 @@ eval <<'EOE' or $_ = $@; 1; EOE -like($_, qr/Can\'t modify non-lvalue subroutine call/) - or diag "'$_', '$x0', '$x1'"; +print "# '$_', '$x0', '$x1'.\nnot " + unless /Can\'t modify non-lvalue subroutine call/; +print "ok 30\n"; -sub lv0 : lvalue { } -sub rlv0 : lvalue { return } +sub lv0 : lvalue { } # Converted to lv10 in scalar context $_ = undef; eval <<'EOE' or $_ = $@; @@ -219,16 +250,11 @@ eval <<'EOE' or $_ = $@; 1; EOE -like($_, qr/Can't return undef from lvalue subroutine/); - -$_ = undef; -eval <<'EOE' or $_ = $@; - rlv0 = (2,3); - 1; -EOE +print "# '$_'.\nnot " + unless /Empty array returned from lvalue subroutine in scalar context/; +print "ok 31\n"; -like($_, qr/Can't return undef from lvalue subroutine/, - 'explicit return of nothing in scalar context'); +sub lv10 : lvalue {} $_ = undef; eval <<'EOE' or $_ = $@; @@ -236,24 +262,10 @@ eval <<'EOE' or $_ = $@; 1; EOE -ok(!defined $_) or diag $_; - -$_ = undef; -eval <<'EOE' or $_ = $@; - (rlv0) = (2,3); - 1; -EOE - -ok(!defined $_, 'explicit return of nothing in list context') or diag $_; - -($a,$b)=(); -(lv0($a,$b)) = (3,4); -is +($a//'undef') . ($b//'undef'), 'undefundef', - 'list assignment to empty lvalue sub'; - +print "# '$_'.\nnot " if defined $_; +print "ok 32\n"; sub lv1u :lvalue { undef } -sub rlv1u :lvalue { undef } $_ = undef; eval <<'EOE' or $_ = $@; @@ -261,16 +273,9 @@ eval <<'EOE' or $_ = $@; 1; EOE -like($_, qr/Can't return undef from lvalue subroutine/); - -$_ = undef; -eval <<'EOE' or $_ = $@; - rlv1u = (2,3); - 1; -EOE - -like($_, qr/Can't return undef from lvalue subroutine/, - 'explicitly returning undef in scalar context'); +print "# '$_'.\nnot " + unless /Can\'t return a readonly value from lvalue subroutine/; +print "ok 33\n"; $_ = undef; eval <<'EOE' or $_ = $@; @@ -278,15 +283,10 @@ eval <<'EOE' or $_ = $@; 1; EOE -ok(!defined, 'implicitly returning undef in list context'); - -$_ = undef; -eval <<'EOE' or $_ = $@; - (rlv1u) = (2,3); - 1; -EOE - -ok(!defined, 'explicitly returning undef in list context'); +# Fixed by change @10777 +#print "# '$_'.\nnot " +# unless /Can\'t return an uninitialized value from lvalue subroutine/; +print "ok 34 # Skip: removed test\n"; $x = '1234567'; @@ -297,56 +297,20 @@ eval <<'EOE' or $_ = $@; 1; EOE -like($_, qr/Can\'t return a temporary from lvalue subroutine/); - -$_ = undef; -eval <<'EOE' or $_ = $@; - sub rlv1t : lvalue { index $x, 2 } - rlv1t = (2,3); - 1; -EOE - -like($_, qr/Can\'t return a temporary from lvalue subroutine/, - 'returning a PADTMP explicitly'); - -$_ = undef; -eval <<'EOE' or $_ = $@; - (rlv1t) = (2,3); - 1; -EOE - -like($_, qr/Can\'t return a temporary from lvalue subroutine/, - 'returning a PADTMP explicitly (list context)'); - -# These next two tests are not necessarily normative. But this way we will -# know if this discrepancy changes. +print "# '$_'.\nnot " + unless /Can\'t modify index in lvalue subroutine return/; +print "ok 35\n"; $_ = undef; eval <<'EOE' or $_ = $@; - sub scalarray : lvalue { @a || $b } - @a = 1; - (scalarray) = (2,3); + sub lv2t : lvalue { shift } + (lv2t) = (2,3); 1; EOE -like($_, qr/Can\'t return a temporary from lvalue subroutine/, - 'returning a scalar-context array via ||'); - -$_ = undef; -eval <<'EOE' or $_ = $@; - use warnings "FATAL" => "all"; - sub myscalarray : lvalue { my @a = 1; @a || $b } - (myscalarray) = (2,3); - 1; -EOE - -like($_, qr/Useless assignment to a temporary/, - 'returning a scalar-context lexical array via ||'); - -$_ = undef; -sub lv2t : lvalue { shift } -(lv2t($_)) = (2,3); -is($_, 2); +print "# '$_'.\nnot " + unless /Can\'t modify shift in lvalue subroutine return/; +print "ok 36\n"; $xxx = 'xxx'; sub xxx () { $xxx } # Not lvalue @@ -358,7 +322,9 @@ eval <<'EOE' or $_ = $@; 1; EOE -like($_, qr/Can\'t modify non-lvalue subroutine call at /); +print "# '$_'.\nnot " + unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/; +print "ok 37\n"; $_ = undef; eval <<'EOE' or $_ = $@; @@ -366,7 +332,9 @@ eval <<'EOE' or $_ = $@; 1; EOE -like($_, qr/Can\'t modify non-lvalue subroutine call at /); +print "# '$_'.\nnot " + unless /Can\'t return a temporary from lvalue subroutine/; +print "ok 38\n"; sub yyy () { 'yyy' } # Const, not lvalue @@ -377,7 +345,9 @@ eval <<'EOE' or $_ = $@; 1; EOE -like($_, qr/Can\'t return a readonly value from lvalue subroutine at/); +print "# '$_'.\nnot " + unless /Can\'t modify constant item in lvalue subroutine return/; +print "ok 39\n"; $_ = undef; eval <<'EOE' or $_ = $@; @@ -385,7 +355,9 @@ eval <<'EOE' or $_ = $@; 1; EOE -like($_, qr/Can\'t return a readonly value from lvalue subroutine/); +print "# '$_'.\nnot " + unless /Can\'t return a readonly value from lvalue subroutine/; +print "ok 40\n"; sub lva : lvalue {@a} @@ -397,7 +369,8 @@ eval <<'EOE' or $_ = $@; 1; EOE -is("'@a' $_", "'2 3' "); +print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; +print "ok 41\n"; $_ = undef; @a = (); @@ -408,16 +381,20 @@ eval <<'EOE' or $_ = $@; 1; EOE -is("'@a' $_", "'2 3' "); - -is lva->${\sub { return $_[0] }}, 2, - 'lvalue->$thing when lvalue returns array'; +print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; +print "ok 42\n"; -my @my = qw/ a b c /; -sub lvmya : lvalue { @my } +$_ = undef; +@a = (); +$a[0] = undef; +$a[1] = 12; +eval <<'EOE' or $_ = $@; + (lva) = (2,3); + 1; +EOE -is lvmya->${\sub { return $_[0] }}, 3, - 'lvalue->$thing when lvalue returns lexical array'; +print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; +print "ok 43\n"; sub lv1n : lvalue { $newvar } @@ -427,7 +404,8 @@ eval <<'EOE' or $_ = $@; 1; EOE -is("'$newvar' $_", "'4' "); +print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' "; +print "ok 44\n"; sub lv1nn : lvalue { $nnewvar } @@ -437,22 +415,25 @@ eval <<'EOE' or $_ = $@; 1; EOE -is("'$nnewvar' $_", "'3' "); +print "# '$_'.\nnot " unless "'$nnewvar' $_" eq "'3' "; +print "ok 45\n"; $a = \&lv1nn; $a->() = 8; -is($nnewvar, '8'); +print "# '$nnewvar'.\nnot " unless $nnewvar eq '8'; +print "ok 46\n"; -eval 'sub AUTOLOAD : lvalue { $newvar }'; +# This must happen at run time +eval { + sub AUTOLOAD : lvalue { $newvar }; +}; foobar() = 12; -is($newvar, "12"); +print "# '$newvar'.\nnot " unless $newvar eq "12"; +print "ok 47\n"; -# But autoloading should only be triggered by a call to an undefined -# subroutine. -&{"lv1nn"} = 14; -is $newvar, 12, 'AUTOLOAD does not take precedence over lvalue sub'; -eval { &{"xxx"} = 14 }; -is $newvar, 12, 'AUTOLOAD does not take precedence over non-lvalue sub'; +print "ok 48 # Skip: removed test\n"; + +print "ok 49 # Skip: removed test\n"; { my %hash; my @array; @@ -462,18 +443,18 @@ sub hlv : lvalue { $hash{"foo"} } sub hlv2 : lvalue { $hash{$_[0]} } $array[1] = "not ok 51\n"; alv() = "ok 50\n"; -is(alv(), "ok 50\n"); +print alv(); alv2(20) = "ok 51\n"; -is($array[20], "ok 51\n"); +print $array[20]; $hash{"foo"} = "not ok 52\n"; hlv() = "ok 52\n"; -is($hash{foo}, "ok 52\n"); +print $hash{foo}; $hash{bar} = "not ok 53\n"; hlv("bar") = "ok 53\n"; -is(hlv("bar"), "ok 53\n"); +print hlv("bar"); sub array : lvalue { @array } sub array2 : lvalue { @array2 } # This is a global. @@ -483,37 +464,45 @@ sub hash2 : lvalue { %hash2 } # So's this. %hash2 = qw(foo bar); (array()) = qw(ok 54); -is("@array", "ok 54"); +print "not " unless "@array" eq "ok 54"; +print "ok 54\n"; (array2()) = qw(ok 55); -is("@array2", "ok 55"); +print "not " unless "@array2" eq "ok 55"; +print "ok 55\n"; (hash()) = qw(ok 56); -cmp_ok($hash{ok}, '==', 56); +print "not " unless $hash{ok} == 56; +print "ok 56\n"; (hash2()) = qw(ok 57); -cmp_ok($hash2{ok}, '==', 57); +print "not " unless $hash2{ok} == 57; +print "ok 57\n"; @array = qw(a b c d); sub aslice1 : lvalue { @array[0,2] }; (aslice1()) = ("ok", "already"); -is("@array", "ok b already d"); +print "# @array\nnot " unless "@array" eq "ok b already d"; +print "ok 58\n"; @array2 = qw(a B c d); sub aslice2 : lvalue { @array2[0,2] }; (aslice2()) = ("ok", "already"); -is("@array2", "ok B already d"); +print "not " unless "@array2" eq "ok B already d"; +print "ok 59\n"; %hash = qw(a Alpha b Beta c Gamma); sub hslice : lvalue { @hash{"c", "b"} } (hslice()) = ("CISC", "BogoMIPS"); -is(join("/",@hash{"c","a","b"}), "CISC/Alpha/BogoMIPS"); +print "not " unless join("/",@hash{"c","a","b"}) eq "CISC/Alpha/BogoMIPS"; +print "ok 60\n"; } $str = "Hello, world!"; sub sstr : lvalue { substr($str, 1, 4) } sstr() = "i"; -is($str, "Hi, world!"); +print "not " unless $str eq "Hi, world!"; +print "ok 61\n"; $str = "Made w/ JavaScript"; sub veclv : lvalue { vec($str, 2, 32) } @@ -523,7 +512,8 @@ if (ord('A') != 193) { else { # EBCDIC? veclv() = 0xD7859993; } -is($str, "Made w/ PerlScript"); +print "# $str\nnot " unless $str eq "Made w/ PerlScript"; +print "ok 62\n"; sub position : lvalue { pos } @p = (); @@ -532,90 +522,24 @@ while (/f/g) { push @p, position; position() += 6; } -is("@p", "1 8"); - -sub keeze : lvalue { keys %__ } -%__ = ("a","b"); -keeze = 64; -is scalar %__, '1/64', 'keys assignment through lvalue sub'; +print "# @p\nnot " unless "@p" eq "1 8"; +print "ok 63\n"; # Bug 20001223.002: split thought that the list had only one element @ary = qw(4 5 6); sub lval1 : lvalue { $ary[0]; } sub lval2 : lvalue { $ary[1]; } (lval1(), lval2()) = split ' ', "1 2 3 4"; +print "not " unless join(':', @ary) eq "1:2:6"; +print "ok 64\n"; -is(join(':', @ary), "1:2:6"); - -# check that an element of a tied hash/array can be assigned to via lvalueness - -package Tie_Hash; - -our ($key, $val); -sub TIEHASH { bless \my $v => __PACKAGE__ } -sub STORE { ($key, $val) = @_[1,2] } - -package main; -sub lval_tie_hash : lvalue { - tie my %t => 'Tie_Hash'; - $t{key}; -} - -eval { lval_tie_hash() = "value"; }; - -is($@, "", "element of tied hash"); - -is("$Tie_Hash::key-$Tie_Hash::val", "key-value"); +require './test.pl'; +curr_test(65); +TODO: { + local $TODO = 'test explicit return of lval expr'; -package Tie_Array; - -our @val; -sub TIEARRAY { bless \my $v => __PACKAGE__ } -sub STORE { $val[ $_[1] ] = $_[2] } - -package main; -sub lval_tie_array : lvalue { - tie my @t => 'Tie_Array'; - $t[0]; -} - -eval { lval_tie_array() = "value"; }; - - -is($@, "", "element of tied array"); - -is ($Tie_Array::val[0], "value"); - - -# Check that tied pad vars that are returned can be assigned to -sub TIESCALAR { bless [] } -sub STORE {$wheel = $_[1]} -sub FETCH {$wheel} -sub tied_pad_var :lvalue { tie my $tyre, ''; $tyre } -sub tied_pad_varr :lvalue { tie my $tyre, ''; return $tyre } -tied_pad_var = 1; -is $wheel, 1, 'tied pad var returned in scalar lvalue context'; -tied_pad_var->${\sub{ $_[0] = 2 }}; -is $wheel, 2, 'tied pad var returned in scalar ref context'; -(tied_pad_var) = 3; -is $wheel, 3, 'tied pad var returned in list lvalue context'; -$_ = 4 for tied_pad_var; -is $wheel, 4, 'tied pad var returned in list ref context'; -tied_pad_varr = 5; -is $wheel, 5, 'tied pad var explicitly returned in scalar lvalue context'; -tied_pad_varr->${\sub{ $_[0] = 6 }}; -is $wheel, 6, 'tied pad var explicitly returned in scalar ref context'; -(tied_pad_varr) = 7; -is $wheel, 7, 'tied pad var explicitly returned in list lvalue context'; -$_ = 8 for tied_pad_varr; -is $wheel, 8, 'tied pad var explicitly returned in list ref context'; - - -# Test explicit return of lvalue expression -{ - # subs are copies from tests 1-~18 with an explicit return added. - # They used not to work, which is why they are ‘badly’ named. + # subs are corrupted copies from tests 1-~4 sub bad_get_lex : lvalue { return $in }; sub bad_get_st : lvalue { return $blah } @@ -637,408 +561,5 @@ is $wheel, 8, 'tied pad var explicitly returned in list ref context'; ++bad_get_st; is($blah, 8, "yada"); - - ++bad_get_lex; - cmp_ok($in, '==', 8); - - bad_id(bad_get_st) = 10; - cmp_ok($blah, '==', 10); - - bad_id(bad_get_lex) = 10; - cmp_ok($in, '==', 10); - - ++bad_id(bad_get_st); - cmp_ok($blah, '==', 11); - - ++bad_id(bad_get_lex); - cmp_ok($in, '==', 11); - - bad_id1(bad_get_st) = 20; - cmp_ok($blah, '==', 20); - - bad_id1(bad_get_lex) = 20; - cmp_ok($in, '==', 20); - - ++bad_id1(bad_get_st); - cmp_ok($blah, '==', 21); - - ++bad_id1(bad_get_lex); - cmp_ok($in, '==', 21); - - bad_inc(bad_get_st); - cmp_ok($blah, '==', 22); - - bad_inc(bad_get_lex); - cmp_ok($in, '==', 22); - - bad_inc(bad_id(bad_get_st)); - cmp_ok($blah, '==', 23); - - bad_inc(bad_id(bad_get_lex)); - cmp_ok($in, '==', 23); - - ++bad_inc(bad_id1(bad_id(bad_get_st))); - cmp_ok($blah, '==', 25); - - ++bad_inc(bad_id1(bad_id(bad_get_lex))); - cmp_ok($in, '==', 25); - - # Recursive - my $r; - my $to_modify; - $r = sub :lvalue { - my $depth = shift//0; - if ($depth == 2) { return $to_modify } - return &$r($depth+1); - }; - &$r(0) = 7; - is $to_modify, 7, 'recursive lvalue sub'; - - # Recursive with substr [perl #72706] - my $val = ''; - my $pie; - $pie = sub :lvalue { - my $depth = shift; - return &$pie($depth) if $depth--; - substr $val, 0; - }; - for my $depth (0, 1, 2) { - my $value = "Good $depth"; - eval { - &$pie($depth) = $value; - }; - is($@, '', "recursive lvalue substr return depth $depth"); - is($val, $value, - "value assigned to recursive lvalue substr (depth $depth)"); - } } -{ # bug #23790 - my @arr = qw /one two three/; - my $line = "zero"; - sub lval_array () : lvalue {@arr} - - for (lval_array) { - $line .= $_; - } - - is($line, "zeroonetwothree"); - - sub trythislval { scalar(@_)."x".join "", @_ } - is(trythislval(lval_array()), "3xonetwothree"); - - sub changeme { $_[2] = "free" } - changeme(lval_array); - is("@arr", "one two free"); - - # test again, with explicit return - sub rlval_array() : lvalue {return @arr} - @arr = qw /one two three/; - $line = "zero"; - for (rlval_array) { - $line .= $_; - } - is($line, "zeroonetwothree"); - is(trythislval(rlval_array()), "3xonetwothree"); - changeme(rlval_array); - is("@arr", "one two free"); - - # Variations on the same theme, with multiple vars returned - my $scalar = 'half'; - sub lval_scalar_array () : lvalue { $scalar, @arr } - @arr = qw /one two three/; - $line = "zero"; - for (lval_scalar_array) { - $line .= $_; - } - is($line, "zerohalfonetwothree"); - is(trythislval(lval_scalar_array()), "4xhalfonetwothree"); - changeme(lval_scalar_array); - is("@arr", "one free three"); - - sub lval_array_scalar () : lvalue { @arr, $scalar } - @arr = qw /one two three/; - $line = "zero"; - $scalar = 'four'; - for (lval_array_scalar) { - $line .= $_; - } - is($line, "zeroonetwothreefour"); - is(trythislval(lval_array_scalar()), "4xonetwothreefour"); - changeme(lval_array_scalar); - is("@arr", "one two free"); - - # Tests for specific ops not tested above - # rv2av - @array2 = qw 'one two free'; - is join(',', map $_, sub:lvalue{@array2}->()), 'one,two,free', - 'rv2av in reference context'; - is join(',', map $_, sub:lvalue{@{\@array2}}->()), 'one,two,free', - 'rv2av-with-ref in reference context'; - # padhv - my %hash = qw[a b c d]; - like join(',', map $_, sub:lvalue{%hash}->()), - qr/^(?:a,b,c,d|c,d,a,b)\z/, 'padhv in reference context'; - # rv2hv - %hash2 = qw[a b c d]; - like join(',', map $_, sub:lvalue{%hash2}->()), - qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv in reference context'; - like join(',', map $_, sub:lvalue{%{\%hash2}}->()), - qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv-with-ref in reference context'; -} - -{ - package Foo; - sub AUTOLOAD :lvalue { *{$AUTOLOAD} }; - package main; - my $foo = bless {},"Foo"; - my $result; - $foo->bar = sub { $result = "bar" }; - $foo->bar; - is ($result, 'bar', "RT #41550"); -} - -SKIP: { skip 'no attributes.pm', 1 unless eval 'require attributes'; -fresh_perl_is(<<'----', <<'====', {}, "lvalue can not be set after definition. [perl #68758]"); -use warnings; -our $x; -sub foo { $x } -sub foo : lvalue; -sub MODIFY_CODE_ATTRIBUTES {} -sub foo : lvalue : fr0g; -foo = 3; ----- -lvalue attribute ignored after the subroutine has been defined at - line 4. -lvalue attribute ignored after the subroutine has been defined at - line 6. -Can't modify non-lvalue subroutine call in scalar assignment at - line 7, near "3;" -Execution of - aborted due to compilation errors. -==== -} - -{ - my $x; - sub lval_decl : lvalue; - sub lval_decl { $x } - lval_decl = 5; - is($x, 5, "subroutine declared with lvalue before definition retains lvalue. [perl #68758]"); -} - -SKIP: { skip "no attributes.pm", 2 unless eval { require attributes }; - sub utf8::valid :lvalue; - require attributes; - is "@{[ &attributes::get(\&utf8::valid) ]}", 'lvalue', - 'sub declaration with :lvalue applies it to XSUBs'; - - BEGIN { *wonky = \&marjibberous } - sub wonky :lvalue; - is "@{[ &attributes::get(\&wonky) ]}", 'lvalue', - 'sub declaration with :lvalue applies it to assigned stub'; -} - -sub fleen : lvalue { $pnare } -$pnare = __PACKAGE__; -ok eval { fleen = 1 }, "lvalues can return COWs (CATTLE?) [perl #75656]";\ -is $pnare, 1, 'and returning CATTLE actually works'; -$pnare = __PACKAGE__; -ok eval { (fleen) = 1 }, "lvalues can return COWs in list context"; -is $pnare, 1, 'and returning COWs in list context actually works'; -$pnare = __PACKAGE__; -ok eval { $_ = 1 for(fleen); 1 }, "lvalues can return COWs in ref cx"; -is $pnare, 1, 'and returning COWs in reference context actually works'; - - -# Returning an arbitrary expression, not necessarily lvalue -+sub :lvalue { return $ambaga || $ambaga }->() = 73; -is $ambaga, 73, 'explicit return of arbitrary expression (scalar context)'; -(sub :lvalue { return $ambaga || $ambaga }->()) = 74; -is $ambaga, 74, 'explicit return of arbitrary expression (list context)'; -+sub :lvalue { $ambaga || $ambaga }->() = 73; -is $ambaga, 73, 'implicit return of arbitrary expression (scalar context)'; -(sub :lvalue { $ambaga || $ambaga }->()) = 74; -is $ambaga, 74, 'implicit return of arbitrary expression (list context)'; -eval { +sub :lvalue { return 3 }->() = 4 }; -like $@, qr/Can\'t return a readonly value from lvalue subroutine at/, - 'assignment to numeric constant explicitly returned from lv sub'; -eval { (sub :lvalue { return 3 }->()) = 4 }; -like $@, qr/Can\'t return a readonly value from lvalue subroutine at/, - 'assignment to num constant explicitly returned (list cx)'; -eval { +sub :lvalue { 3 }->() = 4 }; -like $@, qr/Can\'t return a readonly value from lvalue subroutine at/, - 'assignment to numeric constant implicitly returned from lv sub'; -eval { (sub :lvalue { 3 }->()) = 4 }; -like $@, qr/Can\'t return a readonly value from lvalue subroutine at/, - 'assignment to num constant implicitly returned (list cx)'; - -# reference (potential lvalue) context -$suffix = ''; -for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) { - &$sub()->${\sub { $_[0] = 37 }}; - is $_, '37', 'lvalue->method'.$suffix; - ${\scalar &$sub()} = 38; - is $_, '38', 'scalar(lvalue)'.$suffix; - sub assign39_with_proto ($) { $_[0] = 39 } - assign39_with_proto(&$sub()); - is $_, '39', 'func(lvalue) when func has $ proto'.$suffix; - $_ = 1; - ${\(&$sub()||undef)} = 40; - is $_, '40', 'lvalue||...'.$suffix; - ${\(${\undef}||&$sub())} = 41; # extra ${\...} to bypass const folding - is $_, '41', '...||lvalue'.$suffix; - $_ = 0; - ${\(&$sub()&&undef)} = 42; - is $_, '42', 'lvalue&&...'.$suffix; - ${\(${\1}&&&$sub())} = 43; - is $_, '43', '...&&lvalue'.$suffix; - ${\(&$sub())[0]} = 44; - is $_, '44', '(lvalue)[0]'.$suffix; -} -continue { $suffix = ' (explicit return)' } - -# autovivification -$suffix = ''; -for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) { - undef $_; - &$sub()->[3] = 4; - is $_->[3], 4, 'func->[...] autovivification'.$suffix; - undef $_; - &$sub()->{3} = 4; - is $_->{3}, 4, 'func->{...} autovivification'.$suffix; - undef $_; - ${&$sub()} = 4; - is $$_, 4, '${func()} autovivification' .$suffix; - undef $_; - @{&$sub()} = 4; - is "@$_", 4, '@{func()} autovivification' .$suffix; - undef $_; - %{&$sub()} = (4,5); - is join('-',%$_), '4-5', '%{func()} autovivification'.$suffix; - undef $_; - ${ (), &$sub()} = 4; - is $$_, 4, '${ (), func()} autovivification' .$suffix; -} -continue { $suffix = ' (explicit return)' } - -# [perl #92406] [perl #92290] Returning a pad var in rvalue context -$suffix = ''; -for my $sub ( - sub :lvalue { my $x = 72; $x }, - sub :lvalue { my $x = 72; return $x } -) { - is scalar(&$sub), 72, "sub returning pad var in scalar context$suffix"; - is +(&$sub)[0], 72, "sub returning pad var in list context$suffix"; -} -continue { $suffix = ' (explicit return)' } - -# Returning read-only values in reference context -$suffix = ''; -for ( - sub :lvalue { $] }->(), - sub :lvalue { return $] }->() -) { - is \$_, \$], 'read-only values are returned in reference context' - .$suffix # (they used to be copied) -} -continue { $suffix = ' (explicit return)' } - -# Returning unwritables from nested lvalue sub call in in rvalue context -# First, ensure we are testing what we think we are: -if (!Internals::SvREADONLY($])) { Internals::SvREADONLY($],1); } -sub squibble : lvalue { return $] } -sub squebble : lvalue { squibble } -sub squabble : lvalue { return squibble } -is $x = squebble, $], 'returning ro from nested lv sub call in rv cx'; -is $x = squabble, $], 'explct. returning ro from nested lv sub in rv cx'; -is \squebble, \$], 'returning ro from nested lv sub call in ref cx'; -is \squabble, \$], 'explct. returning ro from nested lv sub in ref cx'; - -# [perl #102486] Sub calls as the last statement of an lvalue sub -package _102486 { - my $called; - my $x = 'nonlv'; - sub strictlv :lvalue { use strict 'refs'; &$x } - sub lv :lvalue { &$x } - sub nonlv { ++$called } - eval { strictlv }; - ::like $@, qr/^Can't use string \("nonlv"\) as a subroutine ref while/, - 'strict mode applies to sub:lvalue{ &$string }'; - $called = 0; - ::ok eval { lv }, - 'sub:lvalue{&$x}->() does not die for non-lvalue inner sub call'; - ::is $called, 1, 'The &$x actually called the sub'; - eval { +sub :lvalue { &$x }->() = 3 }; - ::like $@, qr/^Can't modify non-lvalue subroutine call at /, - 'sub:lvalue{&$x}->() dies in true lvalue context'; -} - -# TARG should be copied in rvalue context -sub ucf :lvalue { ucfirst $_[0] } -is ucf("just another ") . ucf("perl hacker,\n"), - "Just another Perl hacker,\n", 'TARG is copied in rvalue scalar cx'; -is join('',ucf("just another "), ucf "perl hacker,\n"), - "Just another Perl hacker,\n", 'TARG is copied in rvalue list cx'; -sub ucfr : lvalue { - @_ ? ucfirst $_[0] : do { - is ucfr("just another ") . ucfr("perl hacker,\n"), - "Just another Perl hacker,\n", - 'TARG is copied in recursive rvalue scalar cx'; - is join('',ucfr("just another "), ucfr("perl hacker,\n")), - "Just another Perl hacker,\n", - 'TARG is copied in recursive rvalue list cx'; - } -} -ucfr(); - -# Test TARG with potential lvalue context, too -for (sub : lvalue { "$x" }->()) { - is \$_, \$_, '\$_ == \$_ in for(sub :lvalue{"$x"}->()){...}' -} - -# [perl #117947] XSUBs should not be treated as lvalues at run time -eval { &{\&utf8::is_utf8}("") = 3 }; -like $@, qr/^Can't modify non-lvalue subroutine call at /, - 'XSUB not seen at compile time dies in lvalue context'; - -# [perl #119797] else implicitly returning value -# This used to cause Bizarre copy of ARRAY in pp_leave -sub else119797 : lvalue { - if ($_[0]) { - 1; # two statements force a leave op - @119797 - } - else { - @119797 - } -} -eval { (else119797(0)) = 1..3 }; -is $@, "", '$@ after writing to array returned by else'; -is "@119797", "1 2 3", 'writing to array returned by else'; -eval { (else119797(1)) = 4..6 }; -is $@, "", '$@ after writing to array returned by if (with else)'; -is "@119797", "4 5 6", 'writing to array returned by if (with else)'; -sub if119797 : lvalue { - if ($_[0]) { - @119797 - } -} -@119797 = (); -eval { (if119797(1)) = 4..6 }; -is $@, "", '$@ after writing to array returned by if'; -is "@119797", "4 5 6", 'writing to array returned by if'; -sub unless119797 : lvalue { - unless ($_[0]) { - @119797 - } -} -@119797 = (); -eval { (unless119797(0)) = 4..6 }; -is $@, "", '$@ after writing to array returned by unless'; -is "@119797", "4 5 6", 'writing to array returned by unless'; -sub bare119797 : lvalue { - {; - @119797 - } -} -@119797 = (); -eval { (bare119797(0)) = 4..6 }; -is $@, "", '$@ after writing to array returned by bare block'; -is "@119797", "4 5 6", 'writing to array returned by bare block'; diff --git a/gnu/usr.bin/perl/t/op/utfhash.t b/gnu/usr.bin/perl/t/op/utfhash.t index ebb2934459b..af7e6c12960 100644 --- a/gnu/usr.bin/perl/t/op/utfhash.t +++ b/gnu/usr.bin/perl/t/op/utfhash.t @@ -5,7 +5,7 @@ BEGIN { @INC = '../lib'; require './test.pl'; - plan(tests => 99); + plan(tests => 91); } use strict; @@ -21,7 +21,7 @@ my %hashu = ( "\xff" => 0xff, "\x{1ff}" => 0x1ff, ); -# Check that we can find the 8-bit things by various literals +# Check that we can find the 8-bit things by various litterals is($hash8{"\x{00ff}"},0xFF); is($hash8{"\x{007f}"},0x7F); is($hash8{"\xff"},0xFF); @@ -32,9 +32,8 @@ is($hashu{"\xff"},0xFF); is($hashu{"\x7f"},0x7F); # Now try same thing with variables forced into various forms. -foreach ("\x7f","\xff") +foreach my $a ("\x7f","\xff") { - my $a = $_; # Force a copy utf8::upgrade($a); is($hash8{$a},ord($a)); is($hashu{$a},ord($a)); @@ -57,9 +56,8 @@ $hash8{chr(0x1ff)} = 0x1ff; # Check we have not got an spurious extra keys is(join('',sort { ord $a <=> ord $b } keys %hash8),"\x7f\xff\x{1ff}"); -foreach ("\x7f","\xff","\x{1ff}") +foreach my $a ("\x7f","\xff","\x{1ff}") { - my $a = $_; utf8::upgrade($a); is($hash8{$a},ord($a)); my $b = $a.chr(100); @@ -71,9 +69,8 @@ foreach ("\x7f","\xff","\x{1ff}") is(delete $hashu{chr(0x1ff)},0x1ff); is(join('',sort keys %hashu),"\x7f\xff"); -foreach ("\x7f","\xff") +foreach my $a ("\x7f","\xff") { - my $a = $_; utf8::upgrade($a); is($hashu{$a},ord($a)); utf8::downgrade($a); @@ -173,52 +170,3 @@ foreach ("\x7f","\xff") } } - -{ - local $/; # Slurp. - my $utf8 = ; - my $utfebcdic = ; - if (ord('A') == 65) { - eval $utf8; - } elsif (ord('A') == 193) { - eval $utfebcdic; - } -} -__END__ -{ - # See if utf8 barewords work [perl #22969] - use utf8; - my %hash = (теÑÑ‚ => 123); - is($hash{теÑÑ‚}, $hash{'теÑÑ‚'}); - is($hash{теÑÑ‚}, 123); - is($hash{'теÑÑ‚'}, 123); - %hash = (теÑÑ‚ => 123); - is($hash{теÑÑ‚}, $hash{'теÑÑ‚'}); - is($hash{теÑÑ‚}, 123); - is($hash{'теÑÑ‚'}, 123); - - # See if plain ASCII strings quoted with '=>' erroneously get utf8 flag [perl #68812] - my %foo = (a => 'b', 'c' => 'd'); - for my $key (keys %foo) { - ok !utf8::is_utf8($key), "'$key' shouldn't have utf8 flag"; - } -} -__END__ -{ - # See if utf8 barewords work [perl #22969] - use utf8; # UTF-EBCDIC, really. - my %hash = (½ää½âÀ½äâ½ää => 123); - is($hash{½ää½âÀ½äâ½ää}, $hash{'½ää½âÀ½äâ½ää'}); - is($hash{½ää½âÀ½äâ½ää}, 123); - is($hash{'½ää½âÀ½äâ½ää'}, 123); - %hash = (½ää½âÀ½äâ½ää => 123); - is($hash{½ää½âÀ½äâ½ää}, $hash{'½ää½âÀ½äâ½ää'}); - is($hash{½ää½âÀ½äâ½ää}, 123); - is($hash{'½ää½âÀ½äâ½ää'}, 123); - - # See if plain ASCII strings quoted with '=>' erroneously get utf8 flag [perl #68812] - my %foo = (a => 'b', 'c' => 'd'); - for my $key (keys %foo) { - ok !utf8::is_utf8($key), "'$key' shouldn't have utf8 flag"; - } -} diff --git a/gnu/usr.bin/perl/t/run/exit.t b/gnu/usr.bin/perl/t/run/exit.t index 02e57c65f8a..53ba4ea76bf 100644 --- a/gnu/usr.bin/perl/t/run/exit.t +++ b/gnu/usr.bin/perl/t/run/exit.t @@ -8,161 +8,64 @@ BEGIN { @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; - $code = "\"" . $code . "\"" if $^O eq 'VMS'; #VMS needs quotes for this. - return system($^X, "-e", $code); + my $cmd = "$^X -e "; + return system($cmd.$quote.$code.$quote); } BEGIN { - $numtests = ($^O eq 'VMS') ? 16 : 17; -} - - -my $vms_exit_mode = 0; - -if ($^O eq 'VMS') { - if (eval 'require VMS::Feature') { - $vms_exit_mode = !(VMS::Feature::current("posix_exit")); - } else { - my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; - my $env_posix_ex = $ENV{'PERL_VMS_POSIX_EXIT'} || ''; - my $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; - my $posix_ex = $env_posix_ex =~ /^[ET1]/i; - if (($unix_rpt || $posix_ex) ) { - $vms_exit_mode = 0; - } else { - $vms_exit_mode = 1; - } - } - $numtests = 29 unless $vms_exit_mode; + # MacOS system() doesn't have good return value + $numtests = ($^O eq 'VMS') ? 7 : ($^O eq 'MacOS') ? 0 : 3; } require "test.pl"; plan(tests => $numtests); -my $native_success = 0; - $native_success = 1 if $^O eq 'VMS'; - +if ($^O ne 'MacOS') { my $exit, $exit_arg; $exit = run('exit'); is( $exit >> 8, 0, 'Normal exit' ); -is( $exit, $?, 'Normal exit $?' ); -is( ${^CHILD_ERROR_NATIVE}, $native_success, 'Normal exit ${^CHILD_ERROR_NATIVE}' ); - -if (!$vms_exit_mode) { - my $posix_ok = eval { require POSIX; }; - my $wait_macros_ok = defined &POSIX::WIFEXITED; - eval { POSIX::WIFEXITED(${^CHILD_ERROR_NATIVE}) }; - $wait_macros_ok = 0 if $@; - $exit = run('exit 42'); - is( $exit >> 8, 42, 'Non-zero exit' ); - is( $exit, $?, 'Non-zero exit $?' ); - isnt( !${^CHILD_ERROR_NATIVE}, 0, 'Non-zero exit ${^CHILD_ERROR_NATIVE}' ); - SKIP: { - skip("No POSIX", 3) unless $posix_ok; - skip("No POSIX wait macros", 3) unless $wait_macros_ok; - ok(POSIX::WIFEXITED(${^CHILD_ERROR_NATIVE}), "WIFEXITED"); - ok(!POSIX::WIFSIGNALED(${^CHILD_ERROR_NATIVE}), "WIFSIGNALED"); - is(POSIX::WEXITSTATUS(${^CHILD_ERROR_NATIVE}), 42, "WEXITSTATUS"); - } - - SKIP: { - skip("Skip signals and core dump tests on Win32 and VMS", 7) - if ($^O eq 'MSWin32' || $^O eq 'VMS'); - - #TODO VMS will backtrace on this test and exits with code of 0 - #instead of 15. - - $exit = run('kill 15, $$; sleep(1);'); - - is( $exit & 127, 15, 'Term by signal' ); - ok( !($exit & 128), 'No core dump' ); - is( $? & 127, 15, 'Term by signal $?' ); - isnt( ${^CHILD_ERROR_NATIVE}, 0, 'Term by signal ${^CHILD_ERROR_NATIVE}' ); - SKIP: { - skip("No POSIX", 3) unless $posix_ok; - skip("No POSIX wait macros", 3) unless $wait_macros_ok; - ok(!POSIX::WIFEXITED(${^CHILD_ERROR_NATIVE}), "WIFEXITED"); - ok(POSIX::WIFSIGNALED(${^CHILD_ERROR_NATIVE}), "WIFSIGNALED"); - is(POSIX::WTERMSIG(${^CHILD_ERROR_NATIVE}), 15, "WTERMSIG"); - } - } -} +if ($^O ne 'VMS') { -if ($^O eq 'VMS') { - -# On VMS, successful returns from system() are reported 0, VMS errors that -# can not be translated to UNIX are reported as EVMSERR, which has a value -# of 65535. Codes from 2 through 7 are assumed to be from non-compliant -# VMS systems and passed through. Programs written to use _POSIX_EXIT() -# codes like GNV will pass the numbers 2 through 255 encoded in the -# C facility by multiplying the number by 8 and adding %x35A000 to it. -# Perl will decode that number from children back to it's internal status. -# -# For native VMS status codes, success codes are odd numbered, error codes -# are even numbered. The 3 LSBs of the code indicate if the success is -# an informational message or the severity of the failure. -# -# Because the failure codes for the tests of the CLI facility status codes can -# not be translated to UNIX error codes, they will be reported as EVMSERR, -# even though Perl will exit with them having the VMS status codes. -# -# Note that this is testing the perl exit() routine, and not the VMS -# DCL EXIT statement. -# -# The value %x1000000 has been added to the exit code to prevent the -# status message from being sent to the STDOUT and STDERR stream. -# -# Double quotes are needed to pass these commands through DCL to PERL + $exit = run('exit 42'); + is( $exit >> 8, 42, 'Non-zero exit' ); - $exit = run("exit 268632065"); # %CLI-S-NORMAL - is( $exit >> 8, 0, 'PERL success exit' ); - is( ${^CHILD_ERROR_NATIVE} & 7, 1, 'VMS success exit' ); +} else { - $exit = run("exit 268632067"); # %CLI-I-NORMAL - is( $exit >> 8, 0, 'PERL informational exit' ); - is( ${^CHILD_ERROR_NATIVE} & 7, 3, 'VMS informational exit' ); +# On VMS, successful returns from system() are always 0, warnings are 1, +# errors are 2, and fatal errors are 4. - $exit = run("exit 268632064"); # %CLI-W-NORMAL - is( $exit >> 8, 1, 'Perl warning exit' ); - is( ${^CHILD_ERROR_NATIVE} & 7, 0, 'VMS warning exit' ); + $exit = run("exit 196609"); # %CLI-S-NORMAL + is( $exit >> 8, 0, 'success exit' ); - $exit = run("exit 268632066"); # %CLI-E-NORMAL - is( $exit >> 8, 2, 'Perl error exit' ); - is( ${^CHILD_ERROR_NATIVE} & 7, 2, 'VMS error exit' ); + $exit = run("exit 196611"); # %CLI-I-NORMAL + is( $exit >> 8, 0, 'informational exit' ); - $exit = run("exit 268632068"); # %CLI-F-NORMAL - is( $exit >> 8, 4, 'Perl fatal error exit' ); - is( ${^CHILD_ERROR_NATIVE} & 7, 4, 'VMS fatal exit' ); + $exit = run("exit 196608"); # %CLI-W-NORMAL + is( $exit >> 8, 1, 'warning exit' ); - $exit = run("exit 02015320012"); # POSIX exit code 1 - is( $exit >> 8, 1, 'Posix exit code 1' ); + $exit = run("exit 196610"); # %CLI-E-NORMAL + is( $exit >> 8, 2, 'error exit' ); - $exit = run("exit 02015323771"); # POSIX exit code 255 - is( $exit >> 8 , 255, 'Posix exit code 255' ); + $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, -# or 44, which is what you get from any non-zero value of $? except for -# 65535 that has been dePOSIXified by STATUS_UNIX_SET. If $? is set to -# 65535 internally when there is a VMS status code that is valid, and -# when Perl exits, it will set that status code. -# -# In this test on VMS, the child process exit with a SS$_ABORT, which -# the parent stores in ${^CHILD_ERROR_NATIVE}. The SS$_ABORT code is -# then translated to the UNIX code EINTR which has the value of 4 on VMS. -# -# This is complex because Perl translates internally generated UNIX -# status codes to SS$_ABORT on exit, but passes through unmodified UNIX -# status codes that exit() is called with by scripts. - -$exit_arg = (44 & 7) if $vms_exit_mode; +# 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' ); +} diff --git a/gnu/usr.bin/perl/t/run/fresh_perl.t b/gnu/usr.bin/perl/t/run/fresh_perl.t index 885c8cc3d9a..9c2b42fc033 100644 --- a/gnu/usr.bin/perl/t/run/fresh_perl.t +++ b/gnu/usr.bin/perl/t/run/fresh_perl.t @@ -4,9 +4,20 @@ # 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 +# This is for tests that will normally cause segfaults, and other nasty # errors that might kill the interpreter and for some reason you can't # use an eval(). +# +# New tests are added to the bottom. For example. +# +# ######## perlbug ID 20020831.001 +# ($a, b) = (1,2) +# EXPECT +# Can't modify constant item in list assignment - at line 1 +# +# to test that the code "($a, b) = (1,2)" causes the appropriate syntax +# error, rather than just segfaulting as reported in perlbug ID +# 20020831.001 BEGIN { chdir 't' if -d 't'; @@ -35,13 +46,11 @@ foreach my $prog (@prgs) { my($raw_prog, $name) = @$prog; my $switch; - if ($raw_prog =~ s/^\s*(-\w.*)\n//){ + if ($raw_prog =~ s/^\s*(-\w.*)//){ $switch = $1; } my($prog,$expected) = split(/\nEXPECT\n/, $raw_prog); - $prog .= "\n"; - $expected = '' unless defined $expected; if ($prog =~ /^\# SKIP: (.+)/m) { if (eval $1) { @@ -52,12 +61,12 @@ foreach my $prog (@prgs) { $expected =~ s/\n+$//; - fresh_perl_is($prog, $expected, { switches => [$switch || ''] }, $name); + fresh_perl_is($prog, $expected, { switches => [$switch] }, $name); } __END__ ######## -$a = ":="; @_ = split /($a)/o, "a:=b:=c"; print "@_" +$a = ":="; split /($a)/o, "a:=b:=c"; print "@_" EXPECT a := b := c ######## @@ -81,7 +90,7 @@ $array[128]=1 ######## $x=0x0eabcd; print $x->ref; EXPECT -Can't locate object method "ref" via package "961485" (perhaps you forgot to load "961485"?) at - line 1. +Can't call method "ref" without a package or object reference at - line 1. ######## chop ($str .= ); ######## @@ -91,9 +100,9 @@ $x=2;$y=3;$x<$y ? $x : $y += 23;print $x; EXPECT 25 ######## -eval 'sub bar {print "In bar"}'; +eval {sub bar {print "In bar";}} ######## -system './perl -ne "print if eof" /dev/null' +system './perl -ne "print if eof" /dev/null' unless $^O eq 'MacOS' ######## chop($file = ); ######## @@ -105,6 +114,11 @@ print $aa; EXPECT 12345 ######## +%@x=0; +EXPECT +Can't modify hash dereference in repeat (x) at - line 1, near "0;" +Execution of - aborted due to compilation errors. +######## $_="foo"; printf(STDOUT "%s\n", $_); EXPECT @@ -275,7 +289,7 @@ print "ok\n" if ("\0" lt "\xFF"); EXPECT ok ######## -open(H,'run/fresh_perl.t'); # must be in the 't' directory +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 @@ -345,16 +359,20 @@ map {#this newline here tickles the bug $s += $_} (1,2,4); print "eat flaming death\n" unless ($s == 7); ######## -sub foo { local $_ = shift; @_ = split; @_ } +sub foo { local $_ = shift; split; @_ } @x = foo(' x y z '); print "you die joe!\n" unless "@x" eq 'x y z'; ######## -"A" =~ /(?{"{"})/ # Check it outside of eval too +/(?{"{"})/ # Check it outside of eval too EXPECT +Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern +Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE in m/(?{ <-- HERE "{"})/ at - line 1. ######## /(?{"{"}})/ # Check it outside of eval too EXPECT -Sequence (?{...}) not terminated with ')' at - line 1. +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" } @@ -382,7 +400,7 @@ EXPECT -w sub testme { my $a = "test"; { local $a = "new test"; print $a }} EXPECT -Can't localize lexical variable $a at - line 1. +Can't localize lexical variable $a at - line 2. ######## package X; sub ascalar { my $r; bless \$r } @@ -509,7 +527,7 @@ else { if ($x == 0) { print "" } else { print $x } } EXPECT -Use of uninitialized value $x in numeric eq (==) at - line 3. +Use of uninitialized value in numeric eq (==) at - line 4. ######## $x = sub {}; foo(); @@ -527,13 +545,12 @@ my $x = "foo"; EXPECT foo ######## -# [perl #3066] sub C () { 1 } -sub M { print "$_[0]\n" } +sub M { $_[0] = 2; } eval "C"; M(C); EXPECT -1 +Modification of a read-only value attempted at - line 2. ######## print qw(ab a\b a\\b); EXPECT @@ -563,11 +580,45 @@ EOT EXPECT ok ######## -# [ID 20001202.002] and change #8066 added 'at -e line 1'; -# reversed again as a result of [perl #17763] +# 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() { + 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 +######## die qr(x) EXPECT -(?^:x) +(?-xism:x) at - line 1. ######## # 20001210.003 mjd@plover.com format REMITOUT_TOP = @@ -615,9 +666,8 @@ new_pmop "abcdef"; reset; close STDERR; die; EXPECT ######## -# core dump in 20000716.007 -w -"x" =~ /(\G?x)?/; +"x" =~ /(\G?x)?/; # core dump in 20000716.007 ######## # Bug 20010515.004 my @h = 1 .. 10; @@ -636,6 +686,18 @@ OK EXPECT ok ######## +# Bug 20010422.005 +{s//${}/; //} +EXPECT +syntax error at - line 2, near "${}" +Execution of - aborted due to compilation errors. +######## +# Bug 20010528.007 +"\x{" +EXPECT +Missing right brace on \x{} at - line 2, within string +Execution of - aborted due to compilation errors. +######## my $foo = Bar->new(); my @dst; END { @@ -653,6 +715,26 @@ sub DESTROY { } EXPECT Bar=ARRAY(0x...) +######## +######## found by Markov chain stress testing +eval "a.b.c.d.e.f;sub" +EXPECT + +######## perlbug ID 20010831.001 +($a, b) = (1, 2); +EXPECT +Can't modify constant item in list assignment at - line 1, near ");" +Execution of - aborted due to compilation errors. +######## tying a bareword causes a segfault in 5.6.1 +tie FOO, "Foo"; +EXPECT +Can't modify constant item in tie at - line 1, near ""Foo";" +Execution of - aborted due to compilation errors. +######## undefing constant causes a segfault in 5.6.1 [ID 20010906.019] +undef foo; +EXPECT +Can't modify constant item in undef operator at - line 1, near "foo;" +Execution of - aborted due to compilation errors. ######## (?{...}) compilation bounces on PL_rs -0 { @@ -662,6 +744,11 @@ Bar=ARRAY(0x...) BEGIN { print "ok\n" } EXPECT ok +######## read($var, FILE, 1) segfaults on 5.6.1 [ID 20011025.054] +read($bla, FILE, 1); +EXPECT +Can't modify constant item in read at - line 1, near "1)" +Execution of - aborted due to compilation errors. ######## 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"; @@ -678,6 +765,36 @@ ok 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 ; + 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; @@ -727,125 +844,3 @@ 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" -# Newsgroups: comp.lang.perl.moderated -# Subject: Strange UTF error -# Date: Fri, 11 Oct 2002 16:19:58 -0400 -# Message-ID: -$_ = "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] strangeness with utf8 and warn -$_="foo";utf8::upgrade($_);/bar/i,warn$_; -EXPECT -foo at - line 1. -######## "#75146: 27e904532594b7fb (fix for #23810) introduces a #regression" -use strict; - -unshift @INC, sub { - my ($self, $fn) = @_; - - (my $pkg = $fn) =~ s{/}{::}g; - $pkg =~ s{.pm$}{}; - - if ($pkg eq 'Credit') { - my $code = <<'EOC'; -package Credit; - -use NonsenseAndBalderdash; - -1; -EOC - eval $code; - die "\$@ is $@"; - } - - #print STDERR "Generator: not one of mine, ignoring\n"; - return undef; -}; - -# create load-on-demand new() constructors -{ - package Credit; - sub new { - eval "use Credit"; - } -}; - -eval { - my $credit = new Credit; -}; - -print "If you get here, you didn't crash\n"; -EXPECT -If you get here, you didn't crash -######## [perl #112312] crash on syntax error -# SKIP: !defined &DynaLoader::boot_DynaLoader # miniperl -#!/usr/bin/perl -use strict; -use warnings; -sub meow (&); -my %h; -my $k; -meow { - my $t : need_this; - $t = { - size => $h{$k}{size}; - used => $h{$k}(used} - }; -}; -EXPECT -syntax error at - line 12, near "used" -syntax error at - line 12, near "used}" -Unmatched right curly bracket at - line 14, at end of line -Execution of - aborted due to compilation errors. -######## [perl #112312] crash on syntax error - another test -# SKIP: !defined &DynaLoader::boot_DynaLoader # miniperl -#!/usr/bin/perl -use strict; -use warnings; - -sub meow (&); - -my %h; -my $k; - -meow { - my $t : need_this; - $t = { - size => $h{$k}{size}; - used => $h{$k}(used} - }; -}; - -sub testo { - my $value = shift; - print; - print; - print; - 1; -} - -EXPECT -syntax error at - line 15, near "used" -syntax error at - line 15, near "used}" -Unmatched right curly bracket at - line 17, at end of line -Execution of - aborted due to compilation errors. diff --git a/gnu/usr.bin/perl/t/run/switches.t b/gnu/usr.bin/perl/t/run/switches.t index a2e4bad47c6..996ad5d4c64 100644 --- a/gnu/usr.bin/perl/t/run/switches.t +++ b/gnu/usr.bin/perl/t/run/switches.t @@ -1,22 +1,15 @@ #!./perl -w -# Tests for the command-line switches: -# -0, -c, -l, -s, -m, -M, -V, -v, -h, -i, -E and all unknown -# Some switches have their own tests, see MANIFEST. +# Tests for the command-line switches BEGIN { chdir 't' if -d 't'; @INC = '../lib'; - require Config; import Config; } -BEGIN { require "./test.pl"; } +require "./test.pl"; -plan(tests => 115); - -use Config; -use Errno qw(EACCES EISDIR); -BEGIN { eval 'use POSIX qw(setlocale LC_ALL)' } +plan(tests => 19); # 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 @@ -25,7 +18,7 @@ $TODO = "runperl() unable to emulate echo -n due to pipe bug" if $^O eq 'VMS'; my $r; my @tmpfiles = (); -END { unlink_all @tmpfiles } +END { unlink @tmpfiles } # Tests for -0 @@ -71,15 +64,9 @@ $r = runperl( ); 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 = tempfile(); +my $filename = 'swctest.tmp'; SKIP: { local $TODO = ''; # this one works on VMS @@ -108,28 +95,7 @@ SWTEST && $r !~ /\bblock 5\b/, '-c' ); -} - -SKIP: { - skip "no POSIX on miniperl", 1, unless $INC{"POSIX.pm"}; - skip 'No locale testing without d_setlocale', 1 if(!$Config{d_setlocale}); - - my $tempdir = tempfile; - mkdir $tempdir, 0700 or die "Can't mkdir '$tempdir': $!"; - - local $ENV{'LC_ALL'} = 'C'; # Keep the test simple: expect English - local $ENV{LANGUAGE} = 'C'; - setlocale(LC_ALL, "C"); - - # Win32 won't let us open the directory, so we never get to die with - # EISDIR, which happens after open. - my $error = do { local $! = $^O eq 'MSWin32' ? EACCES : EISDIR; "$!" }; - like( - runperl( switches => [ '-c' ], args => [ $tempdir ], stderr => 1), - qr/Can't open perl script.*$tempdir.*\Q$error/s, - "RT \#61362: Cannot syntax-check a directory" - ); - rmdir $tempdir or die "Can't rmdir '$tempdir': $!"; + push @tmpfiles, $filename; } # Tests for -l @@ -149,61 +115,47 @@ $r = runperl( ); is( $r, '21-', '-s switch parsing' ); -$filename = tempfile(); -SKIP: { - open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" ); - print $f <<'SWTEST'; -#!perl -s -BEGIN { print $x,$y; exit } -SWTEST - close $f or die "Could not close: $!"; - $r = runperl( - progfile => $filename, - args => [ '-x=foo -y' ], - ); - is( $r, 'foo1', '-s on the shebang line' ); -} - # Bug ID 20011106.084 -$filename = tempfile(); +$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 } +#!perl -s +print $x SWTEST close $f or die "Could not close: $!"; $r = runperl( + switches => [ '-s' ], progfile => $filename, args => [ '-x=foo' ], ); - is( $r, 'foo', '-sn on the shebang line' ); + is( $r, 'foo', '-s on the shebang line' ); + push @tmpfiles, $filename; } # Tests for -m and -M -my $package = tempfile(); -$filename = "$package.pm"; +$filename = 'swtest.pm'; SKIP: { open my $f, ">$filename" or skip( "Can't write temp file $filename: $!",4 ); - print $f <<"SWTESTPM"; -package $package; -sub import { print map "<\$_>", \@_ } + print $f <<'SWTESTPM'; +package swtest; +sub import { print map "<$_>", @_ } 1; SWTESTPM close $f or die "Could not close: $!"; $r = runperl( - switches => [ "-M$package" ], + switches => [ '-Mswtest' ], prog => '1', ); - is( $r, "<$package>", '-M' ); + is( $r, '', '-M' ); $r = runperl( - switches => [ "-M$package=foo" ], + switches => [ '-Mswtest=foo' ], prog => '1', ); - is( $r, "<$package>", '-M with import parameter' ); + is( $r, '', '-M with import parameter' ); $r = runperl( - switches => [ "-m$package" ], + switches => [ '-mswtest' ], prog => '1', ); @@ -212,48 +164,12 @@ SWTESTPM is( $r, '', '-m' ); } $r = runperl( - switches => [ "-m$package=foo,bar" ], + switches => [ '-mswtest=foo,bar' ], prog => '1', ); - is( $r, "<$package>", '-m with import parameters' ); + is( $r, '', '-m with import parameters' ); push @tmpfiles, $filename; - - { - local $TODO = ''; # these work on VMS - - is( runperl( switches => [ '-MTie::Hash' ], stderr => 1, prog => 1 ), - '', "-MFoo::Bar allowed" ); - - like( runperl( switches => [ "-M:$package" ], stderr => 1, - prog => 'die q{oops}' ), - qr/Invalid module name [\w:]+ with -M option\b/, - "-M:Foo not allowed" ); - - like( runperl( switches => [ '-mA:B:C' ], stderr => 1, - prog => 'die q{oops}' ), - qr/Invalid module name [\w:]+ with -m option\b/, - "-mFoo:Bar not allowed" ); - - like( runperl( switches => [ '-m-A:B:C' ], stderr => 1, - prog => 'die q{oops}' ), - qr/Invalid module name [\w:]+ with -m option\b/, - "-m-Foo:Bar not allowed" ); - - like( runperl( switches => [ '-m-' ], stderr => 1, - prog => 'die q{oops}' ), - qr/Module name required with -m option\b/, - "-m- not allowed" ); - - like( runperl( switches => [ '-M-=' ], stderr => 1, - prog => 'die q{oops}' ), - qr/Module name required with -M option\b/, - "-M- not allowed" ); - } # disable TODO on VMS } -is runperl(stderr => 1, prog => '#!perl -m'), - qq 'Too late for "-m" option at -e line 1.\n', '#!perl -m'; -is runperl(stderr => 1, prog => '#!perl -M'), - qq 'Too late for "-M" option at -e line 1.\n', '#!perl -M'; # Tests for -V @@ -261,14 +177,10 @@ is runperl(stderr => 1, prog => '#!perl -M'), 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 + # we don't test actual format 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'); @@ -288,158 +200,3 @@ is runperl(stderr => 1, prog => '#!perl -M'), # 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 - # there are definitely known build configs where this test will fail - # DG/UX comes to mind. Maybe we should remove these special cases? - my $v = sprintf "%vd", $^V; - my $ver = $Config{PERL_VERSION}; - my $rel = $Config{PERL_SUBVERSION}; - like( runperl( switches => ['-v'] ), - qr/This is perl 5, version \Q$ver\E, subversion \Q$rel\E \(v\Q$v\E(?:[-*\w]+| \([^)]+\))?\) built for \Q$Config{archname}\E.+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 switches which do not exist - -foreach my $switch (split //, "ABbGgHJjKkLNOoPQqRrYyZz123456789_") -{ - local $TODO = ''; # these ones should work on VMS - - like( runperl( switches => ["-$switch"], stderr => 1, - prog => 'die q{oops}' ), - qr/\QUnrecognized switch: -$switch (-h will show valid options)./, - "-$switch correctly unknown" ); - - # [perl #104288] - like( runperl( stderr => 1, prog => "#!perl -$switch" ), - qr/^Unrecognized switch: -$switch \(-h will show valid (?x: - )options\) at -e line 1\./, - "-$switch unrecognised on #! line" ); -} - -# Tests for unshebangable switches -for (qw( e f x E S V )) { - $r = runperl( - stderr => 1, - prog => "#!perl -$_", - ); - is $r, "Can't emulate -$_ on #! line at -e line 1.\n","-$_ on #! line"; -} - -# Tests for -i - -{ - local $TODO = ''; # these ones should work on VMS - - sub do_i_unlink { unlink_all("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 = ); - close FILE; - - open(BAK, "file.bak") or die "$0: Failed to open 'file': $!"; - chomp(my @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"); - - my $out1 = runperl( - switches => ['-i.bak -p'], - prog => 'exit', - stderr => 1, - stdin => "1\n", - ); - is( - $out1, - "-i used with no filenames on the command line, reading from STDIN.\n", - "warning when no files given" - ); - my $out2 = runperl( - switches => ['-i.bak -p'], - prog => 'exit', - stderr => 1, - stdin => "1\n", - args => ['file'], - ); - is($out2, "", "no warning when files given"); -} - -# Tests for -E - -$TODO = ''; # the -E tests work on VMS - -$r = runperl( - switches => [ '-E', '"say q(Hello, world!)"'] -); -is( $r, "Hello, world!\n", "-E say" ); - - -$r = runperl( - switches => [ '-E', '"no warnings q{experimental::smartmatch}; undef ~~ undef and say q(Hello, world!)"'] -); -is( $r, "Hello, world!\n", "-E ~~" ); - -$r = runperl( - switches => [ '-E', '"no warnings q{experimental::smartmatch}; given(undef) {when(undef) { say q(Hello, world!)"}}'] -); -is( $r, "Hello, world!\n", "-E given" ); - -$r = runperl( - switches => [ '-nE', q("} END { say q/affe/") ], - stdin => 'zomtek', -); -is( $r, "affe\n", '-E works outside of the block created by -n' ); - -$r = runperl( - switches => [ '-E', q("*{'bar'} = sub{}; print 'Hello, world!',qq|\n|;")] -); -is( $r, "Hello, world!\n", "-E does not enable strictures" ); - -# RT #30660 - -$filename = tempfile(); -SKIP: { - open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" ); - print $f <<'SWTEST'; -#!perl -w -iok -print "$^I\n"; -SWTEST - close $f or die "Could not close: $!"; - $r = runperl( - progfile => $filename, - ); - like( $r, qr/ok/, 'Spaces on the #! line (#30660)' ); -} diff --git a/gnu/usr.bin/perl/t/run/switcht.t b/gnu/usr.bin/perl/t/run/switcht.t index fd8188518f3..869605ff953 100644 --- a/gnu/usr.bin/perl/t/run/switcht.t +++ b/gnu/usr.bin/perl/t/run/switcht.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan tests => 13; +plan tests => 11; my $Perl = which_perl(); @@ -14,7 +14,7 @@ my $warning; local $SIG{__WARN__} = sub { $warning = join "\n", @_; }; my $Tmsg = 'while running with -t switch'; -is( ${^TAINT}, -1, '${^TAINT} == -1' ); +ok( ${^TAINT}, '${^TAINT} defined' ); my $out = `$Perl -le "print q(Hello)"`; is( $out, "Hello\n", '`` worked' ); @@ -29,9 +29,8 @@ like( $warning, qr/^Insecure .* $Tmsg/, ' taint warn' ); } # Get ourselves a tainted variable. -my $filename = tempfile(); $file = $0; -$file =~ s/.*/$filename/; +$file =~ s/.*/some.tmp/; ok( open(FILE, ">$file"), 'open >' ) or DIE $!; print FILE "Stuff\n"; close FILE; @@ -44,23 +43,3 @@ like( $warning, qr/^Insecure dependency in unlink $Tmsg/, ok( !-e $file, 'unlink worked' ); ok( !$^W, "-t doesn't enable regular warnings" ); - - -mkdir('ttdir'); -open(FH,'>','ttdir/ttest.pl')or DIE $!; -print FH 'return 42'; -close FH or DIE $!; - -SKIP: { - ($^O eq 'MSWin32') || skip('skip tainted do test with \ separator'); - my $test = 0; - $test = do '.\ttdir/ttest.pl'; - is($test, 42, 'Could "do" .\ttdir/ttest.pl'); -} -{ - my $test = 0; - $test = do './ttdir/ttest.pl'; - is($test, 42, 'Could "do" ./ttdir/ttest.pl'); -} -unlink ('./ttdir/ttest.pl'); -rmdir ('ttdir'); diff --git a/gnu/usr.bin/perl/t/test.pl b/gnu/usr.bin/perl/t/test.pl index 30db88ced0f..427a64f5786 100644 --- a/gnu/usr.bin/perl/t/test.pl +++ b/gnu/usr.bin/perl/t/test.pl @@ -1,212 +1,52 @@ # -# t/test.pl - most of Test::More functionality without the fuss, plus -# has mappings native_to_latin1 and latin1_to_native so that fewer tests -# on non ASCII-ish platforms need to be skipped - - -# NOTE: -# -# Increment ($x++) has a certain amount of cleverness for things like -# -# $x = 'zz'; -# $x++; # $x eq 'aaa'; -# -# stands more chance of breaking than just a simple -# -# $x = $x + 1 +# t/test.pl - most of Test::More functionality without the fuss # -# In this file, we use the latter "Baby Perl" approach, and increment -# will be worked over by t/op/inc.t -$Level = 1; my $test = 1; my $planned; -my $noplan; -my $Perl; # Safer version of $^X set by which_perl() - -# This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC -$::IS_ASCII = ord 'A' == 65; -$::IS_EBCDIC = ord 'A' == 193; $TODO = 0; $NO_ENDING = 0; -$Tests_Are_Passing = 1; - -# Use this instead of print to avoid interference while testing globals. -sub _print { - local($\, $", $,) = (undef, ' ', ''); - print STDOUT @_; -} - -sub _print_stderr { - local($\, $", $,) = (undef, ' ', ''); - print STDERR @_; -} sub plan { my $n; if (@_ == 1) { $n = shift; - if ($n eq 'no_plan') { - undef $n; - $noplan = 1; - } } else { my %plan = @_; - $n = $plan{tests}; + $n = $plan{tests}; } - _print "1..$n\n" unless $noplan; - $planned = $n; -} - - -# Set the plan at the end. See Test::More::done_testing. -sub done_testing { - my $n = $test - 1; - $n = shift if @_; - - _print "1..$n\n"; + print STDOUT "1..$n\n"; $planned = $n; } - END { my $ran = $test - 1; - if (!$NO_ENDING) { - if (defined $planned && $planned != $ran) { - _print_stderr - "# Looks like you planned $planned tests but ran $ran.\n"; - } elsif ($noplan) { - _print "1..$ran\n"; - } + if (!$NO_ENDING && defined $planned && $planned != $ran) { + print STDERR "# Looks like you planned $planned tests but ran $ran.\n"; } } -sub _diag { - return unless @_; - my @mess = _comment(@_); - $TODO ? _print(@mess) : _print_stderr(@mess); -} - -# Use this instead of "print STDERR" when outputting failure diagnostic +# Use this instead of "print STDERR" when outputing failure diagnostic # messages -sub diag { - _diag(@_); -} - -# Use this instead of "print" when outputting informational messages -sub note { +sub _diag { return unless @_; - _print( _comment(@_) ); -} + my @mess = map { /^#/ ? "$_\n" : "# $_\n" } + map { split /\n/ } @_; + my $fh = $TODO ? *STDOUT : *STDERR; + print $fh @mess; -sub is_miniperl { - return !defined &DynaLoader::boot_DynaLoader; -} - -sub _comment { - return map { /^#/ ? "$_\n" : "# $_\n" } - map { split /\n/ } @_; -} - -sub _have_dynamic_extension { - my $extension = shift; - unless (eval {require Config; 1}) { - warn "test.pl had problems loading Config: $@"; - return 1; - } - $extension =~ s!::!/!g; - return 1 if ($Config::Config{extensions} =~ /\b$extension\b/); } sub skip_all { if (@_) { - _print "1..0 # Skip @_\n"; + print STDOUT "1..0 # Skipped: @_\n"; } else { - _print "1..0\n"; + print STDOUT "1..0\n"; } exit(0); } -sub skip_all_if_miniperl { - skip_all(@_) if is_miniperl(); -} - -sub skip_all_without_dynamic_extension { - my ($extension) = @_; - skip_all("no dynamic loading on miniperl, no $extension") if is_miniperl(); - return if &_have_dynamic_extension; - skip_all("$extension was not built"); -} - -sub skip_all_without_perlio { - skip_all('no PerlIO') unless PerlIO::Layer->find('perlio'); -} - -sub skip_all_without_config { - unless (eval {require Config; 1}) { - warn "test.pl had problems loading Config: $@"; - return; - } - foreach (@_) { - next if $Config::Config{$_}; - my $key = $_; # Need to copy, before trying to modify. - $key =~ s/^use//; - $key =~ s/^d_//; - skip_all("no $key"); - } -} - -sub find_git_or_skip { - my ($source_dir, $reason); - if (-d '.git') { - $source_dir = '.'; - } elsif (-l 'MANIFEST' && -l 'AUTHORS') { - my $where = readlink 'MANIFEST'; - die "Can't readling MANIFEST: $!" unless defined $where; - die "Confusing symlink target for MANIFEST, '$where'" - unless $where =~ s!/MANIFEST\z!!; - if (-d "$where/.git") { - # Looks like we are in a symlink tree - if (exists $ENV{GIT_DIR}) { - diag("Found source tree at $where, but \$ENV{GIT_DIR} is $ENV{GIT_DIR}. Not changing it"); - } else { - note("Found source tree at $where, setting \$ENV{GIT_DIR}"); - $ENV{GIT_DIR} = "$where/.git"; - } - $source_dir = $where; - } - } elsif (exists $ENV{GIT_DIR}) { - my $commit = '8d063cd8450e59ea1c611a2f4f5a21059a2804f1'; - my $out = `git rev-parse --verify --quiet '$commit^{commit}'`; - chomp $out; - if($out eq $commit) { - $source_dir = '.' - } - } - if ($source_dir) { - my $version_string = `git --version`; - if (defined $version_string - && $version_string =~ /\Agit version (\d+\.\d+\.\d+)(.*)/) { - return $source_dir if eval "v$1 ge v1.5.0"; - # If you have earlier than 1.5.0 and it works, change this test - $reason = "in git checkout, but git version '$1$2' too old"; - } else { - $reason = "in git checkout, but cannot run git"; - } - } else { - $reason = 'not being run from a git checkout'; - } - skip_all($reason) if $_[0] && $_[0] eq 'all'; - skip($reason, @_); -} - -sub BAIL_OUT { - my ($reason) = @_; - _print("Bail out! $reason\n"); - exit 255; -} - sub _ok { my ($pass, $where, $name, @mess) = @_; # Do not try to microoptimize by factoring out the "not ". @@ -220,37 +60,28 @@ sub _ok { $out = $pass ? "ok $test" : "not ok $test"; } - if ($TODO) { - $out = $out . " # TODO $TODO"; - } else { - $Tests_Are_Passing = 0 unless $pass; - } + $out .= " # TODO $TODO" if $TODO; + print STDOUT "$out\n"; - _print "$out\n"; - - if ($pass) { - note @mess; # Ensure that the message is properly escaped. - } - else { - my $msg = "# Failed test $test - "; - $msg.= "$name " if $name; - $msg .= "$where\n"; - _diag $msg; - _diag @mess; + unless ($pass) { + _diag "# Failed $where\n"; } - $test = $test + 1; # don't use ++ + # Ensure that the message is properly escaped. + _diag @mess; + + $test++; return $pass; } sub _where { - my @caller = caller($Level); + my @caller = caller(1); return "at $caller[1] line $caller[2]"; } # DON'T use this for matches. Use like() instead. -sub ok ($@) { +sub ok { my ($pass, $name, @mess) = @_; _ok($pass, _where(), $name, @mess); } @@ -259,8 +90,8 @@ sub _q { my $x = shift; return 'undef' unless defined $x; my $q = $x; - $q =~ s/\\/\\\\/g; - $q =~ s/'/\\'/g; + $q =~ s/\\/\\\\/; + $q =~ s/'/\\'/; return "'$q'"; } @@ -283,24 +114,13 @@ sub display { my $y = ''; foreach my $c (unpack("U*", $x)) { if ($c > 255) { - $y = $y . sprintf "\\x{%x}", $c; + $y .= sprintf "\\x{%x}", $c; } elsif ($backslash_escape{$c}) { - $y = $y . $backslash_escape{$c}; + $y .= $backslash_escape{$c}; } else { my $z = chr $c; # Maybe we can get away with a literal... - if ($z =~ /[[:^print:]]/) { - - # Use octal for characters traditionally expressed as - # such: the low controls, which on EBCDIC aren't - # necessarily the same ones as on ASCII platforms, but - # are small ordinals, nonetheless - if ($c <= 037) { - $z = sprintf "\\%03o", $c; - } else { - $z = sprintf "\\x{%x}", $c; - } - } - $y = $y . $z; + $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/; + $y .= $z; } } $x = $y; @@ -311,45 +131,27 @@ sub display { return @result; } -sub is ($$@) { +sub is { my ($got, $expected, $name, @mess) = @_; - - my $pass; - if( !defined $got || !defined $expected ) { - # undef only matches undef - $pass = !defined $got && !defined $expected; - } - else { - $pass = $got eq $expected; - } - + my $pass = $got eq $expected; unless ($pass) { - unshift(@mess, "# got "._qq($got)."\n", - "# expected "._qq($expected)."\n"); + unshift(@mess, "# got "._q($got)."\n", + "# expected "._q($expected)."\n"); } _ok($pass, _where(), $name, @mess); } -sub isnt ($$@) { +sub isnt { my ($got, $isnt, $name, @mess) = @_; - - my $pass; - if( !defined $got || !defined $isnt ) { - # undef only matches undef - $pass = defined $got || defined $isnt; - } - else { - $pass = $got ne $isnt; - } - + my $pass = $got ne $isnt; unless( $pass ) { - unshift(@mess, "# it should not be "._qq($got)."\n", + unshift(@mess, "# it should not be "._q($got)."\n", "# but it is.\n"); } _ok($pass, _where(), $name, @mess); } -sub cmp_ok ($$$@) { +sub cmp_ok { my($got, $type, $expected, $name, @mess) = @_; my $pass; @@ -361,17 +163,17 @@ sub cmp_ok ($$$@) { } unless ($pass) { # It seems Irix long doubles can have 2147483648 and 2147483648 - # that stringify to the same thing but are actually numerically + # that stringify to the same thing but are acutally numerically # different. Display the numbers if $type isn't a string operator, # and the numbers are stringwise the same. # (all string operators have alphabetic names, so tr/a-z// is true) - # This will also show numbers for some unneeded cases, but will - # definitely be helpful for things such as == and <= that fail + # This will also show numbers for some uneeded cases, but will + # definately be helpful for things such as == and <= that fail if ($got eq $expected and $type !~ tr/a-z//) { unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; } - unshift(@mess, "# got "._qq($got)."\n", - "# expected $type "._qq($expected)."\n"); + unshift(@mess, "# got "._q($got)."\n", + "# expected $type "._q($expected)."\n"); } _ok($pass, _where(), $name, @mess); } @@ -382,7 +184,7 @@ sub cmp_ok ($$$@) { # otherwise $range is a fractional error. # Here $range must be numeric, >= 0 # Non numeric ranges might be a useful future extension. (eg %) -sub within ($$$@) { +sub within { my ($got, $expected, $range, $name, @mess) = @_; my $pass; if (!defined $got or !defined $expected or !defined $range) { @@ -407,28 +209,29 @@ sub within ($$$@) { if ($got eq $expected) { unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; } - unshift@mess, "# got "._qq($got)."\n", - "# expected "._qq($expected)." (within "._qq($range).")\n"; + unshift@mess, "# got "._q($got)."\n", + "# expected "._q($expected)." (within "._q($range).")\n"; } _ok($pass, _where(), $name, @mess); } # Note: this isn't quite as fancy as Test::More::like(). - -sub like ($$@) { like_yn (0,@_) }; # 0 for - -sub unlike ($$@) { like_yn (1,@_) }; # 1 for un- - -sub like_yn ($$$@) { - my ($flip, undef, $expected, $name, @mess) = @_; +sub like { + my ($got, $expected, $name, @mess) = @_; my $pass; - $pass = $_[1] =~ /$expected/ if !$flip; - $pass = $_[1] !~ /$expected/ if $flip; - unless ($pass) { - unshift(@mess, "# got '$_[1]'\n", - $flip - ? "# expected !~ /$expected/\n" : "# expected /$expected/\n"); + if (ref $expected eq 'Regexp') { + $pass = $got =~ $expected; + unless ($pass) { + unshift(@mess, "# got '$got'\n", + "# expected /$expected/\n"); + } + } else { + $pass = $got =~ /$expected/; + unless ($pass) { + unshift(@mess, "# got '$got'\n", + "# expected /$expected/\n"); + } } - local $Level = $Level + 1; _ok($pass, _where(), $name, @mess); } @@ -446,9 +249,7 @@ sub curr_test { } sub next_test { - my $retval = $test; - $test = $test + 1; # don't use ++ - $retval; + $test++; } # Note: can't pass multipart messages since we try to @@ -457,43 +258,17 @@ sub skip { my $why = shift; my $n = @_ ? shift : 1; for (1..$n) { - _print "ok $test # skip $why\n"; - $test = $test + 1; + print STDOUT "ok $test # skip: $why\n"; + $test++; } local $^W = 0; last SKIP; } -sub skip_if_miniperl { - skip(@_) if is_miniperl(); -} - -sub skip_without_dynamic_extension { - my ($extension) = @_; - skip("no dynamic loading on miniperl, no $extension") if is_miniperl(); - return if &_have_dynamic_extension; - skip("$extension was not built"); -} - -sub todo_skip { - my $why = shift; - my $n = @_ ? shift : 1; - - for (1..$n) { - _print "not ok $test # TODO & SKIP $why\n"; - $test = $test + 1; - } - local $^W = 0; - last TODO; -} - sub eq_array { my ($ra, $rb) = @_; return 0 unless $#$ra == $#$rb; for my $i (0..$#$ra) { - next if !defined $ra->[$i] && !defined $rb->[$i]; - return 0 if !defined $ra->[$i]; - return 0 if !defined $rb->[$i]; return 0 unless $ra->[$i] eq $rb->[$i]; } return 1; @@ -506,16 +281,13 @@ sub eq_hash { # Force a hash recompute if this perl's internals can cache the hash key. $key = "" . $key; if (exists $orig->{$key}) { - if ( - defined $orig->{$key} != defined $value - || (defined $value && $orig->{$key} ne $value) - ) { - _print "# key ", _qq($key), " was ", _qq($orig->{$key}), + if ($orig->{$key} ne $value) { + print STDOUT "# key ", _qq($key), " was ", _qq($orig->{$key}), " now ", _qq($value), "\n"; $fail = 1; } } else { - _print "# key ", _qq($key), " is ", _qq($value), + print STDOUT "# key ", _qq($key), " is ", _qq($value), ", not in original.\n"; $fail = 1; } @@ -524,55 +296,44 @@ sub eq_hash { # Force a hash recompute if this perl's internals can cache the hash key. $_ = "" . $_; next if (exists $suspect->{$_}); - _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; + print STDOUT "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; $fail = 1; } !$fail; } -# We only provide a subset of the Test::More functionality. -sub require_ok ($) { +sub require_ok { my ($require) = @_; - if ($require =~ tr/[A-Za-z0-9:.]//c) { - fail("Invalid character in \"$require\", passed to require_ok"); - } else { - eval < [ command-line switches ] # nolib => 1 # don't use -I../lib (included by default) -# non_portable => Don't warn if a one liner contains quotes # prog => one-liner (avoid quotes) # progs => [ multi-liner (avoid quotes) ] # progfile => perl script -# stdin => string to feed the stdin (or undef to redirect from /dev/null) -# stderr => If 'devnull' suppresses stderr, if other TRUE value redirect -# stderr to stdout +# stdin => string to feed the stdin +# stderr => redirect stderr to stdout # args => [ command-line arguments to the perl program ] # verbose => print the command line my $is_mswin = $^O eq 'MSWin32'; my $is_netware = $^O eq 'NetWare'; +my $is_macos = $^O eq 'MacOS'; my $is_vms = $^O eq 'VMS'; -my $is_cygwin = $^O eq 'cygwin'; sub _quote_args { my ($runperl, $args) = @_; @@ -581,65 +342,40 @@ sub _quote_args { # In VMS protect with doublequotes because otherwise # DCL will lowercase -- unless already doublequoted. $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0; - $runperl = $runperl . ' ' . $_; + $$runperl .= ' ' . $_; } - return $runperl; } -sub _create_runperl { # Create the string to qx in runperl(). +sub runperl { my %args = @_; - my $runperl = which_perl(); - if ($runperl =~ m/\s/) { - $runperl = qq{"$runperl"}; - } - #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind - if ($ENV{PERL_RUNPERL_DEBUG}) { - $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl"; - } + my $runperl = $^X; unless ($args{nolib}) { - $runperl = $runperl . ' "-I../lib"'; # doublequotes because of VMS + if ($is_macos) { + $runperl .= ' -I::lib'; + # Use UNIX style error messages instead of MPW style. + $runperl .= ' -MMac::err=unix' if $args{stderr}; + } + else { + $runperl .= ' "-I../lib"'; # doublequotes because of VMS + } } if ($args{switches}) { - local $Level = 2; - die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where() - unless ref $args{switches} eq "ARRAY"; - $runperl = _quote_args($runperl, $args{switches}); + _quote_args(\$runperl, $args{switches}); } if (defined $args{prog}) { - die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where() - if defined $args{progs}; $args{progs} = [$args{prog}] } if (defined $args{progs}) { - die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where() - unless ref $args{progs} eq "ARRAY"; foreach my $prog (@{$args{progs}}) { - if (!$args{non_portable}) { - if ($prog =~ tr/'"//) { - warn "quotes in prog >>$prog<< are not portable"; - } - if ($prog =~ /^([<>|]|2>)/) { - warn "Initial $1 in prog >>$prog<< is not portable"; - } - if ($prog =~ /&\z/) { - warn "Trailing & in prog >>$prog<< is not portable"; - } - } if ($is_mswin || $is_netware || $is_vms) { - $runperl = $runperl . qq ( -e "$prog" ); + $runperl .= qq ( -e "$prog" ); } else { - $runperl = $runperl . qq ( -e '$prog' ); + $runperl .= qq ( -e '$prog' ); } } } elsif (defined $args{progfile}) { - $runperl = $runperl . qq( "$args{progfile}"); - } else { - # You probably didn't want to be sucking in from the upstream stdin - die "test.pl:runperl(): none of prog, progs, progfile, args, " - . " switches or stdin specified" - unless defined $args{args} or defined $args{switches} - or defined $args{stdin}; + $runperl .= qq( "$args{progfile}"); } if (defined $args{stdin}) { # so we don't try to put literal newlines and crs onto the @@ -648,133 +384,76 @@ sub _create_runperl { # Create the string to qx in runperl(). $args{stdin} =~ s/\r/\\r/g; if ($is_mswin || $is_netware || $is_vms) { - $runperl = qq{$Perl -e "print qq(} . + $runperl = qq{$^X -e "print qq(} . $args{stdin} . q{)" | } . $runperl; } + elsif ($is_macos) { + # MacOS can only do two processes under MPW at once; + # the test itself is one; we can't do two more, so + # write to temp file + my $stdin = qq{$^X -e 'print qq(} . $args{stdin} . qq{)' > teststdin; }; + if ($args{verbose}) { + my $stdindisplay = $stdin; + $stdindisplay =~ s/\n/\n\#/g; + print STDERR "# $stdindisplay\n"; + } + `$stdin`; + $runperl .= q{ < teststdin }; + } else { - $runperl = qq{$Perl -e 'print qq(} . + $runperl = qq{$^X -e 'print qq(} . $args{stdin} . q{)' | } . $runperl; } - } elsif (exists $args{stdin}) { - # Using the pipe construction above can cause fun on systems which use - # ksh as /bin/sh, as ksh does pipes differently (with one less process) - # With sh, for the command line 'perl -e 'print qq()' | perl -e ...' - # the sh process forks two children, which use exec to start the two - # perl processes. The parent shell process persists for the duration of - # the pipeline, and the second perl process starts with no children. - # With ksh (and zsh), the shell saves a process by forking a child for - # just the first perl process, and execing itself to start the second. - # This means that the second perl process starts with one child which - # it didn't create. This causes "fun" when if the tests assume that - # wait (or waitpid) will only return information about processes - # started within the test. - # They also cause fun on VMS, where the pipe implementation returns - # the exit code of the process at the front of the pipeline, not the - # end. This messes up any test using OPTION FATAL. - # Hence it's useful to have a way to make STDIN be at eof without - # needing a pipeline, so that the fork tests have a sane environment - # without these surprises. - - # /dev/null appears to be surprisingly portable. - $runperl = $runperl . ($is_mswin ? ' nul' : ' 2>/dev/null'); - } - elsif ($args{stderr}) { - $runperl = $runperl . ' 2>&1'; + _quote_args(\$runperl, $args{args}); } + $runperl .= ' 2>&1' if $args{stderr} && !$is_macos; + $runperl .= " \xB3 Dev:Null" if !$args{stderr} && $is_macos; if ($args{verbose}) { my $runperldisplay = $runperl; $runperldisplay =~ s/\n/\n\#/g; - _print_stderr "# $runperldisplay\n"; + print STDERR "# $runperldisplay\n"; } - return $runperl; -} - -sub runperl { - die "test.pl:runperl() does not take a hashref" - if ref $_[0] and ref $_[0] eq 'HASH'; - my $runperl = &_create_runperl; - my $result; - - my $tainted = ${^TAINT}; - my %args = @_; - exists $args{switches} && grep m/^-T$/, @{$args{switches}} and $tainted = $tainted + 1; - - if ($tainted) { - # We will assume that if you're running under -T, you really mean to - # run a fresh perl, so we'll brute force launder everything for you - my $sep; - - if (! eval {require Config; 1}) { - warn "test.pl had problems loading Config: $@"; - $sep = ':'; - } else { - $sep = $Config::Config{path_sep}; - } - - my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV); - local @ENV{@keys} = (); - # Untaint, plus take out . and empty string: - local $ENV{'DCL$PATH'} = $1 if $is_vms && exists($ENV{'DCL$PATH'}) && ($ENV{'DCL$PATH'} =~ /(.*)/s); - $ENV{PATH} =~ /(.*)/s; - local $ENV{PATH} = - join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and - ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) } - split quotemeta ($sep), $1; - if ($is_cygwin) { # Must have /bin under Cygwin - if (length $ENV{PATH}) { - $ENV{PATH} = $ENV{PATH} . $sep; - } - $ENV{PATH} = $ENV{PATH} . '/bin'; - } - $runperl =~ /(.*)/s; - $runperl = $1; - - $result = `$runperl`; - } else { - $result = `$runperl`; - } - $result =~ s/\n\n/\n/g if $is_vms; # XXX pipes sometimes double these + my $result = `$runperl`; + $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these return $result; } -# Nice alias -*run_perl = *run_perl = \&runperl; # shut up "used only once" warning +*run_perl = \&runperl; # Nice alias. sub DIE { - _print_stderr "# @_\n"; + print STDERR "# @_\n"; exit 1; } # A somewhat safer version of the sometimes wrong $^X. +my $Perl; sub which_perl { unless (defined $Perl) { $Perl = $^X; - + # VMS should have 'perl' aliased properly - return $Perl if $is_vms; + return $Perl if $^O eq 'VMS'; my $exe; - if (! eval {require Config; 1}) { + eval "require Config; Config->import"; + if ($@) { warn "test.pl had problems loading Config: $@"; $exe = ''; } else { - $exe = $Config::Config{_exe}; + $exe = $Config{_exe}; } $exe = '' unless defined $exe; - + # This doesn't absolutize the path: beware of future chdirs(). # We could do File::Spec->abs2rel() but that does getcwd()s, # which is a bit heavyweight to do here. - + if ($Perl =~ /^perl\Q$exe\E$/i) { my $perl = "perl$exe"; - if (! eval {require File::Spec; 1}) { + eval "require File::Spec"; + if ($@) { warn "test.pl had problems loading File::Spec: $@"; $Perl = "./$perl"; } else { @@ -786,11 +465,11 @@ sub which_perl { # the command. if ($Perl !~ /\Q$exe\E$/i) { - $Perl = $Perl . $exe; + $Perl .= $exe; } warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; - + # For subcommands to use. $ENV{PERLEXE} = $Perl; } @@ -798,139 +477,59 @@ sub which_perl { } sub unlink_all { - my $count = 0; foreach my $file (@_) { 1 while unlink $file; - if( -f $file ){ - _print_stderr "# Couldn't unlink '$file': $!\n"; - }else{ - ++$count; - } + print STDERR "# Couldn't unlink '$file': $!\n" if -f $file; } - $count; } -# _num_to_alpha - Returns a string of letters representing a positive integer. -# Arguments : -# number to convert -# maximum number of letters - -# returns undef if the number is negative -# returns undef if the number of letters is greater than the maximum wanted - -# _num_to_alpha( 0) eq 'A'; -# _num_to_alpha( 1) eq 'B'; -# _num_to_alpha(25) eq 'Z'; -# _num_to_alpha(26) eq 'AA'; -# _num_to_alpha(27) eq 'AB'; - -my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z); - -# Avoid ++ -- ranges split negative numbers -sub _num_to_alpha{ - my($num,$max_char) = @_; - return unless $num >= 0; - my $alpha = ''; - my $char_count = 0; - $max_char = 0 if $max_char < 0; - - while( 1 ){ - $alpha = $letters[ $num % 26 ] . $alpha; - $num = int( $num / 26 ); - last if $num == 0; - $num = $num - 1; - - # char limit - next unless $max_char; - $char_count = $char_count + 1; - return if $char_count == $max_char; - } - return $alpha; -} -my %tmpfiles; -END { unlink_all keys %tmpfiles } - -# A regexp that matches the tempfile names -$::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?'; - -# Avoid ++, avoid ranges, avoid split // -my $tempfile_count = 0; -sub tempfile { - while(1){ - my $try = "tmp$$"; - my $alpha = _num_to_alpha($tempfile_count,2); - last unless defined $alpha; - $try = $try . $alpha; - $tempfile_count = $tempfile_count + 1; - - # Need to note all the file names we allocated, as a second request may - # come before the first is created. - if (!$tmpfiles{$try} && !-e $try) { - # We have a winner - $tmpfiles{$try} = 1; - return $try; - } - } - die "Can't find temporary file name starting \"tmp$$\""; -} +my $tmpfile = "misctmp000"; +1 while -f ++$tmpfile; +END { unlink_all $tmpfile } -# register_tempfile - Adds a list of files to be removed at the end of the current test file -# Arguments : -# a list of files to be removed later +# +# _fresh_perl +# +# The $resolve must be a subref that tests the first argument +# for success, or returns the definition of success (e.g. the +# expected scalar) if given no arguments. +# -# returns a count of how many file names were actually added +sub _fresh_perl { + my($prog, $resolve, $runperl_args, $name) = @_; -# Reuses %tmpfiles so that tempfile() will also skip any files added here -# even if the file doesn't exist yet. + $runperl_args ||= {}; + $runperl_args->{progfile} = $tmpfile; + $runperl_args->{stderr} = 1; -sub register_tempfile { - my $count = 0; - for( @_ ){ - if( $tmpfiles{$_} ){ - _print_stderr "# Temporary file '$_' already added\n"; - }else{ - $tmpfiles{$_} = 1; - $count = $count + 1; - } - } - return $count; -} + open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; -# This is the temporary file for _fresh_perl -my $tmpfile = tempfile(); + # VMS adjustments + if( $^O eq 'VMS' ) { + $prog =~ s#/dev/null#NL:#; -sub _fresh_perl { - my($prog, $action, $expect, $runperl_args, $name) = @_; - - # Given the choice of the mis-parsable {} - # (we want an anon hash, but a borked lexer might think that it's a block) - # or relying on taking a reference to a lexical - # (\ might be mis-parsed, and the reference counting on the pad may go - # awry) - # it feels like the least-worse thing is to assume that auto-vivification - # works. At least, this is only going to be a run-time failure, so won't - # affect tests using this file but not this function. - $runperl_args->{progfile} ||= $tmpfile; - $runperl_args->{stderr} = 1 unless exists $runperl_args->{stderr}; + # VMS file locking + $prog =~ s{if \(-e _ and -f _ and -r _\)} + {if (-e _ and -f _)} + } - open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; - print TEST $prog; + print TEST $prog, "\n"; close TEST or die "Cannot close $tmpfile: $!"; my $results = runperl(%$runperl_args); my $status = $?; # Clean up the results into something a bit more predictable. - $results =~ s/\n+$//; - $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; - $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; + $results =~ s/\n+$//; + $results =~ s/at\s+misctmp\d+\s+line/at - line/g; + $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g; # bison says 'parse error' instead of 'syntax error', # various yaccs may or may not capitalize 'syntax'. $results =~ s/^(syntax|parse) error/syntax error/mig; - if ($is_vms) { + if ($^O eq 'VMS') { # some tests will trigger VMS messages that won't be expected $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; @@ -938,771 +537,49 @@ sub _fresh_perl { $results =~ s/\n\n/\n/g; } - # Use the first line of the program as a name if none was given - unless( $name ) { - ($first_line, $name) = $prog =~ /^((.{1,50}).*)/; - $name = $name . '...' if length $first_line > length $name; - } - - # Historically this was implemented using a closure, but then that means - # that the tests for closures avoid using this code. Given that there - # are exactly two callers, doing exactly two things, the simpler approach - # feels like a better trade off. - my $pass; - if ($action eq 'eq') { - $pass = is($results, $expect, $name); - } elsif ($action eq '=~') { - $pass = like($results, $expect, $name); - } else { - die "_fresh_perl can't process action '$action'"; - } - + my $pass = $resolve->($results); unless ($pass) { _diag "# PROG: \n$prog\n"; + _diag "# EXPECTED:\n", $resolve->(), "\n"; + _diag "# GOT:\n$results\n"; _diag "# STATUS: $status\n"; } - return $pass; + # Use the first line of the program as a name if none was given + unless( $name ) { + ($first_line, $name) = $prog =~ /^((.{1,50}).*)/; + $name .= '...' if length $first_line > length $name; + } + + _ok($pass, _where(), "fresh_perl - $name"); } # -# fresh_perl_is +# run_perl_is # # Combination of run_perl() and is(). # sub fresh_perl_is { my($prog, $expected, $runperl_args, $name) = @_; - - # _fresh_perl() is going to clip the trailing newlines off the result. - # This will make it so the test author doesn't have to know that. - $expected =~ s/\n+$//; - - local $Level = 2; - _fresh_perl($prog, 'eq', $expected, $runperl_args, $name); + _fresh_perl($prog, + sub { @_ ? $_[0] eq $expected : $expected }, + $runperl_args, $name); } # -# fresh_perl_like +# run_perl_like # # Combination of run_perl() and like(). # sub fresh_perl_like { my($prog, $expected, $runperl_args, $name) = @_; - local $Level = 2; - _fresh_perl($prog, '=~', $expected, $runperl_args, $name); -} - -# Many tests use the same format in __DATA__ or external files to specify a -# sequence of (fresh) tests to run, extra files they may temporarily need, and -# what the expected output is. Putting it here allows common code to serve -# these multiple tests. -# -# Each program is source code to run followed by an "EXPECT" line, followed -# by the expected output. -# -# The code to run may begin with a command line switch such as -w or -0777 -# (alphanumerics only), and may contain (note the '# ' on each): -# # TODO reason for todo -# # SKIP reason for skip -# # SKIP ?code to test if this should be skipped -# # NAME name of the test (as with ok($ok, $name)) -# -# The expected output may contain: -# OPTION list of options -# OPTIONS list of options -# -# The possible options for OPTION may be: -# regex - the expected output is a regular expression -# random - all lines match but in any order -# fatal - the code will fail fatally (croak, die) -# -# If the actual output contains a line "SKIPPED" the test will be -# skipped. -# -# If the actual output contains a line "PREFIX", any output starting with that -# line will be ignored when comparing with the expected output -# -# If the global variable $FATAL is true then OPTION fatal is the -# default. - -sub _setup_one_file { - my $fh = shift; - # Store the filename as a program that started at line 0. - # Real files count lines starting at line 1. - my @these = (0, shift); - my ($lineno, $current); - while (<$fh>) { - if ($_ eq "########\n") { - if (defined $current) { - push @these, $lineno, $current; - } - undef $current; - } else { - if (!defined $current) { - $lineno = $.; - } - $current .= $_; - } - } - if (defined $current) { - push @these, $lineno, $current; - } - ((scalar @these) / 2 - 1, @these); -} - -sub setup_multiple_progs { - my ($tests, @prgs); - foreach my $file (@_) { - next if $file =~ /(?:~|\.orig|,v)$/; - next if $file =~ /perlio$/ && !PerlIO::Layer->find('perlio'); - next if -d $file; - - open my $fh, '<', $file or die "Cannot open $file: $!\n" ; - my $found; - while (<$fh>) { - if (/^__END__/) { - ++$found; - last; - } - } - # This is an internal error, and should never happen. All bar one of - # the files had an __END__ marker to signal the end of their preamble, - # although for some it wasn't technically necessary as they have no - # tests. It might be possible to process files without an __END__ by - # seeking back to the start and treating the whole file as tests, but - # it's simpler and more reliable just to make the rule that all files - # must have __END__ in. This should never fail - a file without an - # __END__ should not have been checked in, because the regression tests - # would not have passed. - die "Could not find '__END__' in $file" - unless $found; - - my ($t, @p) = _setup_one_file($fh, $file); - $tests += $t; - push @prgs, @p; - - close $fh - or die "Cannot close $file: $!\n"; - } - return ($tests, @prgs); -} - -sub run_multiple_progs { - my $up = shift; - my @prgs; - if ($up) { - # The tests in lib run in a temporary subdirectory of t, and always - # pass in a list of "programs" to run - @prgs = @_; - } else { - # The tests below t run in t and pass in a file handle. In theory we - # can pass (caller)[1] as the second argument to report errors with - # the filename of our caller, as the handle is always DATA. However, - # line numbers in DATA count from the __END__ token, so will be wrong. - # Which is more confusing than not providing line numbers. So, for now, - # don't provide line numbers. No obvious clean solution - one hack - # would be to seek DATA back to the start and read to the __END__ token, - # but that feels almost like we should just open $0 instead. - - # Not going to rely on undef in list assignment. - my $dummy; - ($dummy, @prgs) = _setup_one_file(shift); - } - - my $tmpfile = tempfile(); - - my ($file, $line); - PROGRAM: - while (defined ($line = shift @prgs)) { - $_ = shift @prgs; - unless ($line) { - $file = $_; - if (defined $file) { - print "# From $file\n"; - } - next; - } - my $switch = ""; - my @temps ; - my @temp_path; - if (s/^(\s*-\w+)//) { - $switch = $1; - } - my ($prog, $expected) = split(/\nEXPECT(?:\n|$)/, $_, 2); - - my %reason; - foreach my $what (qw(skip todo)) { - $prog =~ s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1; - # If the SKIP reason starts ? then it's taken as a code snippet to - # evaluate. This provides the flexibility to have conditional SKIPs - if ($reason{$what} && $reason{$what} =~ s/^\?//) { - my $temp = eval $reason{$what}; - if ($@) { - die "# In \U$what\E code reason:\n# $reason{$what}\n$@"; - } - $reason{$what} = $temp; - } - } - - my $name = ''; - if ($prog =~ s/^#\s*NAME\s+(.+)\n//m) { - $name = $1; - } - - if ($reason{skip}) { - SKIP: - { - skip($name ? "$name - $reason{skip}" : $reason{skip}, 1); - } - next PROGRAM; - } - - if ($prog =~ /--FILE--/) { - my @files = split(/\n?--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; - shift @files ; - die "Internal error: test $_ 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; - if ($filename =~ m#(.*)/# && $filename !~ m#^\.\./#) { - require File::Path; - File::Path::mkpath($1); - push(@temp_path, $1); - } - open my $fh, '>', $filename or die "Cannot open $filename: $!\n"; - print $fh $code; - close $fh or die "Cannot close $filename: $!\n"; - } - shift @files; - $prog = shift @files; - } - - open my $fh, '>', $tmpfile or die "Cannot open >$tmpfile: $!"; - print $fh q{ - BEGIN { - open STDERR, '>&', STDOUT - or die "Can't dup STDOUT->STDERR: $!;"; - } - }; - print $fh "\n#line 1\n"; # So the line numbers don't get messed up. - print $fh $prog,"\n"; - close $fh or die "Cannot close $tmpfile: $!"; - my $results = runperl( stderr => 1, progfile => $tmpfile, - stdin => undef, $up - ? (switches => ["-I$up/lib", $switch], nolib => 1) - : (switches => [$switch]) - ); - my $status = $?; - $results =~ s/\n+$//; - # allow expected output to be written as if $prog is on STDIN - $results =~ s/$::tempfile_regexp/-/g; - if ($^O eq 'VMS') { - # some tests will trigger VMS messages that won't be expected - $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; - - # pipes double these sometimes - $results =~ s/\n\n/\n/g; - } - # bison says 'parse error' instead of 'syntax error', - # various yaccs may or may not capitalize 'syntax'. - $results =~ s/^(syntax|parse) error/syntax error/mig; - # allow all tests to run when there are leaks - $results =~ s/Scalars leaked: \d+\n//g; - - $expected =~ s/\n+$//; - my $prefix = ($results =~ s#^PREFIX(\n|$)##) ; - # any special options? (OPTIONS foo bar zap) - my $option_regex = 0; - my $option_random = 0; - my $fatal = $FATAL; - if ($expected =~ s/^OPTIONS? (.+)\n//) { - foreach my $option (split(' ', $1)) { - if ($option eq 'regex') { # allow regular expressions - $option_regex = 1; - } - elsif ($option eq 'random') { # all lines match, but in any order - $option_random = 1; - } - elsif ($option eq 'fatal') { # perl should fail - $fatal = 1; - } - else { - die "$0: Unknown OPTION '$option'\n"; - } - } - } - die "$0: can't have OPTION regex and random\n" - if $option_regex + $option_random > 1; - my $ok = 0; - if ($results =~ s/^SKIPPED\n//) { - print "$results\n" ; - $ok = 1; - } - else { - if ($option_random) { - my @got = sort split "\n", $results; - my @expected = sort split "\n", $expected; - - $ok = "@got" eq "@expected"; - } - elsif ($option_regex) { - $ok = $results =~ /^$expected/; - } - elsif ($prefix) { - $ok = $results =~ /^\Q$expected/; - } - else { - $ok = $results eq $expected; - } - - if ($ok && $fatal && !($status >> 8)) { - $ok = 0; - } - } - - local $::TODO = $reason{todo}; - - unless ($ok) { - my $err_line = "PROG: $switch\n$prog\n" . - "EXPECTED:\n$expected\n"; - $err_line .= "EXIT STATUS: != 0\n" if $fatal; - $err_line .= "GOT:\n$results\n"; - $err_line .= "EXIT STATUS: " . ($status >> 8) . "\n" if $fatal; - if ($::TODO) { - $err_line =~ s/^/# /mg; - print $err_line; # Harness can't filter it out from STDERR. - } - else { - print STDERR $err_line; - } - } - - if (defined $file) { - _ok($ok, "at $file line $line", $name); - } else { - # We don't have file and line number data for the test, so report - # errors as coming from our caller. - local $Level = $Level + 1; - ok($ok, $name); - } - - foreach (@temps) { - unlink $_ if $_; - } - foreach (@temp_path) { - File::Path::rmtree $_ if -d $_; - } - } -} - -sub can_ok ($@) { - my($proto, @methods) = @_; - my $class = ref $proto || $proto; - - unless( @methods ) { - return _ok( 0, _where(), "$class->can(...)" ); - } - - my @nok = (); - foreach my $method (@methods) { - local($!, $@); # don't interfere with caller's $@ - # eval sometimes resets $! - eval { $proto->can($method) } || push @nok, $method; - } - - my $name; - $name = @methods == 1 ? "$class->can('$methods[0]')" - : "$class->can(...)"; - - _ok( !@nok, _where(), $name ); -} - - -# Call $class->new( @$args ); and run the result through object_ok. -# See Test::More::new_ok -sub new_ok { - my($class, $args, $obj_name) = @_; - $args ||= []; - $object_name = "The object" unless defined $obj_name; - - local $Level = $Level + 1; - - my $obj; - my $ok = eval { $obj = $class->new(@$args); 1 }; - my $error = $@; - - if($ok) { - object_ok($obj, $class, $object_name); - } - else { - ok( 0, "new() died" ); - diag("Error was: $@"); - } - - return $obj; - -} - - -sub isa_ok ($$;$) { - my($object, $class, $obj_name) = @_; - - my $diag; - $obj_name = 'The object' unless defined $obj_name; - my $name = "$obj_name isa $class"; - if( !defined $object ) { - $diag = "$obj_name isn't defined"; - } - else { - my $whatami = ref $object ? 'object' : 'class'; - - # We can't use UNIVERSAL::isa because we want to honor isa() overrides - local($@, $!); # eval sometimes resets $! - my $rslt = eval { $object->isa($class) }; - my $error = $@; # in case something else blows away $@ - - if( $error ) { - if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { - # It's an unblessed reference - $obj_name = 'The reference' unless defined $obj_name; - if( !UNIVERSAL::isa($object, $class) ) { - my $ref = ref $object; - $diag = "$obj_name isn't a '$class' it's a '$ref'"; - } - } - elsif( $error =~ /Can't call method "isa" without a package/ ) { - # It's something that can't even be a class - $obj_name = 'The thing' unless defined $obj_name; - $diag = "$obj_name isn't a class or reference"; - } - else { - die <isa on your object and got some weird error. -This should never happen. Please contact the author immediately. -Here's the error. -$@ -WHOA - } - } - elsif( !$rslt ) { - $obj_name = "The $whatami" unless defined $obj_name; - my $ref = ref $object; - $diag = "$obj_name isn't a '$class' it's a '$ref'"; - } - } - - _ok( !$diag, _where(), $name ); -} - - -sub class_ok { - my($class, $isa, $class_name) = @_; - - # Written so as to count as one test - local $Level = $Level + 1; - if( ref $class ) { - ok( 0, "$class is a refrence, not a class name" ); - } - else { - isa_ok($class, $isa, $class_name); - } -} - - -sub object_ok { - my($obj, $isa, $obj_name) = @_; - - local $Level = $Level + 1; - if( !ref $obj ) { - ok( 0, "$obj is not a reference" ); - } - else { - isa_ok($obj, $isa, $obj_name); - } -} - - -# Purposefully avoiding a closure. -sub __capture { - push @::__capture, join "", @_; -} - -sub capture_warnings { - my $code = shift; - - local @::__capture; - local $SIG {__WARN__} = \&__capture; - &$code; - return @::__capture; -} - -# This will generate a variable number of tests. -# Use done_testing() instead of a fixed plan. -sub warnings_like { - my ($code, $expect, $name) = @_; - local $Level = $Level + 1; - - my @w = capture_warnings($code); - - cmp_ok(scalar @w, '==', scalar @$expect, $name); - foreach my $e (@$expect) { - if (ref $e) { - like(shift @w, $e, $name); - } else { - is(shift @w, $e, $name); - } - } - if (@w) { - diag("Saw these additional warnings:"); - diag($_) foreach @w; - } -} - -sub _fail_excess_warnings { - my($expect, $got, $name) = @_; - local $Level = $Level + 1; - # This will fail, and produce diagnostics - is($expect, scalar @$got, $name); - diag("Saw these warnings:"); - diag($_) foreach @$got; -} - -sub warning_is { - my ($code, $expect, $name) = @_; - die sprintf "Expect must be a string or undef, not a %s reference", ref $expect - if ref $expect; - local $Level = $Level + 1; - my @w = capture_warnings($code); - if (@w > 1) { - _fail_excess_warnings(0 + defined $expect, \@w, $name); - } else { - is($w[0], $expect, $name); - } -} - -sub warning_like { - my ($code, $expect, $name) = @_; - die sprintf "Expect must be a regexp object" - unless ref $expect eq 'Regexp'; - local $Level = $Level + 1; - my @w = capture_warnings($code); - if (@w > 1) { - _fail_excess_warnings(0 + defined $expect, \@w, $name); - } else { - like($w[0], $expect, $name); - } -} - -# Set a watchdog to timeout the entire test file -# NOTE: If the test file uses 'threads', then call the watchdog() function -# _AFTER_ the 'threads' module is loaded. -sub watchdog ($;$) -{ - my $timeout = shift; - my $method = shift || ""; - my $timeout_msg = 'Test process timed out - terminating'; - - # Valgrind slows perl way down so give it more time before dying. - $timeout *= 10 if $ENV{PERL_VALGRIND}; - - my $pid_to_kill = $$; # PID for this process - - if ($method eq "alarm") { - goto WATCHDOG_VIA_ALARM; - } - - # shut up use only once warning - my $threads_on = $threads::threads && $threads::threads; - - # Don't use a watchdog process if 'threads' is loaded - - # use a watchdog thread instead - if (!$threads_on || $method eq "process") { - - # On Windows and VMS, try launching a watchdog process - # using system(1, ...) (see perlport.pod) - if ($is_mswin || $is_vms) { - # On Windows, try to get the 'real' PID - if ($is_mswin) { - eval { require Win32; }; - if (defined(&Win32::GetCurrentProcessId)) { - $pid_to_kill = Win32::GetCurrentProcessId(); - } - } - - # If we still have a fake PID, we can't use this method at all - return if ($pid_to_kill <= 0); - - # Launch watchdog process - my $watchdog; - eval { - local $SIG{'__WARN__'} = sub { - _diag("Watchdog warning: $_[0]"); - }; - my $sig = $is_vms ? 'TERM' : 'KILL'; - my $cmd = _create_runperl( prog => "sleep($timeout);" . - "warn qq/# $timeout_msg" . '\n/;' . - "kill($sig, $pid_to_kill);"); - $watchdog = system(1, $cmd); - }; - if ($@ || ($watchdog <= 0)) { - _diag('Failed to start watchdog'); - _diag($@) if $@; - undef($watchdog); - return; - } - - # Add END block to parent to terminate and - # clean up watchdog process - # Win32 watchdog is launched by cmd.exe shell, so use process group - # kill, otherwise the watchdog is never killed and harness waits - # every time for the timeout, #121395 - eval( $is_mswin ? - "END { local \$! = 0; local \$? = 0; - wait() if kill('-KILL', $watchdog); };" - : "END { local \$! = 0; local \$? = 0; - wait() if kill('KILL', $watchdog); };"); - return; - } - - # Try using fork() to generate a watchdog process - my $watchdog; - eval { $watchdog = fork() }; - if (defined($watchdog)) { - if ($watchdog) { # Parent process - # Add END block to parent to terminate and - # clean up watchdog process - eval "END { local \$! = 0; local \$? = 0; - wait() if kill('KILL', $watchdog); };"; - return; - } - - ### Watchdog process code - - # Load POSIX if available - eval { require POSIX; }; - - # Execute the timeout - sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073 - sleep(2); - - # Kill test process if still running - if (kill(0, $pid_to_kill)) { - _diag($timeout_msg); - kill('KILL', $pid_to_kill); - if ($is_cygwin) { - # sometimes the above isn't enough on cygwin - sleep 1; # wait a little, it might have worked after all - system("/bin/kill -f $pid_to_kill"); - } - } - - # Don't execute END block (added at beginning of this file) - $NO_ENDING = 1; - - # Terminate ourself (i.e., the watchdog) - POSIX::_exit(1) if (defined(&POSIX::_exit)); - exit(1); - } - - # fork() failed - fall through and try using a thread - } - - # Use a watchdog thread because either 'threads' is loaded, - # or fork() failed - if (eval {require threads; 1}) { - 'threads'->create(sub { - # Load POSIX if available - eval { require POSIX; }; - - # Execute the timeout - my $time_left = $timeout; - do { - $time_left = $time_left - sleep($time_left); - } while ($time_left > 0); - - # Kill the parent (and ourself) - select(STDERR); $| = 1; - _diag($timeout_msg); - POSIX::_exit(1) if (defined(&POSIX::_exit)); - my $sig = $is_vms ? 'TERM' : 'KILL'; - kill($sig, $pid_to_kill); - })->detach(); - return; - } - - # If everything above fails, then just use an alarm timeout -WATCHDOG_VIA_ALARM: - if (eval { alarm($timeout); 1; }) { - # Load POSIX if available - eval { require POSIX; }; - - # Alarm handler will do the actual 'killing' - $SIG{'ALRM'} = sub { - select(STDERR); $| = 1; - _diag($timeout_msg); - POSIX::_exit(1) if (defined(&POSIX::_exit)); - my $sig = $is_vms ? 'TERM' : 'KILL'; - kill($sig, $pid_to_kill); - }; - } -} - -# The following 2 functions allow tests to work on both EBCDIC and -# ASCII-ish platforms. They convert string scalars between the native -# character set and the set of 256 characters which is usually called -# Latin1. - -sub native_to_latin1($) { - my $string = shift; - - return $string if ord('^') == 94; # ASCII, Latin1 - my $output = ""; - for my $i (0 .. length($string) - 1) { - $output .= chr(ord_native_to_latin1(ord(substr($string, $i, 1)))); - } - # Preserve utf8ness of input onto the output, even if it didn't need to be - # utf8 - utf8::upgrade($output) if utf8::is_utf8($string); - - return $output; -} - -sub latin1_to_native($) { - my $string = shift; - - return $string if ord('^') == 94; # ASCII, Latin1 - my $output = ""; - for my $i (0 .. length($string) - 1) { - $output .= chr(ord_latin1_to_native(ord(substr($string, $i, 1)))); - } - # Preserve utf8ness of input onto the output, even if it didn't need to be - # utf8 - utf8::upgrade($output) if utf8::is_utf8($string); - - return $output; -} - -sub ord_latin1_to_native { - # given an input code point, return the platform's native - # equivalent value. Anything above latin1 is itself. - - my $ord = shift; - return $ord if ord('^') == 94; # ASCII, Latin1 - return utf8::unicode_to_native($ord); -} - -sub ord_native_to_latin1 { - # given an input platform code point, return the latin1 equivalent value. - # Anything above latin1 is itself. - - my $ord = shift; - return $ord if ord('^') == 94; # ASCII, Latin1 - return utf8::native_to_unicode($ord); + _fresh_perl($prog, + sub { @_ ? + $_[0] =~ (ref $expected ? $expected : /$expected/) : + $expected }, + $runperl_args, $name); } 1; diff --git a/gnu/usr.bin/perl/t/uni/case.pl b/gnu/usr.bin/perl/t/uni/case.pl index 08df6706db9..b6df5a8089b 100644 --- a/gnu/usr.bin/perl/t/uni/case.pl +++ b/gnu/usr.bin/perl/t/uni/case.pl @@ -1,70 +1,40 @@ +use File::Spec; + require "test.pl"; -use strict; -use warnings; sub unidump { join " ", map { sprintf "%04X", $_ } unpack "U*", $_[0]; } sub casetest { - my ($already_run, $base, @funcs) = @_; - - my %spec; - - # For each provided function run it, and run a version with some extra - # characters afterwards. Use a recycling symbol, as it doesn't change case. - # $already_run is the number of extra tests the caller has run before this - # call. - my $ballast = chr (0x2672) x 3; - @funcs = map {my $f = $_; - ($f, - sub {my $r = $f->($_[0] . $ballast); # Add it before - $r =~ s/$ballast\z//so # Remove it afterwards - or die "'$_[0]' to '$r' mangled"; - $r; # Result with $ballast removed. - }, - )} @funcs; - - use Unicode::UCD 'prop_invmap'; - - # Get the case mappings - my ($invlist_ref, $invmap_ref, undef, $default) = prop_invmap($base); + my ($base, $spec, $func) = @_; + my $file = File::Spec->catfile(File::Spec->catdir(File::Spec->updir, + "lib", "unicore", "To"), + "$base.pl"); + my $simple = do $file; my %simple; - - for my $i (0 .. @$invlist_ref - 1 - 1) { - next if $invmap_ref->[$i] == $default; - - # Add simple mappings to the simples test list - if (! ref $invmap_ref->[$i]) { - - # The returned map needs to have adjustments made. Each - # subsequent element of the range requires adjustment of +1 from - # the previous element - my $adjust = 0; - for my $k ($invlist_ref->[$i] .. $invlist_ref->[$i+1] - 1) { - $simple{$k} = $invmap_ref->[$i] + $adjust++; - } - } - else { # The return is a list of the characters mapped-to. - # prop_invmap() guarantees a single element in the range in - # this case, so no adjustments are needed. - $spec{$invlist_ref->[$i]} = pack "U0U*" , @{$invmap_ref->[$i]}; - } + for my $i (split(/\n/, $simple)) { + my ($k, $v) = split(' ', $i); + $simple{$k} = $v; } - my %seen; for my $i (sort keys %simple) { - $seen{$i}++; + $seen{hex $i}++; } print "# ", scalar keys %simple, " simple mappings\n"; - for my $i (sort keys %spec) { - if (++$seen{$i} == 2) { - warn sprintf "$base: $i seen twice\n"; + my $both; + + for my $i (sort keys %$spec) { + if (++$seen{hex $i} == 2) { + warn "$base: $i seen twice\n"; + $both++; } } - print "# ", scalar keys %spec, " special mappings\n"; + print "# ", scalar keys %$spec, " special mappings\n"; + + exit(1) if $both; my %none; for my $i (map { ord } split //, @@ -75,45 +45,90 @@ sub casetest { print "# ", scalar keys %none, " noncase mappings\n"; my $tests = - $already_run + - ((scalar keys %simple) + - (scalar keys %spec) + - (scalar keys %none)) * @funcs; + (scalar keys %simple) + + (scalar keys %$spec) + + (scalar keys %none); + print "1..$tests\n"; - my $test = $already_run + 1; + my $test = 1; - for my $i (sort keys %simple) { + for my $i (sort { hex $a <=> hex $b } keys %simple) { my $w = $simple{$i}; - my $c = pack "U0U", $i; - foreach my $func (@funcs) { - my $d = $func->($c); - my $e = unidump($d); - is( $d, pack("U0U", $simple{$i}), "$i -> $e ($w)" ); - } + my $c = pack "U0U", hex $i; + my $d = $func->($c); + my $e = unidump($d); + print $d eq pack("U0U", hex $simple{$i}) ? + "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n"; + $test++; } - for my $i (sort keys %spec) { - my $w = unidump($spec{$i}); - my $h = sprintf "%04X", $i; - my $c = chr($i); $c .= chr(0x100); chop $c; - foreach my $func (@funcs) { - my $d = $func->($c); - my $e = unidump($d); - is( $w, $e, "$h -> $e ($w)" ); + for my $i (sort { hex $a <=> hex $b } keys %$spec) { + my $w = unidump($spec->{$i}); + my $c = pack "U0U", hex $i; + my $d = $func->($c); + my $e = unidump($d); + if (ord "A" == 193) { # EBCDIC + # We need to a little bit of remapping. + # + # For example, in titlecase (ucfirst) mapping + # of U+0149 the Unicode mapping is U+02BC U+004E. + # The 4E is N, which in EBCDIC is 2B-- + # and the ucfirst() does that right. + # The problem is that our reference + # data is in Unicode code points. + # + # The Right Way here would be to use, say, + # Encode, to remap the less-than 0x100 code points, + # but let's try to be Encode-independent here. + # + # These are the titlecase exceptions: + # + # Unicode Unicode+EBCDIC + # + # 0149 -> 02BC 004E (02BC 002B) + # 01F0 -> 004A 030C (00A2 030C) + # 1E96 -> 0048 0331 (00E7 0331) + # 1E97 -> 0054 0308 (00E8 0308) + # 1E98 -> 0057 030A (00EF 030A) + # 1E99 -> 0059 030A (00DF 030A) + # 1E9A -> 0041 02BE (00A0 02BE) + # + # The uppercase exceptions are identical. + # + # The lowercase has one more: + # + # Unicode Unicode+EBCDIC + # + # 0130 -> 0069 0307 (00D1 0307) + # + if ($i =~ /^(0130|0149|01F0|1E96|1E97|1E98|1E99|1E9A)$/) { + $e =~ s/004E/002B/; # N + $e =~ s/004A/00A2/; # J + $e =~ s/0048/00E7/; # H + $e =~ s/0054/00E8/; # T + $e =~ s/0057/00EF/; # W + $e =~ s/0059/00DF/; # Y + $e =~ s/0041/00A0/; # A + $e =~ s/0069/00D1/; # i + } + # We have to map the output, not the input, because + # pack/unpack U has been EBCDICified, too, it would + # just undo our remapping. } + print $w eq $e ? + "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n"; + $test++; } for my $i (sort { $a <=> $b } keys %none) { - my $c = pack "U0U", $i; my $w = $i = sprintf "%04X", $i; - foreach my $func (@funcs) { - my $d = $func->($c); - my $e = unidump($d); - is( $d, $c, "$i -> $e ($w)" ); - } + my $c = pack "U0U", hex $i; + my $d = $func->($c); + my $e = unidump($d); + print $d eq $c ? + "ok $test # $i -> $w\n" : "not ok $test # $i -> $e ($w)\n"; + $test++; } - - done_testing(); } 1; diff --git a/gnu/usr.bin/perl/t/uni/lower.t b/gnu/usr.bin/perl/t/uni/lower.t index 5b706af0d84..4420d0b165d 100644 --- a/gnu/usr.bin/perl/t/uni/lower.t +++ b/gnu/usr.bin/perl/t/uni/lower.t @@ -4,7 +4,5 @@ BEGIN { require "case.pl"; } -casetest(0, # No extra tests run here, - "Lowercase_Mapping", - sub { lc $_[0] }, sub { my $a = ""; lc ($_[0] . $a) }, - sub { lcfirst $_[0] }, sub { my $a = ""; lcfirst ($_[0] . $a) }); +casetest("Lower", \%utf8::ToSpecLower, sub { lc $_[0] }); + diff --git a/gnu/usr.bin/perl/t/uni/sprintf.t b/gnu/usr.bin/perl/t/uni/sprintf.t index 08626498e2c..3c5f574b62c 100644 --- a/gnu/usr.bin/perl/t/uni/sprintf.t +++ b/gnu/usr.bin/perl/t/uni/sprintf.t @@ -6,7 +6,7 @@ BEGIN { require "test.pl"; } -plan tests => 52; +plan tests => 25; $a = "B\x{fc}f"; $b = "G\x{100}r"; @@ -137,19 +137,3 @@ $c = 0x200; $sprintf = sprintf "%s%s", $w, "$w\x{100}"; is(substr($sprintf,0,2), $w, "utf8 echo echo"); } - -my @values =(chr 110, chr 255, chr 256); - -foreach my $prefix (@values) { - foreach my $vector (map {$_ . $_} @values) { - - my $format = "$prefix%*vd"; - - foreach my $dot (@values) { - my $result = sprintf $format, $dot, $vector; - is (length $result, 8) - or print "# ", join (',', map {ord $_} $prefix, $dot, $vector), - "\n"; - } - } -} diff --git a/gnu/usr.bin/perl/t/uni/title.t b/gnu/usr.bin/perl/t/uni/title.t index 2d6dcb77ef3..c0b7e3a0163 100644 --- a/gnu/usr.bin/perl/t/uni/title.t +++ b/gnu/usr.bin/perl/t/uni/title.t @@ -4,6 +4,5 @@ BEGIN { require "case.pl"; } -casetest(0, # No extra tests run here, - "Titlecase_Mapping", sub { ucfirst $_[0] }, - sub { my $a = ""; ucfirst ($_[0] . $a) }); +casetest("Title", \%utf8::ToSpecTitle, sub { ucfirst $_[0] }); + diff --git a/gnu/usr.bin/perl/t/uni/upper.t b/gnu/usr.bin/perl/t/uni/upper.t index 315680c11b6..5694c26f222 100644 --- a/gnu/usr.bin/perl/t/uni/upper.t +++ b/gnu/usr.bin/perl/t/uni/upper.t @@ -4,9 +4,5 @@ BEGIN { require "case.pl"; } -is(uc("\x{3B1}\x{345}\x{301}"), "\x{391}\x{301}\x{399}", 'Verify moves YPOGEGRAMMENI'); +casetest("Upper", \%utf8::ToSpecUpper, sub { uc $_[0] }); -casetest( 1, # extra tests already run - "Uppercase_Mapping", - sub { uc $_[0] }, - sub { my $a = ""; uc ($_[0] . $a) }); diff --git a/gnu/usr.bin/perl/t/win32/system.t b/gnu/usr.bin/perl/t/win32/system.t index a6a94cb51ae..b1906ce73ab 100644 --- a/gnu/usr.bin/perl/t/win32/system.t +++ b/gnu/usr.bin/perl/t/win32/system.t @@ -2,17 +2,12 @@ BEGIN { chdir 't' if -d 't'; - # We need '../../lib' as well as '../lib' because parts of Config are - # delay-loaded, after we've chdir()'ed into $testdir. - @INC = ('../lib', '../../lib'); + @INC = '../lib'; # XXX this could be further munged to enable some parts on other # platforms - require './test.pl'; -} - -BEGIN { unless ($^O =~ /^MSWin/) { - skip_all 'windows specific test'; + print "1..0 # skipped: windows specific test\n"; + exit 0; } } @@ -37,10 +32,28 @@ open(my $F, ">$testdir/$exename.c") or die "Can't create $testdir/$exename.c: $!"; print $F <<'EOT'; #include +#ifdef __BORLANDC__ +#include +#endif int main(int ac, char **av) { int i; +#ifdef __BORLANDC__ + char *s = GetCommandLine(); + int j=0; + av[0] = s; + if (s[0]=='"') { + for(;s[++j]!='"';) + ; + av[0]++; + } + else { + for(;s[++j]!=' ';) + ; + } + s[j]=0; +#endif for (i = 0; i < ac; i++) printf("[%s]", av[i]); printf("\n"); @@ -84,7 +97,7 @@ END { chdir($cwd) && rmtree("$cwd/$testdir") if -d "$cwd/$testdir"; } if (open(my $EIN, "$cwd/win32/${exename}_exe.uu")) { - note "Unpacking $exename.exe"; + print "# Unpacking $exename.exe\n"; my $e; { local $/; @@ -98,22 +111,22 @@ if (open(my $EIN, "$cwd/win32/${exename}_exe.uu")) { } else { my $minus_o = ''; - if ($Config{cc} =~ /\bgcc/i) + if ($Config{cc} eq 'gcc') { $minus_o = "-o $exename.exe"; } - note "Compiling $exename.c"; - note "$Config{cc} $Config{ccflags} $exename.c"; + print "# Compiling $exename.c\n# $Config{cc} $Config{ccflags} $exename.c\n"; if (system("$Config{cc} $Config{ccflags} $minus_o $exename.c >log 2>&1") != 0) { - note "Could not compile $exename.c, status $?"; - note "Where is your C compiler?"; - skip_all "can't build test executable"; + print "# Could not compile $exename.c, status $?\n" + ."# Where is your C compiler?\n" + ."1..0 # skipped: can't build test executable\n"; + exit(0); } unless (-f "$exename.exe") { if (open(LOG,') { - note $_; + print "# ",$_; } } else { @@ -124,18 +137,20 @@ else { copy("$plxname.bat","$plxname.cmd"); chdir($cwd); unless (-x "$testdir/$exename.exe") { - note "Could not build $exename.exe"; - skip_all "can't build test executable"; + print "# Could not build $exename.exe\n" + ."1..0 # skipped: can't build test executable\n"; + exit(0); } open my $T, "$^X -I../lib -w win32/system_tests |" or die "Can't spawn win32/system_tests: $!"; my $expect; my $comment = ""; +my $test = 0; while (<$T>) { chomp; - if (s/^1\.\.//) { - plan $_; + if (/^1\.\./) { + print "$_\n"; } elsif (/^#+\s(.*)$/) { $comment = $1; @@ -147,11 +162,13 @@ while (<$T>) { } else { if ($expect ne $_) { - note $comment if $comment; - note "want: $expect"; - note "got : $_"; + print "# $comment\n" if $comment; + print "# want: $expect\n"; + print "# got : $_\n"; + print "not "; } - ok($expect eq $_); + ++$test; + print "ok $test\n"; } } close $T; diff --git a/gnu/usr.bin/perl/t/win32/system_tests b/gnu/usr.bin/perl/t/win32/system_tests index e2445ed3a7a..f73745ae8fc 100644 --- a/gnu/usr.bin/perl/t/win32/system_tests +++ b/gnu/usr.bin/perl/t/win32/system_tests @@ -3,9 +3,6 @@ use Config; use Cwd; use strict; -BEGIN { - require './test.pl'; -} $| = 1; @@ -93,7 +90,7 @@ for my $cmds (@commands) { my @all_args; my @cmds = defined($cmds) ? (ref($cmds) ? @$cmds : $cmds) : (); my @args = defined($args) ? (ref($args) ? @$args : $args) : (); - note "####### [@cmds]"; + print "######## [@cmds]\n"; print "<", join('><', $cmds[$#cmds], map { my $x = $_; $x =~ s/"//g; $x } @args), @@ -109,7 +106,7 @@ for my $cmds (@commands) { $^D = 0; my $cmdstr = join " ", map { /\s|^$/ && !/\"/ ? qq["$_"] : $_ } @cmds, @args; - note "####### '$cmdstr'"; + print "######## '$cmdstr'\n"; if (system($cmdstr) != 0) { print "Failed, status($?)\n"; if ($Config{ccflags} =~ /\bDDEBUGGING\b/) { diff --git a/gnu/usr.bin/perl/t/x2p/s2p.t b/gnu/usr.bin/perl/t/x2p/s2p.t index 0a0716da0c2..39c6cd80557 100644 --- a/gnu/usr.bin/perl/t/x2p/s2p.t +++ b/gnu/usr.bin/perl/t/x2p/s2p.t @@ -36,6 +36,7 @@ BEGIN { @INC = ( '../lib' ); } +### use Test::More; use File::Copy; use File::Spec; require './test.pl'; @@ -582,7 +583,7 @@ line 8 ### s ### 's' => { script => <<'[TheEnd]', -# enclose any '(a)'.. '(c)' in '-' +# enclose any `(a)'.. `(c)' in `-' s/([a-z])/-\1-/g s/\([abc]\)/-\1-/g @@ -627,19 +628,6 @@ s/a\{3\}/a rep 3/ [TheEnd] }, -### s2 ### RT #115156 -'s2' => { - todo => 'RT #115156', - script => 's/1*$/x/g', - input => 'bins', - expect => <<'[TheEnd]', -0x -x -1000x -1000x -[TheEnd] -}, - ### t ### 't' => { script => join( "\n", @@ -802,15 +790,7 @@ my $plsed = "s2pt$$.pl"; my $s2p = File::Spec->catfile( File::Spec->updir(), 'x2p', 's2p' ); my $psed = File::Spec->catfile( File::Spec->curdir(), 'psed' ); if ($^O eq 'VMS') { - # default in the .com extension if it's not already there - $s2p = VMS::Filespec::vmsify($s2p); - $psed = VMS::Filespec::vmsify($psed); - # Converting file specs from Unix format to VMS with the extended - # character set active can result in a trailing '.' added for null - # extensions. This must be removed if the intent is to default the - # extension. - $s2p =~ s/\.$//; - $psed =~ s/\.$//; + # default in the .com extenson if it's not already there $s2p = VMS::Filespec::rmsexpand($s2p, '.com'); $psed = VMS::Filespec::rmsexpand($psed, '.com'); } @@ -818,6 +798,9 @@ my $sedcmd = [ $psed, '-f', $script, $stdin ]; my $s2pcmd = [ $s2p, '-f', $script ]; my $plcmd = [ $plsed, $stdin ]; +my $switches = ''; +$switches = ['-x'] if $^O eq 'MacOS'; + # psed: we create a local copy as linking may not work on some systems. copy( $s2p, $psed ); push( @aux, $psed ); @@ -828,8 +811,6 @@ my $indat = ''; for my $tc ( sort keys %testcase ){ my( $psedres, $s2pres ); - local $TODO = $testcase{$tc}{todo}; - # 1st test: run psed # prepare the script open( SED, ">$script" ) || goto FAIL_BOTH; @@ -863,19 +844,19 @@ for my $tc ( sort keys %testcase ){ # run and compare # - $psedres = runperl( args => $sedcmd ); + $psedres = runperl( args => $sedcmd, switches => $switches ); is( $psedres, $testcase{$tc}{expect}, "psed $tc" ); # 2nd test: run s2p # translate the sed script to a Perl program - my $perlprog = runperl( args => $s2pcmd ); + my $perlprog = runperl( args => $s2pcmd, switches => $switches ); open( PP, ">$plsed" ) || goto FAIL_S2P; print PP $perlprog; close( PP ) || goto FAIL_S2P; # execute generated Perl program, compare - $s2pres = runperl( args => $plcmd ); + $s2pres = runperl( args => $plcmd, switches => $switches ); is( $s2pres, $testcase{$tc}{expect}, "s2p $tc" ); next; -- cgit v1.2.3