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..95\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 $ENV{DEBUG} }
  26 sub esc   { my $x = shift||'<undef>'; $x =~ s/\n/\\n/gs; $x }
  27
  28 ######################### End of black magic.
  29
  30
  31 $cmd = "print";
  32 $neg = 0;
  33 while (defined($str = <DATA>))
  34 {
  35         chomp $str;
  36         if ($str =~ s/\A# USING://)                 { $neg = 0; $cmd = $str; next; }
  37         elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
  38         elsif (!$str || $str =~ /\A#/)              { $neg = 0; next }
  39         my $setup_cmd = ($str =~ s/\A\{(.*)\}//) ? $1 : '';
  40         my $tests = 'sl';
  41         $str =~ s/\\n/\n/g;
  42         my $orig = $str;
  43
  44         eval $setup_cmd if $setup_cmd ne '';
  45         if($tests =~ /l/) {
  46                 debug "\tUsing: $cmd\n";
  47                 debug "\t   on: [" . esc($setup_cmd) . "][" . esc($str) . "]\n";
  48                 my @res;
  49                 eval qq{\@res = $cmd; };
  50                 debug "\t  got:\n" . join "", map { "\t\t\t$_: [" . esc($res[$_]) . "]\n"} (0..$#res);
  51                 debug "\t left: [" . esc($str) . "]\n";
  52                 debug "\t  pos: [" . esc(substr($str,pos($str))) . "...]\n";
  53                 print "not " if (substr($str,pos($str),1) eq ';')==$neg;
  54                 print "ok ", $count++;
  55                 print "\n";
  56         }
  57
  58         eval $setup_cmd if $setup_cmd ne '';
  59         if($tests =~ /s/) {
  60                 $str = $orig;
  61                 debug "\tUsing: scalar $cmd\n";
  62                 debug "\t   on: [" . esc($str) . "]\n";
  63                 $var = eval $cmd;
  64                 print " ($@)" if $@ && $DEBUG;
  65                 $var = "<undef>" unless defined $var;
  66                 debug "\t scalar got: [" . esc($var) . "]\n";
  67                 debug "\t scalar left: [" . esc($str) . "]\n";
  68                 print "not " if ($str =~ '\A;')==$neg;
  69                 print "ok ", $count++;
  70                 print "\n";
  71         }
  72 }
  73
  74 # fails in Text::Balanced 1.95
  75 $_ = qq(s{}{});
  76 my @z = extract_quotelike();
  77 print "not " if $z[0] eq '';
  78 print "ok ", $count++;
  79 print "\n";
  80
  81
  82 __DATA__
  83
  84 # USING: extract_quotelike($str);
  85 '';
  86 "";
  87 "a";
  88 'b';
  89 `cc`;
  90
  91
  92 <<EOHERE; done();\nline1\nline2\nEOHERE\n; next;
  93      <<EOHERE; done();\nline1\nline2\nEOHERE\n; next;
  94 <<"EOHERE"; done()\nline1\nline2\nEOHERE\n and next
  95 <<`EOHERE`; done()\nline1\nline2\nEOHERE\n and next
  96 <<'EOHERE'; done()\nline1\n'line2'\nEOHERE\n and next
  97 <<'EOHERE;'; done()\nline1\nline2\nEOHERE;\n and next
  98 <<"   EOHERE"; done() \nline1\nline2\n   EOHERE\nand next
  99 <<""; done()\nline1\nline2\n\n and next
 100 <<; done()\nline1\nline2\n\n and next
 101 # fails in Text::Balanced 1.95
 102 <<EOHERE;\nEOHERE\n;
 103 # fails in Text::Balanced 1.95
 104 <<"*";\n\n*\n;
 105
 106 "this is a nested $var[$x] {";
 107 /a/gci;
 108 m/a/gci;
 109
 110 q(d);
 111 qq(e);
 112 qx(f);
 113 qr(g);
 114 qw(h i j);
 115 q{d};
 116 qq{e};
 117 qx{f};
 118 qr{g};
 119 qq{a nested { and } are okay as are () and <> pairs and escaped \}'s };
 120 q/slash/;
 121 q # slash #;
 122 qr qw qx;
 123
 124 s/x/y/;
 125 s/x/y/cgimsox;
 126 s{a}{b};
 127 s{a}\n {b};
 128 s(a){b};
 129 s(a)/b/;
 130 s/'/\\'/g;
 131 tr/x/y/;
 132 y/x/y/;
 133
 134 # fails on Text-Balanced-1.95
 135 { $tests = 'l'; pos($str)=6 }012345<<E;\n\nE\n
 136
 137 # THESE SHOULD FAIL
 138 s<$self->{pat}>{$self->{sub}};          # CAN'T HANDLE '>' in '->'
 139 s-$self->{pap}-$self->{sub}-;           # CAN'T HANDLE '-' in '->'
 140 <<EOHERE; done();\nline1\nline2\nEOHERE;\n; next;           # RDEL HAS NO ';'
 141 <<'EOHERE'; done();\nline1\nline2\nEOHERE;\n; next;         # RDEF HAS NO ';'
 142      <<    EOTHERE; done();\nline1\nline2\n    EOTHERE\n; next;  # RDEL IS "" (!)