diff options
Diffstat (limited to 'contrib/perl5/t/pragma')
47 files changed, 0 insertions, 10992 deletions
diff --git a/contrib/perl5/t/pragma/constant.t b/contrib/perl5/t/pragma/constant.t deleted file mode 100755 index 6e6617b..0000000 --- a/contrib/perl5/t/pragma/constant.t +++ /dev/null @@ -1,230 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use warnings; -use vars qw{ @warnings }; -BEGIN { # ...and save 'em for later - $SIG{'__WARN__'} = sub { push @warnings, @_ } -} -END { print @warnings } - -######################### We start with some black magic to print on failure. - -BEGIN { $| = 1; print "1..73\n"; } -END {print "not ok 1\n" unless $loaded;} -use constant 1.01; -$loaded = 1; -#print "# Version: $constant::VERSION\n"; -print "ok 1\n"; - -######################### End of black magic. - -use strict; - -sub test ($$;$) { - my($num, $bool, $diag) = @_; - if ($bool) { - print "ok $num\n"; - return; - } - print "not ok $num\n"; - return unless defined $diag; - $diag =~ s/\Z\n?/\n/; # unchomp - print map "# $num : $_", split m/^/m, $diag; -} - -use constant PI => 4 * atan2 1, 1; - -test 2, substr(PI, 0, 7) eq '3.14159'; -test 3, defined PI; - -sub deg2rad { PI * $_[0] / 180 } - -my $ninety = deg2rad 90; - -test 4, $ninety > 1.5707; -test 5, $ninety < 1.5708; - -use constant UNDEF1 => undef; # the right way -use constant UNDEF2 => ; # the weird way -use constant 'UNDEF3' ; # the 'short' way -use constant EMPTY => ( ) ; # the right way for lists - -test 6, not defined UNDEF1; -test 7, not defined UNDEF2; -test 8, not defined UNDEF3; -my @undef = UNDEF1; -test 9, @undef == 1; -test 10, not defined $undef[0]; -@undef = UNDEF2; -test 11, @undef == 0; -@undef = UNDEF3; -test 12, @undef == 0; -@undef = EMPTY; -test 13, @undef == 0; - -use constant COUNTDOWN => scalar reverse 1, 2, 3, 4, 5; -use constant COUNTLIST => reverse 1, 2, 3, 4, 5; -use constant COUNTLAST => (COUNTLIST)[-1]; - -test 14, COUNTDOWN eq '54321'; -my @cl = COUNTLIST; -test 15, @cl == 5; -test 16, COUNTDOWN eq join '', @cl; -test 17, COUNTLAST == 1; -test 18, (COUNTLIST)[1] == 4; - -use constant ABC => 'ABC'; -test 19, "abc${\( ABC )}abc" eq "abcABCabc"; - -use constant DEF => 'D', 'E', chr ord 'F'; -test 20, "d e f @{[ DEF ]} d e f" eq "d e f D E F d e f"; - -use constant SINGLE => "'"; -use constant DOUBLE => '"'; -use constant BACK => '\\'; -my $tt = BACK . SINGLE . DOUBLE ; -test 21, $tt eq q(\\'"); - -use constant MESS => q('"'\\"'"\\); -test 22, MESS eq q('"'\\"'"\\); -test 23, length(MESS) == 8; - -use constant TRAILING => '12 cats'; -{ - no warnings 'numeric'; - test 24, TRAILING == 12; -} -test 25, TRAILING eq '12 cats'; - -use constant LEADING => " \t1234"; -test 26, LEADING == 1234; -test 27, LEADING eq " \t1234"; - -use constant ZERO1 => 0; -use constant ZERO2 => 0.0; -use constant ZERO3 => '0.0'; -test 28, ZERO1 eq '0'; -test 29, ZERO2 eq '0'; -test 30, ZERO3 eq '0.0'; - -{ - package Other; - use constant PI => 3.141; -} - -test 31, (PI > 3.1415 and PI < 3.1416); -test 32, Other::PI == 3.141; - -use constant E2BIG => $! = 7; -test 33, E2BIG == 7; -# This is something like "Arg list too long", but the actual message -# text may vary, so we can't test much better than this. -test 34, length(E2BIG) > 6; -test 35, index(E2BIG, " ") > 0; - -test 36, @warnings == 0, join "\n", "unexpected warning", @warnings; -@warnings = (); # just in case -undef &PI; -test 37, @warnings && - ($warnings[0] =~ /Constant sub.* undefined/), - shift @warnings; - -test 38, @warnings == 0, "unexpected warning"; -test 39, 1; - -use constant CSCALAR => \"ok 40\n"; -use constant CHASH => { foo => "ok 41\n" }; -use constant CARRAY => [ undef, "ok 42\n" ]; -use constant CPHASH => [ { foo => 1 }, "ok 43\n" ]; -use constant CCODE => sub { "ok $_[0]\n" }; - -print ${+CSCALAR}; -print CHASH->{foo}; -print CARRAY->[1]; -print CPHASH->{foo}; -eval q{ CPHASH->{bar} }; -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 deleted file mode 100755 index 14014f6..0000000 --- a/contrib/perl5/t/pragma/diagnostics.t +++ /dev/null @@ -1,38 +0,0 @@ -#!./perl - -BEGIN { - chdir '..' if -d '../pod' && -d '../t'; - @INC = '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 deleted file mode 100755 index 068fede..0000000 --- a/contrib/perl5/t/pragma/locale.t +++ /dev/null @@ -1,807 +0,0 @@ -#!./perl -wT - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - unshift @INC, '.'; - require Config; import Config; - if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) { - print "1..0\n"; - exit; - } -} - -use strict; - -my $debug = 1; - -use Dumpvalue; - -my $dumper = Dumpvalue->new( - tick => qq{"}, - quoteHighBit => 0, - unctrl => "quote" - ); -sub debug { - return unless $debug; - my($mess) = join "", @_; - chop $mess; - print $dumper->stringify($mess,1), "\n"; -} - -sub debugf { - printf @_ if $debug; -} - -my $have_setlocale = 0; -eval { - require POSIX; - import POSIX ':locale_h'; - $have_setlocale++; -}; - -# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" -# and mingw32 uses said silly CRT -$have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; - -my $last = $have_setlocale ? 116 : 98; - -print "1..$last\n"; - -use vars qw(&LC_ALL); - -my $a = 'abc %'; - -sub ok { - my ($n, $result) = @_; - - print 'not ' unless ($result); - print "ok $n\n"; -} - -# First we'll do a lot of taint checking for locales. -# This is the easiest to test, actually, as any locale, -# even the default locale will taint under 'use locale'. - -sub is_tainted { # hello, camel two. - no warnings 'uninitialized' ; - my $dummy; - not eval { $dummy = join("", @_), kill 0; 1 } -} - -sub check_taint ($$) { - ok $_[0], is_tainted($_[1]); -} - -sub check_taint_not ($$) { - ok $_[0], not is_tainted($_[1]); -} - -use locale; # engage locale and therefore locale taint. - -check_taint_not 1, $a; - -check_taint 2, uc($a); -check_taint 3, "\U$a"; -check_taint 4, ucfirst($a); -check_taint 5, "\u$a"; -check_taint 6, lc($a); -check_taint 7, "\L$a"; -check_taint 8, lcfirst($a); -check_taint 9, "\l$a"; - -check_taint_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); - -$_ = $a; # untaint $_ - -$_ = uc($a); # taint $_ - -check_taint 15, $_; - -/(\w)/; # taint $&, $`, $', $+, $1. -check_taint 16, $&; -check_taint 17, $`; -check_taint 18, $'; -check_taint 19, $+; -check_taint 20, $1; -check_taint_not 21, $2; - -/(.)/; # untaint $&, $`, $', $+, $1. -check_taint_not 22, $&; -check_taint_not 23, $`; -check_taint_not 24, $'; -check_taint_not 25, $+; -check_taint_not 26, $1; -check_taint_not 27, $2; - -/(\W)/; # taint $&, $`, $', $+, $1. -check_taint 28, $&; -check_taint 29, $`; -check_taint 30, $'; -check_taint 31, $+; -check_taint 32, $1; -check_taint_not 33, $2; - -/(\s)/; # taint $&, $`, $', $+, $1. -check_taint 34, $&; -check_taint 35, $`; -check_taint 36, $'; -check_taint 37, $+; -check_taint 38, $1; -check_taint_not 39, $2; - -/(\S)/; # taint $&, $`, $', $+, $1. -check_taint 40, $&; -check_taint 41, $`; -check_taint 42, $'; -check_taint 43, $+; -check_taint 44, $1; -check_taint_not 45, $2; - -$_ = $a; # untaint $_ - -check_taint_not 46, $_; - -/(b)/; # this must not taint -check_taint_not 47, $&; -check_taint_not 48, $`; -check_taint_not 49, $'; -check_taint_not 50, $+; -check_taint_not 51, $1; -check_taint_not 52, $2; - -$_ = $a; # untaint $_ - -check_taint_not 53, $_; - -$b = uc($a); # taint $b -s/(.+)/$b/; # this must taint only the $_ - -check_taint 54, $_; -check_taint_not 55, $&; -check_taint_not 56, $`; -check_taint_not 57, $'; -check_taint_not 58, $+; -check_taint_not 59, $1; -check_taint_not 60, $2; - -$_ = $a; # untaint $_ - -s/(.+)/b/; # this must not taint -check_taint_not 61, $_; -check_taint_not 62, $&; -check_taint_not 63, $`; -check_taint_not 64, $'; -check_taint_not 65, $+; -check_taint_not 66, $1; -check_taint_not 67, $2; - -$b = $a; # untaint $b - -($b = $a) =~ s/\w/$&/; -check_taint 68, $b; # $b should be tainted. -check_taint_not 69, $a; # $a should be not. - -$_ = $a; # untaint $_ - -s/(\w)/\l$1/; # this must taint -check_taint 70, $_; -check_taint 71, $&; -check_taint 72, $`; -check_taint 73, $'; -check_taint 74, $+; -check_taint 75, $1; -check_taint_not 76, $2; - -$_ = $a; # untaint $_ - -s/(\w)/\L$1/; # this must taint -check_taint 77, $_; -check_taint 78, $&; -check_taint 79, $`; -check_taint 80, $'; -check_taint 81, $+; -check_taint 82, $1; -check_taint_not 83, $2; - -$_ = $a; # untaint $_ - -s/(\w)/\u$1/; # this must taint -check_taint 84, $_; -check_taint 85, $&; -check_taint 86, $`; -check_taint 87, $'; -check_taint 88, $+; -check_taint 89, $1; -check_taint_not 90, $2; - -$_ = $a; # untaint $_ - -s/(\w)/\U$1/; # this must taint -check_taint 91, $_; -check_taint 92, $&; -check_taint 93, $`; -check_taint 94, $'; -check_taint 95, $+; -check_taint 96, $1; -check_taint_not 97, $2; - -# After all this tainting $a should be cool. - -check_taint_not 98, $a; - -# I think we've seen quite enough of taint. -# Let us do some *real* locale work now, -# unless setlocale() is missing (i.e. minitest). - -exit unless $have_setlocale; - -# 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 Big5 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 zw: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 -Moldovan:mo:mo:2 -Norsk Norwegian:no no\@nynorsk: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 KOI8-R koi8u cp1251 cp866 -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:yi::1 15 -EOF - -if ($^O eq 'os390') { - # These cause heartburn. Broken locales? - $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 trylocale { - my $locale = shift; - if (setlocale(LC_ALL, $locale)) { - push @Locale, $locale; - } -} - -sub decode_encodings { - my @enc; - - 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, $_; - push @enc, "$_.UTF-8"; - } - } - if ($^O eq 'os390') { - push @enc, qw(IBM-037 IBM-819 IBM-1047); - } - - return @enc; -} - -trylocale("C"); -trylocale("POSIX"); -foreach (0..15) { - trylocale("ISO8859-$_"); - trylocale("iso8859$_"); - trylocale("iso8859-$_"); - trylocale("iso_8859_$_"); - trylocale("isolatin$_"); - trylocale("isolatin-$_"); - trylocale("iso_latin_$_"); -} - -# Sanitize the environment so that we can run the external 'locale' -# program without the taint mode getting grumpy. - -# $ENV{PATH} is special in VMS. -delete $ENV{PATH} if $^O ne 'VMS' or $Config{d_setenv}; - -# Other subversive stuff. -delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; - -if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) { - while (<LOCALES>) { - chomp; - trylocale($_); - } - close(LOCALES); -} elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') { -# The SYS$I18N_LOCALE logical name search list was not present on -# VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions. - opendir(LOCALES, "SYS\$I18N_LOCALE:"); - while ($_ = readdir(LOCALES)) { - chomp; - trylocale($_); - } - close(LOCALES); -} else { - - # This is going to be slow. - - 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"); - } - } - } - } -} - -setlocale(LC_ALL, "C"); - -sub utf8locale { $_[0] =~ /utf-?8/i } - -@Locale = sort @Locale; - -debug "# Locales = @Locale\n"; - -my %Problem; -my %Okay; -my %Testing; -my @Neoalpha; -my %Neoalpha; - -sub tryneoalpha { - my ($Locale, $i, $test) = @_; - unless ($test) { - $Problem{$i}{$Locale} = 1; - debug "# failed $i with locale '$Locale'\n"; - } else { - push @{$Okay{$i}}, $Locale; - } -} - -foreach $Locale (@Locale) { - debug "# Locale = $Locale\n"; - @Alnum_ = getalnum_(); - debug "# w = ", join("",@Alnum_), "\n"; - - 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{$_}; - } - - debug "# UPPER = ", join("", sort keys %UPPER ), "\n"; - debug "# lower = ", join("", sort keys %lower ), "\n"; - debug "# BoThCaSe = ", join("", sort keys %BoThCaSe), "\n"; - - # Find the alphabets that are not alphabets in the default locale. - - { - no locale; - - @Neoalpha = (); - for (keys %UPPER, keys %lower) { - push(@Neoalpha, $_) if (/\W/); - $Neoalpha{$_} = $_; - } - } - - @Neoalpha = sort @Neoalpha; - - debug "# Neoalpha = ", join("",@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 { - - # Test \w. - - if (utf8locale($Locale)) { - # Until the polymorphic regexen arrive. - debug "# skipping UTF-8 locale '$Locale'\n"; - } else { - 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; - } - } - } - } - - use locale; - - my ($x, $y) = (1.23, 1.23); - - my $a = "$x"; - printf ''; # printf used to reset locale to "C" - my $b = "$y"; - - debug "# 103..107: a = $a, b = $b, Locale = $Locale\n"; - - tryneoalpha($Locale, 103, $a eq $b); - - my $c = "$x"; - my $z = sprintf ''; # sprintf used to reset locale to "C" - my $d = "$y"; - - debug "# 104..107: c = $c, d = $d, Locale = $Locale\n"; - - tryneoalpha($Locale, 104, $c eq $d); - - { - 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"; - - debug "# 112..114: f = $f, locale = $Locale\n"; - - tryneoalpha($Locale, 112, $f == 1.23); - - tryneoalpha($Locale, 113, $f == $x); - - tryneoalpha($Locale, 114, $f == $c); - } - - # Does taking lc separately differ from taking - # the lc "in-line"? (This was the bug 19990704.002, change #3568.) - # The bug was in the caching of the 'o'-magic. - { - 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); - } - - # Does lc of an UPPER (if different from the UPPER) match - # case-insensitively the UPPER, and does the UPPER match - # case-insensitively the lc of the UPPER. And vice versa. - if (utf8locale($Locale)) { - # Until the polymorphic regexen arrive. - debug "# skipping UTF-8 locale '$Locale'\n"; - } else { - use locale; - - 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); - if (@f) { - print "# failed 116 locale '$Locale' characters @f\n" - } - } - -} - -# Recount the errors. - -foreach (99..$last) { - 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"; -} - -# Give final advice. - -my $didwarn = 0; - -foreach (99..$last) { - 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; - } -} - -# Tell which locales were okay and which were not. - -if ($didwarn) { - my (@s, @F); - - foreach my $l (@Locale) { - my $p = 0; - foreach my $t (102..$last) { - $p++ if $Problem{$t}{$l}; - } - push @s, $l if $p == 0; - push @F, $l unless $p == 0; - } - - if (@s) { - 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", - } else { - warn "# None of your locales were fully okay.\n"; - } - - if (@F) { - my $F = join(" ", @F); - $F =~ s/(.{50,60}) /$1\n#\t/g; - - warn - "# The following locales\n#\n", - "#\t", $F, "\n#\n", - "# had problems.\n#\n", - } else { - warn "# None of your locales were broken.\n"; - } -} - -# eof diff --git a/contrib/perl5/t/pragma/locale/latin1 b/contrib/perl5/t/pragma/locale/latin1 deleted file mode 100644 index f40f732..0000000 --- a/contrib/perl5/t/pragma/locale/latin1 +++ /dev/null @@ -1,10 +0,0 @@ -$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 deleted file mode 100644 index fbbe94f..0000000 --- a/contrib/perl5/t/pragma/locale/utf8 +++ /dev/null @@ -1,10 +0,0 @@ -$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 deleted file mode 100755 index a3007ef..0000000 --- a/contrib/perl5/t/pragma/overload.t +++ /dev/null @@ -1,987 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -package Oscalar; -use overload ( - # Anonymous subroutines: -'+' => sub {new Oscalar $ {$_[0]}+$_[1]}, -'-' => sub {new Oscalar - $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, -'<=>' => sub {new Oscalar - $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, -'cmp' => sub {new Oscalar - $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])}, -'*' => sub {new Oscalar ${$_[0]}*$_[1]}, -'/' => sub {new Oscalar - $_[2]? $_[1]/${$_[0]} : - ${$_[0]}/$_[1]}, -'%' => sub {new Oscalar - $_[2]? $_[1]%${$_[0]} : ${$_[0]}%$_[1]}, -'**' => sub {new Oscalar - $_[2]? $_[1]**${$_[0]} : ${$_[0]}-$_[1]}, - -qw( -"" stringify -0+ numify) # Order of arguments unsignificant -); - -sub new { - my $foo = $_[1]; - bless \$foo, $_[0]; -} - -sub stringify { "${$_[0]}" } -sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead - # comparing to direct compilation based on - # stringify - -package main; - -$test = 0; -$| = 1; -print "1..",&last,"\n"; - -sub test { - $test++; - if (@_ > 1) { - if ($_[0] eq $_[1]) { - print "ok $test\n"; - } else { - print "not ok $test: '$_[0]' ne '$_[1]'\n"; - } - } else { - if (shift) { - print "ok $test\n"; - } else { - print "not ok $test\n"; - } - } -} - -$a = new Oscalar "087"; -$b= "$a"; - -# All test numbers in comments are off by 1. -# So much for hard-wiring them in :-) To fix this: -test(1); # 1 - -test ($b eq $a); # 2 -test ($b eq "087"); # 3 -test (ref $a eq "Oscalar"); # 4 -test ($a eq $a); # 5 -test ($a eq "087"); # 6 - -$c = $a + 7; - -test (ref $c eq "Oscalar"); # 7 -test (!($c eq $a)); # 8 -test ($c eq "94"); # 9 - -$b=$a; - -test (ref $a eq "Oscalar"); # 10 - -$b++; - -test (ref $b eq "Oscalar"); # 11 -test ( $a eq "087"); # 12 -test ( $b eq "88"); # 13 -test (ref $a eq "Oscalar"); # 14 - -$c=$b; -$c-=$a; - -test (ref $c eq "Oscalar"); # 15 -test ( $a eq "087"); # 16 -test ( $c eq "1"); # 17 -test (ref $a eq "Oscalar"); # 18 - -$b=1; -$b+=$a; - -test (ref $b eq "Oscalar"); # 19 -test ( $a eq "087"); # 20 -test ( $b eq "88"); # 21 -test (ref $a eq "Oscalar"); # 22 - -eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ]; - -$b=$a; - -test (ref $a eq "Oscalar"); # 23 - -$b++; - -test (ref $b eq "Oscalar"); # 24 -test ( $a eq "087"); # 25 -test ( $b eq "88"); # 26 -test (ref $a eq "Oscalar"); # 27 - -package Oscalar; -$dummy=bless \$dummy; # Now cache of method should be reloaded -package main; - -$b=$a; -$b++; - -test (ref $b eq "Oscalar"); # 28 -test ( $a eq "087"); # 29 -test ( $b eq "88"); # 30 -test (ref $a eq "Oscalar"); # 31 - - -eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ]; - -$b=$a; - -test (ref $a eq "Oscalar"); # 32 - -$b++; - -test (ref $b eq "Oscalar"); # 33 -test ( $a eq "087"); # 34 -test ( $b eq "88"); # 35 -test (ref $a eq "Oscalar"); # 36 - -package Oscalar; -$dummy=bless \$dummy; # Now cache of method should be reloaded -package main; - -$b++; - -test (ref $b eq "Oscalar"); # 37 -test ( $a eq "087"); # 38 -test ( $b eq "90"); # 39 -test (ref $a eq "Oscalar"); # 40 - -$b=$a; -$b++; - -test (ref $b eq "Oscalar"); # 41 -test ( $a eq "087"); # 42 -test ( $b eq "89"); # 43 -test (ref $a eq "Oscalar"); # 44 - - -test ($b? 1:0); # 45 - -eval q[ package Oscalar; use overload ('=' => sub {$main::copies++; - package Oscalar; - local $new=$ {$_[0]}; - bless \$new } ) ]; - -$b=new Oscalar "$a"; - -test (ref $b eq "Oscalar"); # 46 -test ( $a eq "087"); # 47 -test ( $b eq "087"); # 48 -test (ref $a eq "Oscalar"); # 49 - -$b++; - -test (ref $b eq "Oscalar"); # 50 -test ( $a eq "087"); # 51 -test ( $b eq "89"); # 52 -test (ref $a eq "Oscalar"); # 53 -test ($copies == 0); # 54 - -$b+=1; - -test (ref $b eq "Oscalar"); # 55 -test ( $a eq "087"); # 56 -test ( $b eq "90"); # 57 -test (ref $a eq "Oscalar"); # 58 -test ($copies == 0); # 59 - -$b=$a; -$b+=1; - -test (ref $b eq "Oscalar"); # 60 -test ( $a eq "087"); # 61 -test ( $b eq "88"); # 62 -test (ref $a eq "Oscalar"); # 63 -test ($copies == 0); # 64 - -$b=$a; -$b++; - -test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65 -test ( $a eq "087"); # 66 -test ( $b eq "89"); # 67 -test (ref $a eq "Oscalar"); # 68 -test ($copies == 1); # 69 - -eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1]; - $_[0] } ) ]; -$c=new Oscalar; # Cause rehash - -$b=$a; -$b+=1; - -test (ref $b eq "Oscalar"); # 70 -test ( $a eq "087"); # 71 -test ( $b eq "90"); # 72 -test (ref $a eq "Oscalar"); # 73 -test ($copies == 2); # 74 - -$b+=$b; - -test (ref $b eq "Oscalar"); # 75 -test ( $b eq "360"); # 76 -test ($copies == 2); # 77 -$b=-$b; - -test (ref $b eq "Oscalar"); # 78 -test ( $b eq "-360"); # 79 -test ($copies == 2); # 80 - -$b=abs($b); - -test (ref $b eq "Oscalar"); # 81 -test ( $b eq "360"); # 82 -test ($copies == 2); # 83 - -$b=abs($b); - -test (ref $b eq "Oscalar"); # 84 -test ( $b eq "360"); # 85 -test ($copies == 2); # 86 - -eval q[package Oscalar; - use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]} - : "_.${$_[0]}._" x $_[1])}) ]; - -$a=new Oscalar "yy"; -$a x= 3; -test ($a eq "_.yy.__.yy.__.yy._"); # 87 - -eval q[package Oscalar; - use overload ('.' => sub {new Oscalar ( $_[2] ? - "_.$_[1].__.$ {$_[0]}._" - : "_.$ {$_[0]}.__.$_[1]._")}) ]; - -$a=new Oscalar "xx"; - -test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88 - -# Check inheritance of overloading; -{ - package OscalarI; - @ISA = 'Oscalar'; -} - -$aI = new OscalarI "$a"; -test (ref $aI eq "OscalarI"); # 89 -test ("$aI" eq "xx"); # 90 -test ($aI eq "xx"); # 91 -test ("b${aI}c" eq "_._.b.__.xx._.__.c._"); # 92 - -# Here we test blessing to a package updates hash - -eval "package Oscalar; no overload '.'"; - -test ("b${a}" eq "_.b.__.xx._"); # 93 -$x="1"; -bless \$x, Oscalar; -test ("b${a}c" eq "bxxc"); # 94 -new Oscalar 1; -test ("b${a}c" eq "bxxc"); # 95 - -# Negative overloading: - -$na = eval { ~$a }; -test($@ =~ /no method found/); # 96 - -# Check AUTOLOADING: - -*Oscalar::AUTOLOAD = - sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ; - goto &{"Oscalar::$AUTOLOAD"}}; - -eval "package Oscalar; sub comple; use overload '~' => 'comple'"; - -$na = eval { ~$a }; # Hash was not updated -test($@ =~ /no method found/); # 97 - -bless \$x, Oscalar; - -$na = eval { ~$a }; # Hash updated -warn "`$na', $@" if $@; -test !$@; # 98 -test($na eq '_!_xx_!_'); # 99 - -$na = 0; - -$na = eval { ~$aI }; # Hash was not updated -test($@ =~ /no method found/); # 100 - -bless \$x, OscalarI; - -$na = eval { ~$aI }; -print $@; - -test !$@; # 101 -test($na eq '_!_xx_!_'); # 102 - -eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'"; - -$na = eval { $aI >> 1 }; # Hash was not updated -test($@ =~ /no method found/); # 103 - -bless \$x, OscalarI; - -$na = 0; - -$na = eval { $aI >> 1 }; -print $@; - -test !$@; # 104 -test($na eq '_!_xx_!_'); # 105 - -# warn overload::Method($a, '0+'), "\n"; -test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106 -test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107 -test (overload::Overloaded($aI)); # 108 -test (!overload::Overloaded('overload')); # 109 - -test (! defined overload::Method($aI, '<<')); # 110 -test (! defined overload::Method($a, '<')); # 111 - -test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112 -test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113 - -# Check overloading by methods (specified deep in the ISA tree). -{ - package OscalarII; - @ISA = 'OscalarI'; - sub Oscalar::lshft {"_<<_" . shift() . "_<<_"} - eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'"; -} - -$aaII = "087"; -$aII = \$aaII; -bless $aII, 'OscalarII'; -bless \$fake, 'OscalarI'; # update the hash -test(($aI | 3) eq '_<<_xx_<<_'); # 114 -# warn $aII << 3; -test(($aII << 3) eq '_<<_087_<<_'); # 115 - -{ - BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; } - $out = 2**10; -} -test($int, 9); # 116 -test($out, 1024); # 117 - -$foo = 'foo'; -$foo1 = 'f\'o\\o'; -{ - BEGIN { $q = $qr = 7; - overload::constant 'q' => sub {$q++; push @q, shift, ($_[1] || 'none'); shift}, - 'qr' => sub {$qr++; push @qr, shift, ($_[1] || 'none'); shift}; } - $out = 'foo'; - $out1 = 'f\'o\\o'; - $out2 = "a\a$foo,\,"; - /b\b$foo.\./; -} - -test($out, 'foo'); # 118 -test($out, $foo); # 119 -test($out1, 'f\'o\\o'); # 120 -test($out1, $foo1); # 121 -test($out2, "a\afoo,\,"); # 122 -test("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq"); # 123 -test($q, 11); # 124 -test("@qr", "b\\b qq .\\. qq"); # 125 -test($qr, 9); # 126 - -{ - $_ = '!<b>!foo!<-.>!'; - BEGIN { overload::constant 'q' => sub {push @q1, shift, ($_[1] || 'none'); "_<" . (shift) . ">_"}, - 'qr' => sub {push @qr1, shift, ($_[1] || 'none'); "!<" . (shift) . ">!"}; } - $out = 'foo'; - $out1 = 'f\'o\\o'; - $out2 = "a\a$foo,\,"; - $res = /b\b$foo.\./; - $a = <<EOF; -oups -EOF - $b = <<'EOF'; -oups1 -EOF - $c = bareword; - m'try it'; - s'first part'second part'; - s/yet another/tail here/; - tr/z-Z/z-Z/; -} - -test($out, '_<foo>_'); # 117 -test($out1, '_<f\'o\\o>_'); # 128 -test($out2, "_<a\a>_foo_<,\,>_"); # 129 -test("@q1", "foo q f'o\\\\o q a\\a qq ,\\, qq oups - qq oups1 - q second part q tail here s z-Z tr z-Z tr"); # 130 -test("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq"); # 131 -test($res, 1); # 132 -test($a, "_<oups ->_"); # 133 -test($b, "_<oups1 ->_"); # 134 -test($c, "bareword"); # 135 - -{ - package symbolic; # Primitive symbolic calculator - use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, - '=' => \&cpy, '++' => \&inc, '--' => \&dec; - - sub new { shift; bless ['n', @_] } - sub cpy { - my $self = shift; - bless [@$self], ref $self; - } - sub inc { $_[0] = bless ['++', $_[0], 1]; } - sub dec { $_[0] = bless ['--', $_[0], 1]; } - sub wrap { - my ($obj, $other, $inv, $meth) = @_; - if ($meth eq '++' or $meth eq '--') { - @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference - return $obj; - } - ($obj, $other) = ($other, $obj) if $inv; - bless [$meth, $obj, $other]; - } - sub str { - my ($meth, $a, $b) = @{+shift}; - $a = 'u' unless defined $a; - if (defined $b) { - "[$meth $a $b]"; - } else { - "[$meth $a]"; - } - } - my %subr = ( 'n' => sub {$_[0]} ); - foreach my $op (split " ", $overload::ops{with_assign}) { - $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; - } - my @bins = qw(binary 3way_comparison num_comparison str_comparison); - foreach my $op (split " ", "@overload::ops{ @bins }") { - $subr{$op} = eval "sub {shift() $op shift()}"; - } - foreach my $op (split " ", "@overload::ops{qw(unary func)}") { - $subr{$op} = eval "sub {$op shift()}"; - } - $subr{'++'} = $subr{'+'}; - $subr{'--'} = $subr{'-'}; - - sub num { - my ($meth, $a, $b) = @{+shift}; - my $subr = $subr{$meth} - or die "Do not know how to ($meth) in symbolic"; - $a = $a->num if ref $a eq __PACKAGE__; - $b = $b->num if ref $b eq __PACKAGE__; - $subr->($a,$b); - } - sub TIESCALAR { my $pack = shift; $pack->new(@_) } - sub FETCH { shift } - sub nop { } # Around a bug - sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } - sub STORE { - my $obj = shift; - $#$obj = 1; - @$obj->[0,1] = ('=', shift); - } -} - -{ - my $foo = new symbolic 11; - my $baz = $foo++; - test( (sprintf "%d", $foo), '12'); - test( (sprintf "%d", $baz), '11'); - my $bar = $foo; - $baz = ++$foo; - test( (sprintf "%d", $foo), '13'); - test( (sprintf "%d", $bar), '12'); - test( (sprintf "%d", $baz), '13'); - my $ban = $foo; - $baz = ($foo += 1); - test( (sprintf "%d", $foo), '14'); - test( (sprintf "%d", $bar), '12'); - test( (sprintf "%d", $baz), '14'); - test( (sprintf "%d", $ban), '13'); - $baz = 0; - $baz = $foo++; - test( (sprintf "%d", $foo), '15'); - test( (sprintf "%d", $baz), '14'); - test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]'); -} - -{ - my $iter = new symbolic 2; - my $side = new symbolic 1; - my $cnt = $iter; - - while ($cnt) { - $cnt = $cnt - 1; # The "simple" way - $side = (sqrt(1 + $side**2) - 1)/$side; - } - my $pi = $side*(2**($iter+2)); - test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; - test( (sprintf "%f", $pi), '3.182598'); -} - -{ - my $iter = new symbolic 2; - my $side = new symbolic 1; - my $cnt = $iter; - - while ($cnt--) { - $side = (sqrt(1 + $side**2) - 1)/$side; - } - my $pi = $side*(2**($iter+2)); - test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; - test( (sprintf "%f", $pi), '3.182598'); -} - -{ - my ($a, $b); - symbolic->vars($a, $b); - my $c = sqrt($a**2 + $b**2); - $a = 3; $b = 4; - test( (sprintf "%d", $c), '5'); - $a = 12; $b = 5; - test( (sprintf "%d", $c), '13'); -} - -{ - package symbolic1; # Primitive symbolic calculator - # Mutator inc/dec - use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, '=' => \&cpy; - - sub new { shift; bless ['n', @_] } - sub cpy { - my $self = shift; - bless [@$self], ref $self; - } - sub wrap { - my ($obj, $other, $inv, $meth) = @_; - if ($meth eq '++' or $meth eq '--') { - @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference - return $obj; - } - ($obj, $other) = ($other, $obj) if $inv; - bless [$meth, $obj, $other]; - } - sub str { - my ($meth, $a, $b) = @{+shift}; - $a = 'u' unless defined $a; - if (defined $b) { - "[$meth $a $b]"; - } else { - "[$meth $a]"; - } - } - my %subr = ( 'n' => sub {$_[0]} ); - foreach my $op (split " ", $overload::ops{with_assign}) { - $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; - } - my @bins = qw(binary 3way_comparison num_comparison str_comparison); - foreach my $op (split " ", "@overload::ops{ @bins }") { - $subr{$op} = eval "sub {shift() $op shift()}"; - } - foreach my $op (split " ", "@overload::ops{qw(unary func)}") { - $subr{$op} = eval "sub {$op shift()}"; - } - $subr{'++'} = $subr{'+'}; - $subr{'--'} = $subr{'-'}; - - sub num { - my ($meth, $a, $b) = @{+shift}; - my $subr = $subr{$meth} - or die "Do not know how to ($meth) in symbolic"; - $a = $a->num if ref $a eq __PACKAGE__; - $b = $b->num if ref $b eq __PACKAGE__; - $subr->($a,$b); - } - sub TIESCALAR { my $pack = shift; $pack->new(@_) } - sub FETCH { shift } - sub nop { } # Around a bug - sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } - sub STORE { - my $obj = shift; - $#$obj = 1; - @$obj->[0,1] = ('=', shift); - } -} - -{ - my $foo = new symbolic1 11; - my $baz = $foo++; - test( (sprintf "%d", $foo), '12'); - test( (sprintf "%d", $baz), '11'); - my $bar = $foo; - $baz = ++$foo; - test( (sprintf "%d", $foo), '13'); - test( (sprintf "%d", $bar), '12'); - test( (sprintf "%d", $baz), '13'); - my $ban = $foo; - $baz = ($foo += 1); - test( (sprintf "%d", $foo), '14'); - test( (sprintf "%d", $bar), '12'); - test( (sprintf "%d", $baz), '14'); - test( (sprintf "%d", $ban), '13'); - $baz = 0; - $baz = $foo++; - test( (sprintf "%d", $foo), '15'); - test( (sprintf "%d", $baz), '14'); - test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]'); -} - -{ - my $iter = new symbolic1 2; - my $side = new symbolic1 1; - my $cnt = $iter; - - while ($cnt) { - $cnt = $cnt - 1; # The "simple" way - $side = (sqrt(1 + $side**2) - 1)/$side; - } - my $pi = $side*(2**($iter+2)); - test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; - test( (sprintf "%f", $pi), '3.182598'); -} - -{ - my $iter = new symbolic1 2; - my $side = new symbolic1 1; - my $cnt = $iter; - - while ($cnt--) { - $side = (sqrt(1 + $side**2) - 1)/$side; - } - my $pi = $side*(2**($iter+2)); - test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; - test( (sprintf "%f", $pi), '3.182598'); -} - -{ - my ($a, $b); - symbolic1->vars($a, $b); - my $c = sqrt($a**2 + $b**2); - $a = 3; $b = 4; - test( (sprintf "%d", $c), '5'); - $a = 12; $b = 5; - test( (sprintf "%d", $c), '13'); -} - -{ - package two_face; # Scalars with separate string and - # numeric values. - sub new { my $p = shift; bless [@_], $p } - use overload '""' => \&str, '0+' => \&num, fallback => 1; - sub num {shift->[1]} - sub str {shift->[0]} -} - -{ - my $seven = new two_face ("vii", 7); - test( (sprintf "seven=$seven, seven=%d, eight=%d", $seven, $seven+1), - 'seven=vii, seven=7, eight=8'); - test( scalar ($seven =~ /i/), '1') -} - -{ - package sorting; - use overload 'cmp' => \∁ - sub new { my ($p, $v) = @_; bless \$v, $p } - sub comp { my ($x,$y) = @_; ($$x * 3 % 10) <=> ($$y * 3 % 10) or $$x cmp $$y } -} -{ - my @arr = map sorting->new($_), 0..12; - my @sorted1 = sort @arr; - 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; # 207 - -unless ($aaa) { - test 'ok', 'ok'; # 208 -} else { - test 'is not', 'ok'; # 208 -} - -# check that overload isn't done twice by join -{ my $c = 0; - package Join; - use overload '""' => sub { $c++ }; - my $x = join '', bless([]), 'pq', bless([]); - main::test $x, '0pq1'; # 209 -}; - -# Test module-specific warning -{ - # check the Odd number of arguments for overload::constant warning - my $a = "" ; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - $x = eval ' overload::constant "integer" ; ' ; - test($a eq "") ; # 210 - use warnings 'overload' ; - $x = eval ' overload::constant "integer" ; ' ; - test($a =~ /^Odd number of arguments for overload::constant at/) ; # 211 -} - -{ - # check the `$_[0]' is not an overloadable type warning - my $a = "" ; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - $x = eval ' overload::constant "fred" => sub {} ; ' ; - test($a eq "") ; # 212 - use warnings 'overload' ; - $x = eval ' overload::constant "fred" => sub {} ; ' ; - test($a =~ /^`fred' is not an overloadable type at/); # 213 -} - -{ - # check the `$_[1]' is not a code reference warning - my $a = "" ; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - $x = eval ' overload::constant "integer" => 1; ' ; - test($a eq "") ; # 214 - use warnings 'overload' ; - $x = eval ' overload::constant "integer" => 1; ' ; - test($a =~ /^`1' is not a code reference at/); # 215 -} - -# make sure that we don't inifinitely recurse -{ - my $c = 0; - package Recurse; - use overload '""' => sub { shift }, - '0+' => sub { shift }, - 'bool' => sub { shift }, - fallback => 1; - my $x = bless([]); - main::test("$x" =~ /Recurse=ARRAY/); # 216 - main::test($x); # 217 - main::test($x+0 =~ /Recurse=ARRAY/); # 218 -}; - -# Last test is: -sub last {218} diff --git a/contrib/perl5/t/pragma/strict-refs b/contrib/perl5/t/pragma/strict-refs deleted file mode 100644 index 10599b0..0000000 --- a/contrib/perl5/t/pragma/strict-refs +++ /dev/null @@ -1,297 +0,0 @@ -Check strict refs functionality - -__END__ - -# no strict, should build & run ok. -my $fred ; -$b = "fred" ; -$a = $$b ; -$c = ${"def"} ; -$c = @{"def"} ; -$c = %{"def"} ; -$c = *{"def"} ; -$c = \&{"def"} ; -$c = def->[0]; -$c = def->{xyz}; -EXPECT - -######## - -# strict refs - error -use strict ; -my $fred ; -my $a = ${"fred"} ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $fred ; -my $a = ${"fred"} ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $fred ; -my $b = "fred" ; -my $a = $$b ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 6. -######## - -# strict refs - error -use strict 'refs' ; -my $b ; -my $a = $$b ; -EXPECT -Can't use an undefined value as a SCALAR reference at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $b ; -my $a = @$b ; -EXPECT -Can't use an undefined value as an ARRAY reference at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $b ; -my $a = %$b ; -EXPECT -Can't use an undefined value as a HASH reference at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $b ; -my $a = *$b ; -EXPECT -Can't use an undefined value as a symbol reference at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $a = fred->[0] ; -EXPECT -Can't use bareword ("fred") as an ARRAY ref while "strict refs" in use at - line 4. -######## - -# strict refs - error -use strict 'refs' ; -my $a = fred->{barney} ; -EXPECT -Can't use bareword ("fred") as a HASH ref while "strict refs" in use at - line 4. -######## - -# strict refs - no error -use strict ; -no strict 'refs' ; -my $fred ; -my $b = "fred" ; -my $a = $$b ; -use strict 'refs' ; -EXPECT - -######## - -# strict refs - no error -use strict qw(subs vars) ; -my $fred ; -my $b = "fred" ; -my $a = $$b ; -use strict 'refs' ; -EXPECT - -######## - -# strict refs - no error -my $fred ; -my $b = "fred" ; -my $a = $$b ; -use strict 'refs' ; -EXPECT - -######## - -# strict refs - no error -use strict 'refs' ; -my $fred ; -my $b = \$fred ; -my $a = $$b ; -EXPECT - -######## - -# Check runtime scope of strict refs pragma -use strict 'refs'; -my $fred ; -my $b = "fred" ; -{ - no strict ; - my $a = $$b ; -} -my $a = $$b ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10. -######## - -# Check runtime scope of strict refs pragma -no strict ; -my $fred ; -my $b = "fred" ; -{ - use strict 'refs' ; - my $a = $$b ; -} -my $a = $$b ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. -######## - -# Check runtime scope of strict refs pragma -no strict ; -my $fred ; -my $b = "fred" ; -{ - use strict 'refs' ; - $a = sub { my $c = $$b ; } -} -&$a ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. -######## - - ---FILE-- abc -my $a = ${"Fred"} ; -1; ---FILE-- -use strict 'refs' ; -require "./abc"; -EXPECT - -######## - ---FILE-- abc -use strict 'refs' ; -1; ---FILE-- -require "./abc"; -my $a = ${"Fred"} ; -EXPECT - -######## - ---FILE-- abc -use strict 'refs' ; -my $a = ${"Fred"} ; -1; ---FILE-- -${"Fred"} ; -require "./abc"; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at ./abc line 2. -Compilation failed in require at - line 2. -######## - ---FILE-- abc.pm -use strict 'refs' ; -my $a = ${"Fred"} ; -1; ---FILE-- -my $a = ${"Fred"} ; -use abc; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at abc.pm line 2. -Compilation failed in require at - line 2. -BEGIN failed--compilation aborted at - line 2. -######## - -# Check scope of pragma with eval -no strict ; -eval { - my $a = ${"Fred"} ; -}; -print STDERR $@ ; -my $a = ${"Fred"} ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval { - use strict 'refs' ; - my $a = ${"Fred"} ; -}; -print STDERR $@ ; -my $a = ${"Fred"} ; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 6. -######## - -# Check scope of pragma with eval -use strict 'refs' ; -eval { - my $a = ${"Fred"} ; -}; -print STDERR $@ ; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 5. -######## - -# Check scope of pragma with eval -use strict 'refs' ; -eval { - no strict ; - my $a = ${"Fred"} ; -}; -print STDERR $@ ; -my $a = ${"Fred"} ; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 9. -######## - -# Check scope of pragma with eval -no strict ; -eval ' - my $a = ${"Fred"} ; -'; print STDERR $@ ; -my $a = ${"Fred"} ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval q[ - use strict 'refs' ; - my $a = ${"Fred"} ; -]; print STDERR $@; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 3. -######## - -# Check scope of pragma with eval -use strict 'refs' ; -eval ' - my $a = ${"Fred"} ; -'; print STDERR $@ ; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 2. -######## - -# Check scope of pragma with eval -use strict 'refs' ; -eval ' - no strict ; - my $a = ${"Fred"} ; -'; print STDERR $@; -my $a = ${"Fred"} ; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 8. diff --git a/contrib/perl5/t/pragma/strict-subs b/contrib/perl5/t/pragma/strict-subs deleted file mode 100644 index ed4fe7a..0000000 --- a/contrib/perl5/t/pragma/strict-subs +++ /dev/null @@ -1,319 +0,0 @@ -Check strict subs functionality - -__END__ - -# no strict, should build & run ok. -Fred ; -my $fred ; -$b = "fred" ; -$a = $$b ; -EXPECT - -######## - -use strict qw(refs vars); -Fred ; -EXPECT - -######## - -use strict ; -no strict 'subs' ; -Fred ; -EXPECT - -######## - -# strict subs - error -use strict 'subs' ; -Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 4. -Execution of - aborted due to compilation errors. -######## - -# strict subs - error -use strict '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 -Bareword "Fred" not allowed while "strict subs" in use at - line 4. -Execution of - aborted due to compilation errors. -######## - -# strict subs - no error -use strict 'subs' ; -sub Fred {} -Fred ; -EXPECT - -######## - -# Check compile time scope of strict subs pragma -use strict 'subs' ; -{ - no strict ; - my $a = Fred ; -} -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check compile time scope of strict subs pragma -no strict; -{ - use strict 'subs' ; - my $a = Fred ; -} -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 6. -Execution of - aborted due to compilation errors. -######## - -# Check compile time scope of strict vars pragma -use strict 'vars' ; -{ - no strict ; - $joe = 1 ; -} -$joe = 1 ; -EXPECT -Variable "$joe" is not imported at - line 8. -Global symbol "$joe" requires explicit package name at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check compile time scope of strict vars pragma -no strict; -{ - use strict 'vars' ; - $joe = 1 ; -} -$joe = 1 ; -EXPECT -Global symbol "$joe" requires explicit package name at - line 6. -Execution of - aborted due to compilation errors. -######## - -# Check runtime scope of strict refs pragma -use strict 'refs'; -my $fred ; -my $b = "fred" ; -{ - no strict ; - my $a = $$b ; -} -my $a = $$b ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10. -######## - -# Check runtime scope of strict refs pragma -no strict ; -my $fred ; -my $b = "fred" ; -{ - use strict 'refs' ; - my $a = $$b ; -} -my $a = $$b ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. -######## - -# Check runtime scope of strict refs pragma -no strict ; -my $fred ; -my $b = "fred" ; -{ - use strict 'refs' ; - $a = sub { my $c = $$b ; } -} -&$a ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. -######## - -use strict 'subs' ; -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 3. -Execution of - aborted due to compilation errors. -######## - ---FILE-- abc -my $a = Fred ; -1; ---FILE-- -use strict 'subs' ; -require "./abc"; -EXPECT - -######## - ---FILE-- abc -use strict 'subs' ; -1; ---FILE-- -require "./abc"; -my $a = Fred ; -EXPECT - -######## - ---FILE-- abc -use strict 'subs' ; -my $a = Fred ; -1; ---FILE-- -Fred ; -require "./abc"; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at ./abc line 2. -Compilation failed in require at - line 2. -######## - ---FILE-- abc.pm -use strict 'subs' ; -my $a = Fred ; -1; ---FILE-- -Fred ; -use abc; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at abc.pm line 2. -Compilation failed in require at - line 2. -BEGIN failed--compilation aborted at - line 2. -######## - -# Check scope of pragma with eval -no strict ; -eval { - my $a = Fred ; -}; -print STDERR $@; -my $a = Fred ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval { - use strict 'subs' ; - my $a = Fred ; -}; -print STDERR $@; -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 6. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -use strict 'subs' ; -eval { - my $a = Fred ; -}; -print STDERR $@; -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 5. -Bareword "Fred" not allowed while "strict subs" in use at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -use strict 'subs' ; -eval { - no strict ; - my $a = Fred ; -}; -print STDERR $@; -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 9. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -no strict ; -eval ' - Fred ; -'; print STDERR $@ ; -Fred ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval q[ - use strict 'subs' ; - Fred ; -]; print STDERR $@; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 3. -######## - -# Check scope of pragma with eval -use strict 'subs' ; -eval ' - Fred ; -'; print STDERR $@ ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 2. -######## - -# Check scope of pragma with eval -use strict 'subs' ; -eval ' - no strict ; - my $a = Fred ; -'; print STDERR $@; -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 8. -Execution of - aborted due to compilation errors. -######## - -# 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 deleted file mode 100644 index 40b5557..0000000 --- a/contrib/perl5/t/pragma/strict-vars +++ /dev/null @@ -1,410 +0,0 @@ -Check strict vars functionality - -__END__ - -# no strict, should build & run ok. -Fred ; -my $fred ; -$b = "fred" ; -$a = $$b ; -EXPECT - -######## - -use strict qw(subs refs) ; -$fred ; -EXPECT - -######## - -use strict ; -no strict 'vars' ; -$fred ; -EXPECT - -######## - -# strict vars - no error -use strict 'vars' ; -use vars qw( $freddy) ; -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 ; -$Fred::ABC = 1 ; -$freddy = 2 ; -EXPECT - -######## - -# strict vars - error -use strict ; -$fred ; -EXPECT -Global symbol "$fred" requires explicit package name at - line 4. -Execution of - aborted due to compilation errors. -######## - -# strict vars - error -use strict 'vars' ; -<$fred> ; -EXPECT -Global symbol "$fred" requires explicit package name at - line 4. -Execution of - aborted due to compilation errors. -######## - -# strict vars - error -use strict 'vars' ; -local $fred ; -EXPECT -Global symbol "$fred" requires explicit package name at - line 4. -Execution of - aborted due to compilation errors. -######## - -# Check compile time scope of strict vars pragma -use strict 'vars' ; -{ - no strict ; - $joe = 1 ; -} -$joe = 1 ; -EXPECT -Variable "$joe" is not imported at - line 8. -Global symbol "$joe" requires explicit package name at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check compile time scope of strict vars pragma -no strict; -{ - use strict 'vars' ; - $joe = 1 ; -} -$joe = 1 ; -EXPECT -Global symbol "$joe" requires explicit package name at - line 6. -Execution of - aborted due to compilation errors. -######## - ---FILE-- abc -$joe = 1 ; -1; ---FILE-- -use strict 'vars' ; -require "./abc"; -EXPECT - -######## - ---FILE-- abc -use strict 'vars' ; -1; ---FILE-- -require "./abc"; -$joe = 1 ; -EXPECT - -######## - ---FILE-- abc -use strict 'vars' ; -$joe = 1 ; -1; ---FILE-- -$joe = 1 ; -require "./abc"; -EXPECT -Variable "$joe" is not imported at ./abc line 2. -Global symbol "$joe" requires explicit package name at ./abc line 2. -Compilation failed in require at - line 2. -######## - ---FILE-- abc.pm -use strict 'vars' ; -$joe = 1 ; -1; ---FILE-- -$joe = 1 ; -use abc; -EXPECT -Variable "$joe" is not imported at abc.pm line 2. -Global symbol "$joe" requires explicit package name at abc.pm line 2. -Compilation failed in require at - line 2. -BEGIN failed--compilation aborted at - line 2. -######## - ---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-- -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 1. -BEGIN failed--compilation aborted at - line 1. -######## - -# Check scope of pragma with eval -no strict ; -eval { - $joe = 1 ; -}; -print STDERR $@; -$joe = 1 ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval { - use strict 'vars' ; - $joe = 1 ; -}; -print STDERR $@; -$joe = 1 ; -EXPECT -Global symbol "$joe" requires explicit package name at - line 6. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -use strict 'vars' ; -eval { - $joe = 1 ; -}; -print STDERR $@; -$joe = 1 ; -EXPECT -Global symbol "$joe" requires explicit package name at - line 5. -Global symbol "$joe" requires explicit package name at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -use strict 'vars' ; -eval { - no strict ; - $joe = 1 ; -}; -print STDERR $@; -$joe = 1 ; -EXPECT -Variable "$joe" is not imported at - line 9. -Global symbol "$joe" requires explicit package name at - line 9. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -no strict ; -eval ' - $joe = 1 ; -'; print STDERR $@ ; -$joe = 1 ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval q[ - use strict 'vars' ; - $joe = 1 ; -]; print STDERR $@; -EXPECT -Global symbol "$joe" requires explicit package name at (eval 1) line 3. -######## - -# Check scope of pragma with eval -use strict 'vars' ; -eval ' - $joe = 1 ; -'; print STDERR $@ ; -EXPECT -Global symbol "$joe" requires explicit package name at (eval 1) line 2. -######## - -# Check scope of pragma with eval -use strict 'vars' ; -eval ' - no strict ; - $joe = 1 ; -'; print STDERR $@; -$joe = 1 ; -EXPECT -Global symbol "$joe" requires explicit package name at - line 8. -Execution of - aborted due to compilation errors. -######## - -# 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 $x = 1 } -{ our $x = 0 } -our $foo; -{ - our $foo; - package Foo; - our $foo; -} -EXPECT -"our" variable $foo redeclared at - line 9. - (Did you mean "local" instead of "our"?) -Name "Foo::foo" used only once: possible typo at - line 11. -######## - -# Make sure the strict vars failure still occurs -# now that the `@i should be written as \@i' failure does not occur -# 20000522 mjd@plover.com (MJD) -use strict 'vars'; -no warnings; -"@i_like_crackers"; -EXPECT -Global symbol "@i_like_crackers" requires explicit package name at - line 7. -Execution of - aborted due to compilation errors. diff --git a/contrib/perl5/t/pragma/strict.t b/contrib/perl5/t/pragma/strict.t deleted file mode 100755 index 5b245d0..0000000 --- a/contrib/perl5/t/pragma/strict.t +++ /dev/null @@ -1,91 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $ENV{PERL5LIB} = '../lib'; -} - -$| = 1; - -my $Is_VMS = $^O eq 'VMS'; -my $Is_MSWin32 = $^O eq 'MSWin32'; -my $tmpfile = "tmp0000"; -my $i = 0 ; -1 while -f ++$tmpfile; -END { if ($tmpfile) { 1 while unlink $tmpfile; } } - -my @prgs = () ; - -foreach (sort glob("pragma/strict-*")) { - - next if /(~|\.orig|,v)$/; - - open F, "<$_" or die "Cannot open $_: $!\n" ; - while (<F>) { - last if /^__END__/ ; - } - - { - local $/ = undef; - @prgs = (@prgs, split "\n########\n", <F>) ; - } - close F ; -} - -undef $/; - -print "1..", scalar @prgs, "\n"; - - -for (@prgs){ - my $switch = ""; - my @temps = () ; - if (s/^\s*-\w+//){ - $switch = $&; - } - my($prog,$expected) = split(/\nEXPECT\n/, $_); - if ( $prog =~ /--FILE--/) { - my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; - shift @files ; - die "Internal error test $i didn't split into pairs, got " . - scalar(@files) . "[" . join("%%%%", @files) ."]\n" - if @files % 2 ; - while (@files > 2) { - my $filename = shift @files ; - my $code = shift @files ; - push @temps, $filename ; - open F, ">$filename" or die "Cannot open $filename: $!\n" ; - print F $code ; - close F ; - } - shift @files ; - $prog = shift @files ; - } - open TEST, ">$tmpfile"; - print TEST $prog,"\n"; - close TEST; - my $results = $Is_MSWin32 ? - `.\\perl -I../lib $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 - $results =~ s/tmp\d+/-/g; - $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg - $expected =~ s/\n+$//; - my $prefix = ($results =~ s/^PREFIX\n//) ; - if ( $results =~ s/^SKIPPED\n//) { - print "$results\n" ; - } - elsif (($prefix and $results !~ /^\Q$expected/) or - (!$prefix and $results ne $expected)){ - print STDERR "PROG: $switch\n$prog\n"; - print STDERR "EXPECTED:\n$expected\n"; - print STDERR "GOT:\n$results\n"; - print "not "; - } - print "ok ", ++$i, "\n"; - foreach (@temps) - { unlink $_ if $_ } -} diff --git a/contrib/perl5/t/pragma/sub_lval.t b/contrib/perl5/t/pragma/sub_lval.t deleted file mode 100755 index f19268b..0000000 --- a/contrib/perl5/t/pragma/sub_lval.t +++ /dev/null @@ -1,542 +0,0 @@ -print "1..64\n"; - -BEGIN { - chdir 't' if -d 't'; - @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'; - -$_ = undef; -eval <<'EOE' or $_ = $@; - sub lv1t : lvalue { index $x, 2 } - lv1t = (2,3); - 1; -EOE - -print "# '$_'.\nnot " - unless /Can\'t modify index in lvalue subroutine return/; -print "ok 35\n"; - -$_ = undef; -eval <<'EOE' or $_ = $@; - sub lv2t : lvalue { shift } - (lv2t) = (2,3); - 1; -EOE - -print "# '$_'.\nnot " - unless /Can\'t modify shift in lvalue subroutine return/; -print "ok 36\n"; - -$xxx = 'xxx'; -sub xxx () { $xxx } # Not lvalue - -$_ = undef; -eval <<'EOE' or $_ = $@; - sub lv1tmp : lvalue { xxx } # is it a TEMP? - lv1tmp = (2,3); - 1; -EOE - -print "# '$_'.\nnot " - unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/; -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 yyy () { 'yyy' } # Const, not lvalue - -$_ = undef; -eval <<'EOE' or $_ = $@; - sub lv1tmpr : lvalue { yyy } # is it read-only? - lv1tmpr = (2,3); - 1; -EOE - -print "# '$_'.\nnot " - unless /Can\'t modify constant item in lvalue subroutine return/; -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"; - -sub lva : lvalue {@a} - -$_ = undef; -@a = (); -$a[1] = 12; -eval <<'EOE' or $_ = $@; - (lva) = (2,3); - 1; -EOE - -print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' "; -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"; - -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"; - -# This must happen at run time -eval { - sub AUTOLOAD : lvalue { $newvar }; -}; -foobar() = 12; -print "# '$newvar'.\nnot " unless $newvar eq "12"; -print "ok 47\n"; - -# Testing DWIM of foo = bar; -sub foo : lvalue { - $a; -} -$a = "not ok 48\n"; -foo = "ok 48\n"; -print $a; - -open bar, ">nothing" or die $!; -bar = *STDOUT; -print bar "ok 49\n"; -unlink "nothing"; - -{ -my %hash; my @array; -sub alv : lvalue { $array[1] } -sub alv2 : lvalue { $array[$_[0]] } -sub hlv : lvalue { $hash{"foo"} } -sub hlv2 : lvalue { $hash{$_[0]} } -$array[1] = "not ok 51\n"; -alv() = "ok 50\n"; -print alv(); - -alv2(20) = "ok 51\n"; -print $array[20]; - -$hash{"foo"} = "not ok 52\n"; -hlv() = "ok 52\n"; -print $hash{foo}; - -$hash{bar} = "not ok 53\n"; -hlv("bar") = "ok 53\n"; -print hlv("bar"); - -sub array : lvalue { @array } -sub array2 : lvalue { @array2 } # This is a global. -sub hash : lvalue { %hash } -sub hash2 : lvalue { %hash2 } # So's this. -@array2 = qw(foo bar); -%hash2 = qw(foo bar); - -(array()) = qw(ok 54); -print "not " unless "@array" eq "ok 54"; -print "ok 54\n"; - -(array2()) = qw(ok 55); -print "not " unless "@array2" eq "ok 55"; -print "ok 55\n"; - -(hash()) = qw(ok 56); -print "not " unless $hash{ok} == 56; -print "ok 56\n"; - -(hash2()) = qw(ok 57); -print "not " unless $hash2{ok} == 57; -print "ok 57\n"; - -@array = qw(a b c d); -sub aslice1 : lvalue { @array[0,2] }; -(aslice1()) = ("ok", "already"); -print "# @array\nnot " unless "@array" eq "ok b already d"; -print "ok 58\n"; - -@array2 = qw(a B c d); -sub aslice2 : lvalue { @array2[0,2] }; -(aslice2()) = ("ok", "already"); -print "not " unless "@array2" eq "ok B already d"; -print "ok 59\n"; - -%hash = qw(a Alpha b Beta c Gamma); -sub hslice : lvalue { @hash{"c", "b"} } -(hslice()) = ("CISC", "BogoMIPS"); -print "not " unless join("/",@hash{"c","a","b"}) eq "CISC/Alpha/BogoMIPS"; -print "ok 60\n"; -} - -$str = "Hello, world!"; -sub sstr : lvalue { substr($str, 1, 4) } -sstr() = "i"; -print "not " unless $str eq "Hi, world!"; -print "ok 61\n"; - -$str = "Made w/ JavaScript"; -sub veclv : lvalue { vec($str, 2, 32) } -if (ord('A') != 193) { - veclv() = 0x5065726C; -} -else { # EBCDIC? - veclv() = 0xD7859993; -} -print "# $str\nnot " unless $str eq "Made w/ PerlScript"; -print "ok 62\n"; - -sub position : lvalue { pos } -@p = (); -$_ = "fee fi fo fum"; -while (/f/g) { - push @p, position; - position() += 6; -} -print "# @p\nnot " unless "@p" eq "1 8"; -print "ok 63\n"; - -# Bug 20001223.002: split thought that the list had only one element -@ary = qw(4 5 6); -sub lval1 : lvalue { $ary[0]; } -sub lval2 : lvalue { $ary[1]; } -(lval1(), lval2()) = split ' ', "1 2 3 4"; -print "not " unless join(':', @ary) eq "1:2:6"; -print "ok 64\n"; diff --git a/contrib/perl5/t/pragma/subs.t b/contrib/perl5/t/pragma/subs.t deleted file mode 100755 index 7e48e20..0000000 --- a/contrib/perl5/t/pragma/subs.t +++ /dev/null @@ -1,159 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $ENV{PERL5LIB} = '../lib'; -} - -$| = 1; -undef $/; -my @prgs = split "\n########\n", <DATA>; -print "1..", scalar @prgs, "\n"; - -my $Is_VMS = $^O eq 'VMS'; -my $Is_MSWin32 = $^O eq 'MSWin32'; -my $tmpfile = "tmp0000"; -my $i = 0 ; -1 while -f ++$tmpfile; -END { if ($tmpfile) { 1 while unlink $tmpfile} } - -for (@prgs){ - my $switch = ""; - my @temps = () ; - if (s/^\s*-\w+//){ - $switch = $&; - } - my($prog,$expected) = split(/\nEXPECT\n/, $_); - if ( $prog =~ /--FILE--/) { - my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; - shift @files ; - die "Internal error test $i didn't split into pairs, got " . - scalar(@files) . "[" . join("%%%%", @files) ."]\n" - if @files % 2 ; - while (@files > 2) { - my $filename = shift @files ; - my $code = shift @files ; - push @temps, $filename ; - open F, ">$filename" or die "Cannot open $filename: $!\n" ; - print F $code ; - close F ; - } - shift @files ; - $prog = shift @files ; - } - open TEST, ">$tmpfile"; - print TEST $prog,"\n"; - close TEST; - my $results = $Is_VMS ? - `./perl $switch $tmpfile 2>&1` : - $Is_MSWin32 ? - `.\\perl -I../lib $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 - $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; - $expected =~ s/\n+$//; - my $prefix = ($results =~ s/^PREFIX\n//) ; - if ( $results =~ s/^SKIPPED\n//) { - print "$results\n" ; - } - elsif (($prefix and $results !~ /^\Q$expected/) or - (!$prefix and $results ne $expected)){ - print STDERR "PROG: $switch\n$prog\n"; - print STDERR "EXPECTED:\n$expected\n"; - print STDERR "GOT:\n$results\n"; - print "not "; - } - print "ok ", ++$i, "\n"; - foreach (@temps) - { unlink $_ if $_ } -} - -__END__ - -# Error - not predeclaring a sub -Fred 1,2 ; -sub Fred {} -EXPECT -Number found where operator expected at - line 3, near "Fred 1" - (Do you need to predeclare Fred?) -syntax error at - line 3, near "Fred 1" -Execution of - aborted due to compilation errors. -######## - -# Error - not predeclaring a sub in time -Fred 1,2 ; -use subs qw( Fred ) ; -sub Fred {} -EXPECT -Number found where operator expected at - line 3, near "Fred 1" - (Do you need to predeclare Fred?) -syntax error at - line 3, near "Fred 1" -BEGIN not safe after errors--compilation aborted at - line 4. -######## - -# AOK -use subs qw( Fred) ; -Fred 1,2 ; -sub Fred { print $_[0] + $_[1], "\n" } -EXPECT -3 -######## - -# override a built-in function -use subs qw( open ) ; -open 1,2 ; -sub open { print $_[0] + $_[1], "\n" } -EXPECT -3 -######## - -# override a built-in function, call after definition -use subs qw( open ) ; -sub open { print $_[0] + $_[1], "\n" } -open 1,2 ; -EXPECT -3 -######## - -# override a built-in function, call with () -use subs qw( open ) ; -open (1,2) ; -sub open { print $_[0] + $_[1], "\n" } -EXPECT -3 -######## - -# override a built-in function, call with () after definition -use subs qw( open ) ; -sub open { print $_[0] + $_[1], "\n" } -open (1,2) ; -EXPECT -3 -######## - ---FILE-- abc -Fred 1,2 ; -1; ---FILE-- -use subs qw( Fred ) ; -require "./abc" ; -sub Fred { print $_[0] + $_[1], "\n" } -EXPECT -3 -######## - -# check that it isn't affected by block scope -{ - use subs qw( Fred ) ; -} -Fred 1, 2; -sub Fred { print $_[0] + $_[1], "\n" } -EXPECT -3 diff --git a/contrib/perl5/t/pragma/utf8.t b/contrib/perl5/t/pragma/utf8.t deleted file mode 100755 index e0a321a..0000000 --- a/contrib/perl5/t/pragma/utf8.t +++ /dev/null @@ -1,462 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @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..90\n"; - -my $test = 1; - -sub ok { - my ($got,$expect) = @_; - print "# expected [$expect], got [$got]\nnot " if $got ne $expect; - print "ok $test\n"; -} - -sub nok { - my ($got,$expect) = @_; - print "# expected not [$expect], got [$got]\nnot " if $got eq $expect; - print "ok $test\n"; -} - -sub ok_bytes { - use bytes; - my ($got,$expect) = @_; - print "# expected [$expect], got [$got]\nnot " if $got ne $expect; - print "ok $test\n"; -} - -sub nok_bytes { - use bytes; - my ($got,$expect) = @_; - print "# expected not [$expect], got [$got]\nnot " if $got eq $expect; - print "ok $test\n"; -} - -{ - use utf8; - $_ = ">\x{263A}<"; - s/([\x{80}-\x{10ffff}])/"&#".ord($1).";"/eg; - ok $_, '>☺<'; - $test++; # 1 - - $_ = ">\x{263A}<"; - my $rx = "\x{80}-\x{10ffff}"; - s/([$rx])/"&#".ord($1).";"/eg; - ok $_, '>☺<'; - $test++; # 2 - - $_ = ">\x{263A}<"; - my $rx = "\\x{80}-\\x{10ffff}"; - s/([$rx])/"&#".ord($1).";"/eg; - ok $_, '>☺<'; - $test++; # 3 - - $_ = "alpha,numeric"; - m/([[:alpha:]]+)/; - ok $1, 'alpha'; - $test++; # 4 - - $_ = "alphaNUMERICstring"; - m/([[:^lower:]]+)/; - ok $1, 'NUMERIC'; - $test++; # 5 - - $_ = "alphaNUMERICstring"; - m/(\p{Ll}+)/; - ok $1, 'alpha'; - $test++; # 6 - - $_ = "alphaNUMERICstring"; - m/(\p{Lu}+)/; - ok $1, 'NUMERIC'; - $test++; # 7 - - $_ = "alpha,numeric"; - m/([\p{IsAlpha}]+)/; - ok $1, 'alpha'; - $test++; # 8 - - $_ = "alphaNUMERICstring"; - m/([^\p{IsLower}]+)/; - ok $1, 'NUMERIC'; - $test++; # 9 - - $_ = "alpha123numeric456"; - m/([\p{IsDigit}]+)/; - ok $1, '123'; - $test++; # 10 - - $_ = "alpha123numeric456"; - m/([^\p{IsDigit}]+)/; - ok $1, 'alpha'; - $test++; # 11 - - $_ = ",123alpha,456numeric"; - m/([\p{IsAlnum}]+)/; - ok $1, '123alpha'; - $test++; # 12 -} - -{ - use utf8; - - $_ = "\x{263A}>\x{263A}\x{263A}"; - - ok length, 4; - $test++; # 13 - - ok length((m/>(.)/)[0]), 1; - $test++; # 14 - - ok length($&), 2; - $test++; # 15 - - ok length($'), 1; - $test++; # 16 - - ok length($`), 1; - $test++; # 17 - - ok length($1), 1; - $test++; # 18 - - ok length($tmp=$&), 2; - $test++; # 19 - - ok length($tmp=$'), 1; - $test++; # 20 - - ok length($tmp=$`), 1; - $test++; # 21 - - ok length($tmp=$1), 1; - $test++; # 22 - - { - use bytes; - - my $tmp = $&; - ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272); - $test++; # 23 - - $tmp = $'; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 24 - - $tmp = $`; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 25 - - $tmp = $1; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 26 - } - - ok_bytes $&, pack("C*", ord(">"), 0342, 0230, 0272); - $test++; # 27 - - ok_bytes $', pack("C*", 0342, 0230, 0272); - $test++; # 28 - - ok_bytes $`, pack("C*", 0342, 0230, 0272); - $test++; # 29 - - ok_bytes $1, pack("C*", 0342, 0230, 0272); - $test++; # 30 - - { - use bytes; - no utf8; - - ok length, 10; - $test++; # 31 - - ok length((m/>(.)/)[0]), 1; - $test++; # 32 - - ok length($&), 2; - $test++; # 33 - - ok length($'), 5; - $test++; # 34 - - ok length($`), 3; - $test++; # 35 - - ok length($1), 1; - $test++; # 36 - - ok $&, pack("C*", ord(">"), 0342); - $test++; # 37 - - ok $', pack("C*", 0230, 0272, 0342, 0230, 0272); - $test++; # 38 - - ok $`, pack("C*", 0342, 0230, 0272); - $test++; # 39 - - ok $1, pack("C*", 0342); - $test++; # 40 - } - - { - no utf8; - $_="\342\230\272>\342\230\272\342\230\272"; - } - - ok length, 10; - $test++; # 41 - - ok length((m/>(.)/)[0]), 1; - $test++; # 42 - - ok length($&), 2; - $test++; # 43 - - ok length($'), 1; - $test++; # 44 - - ok length($`), 1; - $test++; # 45 - - ok length($1), 1; - $test++; # 46 - - ok length($tmp=$&), 2; - $test++; # 47 - - ok length($tmp=$'), 1; - $test++; # 48 - - ok length($tmp=$`), 1; - $test++; # 49 - - ok length($tmp=$1), 1; - $test++; # 50 - - { - use bytes; - - my $tmp = $&; - ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272); - $test++; # 51 - - $tmp = $'; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 52 - - $tmp = $`; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 53 - - $tmp = $1; - ok $tmp, pack("C*", 0342, 0230, 0272); - $test++; # 54 - } - - { - use bytes; - no utf8; - - ok length, 10; - $test++; # 55 - - ok length((m/>(.)/)[0]), 1; - $test++; # 56 - - ok length($&), 2; - $test++; # 57 - - ok length($'), 5; - $test++; # 58 - - ok length($`), 3; - $test++; # 59 - - ok length($1), 1; - $test++; # 60 - - ok $&, pack("C*", ord(">"), 0342); - $test++; # 61 - - ok $', pack("C*", 0230, 0272, 0342, 0230, 0272); - $test++; # 62 - - ok $`, pack("C*", 0342, 0230, 0272); - $test++; # 63 - - ok $1, pack("C*", 0342); - $test++; # 64 - } - - ok "\x{ab}" =~ /^\x{ab}$/, 1; - $test++; # 65 -} - -{ - use utf8; - ok join(" ",unpack("C*",chr(128).chr(255))), "128 255"; - $test++; -} - -{ - use utf8; - my @a = map ord, split(//, join("", map chr, (1234, 123, 2345))); - ok "@a", "1234 123 2345"; - $test++; # 67 -} - -{ - use utf8; - my $x = chr(123); - my @a = map ord, split(/$x/, join("", map chr, (1234, 123, 2345))); - ok "@a", "1234 2345"; - $test++; # 68 -} - -{ - # bug id 20001009.001 - - my ($a, $b); - - { use bytes; $a = "\xc3\xa4" } - { use utf8; $b = "\xe4" } # \xXX must not produce UTF-8 - - print "not " if $a eq $b; - print "ok $test\n"; $test++; - - { use utf8; print "not " if $a eq $b; } - print "ok $test\n"; $test++; -} - -{ - # bug id 20001008.001 - - my @x = ("stra\337e 138","stra\337e 138"); - for (@x) { - s/(\d+)\s*([\w\-]+)/$1 . uc $2/e; - my($latin) = /^(.+)(?:\s+\d)/; - print $latin eq "stra\337e" ? "ok $test\n" : - "#latin[$latin]\nnot ok $test\n"; - $test++; - $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a - use utf8; - $latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a - } -} - -{ - # bug id 20000427.003 - - use utf8; - use warnings; - use strict; - - my $sushi = "\x{b36c}\x{5a8c}\x{ff5b}\x{5079}\x{505b}"; - - my @charlist = split //, $sushi; - my $r = ''; - foreach my $ch (@charlist) { - $r = $r . " " . sprintf "U+%04X", ord($ch); - } - - print "not " unless $r eq " U+B36C U+5A8C U+FF5B U+5079 U+505B"; - print "ok $test\n"; - $test++; -} - -{ - # bug id 20000426.003 - - use utf8; - - my $s = "\x20\x40\x{80}\x{100}\x{80}\x40\x20"; - - my ($a, $b, $c) = split(/\x40/, $s); - print "not " - unless $a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a; - print "ok $test\n"; - $test++; - - my ($a, $b) = split(/\x{100}/, $s); - print "not " unless $a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20"; - print "ok $test\n"; - $test++; - - my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s); - print "not " unless $a eq "\x20\x40" && $b eq "\x40\x20"; - print "ok $test\n"; - $test++; - - my ($a, $b) = split(/\x40\x{80}/, $s); - print "not " unless $a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20"; - print "ok $test\n"; - $test++; - - my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s); - print "not " unless $a eq "\x20" && $b eq "\x{100}" && $c eq "\x20"; - print "ok $test\n"; - $test++; -} - -{ - # bug id 20000730.004 - - use utf8; - - my $smiley = "\x{263a}"; - - for my $s ("\x{263a}", # 1 - $smiley, # 2 - - "" . $smiley, # 3 - "" . "\x{263a}", # 4 - - $smiley . "", # 5 - "\x{263a}" . "", # 6 - ) { - my $length_chars = length($s); - my $length_bytes; - { use bytes; $length_bytes = length($s) } - my @regex_chars = $s =~ m/(.)/g; - my $regex_chars = @regex_chars; - my @split_chars = split //, $s; - my $split_chars = @split_chars; - print "not " - unless "$length_chars/$regex_chars/$split_chars/$length_bytes" eq - "1/1/1/3"; - print "ok $test\n"; - $test++; - } - - for my $s ("\x{263a}" . "\x{263a}", # 7 - $smiley . $smiley, # 8 - - "\x{263a}\x{263a}", # 9 - "$smiley$smiley", # 10 - - "\x{263a}" x 2, # 11 - $smiley x 2, # 12 - ) { - my $length_chars = length($s); - my $length_bytes; - { use bytes; $length_bytes = length($s) } - my @regex_chars = $s =~ m/(.)/g; - my $regex_chars = @regex_chars; - my @split_chars = split //, $s; - my $split_chars = @split_chars; - print "not " - unless "$length_chars/$regex_chars/$split_chars/$length_bytes" eq - "2/2/2/6"; - print "ok $test\n"; - $test++; - } -} diff --git a/contrib/perl5/t/pragma/warn/1global b/contrib/perl5/t/pragma/warn/1global deleted file mode 100644 index 0af8022..0000000 --- a/contrib/perl5/t/pragma/warn/1global +++ /dev/null @@ -1,189 +0,0 @@ -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 deleted file mode 100644 index b489d62..0000000 --- a/contrib/perl5/t/pragma/warn/2use +++ /dev/null @@ -1,356 +0,0 @@ -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 -use warnings; -{ - no warnings ; - eval { - my $b ; chop $b ; - }; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## - -# Check scope of pragma with eval -use warnings; -{ - 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 8. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval { - my $b ; chop $b ; - }; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at - line 7. -Use of uninitialized value in scalar chop at - line 9. -######## - -# Check scope of pragma with eval -no warnings; -{ - 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 10. -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval { - 1 if $a EQ $b ; - }; print STDERR $@ ; - 1 if $a EQ $b ; -} -EXPECT - -######## - -# Check scope of pragma with eval -use warnings; -{ - 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 8. -######## - -# Check scope of pragma with eval -no warnings; -{ - 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 - line 9. -######## - -# Check scope of pragma with eval -no warnings; -{ - 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 10. -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## - -# Check scope of pragma with eval -use warnings; -{ - 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 -no warnings; -{ - 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 9. -######## - -# Check scope of pragma with eval -no warnings; -{ - 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 10. -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval ' - 1 if $a EQ $b ; - '; print STDERR $@ ; - 1 if $a EQ $b ; -} -EXPECT - -######## - -# Check scope of pragma with eval -use warnings; -{ - 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 -no warnings; -{ - use warnings 'deprecated' ; - eval ' - 1 if $a EQ $b ; - '; print STDERR $@; - 1 if $a EQ $b ; -} -EXPECT -Use of EQ is deprecated at - line 9. -Use of EQ is deprecated at (eval 1) line 2. -######## - -# Check scope of pragma with eval -no warnings; -{ - 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 10. -######## - -# 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 deleted file mode 100644 index 335e1b2..0000000 --- a/contrib/perl5/t/pragma/warn/3both +++ /dev/null @@ -1,266 +0,0 @@ -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. -######## - -# Check scope of pragma with eval -BEGIN { $^W = 1 } -{ - no warnings ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## - -# Check scope of pragma with eval -BEGIN { $^W = 1 } -use warnings; -{ - 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 -BEGIN { $^W = 0 } -{ - 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 9. -######## - -# Check scope of pragma with eval -BEGIN { $^W = 0 } -{ - 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 10. -######## - -# Check scope of pragma with eval -BEGIN { $^W = 1 } -{ - no warnings ; - eval ' - 1 if $a EQ $b ; - '; print STDERR $@ ; - 1 if $a EQ $b ; -} -EXPECT - diff --git a/contrib/perl5/t/pragma/warn/4lint b/contrib/perl5/t/pragma/warn/4lint deleted file mode 100644 index b2fa75f..0000000 --- a/contrib/perl5/t/pragma/warn/4lint +++ /dev/null @@ -1,216 +0,0 @@ -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 STDIN at - line 6. -######## --W -# lint: check runtime $^W is zapped -$^W = 0 ; -close STDIN ; print STDIN "abc" ; -EXPECT -print() on closed filehandle STDIN at - line 4. -######## --W -# lint: check runtime $^W is zapped -{ - $^W = 0 ; - close STDIN ; print STDIN "abc" ; -} -EXPECT -print() on closed filehandle 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 STDIN at - line 6. -######## --W -# lint: check "no warnings" is zapped -{ - no warnings ; - close STDIN ; print STDIN "abc" ; -} -EXPECT -print() on closed filehandle STDIN at - line 5. -######## --Ww -# lint: check combination of -w and -W -{ - $^W = 0 ; - close STDIN ; print STDIN "abc" ; -} -EXPECT -print() on closed filehandle 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. -######## --W -# Check scope of pragma with eval -{ - no warnings ; - 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 8. -######## --W -# Check scope of pragma with eval -use warnings; -{ - 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. -Use of uninitialized value in scalar chop at - line 10. -######## --W -# Check scope of pragma with eval -no warnings; -{ - 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 9. -######## --W -# Check scope of pragma with eval -no warnings; -{ - 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 (eval 1) line 3. -Use of uninitialized value in scalar chop at - line 10. -######## --W -# Check scope of pragma with eval -use warnings; -{ - my $a = "1"; my $b = "2"; - 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 - line 11. -Use of EQ is deprecated at (eval 1) line 3. -######## --W -# Check scope of pragma with eval -no warnings; -{ - my $a = "1"; my $b = "2"; - use warnings 'deprecated' ; - eval ' - 1 if $a EQ $b ; - '; print STDERR $@; - 1 if $a EQ $b ; -} -EXPECT -Use of EQ is deprecated at - line 10. -Use of EQ is deprecated at (eval 1) line 2. -######## --W -# Check scope of pragma with eval -no warnings; -{ - my $a = "1"; my $b = "2"; - 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 11. -Use of EQ is deprecated at (eval 1) line 3. diff --git a/contrib/perl5/t/pragma/warn/5nolint b/contrib/perl5/t/pragma/warn/5nolint deleted file mode 100644 index 2459968..0000000 --- a/contrib/perl5/t/pragma/warn/5nolint +++ /dev/null @@ -1,204 +0,0 @@ -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 -######## --X -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval q[ - use warnings 'uninitialized' ; - my $b ; chop $b ; - ]; print STDERR $@; - my $b ; chop $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval ' - no warnings ; - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval ' - 1 if $a EQ $b ; - '; print STDERR $@ ; - 1 if $a EQ $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval q[ - use warnings 'deprecated' ; - 1 if $a EQ $b ; - ]; print STDERR $@; - 1 if $a EQ $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -no warnings; -{ - use warnings 'deprecated' ; - eval ' - 1 if $a EQ $b ; - '; print STDERR $@; - 1 if $a EQ $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -no warnings; -{ - use warnings 'deprecated' ; - eval ' - no warnings ; - 1 if $a EQ $b ; - '; print STDERR $@; - 1 if $a EQ $b ; -} -EXPECT - diff --git a/contrib/perl5/t/pragma/warn/6default b/contrib/perl5/t/pragma/warn/6default deleted file mode 100644 index a8aafee..0000000 --- a/contrib/perl5/t/pragma/warn/6default +++ /dev/null @@ -1,121 +0,0 @@ -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. -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval ' - my $a = oct "0xfffffffffffffffffg" ; - '; print STDERR $@ ; - my $a = oct "0xfffffffffffffffffg" ; -} -EXPECT - -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval q[ - use warnings ; - my $a = oct "0xfffffffffffffffffg" ; - ]; print STDERR $@; - my $a = oct "0xfffffffffffffffffg" ; -} -EXPECT -Integer overflow in hexadecimal number at (eval 1) line 3. -Illegal hexadecimal digit 'g' ignored at (eval 1) line 3. -Hexadecimal number > 0xffffffff non-portable at (eval 1) line 3. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings ; - eval ' - my $a = oct "0xfffffffffffffffffg" ; - '; print STDERR $@ ; -} -EXPECT -Integer overflow in hexadecimal number at (eval 1) line 2. -Illegal hexadecimal digit 'g' ignored at (eval 1) line 2. -Hexadecimal number > 0xffffffff non-portable at (eval 1) line 2. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings; - eval ' - no warnings ; - my $a = oct "0xfffffffffffffffffg" ; - '; print STDERR $@ ; -} -EXPECT - -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'deprecated' ; - eval ' - my $a = oct "0xfffffffffffffffffg" ; - '; print STDERR $@; -} -EXPECT - diff --git a/contrib/perl5/t/pragma/warn/7fatal b/contrib/perl5/t/pragma/warn/7fatal deleted file mode 100644 index ed585c2..0000000 --- a/contrib/perl5/t/pragma/warn/7fatal +++ /dev/null @@ -1,312 +0,0 @@ -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 compile time warning -use warnings FATAL => 'all' ; -{ - 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 -use warnings FATAL => 'all' ; -{ - 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. -######## - -# Check runtime scope of pragma -no warnings ; -{ - use warnings FATAL => 'all' ; - $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. -######## - -use warnings 'void' ; - -time ; - -{ - use warnings FATAL => qw(void) ; - length "abc" ; -} - -join "", 1,2,3 ; - -print "done\n" ; -EXPECT -Useless use of time in void context at - line 4. -Useless use of length in void context at - line 8. -######## - -use warnings ; - -time ; - -{ - use warnings FATAL => qw(void) ; - length "abc" ; -} - -join "", 1,2,3 ; - -print "done\n" ; -EXPECT -Useless use of time in void context at - line 4. -Useless use of length in void context at - line 8. diff --git a/contrib/perl5/t/pragma/warn/8signal b/contrib/perl5/t/pragma/warn/8signal deleted file mode 100644 index d480f19..0000000 --- a/contrib/perl5/t/pragma/warn/8signal +++ /dev/null @@ -1,18 +0,0 @@ -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 deleted file mode 100755 index f5579b2..0000000 --- a/contrib/perl5/t/pragma/warn/9enabled +++ /dev/null @@ -1,1162 +0,0 @@ -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 -######## - -# check warnings::warnif -use warnings ; -eval { warnings::warnif() } ; -print $@ ; -eval { warnings::warnif("fred", "joe") } ; -print $@ ; -EXPECT -Usage: warnings::warnif([category,] 'message') at - line 4 -unknown warnings category 'fred' 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 - eval {...} called 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 - eval {...} called 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 abc.pm line 4 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -sub check { - warnings::warn("fred") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -abc::check() ; -EXPECT -package 'abc' not registered for warnings at abc.pm line 4 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -sub check { - warnings::warnif("fred") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -abc::check() ; -EXPECT -package 'abc' not registered for warnings at abc.pm line 4 -######## - ---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 - eval {...} called 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 - eval {...} called 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") ; - warnings::warnif("my message 1") ; - warnings::warnif('abc', "my message 2") ; - warnings::warnif('io', "my message 3") ; - warnings::warnif('all', "my message 4") ; -} -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 -######## --w ---FILE-- abc.pm -package abc ; -no warnings ; -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 ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## --w ---FILE-- abc.pm -package abc ; -no warnings ; -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 ; -no warnings ; -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") ; - warnings::warnif("my message 1") ; - warnings::warnif('abc', "my message 2") ; - warnings::warnif('io', "my message 3") ; - warnings::warnif('all', "my message 4") ; -} -1; ---FILE-- -use abc ; -use warnings 'abc'; -no warnings ; -BEGIN { $^W = 1 ; } -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("io") ; - print "ok3\n" if !warnings::enabled("all") ; -} -1; ---FILE-- -use abc ; -use warnings 'abc'; -no warnings ; -$^W = 1 ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -$| = 1; -package abc ; -no warnings ; -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") ; - print "ok4\n" if warnings::enabled("abc") ; - warnings::warn("my message 1") ; - warnings::warnif("my message 2") ; - warnings::warnif('abc', "my message 3") ; - warnings::warnif('io', "my message 4") ; - warnings::warnif('all', "my message 5") ; -} -sub in2 { no warnings ; check() } -sub in1 { no warnings ; in2() } -1; ---FILE-- -use abc ; -use warnings 'abc'; -abc::in1() ; -EXPECT -ok1 -ok2 -ok3 -ok4 -my message 1 at - line 3 -my message 2 at - line 3 -my message 3 at - line 3 -######## - ---FILE-- def.pm -package def ; -no warnings ; -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") ; - print "ok4\n" if warnings::enabled("def") ; - warnings::warn("my message 1") ; - warnings::warnif("my message 2") ; - warnings::warnif('def', "my message 3") ; - warnings::warnif('io', "my message 4") ; - warnings::warnif('all', "my message 5") ; -} -sub in2 { no warnings ; check() } -sub in1 { no warnings ; in2() } -1; ---FILE-- abc.pm -$| = 1; -package abc ; -use def ; -use warnings 'def'; -sub in1 { def::in1() ; } -1; ---FILE-- -use abc ; -no warnings; -abc::in1() ; -EXPECT -ok1 -ok2 -ok3 -ok4 -my message 1 at abc.pm line 5 - abc::in1() called at - line 3 -my message 2 at abc.pm line 5 - abc::in1() called at - line 3 -my message 3 at abc.pm line 5 - abc::in1() called at - line 3 -######## - ---FILE-- def.pm -$| = 1; -package def ; -no warnings ; -use warnings::register ; -require Exporter; -@ISA = qw( Exporter ) ; -@EXPORT = qw( in1 ) ; -sub check { - print "ok1\n" if warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; - print "ok4\n" if warnings::enabled("abc") ; - print "ok5\n" if !warnings::enabled("def") ; - warnings::warn("my message 1") ; - warnings::warnif("my message 2") ; - warnings::warnif('abc', "my message 3") ; - warnings::warnif('def', "my message 4") ; - warnings::warnif('io', "my message 5") ; - warnings::warnif('all', "my message 6") ; -} -sub in2 { no warnings ; check() } -sub in1 { no warnings ; in2() } -1; ---FILE-- abc.pm -package abc ; -use warnings::register ; -use def ; -#@ISA = qw(def) ; -1; ---FILE-- -use abc ; -no warnings; -use warnings 'abc'; -abc::in1() ; -EXPECT -ok2 -ok3 -ok4 -ok5 -my message 1 at - line 4 -my message 3 at - line 4 -######## - ---FILE-- def.pm -package def ; -no warnings ; -use warnings::register ; - -sub new -{ - my $class = shift ; - bless [], $class ; -} - -sub check -{ - my $self = shift ; - print "ok1\n" if !warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; - print "ok4\n" if warnings::enabled("abc") ; - print "ok5\n" if !warnings::enabled("def") ; - print "ok6\n" if warnings::enabled($self) ; - - warnings::warn("my message 1") ; - warnings::warn($self, "my message 2") ; - - warnings::warnif("my message 3") ; - warnings::warnif('abc', "my message 4") ; - warnings::warnif('def', "my message 5") ; - warnings::warnif('io', "my message 6") ; - warnings::warnif('all', "my message 7") ; - warnings::warnif($self, "my message 8") ; -} -sub in2 -{ - no warnings ; - my $self = shift ; - $self->check() ; -} -sub in1 -{ - no warnings ; - my $self = shift ; - $self->in2(); -} -1; ---FILE-- abc.pm -$| = 1; -package abc ; -use warnings::register ; -use def ; -@ISA = qw(def) ; -sub new -{ - my $class = shift ; - bless [], $class ; -} - -1; ---FILE-- -use abc ; -no warnings; -use warnings 'abc'; -$a = new abc ; -$a->in1() ; -print "**\n"; -$b = new def ; -$b->in1() ; -EXPECT -ok1 -ok2 -ok3 -ok4 -ok5 -ok6 -my message 1 at - line 5 -my message 2 at - line 5 -my message 4 at - line 5 -my message 8 at - line 5 -** -ok1 -ok2 -ok3 -ok4 -ok5 -my message 1 at - line 8 -my message 2 at - line 8 -my message 4 at - line 8 diff --git a/contrib/perl5/t/pragma/warn/av b/contrib/perl5/t/pragma/warn/av deleted file mode 100644 index 79bd3b76..0000000 --- a/contrib/perl5/t/pragma/warn/av +++ /dev/null @@ -1,9 +0,0 @@ - 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 deleted file mode 100644 index 2a357e2..0000000 --- a/contrib/perl5/t/pragma/warn/doio +++ /dev/null @@ -1,209 +0,0 @@ - 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 filehandle %s [Perl_do_close] - $a = "fred";close("$a") - - tell() on closed filehandle [Perl_do_tell] - $a = "fred";$a = tell($a) - - seek() on closed filehandle [Perl_do_seek] - $a = "fred";$a = seek($a,1,1) - - sysseek() on closed filehandle [Perl_do_sysseek] - $a = "fred";$a = seek($a,1,1) - - warn(warn_uninit); [Perl_do_print] - print $a ; - - -x on closed filehandle %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 filehandle 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 ; -stat(STDIN) ; -$a = "fred"; -tell($a); -seek($a,1,1); -sysseek($a,1,1); --x $a; # ok -stat($a); # ok -no warnings 'io' ; -close STDIN ; -tell(STDIN); -$a = seek(STDIN,1,1); -$a = sysseek(STDIN,1,1); --x STDIN ; -stat(STDIN) ; -$a = "fred"; -tell($a); -seek($a,1,1); -sysseek($a,1,1); --x $a; -stat($a); -EXPECT -tell() on closed filehandle STDIN at - line 4. -seek() on closed filehandle STDIN at - line 5. -sysseek() on closed filehandle STDIN at - line 6. --x on closed filehandle STDIN at - line 7. -stat() on closed filehandle STDIN at - line 8. -tell() on unopened filehandle at - line 10. -seek() on unopened filehandle at - line 11. -sysseek() on unopened filehandle at - line 12. -######## -# 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 STDOUT opened only for output at - line 3. diff --git a/contrib/perl5/t/pragma/warn/doop b/contrib/perl5/t/pragma/warn/doop deleted file mode 100644 index 5803b44..0000000 --- a/contrib/perl5/t/pragma/warn/doop +++ /dev/null @@ -1,6 +0,0 @@ -# doop.c -use utf8 ; -$_ = "\x80 \xff" ; -chop ; -EXPECT -######## diff --git a/contrib/perl5/t/pragma/warn/gv b/contrib/perl5/t/pragma/warn/gv deleted file mode 100644 index 5ed4eca..0000000 --- a/contrib/perl5/t/pragma/warn/gv +++ /dev/null @@ -1,54 +0,0 @@ - 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 deleted file mode 100644 index c9eec02..0000000 --- a/contrib/perl5/t/pragma/warn/hv +++ /dev/null @@ -1,8 +0,0 @@ - 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 deleted file mode 100644 index 2f8b096..0000000 --- a/contrib/perl5/t/pragma/warn/malloc +++ /dev/null @@ -1,9 +0,0 @@ - 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 deleted file mode 100644 index a8f9dbc..0000000 --- a/contrib/perl5/t/pragma/warn/mg +++ /dev/null @@ -1,44 +0,0 @@ - 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 deleted file mode 100644 index 1f41a98..0000000 --- a/contrib/perl5/t/pragma/warn/op +++ /dev/null @@ -1,872 +0,0 @@ - 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 { - our $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 or string 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 -# -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. -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. -Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;" -BEGIN not safe after errors--compilation aborted at - line 18. -######## -# op.c -use warnings '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 deleted file mode 100644 index b4a00ba..0000000 --- a/contrib/perl5/t/pragma/warn/perl +++ /dev/null @@ -1,72 +0,0 @@ - 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 -######## - -# perl.c -{ use warnings 'once' ; $x = 3 ; } -$y = 3 ; -EXPECT -Name "main::x" used only once: possible typo at - line 3. -######## - -# perl.c -$z = 3 ; -BEGIN { $^W = 1 } -{ no warnings 'once' ; $x = 3 ; } -$y = 3 ; -EXPECT -Name "main::y" used only once: possible typo at - line 6. diff --git a/contrib/perl5/t/pragma/warn/perlio b/contrib/perl5/t/pragma/warn/perlio deleted file mode 100644 index 18c0dfa..0000000 --- a/contrib/perl5/t/pragma/warn/perlio +++ /dev/null @@ -1,10 +0,0 @@ - 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 deleted file mode 100644 index afc5dcc..0000000 --- a/contrib/perl5/t/pragma/warn/perly +++ /dev/null @@ -1,31 +0,0 @@ - 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 deleted file mode 100644 index 8f42ba6..0000000 --- a/contrib/perl5/t/pragma/warn/pp +++ /dev/null @@ -1,110 +0,0 @@ - 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 deleted file mode 100644 index ac01f27..0000000 --- a/contrib/perl5/t/pragma/warn/pp_ctl +++ /dev/null @@ -1,230 +0,0 @@ - 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 -######## -# pp_ctl.c -use warnings; -eval 'print $foo'; -EXPECT -Use of uninitialized value in print at (eval 1) line 1. -######## -# pp_ctl.c -use warnings; -{ - no warnings; - eval 'print $foo'; -} -EXPECT diff --git a/contrib/perl5/t/pragma/warn/pp_hot b/contrib/perl5/t/pragma/warn/pp_hot deleted file mode 100644 index 698255c..0000000 --- a/contrib/perl5/t/pragma/warn/pp_hot +++ /dev/null @@ -1,230 +0,0 @@ - pp_hot.c - - print() on unopened filehandle abc [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>; - - readline() on closed filehandle %s [Perl_do_readline] - readline(NONESUCH); - - 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 -print() on unopened filehandle abc 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 STDIN opened only for input at - line 3. -Filehandle STDOUT opened only for output at - line 4. -Filehandle STDERR opened only for output at - line 5. -Filehandle FOO opened only for output at - line 6. -Filehandle STDERR opened only for output at - line 7. -Filehandle 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 STDIN at - line 4. -print() on closed filehandle STDIN at - line 6. - (Are you trying to call print() on dirhandle 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 STDIN at - line 3. -readline() on closed filehandle STDIN at - line 4. - (Are you trying to call readline() on dirhandle STDIN?) -######## -# pp_hot.c [Perl_do_readline] -use warnings 'io' ; -my $file = "./xcv" ; unlink $file ; -open (FH, ">./xcv") ; -my $a = <FH> ; -no warnings 'io' ; -$a = <FH> ; -close (FH) ; -unlink $file ; -EXPECT -Filehandle 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 deleted file mode 100644 index 68518e2..0000000 --- a/contrib/perl5/t/pragma/warn/pp_sys +++ /dev/null @@ -1,381 +0,0 @@ - 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] - - printf() on unopened filehandle abc [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] - flock() on closed socket [pp_flock] - close STDIN; - flock STDIN, 8; - flock $a, 8; - - warn(warn_nl, "stat"); [pp_stat] - - -T on closed filehandle %s - stat() on closed filehandle %s - close STDIN ; -T STDIN ; stat(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 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 STDIN at - line 6. -write() on closed filehandle STDIN at - line 8. - (Are you trying to call write() on dirhandle 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 -printf() on unopened filehandle abc 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 STDIN at - line 4. -printf() on closed filehandle STDIN at - line 6. - (Are you trying to call printf() on dirhandle STDIN?) -######## -# pp_sys.c [pp_prtf] -use warnings 'io' ; -printf STDIN "fred"; -no warnings 'io' ; -printf STDIN "fred"; -EXPECT -Filehandle STDIN opened only for input at - line 3. -######## -# pp_sys.c [pp_send] -use warnings 'closed' ; -close STDIN; -syswrite STDIN, "fred", 1; -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 STDIN at - line 4. -syswrite() on closed filehandle STDIN at - line 6. - (Are you trying to call syswrite() on dirhandle STDIN?) -######## -# pp_sys.c [pp_flock] -use Config; -BEGIN { - if ( !$Config{d_flock} && - !$Config{d_fcntl_can_lock} && - !$Config{d_lockf} ) { - print <<EOM ; -SKIPPED -# flock not present -EOM - exit ; - } -} -use warnings qw(unopened closed); -close STDIN; -flock STDIN, 8; -opendir STDIN, "."; -flock STDIN, 8; -flock FOO, 8; -flock $a, 8; -no warnings qw(unopened closed); -flock STDIN, 8; -opendir STDIN, "."; -flock STDIN, 8; -flock FOO, 8; -flock $a, 8; -EXPECT -flock() on closed filehandle STDIN at - line 16. -flock() on closed filehandle STDIN at - line 18. - (Are you trying to call flock() on dirhandle STDIN?) -flock() on unopened filehandle FOO at - line 19. -flock() on unopened filehandle at - line 20. -######## -# pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername] -use warnings '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 STDIN at - line 22. -bind() on closed socket STDIN at - line 23. -connect() on closed socket STDIN at - line 24. -listen() on closed socket STDIN at - line 25. -accept() on closed socket STDIN at - line 26. -shutdown() on closed socket STDIN at - line 27. -setsockopt() on closed socket STDIN at - line 28. -getsockopt() on closed socket STDIN at - line 29. -getsockname() on closed socket STDIN at - line 30. -getpeername() on closed socket STDIN at - line 31. -send() on closed socket STDIN at - line 33. - (Are you trying to call send() on dirhandle STDIN?) -bind() on closed socket STDIN at - line 34. - (Are you trying to call bind() on dirhandle STDIN?) -connect() on closed socket STDIN at - line 35. - (Are you trying to call connect() on dirhandle STDIN?) -listen() on closed socket STDIN at - line 36. - (Are you trying to call listen() on dirhandle STDIN?) -accept() on closed socket STDIN at - line 37. - (Are you trying to call accept() on dirhandle STDIN?) -shutdown() on closed socket STDIN at - line 38. - (Are you trying to call shutdown() on dirhandle STDIN?) -setsockopt() on closed socket STDIN at - line 39. - (Are you trying to call setsockopt() on dirhandle STDIN?) -getsockopt() on closed socket STDIN at - line 40. - (Are you trying to call getsockopt() on dirhandle STDIN?) -getsockname() on closed socket STDIN at - line 41. - (Are you trying to call getsockname() on dirhandle STDIN?) -getpeername() on closed socket STDIN at - line 42. - (Are you trying to call getpeername() on dirhandle 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 qw(unopened closed) ; -close STDIN ; --T STDIN ; -stat(STDIN) ; --T HOCUS; -stat(POCUS); -no warnings qw(unopened closed) ; --T STDIN ; -stat(STDIN); --T HOCUS; -stat(POCUS); -EXPECT --T on closed filehandle STDIN at - line 4. -stat() on closed filehandle STDIN at - line 5. --T on unopened filehandle HOCUS at - line 6. -stat() on unopened filehandle POCUS at - line 7. -######## -# 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' ; -if ($^O eq 'dos') { - print <<EOM ; -SKIPPED -# skipped on dos -EOM - exit ; -} -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 F opened only for output at - line 12. diff --git a/contrib/perl5/t/pragma/warn/regcomp b/contrib/perl5/t/pragma/warn/regcomp deleted file mode 100644 index 8b86b50..0000000 --- a/contrib/perl5/t/pragma/warn/regcomp +++ /dev/null @@ -1,167 +0,0 @@ - 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 [%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 before HERE mark in regex m/(?=a)* << HERE / at - line 4. -######## -# regcomp.c [S_study_chunk] -use warnings 'regexp' ; -$_ = "" ; -/(?=a)?/; -no warnings 'regexp' ; -/(?=a)?/; -EXPECT -Quantifier unexpected on zero-length expression before HERE mark in regex m/(?=a)? << HERE / at - line 4. -######## -# regcomp.c [S_regatom] -$x = '\m' ; -use warnings 'regexp' ; -$a =~ /a$x/ ; -no warnings 'regexp' ; -$a =~ /a$x/ ; -EXPECT -Unrecognized escape \m passed through before HERE mark in regex m/a\m << HERE / at - line 4. -######## -# regcomp.c [S_regpposixcc S_checkposixcc] -# -use warnings 'regexp' ; -$_ = "" ; -/[:alpha:]/; -/[:zog:]/; -/[[:zog:]]/; -no warnings 'regexp' ; -/[:alpha:]/; -/[:zog:]/; -/[[:zog:]]/; -EXPECT -POSIX syntax [: :] belongs inside character classes before HERE mark in regex m/[:alpha:] << HERE / at - line 5. -POSIX syntax [: :] belongs inside character classes before HERE mark in regex m/[:zog:] << HERE / at - line 6. -POSIX class [:zog:] unknown before HERE mark in regex m/[[:zog:] << HERE ]/ -######## -# regcomp.c [S_checkposixcc] -# -use warnings 'regexp' ; -$_ = "" ; -/[.zog.]/; -no warnings 'regexp' ; -/[.zog.]/; -EXPECT -POSIX syntax [. .] belongs inside character classes before HERE mark in regex m/[.zog.] << HERE / at - line 5. -POSIX syntax [. .] is reserved for future extensions before HERE mark in regex m/[.zog.] << HERE / -######## -# regcomp.c [S_checkposixcc] -# -use warnings 'regexp' ; -$_ = "" ; -/[[.zog.]]/; -no warnings 'regexp' ; -/[[.zog.]]/; -EXPECT -POSIX syntax [. .] is reserved for future extensions before HERE mark in regex m/[[.zog.] << HERE ]/ -######## -# 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 -False [] range "a-\d" before HERE mark in regex m/[a-\d << HERE ]/ at - line 5. -False [] range "\d-" before HERE mark in regex m/[\d- << HERE b]/ at - line 6. -False [] range "\s-" before HERE mark in regex m/[\s- << HERE \d]/ at - line 7. -False [] range "\d-" before HERE mark in regex m/[\d- << HERE \s]/ at - line 8. -False [] range "a-[:digit:]" before HERE mark in regex m/[a-[:digit:] << HERE ]/ at - line 9. -False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE b]/ at - line 10. -False [] range "[:alpha:]-" before HERE mark in regex m/[[:alpha:]- << HERE [:digit:]]/ at - line 11. -False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE [:alpha:]]/ 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 -False [] range "a-\d" before HERE mark in regex m/[a-\d << HERE ]/ at - line 12. -False [] range "\d-" before HERE mark in regex m/[\d- << HERE b]/ at - line 13. -False [] range "\s-" before HERE mark in regex m/[\s- << HERE \d]/ at - line 14. -False [] range "\d-" before HERE mark in regex m/[\d- << HERE \s]/ at - line 15. -False [] range "a-[:digit:]" before HERE mark in regex m/[a-[:digit:] << HERE ]/ at - line 16. -False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE b]/ at - line 17. -False [] range "[:alpha:]-" before HERE mark in regex m/[[:alpha:]- << HERE [:digit:]]/ at - line 18. -False [] range "[:digit:]-" before HERE mark in regex m/[[:digit:]- << HERE [:alpha:]]/ at - line 19. -######## -# regcomp.c [S_regclass S_regclassutf8] -use warnings 'regexp' ; -$a =~ /[a\zb]/ ; -no warnings 'regexp' ; -$a =~ /[a\zb]/ ; -EXPECT -Unrecognized escape \z in character class passed through before HERE mark in regex m/[a\z << HERE b]/ at - line 3. - diff --git a/contrib/perl5/t/pragma/warn/regexec b/contrib/perl5/t/pragma/warn/regexec deleted file mode 100644 index 73696df..0000000 --- a/contrib/perl5/t/pragma/warn/regexec +++ /dev/null @@ -1,119 +0,0 @@ - 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 deleted file mode 100644 index 7a4be20..0000000 --- a/contrib/perl5/t/pragma/warn/run +++ /dev/null @@ -1,8 +0,0 @@ - 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 deleted file mode 100644 index 2409589..0000000 --- a/contrib/perl5/t/pragma/warn/sv +++ /dev/null @@ -1,303 +0,0 @@ - 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 (.) or string 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 deleted file mode 100644 index fd6deed..0000000 --- a/contrib/perl5/t/pragma/warn/taint +++ /dev/null @@ -1,49 +0,0 @@ - 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 deleted file mode 100644 index fa71329..0000000 --- a/contrib/perl5/t/pragma/warn/toke +++ /dev/null @@ -1,587 +0,0 @@ -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 -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 3. -Reversed -= operator at - line 4. -Reversed *= operator at - line 5. -Reversed %= operator at - line 6. -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. -syntax error at - line 8, near "=." -syntax error at - line 9, near "=^" -syntax error at - line 10, near "=|" -Unterminated <> operator at - line 11. -######## -# toke.c -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 8, near "=." -syntax error at - line 9, near "=^" -syntax error at - line 10, near "=|" -Unterminated <> operator at - line 11. -######## -# 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; -$a = { def - -=> 1 }; -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" -warn "yelp"; -{ - $_ = " \x{123} " ; -} -EOE -EXPECT -yelp at foo line 30. -######## -# 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. -######## -# toke.c -use warnings 'ambiguous'; -"@mjd_previously_unused_array"; -no warnings 'ambiguous'; -"@mjd_previously_unused_array"; -EXPECT -Possible unintended interpolation of @mjd_previously_unused_array in string at - line 3. diff --git a/contrib/perl5/t/pragma/warn/universal b/contrib/perl5/t/pragma/warn/universal deleted file mode 100644 index 6dbb1be..0000000 --- a/contrib/perl5/t/pragma/warn/universal +++ /dev/null @@ -1,16 +0,0 @@ - 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 deleted file mode 100644 index 9a7dbaf..0000000 --- a/contrib/perl5/t/pragma/warn/utf8 +++ /dev/null @@ -1,35 +0,0 @@ - - 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 -BEGIN { - if (ord('A') == 193) { - print "SKIPPED\n# ebcdic platforms do not generate Malformed UTF-8 warnings."; - exit 0; - } -} -use utf8 ; -my $a = "snstorm" ; -{ - no warnings 'utf8' ; - my $a = "snstorm"; - use warnings 'utf8' ; - my $a = "snstorm"; -} -EXPECT -Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 9. -Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 14. -######## diff --git a/contrib/perl5/t/pragma/warn/util b/contrib/perl5/t/pragma/warn/util deleted file mode 100644 index e82d6a6..0000000 --- a/contrib/perl5/t/pragma/warn/util +++ /dev/null @@ -1,108 +0,0 @@ - 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 deleted file mode 100755 index 66b4ff9..0000000 --- a/contrib/perl5/t/pragma/warnings.t +++ /dev/null @@ -1,119 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @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|,v)$/; - - 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 $_ } -} |
