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