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