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