1# Before `make install' is performed this script should be runnable with 2# `make test'. After `make install' it should work as `perl test.pl' 3 4use 5.008001; 5 6use strict; 7use warnings; 8 9######################### We start with some black magic to print on failure. 10 11# Change 1..1 below to 1..last_test_to_print . 12# (It may become useful if the test is moved to ./t subdirectory.) 13 14my $loaded = 0; 15BEGIN { $| = 1; print "1..41\n"; } 16END {print "not ok 1\n" unless $loaded;} 17use Text::Balanced qw ( extract_codeblock ); 18$loaded = 1; 19print "ok 1\n"; 20my $count=2; 21use vars qw( $DEBUG ); 22sub debug { print "\t>>>",@_ if $DEBUG } 23 24######################### End of black magic. 25 26## no critic (BuiltinFunctions::ProhibitStringyEval) 27 28my $cmd = "print"; 29my $neg = 0; 30my $str; 31while (defined($str = <DATA>)) 32{ 33 chomp $str; 34 if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } 35 elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } 36 elsif (!$str || $str =~ /\A#/) { $neg = 0; next } 37 $str =~ s/\\n/\n/g; 38 debug "\tUsing: $cmd\n"; 39 debug "\t on: [$str]\n"; 40 41 my @res; 42 my $var = eval "\@res = $cmd"; 43 debug "\t Failed: $@ at " . $@+0 .")" if $@; 44 debug "\t list got: [" . join("|", map {defined $_ ? $_ : '<undef>'} @res) . "]\n"; 45 debug "\t list left: [$str]\n"; 46 print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; 47 print "ok ", $count++; 48 print "\n"; 49 50 pos $str = 0; 51 $var = eval $cmd; 52 $var = "<undef>" unless defined $var; 53 debug "\t scalar got: [$var]\n"; 54 debug "\t scalar left: [$str]\n"; 55 print "not " if ($str =~ '\A;')==$neg; 56 print "ok ", $count++; 57 print " ($@)" if $@ && $DEBUG; 58 print "\n"; 59} 60 61__DATA__ 62 63# USING: extract_codeblock($str,'(){}',undef,'()'); 64(Foo(')')); 65 66# USING: extract_codeblock($str); 67{ $data[4] =~ /['"]/; }; 68 69# USING: extract_codeblock($str,'<>'); 70< %x = ( try => "this") >; 71< %x = () >; 72< %x = ( $try->{this}, "too") >; 73< %'x = ( $try->{this}, "too") >; 74< %'x'y = ( $try->{this}, "too") >; 75< %::x::y = ( $try->{this}, "too") >; 76 77# THIS SHOULD FAIL 78< %x = do { $try > 10 } >; 79 80# USING: extract_codeblock($str); 81 82{ $a = /\}/; }; 83{ sub { $_[0] /= $_[1] } }; # / here 84{ 1; }; 85{ $a = 1; }; 86 87 88# USING: extract_codeblock($str,undef,'=*'); 89========{$a=1}; 90 91# USING: extract_codeblock($str,'{}<>'); 92< %x = do { $try > 10 } >; 93 94# USING: extract_codeblock($str,'{}',undef,'<>'); 95< %x = do { $try > 10 } >; 96 97# USING: extract_codeblock($str,'{}'); 98{ $a = $b; # what's this doing here? \n };' 99{ $a = $b; \n $a =~ /$b/; \n @a = map /\s/ @b }; 100 101# THIS SHOULD FAIL 102{ $a = $b; # what's this doing here? };' 103{ $a = $b; # what's this doing here? ;' 104