1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 $ENV{PERL5LIB} = '../lib'; 7} 8 9$| = 1; 10 11my $Is_VMS = $^O eq 'VMS'; 12my $Is_MSWin32 = $^O eq 'MSWin32'; 13my $Is_NetWare = $^O eq 'NetWare'; 14my $tmpfile = "tmp0000"; 15my $i = 0 ; 161 while -e ++$tmpfile; 17END { if ($tmpfile) { 1 while unlink $tmpfile; } } 18 19my @prgs = () ; 20 21foreach (sort glob($^O eq 'MacOS' ? ":lib:strict:*" : "lib/strict/*")) { 22 23 next if -d || /(~|\.orig|,v)$/; 24 25 open F, "<$_" or die "Cannot open $_: $!\n" ; 26 while (<F>) { 27 last if /^__END__/ ; 28 } 29 30 { 31 local $/ = undef; 32 @prgs = (@prgs, split "\n########\n", <F>) ; 33 } 34 close F or die "Could not close: $!" ; 35} 36 37undef $/; 38 39print "1.." . (@prgs + 4) . "\n"; 40 41 42for (@prgs){ 43 my $switch = ""; 44 my @temps = () ; 45 if (s/^\s*-\w+//){ 46 $switch = $&; 47 } 48 my($prog,$expected) = split(/\nEXPECT\n/, $_); 49 if ( $prog =~ /--FILE--/) { 50 my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; 51 shift @files ; 52 die "Internal error test $i didn't split into pairs, got " . 53 scalar(@files) . "[" . join("%%%%", @files) ."]\n" 54 if @files % 2 ; 55 while (@files > 2) { 56 my $filename = shift @files ; 57 my $code = shift @files ; 58 $code =~ s|\./abc|:abc|g if $^O eq 'MacOS'; 59 push @temps, $filename ; 60 open F, ">$filename" or die "Cannot open $filename: $!\n" ; 61 print F $code ; 62 close F or die "Could not close: $!" ; 63 } 64 shift @files ; 65 $prog = shift @files ; 66 $prog =~ s|\./abc|:abc|g if $^O eq 'MacOS'; 67 } 68 open TEST, ">$tmpfile" or die "Could not open: $!"; 69 print TEST $prog,"\n"; 70 close TEST or die "Could not close: $!"; 71 my $results = $Is_MSWin32 ? 72 `.\\perl -I../lib $switch $tmpfile 2>&1` : 73 $^O eq 'NetWare' ? 74 `perl -I../lib $switch $tmpfile 2>&1` : 75 $^O eq 'MacOS' ? 76 `$^X -I::lib -MMac::err=unix $switch $tmpfile` : 77 `./perl $switch $tmpfile 2>&1`; 78 my $status = $?; 79 $results =~ s/\n+$//; 80 # allow expected output to be written as if $prog is on STDIN 81 $results =~ s/tmp\d+/-/g; 82 $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg 83 $expected =~ s/\n+$//; 84 $expected =~ s|(\./)?abc\.pm|:abc.pm|g if $^O eq 'MacOS'; 85 $expected =~ s|./abc|:abc|g if $^O eq 'MacOS'; 86 my $prefix = ($results =~ s/^PREFIX\n//) ; 87 if ( $results =~ s/^SKIPPED\n//) { 88 print "$results\n" ; 89 } 90 elsif (($prefix and $results !~ /^\Q$expected/) or 91 (!$prefix and $results ne $expected)){ 92 print STDERR "PROG: $switch\n$prog\n"; 93 print STDERR "EXPECTED:\n$expected\n"; 94 print STDERR "GOT:\n$results\n"; 95 print "not "; 96 } 97 print "ok " . ++$i . "\n"; 98 foreach (@temps) 99 { unlink $_ if $_ } 100} 101 102eval qq(use strict 'garbage'); 103print +($@ =~ /^Unknown 'strict' tag\(s\) 'garbage'/) 104 ? "ok ".++$i."\n" : "not ok ".++$i."\t# $@"; 105 106eval qq(no strict 'garbage'); 107print +($@ =~ /^Unknown 'strict' tag\(s\) 'garbage'/) 108 ? "ok ".++$i."\n" : "not ok ".++$i."\t# $@"; 109 110eval qq(use strict qw(foo bar)); 111print +($@ =~ /^Unknown 'strict' tag\(s\) 'foo bar'/) 112 ? "ok ".++$i."\n" : "not ok ".++$i."\t# $@"; 113 114eval qq(no strict qw(foo bar)); 115print +($@ =~ /^Unknown 'strict' tag\(s\) 'foo bar'/) 116 ? "ok ".++$i."\n" : "not ok ".++$i."\t# $@"; 117