cpan/Text-Balanced/t/06_extqlk.t

   1 #! /usr/local/bin/perl -ws
   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
  10 BEGIN { $| = 1; print "1..95\n"; }
  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 );
  17 #$DEBUG=1;
  18 sub debug { print "\t>>>",@_ if $ENV{DEBUG} }
  19 sub esc   { my $x = shift||'<undef>'; $x =~ s/\n/\\n/gs; $x }
  20
  21 ######################### End of black magic.
  22
  23
  24 $cmd = "print";
  25 $neg = 0;
  26 while (defined($str = <DATA>))
  27 {
  28         chomp $str;
  29         if ($str =~ s/\A# USING://)                 { $neg = 0; $cmd = $str; next; }
  30         elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
  31         elsif (!$str || $str =~ /\A#/)              { $neg = 0; next }
  32         my $setup_cmd = ($str =~ s/\A\{(.*)\}//) ? $1 : '';
  33         my $tests = 'sl';
  34         $str =~ s/\\n/\n/g;
  35         my $orig = $str;
  36
  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         }
  65 }
  66
  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
  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
  88 <<`EOHERE`; done()\nline1\nline2\nEOHERE\n and next
  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
  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;
  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
 127 # fails on Text-Balanced-1.95
 128 { $tests = 'l'; pos($str)=6 }012345<<E;\n\nE\n
 129
 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 "" (!)