home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / pragma / subs.t < prev    next >
Text File  |  2000-02-29  |  3KB  |  136 lines
  1. #!./perl 
  2.  
  3. BEGIN {
  4.     chdir 't' if -d 't';
  5.     unshift @INC, '../lib';
  6.     $ENV{PERL5LIB} = '../lib';
  7. }
  8.  
  9. $| = 1;
  10. undef $/;
  11. my @prgs = split "\n########\n", <DATA>;
  12. print "1..", scalar @prgs, "\n";
  13.  
  14. my $Is_VMS = $^O eq 'VMS';
  15. my $Is_MSWin32 = $^O eq 'MSWin32';
  16. my $tmpfile = "tmp0000";
  17. my $i = 0 ;
  18. 1 while -f ++$tmpfile;
  19. END {  if ($tmpfile) { 1 while unlink $tmpfile} }
  20.  
  21. for (@prgs){
  22.     my $switch = "";
  23.     my @temps = () ;
  24.     if (s/^\s*-\w+//){
  25.         $switch = $&;
  26.     }
  27.     my($prog,$expected) = split(/\nEXPECT\n/, $_);
  28.     if ( $prog =~ /--FILE--/) {
  29.         my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
  30.     shift @files ;
  31.     die "Internal error test $i didn't split into pairs, got " . 
  32.         scalar(@files) . "[" . join("%%%%", @files) ."]\n"
  33.         if @files % 2 ;
  34.     while (@files > 2) {
  35.         my $filename = shift @files ;
  36.         my $code = shift @files ;
  37.             push @temps, $filename ;
  38.         open F, ">$filename" or die "Cannot open $filename: $!\n" ;
  39.         print F $code ;
  40.         close F ;
  41.     }
  42.     shift @files ;
  43.     $prog = shift @files ;
  44.     }
  45.     open TEST, ">$tmpfile";
  46.     print TEST $prog,"\n";
  47.     close TEST;
  48.     my $results = $Is_VMS ?
  49.                   `./perl $switch $tmpfile 2>&1` :
  50.           $Is_MSWin32 ?
  51.                   `.\\perl -I../lib $switch $tmpfile 2>&1` :
  52.                   `./perl $switch $tmpfile 2>&1`;
  53.     my $status = $?;
  54.     $results =~ s/\n+$//;
  55.     # allow expected output to be written as if $prog is on STDIN
  56.     $results =~ s/tmp\d+/-/g;
  57.     $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS;  # clip off DCL status msg
  58. # bison says 'parse error' instead of 'syntax error',
  59. # various yaccs may or may not capitalize 'syntax'.
  60.     $results =~ s/^(syntax|parse) error/syntax error/mig;
  61.     $expected =~ s/\n+$//;
  62.     my $prefix = ($results =~ s/^PREFIX\n//) ;
  63.     if ( $results =~ s/^SKIPPED\n//) {
  64.     print "$results\n" ;
  65.     }
  66.     elsif (($prefix and $results !~ /^\Q$expected/) or
  67.        (!$prefix and $results ne $expected)){
  68.         print STDERR "PROG: $switch\n$prog\n";
  69.         print STDERR "EXPECTED:\n$expected\n";
  70.         print STDERR "GOT:\n$results\n";
  71.         print "not ";
  72.     }
  73.     print "ok ", ++$i, "\n";
  74.     foreach (@temps) 
  75.     { unlink $_ if $_ } 
  76. }
  77.  
  78. __END__
  79.  
  80. # Error - not predeclaring a sub
  81. Fred 1,2 ;
  82. sub Fred {}
  83. EXPECT
  84. Number found where operator expected at - line 3, near "Fred 1"
  85.     (Do you need to predeclare Fred?)
  86. syntax error at - line 3, near "Fred 1"
  87. Execution of - aborted due to compilation errors.
  88. ########
  89.  
  90. # Error - not predeclaring a sub in time
  91. Fred 1,2 ;
  92. use subs qw( Fred ) ;
  93. sub Fred {}
  94. EXPECT
  95. Number found where operator expected at - line 3, near "Fred 1"
  96.     (Do you need to predeclare Fred?)
  97. syntax error at - line 3, near "Fred 1"
  98. BEGIN not safe after errors--compilation aborted at - line 4.
  99. ########
  100.  
  101. # AOK
  102. use subs qw( Fred) ;
  103. Fred 1,2 ;
  104. sub Fred { print $_[0] + $_[1], "\n" }
  105. EXPECT
  106. 3
  107. ########
  108.  
  109. # override a built-in function
  110. use subs qw( open ) ;
  111. open 1,2 ;
  112. sub open { print $_[0] + $_[1], "\n" }
  113. EXPECT
  114. 3
  115. ########
  116.  
  117. --FILE-- abc
  118. Fred 1,2 ;
  119. 1;
  120. --FILE--
  121. use subs qw( Fred ) ;
  122. require "./abc" ;
  123. sub Fred { print $_[0] + $_[1], "\n" }
  124. EXPECT
  125. 3
  126. ########
  127.  
  128. # check that it isn't affected by block scope
  129. {
  130.     use subs qw( Fred ) ;
  131. }
  132. Fred 1, 2;
  133. sub Fred { print $_[0] + $_[1], "\n" }
  134. EXPECT
  135. 3
  136.