diff options
Diffstat (limited to 'contrib/perl5/t/pragma')
47 files changed, 7461 insertions, 241 deletions
diff --git a/contrib/perl5/t/pragma/constant.t b/contrib/perl5/t/pragma/constant.t index 5b63dfa..6438332 100755 --- a/contrib/perl5/t/pragma/constant.t +++ b/contrib/perl5/t/pragma/constant.t @@ -2,10 +2,10 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } -BEGIN {$^W |= 1} # Insist upon warnings +use warnings; use vars qw{ @warnings }; BEGIN { # ...and save 'em for later $SIG{'__WARN__'} = sub { push @warnings, @_ } @@ -14,9 +14,9 @@ END { print @warnings } ######################### We start with some black magic to print on failure. -BEGIN { $| = 1; print "1..46\n"; } +BEGIN { $| = 1; print "1..73\n"; } END {print "not ok 1\n" unless $loaded;} -use constant; +use constant 1.01; $loaded = 1; #print "# Version: $constant::VERSION\n"; print "ok 1\n"; @@ -96,11 +96,8 @@ test 23, length(MESS) == 8; use constant TRAILING => '12 cats'; { - my $save_warn; - local $^W; - BEGIN { $save_warn = $^W; $^W = 0 } + no warnings 'numeric'; test 24, TRAILING == 12; - BEGIN { $^W = $save_warn } } test 25, TRAILING eq '12 cats'; @@ -138,7 +135,7 @@ test 37, @warnings && shift @warnings; test 38, @warnings == 0, "unexpected warning"; -test 39, $^W & 1, "Who disabled the warnings?"; +test 39, 1; use constant CSCALAR => \"ok 40\n"; use constant CHASH => { foo => "ok 41\n" }; @@ -151,7 +148,83 @@ print CHASH->{foo}; print CARRAY->[1]; print CPHASH->{foo}; eval q{ CPHASH->{bar} }; -test 44, scalar($@ =~ /^No such array/); +test 44, scalar($@ =~ /^No such pseudo-hash field/); print CCODE->(45); eval q{ CCODE->{foo} }; test 46, scalar($@ =~ /^Constant is not a HASH/); + +# Allow leading underscore +use constant _PRIVATE => 47; +test 47, _PRIVATE == 47; + +# Disallow doubled leading underscore +eval q{ + use constant __DISALLOWED => "Oops"; +}; +test 48, $@ =~ /begins with '__'/; + +# Check on declared() and %declared. This sub should be EXACTLY the +# same as the one quoted in the docs! +sub declared ($) { + use constant 1.01; # don't omit this! + my $name = shift; + $name =~ s/^::/main::/; + my $pkg = caller; + my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; + $constant::declared{$full_name}; +} + +test 49, declared 'PI'; +test 50, $constant::declared{'main::PI'}; + +test 51, !declared 'PIE'; +test 52, !$constant::declared{'main::PIE'}; + +{ + package Other; + use constant IN_OTHER_PACK => 42; + ::test 53, ::declared 'IN_OTHER_PACK'; + ::test 54, $constant::declared{'Other::IN_OTHER_PACK'}; + ::test 55, ::declared 'main::PI'; + ::test 56, $constant::declared{'main::PI'}; +} + +test 57, declared 'Other::IN_OTHER_PACK'; +test 58, $constant::declared{'Other::IN_OTHER_PACK'}; + +@warnings = (); +eval q{ + no warnings; + use warnings 'constant'; + use constant 'BEGIN' => 1 ; + use constant 'INIT' => 1 ; + use constant 'CHECK' => 1 ; + use constant 'END' => 1 ; + use constant 'DESTROY' => 1 ; + use constant 'AUTOLOAD' => 1 ; + use constant 'STDIN' => 1 ; + use constant 'STDOUT' => 1 ; + use constant 'STDERR' => 1 ; + use constant 'ARGV' => 1 ; + use constant 'ARGVOUT' => 1 ; + use constant 'ENV' => 1 ; + use constant 'INC' => 1 ; + use constant 'SIG' => 1 ; +}; + +test 59, @warnings == 14 ; +test 60, (shift @warnings) =~ /^Constant name 'BEGIN' is a Perl keyword at/; +test 61, (shift @warnings) =~ /^Constant name 'INIT' is a Perl keyword at/; +test 62, (shift @warnings) =~ /^Constant name 'CHECK' is a Perl keyword at/; +test 63, (shift @warnings) =~ /^Constant name 'END' is a Perl keyword at/; +test 64, (shift @warnings) =~ /^Constant name 'DESTROY' is a Perl keyword at/; +test 65, (shift @warnings) =~ /^Constant name 'AUTOLOAD' is a Perl keyword at/; +test 66, (shift @warnings) =~ /^Constant name 'STDIN' is forced into package main:: a/; +test 67, (shift @warnings) =~ /^Constant name 'STDOUT' is forced into package main:: at/; +test 68, (shift @warnings) =~ /^Constant name 'STDERR' is forced into package main:: at/; +test 69, (shift @warnings) =~ /^Constant name 'ARGV' is forced into package main:: at/; +test 70, (shift @warnings) =~ /^Constant name 'ARGVOUT' is forced into package main:: at/; +test 71, (shift @warnings) =~ /^Constant name 'ENV' is forced into package main:: at/; +test 72, (shift @warnings) =~ /^Constant name 'INC' is forced into package main:: at/; +test 73, (shift @warnings) =~ /^Constant name 'SIG' is forced into package main:: at/; +@warnings = (); diff --git a/contrib/perl5/t/pragma/diagnostics.t b/contrib/perl5/t/pragma/diagnostics.t new file mode 100755 index 0000000..15cd6b5 --- /dev/null +++ b/contrib/perl5/t/pragma/diagnostics.t @@ -0,0 +1,38 @@ +#!./perl + +BEGIN { + chdir '..' if -d '../pod'; + unshift @INC, './lib' if -d './lib'; +} + + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) +use strict; +use warnings; + +use vars qw($Test_Num $Total_tests); + +my $loaded; +BEGIN { $| = 1; $Test_Num = 1 } +END {print "not ok $Test_Num\n" unless $loaded;} +print "1..$Total_tests\n"; +BEGIN { require diagnostics; } # Don't want diagnostics' noise yet. +$loaded = 1; +ok($loaded, 'compile'); +######################### End of black magic. + +sub ok { + my($test, $name) = shift; + print "not " unless $test; + print "ok $Test_Num"; + print " - $name" if defined $name; + print "\n"; + $Test_Num++; +} + + +# Change this to your # of ok() calls + 1 +BEGIN { $Total_tests = 1 } diff --git a/contrib/perl5/t/pragma/locale.t b/contrib/perl5/t/pragma/locale.t index 7e3df8c..414ceff 100755 --- a/contrib/perl5/t/pragma/locale.t +++ b/contrib/perl5/t/pragma/locale.t @@ -2,7 +2,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; + unshift @INC, '.'; require Config; import Config; if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) { print "1..0\n"; @@ -12,6 +13,16 @@ BEGIN { use strict; +my $debug = 1; + +sub debug { + print @_ if $debug; +} + +sub debugf { + printf @_ if $debug; +} + my $have_setlocale = 0; eval { require POSIX; @@ -23,17 +34,11 @@ eval { # and mingw32 uses said silly CRT $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; -# 103 (the last test) may fail but that is okay. -# (It indicates something broken in the environment, not Perl) -# Therefore .. only until 102, not 103. -print "1..", ($have_setlocale ? 102 : 98), "\n"; +print "1..", ($have_setlocale ? 116 : 98), "\n"; -use vars qw($a - $English $German $French $Spanish - @C @English @German @French @Spanish - $Locale @Locale %iLocale %UPPER %lower @Neoalpha); +use vars qw(&LC_ALL); -$a = 'abc %'; +my $a = 'abc %'; sub ok { my ($n, $result) = @_; @@ -47,7 +52,7 @@ sub ok { # even the default locale will taint under 'use locale'. sub is_tainted { # hello, camel two. - local $^W; # no warnings 'undef' + no warnings 'uninitialized' ; my $dummy; not eval { $dummy = join("", @_), kill 0; 1 } } @@ -73,9 +78,9 @@ check_taint 7, "\L$a"; check_taint 8, lcfirst($a); check_taint 9, "\l$a"; -check_taint 10, sprintf('%e', 123.456); -check_taint 11, sprintf('%f', 123.456); -check_taint 12, sprintf('%g', 123.456); +check_taint_not 10, sprintf('%e', 123.456); +check_taint_not 11, sprintf('%f', 123.456); +check_taint_not 12, sprintf('%g', 123.456); check_taint_not 13, sprintf('%d', 123.456); check_taint_not 14, sprintf('%x', 123.456); @@ -219,269 +224,511 @@ check_taint_not 98, $a; # I think we've seen quite enough of taint. # Let us do some *real* locale work now, -# unless setlocale() is missing (i.e. minitest). +# unless setlocale() is missing (i.e. minitest). exit unless $have_setlocale; -sub getalnum { +# Find locales. + +debug "# Scanning for locales...\n"; + +# Note that it's okay that some languages have their native names +# capitalized here even though that's not "right". They are lowercased +# anyway later during the scanning process (and besides, some clueless +# vendor might have them capitalized errorneously anyway). + +my $locales = <<EOF; +Afrikaans:af:za:1 15 +Arabic:ar:dz eg sa:6 arabic8 +Brezhoneg Breton:br:fr:1 15 +Bulgarski Bulgarian:bg:bg:5 +Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW GB2312 tw.EUC +Hrvatski Croatian:hr:hr:2 +Cymraeg Welsh:cy:cy:1 14 15 +Czech:cs:cz:2 +Dansk Danish:dk:da:1 15 +Nederlands Dutch:nl:be nl:1 15 +English American British:en:au ca gb ie nz us uk:1 15 cp850 +Esperanto:eo:eo:3 +Eesti Estonian:et:ee:4 6 13 +Suomi Finnish:fi:fi:1 15 +Flamish::fl:1 15 +Deutsch German:de:at be ch de lu:1 15 +Euskaraz Basque:eu:es fr:1 15 +Galego Galician:gl:es:1 15 +Ellada Greek:el:gr:7 g8 +Frysk:fy:nl:1 15 +Greenlandic:kl:gl:4 6 +Hebrew:iw:il:8 hebrew8 +Hungarian:hu:hu:2 +Indonesian:in:id:1 15 +Gaeilge Irish:ga:IE:1 14 15 +Italiano Italian:it:ch it:1 15 +Nihongo Japanese:ja:jp:euc eucJP jp.EUC sjis +Korean:ko:kr: +Latine Latin:la:va:1 15 +Latvian:lv:lv:4 6 13 +Lithuanian:lt:lt:4 6 13 +Macedonian:mk:mk:1 15 +Maltese:mt:mt:3 +Norsk Norwegian:no:no:1 15 +Occitan:oc:es:1 15 +Polski Polish:pl:pl:2 +Rumanian:ro:ro:2 +Russki Russian:ru:ru su ua:5 koi8 koi8r koi8u cp1251 +Serbski Serbian:sr:yu:5 +Slovak:sk:sk:2 +Slovene Slovenian:sl:si:2 +Sqhip Albanian:sq:sq:1 15 +Svenska Swedish:sv:fi se:1 15 +Thai:th:th:11 tis620 +Turkish:tr:tr:9 turkish8 +Yiddish:::1 15 +EOF + +if ($^O eq 'os390') { + $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//; + $locales =~ s/Thai:th:th:11 tis620\n//; +} + +sub in_utf8 () { $^H & 0x08 } + +if (in_utf8) { + require "pragma/locale/utf8"; +} else { + require "pragma/locale/latin1"; +} + +my @Locale; +my $Locale; +my @Alnum_; + +sub getalnum_ { sort grep /\w/, map { chr } 0..255 } -sub locatelocale ($$@) { - my ($lcall, $alnum, @try) = @_; +sub trylocale { + my $locale = shift; + if (setlocale(LC_ALL, $locale)) { + push @Locale, $locale; + } +} - undef $$lcall; +sub decode_encodings { + my @enc; - for (@try) { - local $^W = 0; # suppress "Subroutine LC_ALL redefined" - if (setlocale(&LC_ALL, $_)) { - $$lcall = $_; - @$alnum = &getalnum; - last; + foreach (split(/ /, shift)) { + if (/^(\d+)$/) { + push @enc, "ISO8859-$1"; + push @enc, "iso8859$1"; # HP + if ($1 eq '1') { + push @enc, "roman8"; # HP + } + } else { + push @enc, $_; } } + if ($^O eq 'os390') { + push @enc, qw(IBM-037 IBM-819 IBM-1047); + } - @$alnum = () unless (defined $$lcall); + return @enc; } -# Find some default locale - -locatelocale(\$Locale, \@Locale, qw(C POSIX)); - -# Find some English locale - -locatelocale(\$English, \@English, - qw(en_US.ISO8859-1 en_GB.ISO8859-1 - en en_US en_UK en_IE en_CA en_AU en_NZ - english english.iso88591 - american american.iso88591 - british british.iso88591 - )); - -# Find some German locale - -locatelocale(\$German, \@German, - qw(de_DE.ISO8859-1 de_AT.ISO8859-1 de_CH.ISO8859-1 - de de_DE de_AT de_CH - german german.iso88591)); - -# Find some French locale - -locatelocale(\$French, \@French, - qw(fr_FR.ISO8859-1 fr_BE.ISO8859-1 fr_CA.ISO8859-1 fr_CH.ISO8859-1 - fr fr_FR fr_BE fr_CA fr_CH - french french.iso88591)); - -# Find some Spanish locale - -locatelocale(\$Spanish, \@Spanish, - qw(es_AR.ISO8859-1 es_BO.ISO8859-1 es_CL.ISO8859-1 - es_CO.ISO8859-1 es_CR.ISO8859-1 es_EC.ISO8859-1 - es_ES.ISO8859-1 es_GT.ISO8859-1 es_MX.ISO8859-1 - es_NI.ISO8859-1 es_PA.ISO8859-1 es_PE.ISO8859-1 - es_PY.ISO8859-1 es_SV.ISO8859-1 es_UY.ISO8859-1 es_VE.ISO8859-1 - es es_AR es_BO es_CL - es_CO es_CR es_EC - es_ES es_GT es_MX - es_NI es_PA es_PE - es_PY es_SV es_UY es_VE - spanish spanish.iso88591)); - -# Select the largest of the alpha(num)bets. - -($Locale, @Locale) = ($English, @English) - if (@English > @Locale); -($Locale, @Locale) = ($German, @German) - if (@German > @Locale); -($Locale, @Locale) = ($French, @French) - if (@French > @Locale); -($Locale, @Locale) = ($Spanish, @Spanish) - if (@Spanish > @Locale); - -{ - local $^W = 0; - setlocale(&LC_ALL, $Locale); +trylocale("C"); +trylocale("POSIX"); +foreach (0..15) { + trylocale("ISO8859-$_"); + trylocale("iso8859$_"); + trylocale("iso8859-$_"); + trylocale("iso_8859_$_"); + trylocale("isolatin$_"); + trylocale("isolatin-$_"); + trylocale("iso_latin_$_"); +} + +foreach my $locale (split(/\n/, $locales)) { + my ($locale_name, $language_codes, $country_codes, $encodings) = + split(/:/, $locale); + my @enc = decode_encodings($encodings); + foreach my $loc (split(/ /, $locale_name)) { + trylocale($loc); + foreach my $enc (@enc) { + trylocale("$loc.$enc"); + } + $loc = lc $loc; + foreach my $enc (@enc) { + trylocale("$loc.$enc"); + } + } + foreach my $lang (split(/ /, $language_codes)) { + trylocale($lang); + foreach my $country (split(/ /, $country_codes)) { + my $lc = "${lang}_${country}"; + trylocale($lc); + foreach my $enc (@enc) { + trylocale("$lc.$enc"); + } + my $lC = "${lang}_\U${country}"; + trylocale($lC); + foreach my $enc (@enc) { + trylocale("$lC.$enc"); + } + } + } } -# Sort it now that LC_ALL has been set. +setlocale(LC_ALL, "C"); @Locale = sort @Locale; -print "# Locale = $Locale\n"; -print "# Alnum_ = @Locale\n"; +debug "# Locales = @Locale\n"; + +my %Problem; +my %Okay; +my %Testing; +my @Neoalpha; +my %Neoalpha; + +sub tryneoalpha { + my ($Locale, $i, $test) = @_; + debug "# testing $i with locale '$Locale'\n" + unless $Testing{$i}{$Locale}++; + unless ($test) { + $Problem{$i}{$Locale} = 1; + debug "# failed $i with locale '$Locale'\n"; + } else { + push @{$Okay{$i}}, $Locale; + } +} -{ - my $i = 0; +foreach $Locale (@Locale) { + debug "# Locale = $Locale\n"; + @Alnum_ = getalnum_(); + debug "# \\w = @Alnum_\n"; - for (@Locale) { - $iLocale{$_} = $i++; + unless (setlocale(LC_ALL, $Locale)) { + foreach (99..103) { + $Problem{$_}{$Locale} = -1; + } + next; + } + + # Sieve the uppercase and the lowercase. + + my %UPPER = (); + my %lower = (); + my %BoThCaSe = (); + for (@Alnum_) { + if (/[^\d_]/) { # skip digits and the _ + if (uc($_) eq $_) { + $UPPER{$_} = $_; + } + if (lc($_) eq $_) { + $lower{$_} = $_; + } + } + } + foreach (keys %UPPER) { + $BoThCaSe{$_}++ if exists $lower{$_}; + } + foreach (keys %lower) { + $BoThCaSe{$_}++ if exists $UPPER{$_}; + } + foreach (keys %BoThCaSe) { + delete $UPPER{$_}; + delete $lower{$_}; } -} -# Sieve the uppercase and the lowercase. + debug "# UPPER = ", join(" ", sort keys %UPPER ), "\n"; + debug "# lower = ", join(" ", sort keys %lower ), "\n"; + debug "# BoThCaSe = ", join(" ", sort keys %BoThCaSe), "\n"; -for (@Locale) { - if (/[^\d_]/) { # skip digits and the _ - if (lc eq $_) { - $UPPER{$_} = uc; - } else { - $lower{$_} = lc; + # Find the alphabets that are not alphabets in the default locale. + + { + no locale; + + @Neoalpha = (); + for (keys %UPPER, keys %lower) { + push(@Neoalpha, $_) if (/\W/); + $Neoalpha{$_} = $_; } } -} -# Find the alphabets that are not alphabets in the default locale. + @Neoalpha = sort @Neoalpha; + + debug "# Neoalpha = @Neoalpha\n"; + + if (@Neoalpha == 0) { + # If we have no Neoalphas the remaining tests are no-ops. + debug "# no Neoalpha, skipping tests 99..102 for locale '$Locale'\n"; + foreach (99..102) { + push @{$Okay{$_}}, $Locale; + } + } else { -{ - no locale; + # Test \w. - for (keys %UPPER, keys %lower) { - push(@Neoalpha, $_) if (/\W/); + { + my $word = join('', @Neoalpha); + + $word =~ /^(\w+)$/; + + tryneoalpha($Locale, 99, $1 eq $word); + } + + # Cross-check the whole 8-bit character set. + + for (map { chr } 0..255) { + tryneoalpha($Locale, 100, + (/\w/ xor /\W/) || + (/\d/ xor /\D/) || + (/\s/ xor /\S/)); + } + + # Test for read-only scalars' locale vs non-locale comparisons. + + { + no locale; + $a = "qwerty"; + { + use locale; + tryneoalpha($Locale, 101, ($a cmp "qwerty") == 0); + } + } + + { + my ($from, $to, $lesser, $greater, + @test, %test, $test, $yes, $no, $sign); + + for (0..9) { + # Select a slice. + $from = int(($_*@Alnum_)/10); + $to = $from + int(@Alnum_/10); + $to = $#Alnum_ if ($to > $#Alnum_); + $lesser = join('', @Alnum_[$from..$to]); + # Select a slice one character on. + $from++; $to++; + $to = $#Alnum_ if ($to > $#Alnum_); + $greater = join('', @Alnum_[$from..$to]); + ($yes, $no, $sign) = ($lesser lt $greater + ? (" ", "not ", 1) + : ("not ", " ", -1)); + # all these tests should FAIL (return 0). + # Exact lt or gt cannot be tested because + # in some locales, say, eacute and E may test equal. + @test = + ( + $no.' ($lesser le $greater)', # 1 + 'not ($lesser ne $greater)', # 2 + ' ($lesser eq $greater)', # 3 + $yes.' ($lesser ge $greater)', # 4 + $yes.' ($lesser ge $greater)', # 5 + $yes.' ($greater le $lesser )', # 7 + 'not ($greater ne $lesser )', # 8 + ' ($greater eq $lesser )', # 9 + $no.' ($greater ge $lesser )', # 10 + 'not (($lesser cmp $greater) == -$sign)' # 12 + ); + @test{@test} = 0 x @test; + $test = 0; + for my $ti (@test) { + $test{$ti} = eval $ti; + $test ||= $test{$ti} + } + tryneoalpha($Locale, 102, $test == 0); + if ($test) { + debug "# lesser = '$lesser'\n"; + debug "# greater = '$greater'\n"; + debug "# lesser cmp greater = ", + $lesser cmp $greater, "\n"; + debug "# greater cmp lesser = ", + $greater cmp $lesser, "\n"; + debug "# (greater) from = $from, to = $to\n"; + for my $ti (@test) { + debugf("# %-40s %-4s", $ti, + $test{$ti} ? 'FAIL' : 'ok'); + if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) { + debugf("(%s == %4d)", $1, eval $1); + } + debug "\n#"; + } + + last; + } + } + } } -} -@Neoalpha = sort @Neoalpha; + use locale; -# Test \w. + my ($x, $y) = (1.23, 1.23); -{ - my $word = join('', @Neoalpha); + my $a = "$x"; + printf ''; # printf used to reset locale to "C" + my $b = "$y"; - $word =~ /^(\w*)$/; + debug "# 103..107: a = $a, b = $b, Locale = $Locale\n"; - print 'not ' if ($1 ne $word); -} -print "ok 99\n"; + tryneoalpha($Locale, 103, $a eq $b); -# Find places where the collation order differs from the default locale. + my $c = "$x"; + my $z = sprintf ''; # sprintf used to reset locale to "C" + my $d = "$y"; -print "# testing 100\n"; -{ - my (@k, $i, $j, @d); + debug "# 104..107: c = $c, d = $d, Locale = $Locale\n"; + + tryneoalpha($Locale, 104, $c eq $d); { - no locale; + use warnings; + my $w = 0; + local $SIG{__WARN__} = sub { $w++ }; + + # the == (among other ops) used to warn for locales + # that had something else than "." as the radix character + + tryneoalpha($Locale, 105, $c == 1.23); + + tryneoalpha($Locale, 106, $c == $x); + + tryneoalpha($Locale, 107, $c == $d); + + { + no locale; + + my $e = "$x"; + + debug "# 108..110: e = $e, Locale = $Locale\n"; + + tryneoalpha($Locale, 108, $e == 1.23); + + tryneoalpha($Locale, 109, $e == $x); + + tryneoalpha($Locale, 110, $e == $c); + } + + tryneoalpha($Locale, 111, $w == 0); + + my $f = "1.23"; - @k = sort (keys %UPPER, keys %lower); + debug "# 112..114: f = $f, locale = $Locale\n"; + + tryneoalpha($Locale, 112, $f == 1.23); + + tryneoalpha($Locale, 113, $f == $x); + + tryneoalpha($Locale, 114, $f == $c); } - for ($i = 0; $i < @k; $i++) { - for ($j = $i + 1; $j < @k; $j++) { - if ($iLocale{$k[$j]} < $iLocale{$k[$i]}) { - push(@d, [$k[$j], $k[$i]]); - } + debug "# testing 115 with locale '$Locale'\n"; + { + use locale; + + sub lcA { + my $lc0 = lc $_[0]; + my $lc1 = lc $_[1]; + return $lc0 cmp $lc1; } + + sub lcB { + return lc($_[0]) cmp lc($_[1]); + } + + my $x = "ab"; + my $y = "aa"; + my $z = "AB"; + + tryneoalpha($Locale, 115, + lcA($x, $y) == 1 && lcB($x, $y) == 1 || + lcA($x, $z) == 0 && lcB($x, $z) == 0); } - # Cross-check those places. + debug "# testing 116 with locale '$Locale'\n"; + { + use locale; - for (@d) { - ($i, $j) = @$_; - if ($i gt $j) { - print "# failed 100 at:\n"; - print "# i = $i, j = $j, i ", - $i le $j ? 'le' : 'gt', " j\n"; - print 'not '; - last; + my @f = (); + foreach my $x (keys %UPPER) { + my $y = lc $x; + next unless uc $y eq $x; + push @f, $x unless $x =~ /$y/i && $y =~ /$x/i; } + foreach my $x (keys %lower) { + my $y = uc $x; + next unless lc $y eq $x; + push @f, $x unless $x =~ /$y/i && $y =~ /$x/i; + } + tryneoalpha($Locale, 116, @f == 0); + print "# testing 116 failed for locale '$Locale' for characters @f\n" + if @f; } } -print "ok 100\n"; - -# Cross-check whole character set. - -print "# testing 101\n"; -for (map { chr } 0..255) { - if (/\w/ and /\W/) { print 'not '; last } - if (/\d/ and /\D/) { print 'not '; last } - if (/\s/ and /\S/) { print 'not '; last } - if (/\w/ and /\D/ and not /_/ and - not (exists $UPPER{$_} or exists $lower{$_})) { - print "# failed 101 at:\n"; - print "# ", ord($_), " '$_'\n"; - print 'not '; - last; + +# Recount the errors. + +foreach (99..116) { + if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) { + if ($_ == 102) { + print "# The failure of test 102 is not necessarily fatal.\n"; + print "# It usually indicates a problem in the enviroment,\n"; + print "# not in Perl itself.\n"; + } + print "not "; } + print "ok $_\n"; } -print "ok 101\n"; - -# Test for read-onlys. -print "# testing 102\n"; -{ - no locale; - $a = "qwerty"; - { - use locale; - print "not " if $a cmp "qwerty"; +# Give final advice. + +my $didwarn = 0; + +foreach (99..116) { + if ($Problem{$_}) { + my @f = sort keys %{ $Problem{$_} }; + my $f = join(" ", @f); + $f =~ s/(.{50,60}) /$1\n#\t/g; + print + "#\n", + "# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n", + "#\t", $f, "\n#\n", + "# on your system may have errors because the locale test $_\n", + "# failed in ", (@f == 1 ? "that locale" : "those locales"), + ".\n"; + print <<EOW; +# +# If your users are not using these locales you are safe for the moment, +# but please report this failure first to perlbug\@perl.com using the +# perlbug script (as described in the INSTALL file) so that the exact +# details of the failures can be sorted out first and then your operating +# system supplier can be alerted about these anomalies. +# +EOW + $didwarn = 1; } } -print "ok 102\n"; - -# This test must be the last one because its failure is not fatal. -# The @Locale should be internally consistent. -# Thanks to Hallvard Furuseth <h.b.furuseth@usit.uio.no> -# for inventing a way to test for ordering consistency -# without requiring any particular order. -# <jhi@iki.fi> - -print "# testing 103\n"; -{ - my ($from, $to, $lesser, $greater, @test, %test, $test, $yes, $no, $sign); - - for (0..9) { - # Select a slice. - $from = int(($_*@Locale)/10); - $to = $from + int(@Locale/10); - $to = $#Locale if ($to > $#Locale); - $lesser = join('', @Locale[$from..$to]); - # Select a slice one character on. - $from++; $to++; - $to = $#Locale if ($to > $#Locale); - $greater = join('', @Locale[$from..$to]); - ($yes, $no, $sign) = ($lesser lt $greater - ? (" ", "not ", 1) - : ("not ", " ", -1)); - # all these tests should FAIL (return 0). - @test = - ( - $no.' ($lesser lt $greater)', # 0 - $no.' ($lesser le $greater)', # 1 - 'not ($lesser ne $greater)', # 2 - ' ($lesser eq $greater)', # 3 - $yes.' ($lesser ge $greater)', # 4 - $yes.' ($lesser gt $greater)', # 5 - $yes.' ($greater lt $lesser )', # 6 - $yes.' ($greater le $lesser )', # 7 - 'not ($greater ne $lesser )', # 8 - ' ($greater eq $lesser )', # 9 - $no.' ($greater ge $lesser )', # 10 - $no.' ($greater gt $lesser )', # 11 - 'not (($lesser cmp $greater) == -$sign)' # 12 - ); - @test{@test} = 0 x @test; - $test = 0; - for my $ti (@test) { $test{$ti} = eval $ti ; $test ||= $test{$ti} } - if ($test) { - print "# failed 103 at:\n"; - print "# lesser = '$lesser'\n"; - print "# greater = '$greater'\n"; - print "# lesser cmp greater = ", $lesser cmp $greater, "\n"; - print "# greater cmp lesser = ", $greater cmp $lesser, "\n"; - print "# (greater) from = $from, to = $to\n"; - for my $ti (@test) { - printf("# %-40s %-4s", $ti, - $test{$ti} ? 'FAIL' : 'ok'); - if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) { - printf("(%s == %4d)", $1, eval $1); - } - print "\n"; - } - warn "The locale definition on your system may have errors.\n"; - last; +# Tell which locales ere okay. + +if ($didwarn) { + my @s; + + foreach my $l (@Locale) { + my $p = 0; + foreach my $t (102..102) { + $p++ if $Problem{$t}{$l}; } + push @s, $l if $p == 0; } + + my $s = join(" ", @s); + $s =~ s/(.{50,60}) /$1\n#\t/g; + + warn + "# The following locales\n#\n", + "#\t", $s, "\n#\n", + "# tested okay.\n#\n", } # eof diff --git a/contrib/perl5/t/pragma/locale/latin1 b/contrib/perl5/t/pragma/locale/latin1 new file mode 100644 index 0000000..f40f732 --- /dev/null +++ b/contrib/perl5/t/pragma/locale/latin1 @@ -0,0 +1,10 @@ +$locales .= <<EOF; +Catal Catalan:ca:es:1 15 +Franais French:fr:be ca ch fr lu:1 15 +Gidhlig Gaelic:gd:gb uk:1 14 15 +Froyskt Faroese:fo:fo:1 15 +slensku Icelandic:is:is:1 15 +Smi Lappish:::4 6 13 +Portugus Portuguese:po:po br:1 15 +Espanl Spanish:es:ar bo cl co cr do ec es gt hn mx ni pa pe py sv uy ve:1 15 +EOF diff --git a/contrib/perl5/t/pragma/locale/utf8 b/contrib/perl5/t/pragma/locale/utf8 new file mode 100644 index 0000000..fbbe94f --- /dev/null +++ b/contrib/perl5/t/pragma/locale/utf8 @@ -0,0 +1,10 @@ +$locales .= <<EOF; +Català Catalan:ca:es:1 15 +Français French:fr:be ca ch fr lu:1 15 +Gáidhlig Gaelic:gd:gb uk:1 14 15 +Føroyskt Faroese:fo:fo:1 15 +Íslensku Icelandic:is:is:1 15 +Sámi Lappish:::4 6 13 +Português Portuguese:po:po br:1 15 +Espanõl Spanish:es:ar bo cl co cr do ec es gt hn mx ni pa pe py sv uy ve:1 15 +EOF diff --git a/contrib/perl5/t/pragma/overload.t b/contrib/perl5/t/pragma/overload.t index 0682266..f9a9c59 100755 --- a/contrib/perl5/t/pragma/overload.t +++ b/contrib/perl5/t/pragma/overload.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } package Oscalar; @@ -706,5 +706,227 @@ test($c, "bareword"); # 135 my @sorted2 = map $$_, @sorted1; test "@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3'; } +{ + package iterator; + use overload '<>' => \&iter; + sub new { my ($p, $v) = @_; bless \$v, $p } + sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; } +} + +# XXX iterator overload not intended to work with CORE::GLOBAL? +if (defined &CORE::GLOBAL::glob) { + test '1', '1'; # 175 + test '1', '1'; # 176 + test '1', '1'; # 177 +} +else { + my $iter = iterator->new(5); + my $acc = ''; + my $out; + $acc .= " $out" while $out = <${iter}>; + test $acc, ' 5 4 3 2 1 0'; # 175 + $iter = iterator->new(5); + test scalar <${iter}>, '5'; # 176 + $acc = ''; + $acc .= " $out" while $out = <$iter>; + test $acc, ' 4 3 2 1 0'; # 177 +} +{ + package deref; + use overload '%{}' => \&hderef, '&{}' => \&cderef, + '*{}' => \&gderef, '${}' => \&sderef, '@{}' => \&aderef; + sub new { my ($p, $v) = @_; bless \$v, $p } + sub deref { + my ($self, $key) = (shift, shift); + my $class = ref $self; + bless $self, 'deref::dummy'; # Disable overloading of %{} + my $out = $self->{$key}; + bless $self, $class; # Restore overloading + $out; + } + sub hderef {shift->deref('h')} + sub aderef {shift->deref('a')} + sub cderef {shift->deref('c')} + sub gderef {shift->deref('g')} + sub sderef {shift->deref('s')} +} +{ + my $deref = bless { h => { foo => 5 , fake => 23 }, + c => sub {return shift() + 34}, + 's' => \123, + a => [11..13], + g => \*srt, + }, 'deref'; + # Hash: + my @cont = sort %$deref; + if ("\t" eq "\011") { # ascii + test "@cont", '23 5 fake foo'; # 178 + } + else { # ebcdic alpha-numeric sort order + test "@cont", 'fake foo 23 5'; # 178 + } + my @keys = sort keys %$deref; + test "@keys", 'fake foo'; # 179 + my @val = sort values %$deref; + test "@val", '23 5'; # 180 + test $deref->{foo}, 5; # 181 + test defined $deref->{bar}, ''; # 182 + my $key; + @keys = (); + push @keys, $key while $key = each %$deref; + @keys = sort @keys; + test "@keys", 'fake foo'; # 183 + test exists $deref->{bar}, ''; # 184 + test exists $deref->{foo}, 1; # 185 + # Code: + test $deref->(5), 39; # 186 + test &$deref(6), 40; # 187 + sub xxx_goto { goto &$deref } + test xxx_goto(7), 41; # 188 + my $srt = bless { c => sub {$b <=> $a} + }, 'deref'; + *srt = \&$srt; + my @sorted = sort srt 11, 2, 5, 1, 22; + test "@sorted", '22 11 5 2 1'; # 189 + # Scalar + test $$deref, 123; # 190 + # Code + @sorted = sort $srt 11, 2, 5, 1, 22; + test "@sorted", '22 11 5 2 1'; # 191 + # Array + test "@$deref", '11 12 13'; # 192 + test $#$deref, '2'; # 193 + my $l = @$deref; + test $l, 3; # 194 + test $deref->[2], '13'; # 195 + $l = pop @$deref; + test $l, 13; # 196 + $l = 1; + test $deref->[$l], '12'; # 197 + # Repeated dereference + my $double = bless { h => $deref, + }, 'deref'; + test $double->{foo}, 5; # 198 +} + +{ + package two_refs; + use overload '%{}' => \&gethash, '@{}' => sub { ${shift()} }; + sub new { + my $p = shift; + bless \ [@_], $p; + } + sub gethash { + my %h; + my $self = shift; + tie %h, ref $self, $self; + \%h; + } + + sub TIEHASH { my $p = shift; bless \ shift, $p } + my %fields; + my $i = 0; + $fields{$_} = $i++ foreach qw{zero one two three}; + sub STORE { + my $self = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $$self->[$key] = shift; + } + sub FETCH { + my $self = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $$self->[$key]; + } +} + +my $bar = new two_refs 3,4,5,6; +$bar->[2] = 11; +test $bar->{two}, 11; # 199 +$bar->{three} = 13; +test $bar->[3], 13; # 200 + +{ + package two_refs_o; + @ISA = ('two_refs'); +} + +$bar = new two_refs_o 3,4,5,6; +$bar->[2] = 11; +test $bar->{two}, 11; # 201 +$bar->{three} = 13; +test $bar->[3], 13; # 202 + +{ + package two_refs1; + use overload '%{}' => sub { ${shift()}->[1] }, + '@{}' => sub { ${shift()}->[0] }; + sub new { + my $p = shift; + my $a = [@_]; + my %h; + tie %h, $p, $a; + bless \ [$a, \%h], $p; + } + sub gethash { + my %h; + my $self = shift; + tie %h, ref $self, $self; + \%h; + } + + sub TIEHASH { my $p = shift; bless \ shift, $p } + my %fields; + my $i = 0; + $fields{$_} = $i++ foreach qw{zero one two three}; + sub STORE { + my $a = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $a->[$key] = shift; + } + sub FETCH { + my $a = ${shift()}; + my $key = $fields{shift()}; + defined $key or die "Out of band access"; + $a->[$key]; + } +} + +$bar = new two_refs_o 3,4,5,6; +$bar->[2] = 11; +test $bar->{two}, 11; # 203 +$bar->{three} = 13; +test $bar->[3], 13; # 204 + +{ + package two_refs1_o; + @ISA = ('two_refs1'); +} + +$bar = new two_refs1_o 3,4,5,6; +$bar->[2] = 11; +test $bar->{two}, 11; # 205 +$bar->{three} = 13; +test $bar->[3], 13; # 206 + +{ + package B; + use overload bool => sub { ${+shift} }; +} + +my $aaa; +{ my $bbbb = 0; $aaa = bless \$bbbb, B } + +test !$aaa, 1; + +unless ($aaa) { + test 'ok', 'ok'; +} else { + test 'is not', 'ok'; +} + + # Last test is: -sub last {174} +sub last {208} diff --git a/contrib/perl5/t/pragma/strict-refs b/contrib/perl5/t/pragma/strict-refs index 7bf1556..10599b0 100644 --- a/contrib/perl5/t/pragma/strict-refs +++ b/contrib/perl5/t/pragma/strict-refs @@ -196,6 +196,7 @@ ${"Fred"} ; require "./abc"; EXPECT Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at ./abc line 2. +Compilation failed in require at - line 2. ######## --FILE-- abc.pm @@ -207,6 +208,7 @@ my $a = ${"Fred"} ; use abc; EXPECT Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at abc.pm line 2. +Compilation failed in require at - line 2. BEGIN failed--compilation aborted at - line 2. ######## diff --git a/contrib/perl5/t/pragma/strict-subs b/contrib/perl5/t/pragma/strict-subs index 61ec286..ed4fe7a 100644 --- a/contrib/perl5/t/pragma/strict-subs +++ b/contrib/perl5/t/pragma/strict-subs @@ -33,6 +33,24 @@ Execution of - aborted due to compilation errors. ######## # strict subs - error +use strict 'subs' ; +my @a = (A..Z); +EXPECT +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. +######## + +# strict subs - error +use strict 'subs' ; +my $a = (B..Y); +EXPECT +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. +######## + +# strict subs - error use strict ; Fred ; EXPECT @@ -277,3 +295,25 @@ my $a = Fred ; EXPECT Bareword "Fred" not allowed while "strict subs" in use at - line 8. Execution of - aborted due to compilation errors. +######## + +# see if Foo->Bar(...) etc work under strictures +use strict; +package Foo; sub Bar { print "@_\n" } +Foo->Bar('a',1); +Bar Foo ('b',2); +Foo->Bar(qw/c 3/); +Bar Foo (qw/d 4/); +Foo::->Bar('A',1); +Bar Foo:: ('B',2); +Foo::->Bar(qw/C 3/); +Bar Foo:: (qw/D 4/); +EXPECT +Foo a 1 +Foo b 2 +Foo c 3 +Foo d 4 +Foo A 1 +Foo B 2 +Foo C 3 +Foo D 4 diff --git a/contrib/perl5/t/pragma/strict-vars b/contrib/perl5/t/pragma/strict-vars index 42107fa..ae09742 100644 --- a/contrib/perl5/t/pragma/strict-vars +++ b/contrib/perl5/t/pragma/strict-vars @@ -27,6 +27,15 @@ EXPECT # strict vars - no error use strict 'vars' ; use vars qw( $freddy) ; +BEGIN { *freddy = \$joe::shmoe; } +$freddy = 2 ; +EXPECT + +######## + +# strict vars - no error +use strict 'vars' ; +use vars qw( $freddy) ; local $abc::joe ; my $fred ; my $b = \$fred ; @@ -132,6 +141,40 @@ Compilation failed in require at - line 2. BEGIN failed--compilation aborted at - line 2. ######## +--FILE-- abc.pm +package Burp; +use strict; +$a = 1;$f = 1;$k = 1; # just to get beyond the limit... +$b = 1;$g = 1;$l = 1; +$c = 1;$h = 1;$m = 1; +$d = 1;$i = 1;$n = 1; +$e = 1;$j = 1;$o = 1; +$p = 0b12; +--FILE-- +# known scalar leak +BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } +use abc; +EXPECT +Global symbol "$f" requires explicit package name at abc.pm line 3. +Global symbol "$k" requires explicit package name at abc.pm line 3. +Global symbol "$g" requires explicit package name at abc.pm line 4. +Global symbol "$l" requires explicit package name at abc.pm line 4. +Global symbol "$c" requires explicit package name at abc.pm line 5. +Global symbol "$h" requires explicit package name at abc.pm line 5. +Global symbol "$m" requires explicit package name at abc.pm line 5. +Global symbol "$d" requires explicit package name at abc.pm line 6. +Global symbol "$i" requires explicit package name at abc.pm line 6. +Global symbol "$n" requires explicit package name at abc.pm line 6. +Global symbol "$e" requires explicit package name at abc.pm line 7. +Global symbol "$j" requires explicit package name at abc.pm line 7. +Global symbol "$o" requires explicit package name at abc.pm line 7. +Global symbol "$p" requires explicit package name at abc.pm line 8. +Illegal binary digit '2' at abc.pm line 8, at end of line +abc.pm has too many errors. +Compilation failed in require at - line 3. +BEGIN failed--compilation aborted at - line 3. +######## + # Check scope of pragma with eval no strict ; eval { @@ -165,6 +208,7 @@ print STDERR $@; $joe = 1 ; EXPECT Global symbol "$joe" requires explicit package name at - line 5. +Global symbol "$joe" requires explicit package name at - line 8. Execution of - aborted due to compilation errors. ######## @@ -221,3 +265,135 @@ $joe = 1 ; EXPECT Global symbol "$joe" requires explicit package name at - line 8. Execution of - aborted due to compilation errors. +######## + +# Check if multiple evals produce same errors +use strict 'vars'; +my $ret = eval q{ print $x; }; +print $@; +print "ok 1\n" unless defined $ret; +$ret = eval q{ print $x; }; +print $@; +print "ok 2\n" unless defined $ret; +EXPECT +Global symbol "$x" requires explicit package name at (eval 1) line 1. +ok 1 +Global symbol "$x" requires explicit package name at (eval 2) line 1. +ok 2 +######## + +# strict vars with outer our - no error +use strict 'vars' ; +our $freddy; +local $abc::joe ; +my $fred ; +my $b = \$fred ; +$Fred::ABC = 1 ; +$freddy = 2 ; +EXPECT + +######## + +# strict vars with inner our - no error +use strict 'vars' ; +sub foo { + our $fred; + $fred; +} +EXPECT + +######## + +# strict vars with outer our, inner use - no error +use strict 'vars' ; +our $fred; +sub foo { + $fred; +} +EXPECT + +######## + +# strict vars with nested our - no error +use strict 'vars' ; +our $fred; +sub foo { + our $fred; + $fred; +} +$fred ; +EXPECT + +######## + +# strict vars with elapsed our - error +use strict 'vars' ; +sub foo { + our $fred; + $fred; +} +$fred ; +EXPECT +Variable "$fred" is not imported at - line 8. +Global symbol "$fred" requires explicit package name at - line 8. +Execution of - aborted due to compilation errors. +######## + +# nested our with local - no error +$fred = 1; +use strict 'vars'; +{ + local our $fred = 2; + print $fred,"\n"; +} +print our $fred,"\n"; +EXPECT +2 +1 +######## + +# "nailed" our declaration visibility across package boundaries +use strict 'vars'; +our $foo; +$foo = 20; +package Foo; +print $foo, "\n"; +EXPECT +20 +######## + +# multiple our declarations in same scope, different packages, no warning +use strict 'vars'; +use warnings; +our $foo; +${foo} = 10; +package Foo; +our $foo = 20; +print $foo, "\n"; +EXPECT +20 +######## + +# multiple our declarations in same scope, same package, warning +use strict 'vars'; +use warnings; +our $foo; +${foo} = 10; +our $foo; +EXPECT +"our" variable $foo masks earlier declaration in same scope at - line 7. +######## + +# multiple our declarations in same scope, same package, warning +use strict 'vars'; +use warnings; +our $foo; +{ + our $foo; + package Foo; + our $foo; +} +EXPECT +"our" variable $foo redeclared at - line 7. + (Did you mean "local" instead of "our"?) +Name "Foo::foo" used only once: possible typo at - line 9. diff --git a/contrib/perl5/t/pragma/strict.t b/contrib/perl5/t/pragma/strict.t index fc32820..c4d6416 100755 --- a/contrib/perl5/t/pragma/strict.t +++ b/contrib/perl5/t/pragma/strict.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; $ENV{PERL5LIB} = '../lib'; } @@ -65,11 +65,9 @@ for (@prgs){ open TEST, ">$tmpfile"; print TEST $prog,"\n"; close TEST; - my $results = $Is_VMS ? - `MCR $^X $switch $tmpfile` : - $Is_MSWin32 ? + my $results = $Is_MSWin32 ? `.\\perl -I../lib $switch $tmpfile 2>&1` : - `sh -c './perl $switch $tmpfile' 2>&1`; + `./perl $switch $tmpfile 2>&1`; my $status = $?; $results =~ s/\n+$//; # allow expected output to be written as if $prog is on STDIN diff --git a/contrib/perl5/t/pragma/sub_lval.t b/contrib/perl5/t/pragma/sub_lval.t new file mode 100755 index 0000000..e96c329 --- /dev/null +++ b/contrib/perl5/t/pragma/sub_lval.t @@ -0,0 +1,429 @@ +print "1..46\n"; + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +sub a : lvalue { my $a = 34; bless \$a } # Return a temporary +sub b : lvalue { shift } + +my $out = a(b()); # Check that temporaries are allowed. +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. +print "# `@out'\nnot " unless @out==1; # Not reached if error. +print "ok 2\n"; + +my $in; + +# Check that we can return localized values from subroutines: + +sub in : lvalue { $in = shift; } +sub neg : lvalue { #(num_str) return num_str + local $_ = shift; + s/^\+/-/; + $_; +} +in(neg("+2")); + + +print "# `$in'\nnot " unless $in eq '-2'; +print "ok 3\n"; + +sub get_lex : lvalue { $in } +sub get_st : lvalue { $blah } +sub id : lvalue { shift } +sub id1 : lvalue { $_[0] } +sub inc : lvalue { ++$_[0] } + +$in = 5; +$blah = 3; + +get_st = 7; + +print "# `$blah' ne 7\nnot " unless $blah eq 7; +print "ok 4\n"; + +get_lex = 7; + +print "# `$in' ne 7\nnot " unless $in eq 7; +print "ok 5\n"; + +++get_st; + +print "# `$blah' ne 8\nnot " unless $blah eq 8; +print "ok 6\n"; + +++get_lex; + +print "# `$in' ne 8\nnot " unless $in eq 8; +print "ok 7\n"; + +id(get_st) = 10; + +print "# `$blah' ne 10\nnot " unless $blah eq 10; +print "ok 8\n"; + +id(get_lex) = 10; + +print "# `$in' ne 10\nnot " unless $in eq 10; +print "ok 9\n"; + +++id(get_st); + +print "# `$blah' ne 11\nnot " unless $blah eq 11; +print "ok 10\n"; + +++id(get_lex); + +print "# `$in' ne 11\nnot " unless $in eq 11; +print "ok 11\n"; + +id1(get_st) = 20; + +print "# `$blah' ne 20\nnot " unless $blah eq 20; +print "ok 12\n"; + +id1(get_lex) = 20; + +print "# `$in' ne 20\nnot " unless $in eq 20; +print "ok 13\n"; + +++id1(get_st); + +print "# `$blah' ne 21\nnot " unless $blah eq 21; +print "ok 14\n"; + +++id1(get_lex); + +print "# `$in' ne 21\nnot " unless $in eq 21; +print "ok 15\n"; + +inc(get_st); + +print "# `$blah' ne 22\nnot " unless $blah eq 22; +print "ok 16\n"; + +inc(get_lex); + +print "# `$in' ne 22\nnot " unless $in eq 22; +print "ok 17\n"; + +inc(id(get_st)); + +print "# `$blah' ne 23\nnot " unless $blah eq 23; +print "ok 18\n"; + +inc(id(get_lex)); + +print "# `$in' ne 23\nnot " unless $in eq 23; +print "ok 19\n"; + +++inc(id1(id(get_st))); + +print "# `$blah' ne 25\nnot " unless $blah eq 25; +print "ok 20\n"; + +++inc(id1(id(get_lex))); + +print "# `$in' ne 25\nnot " unless $in eq 25; +print "ok 21\n"; + +@a = (1) x 3; +@b = (undef) x 2; +$#c = 3; # These slots are not fillable. + +# Explanation: empty slots contain &sv_undef. + +=for disabled constructs + +sub a3 :lvalue {@a} +sub b2 : lvalue {@b} +sub c4: lvalue {@c} + +$_ = ''; + +eval <<'EOE' or $_ = $@; + ($x, a3, $y, b2, $z, c4, $t) = (34 .. 78); + 1; +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"; + +print "# '$_'.\nnot " + unless /Can\'t return an uninitialized value from lvalue subroutine/; +=cut + +print "ok 22\n"; + +my $var; + +sub a::var : lvalue { $var } + +"a"->var = 45; + +print "# `$var' ne 45\nnot " unless $var eq 45; +print "ok 23\n"; + +my $oo; +$o = bless \$oo, "a"; + +$o->var = 47; + +print "# `$var' ne 47\nnot " unless $var eq 47; +print "ok 24\n"; + +sub o : lvalue { $o } + +o->var = 49; + +print "# `$var' ne 49\nnot " unless $var eq 49; +print "ok 25\n"; + +sub nolv () { $x0, $x1 } # Not lvalue + +$_ = ''; + +eval <<'EOE' or $_ = $@; + nolv = (2,3); + 1; +EOE + +print "not " + unless /Can\'t modify non-lvalue subroutine call in scalar assignment/; +print "ok 26\n"; + +$_ = ''; + +eval <<'EOE' or $_ = $@; + nolv = (2,3) if $_; + 1; +EOE + +print "not " + unless /Can\'t modify non-lvalue subroutine call in scalar assignment/; +print "ok 27\n"; + +$_ = ''; + +eval <<'EOE' or $_ = $@; + &nolv = (2,3) if $_; + 1; +EOE + +print "not " + unless /Can\'t modify non-lvalue subroutine call in scalar assignment/; +print "ok 28\n"; + +$x0 = $x1 = $_ = undef; +$nolv = \&nolv; + +eval <<'EOE' or $_ = $@; + $nolv->() = (2,3) if $_; + 1; +EOE + +print "# '$_', '$x0', '$x1'.\nnot " if defined $_; +print "ok 29\n"; + +$x0 = $x1 = $_ = undef; +$nolv = \&nolv; + +eval <<'EOE' or $_ = $@; + $nolv->() = (2,3); + 1; +EOE + +print "# '$_', '$x0', '$x1'.\nnot " + unless /Can\'t modify non-lvalue subroutine call/; +print "ok 30\n"; + +sub lv0 : lvalue { } # Converted to lv10 in scalar context + +$_ = undef; +eval <<'EOE' or $_ = $@; + lv0 = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return a readonly value from lvalue subroutine/; +print "ok 31\n"; + +sub lv10 : lvalue {} + +$_ = undef; +eval <<'EOE' or $_ = $@; + (lv0) = (2,3); + 1; +EOE + +print "# '$_'.\nnot " if defined $_; +print "ok 32\n"; + +sub lv1u :lvalue { undef } + +$_ = undef; +eval <<'EOE' or $_ = $@; + lv1u = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return a readonly value from lvalue subroutine/; +print "ok 33\n"; + +$_ = undef; +eval <<'EOE' or $_ = $@; + (lv1u) = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return an uninitialized value from lvalue subroutine/; +print "ok 34\n"; + +$x = '1234567'; +sub lv1t : lvalue { index $x, 2 } + +$_ = undef; +eval <<'EOE' or $_ = $@; + lv1t = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return a temporary from lvalue subroutine/; +print "ok 35\n"; + +$_ = undef; +eval <<'EOE' or $_ = $@; + (lv1t) = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return a temporary from lvalue subroutine/; +print "ok 36\n"; + +$xxx = 'xxx'; +sub xxx () { $xxx } # Not lvalue +sub lv1tmp : lvalue { xxx } # is it a TEMP? + +$_ = undef; +eval <<'EOE' or $_ = $@; + lv1tmp = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return a temporary from lvalue subroutine/; +print "ok 37\n"; + +$_ = undef; +eval <<'EOE' or $_ = $@; + (lv1tmp) = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return a temporary from lvalue subroutine/; +print "ok 38\n"; + +sub xxx () { 'xxx' } # Not lvalue +sub lv1tmpr : lvalue { xxx } # is it a TEMP? + +$_ = undef; +eval <<'EOE' or $_ = $@; + lv1tmpr = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return a readonly value from lvalue subroutine/; +print "ok 39\n"; + +$_ = undef; +eval <<'EOE' or $_ = $@; + (lv1tmpr) = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return a readonly value from lvalue subroutine/; +print "ok 40\n"; + +=for disabled constructs + +sub lva : lvalue {@a} + +$_ = undef; +@a = (); +$a[1] = 12; +eval <<'EOE' or $_ = $@; + (lva) = (2,3); + 1; +EOE + +print "# '$_'.\nnot " + unless /Can\'t return an uninitialized value from lvalue subroutine/; +print "ok 41\n"; + +$_ = undef; +@a = (); +$a[0] = undef; +$a[1] = 12; +eval <<'EOE' or $_ = $@; + (lva) = (2,3); + 1; +EOE + +print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; +print "ok 42\n"; + +$_ = undef; +@a = (); +$a[0] = undef; +$a[1] = 12; +eval <<'EOE' or $_ = $@; + (lva) = (2,3); + 1; +EOE + +print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; +print "ok 43\n"; + +=cut + +print "ok $_\n" for 41..43; + +sub lv1n : lvalue { $newvar } + +$_ = undef; +eval <<'EOE' or $_ = $@; + lv1n = (3,4); + 1; +EOE + +print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' "; +print "ok 44\n"; + +sub lv1nn : lvalue { $nnewvar } + +$_ = undef; +eval <<'EOE' or $_ = $@; + (lv1nn) = (3,4); + 1; +EOE + +print "# '$_'.\nnot " unless "'$nnewvar' $_" eq "'3' "; +print "ok 45\n"; + +$a = \&lv1nn; +$a->() = 8; +print "# '$nnewvar'.\nnot " unless $nnewvar eq '8'; +print "ok 46\n"; diff --git a/contrib/perl5/t/pragma/subs.t b/contrib/perl5/t/pragma/subs.t index 6ebbf78..fe84f5e 100755 --- a/contrib/perl5/t/pragma/subs.t +++ b/contrib/perl5/t/pragma/subs.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; $ENV{PERL5LIB} = '../lib'; } @@ -46,10 +46,10 @@ for (@prgs){ print TEST $prog,"\n"; close TEST; my $results = $Is_VMS ? - `MCR $^X $switch $tmpfile` : + `./perl $switch $tmpfile 2>&1` : $Is_MSWin32 ? `.\\perl -I../lib $switch $tmpfile 2>&1` : - `sh -c './perl $switch $tmpfile' 2>&1`; + `./perl $switch $tmpfile 2>&1`; my $status = $?; $results =~ s/\n+$//; # allow expected output to be written as if $prog is on STDIN diff --git a/contrib/perl5/t/pragma/utf8.t b/contrib/perl5/t/pragma/utf8.t new file mode 100755 index 0000000..0e55a67 --- /dev/null +++ b/contrib/perl5/t/pragma/utf8.t @@ -0,0 +1,253 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + $ENV{PERL5LIB} = '../lib'; + if ( ord("\t") != 9 ) { # skip on ebcdic platforms + print "1..0 # Skip utf8 tests on ebcdic platform.\n"; + exit; + } +} + +print "1..60\n"; + +my $test = 1; + +sub ok { + my ($got,$expect) = @_; + print "# expected [$expect], got [$got]\nnot " if $got ne $expect; + print "ok $test\n"; +} + +{ + use utf8; + $_ = ">\x{263A}<"; + s/([\x{80}-\x{10ffff}])/"&#".ord($1).";"/eg; + ok $_, '>☺<'; + $test++; + + $_ = ">\x{263A}<"; + my $rx = "\x{80}-\x{10ffff}"; + s/([$rx])/"&#".ord($1).";"/eg; + ok $_, '>☺<'; + $test++; + + $_ = ">\x{263A}<"; + my $rx = "\\x{80}-\\x{10ffff}"; + s/([$rx])/"&#".ord($1).";"/eg; + ok $_, '>☺<'; + $test++; + + $_ = "alpha,numeric"; + m/([[:alpha:]]+)/; + ok $1, 'alpha'; + $test++; + + $_ = "alphaNUMERICstring"; + m/([[:^lower:]]+)/; + ok $1, 'NUMERIC'; + $test++; + + $_ = "alphaNUMERICstring"; + m/(\p{Ll}+)/; + ok $1, 'alpha'; + $test++; + + $_ = "alphaNUMERICstring"; + m/(\p{Lu}+)/; + ok $1, 'NUMERIC'; + $test++; + + $_ = "alpha,numeric"; + m/([\p{IsAlpha}]+)/; + ok $1, 'alpha'; + $test++; + + $_ = "alphaNUMERICstring"; + m/([^\p{IsLower}]+)/; + ok $1, 'NUMERIC'; + $test++; + + $_ = "alpha123numeric456"; + m/([\p{IsDigit}]+)/; + ok $1, '123'; + $test++; + + $_ = "alpha123numeric456"; + m/([^\p{IsDigit}]+)/; + ok $1, 'alpha'; + $test++; + + $_ = ",123alpha,456numeric"; + m/([\p{IsAlnum}]+)/; + ok $1, '123alpha'; + $test++; +} +{ + use utf8; + + $_ = "\x{263A}>\x{263A}\x{263A}"; + + ok length, 4; + $test++; + + ok length((m/>(.)/)[0]), 1; + $test++; + + ok length($&), 2; + $test++; + + ok length($'), 1; + $test++; + + ok length($`), 1; + $test++; + + ok length($1), 1; + $test++; + + ok length($tmp=$&), 2; + $test++; + + ok length($tmp=$'), 1; + $test++; + + ok length($tmp=$`), 1; + $test++; + + ok length($tmp=$1), 1; + $test++; + + ok $&, pack("C*", ord(">"), 0342, 0230, 0272); + $test++; + + ok $', pack("C*", 0342, 0230, 0272); + $test++; + + ok $`, pack("C*", 0342, 0230, 0272); + $test++; + + ok $1, pack("C*", 0342, 0230, 0272); + $test++; + + { + use bytes; + no utf8; + + ok length, 10; + $test++; + + ok length((m/>(.)/)[0]), 1; + $test++; + + ok length($&), 2; + $test++; + + ok length($'), 5; + $test++; + + ok length($`), 3; + $test++; + + ok length($1), 1; + $test++; + + ok $&, pack("C*", ord(">"), 0342); + $test++; + + ok $', pack("C*", 0230, 0272, 0342, 0230, 0272); + $test++; + + ok $`, pack("C*", 0342, 0230, 0272); + $test++; + + ok $1, pack("C*", 0342); + $test++; + + } + + + { + no utf8; + $_="\342\230\272>\342\230\272\342\230\272"; + } + + ok length, 10; + $test++; + + ok length((m/>(.)/)[0]), 1; + $test++; + + ok length($&), 2; + $test++; + + ok length($'), 1; + $test++; + + ok length($`), 1; + $test++; + + ok length($1), 1; + $test++; + + ok length($tmp=$&), 2; + $test++; + + ok length($tmp=$'), 1; + $test++; + + ok length($tmp=$`), 1; + $test++; + + ok length($tmp=$1), 1; + $test++; + + ok $&, pack("C*", ord(">"), 0342, 0230, 0272); + $test++; + + ok $', pack("C*", 0342, 0230, 0272); + $test++; + + ok $`, pack("C*", 0342, 0230, 0272); + $test++; + + ok $1, pack("C*", 0342, 0230, 0272); + $test++; + + { + use bytes; + no utf8; + + ok length, 10; + $test++; + + ok length((m/>(.)/)[0]), 1; + $test++; + + ok length($&), 2; + $test++; + + ok length($'), 5; + $test++; + + ok length($`), 3; + $test++; + + ok length($1), 1; + $test++; + + ok $&, pack("C*", ord(">"), 0342); + $test++; + + ok $', pack("C*", 0230, 0272, 0342, 0230, 0272); + $test++; + + ok $`, pack("C*", 0342, 0230, 0272); + $test++; + + ok $1, pack("C*", 0342); + $test++; + + } +} diff --git a/contrib/perl5/t/pragma/warn/1global b/contrib/perl5/t/pragma/warn/1global new file mode 100644 index 0000000..0af8022 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/1global @@ -0,0 +1,189 @@ +Check existing $^W functionality + + +__END__ + +# warnable code, warnings disabled +$a =+ 3 ; +EXPECT + +######## +-w +# warnable code, warnings enabled via command line switch +$a =+ 3 ; +EXPECT +Reversed += operator at - line 3. +Name "main::a" used only once: possible typo at - line 3. +######## +#! perl -w +# warnable code, warnings enabled via #! line +$a =+ 3 ; +EXPECT +Reversed += operator at - line 3. +Name "main::a" used only once: possible typo at - line 3. +######## + +# warnable code, warnings enabled via compile time $^W +BEGIN { $^W = 1 } +$a =+ 3 ; +EXPECT +Reversed += operator at - line 4. +Name "main::a" used only once: possible typo at - line 4. +######## + +# compile-time warnable code, warnings enabled via runtime $^W +# so no warning printed. +$^W = 1 ; +$a =+ 3 ; +EXPECT + +######## + +# warnable code, warnings enabled via runtime $^W +$^W = 1 ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 4. +######## + +# warnings enabled at compile time, disabled at run time +BEGIN { $^W = 1 } +$^W = 0 ; +my $b ; chop $b ; +EXPECT + +######## + +# warnings disabled at compile time, enabled at run time +BEGIN { $^W = 0 } +$^W = 1 ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 5. +######## +-w +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +require "./abcd"; +EXPECT +Use of uninitialized value in scalar chop at ./abcd line 1. +######## + +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +#! perl -w +require "./abcd"; +EXPECT +Use of uninitialized value in scalar chop at ./abcd line 1. +######## + +--FILE-- abcd +my $b ; chop $b ; +1 ; +--FILE-- +$^W =1 ; +require "./abcd"; +EXPECT +Use of uninitialized value in scalar chop at ./abcd line 1. +######## + +--FILE-- abcd +$^W = 0; +my $b ; chop $b ; +1 ; +--FILE-- +$^W =1 ; +require "./abcd"; +EXPECT + +######## + +--FILE-- abcd +$^W = 1; +1 ; +--FILE-- +$^W =0 ; +require "./abcd"; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 3. +######## + +$^W = 1; +eval 'my $b ; chop $b ;' ; +print $@ ; +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 1. +######## + +eval '$^W = 1;' ; +print $@ ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 4. +######## + +eval {$^W = 1;} ; +print $@ ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 4. +######## + +{ + local ($^W) = 1; +} +my $b ; chop $b ; +EXPECT + +######## + +my $a ; chop $a ; +{ + local ($^W) = 1; + my $b ; chop $b ; +} +my $c ; chop $c ; +EXPECT +Use of uninitialized value in scalar chop at - line 5. +######## +-w +-e undef +EXPECT +Use of uninitialized value in -e at - line 2. +######## + +$^W = 1 + 2 ; +EXPECT + +######## + +$^W = $a ; +EXPECT + +######## + +sub fred {} +$^W = fred() ; +EXPECT + +######## + +sub fred { my $b ; chop $b ;} +{ local $^W = 0 ; + fred() ; +} +EXPECT + +######## + +sub fred { my $b ; chop $b ;} +{ local $^W = 1 ; + fred() ; +} +EXPECT +Use of uninitialized value in scalar chop at - line 2. diff --git a/contrib/perl5/t/pragma/warn/2use b/contrib/perl5/t/pragma/warn/2use new file mode 100644 index 0000000..60a60c3 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/2use @@ -0,0 +1,308 @@ +Check lexical warnings functionality + +TODO + check that the warning hierarchy works. + +__END__ + +# check illegal category is caught +use warnings 'this-should-never-be-a-warning-category' ; +EXPECT +unknown warnings category 'this-should-never-be-a-warning-category' at - line 3 +BEGIN failed--compilation aborted at - line 3. +######## + +# Check compile time scope of pragma +use warnings 'deprecated' ; +{ + no warnings ; + 1 if $a EQ $b ; +} +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 8. +######## + +# Check compile time scope of pragma +no warnings; +{ + use warnings 'deprecated' ; + 1 if $a EQ $b ; +} +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 6. +######## + +# Check runtime scope of pragma +use warnings 'uninitialized' ; +{ + no warnings ; + my $b ; chop $b ; +} +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 8. +######## + +# Check runtime scope of pragma +no warnings ; +{ + use warnings 'uninitialized' ; + my $b ; chop $b ; +} +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check runtime scope of pragma +no warnings ; +{ + use warnings 'uninitialized' ; + $a = sub { my $b ; chop $b ; } +} +&$a ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +use warnings 'deprecated' ; +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 3. +######## + +--FILE-- abc +1 if $a EQ $b ; +1; +--FILE-- +use warnings 'deprecated' ; +require "./abc"; +EXPECT + +######## + +--FILE-- abc +use warnings 'deprecated' ; +1; +--FILE-- +require "./abc"; +1 if $a EQ $b ; +EXPECT + +######## + +--FILE-- abc +use warnings 'deprecated' ; +1 if $a EQ $b ; +1; +--FILE-- +use warnings 'uninitialized' ; +require "./abc"; +my $a ; chop $a ; +EXPECT +Use of EQ is deprecated at ./abc line 2. +Use of uninitialized value in scalar chop at - line 3. +######## + +--FILE-- abc.pm +use warnings 'deprecated' ; +1 if $a EQ $b ; +1; +--FILE-- +use warnings 'uninitialized' ; +use abc; +my $a ; chop $a ; +EXPECT +Use of EQ is deprecated at abc.pm line 2. +Use of uninitialized value in scalar chop at - line 3. +######## + +# Check scope of pragma with eval +no warnings ; +eval { + my $b ; chop $b ; +}; print STDERR $@ ; +my $b ; chop $b ; +EXPECT + +######## + +# Check scope of pragma with eval +no warnings ; +eval { + use warnings 'uninitialized' ; + my $b ; chop $b ; +}; print STDERR $@ ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check scope of pragma with eval +use warnings 'uninitialized' ; +eval { + my $b ; chop $b ; +}; print STDERR $@ ; +my $b ; chop $b ; +EXPECT +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 +use warnings 'uninitialized' ; +eval { + no warnings ; + my $b ; chop $b ; +}; print STDERR $@ ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 8. +######## + +# Check scope of pragma with eval +no warnings ; +eval { + 1 if $a EQ $b ; +}; print STDERR $@ ; +1 if $a EQ $b ; +EXPECT + +######## + +# Check scope of pragma with eval +no warnings ; +eval { + use warnings 'deprecated' ; + 1 if $a EQ $b ; +}; print STDERR $@ ; +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 6. +######## + +# Check scope of pragma with eval +use warnings 'deprecated' ; +eval { + 1 if $a EQ $b ; +}; print STDERR $@ ; +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 5. +Use of EQ is deprecated at - line 7. +######## + +# Check scope of pragma with eval +use warnings 'deprecated' ; +eval { + no warnings ; + 1 if $a EQ $b ; +}; print STDERR $@ ; +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 8. +######## + +# Check scope of pragma with eval +no warnings ; +eval ' + my $b ; chop $b ; +'; print STDERR $@ ; +my $b ; chop $b ; +EXPECT + +######## + +# Check scope of pragma with eval +no warnings ; +eval q[ + use warnings 'uninitialized' ; + my $b ; chop $b ; +]; print STDERR $@; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at (eval 1) line 3. +######## + +# Check scope of pragma with eval +use warnings 'uninitialized' ; +eval ' + my $b ; chop $b ; +'; print STDERR $@ ; +my $b ; chop $b ; +EXPECT +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 +use warnings 'uninitialized' ; +eval ' + no warnings ; + my $b ; chop $b ; +'; print STDERR $@ ; +my $b ; chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 8. +######## + +# Check scope of pragma with eval +no warnings ; +eval ' + 1 if $a EQ $b ; +'; print STDERR $@ ; +1 if $a EQ $b ; +EXPECT + +######## + +# Check scope of pragma with eval +no warnings ; +eval q[ + use warnings 'deprecated' ; + 1 if $a EQ $b ; +]; print STDERR $@; +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at (eval 1) line 3. +######## + +# Check scope of pragma with eval +use warnings 'deprecated' ; +eval ' + 1 if $a EQ $b ; +'; print STDERR $@; +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 7. +Use of EQ is deprecated at (eval 1) line 2. +######## + +# Check scope of pragma with eval +use warnings 'deprecated' ; +eval ' + no warnings ; + 1 if $a EQ $b ; +'; print STDERR $@; +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 8. +######## + +# Check the additive nature of the pragma +1 if $a EQ $b ; +my $a ; chop $a ; +use warnings 'deprecated' ; +1 if $a EQ $b ; +my $b ; chop $b ; +use warnings 'uninitialized' ; +my $c ; chop $c ; +no warnings 'deprecated' ; +1 if $a EQ $b ; +EXPECT +Use of EQ is deprecated at - line 6. +Use of uninitialized value in scalar chop at - line 9. +Use of uninitialized value in string eq at - line 11. +Use of uninitialized value in string eq at - line 11. diff --git a/contrib/perl5/t/pragma/warn/3both b/contrib/perl5/t/pragma/warn/3both new file mode 100644 index 0000000..132b99b --- /dev/null +++ b/contrib/perl5/t/pragma/warn/3both @@ -0,0 +1,197 @@ +Check interaction of $^W and lexical + +__END__ + +# Check interaction of $^W and use warnings +sub fred { + use warnings ; + my $b ; + chop $b ; +} +{ local $^W = 0 ; + fred() ; +} + +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check interaction of $^W and use warnings +sub fred { + use warnings ; + my $b ; + chop $b ; +} +{ $^W = 0 ; + fred() ; +} + +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check interaction of $^W and use warnings +sub fred { + no warnings ; + my $b ; + chop $b ; +} +{ local $^W = 1 ; + fred() ; +} + +EXPECT + +######## + +# Check interaction of $^W and use warnings +sub fred { + no warnings ; + my $b ; + chop $b ; +} +{ $^W = 1 ; + fred() ; +} + +EXPECT + +######## + +# Check interaction of $^W and use warnings +use warnings ; +$^W = 1 ; +my $b ; +chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check interaction of $^W and use warnings +$^W = 1 ; +use warnings ; +my $b ; +chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check interaction of $^W and use warnings +$^W = 1 ; +no warnings ; +my $b ; +chop $b ; +EXPECT + +######## + +# Check interaction of $^W and use warnings +no warnings ; +$^W = 1 ; +my $b ; +chop $b ; +EXPECT + +######## +-w +# Check interaction of $^W and use warnings +no warnings ; +my $b ; +chop $b ; +EXPECT + +######## +-w +# Check interaction of $^W and use warnings +use warnings ; +my $b ; +chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 5. +######## + +# Check interaction of $^W and use warnings +sub fred { + use warnings ; + my $b ; + chop $b ; +} +BEGIN { $^W = 0 } +fred() ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check interaction of $^W and use warnings +sub fred { + no warnings ; + my $b ; + chop $b ; +} +BEGIN { $^W = 1 } +fred() ; + +EXPECT + +######## + +# Check interaction of $^W and use warnings +use warnings ; +BEGIN { $^W = 1 } +my $b ; +chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check interaction of $^W and use warnings +BEGIN { $^W = 1 } +use warnings ; +my $b ; +chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +# Check interaction of $^W and use warnings +BEGIN { $^W = 1 } +no warnings ; +my $b ; +chop $b ; +EXPECT + +######## + +# Check interaction of $^W and use warnings +no warnings ; +BEGIN { $^W = 1 } +my $b ; +chop $b ; +EXPECT + +######## + +# Check interaction of $^W and use warnings +BEGIN { $^W = 1 } +{ + no warnings ; + my $b ; + chop $b ; +} +my $b ; +chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 10. +######## + +# Check interaction of $^W and use warnings +BEGIN { $^W = 0 } +{ + use warnings ; + my $b ; + chop $b ; +} +my $b ; +chop $b ; +EXPECT +Use of uninitialized value in scalar chop at - line 7. diff --git a/contrib/perl5/t/pragma/warn/4lint b/contrib/perl5/t/pragma/warn/4lint new file mode 100644 index 0000000..db54f31 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/4lint @@ -0,0 +1,112 @@ +Check lint + +__END__ +-W +# lint: check compile time $^W is zapped +BEGIN { $^W = 0 ;} +$a = $b = 1 ; +$a = 1 if $a EQ $b ; +close STDIN ; print STDIN "abc" ; +EXPECT +Use of EQ is deprecated at - line 5. +print() on closed filehandle main::STDIN at - line 6. +######## +-W +# lint: check runtime $^W is zapped +$^W = 0 ; +close STDIN ; print STDIN "abc" ; +EXPECT +print() on closed filehandle main::STDIN at - line 4. +######## +-W +# lint: check runtime $^W is zapped +{ + $^W = 0 ; + close STDIN ; print STDIN "abc" ; +} +EXPECT +print() on closed filehandle main::STDIN at - line 5. +######## +-W +# lint: check "no warnings" is zapped +no warnings ; +$a = $b = 1 ; +$a = 1 if $a EQ $b ; +close STDIN ; print STDIN "abc" ; +EXPECT +Use of EQ is deprecated at - line 5. +print() on closed filehandle main::STDIN at - line 6. +######## +-W +# lint: check "no warnings" is zapped +{ + no warnings ; + close STDIN ; print STDIN "abc" ; +} +EXPECT +print() on closed filehandle main::STDIN at - line 5. +######## +-Ww +# lint: check combination of -w and -W +{ + $^W = 0 ; + close STDIN ; print STDIN "abc" ; +} +EXPECT +print() on closed filehandle main::STDIN at - line 5. +######## +-W +--FILE-- abc.pm +no warnings 'deprecated' ; +my ($a, $b) = (0,0); +1 if $a EQ $b ; +1; +--FILE-- +no warnings 'uninitialized' ; +use abc; +my $a ; chop $a ; +EXPECT +Use of EQ is deprecated at abc.pm line 3. +Use of uninitialized value in scalar chop at - line 3. +######## +-W +--FILE-- abc +no warnings 'deprecated' ; +my ($a, $b) = (0,0); +1 if $a EQ $b ; +1; +--FILE-- +no warnings 'uninitialized' ; +require "./abc"; +my $a ; chop $a ; +EXPECT +Use of EQ is deprecated at ./abc line 3. +Use of uninitialized value in scalar chop at - line 3. +######## +-W +--FILE-- abc.pm +BEGIN {$^W = 0} +my ($a, $b) = (0,0); +1 if $a EQ $b ; +1; +--FILE-- +$^W = 0 ; +use abc; +my $a ; chop $a ; +EXPECT +Use of EQ is deprecated at abc.pm line 3. +Use of uninitialized value in scalar chop at - line 3. +######## +-W +--FILE-- abc +BEGIN {$^W = 0} +my ($a, $b) = (0,0); +1 if $a EQ $b ; +1; +--FILE-- +$^W = 0 ; +require "./abc"; +my $a ; chop $a ; +EXPECT +Use of EQ is deprecated at ./abc line 3. +Use of uninitialized value in scalar chop at - line 3. diff --git a/contrib/perl5/t/pragma/warn/5nolint b/contrib/perl5/t/pragma/warn/5nolint new file mode 100644 index 0000000..994190a --- /dev/null +++ b/contrib/perl5/t/pragma/warn/5nolint @@ -0,0 +1,96 @@ +Check anti-lint + +__END__ +-X +# nolint: check compile time $^W is zapped +BEGIN { $^W = 1 ;} +$a = $b = 1 ; +$a = 1 if $a EQ $b ; +close STDIN ; print STDIN "abc" ; +EXPECT +######## +-X +# nolint: check runtime $^W is zapped +$^W = 1 ; +close STDIN ; print STDIN "abc" ; +EXPECT +######## +-X +# nolint: check runtime $^W is zapped +{ + $^W = 1 ; + close STDIN ; print STDIN "abc" ; +} +EXPECT +######## +-X +# nolint: check "no warnings" is zapped +use warnings ; +$a = $b = 1 ; +$a = 1 if $a EQ $b ; +close STDIN ; print STDIN "abc" ; +EXPECT +######## +-X +# nolint: check "no warnings" is zapped +{ + use warnings ; + close STDIN ; print STDIN "abc" ; +} +EXPECT +######## +-Xw +# nolint: check combination of -w and -X +{ + $^W = 1 ; + close STDIN ; print STDIN "abc" ; +} +EXPECT +######## +-X +--FILE-- abc.pm +use warnings 'deprecated' ; +my ($a, $b) = (0,0); +1 if $a EQ $b ; +1; +--FILE-- +use warnings 'uninitialized' ; +use abc; +my $a ; chop $a ; +EXPECT +######## +-X +--FILE-- abc +use warnings 'deprecated' ; +my ($a, $b) = (0,0); +1 if $a EQ $b ; +1; +--FILE-- +use warnings 'uninitialized' ; +require "./abc"; +my $a ; chop $a ; +EXPECT +######## +-X +--FILE-- abc.pm +BEGIN {$^W = 1} +my ($a, $b) = (0,0); +1 if $a EQ $b ; +1; +--FILE-- +$^W = 1 ; +use abc; +my $a ; chop $a ; +EXPECT +######## +-X +--FILE-- abc +BEGIN {$^W = 1} +my ($a, $b) = (0,0); +1 if $a EQ $b ; +1; +--FILE-- +$^W = 1 ; +require "./abc"; +my $a ; chop $a ; +EXPECT diff --git a/contrib/perl5/t/pragma/warn/6default b/contrib/perl5/t/pragma/warn/6default new file mode 100644 index 0000000..dd3d182 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/6default @@ -0,0 +1,53 @@ +Check default warnings + +__END__ +# default warnings should be displayed if you don't add anything +# optional shouldn't +my $a = oct "7777777777777777777777777777777777779" ; +EXPECT +Integer overflow in octal number at - line 3. +######## +# no warnings should be displayed +no warnings ; +my $a = oct "7777777777777777777777777777777777778" ; +EXPECT +######## +# all warnings should be displayed +use warnings ; +my $a = oct "7777777777777777777777777777777777778" ; +EXPECT +Integer overflow in octal number at - line 3. +Illegal octal digit '8' ignored at - line 3. +Octal number > 037777777777 non-portable at - line 3. +######## +# check scope +use warnings ; +my $a = oct "7777777777777777777777777777777777778" ; +{ + no warnings ; + my $a = oct "7777777777777777777777777777777777778" ; +} +my $c = oct "7777777777777777777777777777777777778" ; +EXPECT +Integer overflow in octal number at - line 3. +Illegal octal digit '8' ignored at - line 3. +Octal number > 037777777777 non-portable at - line 3. +Integer overflow in octal number at - line 8. +Illegal octal digit '8' ignored at - line 8. +Octal number > 037777777777 non-portable at - line 8. +######## +# all warnings should be displayed +use warnings ; +my $a = oct "0xfffffffffffffffffg" ; +EXPECT +Integer overflow in hexadecimal number at - line 3. +Illegal hexadecimal digit 'g' ignored at - line 3. +Hexadecimal number > 0xffffffff non-portable at - line 3. +######## +# all warnings should be displayed +use warnings ; +my $a = oct "0b111111111111111111111111111111111111111111111111111111111111111112"; +EXPECT +Integer overflow in binary number at - line 3. +Illegal binary digit '2' ignored at - line 3. +Binary number > 0b11111111111111111111111111111111 non-portable at - line 3. diff --git a/contrib/perl5/t/pragma/warn/7fatal b/contrib/perl5/t/pragma/warn/7fatal new file mode 100644 index 0000000..943bb06f --- /dev/null +++ b/contrib/perl5/t/pragma/warn/7fatal @@ -0,0 +1,242 @@ +Check FATAL functionality + +__END__ + +# Check compile time warning +use warnings FATAL => 'deprecated' ; +{ + no warnings ; + 1 if $a EQ $b ; +} +1 if $a EQ $b ; +print STDERR "The End.\n" ; +EXPECT +Use of EQ is deprecated at - line 8. +######## + +# Check runtime scope of pragma +use warnings FATAL => 'uninitialized' ; +{ + no warnings ; + my $b ; chop $b ; +} +my $b ; chop $b ; +print STDERR "The End.\n" ; +EXPECT +Use of uninitialized value in scalar chop at - line 8. +######## + +# Check runtime scope of pragma +no warnings ; +{ + use warnings FATAL => 'uninitialized' ; + $a = sub { my $b ; chop $b ; } +} +&$a ; +print STDERR "The End.\n" ; +EXPECT +Use of uninitialized value in scalar chop at - line 6. +######## + +--FILE-- abc +1 if $a EQ $b ; +1; +--FILE-- +use warnings FATAL => 'deprecated' ; +require "./abc"; +EXPECT + +######## + +--FILE-- abc +use warnings FATAL => 'deprecated' ; +1; +--FILE-- +require "./abc"; +1 if $a EQ $b ; +EXPECT + +######## + +--FILE-- abc +use warnings 'deprecated' ; +1 if $a EQ $b ; +1; +--FILE-- +use warnings FATAL => 'uninitialized' ; +require "./abc"; +my $a ; chop $a ; +print STDERR "The End.\n" ; +EXPECT +Use of EQ is deprecated at ./abc line 2. +Use of uninitialized value in scalar chop at - line 3. +######## + +--FILE-- abc.pm +use warnings 'deprecated' ; +1 if $a EQ $b ; +1; +--FILE-- +use warnings FATAL => 'uninitialized' ; +use abc; +my $a ; chop $a ; +print STDERR "The End.\n" ; +EXPECT +Use of EQ is deprecated at abc.pm line 2. +Use of uninitialized value in scalar chop at - line 3. +######## + +# Check scope of pragma with eval +no warnings ; +eval { + use warnings FATAL => 'uninitialized' ; + my $b ; chop $b ; +}; print STDERR "-- $@" ; +my $b ; chop $b ; +print STDERR "The End.\n" ; +EXPECT +-- Use of uninitialized value in scalar chop at - line 6. +The End. +######## + +# Check scope of pragma with eval +use warnings FATAL => 'uninitialized' ; +eval { + my $b ; chop $b ; +}; print STDERR "-- $@" ; +my $b ; chop $b ; +print STDERR "The End.\n" ; +EXPECT +-- 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 +use warnings FATAL => 'uninitialized' ; +eval { + no warnings ; + my $b ; chop $b ; +}; print STDERR $@ ; +my $b ; chop $b ; +print STDERR "The End.\n" ; +EXPECT +Use of uninitialized value in scalar chop at - line 8. +######## + +# Check scope of pragma with eval +no warnings ; +eval { + use warnings FATAL => 'deprecated' ; + 1 if $a EQ $b ; +}; print STDERR "-- $@" ; +1 if $a EQ $b ; +print STDERR "The End.\n" ; +EXPECT +Use of EQ is deprecated at - line 6. +######## + +# Check scope of pragma with eval +use warnings FATAL => 'deprecated' ; +eval { + 1 if $a EQ $b ; +}; print STDERR "-- $@" ; +1 if $a EQ $b ; +print STDERR "The End.\n" ; +EXPECT +Use of EQ is deprecated at - line 5. +######## + +# Check scope of pragma with eval +use warnings FATAL => 'deprecated' ; +eval { + no warnings ; + 1 if $a EQ $b ; +}; print STDERR $@ ; +1 if $a EQ $b ; +print STDERR "The End.\n" ; +EXPECT +Use of EQ is deprecated at - line 8. +######## + +# Check scope of pragma with eval +no warnings ; +eval { + use warnings FATAL => 'deprecated' ; +}; print STDERR $@ ; +1 if $a EQ $b ; +print STDERR "The End.\n" ; +EXPECT +The End. +######## + +# Check scope of pragma with eval +no warnings ; +eval q[ + use warnings FATAL => 'uninitialized' ; + my $b ; chop $b ; +]; print STDERR "-- $@"; +my $b ; chop $b ; +print STDERR "The End.\n" ; +EXPECT +-- Use of uninitialized value in scalar chop at (eval 1) line 3. +The End. +######## + +# Check scope of pragma with eval +use warnings FATAL => 'uninitialized' ; +eval ' + my $b ; chop $b ; +'; print STDERR "-- $@" ; +my $b ; chop $b ; +print STDERR "The End.\n" ; +EXPECT +-- 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 +use warnings FATAL => 'uninitialized' ; +eval ' + no warnings ; + my $b ; chop $b ; +'; print STDERR $@ ; +my $b ; chop $b ; +print STDERR "The End.\n" ; +EXPECT +Use of uninitialized value in scalar chop at - line 8. +######## + +# Check scope of pragma with eval +no warnings ; +eval q[ + use warnings FATAL => 'deprecated' ; + 1 if $a EQ $b ; +]; print STDERR "-- $@"; +1 if $a EQ $b ; +print STDERR "The End.\n" ; +EXPECT +-- Use of EQ is deprecated at (eval 1) line 3. +The End. +######## + +# Check scope of pragma with eval +use warnings FATAL => 'deprecated' ; +eval ' + 1 if $a EQ $b ; +'; print STDERR "-- $@"; +print STDERR "The End.\n" ; +EXPECT +-- Use of EQ is deprecated at (eval 1) line 2. +The End. +######## + +# Check scope of pragma with eval +use warnings FATAL => 'deprecated' ; +eval ' + no warnings ; + 1 if $a EQ $b ; +'; print STDERR "-- $@"; +1 if $a EQ $b ; +print STDERR "The End.\n" ; +EXPECT +Use of EQ is deprecated at - line 8. diff --git a/contrib/perl5/t/pragma/warn/8signal b/contrib/perl5/t/pragma/warn/8signal new file mode 100644 index 0000000..d480f19 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/8signal @@ -0,0 +1,18 @@ +Check interaction of __WARN__, __DIE__ & lexical Warnings + +TODO + +__END__ +# 8signal +BEGIN { $| = 1; $SIG{__WARN__} = sub { print "WARN -- @_" } } +BEGIN { $SIG{__DIE__} = sub { print "DIE -- @_" } } +1 if 1 EQ 2 ; +use warnings qw(deprecated) ; +1 if 1 EQ 2 ; +use warnings FATAL => qw(deprecated) ; +1 if 1 EQ 2 ; +print "The End.\n" ; +EXPECT +WARN -- Use of EQ is deprecated at - line 6. +DIE -- Use of EQ is deprecated at - line 8. +Use of EQ is deprecated at - line 8. diff --git a/contrib/perl5/t/pragma/warn/9enabled b/contrib/perl5/t/pragma/warn/9enabled new file mode 100755 index 0000000..7facf99 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/9enabled @@ -0,0 +1,819 @@ +Check warnings::enabled & warnings::warn + +__END__ + +--FILE-- abc.pm +package abc ; +use warnings "io" ; +print "ok1\n" if ! warnings::enabled('all') ; +print "ok2\n" if ! warnings::enabled("io") ; +1; +--FILE-- +no warnings; +use abc ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +print "ok1\n" if !warnings::enabled('all') ; +print "ok2\n" if warnings::enabled("syntax") ; +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'syntax' ; +print "ok1\n" if warnings::enabled('io') ; +print "ok2\n" if ! warnings::enabled("syntax") ; +1; +--FILE-- +use warnings 'io' ; +use abc ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc +no warnings ; +print "ok1\n" if !warnings::enabled('all') ; +print "ok2\n" if warnings::enabled("syntax") ; +1; +--FILE-- +use warnings 'syntax' ; +require "abc" ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc +use warnings 'syntax' ; +print "ok1\n" if ! warnings::enabled('all') ; +print "ok2\n" if ! warnings::enabled("syntax") ; +print "ok3\n" if warnings::enabled("io") ; +1; +--FILE-- +use warnings 'io' ; +require "abc" ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +sub check { + print "ok1\n" if !warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +sub check { + print "ok1\n" if ! warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if ! warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc +package abc ; +no warnings ; +sub check { + print "ok1\n" if !warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; +} +1; +--FILE-- +use warnings 'syntax' ; +require "abc" ; +abc::check() ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc +package abc ; +use warnings 'io' ; +sub check { + print "ok1\n" if ! warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if ! warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +require "abc" ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings "io" ; +print "ok1\n" if ! warnings::enabled('all') ; +print "ok2\n" if ! warnings::enabled("io") ; +1; +--FILE-- def.pm +no warnings; +use abc ; +1; +--FILE-- +use warnings; +use def ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +print "ok1\n" if ! warnings::enabled('all') ; +print "ok2\n" if warnings::enabled("syntax") ; +print "ok3\n" if !warnings::enabled("io") ; +1; +--FILE-- def.pm +use warnings 'syntax' ; +print "ok4\n" if !warnings::enabled('all') ; +print "ok5\n" if warnings::enabled("io") ; +use abc ; +1; +--FILE-- +use warnings 'io' ; +use def ; +EXPECT +ok1 +ok2 +ok3 +ok4 +ok5 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +sub check { + print "ok1\n" if !warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +eval { abc::check() ; }; +print $@ ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +sub check { + print "ok1\n" if ! warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if ! warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +eval { abc::check() ; } ; +print $@ ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc +package abc ; +no warnings ; +sub check { + print "ok1\n" if !warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; +} +1; +--FILE-- +use warnings 'syntax' ; +require "abc" ; +eval { abc::check() ; } ; +print $@ ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc +package abc ; +use warnings 'io' ; +sub check { + print "ok1\n" if !warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +require "abc" ; +eval { use warnings 'io' ; abc::check() ; }; +abc::check() ; +print $@ ; +EXPECT +ok1 +ok2 +ok3 +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +sub check { + print "ok1\n" if ! warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if ! warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +sub fred { abc::check() } +fred() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +sub check { + print "ok1\n" if ! warnings::enabled('all') ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +sub fred { no warnings ; abc::check() } +fred() ; +EXPECT +ok1 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'misc' ; +sub check { + print "ok1\n" if ! warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if warnings::enabled("io") ; + print "ok4\n" if ! warnings::enabled("misc") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +sub fred { use warnings 'io' ; abc::check() } +fred() ; +EXPECT +ok1 +ok2 +ok3 +ok4 +######## + +# check warnings::warn +use warnings ; +eval { warnings::warn() } ; +print $@ ; +eval { warnings::warn("fred", "joe") } ; +print $@ ; +EXPECT +Usage: warnings::warn([category,] 'message') at - line 4 +unknown warnings category 'fred' at - line 6 + require 0 called at - line 6 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'misc' ; +sub check { warnings::warn("io", "hello") } +1; +--FILE-- +use warnings "io" ; +use abc; +abc::check() ; +EXPECT +hello at - line 3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'misc' ; +sub check { warnings::warn("misc", "hello") } +1; +--FILE-- +use warnings "io" ; +use abc; +abc::check() ; +EXPECT +hello at - line 3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'misc' ; +sub check { warnings::warn("io", "hello") } +1; +--FILE-- +use warnings qw( FATAL deprecated ) ; +use abc; +eval { abc::check() ; } ; +print "[[$@]]\n"; +EXPECT +hello at - line 3 +[[]] +######## + +--FILE-- abc.pm +package abc ; +use warnings 'misc' ; +sub check { warnings::warn("io", "hello") } +1; +--FILE-- +use warnings qw( FATAL io ) ; +use abc; +eval { abc::check() ; } ; +print "[[$@]]\n"; +EXPECT +[[hello at - line 3 +]] +######## +-W +--FILE-- abc.pm +package abc ; +use warnings "io" ; +print "ok1\n" if warnings::enabled("io") ; +print "ok2\n" if warnings::enabled("all") ; +1; +--FILE-- +no warnings; +use abc ; +EXPECT +ok1 +ok2 +######## +-X +--FILE-- abc.pm +package abc ; +use warnings "io" ; +print "ok1\n" if !warnings::enabled("io") ; +print "ok2\n" if !warnings::enabled("all") ; +1; +--FILE-- +use warnings; +use abc ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +sub check { + print "ok\n" if ! warnings::enabled() ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +abc::check() ; +EXPECT +package 'abc' not registered for warnings at - line 3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if !warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +use warnings 'abc' ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if !warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +use warnings 'abc' ; +eval { abc::check() ; }; +print $@ ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if !warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +eval { abc::check() ; } ; +print $@ ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if !warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +use warnings 'abc' ; +sub fred { abc::check() } +fred() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +use warnings::register ; +sub check { + print "ok1\n" if ! warnings::enabled ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +sub fred { no warnings ; abc::check() } +fred() ; +EXPECT +ok1 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'misc' ; +use warnings::register; +sub check { + print "ok1\n" if warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if warnings::enabled("io") ; + print "ok4\n" if ! warnings::enabled("misc") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +use warnings 'abc' ; +sub fred { use warnings 'io' ; abc::check() } +fred() ; +EXPECT +ok1 +ok2 +ok3 +ok4 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'misc' ; +use warnings::register; +sub check { warnings::warn("hello") } +1; +--FILE-- +use abc; +use warnings "abc" ; +abc::check() ; +EXPECT +hello at - line 3 +######## + +--FILE-- abc.pm +package abc ; +use warnings::register; +sub check { warnings::warn("hello") } +1; +--FILE-- +use abc; +abc::check() ; +EXPECT +hello at - line 2 +######## + +--FILE-- abc.pm +package abc ; +use warnings::register ; +sub check { warnings::warn("hello") } +1; +--FILE-- +use abc; +use warnings qw( FATAL deprecated ) ; +eval { abc::check() ; } ; +print "[[$@]]\n"; +EXPECT +hello at - line 3 +[[]] +######## + +--FILE-- abc.pm +package abc ; +use warnings::register ; +sub check { warnings::warn("hello") } +1; +--FILE-- +use abc; +use warnings qw( FATAL abc ) ; +eval { abc::check() ; } ; +print "[[$@]]\n"; +EXPECT +[[hello at - line 3 +]] +######## +-W +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if warnings::enabled("io") ; + print "ok3\n" if warnings::enabled("all") ; +} +1; +--FILE-- +no warnings; +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## +-X +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; +} +1; +--FILE-- +no warnings; +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if warnings::enabled("io") ; + print "ok3\n" if warnings::enabled("all") ; +} +1; +--FILE-- +use warnings 'all'; +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; +} +1; +--FILE-- +use abc ; +no warnings ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; +} +1; +--FILE-- +use abc ; +use warnings 'abc'; +no warnings ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "abc self" . (warnings::enabled() ? "" : " not") . " enabled\n" ; + print "abc def" . (warnings::enabled('def') ? "" : " not") . " enabled\n" ; + print "abc all" . (warnings::enabled('all') ? "" : " not") . " enabled\n" ; +} +1; +--FILE-- def.pm +package def ; +use warnings "io" ; +use warnings::register ; +sub check { + print "def self" . (warnings::enabled() ? "" : " not") . " enabled\n" ; + print "def abc" . (warnings::enabled('abc') ? "" : " not") . " enabled\n" ; + print "def all" . (warnings::enabled('all') ? "" : " not") . " enabled\n" ; +} +1; +--FILE-- +use abc ; +use def ; +use warnings 'abc'; +abc::check() ; +def::check() ; +no warnings 'abc' ; +use warnings 'def' ; +abc::check() ; +def::check() ; +use warnings 'abc' ; +use warnings 'def' ; +abc::check() ; +def::check() ; +no warnings 'abc' ; +no warnings 'def' ; +abc::check() ; +def::check() ; +use warnings; +abc::check() ; +def::check() ; +no warnings 'abc' ; +abc::check() ; +def::check() ; +EXPECT +abc self enabled +abc def not enabled +abc all not enabled +def self not enabled +def abc enabled +def all not enabled +abc self not enabled +abc def enabled +abc all not enabled +def self enabled +def abc not enabled +def all not enabled +abc self enabled +abc def enabled +abc all not enabled +def self enabled +def abc enabled +def all not enabled +abc self not enabled +abc def not enabled +abc all not enabled +def self not enabled +def abc not enabled +def all not enabled +abc self enabled +abc def enabled +abc all enabled +def self enabled +def abc enabled +def all enabled +abc self not enabled +abc def enabled +abc all not enabled +def self enabled +def abc not enabled +def all not enabled diff --git a/contrib/perl5/t/pragma/warn/av b/contrib/perl5/t/pragma/warn/av new file mode 100644 index 0000000..79bd3b76 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/av @@ -0,0 +1,9 @@ + av.c + + Mandatory Warnings ALL TODO + ------------------ + av_reify called on tied array [av_reify] + + Attempt to clear deleted array [av_clear] + +__END__ diff --git a/contrib/perl5/t/pragma/warn/doio b/contrib/perl5/t/pragma/warn/doio new file mode 100644 index 0000000..bd40972 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/doio @@ -0,0 +1,191 @@ + doio.c + + Can't open bidirectional pipe [Perl_do_open9] + open(F, "| true |"); + + Missing command in piped open [Perl_do_open9] + open(F, "| "); + + Missing command in piped open [Perl_do_open9] + open(F, " |"); + + warn(warn_nl, "open"); [Perl_do_open9] + open(F, "true\ncd") + + Close on unopened file <%s> [Perl_do_close] <<TODO + $a = "fred";close("$a") + + tell() on unopened file [Perl_do_tell] + $a = "fred";$a = tell($a) + + seek() on unopened file [Perl_do_seek] + $a = "fred";$a = seek($a,1,1) + + sysseek() on unopened file [Perl_do_sysseek] + $a = "fred";$a = seek($a,1,1) + + warn(warn_uninit); [Perl_do_print] + print $a ; + + Stat on unopened file <%s> [Perl_my_stat] + close STDIN ; -x STDIN ; + + warn(warn_nl, "stat"); [Perl_my_stat] + stat "ab\ncd" + + warn(warn_nl, "lstat"); [Perl_my_lstat] + lstat "ab\ncd" + + Can't exec \"%s\": %s [Perl_do_aexec5] + + Can't exec \"%s\": %s [Perl_do_exec3] + + Filehandle %s opened only for output [Perl_do_eof] + my $a = eof STDOUT + + Mandatory Warnings ALL TODO + ------------------ + Can't do inplace edit: %s is not a regular file [Perl_nextargv] + edit a directory + + Can't do inplace edit: %s would not be unique [Perl_nextargv] + Can't rename %s to %s: %s, skipping file [Perl_nextargv] + Can't rename %s to %s: %s, skipping file [Perl_nextargv] + Can't remove %s: %s, skipping file [Perl_nextargv] + Can't do inplace edit on %s: %s [Perl_nextargv] + + +__END__ +# doio.c [Perl_do_open9] +use warnings 'io' ; +open(F, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); +close(F); +no warnings 'io' ; +open(G, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); +close(G); +EXPECT +Can't open bidirectional pipe at - line 3. +######## +# doio.c [Perl_do_open9] +use warnings 'io' ; +open(F, "| "); +no warnings 'io' ; +open(G, "| "); +EXPECT +Missing command in piped open at - line 3. +######## +# doio.c [Perl_do_open9] +use warnings 'io' ; +open(F, " |"); +no warnings 'io' ; +open(G, " |"); +EXPECT +Missing command in piped open at - line 3. +######## +# doio.c [Perl_do_open9] +use warnings 'io' ; +open(F, "<true\ncd"); +no warnings 'io' ; +open(G, "<true\ncd"); +EXPECT +Unsuccessful open on filename containing newline at - line 3. +######## +# doio.c [Perl_do_close] <<TODO +use warnings 'unopened' ; +close "fred" ; +no warnings 'unopened' ; +close "joe" ; +EXPECT +Close on unopened file <fred> at - line 3. +######## +# doio.c [Perl_do_tell Perl_do_seek Perl_do_sysseek Perl_my_stat] +use warnings 'io' ; +close STDIN ; +tell(STDIN); +$a = seek(STDIN,1,1); +$a = sysseek(STDIN,1,1); +-x STDIN ; +no warnings 'io' ; +close STDIN ; +tell(STDIN); +$a = seek(STDIN,1,1); +$a = sysseek(STDIN,1,1); +-x STDIN ; +EXPECT +tell() on unopened file at - line 4. +seek() on unopened file at - line 5. +sysseek() on unopened file at - line 6. +Stat on unopened file <STDIN> at - line 7. +######## +# doio.c [Perl_do_print] +use warnings 'uninitialized' ; +print $a ; +no warnings 'uninitialized' ; +print $b ; +EXPECT +Use of uninitialized value in print at - line 3. +######## +# doio.c [Perl_my_stat Perl_my_lstat] +use warnings 'io' ; +stat "ab\ncd"; +lstat "ab\ncd"; +no warnings 'io' ; +stat "ab\ncd"; +lstat "ab\ncd"; +EXPECT +Unsuccessful stat on filename containing newline at - line 3. +Unsuccessful stat on filename containing newline at - line 4. +######## +# doio.c [Perl_do_aexec5] +use warnings 'io' ; +exec "lskdjfalksdjfdjfkls","" ; +no warnings 'io' ; +exec "lskdjfalksdjfdjfkls","" ; +EXPECT +OPTION regex +Can't exec "lskdjfalksdjfdjfkls": .+ +######## +# doio.c [Perl_do_exec3] +use warnings 'io' ; +exec "lskdjfalksdjfdjfkls", "abc" ; +no warnings 'io' ; +exec "lskdjfalksdjfdjfkls", "abc" ; +EXPECT +OPTION regex +Can't exec "lskdjfalksdjfdjfkls(:? abc)?": .+ +######## +# doio.c [Perl_nextargv] +$^W = 0 ; +my $filename = "./temp.dir" ; +mkdir $filename, 0777 + or die "Cannot create directory $filename: $!\n" ; +{ + local (@ARGV) = ($filename) ; + local ($^I) = "" ; + my $x = <> ; +} +{ + no warnings 'inplace' ; + local (@ARGV) = ($filename) ; + local ($^I) = "" ; + my $x = <> ; +} +{ + use warnings 'inplace' ; + local (@ARGV) = ($filename) ; + local ($^I) = "" ; + my $x = <> ; +} +rmdir $filename ; +EXPECT +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' ; +my $a = eof STDOUT ; +no warnings 'io' ; +$a = eof STDOUT ; +EXPECT +Filehandle main::STDOUT opened only for output at - line 3. diff --git a/contrib/perl5/t/pragma/warn/doop b/contrib/perl5/t/pragma/warn/doop new file mode 100644 index 0000000..5803b44 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/doop @@ -0,0 +1,6 @@ +# doop.c +use utf8 ; +$_ = "\x80 \xff" ; +chop ; +EXPECT +######## diff --git a/contrib/perl5/t/pragma/warn/gv b/contrib/perl5/t/pragma/warn/gv new file mode 100644 index 0000000..5ed4eca --- /dev/null +++ b/contrib/perl5/t/pragma/warn/gv @@ -0,0 +1,54 @@ + gv.c AOK + + Can't locate package %s for @%s::ISA + @ISA = qw(Fred); joe() + + Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated + sub Other::AUTOLOAD { 1 } sub Other::fred {} + @ISA = qw(Other) ; + fred() ; + + Use of $# is deprecated + Use of $* is deprecated + + $a = ${"#"} ; + $a = ${"*"} ; + + Mandatory Warnings ALL TODO + ------------------ + + Had to create %s unexpectedly [gv_fetchpv] + Attempt to free unreferenced glob pointers [gp_free] + +__END__ +# gv.c +use warnings 'misc' ; +@ISA = qw(Fred); joe() +EXPECT +Can't locate package Fred for @main::ISA at - line 3. +Undefined subroutine &main::joe called at - line 3. +######## +# gv.c +no warnings 'misc' ; +@ISA = qw(Fred); joe() +EXPECT +Undefined subroutine &main::joe called at - line 3. +######## +# gv.c +sub Other::AUTOLOAD { 1 } sub Other::fred {} +@ISA = qw(Other) ; +use warnings 'deprecated' ; +fred() ; +EXPECT +Use of inherited AUTOLOAD for non-method main::fred() is deprecated at - line 5. +######## +# gv.c +use warnings 'deprecated' ; +$a = ${"#"}; +$a = ${"*"}; +no warnings 'deprecated' ; +$a = ${"#"}; +$a = ${"*"}; +EXPECT +Use of $# is deprecated at - line 3. +Use of $* is deprecated at - line 4. diff --git a/contrib/perl5/t/pragma/warn/hv b/contrib/perl5/t/pragma/warn/hv new file mode 100644 index 0000000..c9eec02 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/hv @@ -0,0 +1,8 @@ + hv.c + + + Mandatory Warnings ALL TODO + ------------------ + Attempt to free non-existent shared string [unsharepvn] + +__END__ diff --git a/contrib/perl5/t/pragma/warn/malloc b/contrib/perl5/t/pragma/warn/malloc new file mode 100644 index 0000000..2f8b096 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/malloc @@ -0,0 +1,9 @@ + malloc.c + + + Mandatory Warnings ALL TODO + ------------------ + %s free() ignored [Perl_mfree] + %s", "Bad free() ignored [Perl_mfree] + +__END__ diff --git a/contrib/perl5/t/pragma/warn/mg b/contrib/perl5/t/pragma/warn/mg new file mode 100644 index 0000000..a8f9dbc --- /dev/null +++ b/contrib/perl5/t/pragma/warn/mg @@ -0,0 +1,44 @@ + mg.c AOK + + No such signal: SIG%s + $SIG{FRED} = sub {} + + SIG%s handler \"%s\" not defined. + $SIG{"INT"} = "ok3"; kill "INT",$$; + + Mandatory Warnings TODO + ------------------ + Can't break at that line [magic_setdbline] + +__END__ +# mg.c +use warnings 'signal' ; +$SIG{FRED} = sub {}; +EXPECT +No such signal: SIGFRED at - line 3. +######## +# mg.c +no warnings 'signal' ; +$SIG{FRED} = sub {}; +EXPECT + +######## +# mg.c +use warnings 'signal' ; +if ($^O eq 'MSWin32' || $^O eq 'VMS') { + print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit; +} +$|=1; +$SIG{"INT"} = "fred"; kill "INT",$$; +EXPECT +SIGINT handler "fred" not defined. +######## +# mg.c +no warnings 'signal' ; +if ($^O eq 'MSWin32' || $^O eq 'VMS') { + print "SKIPPED\n# win32, can't kill() to raise()\n"; exit; +} +$|=1; +$SIG{"INT"} = "fred"; kill "INT",$$; +EXPECT + diff --git a/contrib/perl5/t/pragma/warn/op b/contrib/perl5/t/pragma/warn/op new file mode 100644 index 0000000..1a79b4a --- /dev/null +++ b/contrib/perl5/t/pragma/warn/op @@ -0,0 +1,861 @@ + op.c AOK + + "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 ; + + 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 + Useless use of a constant in void context + time ; + $a ; + "abc" + + Applying %s to %s will act on scalar(%s) + my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; + @a =~ /abc/ ; + @a =~ s/a/b/ ; + @a =~ tr/a/b/ ; + @$b =~ /abc/ ; + @$b =~ s/a/b/ ; + @$b =~ tr/a/b/ ; + %a =~ /abc/ ; + %a =~ s/a/b/ ; + %a =~ tr/a/b/ ; + %$c =~ /abc/ ; + %$c =~ s/a/b/ ; + %$c =~ tr/a/b/ ; + + + Parentheses missing around "my" list at -e line 1. + my $a, $b = (1,2); + + Parentheses missing around "local" list at -e line 1. + local $a, $b = (1,2); + + Bareword found in conditional at -e line 1. + use warnings 'bareword'; my $x = print(ABC || 1); + + Value of %s may be \"0\"; use \"defined\" + $x = 1 if $x = <FH> ; + $x = 1 while $x = <FH> ; + + Subroutine fred redefined at -e line 1. + sub fred{1;} sub fred{1;} + + Constant subroutine %s redefined + sub fred() {1;} sub fred() {1;} + + Format FRED redefined at /tmp/x line 5. + format FRED = + . + format FRED = + . + + Array @%s missing the @ in argument %d of %s() + push fred ; + + Hash %%%s missing the %% in argument %d of %s() + keys joe ; + + Statement unlikely to be reached + (Maybe you meant system() when you said exec()? + exec "true" ; my $a + + defined(@array) is deprecated + (Maybe you should just omit the defined()?) + my @a ; defined @a ; + defined (@a = (1,2,3)) ; + + defined(%hash) is deprecated + (Maybe you should just omit the defined()?) + my %h ; defined %h ; + + /---/ should probably be written as "---" + join(/---/, @foo); + + %s() called too early to check prototype [Perl_peep] + fred() ; sub fred ($$) {} + + + Mandatory Warnings + ------------------ + Prototype mismatch: [cv_ckproto] + 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 'misc' ; +my $x ; +my $x ; +no warnings 'misc' ; +my $x ; +EXPECT +"my" variable $x masks earlier declaration in same scope at - line 4. +######## +# op.c +use warnings 'closure' ; +sub x { + my $x; + sub y { + $x + } + } +EXPECT +Variable "$x" will not stay shared at - line 7. +######## +# op.c +no warnings 'closure' ; +sub x { + my $x; + sub y { + $x + } + } +EXPECT + +######## +# op.c +use warnings 'closure' ; +sub x { + my $x; + sub y { + sub { $x } + } + } +EXPECT +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 warnings 'syntax' ; +1 if $a = 1 ; +no warnings 'syntax' ; +1 if $a = 1 ; +EXPECT +Found = in conditional, should be == at - line 3. +######## +# op.c +use warnings 'deprecated' ; +split ; +no warnings 'deprecated' ; +split ; +EXPECT +Use of implicit split to @_ is deprecated at - line 3. +######## +# op.c +use warnings 'deprecated' ; +$a = split ; +no warnings 'deprecated' ; +$a = split ; +EXPECT +Use of implicit split to @_ is deprecated at - line 3. +######## +# op.c +use warnings 'void' ; close STDIN ; +1 x 3 ; # OP_REPEAT + # OP_GVSV +wantarray ; # OP_WANTARRAY + # OP_GV + # OP_PADSV + # OP_PADAV + # OP_PADHV + # OP_PADANY + # OP_AV2ARYLEN +ref ; # OP_REF +\@a ; # OP_REFGEN +\$a ; # OP_SREFGEN +defined $a ; # OP_DEFINED +hex $a ; # OP_HEX +oct $a ; # OP_OCT +length $a ; # OP_LENGTH +substr $a,1 ; # OP_SUBSTR +vec $a,1,2 ; # OP_VEC +index $a,1,2 ; # OP_INDEX +rindex $a,1,2 ; # OP_RINDEX +sprintf $a ; # OP_SPRINTF +$a[0] ; # OP_AELEM + # OP_AELEMFAST +@a[0] ; # OP_ASLICE +#values %a ; # OP_VALUES +#keys %a ; # OP_KEYS +$a{0} ; # OP_HELEM +@a{0} ; # OP_HSLICE +unpack "a", "a" ; # OP_UNPACK +pack $a,"" ; # OP_PACK +join "" ; # OP_JOIN +(@a)[0,1] ; # OP_LSLICE + # OP_ANONLIST + # OP_ANONHASH +sort(1,2) ; # OP_SORT +reverse(1,2) ; # OP_REVERSE + # OP_RANGE + # OP_FLIP +(1 ..2) ; # OP_FLOP +caller ; # OP_CALLER +fileno STDIN ; # OP_FILENO +eof STDIN ; # OP_EOF +tell STDIN ; # OP_TELL +readlink 1; # OP_READLINK +time ; # OP_TIME +localtime ; # OP_LOCALTIME +gmtime ; # OP_GMTIME +eval { getgrnam 1 }; # OP_GGRNAM +eval { getgrgid 1 }; # OP_GGRGID +eval { getpwnam 1 }; # OP_GPWNAM +eval { getpwuid 1 }; # OP_GPWUID +EXPECT +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. +Useless use of reference constructor in void context at - line 13. +Useless use of single ref constructor in void context at - line 14. +Useless use of defined operator in void context at - line 15. +Useless use of hex in void context at - line 16. +Useless use of oct in void context at - line 17. +Useless use of length in void context at - line 18. +Useless use of substr in void context at - line 19. +Useless use of vec in void context at - line 20. +Useless use of index in void context at - line 21. +Useless use of rindex in void context at - line 22. +Useless use of sprintf in void context at - line 23. +Useless use of array element in void context at - line 24. +Useless use of array slice in void context at - line 26. +Useless use of hash element in void context at - line 29. +Useless use of hash slice in void context at - line 30. +Useless use of unpack in void context at - line 31. +Useless use of pack in void context at - line 32. +Useless use of join in void context at - line 33. +Useless use of list slice in void context at - line 34. +Useless use of sort in void context at - line 37. +Useless use of reverse in void context at - line 38. +Useless use of range (or flop) in void context at - line 41. +Useless use of caller in void context at - line 42. +Useless use of fileno in void context at - line 43. +Useless use of eof in void context at - line 44. +Useless use of tell in void context at - line 45. +Useless use of readlink in void context at - line 46. +Useless use of time in void context at - line 47. +Useless use of localtime in void context at - line 48. +Useless use of gmtime in void context at - line 49. +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. +######## +# op.c +no warnings 'void' ; close STDIN ; +1 x 3 ; # OP_REPEAT + # OP_GVSV +wantarray ; # OP_WANTARRAY + # OP_GV + # OP_PADSV + # OP_PADAV + # OP_PADHV + # OP_PADANY + # OP_AV2ARYLEN +ref ; # OP_REF +\@a ; # OP_REFGEN +\$a ; # OP_SREFGEN +defined $a ; # OP_DEFINED +hex $a ; # OP_HEX +oct $a ; # OP_OCT +length $a ; # OP_LENGTH +substr $a,1 ; # OP_SUBSTR +vec $a,1,2 ; # OP_VEC +index $a,1,2 ; # OP_INDEX +rindex $a,1,2 ; # OP_RINDEX +sprintf $a ; # OP_SPRINTF +$a[0] ; # OP_AELEM + # OP_AELEMFAST +@a[0] ; # OP_ASLICE +#values %a ; # OP_VALUES +#keys %a ; # OP_KEYS +$a{0} ; # OP_HELEM +@a{0} ; # OP_HSLICE +unpack "a", "a" ; # OP_UNPACK +pack $a,"" ; # OP_PACK +join "" ; # OP_JOIN +(@a)[0,1] ; # OP_LSLICE + # OP_ANONLIST + # OP_ANONHASH +sort(1,2) ; # OP_SORT +reverse(1,2) ; # OP_REVERSE + # OP_RANGE + # OP_FLIP +(1 ..2) ; # OP_FLOP +caller ; # OP_CALLER +fileno STDIN ; # OP_FILENO +eof STDIN ; # OP_EOF +tell STDIN ; # OP_TELL +readlink 1; # OP_READLINK +time ; # OP_TIME +localtime ; # OP_LOCALTIME +gmtime ; # OP_GMTIME +eval { getgrnam 1 }; # OP_GGRNAM +eval { getgrgid 1 }; # OP_GGRGID +eval { getpwnam 1 }; # OP_GPWNAM +eval { getpwuid 1 }; # OP_GPWUID +EXPECT +######## +# op.c +use warnings 'void' ; +for (@{[0]}) { "$_" } # check warning isn't duplicated +no warnings 'void' ; +for (@{[0]}) { "$_" } # check warning isn't duplicated +EXPECT +Useless use of string in void context at - line 3. +######## +# op.c +use warnings 'void' ; +use Config ; +BEGIN { + if ( ! $Config{d_telldir}) { + print <<EOM ; +SKIPPED +# telldir not present +EOM + exit + } +} +telldir 1 ; # OP_TELLDIR +no warnings 'void' ; +telldir 1 ; # OP_TELLDIR +EXPECT +Useless use of telldir in void context at - line 13. +######## +# op.c +use warnings 'void' ; +use Config ; +BEGIN { + if ( ! $Config{d_getppid}) { + print <<EOM ; +SKIPPED +# getppid not present +EOM + exit + } +} +getppid ; # OP_GETPPID +no warnings 'void' ; +getppid ; # OP_GETPPID +EXPECT +Useless use of getppid in void context at - line 13. +######## +# op.c +use warnings 'void' ; +use Config ; +BEGIN { + if ( ! $Config{d_getpgrp}) { + print <<EOM ; +SKIPPED +# getpgrp not present +EOM + exit + } +} +getpgrp ; # OP_GETPGRP +no warnings 'void' ; +getpgrp ; # OP_GETPGRP +EXPECT +Useless use of getpgrp in void context at - line 13. +######## +# op.c +use warnings 'void' ; +use Config ; +BEGIN { + if ( ! $Config{d_times}) { + print <<EOM ; +SKIPPED +# times not present +EOM + exit + } +} +times ; # OP_TMS +no warnings 'void' ; +times ; # OP_TMS +EXPECT +Useless use of times in void context at - line 13. +######## +# op.c +use warnings 'void' ; +use Config ; +BEGIN { + if ( ! $Config{d_getprior} or $^O eq 'os2') { # Locks before fixpak22 + print <<EOM ; +SKIPPED +# getpriority not present +EOM + exit + } +} +getpriority 1,2; # OP_GETPRIORITY +no warnings 'void' ; +getpriority 1,2; # OP_GETPRIORITY +EXPECT +Useless use of getpriority in void context at - line 13. +######## +# op.c +use warnings 'void' ; +use Config ; +BEGIN { + if ( ! $Config{d_getlogin}) { + print <<EOM ; +SKIPPED +# getlogin not present +EOM + exit + } +} +getlogin ; # OP_GETLOGIN +no warnings 'void' ; +getlogin ; # OP_GETLOGIN +EXPECT +Useless use of getlogin in void context at - line 13. +######## +# op.c +use warnings 'void' ; +use Config ; BEGIN { +if ( ! $Config{d_socket}) { + print <<EOM ; +SKIPPED +# getsockname not present +# getpeername not present +# gethostbyname not present +# gethostbyaddr not present +# gethostent not present +# getnetbyname not present +# getnetbyaddr not present +# getnetent not present +# getprotobyname not present +# getprotobynumber not present +# getprotoent not present +# getservbyname not present +# getservbyport not present +# getservent not present +EOM + exit +} } +getsockname STDIN ; # OP_GETSOCKNAME +getpeername STDIN ; # OP_GETPEERNAME +gethostbyname 1 ; # OP_GHBYNAME +gethostbyaddr 1,2; # OP_GHBYADDR +gethostent ; # OP_GHOSTENT +getnetbyname 1 ; # OP_GNBYNAME +getnetbyaddr 1,2 ; # OP_GNBYADDR +getnetent ; # OP_GNETENT +getprotobyname 1; # OP_GPBYNAME +getprotobynumber 1; # OP_GPBYNUMBER +getprotoent ; # OP_GPROTOENT +getservbyname 1,2; # OP_GSBYNAME +getservbyport 1,2; # OP_GSBYPORT +getservent ; # OP_GSERVENT + +no warnings 'void' ; +getsockname STDIN ; # OP_GETSOCKNAME +getpeername STDIN ; # OP_GETPEERNAME +gethostbyname 1 ; # OP_GHBYNAME +gethostbyaddr 1,2; # OP_GHBYADDR +gethostent ; # OP_GHOSTENT +getnetbyname 1 ; # OP_GNBYNAME +getnetbyaddr 1,2 ; # OP_GNBYADDR +getnetent ; # OP_GNETENT +getprotobyname 1; # OP_GPBYNAME +getprotobynumber 1; # OP_GPBYNUMBER +getprotoent ; # OP_GPROTOENT +getservbyname 1,2; # OP_GSBYNAME +getservbyport 1,2; # OP_GSBYPORT +getservent ; # OP_GSERVENT +INIT { + # some functions may not be there, so we exit without running + exit; +} +EXPECT +Useless use of getsockname in void context at - line 24. +Useless use of getpeername in void context at - line 25. +Useless use of gethostbyname in void context at - line 26. +Useless use of gethostbyaddr in void context at - line 27. +Useless use of gethostent in void context at - line 28. +Useless use of getnetbyname in void context at - line 29. +Useless use of getnetbyaddr in void context at - line 30. +Useless use of getnetent in void context at - line 31. +Useless use of getprotobyname in void context at - line 32. +Useless use of getprotobynumber in void context at - line 33. +Useless use of getprotoent in void context at - line 34. +Useless use of getservbyname in void context at - line 35. +Useless use of getservbyport in void context at - line 36. +Useless use of getservent in void context at - line 37. +######## +# op.c +use warnings 'void' ; +*a ; # OP_RV2GV +$a ; # OP_RV2SV +@a ; # OP_RV2AV +%a ; # OP_RV2HV +no warnings 'void' ; +*a ; # OP_RV2GV +$a ; # OP_RV2SV +@a ; # OP_RV2AV +%a ; # OP_RV2HV +EXPECT +Useless use of a variable in void context at - line 3. +Useless use of a variable in void context at - line 4. +Useless use of a variable in void context at - line 5. +Useless use of a variable in void context at - line 6. +######## +# op.c +use warnings 'void' ; +"abc"; # OP_CONST +7 ; # OP_CONST +no warnings 'void' ; +"abc"; # OP_CONST +7 ; # OP_CONST +EXPECT +Useless use of a constant in void context at - line 3. +Useless use of a constant in void context at - line 4. +######## +# op.c +BEGIN{ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } # known scalar leak +use warnings 'misc' ; +my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; +@a =~ /abc/ ; +@a =~ s/a/b/ ; +@a =~ tr/a/b/ ; +@$b =~ /abc/ ; +@$b =~ s/a/b/ ; +@$b =~ tr/a/b/ ; +%a =~ /abc/ ; +%a =~ s/a/b/ ; +%a =~ tr/a/b/ ; +%$c =~ /abc/ ; +%$c =~ s/a/b/ ; +%$c =~ tr/a/b/ ; +{ +no warnings 'misc' ; +my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; +@a =~ /abc/ ; +@a =~ s/a/b/ ; +@a =~ tr/a/b/ ; +@$b =~ /abc/ ; +@$b =~ s/a/b/ ; +@$b =~ tr/a/b/ ; +%a =~ /abc/ ; +%a =~ s/a/b/ ; +%a =~ tr/a/b/ ; +%$c =~ /abc/ ; +%$c =~ s/a/b/ ; +%$c =~ tr/a/b/ ; +} +EXPECT +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. +Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;" +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 %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. +BEGIN not safe after errors--compilation aborted at - line 18. +######## +# op.c +use warnings 'syntax' ; +my $a, $b = (1,2); +no warnings 'syntax' ; +my $c, $d = (1,2); +EXPECT +Parentheses missing around "my" list at - line 3. +######## +# op.c +use warnings 'syntax' ; +local $a, $b = (1,2); +no warnings 'syntax' ; +local $c, $d = (1,2); +EXPECT +Parentheses missing around "local" list at - line 3. +######## +# op.c +use warnings 'bareword' ; +print (ABC || 1) ; +no warnings 'bareword' ; +print (ABC || 1) ; +EXPECT +Bareword found in conditional at - line 3. +######## +--FILE-- abc + +--FILE-- +# op.c +use warnings 'misc' ; +open FH, "<abc" ; +$x = 1 if $x = <FH> ; +no warnings 'misc' ; +$x = 1 if $x = <FH> ; +EXPECT +Value of <HANDLE> construct can be "0"; test with defined() at - line 4. +######## +# op.c +use warnings 'misc' ; +opendir FH, "." ; +$x = 1 if $x = readdir FH ; +no warnings 'misc' ; +$x = 1 if $x = readdir FH ; +closedir FH ; +EXPECT +Value of readdir() operator can be "0"; test with defined() at - line 4. +######## +# op.c +use warnings 'misc' ; +$x = 1 if $x = <*> ; +no warnings 'misc' ; +$x = 1 if $x = <*> ; +EXPECT +Value of glob construct can be "0"; test with defined() at - line 3. +######## +# op.c +use warnings 'misc' ; +%a = (1,2,3,4) ; +$x = 1 if $x = each %a ; +no warnings 'misc' ; +$x = 1 if $x = each %a ; +EXPECT +Value of each() operator can be "0"; test with defined() at - line 4. +######## +# op.c +use warnings 'misc' ; +$x = 1 while $x = <*> and 0 ; +no warnings 'misc' ; +$x = 1 while $x = <*> and 0 ; +EXPECT +Value of glob construct can be "0"; test with defined() at - line 3. +######## +# op.c +use warnings 'misc' ; +opendir FH, "." ; +$x = 1 while $x = readdir FH and 0 ; +no warnings 'misc' ; +$x = 1 while $x = readdir FH and 0 ; +closedir FH ; +EXPECT +Value of readdir() operator can be "0"; test with defined() at - line 4. +######## +# op.c +use warnings 'redefine' ; +sub fred {} +sub fred {} +no warnings 'redefine' ; +sub fred {} +EXPECT +Subroutine fred redefined at - line 4. +######## +# op.c +use warnings 'redefine' ; +sub fred () { 1 } +sub fred () { 1 } +no warnings 'redefine' ; +sub fred () { 1 } +EXPECT +Constant subroutine fred redefined at - line 4. +######## +# op.c +use warnings 'redefine' ; +format FRED = +. +format FRED = +. +no warnings 'redefine' ; +format FRED = +. +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 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 3. +######## +# op.c +use warnings 'syntax' ; +exec "$^X -e 1" ; +my $a +EXPECT +Statement unlikely to be reached at - line 4. + (Maybe you meant system() when you said exec()?) +######## +# op.c +use warnings 'deprecated' ; +my @a; defined(@a); +EXPECT +defined(@array) is deprecated at - line 3. + (Maybe you should just omit the defined()?) +######## +# op.c +use warnings 'deprecated' ; +defined(@a = (1,2,3)); +EXPECT +defined(@array) is deprecated at - line 3. + (Maybe you should just omit the defined()?) +######## +# op.c +use warnings 'deprecated' ; +my %h; defined(%h); +EXPECT +defined(%hash) is deprecated at - line 3. + (Maybe you should just omit the defined()?) +######## +# op.c +no warnings 'syntax' ; +exec "$^X -e 1" ; +my $a +EXPECT + +######## +# op.c +sub fred(); +sub fred($) {} +EXPECT +Prototype mismatch: sub main::fred () vs ($) at - line 3. +######## +# op.c +$^W = 0 ; +sub fred() ; +sub fred($) {} +{ + no warnings 'prototype' ; + sub Fred() ; + sub Fred($) {} + use warnings 'prototype' ; + sub freD() ; + sub freD($) {} +} +sub FRED() ; +sub FRED($) {} +EXPECT +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 +use warnings 'syntax' ; +join /---/, 'x', 'y', 'z'; +EXPECT +/---/ should probably be written as "---" at - line 3. +######## +# op.c [Perl_peep] +use warnings 'prototype' ; +fred() ; +sub fred ($$) {} +no warnings 'prototype' ; +joe() ; +sub joe ($$) {} +EXPECT +main::fred() called too early to check prototype at - line 3. +######## +# op.c [Perl_newATTRSUB] +--FILE-- abc.pm +use warnings 'void' ; +BEGIN { $| = 1; print "in begin\n"; } +CHECK { print "in check\n"; } +INIT { print "in init\n"; } +END { print "in end\n"; } +print "in mainline\n"; +1; +--FILE-- +use abc; +delete $INC{"abc.pm"}; +require abc; +do "abc.pm"; +EXPECT +in begin +in mainline +in check +in init +in begin +Too late to run CHECK block at abc.pm line 3. +Too late to run INIT block at abc.pm line 4. +in mainline +in begin +Too late to run CHECK block at abc.pm line 3. +Too late to run INIT block at abc.pm line 4. +in mainline +in end +in end +in end +######## +# op.c [Perl_newATTRSUB] +--FILE-- abc.pm +no warnings 'void' ; +BEGIN { $| = 1; print "in begin\n"; } +CHECK { print "in check\n"; } +INIT { print "in init\n"; } +END { print "in end\n"; } +print "in mainline\n"; +1; +--FILE-- +require abc; +do "abc.pm"; +EXPECT +in begin +in mainline +in begin +in mainline +in end +in end diff --git a/contrib/perl5/t/pragma/warn/perl b/contrib/perl5/t/pragma/warn/perl new file mode 100644 index 0000000..4580749 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/perl @@ -0,0 +1,57 @@ + perl.c AOK + + gv_check(defstash) + Name \"%s::%s\" used only once: possible typo + + Mandatory Warnings All TODO + ------------------ + Recompile perl with -DDEBUGGING to use -D switch [moreswitches] + Unbalanced scopes: %ld more ENTERs than LEAVEs [perl_destruct] + Unbalanced saves: %ld more saves than restores [perl_destruct] + Unbalanced tmps: %ld more allocs than frees [perl_destruct] + Unbalanced context: %ld more PUSHes than POPs [perl_destruct] + Unbalanced string table refcount: (%d) for \"%s\" [perl_destruct] + Scalars leaked: %ld [perl_destruct] + + +__END__ +# perl.c +no warnings 'once' ; +$x = 3 ; +use warnings 'once' ; +$z = 3 ; +EXPECT +Name "main::z" used only once: possible typo at - line 5. +######## +-w +# perl.c +$x = 3 ; +no warnings 'once' ; +$z = 3 +EXPECT +Name "main::x" used only once: possible typo at - line 3. +######## +# perl.c +BEGIN { $^W =1 ; } +$x = 3 ; +no warnings 'once' ; +$z = 3 +EXPECT +Name "main::x" used only once: possible typo at - line 3. +######## +-W +# perl.c +no warnings 'once' ; +$x = 3 ; +use warnings 'once' ; +$z = 3 ; +EXPECT +Name "main::x" used only once: possible typo at - line 4. +Name "main::z" used only once: possible typo at - line 6. +######## +-X +# perl.c +use warnings 'once' ; +$x = 3 ; +EXPECT + diff --git a/contrib/perl5/t/pragma/warn/perlio b/contrib/perl5/t/pragma/warn/perlio new file mode 100644 index 0000000..18c0dfa --- /dev/null +++ b/contrib/perl5/t/pragma/warn/perlio @@ -0,0 +1,10 @@ + perlio.c + + + Mandatory Warnings ALL TODO + ------------------ + Setting cnt to %d + Setting ptr %p > end+1 %p + Setting cnt to %d, ptr implies %d + +__END__ diff --git a/contrib/perl5/t/pragma/warn/perly b/contrib/perl5/t/pragma/warn/perly new file mode 100644 index 0000000..afc5dcc --- /dev/null +++ b/contrib/perl5/t/pragma/warn/perly @@ -0,0 +1,31 @@ + perly.y AOK + + dep() => deprecate("\"do\" to call subroutines") + Use of "do" to call subroutines is deprecated + + sub fred {} do fred() + sub fred {} do fred(1) + sub fred {} $a = "fred" ; do $a() + sub fred {} $a = "fred" ; do $a(1) + + +__END__ +# perly.y +use warnings 'deprecated' ; +sub fred {} +do fred() ; +do fred(1) ; +$a = "fred" ; +do $a() ; +do $a(1) ; +no warnings 'deprecated' ; +do fred() ; +do fred(1) ; +$a = "fred" ; +do $a() ; +do $a(1) ; +EXPECT +Use of "do" to call subroutines is deprecated at - line 4. +Use of "do" to call subroutines is deprecated at - line 5. +Use of "do" to call subroutines is deprecated at - line 7. +Use of "do" to call subroutines is deprecated at - line 8. diff --git a/contrib/perl5/t/pragma/warn/pp b/contrib/perl5/t/pragma/warn/pp new file mode 100644 index 0000000..8f42ba6 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/pp @@ -0,0 +1,110 @@ + pp.c TODO + + substr outside of string + $a = "ab" ; $b = substr($a, 4,5) ; + + Attempt to use reference as lvalue in substr + $a = "ab" ; $b = \$a ; substr($b, 1,1) = $b + + uninitialized in pp_rv2gv() + my *b = *{ undef()} + + uninitialized in pp_rv2sv() + my $a = undef ; my $b = $$a + + Odd number of elements in hash list + my $a = { 1,2,3 } ; + + Invalid type in unpack: '%c + my $A = pack ("A,A", 1,2) ; + my @A = unpack ("A,A", "22") ; + + Attempt to pack pointer to temporary value + pack("p", "abc") ; + + Explicit blessing to '' (assuming package main) + bless \[], ""; + + Constant subroutine %s undefined <<<TODO + Constant subroutine (anonymous) undefined <<<TODO + +__END__ +# pp.c +use warnings 'substr' ; +$a = "ab" ; +$b = substr($a, 4,5) ; +no warnings 'substr' ; +$a = "ab" ; +$b = substr($a, 4,5) ; +EXPECT +substr outside of string at - line 4. +######## +# pp.c +use warnings 'substr' ; +$a = "ab" ; +$b = \$a ; +substr($b, 1,1) = "ab" ; +no warnings 'substr' ; +substr($b, 1,1) = "ab" ; +EXPECT +Attempt to use reference as lvalue in substr at - line 5. +######## +# pp.c +use warnings 'uninitialized' ; +# TODO +EXPECT + +######## +# pp.c +use warnings 'misc' ; +my $a = { 1,2,3}; +no warnings 'misc' ; +my $b = { 1,2,3}; +EXPECT +Odd number of elements in hash assignment at - line 3. +######## +# pp.c +use warnings 'pack' ; +use warnings 'unpack' ; +my @a = unpack ("A,A", "22") ; +my $a = pack ("A,A", 1,2) ; +no warnings 'pack' ; +no warnings 'unpack' ; +my @b = unpack ("A,A", "22") ; +my $b = pack ("A,A", 1,2) ; +EXPECT +Invalid type in unpack: ',' at - line 4. +Invalid type in pack: ',' at - line 5. +######## +# pp.c +use warnings 'uninitialized' ; +my $a = undef ; +my $b = $$a; +no warnings 'uninitialized' ; +my $c = $$a; +EXPECT +Use of uninitialized value in scalar dereference at - line 4. +######## +# pp.c +use warnings 'pack' ; +sub foo { my $a = "a"; return $a . $a++ . $a++ } +my $a = pack("p", &foo) ; +no warnings 'pack' ; +my $b = pack("p", &foo) ; +EXPECT +Attempt to pack pointer to temporary value at - line 4. +######## +# pp.c +use warnings 'misc' ; +bless \[], "" ; +no warnings 'misc' ; +bless \[], "" ; +EXPECT +Explicit blessing to '' (assuming package main) at - line 3. +######## +# pp.c +use utf8 ; +$_ = "\x80 \xff" ; +reverse ; +EXPECT +######## diff --git a/contrib/perl5/t/pragma/warn/pp_ctl b/contrib/perl5/t/pragma/warn/pp_ctl new file mode 100644 index 0000000..0deccd3 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/pp_ctl @@ -0,0 +1,217 @@ + pp_ctl.c AOK + + Not enough format arguments + format STDOUT = + @<<< @<<< + $a + . + write; + + + Exiting substitution via %s + $_ = "abc" ; + while ($i ++ == 0) + { + s/ab/last/e ; + } + + Exiting subroutine via %s + sub fred { last } + { fred() } + + Exiting eval via %s + { eval "last" } + + Exiting pseudo-block via %s + @a = (1,2) ; @b = sort { last } @a ; + + Exiting substitution via %s + $_ = "abc" ; + last fred: + while ($i ++ == 0) + { + s/ab/last fred/e ; + } + + + Exiting subroutine via %s + sub fred { last joe } + joe: { fred() } + + Exiting eval via %s + fred: { eval "last fred" } + + Exiting pseudo-block via %s + @a = (1,2) ; fred: @b = sort { last fred } @a ; + + + Deep recursion on subroutine \"%s\" + sub fred + { + fred() if $a++ < 200 + } + + fred() + + (in cleanup) foo bar + package Foo; + DESTROY { die "foo bar" } + { bless [], 'Foo' for 1..10 } + +__END__ +# pp_ctl.c +use warnings 'syntax' ; +format STDOUT = +@<<< @<<< +1 +. +write; +EXPECT +Not enough format arguments at - line 5. +1 +######## +# pp_ctl.c +no warnings 'syntax' ; +format = +@<<< @<<< +1 +. +write ; +EXPECT +1 +######## +# pp_ctl.c +use warnings 'exiting' ; +$_ = "abc" ; + +while ($i ++ == 0) +{ + s/ab/last/e ; +} +no warnings 'exiting' ; +while ($i ++ == 0) +{ + s/ab/last/e ; +} +EXPECT +Exiting substitution via last at - line 7. +######## +# pp_ctl.c +use warnings 'exiting' ; +sub fred { last } +{ fred() } +no warnings 'exiting' ; +sub joe { last } +{ joe() } +EXPECT +Exiting subroutine via last at - line 3. +######## +# pp_ctl.c +{ + eval "use warnings 'exiting' ; last;" +} +print STDERR $@ ; +{ + eval "no warnings 'exiting' ;last;" +} +print STDERR $@ ; +EXPECT +Exiting eval via last at (eval 1) line 1. +######## +# pp_ctl.c +use warnings 'exiting' ; +@a = (1,2) ; +@b = sort { last } @a ; +no warnings 'exiting' ; +@b = sort { last } @a ; +EXPECT +Exiting pseudo-block via last at - line 4. +Can't "last" outside a loop block at - line 4. +######## +# pp_ctl.c +use warnings 'exiting' ; +$_ = "abc" ; +fred: +while ($i ++ == 0) +{ + s/ab/last fred/e ; +} +no warnings 'exiting' ; +while ($i ++ == 0) +{ + s/ab/last fred/e ; +} +EXPECT +Exiting substitution via last at - line 7. +######## +# pp_ctl.c +use warnings 'exiting' ; +sub fred { last joe } +joe: { fred() } +no warnings 'exiting' ; +sub Fred { last Joe } +Joe: { Fred() } +EXPECT +Exiting subroutine via last at - line 3. +######## +# pp_ctl.c +joe: +{ eval "use warnings 'exiting' ; last joe;" } +print STDERR $@ ; +Joe: +{ eval "no warnings 'exiting' ; last Joe;" } +print STDERR $@ ; +EXPECT +Exiting eval via last at (eval 1) line 1. +######## +# pp_ctl.c +use warnings 'exiting' ; +@a = (1,2) ; +fred: @b = sort { last fred } @a ; +no warnings 'exiting' ; +Fred: @b = sort { last Fred } @a ; +EXPECT +Exiting pseudo-block via last at - line 4. +Label not found for "last fred" at - line 4. +######## +# pp_ctl.c +use warnings 'recursion' ; +BEGIN { warn "PREFIX\n" ;} +sub fred +{ + fred() if $a++ < 200 +} + +fred() +EXPECT +Deep recursion on subroutine "main::fred" at - line 6. +######## +# pp_ctl.c +no warnings 'recursion' ; +BEGIN { warn "PREFIX\n" ;} +sub fred +{ + fred() if $a++ < 200 +} + +fred() +EXPECT +######## +# pp_ctl.c +use warnings 'misc' ; +package Foo; +DESTROY { die "@{$_[0]} foo bar" } +{ bless ['A'], 'Foo' for 1..10 } +{ bless ['B'], 'Foo' for 1..10 } +EXPECT + (in cleanup) A foo bar at - line 4. + (in cleanup) B foo bar at - line 4. +######## +# pp_ctl.c +no warnings 'misc' ; +package Foo; +DESTROY { die "@{$_[0]} foo bar" } +{ bless ['A'], 'Foo' for 1..10 } +{ bless ['B'], 'Foo' for 1..10 } +EXPECT + diff --git a/contrib/perl5/t/pragma/warn/pp_hot b/contrib/perl5/t/pragma/warn/pp_hot new file mode 100644 index 0000000..2759057 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/pp_hot @@ -0,0 +1,226 @@ + pp_hot.c + + Filehandle %s never opened [pp_print] + $f = $a = "abc" ; print $f $a + + Filehandle %s opened only for input [pp_print] + print STDIN "abc" ; + + Filehandle %s opened only for output [pp_print] + print <STDOUT> ; + + print() on closed filehandle %s [pp_print] + close STDIN ; print STDIN "abc" ; + + uninitialized [pp_rv2av] + my $a = undef ; my @b = @$a + + uninitialized [pp_rv2hv] + my $a = undef ; my %b = %$a + + Odd number of elements in hash list [pp_aassign] + %X = (1,2,3) ; + + Reference found where even-sized list expected [pp_aassign] + $X = [ 1 ..3 ]; + + Filehandle %s opened only for output [Perl_do_readline] + open (FH, ">./xcv") ; + my $a = <FH> ; + + glob failed (can't start child: %s) [Perl_do_readline] <<TODO + + readline() on closed filehandle %s [Perl_do_readline] + close STDIN ; $a = <STDIN>; + + glob failed (child exited with status %d%s) [Perl_do_readline] <<TODO + + Deep recursion on subroutine \"%s\" [Perl_sub_crush_depth] + sub fred { fred() if $a++ < 200} fred() + + 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"; + +__END__ +# pp_hot.c [pp_print] +use warnings 'unopened' ; +$f = $a = "abc" ; +print $f $a; +no warnings 'unopened' ; +print $f $a; +EXPECT +Filehandle main::abc never opened at - line 4. +######## +# pp_hot.c [pp_print] +use warnings 'io' ; +print STDIN "anc"; +print <STDOUT>; +print <STDERR>; +open(FOO, ">&STDOUT") and print <FOO>; +print getc(STDERR); +print getc(FOO); +#################################################################### +# The next test is known to fail on some systems (Linux+old glibc, # +# old *BSDs, and NeXT, among others. # +# We skip it for now (on the grounds that it is "just" a warning). # +#################################################################### +#read(FOO,$_,1); +no warnings 'io' ; +print STDIN "anc"; +EXPECT +Filehandle main::STDIN opened only for input at - line 3. +Filehandle main::STDOUT opened only for output at - line 4. +Filehandle main::STDERR opened only for output at - line 5. +Filehandle main::FOO opened only for output at - line 6. +Filehandle main::STDERR opened only for output at - line 7. +Filehandle main::FOO opened only for output at - line 8. +######## +# pp_hot.c [pp_print] +use warnings 'closed' ; +close STDIN ; +print STDIN "anc"; +opendir STDIN, "."; +print STDIN "anc"; +closedir STDIN; +no warnings 'closed' ; +print STDIN "anc"; +opendir STDIN, "."; +print STDIN "anc"; +EXPECT +print() on closed filehandle main::STDIN at - line 4. +print() on closed filehandle main::STDIN at - line 6. + (Are you trying to call print() on dirhandle main::STDIN?) +######## +# pp_hot.c [pp_rv2av] +use warnings 'uninitialized' ; +my $a = undef ; +my @b = @$a; +no warnings 'uninitialized' ; +my @c = @$a; +EXPECT +Use of uninitialized value in array dereference at - line 4. +######## +# pp_hot.c [pp_rv2hv] +use warnings 'uninitialized' ; +my $a = undef ; +my %b = %$a; +no warnings 'uninitialized' ; +my %c = %$a; +EXPECT +Use of uninitialized value in hash dereference at - line 4. +######## +# pp_hot.c [pp_aassign] +use warnings 'misc' ; +my %X ; %X = (1,2,3) ; +no warnings 'misc' ; +my %Y ; %Y = (1,2,3) ; +EXPECT +Odd number of elements in hash assignment at - line 3. +######## +# pp_hot.c [pp_aassign] +use warnings 'misc' ; +my %X ; %X = [1 .. 3] ; +no warnings 'misc' ; +my %Y ; %Y = [1 .. 3] ; +EXPECT +Reference found where even-sized list expected at - line 3. +######## +# pp_hot.c [Perl_do_readline] +use warnings 'closed' ; +close STDIN ; $a = <STDIN> ; +opendir STDIN, "." ; $a = <STDIN> ; +closedir STDIN; +no warnings 'closed' ; +opendir STDIN, "." ; $a = <STDIN> ; +$a = <STDIN> ; +EXPECT +readline() on closed filehandle main::STDIN at - line 3. +readline() on closed filehandle main::STDIN at - line 4. + (Are you trying to call readline() on dirhandle main::STDIN?) +######## +# pp_hot.c [Perl_do_readline] +use warnings 'io' ; +my $file = "./xcv" ; unlink $file ; +open (FH, ">./xcv") ; +my $a = <FH> ; +no warnings 'io' ; +$a = <FH> ; +unlink $file ; +EXPECT +Filehandle main::FH opened only for output at - line 5. +######## +# pp_hot.c [Perl_sub_crush_depth] +use warnings 'recursion' ; +sub fred +{ + fred() if $a++ < 200 +} +{ + local $SIG{__WARN__} = sub { + die "ok\n" if $_[0] =~ /^Deep recursion on subroutine "main::fred"/ + }; + fred(); +} +EXPECT +ok +######## +# pp_hot.c [Perl_sub_crush_depth] +no warnings 'recursion' ; +sub fred +{ + fred() if $a++ < 200 +} +{ + local $SIG{__WARN__} = sub { + die "ok\n" if $_[0] =~ /^Deep recursion on subroutine "main::fred"/ + }; + fred(); +} +EXPECT + +######## +# pp_hot.c [Perl_sub_crush_depth] +use warnings 'recursion' ; +$b = sub +{ + &$b if $a++ < 200 +} ; + +&$b ; +EXPECT +Deep recursion on anonymous subroutine at - line 5. +######## +# pp_hot.c [Perl_sub_crush_depth] +no warnings 'recursion' ; +$b = sub +{ + &$b if $a++ < 200 +} ; + +&$b ; +EXPECT +######## +# 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"; +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. diff --git a/contrib/perl5/t/pragma/warn/pp_sys b/contrib/perl5/t/pragma/warn/pp_sys new file mode 100644 index 0000000..7c38727 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/pp_sys @@ -0,0 +1,354 @@ + pp_sys.c AOK + + untie attempted while %d inner references still exist [pp_untie] + sub TIESCALAR { bless [] } ; tie $a, 'main'; untie $a ; + + Filehandle %s opened only for input [pp_leavewrite] + format STDIN = + . + write STDIN; + + write() on closed filehandle %s [pp_leavewrite] + format STDIN = + . + close STDIN; + write STDIN ; + + page overflow [pp_leavewrite] + + Filehandle %s never opened [pp_prtf] + $a = "abc"; printf $a "fred" + + Filehandle %s opened only for input [pp_prtf] + $a = "abc"; + printf $a "fred" + + printf() on closed filehandle %s [pp_prtf] + close STDIN ; + printf STDIN "fred" + + syswrite() on closed filehandle %s [pp_send] + close STDIN; + syswrite STDIN, "fred", 1; + + send() on closed socket %s [pp_send] + close STDIN; + send STDIN, "fred", 1 + + bind() on closed socket %s [pp_bind] + close STDIN; + bind STDIN, "fred" ; + + + connect() on closed socket %s [pp_connect] + close STDIN; + connect STDIN, "fred" ; + + listen() on closed socket %s [pp_listen] + close STDIN; + listen STDIN, 2; + + accept() on closed socket %s [pp_accept] + close STDIN; + accept "fred", STDIN ; + + shutdown() on closed socket %s [pp_shutdown] + close STDIN; + shutdown STDIN, 0; + + setsockopt() on closed socket %s [pp_ssockopt] + getsockopt() on closed socket %s [pp_ssockopt] + close STDIN; + setsockopt STDIN, 1,2,3; + getsockopt STDIN, 1,2; + + getsockname() on closed socket %s [pp_getpeername] + getpeername() on closed socket %s [pp_getpeername] + close STDIN; + getsockname STDIN; + getpeername STDIN; + + flock() on closed socket %s [pp_flock] + close STDIN; + flock STDIN, 8; + + warn(warn_nl, "stat"); [pp_stat] + + Test on unopened file <%s> + close STDIN ; -T STDIN ; + + warn(warn_nl, "open"); [pp_fttext] + -T "abc\ndef" ; + + Filehandle %s opened only for output [pp_sysread] + my $file = "./xcv" ; + open(F, ">$file") ; + my $a = sysread(F, $a,10) ; + + + +__END__ +# pp_sys.c [pp_untie] +use warnings 'untie' ; +sub TIESCALAR { bless [] } ; +$b = tie $a, 'main'; +untie $a ; +no warnings 'untie' ; +$c = tie $d, 'main'; +untie $d ; +EXPECT +untie attempted while 1 inner references still exist at - line 5. +######## +# pp_sys.c [pp_leavewrite] +use warnings 'io' ; +format STDIN = +. +write STDIN; +no warnings 'io' ; +write STDIN; +EXPECT +Filehandle main::STDIN opened only for input at - line 5. +######## +# pp_sys.c [pp_leavewrite] +use warnings 'closed' ; +format STDIN = +. +close STDIN; +write STDIN; +opendir STDIN, "."; +write STDIN; +closedir STDIN; +no warnings 'closed' ; +write STDIN; +opendir STDIN, "."; +write STDIN; +EXPECT +write() on closed filehandle main::STDIN at - line 6. +write() on closed filehandle main::STDIN at - line 8. + (Are you trying to call write() on dirhandle main::STDIN?) +######## +# pp_sys.c [pp_leavewrite] +use warnings 'io' ; +format STDOUT_TOP = +abc +. +format STDOUT = +def +ghi +. +$= = 1 ; +$- =1 ; +open STDOUT, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ; +write ; +no warnings 'io' ; +write ; +EXPECT +page overflow at - line 13. +######## +# pp_sys.c [pp_prtf] +use warnings 'unopened' ; +$a = "abc"; +printf $a "fred"; +no warnings 'unopened' ; +printf $a "fred"; +EXPECT +Filehandle main::abc never opened at - line 4. +######## +# pp_sys.c [pp_prtf] +use warnings 'closed' ; +close STDIN ; +printf STDIN "fred"; +opendir STDIN, "."; +printf STDIN "fred"; +closedir STDIN; +no warnings 'closed' ; +printf STDIN "fred"; +opendir STDIN, "."; +printf STDIN "fred"; +EXPECT +printf() on closed filehandle main::STDIN at - line 4. +printf() on closed filehandle main::STDIN at - line 6. + (Are you trying to call printf() on dirhandle main::STDIN?) +######## +# pp_sys.c [pp_prtf] +use warnings 'io' ; +printf STDIN "fred"; +no warnings 'io' ; +printf STDIN "fred"; +EXPECT +Filehandle main::STDIN opened only for input at - line 3. +######## +# pp_sys.c [pp_send] +use warnings 'closed' ; +close STDIN; +syswrite STDIN, "fred", 1; +opendir STDIN, "."; +syswrite STDIN, "fred", 1; +closedir STDIN; +no warnings 'closed' ; +syswrite STDIN, "fred", 1; +opendir STDIN, "."; +syswrite STDIN, "fred", 1; +EXPECT +syswrite() on closed filehandle main::STDIN at - line 4. +syswrite() on closed filehandle main::STDIN at - line 6. + (Are you trying to call syswrite() on dirhandle main::STDIN?) +######## +# pp_sys.c [pp_flock] +use Config; +BEGIN { + if ( $^O eq 'VMS' and ! $Config{d_flock}) { + print <<EOM ; +SKIPPED +# flock not present +EOM + exit ; + } +} +use warnings 'closed' ; +close STDIN; +flock STDIN, 8; +opendir STDIN, "."; +flock STDIN, 8; +no warnings 'closed' ; +flock STDIN, 8; +opendir STDIN, "."; +flock STDIN, 8; +EXPECT +flock() on closed filehandle main::STDIN at - line 14. +flock() on closed filehandle main::STDIN at - line 16. + (Are you trying to call flock() on dirhandle main::STDIN?) +######## +# pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername] +use warnings 'io' ; +use Config; +BEGIN { + if ( $^O ne 'VMS' and ! $Config{d_socket}) { + print <<EOM ; +SKIPPED +# send not present +# bind not present +# connect not present +# accept not present +# shutdown not present +# setsockopt not present +# getsockopt not present +# getsockname not present +# getpeername not present +EOM + exit ; + } +} +close STDIN; +send STDIN, "fred", 1; +bind STDIN, "fred" ; +connect STDIN, "fred" ; +listen STDIN, 2; +accept "fred", STDIN; +shutdown STDIN, 0; +setsockopt STDIN, 1,2,3; +getsockopt STDIN, 1,2; +getsockname STDIN; +getpeername STDIN; +opendir STDIN, "."; +send STDIN, "fred", 1; +bind STDIN, "fred" ; +connect STDIN, "fred" ; +listen STDIN, 2; +accept "fred", STDIN; +shutdown STDIN, 0; +setsockopt STDIN, 1,2,3; +getsockopt STDIN, 1,2; +getsockname STDIN; +getpeername STDIN; +closedir STDIN; +no warnings 'io' ; +send STDIN, "fred", 1; +bind STDIN, "fred" ; +connect STDIN, "fred" ; +listen STDIN, 2; +accept STDIN, "fred" ; +shutdown STDIN, 0; +setsockopt STDIN, 1,2,3; +getsockopt STDIN, 1,2; +getsockname STDIN; +getpeername STDIN; +opendir STDIN, "."; +send STDIN, "fred", 1; +bind STDIN, "fred" ; +connect STDIN, "fred" ; +listen STDIN, 2; +accept "fred", STDIN; +shutdown STDIN, 0; +setsockopt STDIN, 1,2,3; +getsockopt STDIN, 1,2; +getsockname STDIN; +getpeername STDIN; +EXPECT +send() on closed socket main::STDIN at - line 22. +bind() on closed socket main::STDIN at - line 23. +connect() on closed socket main::STDIN at - line 24. +listen() on closed socket main::STDIN at - line 25. +accept() on closed socket main::STDIN at - line 26. +shutdown() on closed socket main::STDIN at - line 27. +setsockopt() on closed socket main::STDIN at - line 28. +getsockopt() on closed socket main::STDIN at - line 29. +getsockname() on closed socket main::STDIN at - line 30. +getpeername() on closed socket main::STDIN at - line 31. +send() on closed socket main::STDIN at - line 33. + (Are you trying to call send() on dirhandle main::STDIN?) +bind() on closed socket main::STDIN at - line 34. + (Are you trying to call bind() on dirhandle main::STDIN?) +connect() on closed socket main::STDIN at - line 35. + (Are you trying to call connect() on dirhandle main::STDIN?) +listen() on closed socket main::STDIN at - line 36. + (Are you trying to call listen() on dirhandle main::STDIN?) +accept() on closed socket main::STDIN at - line 37. + (Are you trying to call accept() on dirhandle main::STDIN?) +shutdown() on closed socket main::STDIN at - line 38. + (Are you trying to call shutdown() on dirhandle main::STDIN?) +setsockopt() on closed socket main::STDIN at - line 39. + (Are you trying to call setsockopt() on dirhandle main::STDIN?) +getsockopt() on closed socket main::STDIN at - line 40. + (Are you trying to call getsockopt() on dirhandle main::STDIN?) +getsockname() on closed socket main::STDIN at - line 41. + (Are you trying to call getsockname() on dirhandle main::STDIN?) +getpeername() on closed socket main::STDIN at - line 42. + (Are you trying to call getpeername() on dirhandle main::STDIN?) +######## +# pp_sys.c [pp_stat] +use warnings 'newline' ; +stat "abc\ndef"; +no warnings 'newline' ; +stat "abc\ndef"; +EXPECT +Unsuccessful stat on filename containing newline at - line 3. +######## +# pp_sys.c [pp_fttext] +use warnings 'unopened' ; +close STDIN ; +-T STDIN ; +no warnings 'unopened' ; +-T STDIN ; +EXPECT +Test on unopened file <STDIN> at - line 4. +######## +# pp_sys.c [pp_fttext] +use warnings 'newline' ; +-T "abc\ndef" ; +no warnings 'newline' ; +-T "abc\ndef" ; +EXPECT +Unsuccessful open on filename containing newline at - line 3. +######## +# pp_sys.c [pp_sysread] +use warnings 'io' ; +my $file = "./xcv" ; +open(F, ">$file") ; +my $a = sysread(F, $a,10) ; +no warnings 'io' ; +my $a = sysread(F, $a,10) ; +close F ; +unlink $file ; +EXPECT +Filehandle main::F opened only for output at - line 5. diff --git a/contrib/perl5/t/pragma/warn/regcomp b/contrib/perl5/t/pragma/warn/regcomp new file mode 100644 index 0000000..5d0c291 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/regcomp @@ -0,0 +1,165 @@ + regcomp.c AOK + + Strange *+?{} on zero-length expression [S_study_chunk] + /(?=a)?/ + + %.*s matches null string many times [S_regpiece] + $a = "ABC123" ; $a =~ /(?=a)*/' + + /%.127s/: Unrecognized escape \\%c passed through [S_regatom] + $x = '\m' ; /$x/ + + Character class [:%.*s:] unknown [S_regpposixcc] + + Character class syntax [. .] is reserved for future extensions [S_regpposixcc] + + Character class syntax [= =] is reserved for future extensions [S_checkposixcc] + + Character class syntax [%c %c] belongs inside character classes [S_checkposixcc] + + /%.127s/: false [] range \"%*.*s\" in regexp [S_regclass] + + /%.127s/: false [] range \"%*.*s\" in regexp [S_regclassutf8] + + /%.127s/: Unrecognized escape \\%c in character class passed through" [S_regclass] + + /%.127s/: Unrecognized escape \\%c in character class passed through" [S_regclassutf8] + +__END__ +# regcomp.c [S_regpiece] +use warnings 'regexp' ; +my $a = "ABC123" ; +$a =~ /(?=a)*/ ; +no warnings 'regexp' ; +$a =~ /(?=a)*/ ; +EXPECT +(?=a)* matches null string many times at - line 4. +######## +# regcomp.c [S_study_chunk] +use warnings 'regexp' ; +$_ = "" ; +/(?=a)?/; +no warnings 'regexp' ; +/(?=a)?/; +EXPECT +Strange *+?{} on zero-length expression at - line 4. +######## +# regcomp.c [S_regatom] +$x = '\m' ; +use warnings 'regexp' ; +$a =~ /a$x/ ; +no warnings 'regexp' ; +$a =~ /a$x/ ; +EXPECT +/a\m/: Unrecognized escape \m passed through at - line 4. +######## +# regcomp.c [S_regpposixcc S_checkposixcc] +BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 } +use warnings 'regexp' ; +$_ = "" ; +/[:alpha:]/; +/[.bar.]/; +/[=zog=]/; +/[[:alpha:]]/; +/[[.foo.]]/; +/[[=bar=]]/; +/[:zog:]/; +/[[:zog:]]/; +no warnings 'regexp' ; +/[:alpha:]/; +/[.foo.]/; +/[=bar=]/; +/[[:alpha:]]/; +/[[.foo.]]/; +/[[=bar=]]/; +/[[:zog:]]/; +/[:zog:]/; +EXPECT +Character class syntax [: :] belongs inside character classes at - line 5. +Character class syntax [. .] belongs inside character classes at - line 6. +Character class syntax [. .] is reserved for future extensions at - line 6. +Character class syntax [= =] belongs inside character classes at - line 7. +Character class syntax [= =] is reserved for future extensions at - line 7. +Character class syntax [. .] is reserved for future extensions at - line 9. +Character class syntax [= =] is reserved for future extensions at - line 10. +Character class syntax [: :] belongs inside character classes at - line 11. +Character class [:zog:] unknown at - line 12. +######## +# regcomp.c [S_regclass] +$_ = ""; +use warnings 'regexp' ; +/[a-b]/; +/[a-\d]/; +/[\d-b]/; +/[\s-\d]/; +/[\d-\s]/; +/[a-[:digit:]]/; +/[[:digit:]-b]/; +/[[:alpha:]-[:digit:]]/; +/[[:digit:]-[:alpha:]]/; +no warnings 'regexp' ; +/[a-b]/; +/[a-\d]/; +/[\d-b]/; +/[\s-\d]/; +/[\d-\s]/; +/[a-[:digit:]]/; +/[[:digit:]-b]/; +/[[:alpha:]-[:digit:]]/; +/[[:digit:]-[:alpha:]]/; +EXPECT +/[a-\d]/: false [] range "a-\d" in regexp at - line 5. +/[\d-b]/: false [] range "\d-" in regexp at - line 6. +/[\s-\d]/: false [] range "\s-" in regexp at - line 7. +/[\d-\s]/: false [] range "\d-" in regexp at - line 8. +/[a-[:digit:]]/: false [] range "a-[:digit:]" in regexp at - line 9. +/[[:digit:]-b]/: false [] range "[:digit:]-" in regexp at - line 10. +/[[:alpha:]-[:digit:]]/: false [] range "[:alpha:]-" in regexp at - line 11. +/[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 12. +######## +# regcomp.c [S_regclassutf8] +BEGIN { + if (ord("\t") == 5) { + print "SKIPPED\n# ebcdic regular expression ranges differ."; + exit 0; + } +} +use utf8; +$_ = ""; +use warnings 'regexp' ; +/[a-b]/; +/[a-\d]/; +/[\d-b]/; +/[\s-\d]/; +/[\d-\s]/; +/[a-[:digit:]]/; +/[[:digit:]-b]/; +/[[:alpha:]-[:digit:]]/; +/[[:digit:]-[:alpha:]]/; +no warnings 'regexp' ; +/[a-b]/; +/[a-\d]/; +/[\d-b]/; +/[\s-\d]/; +/[\d-\s]/; +/[a-[:digit:]]/; +/[[:digit:]-b]/; +/[[:alpha:]-[:digit:]]/; +/[[:digit:]-[:alpha:]]/; +EXPECT +/[a-\d]/: false [] range "a-\d" in regexp at - line 12. +/[\d-b]/: false [] range "\d-" in regexp at - line 13. +/[\s-\d]/: false [] range "\s-" in regexp at - line 14. +/[\d-\s]/: false [] range "\d-" in regexp at - line 15. +/[a-[:digit:]]/: false [] range "a-[:digit:]" in regexp at - line 16. +/[[:digit:]-b]/: false [] range "[:digit:]-" in regexp at - line 17. +/[[:alpha:]-[:digit:]]/: false [] range "[:alpha:]-" in regexp at - line 18. +/[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 19. +######## +# regcomp.c [S_regclass S_regclassutf8] +use warnings 'regexp' ; +$a =~ /[a\zb]/ ; +no warnings 'regexp' ; +$a =~ /[a\zb]/ ; +EXPECT +/[a\zb]/: Unrecognized escape \z in character class passed through at - line 3. diff --git a/contrib/perl5/t/pragma/warn/regexec b/contrib/perl5/t/pragma/warn/regexec new file mode 100644 index 0000000..73696df --- /dev/null +++ b/contrib/perl5/t/pragma/warn/regexec @@ -0,0 +1,119 @@ + regexec.c + + This test generates "bad free" warnings when run under + PERL_DESTRUCT_LEVEL. This file merely serves as a placeholder + for investigation. + + Complex regular subexpression recursion limit (%d) exceeded + + $_ = 'a' x (2**15+1); /^()(a\1)*$/ ; + Complex regular subexpression recursion limit (%d) exceeded + + $_ = 'a' x (2**15+1); /^()(a\1)*?$/ ; + + (The actual value substituted for %d is masked in the tests so that + REG_INFTY configuration variable value does not affect outcome.) +__END__ +# regexec.c +print("SKIPPED\n# most systems run into stacksize limits\n"),exit; +use warnings 'regexp' ; +$SIG{__WARN__} = sub{local ($m) = shift; + $m =~ s/\(\d+\)/(*MASKED*)/; + print STDERR $m}; +$_ = 'a' x (2**15+1); +/^()(a\1)*$/ ; +# +# If this test fails with a segmentation violation or similar, +# you may have to increase the default stacksize limit in your +# shell. You may need superuser privileges. +# +# Under the sh, ksh, zsh: +# $ ulimit -s +# 8192 +# $ ulimit -s 16000 +# +# Under the csh: +# % limit stacksize +# stacksize 8192 kbytes +# % limit stacksize 16000 +# +EXPECT +Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9. +######## +# regexec.c +print("SKIPPED\n# most systems run into stacksize limits\n"),exit; +no warnings 'regexp' ; +$SIG{__WARN__} = sub{local ($m) = shift; + $m =~ s/\(\d+\)/(*MASKED*)/; + print STDERR $m}; +$_ = 'a' x (2**15+1); +/^()(a\1)*$/ ; +# +# If this test fails with a segmentation violation or similar, +# you may have to increase the default stacksize limit in your +# shell. You may need superuser privileges. +# +# Under the sh, ksh, zsh: +# $ ulimit -s +# 8192 +# $ ulimit -s 16000 +# +# Under the csh: +# % limit stacksize +# stacksize 8192 kbytes +# % limit stacksize 16000 +# +EXPECT + +######## +# regexec.c +print("SKIPPED\n# most systems run into stacksize limits\n"),exit; +use warnings 'regexp' ; +$SIG{__WARN__} = sub{local ($m) = shift; + $m =~ s/\(\d+\)/(*MASKED*)/; + print STDERR $m}; +$_ = 'a' x (2**15+1); +/^()(a\1)*?$/ ; +# +# If this test fails with a segmentation violation or similar, +# you may have to increase the default stacksize limit in your +# shell. You may need superuser privileges. +# +# Under the sh, ksh, zsh: +# $ ulimit -s +# 8192 +# $ ulimit -s 16000 +# +# Under the csh: +# % limit stacksize +# stacksize 8192 kbytes +# % limit stacksize 16000 +# +EXPECT +Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9. +######## +# regexec.c +print("SKIPPED\n# most systems run into stacksize limits\n"),exit; +no warnings 'regexp' ; +$SIG{__WARN__} = sub{local ($m) = shift; + $m =~ s/\(\d+\)/(*MASKED*)/; + print STDERR $m}; +$_ = 'a' x (2**15+1); +/^()(a\1)*?$/ ; +# +# If this test fails with a segmentation violation or similar, +# you may have to increase the default stacksize limit in your +# shell. You may need superuser privileges. +# +# Under the sh, ksh, zsh: +# $ ulimit -s +# 8192 +# $ ulimit -s 16000 +# +# Under the csh: +# % limit stacksize +# stacksize 8192 kbytes +# % limit stacksize 16000 +# +EXPECT + diff --git a/contrib/perl5/t/pragma/warn/run b/contrib/perl5/t/pragma/warn/run new file mode 100644 index 0000000..7a4be20 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/run @@ -0,0 +1,8 @@ + run.c + + + Mandatory Warnings ALL TODO + ------------------ + NULL OP IN RUN + +__END__ diff --git a/contrib/perl5/t/pragma/warn/sv b/contrib/perl5/t/pragma/warn/sv new file mode 100644 index 0000000..758137f --- /dev/null +++ b/contrib/perl5/t/pragma/warn/sv @@ -0,0 +1,303 @@ + sv.c + + warn(warn_uninit); + + warn(warn_uninit); + + warn(warn_uninit); + + warn(warn_uninit); + + not_a_number(sv); + + not_a_number(sv); + + warn(warn_uninit); + + not_a_number(sv); + + warn(warn_uninit); + + not_a_number(sv); + + not_a_number(sv); + + warn(warn_uninit); + + warn(warn_uninit); + + Subroutine %s redefined + + Invalid conversion in %s: + + Undefined value assigned to typeglob + + Possible Y2K bug: %d format string following '19' + + Reference is already weak [Perl_sv_rvweaken] <<TODO + + Mandatory Warnings + ------------------ + Malformed UTF-8 character [sv_pos_b2u] (not tested: difficult to produce + with perl now) + + Mandatory Warnings TODO + ------------------ + Attempt to free non-arena SV: 0x%lx [del_sv] + Reference miscount in sv_replace() [sv_replace] + Attempt to free unreferenced scalar [sv_free] + Attempt to free temp prematurely: SV 0x%lx [sv_free] + semi-panic: attempt to dup freed string [newSVsv] + + +__END__ +# sv.c +use integer ; +use warnings 'uninitialized' ; +$x = 1 + $a[0] ; # a +no warnings 'uninitialized' ; +$x = 1 + $b[0] ; # a +EXPECT +Use of uninitialized value in integer addition (+) at - line 4. +######## +# sv.c (sv_2iv) +package fred ; +sub TIESCALAR { my $x ; bless \$x} +sub FETCH { return undef } +sub STORE { return 1 } +package main ; +tie $A, 'fred' ; +use integer ; +use warnings 'uninitialized' ; +$A *= 2 ; +no warnings 'uninitialized' ; +$A *= 2 ; +EXPECT +Use of uninitialized value in integer multiplication (*) at - line 10. +######## +# sv.c +use integer ; +use warnings 'uninitialized' ; +my $x *= 2 ; #b +no warnings 'uninitialized' ; +my $y *= 2 ; #b +EXPECT +Use of uninitialized value in integer multiplication (*) at - line 4. +######## +# sv.c (sv_2uv) +package fred ; +sub TIESCALAR { my $x ; bless \$x} +sub FETCH { return undef } +sub STORE { return 1 } +package main ; +tie $A, 'fred' ; +use warnings 'uninitialized' ; +$B = 0 ; +$B |= $A ; +no warnings 'uninitialized' ; +$B = 0 ; +$B |= $A ; +EXPECT +Use of uninitialized value in bitwise or (|) at - line 10. +######## +# sv.c +use warnings 'uninitialized' ; +my $Y = 1 ; +my $x = 1 | $a[$Y] ; +no warnings 'uninitialized' ; +my $Y = 1 ; +$x = 1 | $b[$Y] ; +EXPECT +Use of uninitialized value in bitwise or (|) at - line 4. +######## +# sv.c +use warnings 'uninitialized' ; +my $x *= 1 ; # d +no warnings 'uninitialized' ; +my $y *= 1 ; # d +EXPECT +Use of uninitialized value in multiplication (*) at - line 3. +######## +# sv.c +use warnings 'uninitialized' ; +$x = 1 + $a[0] ; # e +no warnings 'uninitialized' ; +$x = 1 + $b[0] ; # e +EXPECT +Use of uninitialized value in addition (+) at - line 3. +######## +# sv.c (sv_2nv) +package fred ; +sub TIESCALAR { my $x ; bless \$x} +sub FETCH { return undef } +sub STORE { return 1 } +package main ; +tie $A, 'fred' ; +use warnings 'uninitialized' ; +$A *= 2 ; +no warnings 'uninitialized' ; +$A *= 2 ; +EXPECT +Use of uninitialized value in multiplication (*) at - line 9. +######## +# sv.c +use warnings 'uninitialized' ; +$x = $y + 1 ; # f +no warnings 'uninitialized' ; +$x = $z + 1 ; # f +EXPECT +Use of uninitialized value in addition (+) at - line 3. +######## +# sv.c +use warnings 'uninitialized' ; +$x = chop undef ; # g +no warnings 'uninitialized' ; +$x = chop undef ; # g +EXPECT +Modification of a read-only value attempted at - line 3. +######## +# sv.c +use warnings 'uninitialized' ; +$x = chop $y ; # h +no warnings 'uninitialized' ; +$x = chop $z ; # h +EXPECT +Use of uninitialized value in scalar chop at - line 3. +######## +# sv.c (sv_2pv) +package fred ; +sub TIESCALAR { my $x ; bless \$x} +sub FETCH { return undef } +sub STORE { return 1 } +package main ; +tie $A, 'fred' ; +use warnings 'uninitialized' ; +$B = "" ; +$B .= $A ; +no warnings 'uninitialized' ; +$C = "" ; +$C .= $A ; +EXPECT +Use of uninitialized value in concatenation (.) at - line 10. +######## +# sv.c +use warnings 'numeric' ; +sub TIESCALAR{bless[]} ; +sub FETCH {"def"} ; +tie $a,"main" ; +my $b = 1 + $a; +no warnings 'numeric' ; +my $c = 1 + $a; +EXPECT +Argument "def" isn't numeric in addition (+) at - line 6. +######## +# sv.c +use warnings 'numeric' ; +my $x = 1 + "def" ; +no warnings 'numeric' ; +my $z = 1 + "def" ; +EXPECT +Argument "def" isn't numeric in addition (+) at - line 3. +######## +# sv.c +use warnings 'numeric' ; +my $a = "def" ; +my $x = 1 + $a ; +no warnings 'numeric' ; +my $y = 1 + $a ; +EXPECT +Argument "def" isn't numeric in addition (+) at - line 4. +######## +# sv.c +use warnings 'numeric' ; use integer ; +my $a = "def" ; +my $x = 1 + $a ; +no warnings 'numeric' ; +my $z = 1 + $a ; +EXPECT +Argument "def" isn't numeric in integer addition (+) at - line 4. +######## +# sv.c +use warnings 'numeric' ; +my $x = 1 & "def" ; +no warnings 'numeric' ; +my $z = 1 & "def" ; +EXPECT +Argument "def" isn't numeric in bitwise and (&) at - line 3. +######## +# sv.c +use warnings 'redefine' ; +sub fred {} +sub joe {} +*fred = \&joe ; +no warnings 'redefine' ; +sub jim {} +*jim = \&joe ; +EXPECT +Subroutine fred redefined at - line 5. +######## +# sv.c +use warnings 'printf' ; +open F, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ; +printf F "%z\n" ; +my $a = sprintf "%z" ; +printf F "%" ; +$a = sprintf "%" ; +printf F "%\x02" ; +$a = sprintf "%\x02" ; +no warnings 'printf' ; +printf F "%z\n" ; +$a = sprintf "%z" ; +printf F "%" ; +$a = sprintf "%" ; +printf F "%\x02" ; +$a = sprintf "%\x02" ; +EXPECT +Invalid conversion in sprintf: "%z" at - line 5. +Invalid conversion in sprintf: end of string at - line 7. +Invalid conversion in sprintf: "%\002" at - line 9. +Invalid conversion in printf: "%z" at - line 4. +Invalid conversion in printf: end of string at - line 6. +Invalid conversion in printf: "%\002" at - line 8. +######## +# sv.c +use warnings 'misc' ; +*a = undef ; +no warnings 'misc' ; +*b = undef ; +EXPECT +Undefined value assigned to typeglob at - line 3. +######## +# sv.c +use warnings 'y2k'; +use Config; +BEGIN { + unless ($Config{ccflags} =~ /Y2KWARN/) { + print "SKIPPED\n# perl not built with -DPERL_Y2KWARN"; + exit 0; + } + $|=1; +} +my $x; +my $yy = 78; +$x = printf "19%02d\n", $yy; +$x = sprintf "#19%02d\n", $yy; +$x = printf " 19%02d\n", 78; +$x = sprintf "19%02d\n", 78; +$x = printf "319%02d\n", $yy; +$x = sprintf "319%02d\n", $yy; +no warnings 'y2k'; +$x = printf "19%02d\n", $yy; +$x = sprintf "19%02d\n", $yy; +$x = printf "19%02d\n", 78; +$x = sprintf "19%02d\n", 78; +EXPECT +Possible Y2K bug: %d format string following '19' at - line 16. +Possible Y2K bug: %d format string following '19' at - line 13. +1978 +Possible Y2K bug: %d format string following '19' at - line 14. +Possible Y2K bug: %d format string following '19' at - line 15. + 1978 +31978 +1978 +1978 diff --git a/contrib/perl5/t/pragma/warn/taint b/contrib/perl5/t/pragma/warn/taint new file mode 100644 index 0000000..fd6deed --- /dev/null +++ b/contrib/perl5/t/pragma/warn/taint @@ -0,0 +1,49 @@ + taint.c AOK + + Insecure %s%s while running with -T switch + +__END__ +-T +--FILE-- abc +def +--FILE-- +# taint.c +open(FH, "<abc") ; +$a = <FH> ; +close FH ; +chdir $a ; +print "xxx\n" ; +EXPECT +Insecure dependency in chdir while running with -T switch at - line 5. +######## +-TU +--FILE-- abc +def +--FILE-- +# taint.c +open(FH, "<abc") ; +$a = <FH> ; +close FH ; +chdir $a ; +print "xxx\n" ; +EXPECT +xxx +######## +-TU +--FILE-- abc +def +--FILE-- +# taint.c +open(FH, "<abc") ; +$a = <FH> ; +close FH ; +use warnings 'taint' ; +chdir $a ; +print "xxx\n" ; +no warnings 'taint' ; +chdir $a ; +print "yyy\n" ; +EXPECT +Insecure dependency in chdir while running with -T switch at - line 6. +xxx +yyy diff --git a/contrib/perl5/t/pragma/warn/toke b/contrib/perl5/t/pragma/warn/toke new file mode 100644 index 0000000..cfdea78 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/toke @@ -0,0 +1,583 @@ +toke.c AOK + + we seem to have lost a few ambiguous warnings!! + + + 1 if $a EQ $b ; + 1 if $a NE $b ; + 1 if $a LT $b ; + 1 if $a GT $b ; + 1 if $a GE $b ; + 1 if $a LE $b ; + $a = <<; + Use of comma-less variable list is deprecated + (called 3 times via depcom) + + \1 better written as $1 + use warnings 'syntax' ; + s/(abc)/\1/; + + warn(warn_nosemi) + Semicolon seems to be missing + $a = 1 + &time ; + + + Reversed %c= operator + my $a =+ 2 ; + $a =- 2 ; + $a =* 2 ; + $a =% 2 ; + $a =& 2 ; + $a =. 2 ; + $a =^ 2 ; + $a =| 2 ; + $a =< 2 ; + $a =/ 2 ; + + Multidimensional syntax %.*s not supported + my $a = $a[1,2] ; + + You need to quote \"%s\"" + sub fred {} ; $SIG{TERM} = fred; + + Scalar value %.*s better written as $%.*s" + @a[3] = 2; + @a{3} = 2; + + Can't use \\%c to mean $%c in expression + $_ = "ab" ; s/(ab)/\1/e; + + Unquoted string "abc" may clash with future reserved word at - line 3. + warn(warn_reserved + $a = abc; + + chmod() mode argument is missing initial 0 + chmod 3; + + Possible attempt to separate words with commas + @a = qw(a, b, c) ; + + Possible attempt to put comments in qw() list + @a = qw(a b # c) ; + + umask: argument is missing initial 0 + umask 3; + + %s (...) interpreted as function + print ("") + printf ("") + sort ("") + + Ambiguous use of %c{%s%s} resolved to %c%s%s + $a = ${time[2]} + $a = ${time{2}} + + + Ambiguous use of %c{%s} resolved to %c%s + $a = ${time} + sub fred {} $a = ${fred} + + Misplaced _ in number + $a = 1_2; + $a = 1_2345_6; + + Bareword \"%s\" refers to nonexistent package + $a = FRED:: ; + + Ambiguous call resolved as CORE::%s(), qualify as such or use & + sub time {} + my $a = time() + + Unrecognized escape \\%c passed through + $a = "\m" ; + + %s number > %s non-portable + my $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b111111111111111111111111111111111 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x1ffffffff ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 0047777777777 ; + + Integer overflow in binary number + my $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b111111111111111111111111111111111 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x1ffffffff ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 0047777777777 ; + + Mandatory Warnings + ------------------ + Use of "%s" without parentheses is ambiguous [check_uni] + rand + 4 + + Ambiguous use of -%s resolved as -&%s() [yylex] + sub fred {} ; - fred ; + + Precedence problem: open %.*s should be open(%.*s) [yylex] + open FOO || die; + + Operator or semicolon missing before %c%s [yylex] + Ambiguous use of %c resolved as operator %c + *foo *foo + +__END__ +# toke.c +use warnings 'deprecated' ; +1 if $a EQ $b ; +1 if $a NE $b ; +1 if $a GT $b ; +1 if $a LT $b ; +1 if $a GE $b ; +1 if $a LE $b ; +no warnings 'deprecated' ; +1 if $a EQ $b ; +1 if $a NE $b ; +1 if $a GT $b ; +1 if $a LT $b ; +1 if $a GE $b ; +1 if $a LE $b ; +EXPECT +Use of EQ is deprecated at - line 3. +Use of NE is deprecated at - line 4. +Use of GT is deprecated at - line 5. +Use of LT is deprecated at - line 6. +Use of GE is deprecated at - line 7. +Use of LE is deprecated at - line 8. +######## +# toke.c +use warnings 'deprecated' ; +format STDOUT = +@<<< @||| @>>> @>>> +$a $b "abc" 'def' +. +no warnings 'deprecated' ; +format STDOUT = +@<<< @||| @>>> @>>> +$a $b "abc" 'def' +. +EXPECT +Use of comma-less variable list is deprecated at - line 5. +Use of comma-less variable list is deprecated at - line 5. +Use of comma-less variable list is deprecated at - line 5. +######## +# toke.c +use warnings 'deprecated' ; +$a = <<; + +no warnings 'deprecated' ; +$a = <<; + +EXPECT +Use of bare << to mean <<"" is deprecated at - line 3. +######## +# toke.c +use warnings 'syntax' ; +s/(abc)/\1/; +no warnings 'syntax' ; +s/(abc)/\1/; +EXPECT +\1 better written as $1 at - line 3. +######## +# toke.c +use warnings 'semicolon' ; +$a = 1 +&time ; +no warnings 'semicolon' ; +$a = 1 +&time ; +EXPECT +Semicolon seems to be missing at - line 3. +######## +# toke.c +BEGIN { + # Scalars leaked: due to syntax errors + $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; +} +use warnings 'syntax' ; +my $a =+ 2 ; +$a =- 2 ; +$a =* 2 ; +$a =% 2 ; +$a =& 2 ; +$a =. 2 ; +$a =^ 2 ; +$a =| 2 ; +$a =< 2 ; +$a =/ 2 ; +EXPECT +Reversed += operator at - line 7. +Reversed -= operator at - line 8. +Reversed *= operator at - line 9. +Reversed %= operator at - line 10. +Reversed &= operator at - line 11. +Reversed .= operator at - line 12. +syntax error at - line 12, near "=." +Reversed ^= operator at - line 13. +syntax error at - line 13, near "=^" +Reversed |= operator at - line 14. +syntax error at - line 14, near "=|" +Reversed <= operator at - line 15. +Unterminated <> operator at - line 15. +######## +# toke.c +BEGIN { + # Scalars leaked: due to syntax errors + $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; +} +no warnings 'syntax' ; +my $a =+ 2 ; +$a =- 2 ; +$a =* 2 ; +$a =% 2 ; +$a =& 2 ; +$a =. 2 ; +$a =^ 2 ; +$a =| 2 ; +$a =< 2 ; +$a =/ 2 ; +EXPECT +syntax error at - line 12, near "=." +syntax error at - line 13, near "=^" +syntax error at - line 14, near "=|" +Unterminated <> operator at - line 15. +######## +# toke.c +use warnings 'syntax' ; +my $a = $a[1,2] ; +no warnings 'syntax' ; +my $a = $a[1,2] ; +EXPECT +Multidimensional syntax $a[1,2] not supported at - line 3. +######## +# toke.c +use warnings 'syntax' ; +sub fred {} ; $SIG{TERM} = fred; +no warnings 'syntax' ; +$SIG{TERM} = fred; +EXPECT +You need to quote "fred" at - line 3. +######## +# toke.c +use warnings 'syntax' ; +@a[3] = 2; +@a{3} = 2; +no warnings 'syntax' ; +@a[3] = 2; +@a{3} = 2; +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. +######## +# toke.c +use warnings 'syntax' ; +$_ = "ab" ; +s/(ab)/\1/e; +no warnings 'syntax' ; +$_ = "ab" ; +s/(ab)/\1/e; +EXPECT +Can't use \1 to mean $1 in expression at - line 4. +######## +# toke.c +use warnings 'reserved' ; +$a = abc; +no warnings 'reserved' ; +$a = abc; +EXPECT +Unquoted string "abc" may clash with future reserved word at - line 3. +######## +# toke.c +use warnings 'chmod' ; +chmod 3; +no warnings 'chmod' ; +chmod 3; +EXPECT +chmod() mode argument is missing initial 0 at - line 3. +######## +# toke.c +use warnings 'qw' ; +@a = qw(a, b, c) ; +no warnings 'qw' ; +@a = qw(a, b, c) ; +EXPECT +Possible attempt to separate words with commas at - line 3. +######## +# toke.c +use warnings 'qw' ; +@a = qw(a b #) ; +no warnings 'qw' ; +@a = qw(a b #) ; +EXPECT +Possible attempt to put comments in qw() list at - line 3. +######## +# toke.c +use warnings 'umask' ; +umask 3; +no warnings 'umask' ; +umask 3; +EXPECT +umask: argument is missing initial 0 at - line 3. +######## +# toke.c +use warnings 'syntax' ; +print ("") +EXPECT +print (...) interpreted as function at - line 3. +######## +# toke.c +no warnings 'syntax' ; +print ("") +EXPECT + +######## +# toke.c +use warnings 'syntax' ; +printf ("") +EXPECT +printf (...) interpreted as function at - line 3. +######## +# toke.c +no warnings 'syntax' ; +printf ("") +EXPECT + +######## +# toke.c +use warnings 'syntax' ; +sort ("") +EXPECT +sort (...) interpreted as function at - line 3. +######## +# toke.c +no warnings 'syntax' ; +sort ("") +EXPECT + +######## +# toke.c +use warnings 'ambiguous' ; +$a = ${time[2]}; +no warnings 'ambiguous' ; +$a = ${time[2]}; +EXPECT +Ambiguous use of ${time[...]} resolved to $time[...] at - line 3. +######## +# toke.c +use warnings 'ambiguous' ; +$a = ${time{2}}; +EXPECT +Ambiguous use of ${time{...}} resolved to $time{...} at - line 3. +######## +# toke.c +no warnings 'ambiguous' ; +$a = ${time{2}}; +EXPECT + +######## +# toke.c +use warnings 'ambiguous' ; +$a = ${time} ; +no warnings 'ambiguous' ; +$a = ${time} ; +EXPECT +Ambiguous use of ${time} resolved to $time at - line 3. +######## +# toke.c +use warnings 'ambiguous' ; +sub fred {} +$a = ${fred} ; +no warnings 'ambiguous' ; +$a = ${fred} ; +EXPECT +Ambiguous use of ${fred} resolved to $fred at - line 4. +######## +# toke.c +use warnings 'syntax' ; +$a = 1_2; +$a = 1_2345_6; +no warnings 'syntax' ; +$a = 1_2; +$a = 1_2345_6; +EXPECT +Misplaced _ in number at - line 3. +Misplaced _ in number at - line 4. +Misplaced _ in number at - line 4. +######## +# toke.c +use warnings 'bareword' ; +#line 25 "bar" +$a = FRED:: ; +no warnings 'bareword' ; +#line 25 "bar" +$a = FRED:: ; +EXPECT +Bareword "FRED::" refers to nonexistent package at bar line 25. +######## +# toke.c +use warnings 'ambiguous' ; +sub time {} +my $a = time() ; +no warnings 'ambiguous' ; +my $b = time() ; +EXPECT +Ambiguous call resolved as CORE::time(), qualify as such or use & at - line 4. +######## +# toke.c +use warnings ; +eval <<'EOE'; +{ +#line 30 "foo" + $_ = " \x{123} " ; +} +EOE +EXPECT + +######## +# toke.c +my $a = rand + 4 ; +EXPECT +Warning: Use of "rand" without parens is ambiguous at - line 2. +######## +# toke.c +$^W = 0 ; +my $a = rand + 4 ; +{ + no warnings 'ambiguous' ; + $a = rand + 4 ; + use warnings 'ambiguous' ; + $a = rand + 4 ; +} +$a = rand + 4 ; +EXPECT +Warning: Use of "rand" without parens is ambiguous at - line 3. +Warning: Use of "rand" without parens is ambiguous at - line 8. +Warning: Use of "rand" without parens is ambiguous at - line 10. +######## +# toke.c +sub fred {}; +-fred ; +EXPECT +Ambiguous use of -fred resolved as -&fred() at - line 3. +######## +# toke.c +$^W = 0 ; +sub fred {} ; +-fred ; +{ + no warnings 'ambiguous' ; + -fred ; + use warnings 'ambiguous' ; + -fred ; +} +-fred ; +EXPECT +Ambiguous use of -fred resolved as -&fred() at - line 4. +Ambiguous use of -fred resolved as -&fred() at - line 9. +Ambiguous use of -fred resolved as -&fred() at - line 11. +######## +# toke.c +open FOO || time; +EXPECT +Precedence problem: open FOO should be open(FOO) at - line 2. +######## +# toke.c +$^W = 0 ; +open FOO || time; +{ + no warnings 'precedence' ; + open FOO || time; + use warnings 'precedence' ; + open FOO || time; +} +open FOO || time; +EXPECT +Precedence problem: open FOO should be open(FOO) at - line 3. +Precedence problem: open FOO should be open(FOO) at - line 8. +Precedence problem: open FOO should be open(FOO) at - line 10. +######## +# toke.c +$^W = 0 ; +*foo *foo ; +{ + no warnings 'ambiguous' ; + *foo *foo ; + use warnings 'ambiguous' ; + *foo *foo ; +} +*foo *foo ; +EXPECT +Operator or semicolon missing before *foo at - line 3. +Ambiguous use of * resolved as operator * at - line 3. +Operator or semicolon missing before *foo at - line 8. +Ambiguous use of * resolved as operator * at - line 8. +Operator or semicolon missing before *foo at - line 10. +Ambiguous use of * resolved as operator * at - line 10. +######## +# toke.c +use warnings 'misc' ; +my $a = "\m" ; +no warnings 'misc' ; +$a = "\m" ; +EXPECT +Unrecognized escape \m passed through at - line 3. +######## +# toke.c +use warnings 'portable' ; +my $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b111111111111111111111111111111111 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x1ffffffff ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 0047777777777 ; +no warnings 'portable' ; + $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b111111111111111111111111111111111 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x1ffffffff ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 0047777777777 ; +EXPECT +Binary number > 0b11111111111111111111111111111111 non-portable at - line 5. +Hexadecimal number > 0xffffffff non-portable at - line 8. +Octal number > 037777777777 non-portable at - line 11. +######## +# toke.c +use warnings 'overflow' ; +my $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b10000000000000000000000000000000000000000000000000000000000000000 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x10000000000000000 ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 002000000000000000000000; +no warnings 'overflow' ; + $a = 0b011111111111111111111111111111110 ; + $a = 0b011111111111111111111111111111111 ; + $a = 0b10000000000000000000000000000000000000000000000000000000000000000 ; + $a = 0x0fffffffe ; + $a = 0x0ffffffff ; + $a = 0x10000000000000000 ; + $a = 0037777777776 ; + $a = 0037777777777 ; + $a = 002000000000000000000000; +EXPECT +Integer overflow in binary number at - line 5. +Integer overflow in hexadecimal number at - line 8. +Integer overflow in octal number at - line 11. diff --git a/contrib/perl5/t/pragma/warn/universal b/contrib/perl5/t/pragma/warn/universal new file mode 100644 index 0000000..6dbb1be --- /dev/null +++ b/contrib/perl5/t/pragma/warn/universal @@ -0,0 +1,16 @@ + universal.c AOK + + Can't locate package %s for @%s::ISA [S_isa_lookup] + + + +__END__ +# universal.c [S_isa_lookup] +use warnings 'misc' ; +@ISA = qw(Joe) ; +my $a = bless [] ; +UNIVERSAL::isa $a, Jim ; +EXPECT +Can't locate package Joe for @main::ISA at - line 5. +Can't locate package Joe for @main::ISA. +Can't locate package Joe for @main::ISA. diff --git a/contrib/perl5/t/pragma/warn/utf8 b/contrib/perl5/t/pragma/warn/utf8 new file mode 100644 index 0000000..6a2fe54 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/utf8 @@ -0,0 +1,29 @@ + + utf8.c AOK + + [utf8_to_uv] + Malformed UTF-8 character + my $a = ord "\x80" ; + + Malformed UTF-8 character + my $a = ord "\xf080" ; + <<<<<< this warning can't be easily triggered from perl anymore + + [utf16_to_utf8] + Malformed UTF-16 surrogate + <<<<<< Add a test when somethig actually calls utf16_to_utf8 + +__END__ +# utf8.c [utf8_to_uv] -W +use utf8 ; +my $a = "snstorm" ; +{ + no warnings 'utf8' ; + my $a = "snstorm"; + use warnings 'utf8' ; + my $a = "snstorm"; +} +EXPECT +Malformed UTF-8 character at - line 3. +Malformed UTF-8 character at - line 8. +######## diff --git a/contrib/perl5/t/pragma/warn/util b/contrib/perl5/t/pragma/warn/util new file mode 100644 index 0000000..e82d6a6 --- /dev/null +++ b/contrib/perl5/t/pragma/warn/util @@ -0,0 +1,108 @@ + util.c AOK + + Illegal octal digit ignored + my $a = oct "029" ; + + Illegal hex digit ignored + my $a = hex "0xv9" ; + + Illegal binary digit ignored + my $a = oct "0b9" ; + + Integer overflow in binary number + my $a = oct "0b111111111111111111111111111111111111111111" ; + Binary number > 0b11111111111111111111111111111111 non-portable + $a = oct "0b111111111111111111111111111111111" ; + Integer overflow in octal number + my $a = oct "077777777777777777777777777777" ; + Octal number > 037777777777 non-portable + $a = oct "0047777777777" ; + Integer overflow in hexadecimal number + my $a = hex "0xffffffffffffffffffff" ; + Hexadecimal number > 0xffffffff non-portable + $a = hex "0x1ffffffff" ; + +__END__ +# util.c +use warnings 'digit' ; +my $a = oct "029" ; +no warnings 'digit' ; +$a = oct "029" ; +EXPECT +Illegal octal digit '9' ignored at - line 3. +######## +# util.c +use warnings 'digit' ; +my $a = hex "0xv9" ; +no warnings 'digit' ; +$a = hex "0xv9" ; +EXPECT +Illegal hexadecimal digit 'v' ignored at - line 3. +######## +# util.c +use warnings 'digit' ; +my $a = oct "0b9" ; +no warnings 'digit' ; +$a = oct "0b9" ; +EXPECT +Illegal binary digit '9' ignored at - line 3. +######## +# util.c +use warnings 'overflow' ; +my $a = oct "0b11111111111111111111111111111111111111111111111111111111111111111"; +no warnings 'overflow' ; +$a = oct "0b11111111111111111111111111111111111111111111111111111111111111111"; +EXPECT +Integer overflow in binary number at - line 3. +######## +# util.c +use warnings 'overflow' ; +my $a = hex "0xffffffffffffffffffff" ; +no warnings 'overflow' ; +$a = hex "0xffffffffffffffffffff" ; +EXPECT +Integer overflow in hexadecimal number at - line 3. +######## +# util.c +use warnings 'overflow' ; +my $a = oct "077777777777777777777777777777" ; +no warnings 'overflow' ; +$a = oct "077777777777777777777777777777" ; +EXPECT +Integer overflow in octal number at - line 3. +######## +# util.c +use warnings 'portable' ; +my $a = oct "0b011111111111111111111111111111110" ; + $a = oct "0b011111111111111111111111111111111" ; + $a = oct "0b111111111111111111111111111111111" ; +no warnings 'portable' ; + $a = oct "0b011111111111111111111111111111110" ; + $a = oct "0b011111111111111111111111111111111" ; + $a = oct "0b111111111111111111111111111111111" ; +EXPECT +Binary number > 0b11111111111111111111111111111111 non-portable at - line 5. +######## +# util.c +use warnings 'portable' ; +my $a = hex "0x0fffffffe" ; + $a = hex "0x0ffffffff" ; + $a = hex "0x1ffffffff" ; +no warnings 'portable' ; + $a = hex "0x0fffffffe" ; + $a = hex "0x0ffffffff" ; + $a = hex "0x1ffffffff" ; +EXPECT +Hexadecimal number > 0xffffffff non-portable at - line 5. +######## +# util.c +use warnings 'portable' ; +my $a = oct "0037777777776" ; + $a = oct "0037777777777" ; + $a = oct "0047777777777" ; +no warnings 'portable' ; + $a = oct "0037777777776" ; + $a = oct "0037777777777" ; + $a = oct "0047777777777" ; +EXPECT +Octal number > 037777777777 non-portable at - line 5. diff --git a/contrib/perl5/t/pragma/warnings.t b/contrib/perl5/t/pragma/warnings.t new file mode 100755 index 0000000..71fb0df --- /dev/null +++ b/contrib/perl5/t/pragma/warnings.t @@ -0,0 +1,121 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + $ENV{PERL5LIB} = '../lib'; + require Config; import Config; +} + +$| = 1; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MSWin32 = $^O eq 'MSWin32'; +my $tmpfile = "tmp0000"; +my $i = 0 ; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile} } + +my @prgs = () ; +my @w_files = () ; + +if (@ARGV) + { print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./pragma/warn/#; $_ } @ARGV } +else + { @w_files = sort glob("pragma/warn/*") } + +foreach (@w_files) { + + next if /\.orig$/ ; + + next if /(~|\.orig)$/; + + open F, "<$_" or die "Cannot open $_: $!\n" ; + while (<F>) { + last if /^__END__/ ; + } + + { + local $/ = undef; + @prgs = (@prgs, split "\n########\n", <F>) ; + } + close F ; +} + +undef $/; + +print "1..", scalar @prgs, "\n"; + + +for (@prgs){ + my $switch = ""; + my @temps = () ; + if (s/^\s*-\w+//){ + $switch = $&; + $switch =~ s/(-\S*[A-Z]\S*)/"$1"/ if $Is_VMS; # protect uc switches + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + if ( $prog =~ /--FILE--/) { + my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; + shift @files ; + die "Internal error test $i didn't split into pairs, got " . + scalar(@files) . "[" . join("%%%%", @files) ."]\n" + if @files % 2 ; + while (@files > 2) { + my $filename = shift @files ; + my $code = shift @files ; + push @temps, $filename ; + open F, ">$filename" or die "Cannot open $filename: $!\n" ; + print F $code ; + close F ; + } + shift @files ; + $prog = shift @files ; + } + open TEST, ">$tmpfile"; + print TEST $prog,"\n"; + close TEST; + my $results = $Is_VMS ? + `./perl "-I../lib" $switch $tmpfile 2>&1` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + `./perl -I../lib $switch $tmpfile 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/tmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg +# 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; + if ($expected =~ s/^OPTIONS? (.+)\n//) { + foreach my $option (split(' ', $1)) { + if ($option eq 'regex') { # allow regular expressions + $option_regex = 1; + } else { + die "$0: Unknown OPTION '$option'\n"; + } + } + } + if ( $results =~ s/^SKIPPED\n//) { + print "$results\n" ; + } + elsif (($prefix && (( $option_regex && $results !~ /^$expected/) || + (!$option_regex && $results !~ /^\Q$expected/))) or + (!$prefix && (( $option_regex && $results !~ /^$expected/) || + (!$option_regex && $results ne $expected)))) { + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; + foreach (@temps) + { unlink $_ if $_ } +} |
