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..183\n"; } 17END {print "not ok 1\n" unless $loaded;} 18use Text::Balanced qw ( extract_variable ); 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 list got: [" . join("|",@res) . "]\n"; 43 debug "\t list left: [$str]\n"; 44 print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; 45 print "ok ", $count++; 46 print " ($@)" if $@ && $DEBUG; 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_variable($str); 63# THESE SHOULD FAIL 64$a->; 65$a (1..3) { print $a }; 66 67# USING: extract_variable($str); 68$::obj; 69$obj->nextval; 70*var; 71*$var; 72*{var}; 73*{$var}; 74*var{cat}; 75\&var; 76\&mod::var; 77\&mod'var; 78$a; 79$_; 80$a[1]; 81$_[1]; 82$a{cat}; 83$_{cat}; 84$a->[1]; 85$a->{"cat"}[1]; 86@$listref; 87@{$listref}; 88$obj->nextval; 89$obj->_nextval; 90$obj->next_val_; 91@{$obj->nextval}; 92@{$obj->nextval($cat,$dog)->{new}}; 93@{$obj->nextval($cat?$dog:$fish)->{new}}; 94@{$obj->nextval(cat()?$dog:$fish)->{new}}; 95$ a {'cat'}; 96$a::b::c{d}->{$e->()}; 97$a'b'c'd{e}->{$e->()}; 98$a'b::c'd{e}->{$e->()}; 99$#_; 100$#array; 101$#{array}; 102$var[$#var]; 103$1; 104$11; 105$&; 106$`; 107$'; 108$+; 109$*; 110$.; 111$/; 112$|; 113$,; 114$"; 115$;; 116$#; 117$%; 118$=; 119$-; 120$~; 121$^; 122$:; 123$^L; 124$^A; 125$?; 126$!; 127$^E; 128$@; 129$$; 130$<; 131$>; 132$(; 133$); 134$[; 135$]; 136$^C; 137$^D; 138$^F; 139$^H; 140$^I; 141$^M; 142$^O; 143$^P; 144$^R; 145$^S; 146$^T; 147$^V; 148$^W; 149${^WARNING_BITS}; 150${^WIDE_SYSTEM_CALLS}; 151$^X; 152 153# THESE SHOULD FAIL 154$a->; 155@{$; 156$ a :: b :: c 157$ a ' b ' c 158 159# USING: extract_variable($str,'=*'); 160========$a; 161