1use 5.008001; 2 3use strict; 4use warnings; 5use Test::More; 6use Text::Balanced qw ( extract_quotelike ); 7 8our $DEBUG; 9sub debug { print "\t>>>",@_ if $DEBUG } 10sub esc { my $x = shift||'<undef>'; $x =~ s/\n/\\n/gs; $x } 11 12## no critic (BuiltinFunctions::ProhibitStringyEval) 13 14my $cmd = "print"; 15my $neg = 0; 16my $str; 17while (defined($str = <DATA>)) 18{ 19 chomp $str; 20 if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } 21 elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } 22 elsif (!$str || $str =~ /\A#/) { $neg = 0; next } 23 my $setup_cmd = ($str =~ s/\A\{(.*)\}//) ? $1 : ''; 24 my $tests = 'sl'; 25 my $orig_str = $str; 26 $str =~ s/\\n/\n/g; 27 my $orig = $str; 28 29 eval $setup_cmd if $setup_cmd ne ''; 30 is $@, '', 'no error'; 31 if($tests =~ /l/) { 32 debug "\tUsing: $cmd\n"; 33 debug "\t on: [" . esc($setup_cmd) . "][" . esc($str) . "]\n"; 34 my @res; 35 eval qq{\@res = $cmd; }; 36 is $@, '', 'no error'; 37 debug "\t got:\n" . join "", map { "\t\t\t$_: [" . esc($res[$_]) . "]\n"} (0..$#res); 38 debug "\t left: [" . esc($str) . "]\n"; 39 debug "\t pos: [" . esc(substr($str,pos($str))) . "...]\n"; 40 ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list"); 41 } 42 43 eval $setup_cmd if $setup_cmd ne ''; 44 is $@, '', 'no error'; 45 if($tests =~ /s/) { 46 $str = $orig; 47 debug "\tUsing: scalar $cmd\n"; 48 debug "\t on: [" . esc($str) . "]\n"; 49 my $var = eval $cmd; 50 $var = "<undef>" unless defined $var; 51 debug "\t scalar got: [" . esc($var) . "]\n"; 52 debug "\t scalar left: [" . esc($str) . "]\n"; 53 ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar"); 54 } 55} 56 57# fails in Text::Balanced 1.95 58$_ = qq(s{}{}); 59my @z = extract_quotelike(); 60isnt $z[0], ''; 61 62@z = extract_quotelike("<<, 1; done()\nline1\nline2\n\n and next"); 63like $z[1], qr/\A,/, 'implied heredoc with ,' or do { 64 diag "error: '$@'\ngot: ", explain \@z; 65}; 66 67done_testing; 68 69__DATA__ 70 71# USING: extract_quotelike($str); 72''; 73""; 74"a"; 75'b'; 76`cc`; 77 78<<EOHERE; done();\nline1\nline2\nEOHERE\n; next; 79 <<EOHERE; done();\nline1\nline2\nEOHERE\n; next; 80<<"EOHERE"; done()\nline1\nline2\nEOHERE\n and next 81<<`EOHERE`; done()\nline1\nline2\nEOHERE\n and next 82<<'EOHERE'; done()\nline1\n'line2'\nEOHERE\n and next 83<<'EOHERE;'; done()\nline1\nline2\nEOHERE;\n and next 84<<" EOHERE"; done() \nline1\nline2\n EOHERE\nand next 85<<""; done()\nline1\nline2\n\n and next 86<<; done()\nline1\nline2\n\n and next 87# fails in Text::Balanced 1.95 88<<EOHERE;\nEOHERE\n; 89# fails in Text::Balanced 1.95 90<<"*";\n\n*\n; 91 92"this is a nested $var[$x] {"; 93/a/gci; 94m/a/gci; 95 96q(d); 97qq(e); 98qx(f); 99qr(g); 100qw(h i j); 101q{d}; 102qq{e}; 103qx{f}; 104qr{g}; 105qq{a nested { and } are okay as are () and <> pairs and escaped \}'s }; 106q/slash/; 107q # slash #; 108qr qw qx; 109 110s/x/y/; 111s/x/y/cgimsox; 112s{a}{b}; 113s{a}\n {b}; 114s(a){b}; 115s(a)/b/; 116s/'/\\'/g; 117tr/x/y/; 118y/x/y/; 119 120# fails on Text-Balanced-1.95 121{ $tests = 'l'; pos($str)=6 }012345<<E;\n\nE\n 122 123# THESE SHOULD FAIL 124s<$self->{pat}>{$self->{sub}}; # CAN'T HANDLE '>' in '->' 125s-$self->{pap}-$self->{sub}-; # CAN'T HANDLE '-' in '->' 126<<EOHERE; done();\nline1\nline2\nEOHERE;\n; next; # RDEL HAS NO ';' 127<<'EOHERE'; done();\nline1\nline2\nEOHERE;\n; next; # RDEF HAS NO ';' 128 << EOTHERE; done();\nline1\nline2\n EOTHERE\n; next; # RDEL IS "" (!) 129