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