This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Text-Balanced-1.98
[perl5.git] / lib / Text / Balanced / t / gentag.t
1 BEGIN {
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
16 BEGIN { $| = 1; print "1..37\n"; }
17 END {print "not ok 1\n" unless $loaded;}
18 use Text::Balanced qw ( gen_extract_tagged );
19 $loaded = 1;
20 print "ok 1\n";
21 $count=2;
22 use vars qw( $DEBUG );
23 sub debug { print "\t>>>",@_ if $DEBUG }
24
25 ######################### End of black magic.
26
27
28 $cmd = "print";
29 $neg = 0;
30 while (defined($str = <DATA>))
31 {
32         chomp $str;
33         $str =~ s/\\n/\n/g;
34         if ($str =~ s/\A# USING://)
35         {
36                 $neg = 0;
37                 eval{local$^W;*f = eval $str || die};
38                 next;
39         }
40         elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
41         elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
42         $str =~ s/\\n/\n/g;
43         debug "\tUsing: $cmd\n";
44         debug "\t   on: [$str]\n";
45
46         my @res;
47         $var = eval { @res = f($str) };
48         debug "\t list got: [" . join("|",map {defined $_ ? $_ : '<undef>'} @res) . "]\n";
49         debug "\t list left: [$str]\n";
50         print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
51         print "ok ", $count++;
52         print " ($@)" if $@ && $DEBUG;
53         print "\n";
54
55         pos $str = 0;
56         $var = eval { scalar f($str) };
57         $var = "<undef>" unless defined $var;
58         debug "\t scalar got: [$var]\n";
59         debug "\t scalar left: [$str]\n";
60         print "not " if ($str =~ '\A;')==$neg;
61         print "ok ", $count++;
62         print " ($@)" if $@ && $DEBUG;
63         print "\n";
64 }
65
66 __DATA__
67
68 # USING: gen_extract_tagged('{','}');
69         { a test };
70
71 # USING: gen_extract_tagged(qr/<[A-Z]+>/,undef, undef, {ignore=>["<BR>"]});
72         <A>aaa<B>bbb<BR>ccc</B>ddd</A>;
73
74 # USING: gen_extract_tagged("BEGIN","END");
75         BEGIN at the BEGIN keyword and END at the END;
76         BEGIN at the beginning and end at the END;
77
78 # USING: gen_extract_tagged(undef,undef,undef,{ignore=>["<[^>]*/>"]});
79         <A>aaa<B>bbb<BR/>ccc</B>ddd</A>;
80
81 # USING: gen_extract_tagged(";","-",undef,{reject=>[";"],fail=>"MAX"});
82         ; at the ;-) keyword
83
84 # USING: gen_extract_tagged("<[A-Z]+>",undef, undef, {ignore=>["<BR>"]});
85         <A>aaa<B>bbb<BR>ccc</B>ddd</A>;
86
87 # THESE SHOULD FAIL
88         BEGIN at the beginning and end at the end;
89         BEGIN at the BEGIN keyword and END at the end;
90
91 # TEST EXTRACTION OF TAGGED STRINGS
92 # USING: gen_extract_tagged("BEGIN","END",undef,{reject=>["BEGIN","END"]});
93 # THESE SHOULD FAIL
94         BEGIN at the BEGIN keyword and END at the end;
95
96 # USING: gen_extract_tagged(";","-",undef,{reject=>[";"],fail=>"PARA"});
97         ; at the ;-) keyword
98
99
100 # USING: gen_extract_tagged();
101         <A>some text</A>;
102         <B>some text<A>other text</A></B>;
103         <A>some text<A>other text</A></A>;
104         <A HREF="#section2">some text</A>;
105
106 # THESE SHOULD FAIL
107         <A>some text
108         <A>some text<A>other text</A>;
109         <B>some text<A>other text</B>;