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