lib/Text/Balanced/t/extcbk.t

   1 BEGIN {
   2     if ($ENV{PERL_CORE}) {
   3         chdir('t') if -d 't';
   4         @INC = qw(../lib);
   5     }
   6 }
   7
   8 # Before `make install' is performed this script should be runnable with
   9 # `make test'. After `make install' it should work as `perl test.pl'
  10
  11 ######################### We start with some black magic to print on failure.
  12
  13 # Change 1..1 below to 1..last_test_to_print .
  14 # (It may become useful if the test is moved to ./t subdirectory.)
  15
  16 BEGIN { $| = 1; print "1..41\n"; }
  17 END {print "not ok 1\n" unless $loaded;}
  18 use Text::Balanced qw ( extract_codeblock );
  19 $loaded = 1;
  20 print "ok 1\n";
  21 $count=2;
  22 use vars qw( $DEBUG );
  23 sub debug { print "\t>>>",@_ if $DEBUG }
  24
  25 ######################### End of black magic.
  26
  27
  28 $cmd = "print";
  29 $neg = 0;
  30 while (defined($str = <DATA>))
  31 {
  32         chomp $str;
  33         if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
  34         elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
  35         elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
  36         $str =~ s/\\n/\n/g;
  37         debug "\tUsing: $cmd\n";
  38         debug "\t   on: [$str]\n";
  39
  40         my @res;
  41         $var = eval "\@res = $cmd";
  42         debug "\t   Failed: $@ at " . $@+0 .")" if $@;
  43         debug "\t list got: [" . join("|", map {defined $_ ? $_ : '<undef>'} @res) . "]\n";
  44         debug "\t list left: [$str]\n";
  45         print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
  46         print "ok ", $count++;
  47         print "\n";
  48
  49         pos $str = 0;
  50         $var = eval $cmd;
  51         $var = "<undef>" unless defined $var;
  52         debug "\t scalar got: [$var]\n";
  53         debug "\t scalar left: [$str]\n";
  54         print "not " if ($str =~ '\A;')==$neg;
  55         print "ok ", $count++;
  56         print " ($@)" if $@ && $DEBUG;
  57         print "\n";
  58 }
  59
  60 __DATA__
  61
  62 # USING: extract_codeblock($str,'(){}',undef,'()');
  63 (Foo(')'));
  64
  65 # USING: extract_codeblock($str);
  66 { $data[4] =~ /['"]/; };
  67
  68 # USING: extract_codeblock($str,'<>');
  69 < %x = ( try => "this") >;
  70 < %x = () >;
  71 < %x = ( $try->{this}, "too") >;
  72 < %'x = ( $try->{this}, "too") >;
  73 < %'x'y = ( $try->{this}, "too") >;
  74 < %::x::y = ( $try->{this}, "too") >;
  75
  76 # THIS SHOULD FAIL
  77 < %x = do { $try > 10 } >;
  78
  79 # USING: extract_codeblock($str);
  80
  81 { $a = /\}/; };
  82 { sub { $_[0] /= $_[1] } };  # / here
  83 { 1; };
  84 { $a = 1; };
  85
  86
  87 # USING: extract_codeblock($str,undef,'=*');
  88 ========{$a=1};
  89
  90 # USING: extract_codeblock($str,'{}<>');
  91 < %x = do { $try > 10 } >;
  92
  93 # USING: extract_codeblock($str,'{}',undef,'<>');
  94 < %x = do { $try > 10 } >;
  95
  96 # USING: extract_codeblock($str,'{}');
  97 { $a = $b; # what's this doing here? \n };'
  98 { $a = $b; \n $a =~ /$b/; \n @a = map /\s/ @b };
  99
 100 # THIS SHOULD FAIL
 101 { $a = $b; # what's this doing here? };'
 102 { $a = $b; # what's this doing here? ;'