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