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..19\n"; } 17END {print "not ok 1\n" unless $loaded;} 18use Text::Balanced qw ( extract_bracketed ); 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 $var = eval "() = $cmd"; 41 debug "\t list got: [$var]\n"; 42 debug "\t list left: [$str]\n"; 43 print "not " if (substr($str,pos($str),1) eq ';')==$neg; 44 print "ok ", $count++; 45 print " ($@)" if $@ && $DEBUG; 46 print "\n"; 47 48 pos $str = 0; 49 $var = eval $cmd; 50 $var = "<undef>" unless defined $var; 51 debug "\t scalar got: [$var]\n"; 52 debug "\t scalar left: [$str]\n"; 53 print "not " if ($str =~ '\A;')==$neg; 54 print "ok ", $count++; 55 print " ($@)" if $@ && $DEBUG; 56 print "\n"; 57} 58 59__DATA__ 60 61# USING: extract_bracketed($str); 62{a nested { and } are okay as are () and <> pairs and escaped \}'s }; 63{a nested\n{ and } are okay as are\n() and <> pairs and escaped \}'s }; 64 65# USING: extract_bracketed($str,'{}'); 66{a nested { and } are okay as are unbalanced ( and < pairs and escaped \}'s }; 67 68# THESE SHOULD FAIL 69{an unmatched nested { isn't okay, nor are ( and < }; 70{an unbalanced nested [ even with } and ] to match them; 71 72 73# USING: extract_bracketed($str,'<"`q>'); 74<a q{uoted} ">" unbalanced right bracket of /(q>)/ either sort (`>>>""">>>>`) is okay >; 75 76# USING: extract_bracketed($str,'<">'); 77<a quoted ">" unbalanced right bracket is okay >; 78 79# USING: extract_bracketed($str,'<"`>'); 80<a quoted ">" unbalanced right bracket of either sort (`>>>""">>>>`) is okay >; 81 82# THIS SHOULD FAIL 83<a misquoted '>' unbalanced right bracket is bad >; 84