Commit | Line | Data |
55a1c97c |
1 | #! /usr/local/bin/perl -ws |
3270c621 |
2 | # Before `make install' is performed this script should be runnable with |
3 | # `make test'. After `make install' it should work as `perl test.pl' |
4 | |
5 | ######################### We start with some black magic to print on failure. |
6 | |
7 | # Change 1..1 below to 1..last_test_to_print . |
8 | # (It may become useful if the test is moved to ./t subdirectory.) |
9 | |
aa10195b |
10 | BEGIN { $| = 1; print "1..95\n"; } |
3270c621 |
11 | END {print "not ok 1\n" unless $loaded;} |
12 | use Text::Balanced qw ( extract_quotelike ); |
13 | $loaded = 1; |
14 | print "ok 1\n"; |
15 | $count=2; |
16 | use vars qw( $DEBUG ); |
aa10195b |
17 | #$DEBUG=1; |
18 | sub debug { print "\t>>>",@_ if $ENV{DEBUG} } |
0c793b6f |
19 | sub esc { my $x = shift||'<undef>'; $x =~ s/\n/\\n/gs; $x } |
3270c621 |
20 | |
21 | ######################### End of black magic. |
22 | |
23 | |
24 | $cmd = "print"; |
25 | $neg = 0; |
26 | while (defined($str = <DATA>)) |
27 | { |
28 | chomp $str; |
aa10195b |
29 | if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } |
3270c621 |
30 | elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } |
aa10195b |
31 | elsif (!$str || $str =~ /\A#/) { $neg = 0; next } |
32 | my $setup_cmd = ($str =~ s/\A\{(.*)\}//) ? $1 : ''; |
33 | my $tests = 'sl'; |
3270c621 |
34 | $str =~ s/\\n/\n/g; |
35 | my $orig = $str; |
36 | |
aa10195b |
37 | eval $setup_cmd if $setup_cmd ne ''; |
38 | if($tests =~ /l/) { |
39 | debug "\tUsing: $cmd\n"; |
40 | debug "\t on: [" . esc($setup_cmd) . "][" . esc($str) . "]\n"; |
41 | my @res; |
42 | eval qq{\@res = $cmd; }; |
43 | debug "\t got:\n" . join "", map { "\t\t\t$_: [" . esc($res[$_]) . "]\n"} (0..$#res); |
44 | debug "\t left: [" . esc($str) . "]\n"; |
45 | debug "\t pos: [" . esc(substr($str,pos($str))) . "...]\n"; |
46 | print "not " if (substr($str,pos($str),1) eq ';')==$neg; |
47 | print "ok ", $count++; |
48 | print "\n"; |
49 | } |
50 | |
51 | eval $setup_cmd if $setup_cmd ne ''; |
52 | if($tests =~ /s/) { |
53 | $str = $orig; |
54 | debug "\tUsing: scalar $cmd\n"; |
55 | debug "\t on: [" . esc($str) . "]\n"; |
56 | $var = eval $cmd; |
57 | print " ($@)" if $@ && $DEBUG; |
58 | $var = "<undef>" unless defined $var; |
59 | debug "\t scalar got: [" . esc($var) . "]\n"; |
60 | debug "\t scalar left: [" . esc($str) . "]\n"; |
61 | print "not " if ($str =~ '\A;')==$neg; |
62 | print "ok ", $count++; |
63 | print "\n"; |
64 | } |
3270c621 |
65 | } |
66 | |
aa10195b |
67 | # fails in Text::Balanced 1.95 |
68 | $_ = qq(s{}{}); |
69 | my @z = extract_quotelike(); |
70 | print "not " if $z[0] eq ''; |
71 | print "ok ", $count++; |
72 | print "\n"; |
73 | |
74 | |
3270c621 |
75 | __DATA__ |
76 | |
77 | # USING: extract_quotelike($str); |
78 | ''; |
79 | ""; |
80 | "a"; |
81 | 'b'; |
82 | `cc`; |
83 | |
84 | |
85 | <<EOHERE; done();\nline1\nline2\nEOHERE\n; next; |
86 | <<EOHERE; done();\nline1\nline2\nEOHERE\n; next; |
87 | <<"EOHERE"; done()\nline1\nline2\nEOHERE\n and next |
aa10195b |
88 | <<`EOHERE`; done()\nline1\nline2\nEOHERE\n and next |
3270c621 |
89 | <<'EOHERE'; done()\nline1\n'line2'\nEOHERE\n and next |
90 | <<'EOHERE;'; done()\nline1\nline2\nEOHERE;\n and next |
91 | <<" EOHERE"; done() \nline1\nline2\n EOHERE\nand next |
92 | <<""; done()\nline1\nline2\n\n and next |
aa10195b |
93 | <<; done()\nline1\nline2\n\n and next |
94 | # fails in Text::Balanced 1.95 |
95 | <<EOHERE;\nEOHERE\n; |
96 | # fails in Text::Balanced 1.95 |
97 | <<"*";\n\n*\n; |
3270c621 |
98 | |
99 | "this is a nested $var[$x] {"; |
100 | /a/gci; |
101 | m/a/gci; |
102 | |
103 | q(d); |
104 | qq(e); |
105 | qx(f); |
106 | qr(g); |
107 | qw(h i j); |
108 | q{d}; |
109 | qq{e}; |
110 | qx{f}; |
111 | qr{g}; |
112 | qq{a nested { and } are okay as are () and <> pairs and escaped \}'s }; |
113 | q/slash/; |
114 | q # slash #; |
115 | qr qw qx; |
116 | |
117 | s/x/y/; |
118 | s/x/y/cgimsox; |
119 | s{a}{b}; |
120 | s{a}\n {b}; |
121 | s(a){b}; |
122 | s(a)/b/; |
123 | s/'/\\'/g; |
124 | tr/x/y/; |
125 | y/x/y/; |
126 | |
aa10195b |
127 | # fails on Text-Balanced-1.95 |
128 | { $tests = 'l'; pos($str)=6 }012345<<E;\n\nE\n |
129 | |
3270c621 |
130 | # THESE SHOULD FAIL |
131 | s<$self->{pat}>{$self->{sub}}; # CAN'T HANDLE '>' in '->' |
132 | s-$self->{pap}-$self->{sub}-; # CAN'T HANDLE '-' in '->' |
133 | <<EOHERE; done();\nline1\nline2\nEOHERE;\n; next; # RDEL HAS NO ';' |
134 | <<'EOHERE'; done();\nline1\nline2\nEOHERE;\n; next; # RDEF HAS NO ';' |
135 | << EOTHERE; done();\nline1\nline2\n EOTHERE\n; next; # RDEL IS "" (!) |