diff options
Diffstat (limited to 'lib/Text')
-rw-r--r-- | lib/Text/Balanced/t/genxt.t | 104 | ||||
-rw-r--r-- | lib/Text/Balanced/t/xbrak.t | 81 | ||||
-rw-r--r-- | lib/Text/Balanced/t/xcode.t | 94 | ||||
-rw-r--r-- | lib/Text/Balanced/t/xdeli.t | 95 | ||||
-rw-r--r-- | lib/Text/Balanced/t/xmult.t | 316 | ||||
-rw-r--r-- | lib/Text/Balanced/t/xquot.t | 118 | ||||
-rw-r--r-- | lib/Text/Balanced/t/xtagg.t | 118 | ||||
-rw-r--r-- | lib/Text/Balanced/t/xvari.t | 107 | ||||
-rwxr-xr-x | lib/Text/ParseWords.t | 110 | ||||
-rwxr-xr-x | lib/Text/Soundex.t | 143 | ||||
-rwxr-xr-x | lib/Text/Tabs.t | 141 | ||||
-rwxr-xr-x | lib/Text/Wrap/fill.t | 98 | ||||
-rwxr-xr-x | lib/Text/Wrap/wrap.t | 209 |
13 files changed, 1734 insertions, 0 deletions
diff --git a/lib/Text/Balanced/t/genxt.t b/lib/Text/Balanced/t/genxt.t new file mode 100644 index 0000000000..6889653841 --- /dev/null +++ b/lib/Text/Balanced/t/genxt.t @@ -0,0 +1,104 @@ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..35\n"; } +END {print "not ok 1\n" unless $loaded;} +use Text::Balanced qw ( gen_extract_tagged ); +$loaded = 1; +print "ok 1\n"; +$count=2; +use vars qw( $DEBUG ); +sub debug { print "\t>>>",@_ if $DEBUG } + +######################### End of black magic. + + +$cmd = "print"; +$neg = 0; +while (defined($str = <DATA>)) +{ + chomp $str; + $str =~ s/\\n/\n/g; + if ($str =~ s/\A# USING://) + { + $neg = 0; + eval{local$^W;*f = eval $str || die}; + next; + } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; + + my @res; + $var = eval { @res = f($str) }; + debug "\t list got: [" . join("|",@res) . "]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; + + pos $str = 0; + $var = eval { scalar f($str) }; + $var = "<undef>" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; +} + +__DATA__ + +# USING: gen_extract_tagged(qr/<[A-Z]+>/,undef, undef, {ignore=>["<BR>"]}); + <A>aaa<B>bbb<BR>ccc</B>ddd</A>; + +# USING: gen_extract_tagged("BEGIN","END"); + BEGIN at the BEGIN keyword and END at the END; + BEGIN at the beginning and end at the END; + +# USING: gen_extract_tagged(undef,undef,undef,{ignore=>["<[^>]*/>"]}); + <A>aaa<B>bbb<BR/>ccc</B>ddd</A>; + +# USING: gen_extract_tagged(";","-",undef,{reject=>[";"],fail=>"MAX"}); + ; at the ;-) keyword + +# USING: gen_extract_tagged("<[A-Z]+>",undef, undef, {ignore=>["<BR>"]}); + <A>aaa<B>bbb<BR>ccc</B>ddd</A>; + +# THESE SHOULD FAIL + BEGIN at the beginning and end at the end; + BEGIN at the BEGIN keyword and END at the end; + +# TEST EXTRACTION OF TAGGED STRINGS +# USING: gen_extract_tagged("BEGIN","END",undef,{reject=>["BEGIN","END"]}); +# THESE SHOULD FAIL + BEGIN at the BEGIN keyword and END at the end; + +# USING: gen_extract_tagged(";","-",undef,{reject=>[";"],fail=>"PARA"}); + ; at the ;-) keyword + + +# USING: gen_extract_tagged(); + <A>some text</A>; + <B>some text<A>other text</A></B>; + <A>some text<A>other text</A></A>; + <A HREF="#section2">some text</A>; + +# THESE SHOULD FAIL + <A>some text + <A>some text<A>other text</A>; + <B>some text<A>other text</B>; diff --git a/lib/Text/Balanced/t/xbrak.t b/lib/Text/Balanced/t/xbrak.t new file mode 100644 index 0000000000..5a8e5249a8 --- /dev/null +++ b/lib/Text/Balanced/t/xbrak.t @@ -0,0 +1,81 @@ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..19\n"; } +END {print "not ok 1\n" unless $loaded;} +use Text::Balanced qw ( extract_bracketed ); +$loaded = 1; +print "ok 1\n"; +$count=2; +use vars qw( $DEBUG ); +sub debug { print "\t>>>",@_ if $DEBUG } + +######################### End of black magic. + + +$cmd = "print"; +$neg = 0; +while (defined($str = <DATA>)) +{ + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; + + $var = eval "() = $cmd"; + debug "\t list got: [$var]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str),1) eq ';')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; + + pos $str = 0; + $var = eval $cmd; + $var = "<undef>" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; +} + +__DATA__ + +# USING: extract_bracketed($str); +{a nested { and } are okay as are () and <> pairs and escaped \}'s }; +{a nested\n{ and } are okay as are\n() and <> pairs and escaped \}'s }; + +# USING: extract_bracketed($str,'{}'); +{a nested { and } are okay as are unbalanced ( and < pairs and escaped \}'s }; + +# THESE SHOULD FAIL +{an unmatched nested { isn't okay, nor are ( and < }; +{an unbalanced nested [ even with } and ] to match them; + + +# USING: extract_bracketed($str,'<"`q>'); +<a q{uoted} ">" unbalanced right bracket of /(q>)/ either sort (`>>>""">>>>`) is okay >; + +# USING: extract_bracketed($str,'<">'); +<a quoted ">" unbalanced right bracket is okay >; + +# USING: extract_bracketed($str,'<"`>'); +<a quoted ">" unbalanced right bracket of either sort (`>>>""">>>>`) is okay >; + +# THIS SHOULD FAIL +<a misquoted '>' unbalanced right bracket is bad >; diff --git a/lib/Text/Balanced/t/xcode.t b/lib/Text/Balanced/t/xcode.t new file mode 100644 index 0000000000..00be51e542 --- /dev/null +++ b/lib/Text/Balanced/t/xcode.t @@ -0,0 +1,94 @@ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..37\n"; } +END {print "not ok 1\n" unless $loaded;} +use Text::Balanced qw ( extract_codeblock ); +$loaded = 1; +print "ok 1\n"; +$count=2; +use vars qw( $DEBUG ); +sub debug { print "\t>>>",@_ if $DEBUG } + +######################### End of black magic. + + +$cmd = "print"; +$neg = 0; +while (defined($str = <DATA>)) +{ + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; + + my @res; + $var = eval "\@res = $cmd"; + debug "\t Failed: $@ at " . $@+0 .")" if $@; + debug "\t list got: [" . join("|",@res) . "]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; + print "ok ", $count++; + print "\n"; + + pos $str = 0; + $var = eval $cmd; + $var = "<undef>" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; +} + +__DATA__ + +# USING: extract_codeblock($str,'<>'); +< %x = ( try => "this") >; +< %x = () >; +< %x = ( $try->{this}, "too") >; +< %'x = ( $try->{this}, "too") >; +< %'x'y = ( $try->{this}, "too") >; +< %::x::y = ( $try->{this}, "too") >; + +# THIS SHOULD FAIL +< %x = do { $try > 10 } >; + +# USING: extract_codeblock($str); + +{ $a = /\}/; }; +{ sub { $_[0] /= $_[1] } }; # / here +{ 1; }; +{ $a = 1; }; + + +# USING: extract_codeblock($str,undef,'=*'); +========{$a=1}; + +# USING: extract_codeblock($str,'{}<>'); +< %x = do { $try > 10 } >; + +# USING: extract_codeblock($str,'{}',undef,'<>'); +< %x = do { $try > 10 } >; + +# USING: extract_codeblock($str,'{}'); +{ $a = $b; # what's this doing here? \n };' +{ $a = $b; \n $a =~ /$b/; \n @a = map /\s/ @b }; + +# THIS SHOULD FAIL +{ $a = $b; # what's this doing here? };' +{ $a = $b; # what's this doing here? ;' diff --git a/lib/Text/Balanced/t/xdeli.t b/lib/Text/Balanced/t/xdeli.t new file mode 100644 index 0000000000..7e5b06beca --- /dev/null +++ b/lib/Text/Balanced/t/xdeli.t @@ -0,0 +1,95 @@ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..45\n"; } +END {print "not ok 1\n" unless $loaded;} +use Text::Balanced qw ( extract_delimited ); +$loaded = 1; +print "ok 1\n"; +$count=2; +use vars qw( $DEBUG ); +sub debug { print "\t>>>",@_ if $DEBUG } + +######################### End of black magic. + + +$cmd = "print"; +$neg = 0; +while (defined($str = <DATA>)) +{ + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; + + $var = eval "() = $cmd"; + debug "\t list got: [$var]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; + + pos $str = 0; + $var = eval $cmd; + $var = "<undef>" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; +} + +__DATA__ +# USING: extract_delimited($str,'/#$',undef,'/#$'); +/a/; +/a///; +#b#; +#b###; +$c$; +$c$$$; + +# TEST EXTRACTION OF DELIMITED TEXT WITH ESCAPES +# USING: extract_delimited($str,'/#$',undef,'\\'); +/a/; +/a\//; +#b#; +#b\##; +$c$; +$c\$$; + +# TEST EXTRACTION OF DELIMITED TEXT +# USING: extract_delimited($str); +'a'; +"b"; +`c`; +'a\''; +'a\\'; +'\\a'; +"a\\"; +"\\a"; +"b\'\"\'"; +`c '\`abc\`'`; + +# TEST EXTRACTION OF DELIMITED TEXT +# USING: extract_delimited($str,'/#$','-->'); +-->/a/; +-->#b#; +-->$c$; + +# THIS SHOULD FAIL +$c$; diff --git a/lib/Text/Balanced/t/xmult.t b/lib/Text/Balanced/t/xmult.t new file mode 100644 index 0000000000..31dd7d4051 --- /dev/null +++ b/lib/Text/Balanced/t/xmult.t @@ -0,0 +1,316 @@ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..85\n"; } +END {print "not ok 1\n" unless $loaded;} +use Text::Balanced qw ( :ALL ); +$loaded = 1; +print "ok 1\n"; +$count=2; +use vars qw( $DEBUG ); +sub debug { print "\t>>>",@_ if $DEBUG } + +######################### End of black magic. + +sub expect +{ + local $^W; + my ($l1, $l2) = @_; + + if (@$l1 != @$l2) + { + print "\@l1: ", join(", ", @$l1), "\n"; + print "\@l2: ", join(", ", @$l2), "\n"; + print "not "; + } + else + { + for (my $i = 0; $i < @$l1; $i++) + { + if ($l1->[$i] ne $l2->[$i]) + { + print "field $i: '$l1->[$i]' ne '$l2->[$i]'\n"; + print "not "; + last; + } + } + } + + print "ok $count\n"; + $count++; +} + +sub divide +{ + my ($text, @index) = @_; + my @bits = (); + unshift @index, 0; + push @index, length($text); + for ( my $i= 0; $i < $#index; $i++) + { + push @bits, substr($text, $index[$i], $index[$i+1]-$index[$i]); + } + pop @bits; + return @bits; + +} + + +$stdtext1 = q{$var = do {"val" && $val;};}; + +# TESTS 2-4 +$text = $stdtext1; +expect [ extract_multiple($text,undef,1) ], + [ divide $stdtext1 => 4 ]; + +expect [ pos $text], [ 4 ]; +expect [ $text ], [ $stdtext1 ]; + +# TESTS 5-7 +$text = $stdtext1; +expect [ scalar extract_multiple($text,undef,1) ], + [ divide $stdtext1 => 4 ]; + +expect [ pos $text], [ 0 ]; +expect [ $text ], [ substr($stdtext1,4) ]; + + +# TESTS 8-10 +$text = $stdtext1; +expect [ extract_multiple($text,undef,2) ], + [ divide($stdtext1 => 4, 10) ]; + +expect [ pos $text], [ 10 ]; +expect [ $text ], [ $stdtext1 ]; + +# TESTS 11-13 +$text = $stdtext1; +expect [ eval{local$^W;scalar extract_multiple($text,undef,2)} ], + [ substr($stdtext1,0,4) ]; + +expect [ pos $text], [ 0 ]; +expect [ $text ], [ substr($stdtext1,4) ]; + + +# TESTS 14-16 +$text = $stdtext1; +expect [ extract_multiple($text,undef,3) ], + [ divide($stdtext1 => 4, 10, 26) ]; + +expect [ pos $text], [ 26 ]; +expect [ $text ], [ $stdtext1 ]; + +# TESTS 17-19 +$text = $stdtext1; +expect [ eval{local$^W;scalar extract_multiple($text,undef,3)} ], + [ substr($stdtext1,0,4) ]; + +expect [ pos $text], [ 0 ]; +expect [ $text ], [ substr($stdtext1,4) ]; + + +# TESTS 20-22 +$text = $stdtext1; +expect [ extract_multiple($text,undef,4) ], + [ divide($stdtext1 => 4, 10, 26, 27) ]; + +expect [ pos $text], [ 27 ]; +expect [ $text ], [ $stdtext1 ]; + +# TESTS 23-25 +$text = $stdtext1; +expect [ eval{local$^W;scalar extract_multiple($text,undef,4)} ], + [ substr($stdtext1,0,4) ]; + +expect [ pos $text], [ 0 ]; +expect [ $text ], [ substr($stdtext1,4) ]; + + +# TESTS 26-28 +$text = $stdtext1; +expect [ extract_multiple($text,undef,5) ], + [ divide($stdtext1 => 4, 10, 26, 27) ]; + +expect [ pos $text], [ 27 ]; +expect [ $text ], [ $stdtext1 ]; + + +# TESTS 29-31 +$text = $stdtext1; +expect [ eval{local$^W;scalar extract_multiple($text,undef,5)} ], + [ substr($stdtext1,0,4) ]; + +expect [ pos $text], [ 0 ]; +expect [ $text ], [ substr($stdtext1,4) ]; + + + +# TESTS 32-34 +$stdtext2 = q{$var = "val" && (1,2,3);}; + +$text = $stdtext2; +expect [ extract_multiple($text) ], + [ divide($stdtext2 => 4, 7, 12, 24) ]; + +expect [ pos $text], [ 24 ]; +expect [ $text ], [ $stdtext2 ]; + +# TESTS 35-37 +$text = $stdtext2; +expect [ scalar extract_multiple($text) ], + [ substr($stdtext2,0,4) ]; + +expect [ pos $text], [ 0 ]; +expect [ $text ], [ substr($stdtext2,4) ]; + + +# TESTS 38-40 +$text = $stdtext2; +expect [ extract_multiple($text,[\&extract_bracketed]) ], + [ substr($stdtext2,0,15), substr($stdtext2,16,7), substr($stdtext2,23) ]; + +expect [ pos $text], [ 24 ]; +expect [ $text ], [ $stdtext2 ]; + +# TESTS 41-43 +$text = $stdtext2; +expect [ scalar extract_multiple($text,[\&extract_bracketed]) ], + [ substr($stdtext2,0,15) ]; + +expect [ pos $text], [ 0 ]; +expect [ $text ], [ substr($stdtext2,15) ]; + + +# TESTS 44-46 +$text = $stdtext2; +expect [ extract_multiple($text,[\&extract_variable]) ], + [ substr($stdtext2,0,4), substr($stdtext2,4) ]; + +expect [ pos $text], [ length($text) ]; +expect [ $text ], [ $stdtext2 ]; + +# TESTS 47-49 +$text = $stdtext2; +expect [ scalar extract_multiple($text,[\&extract_variable]) ], + [ substr($stdtext2,0,4) ]; + +expect [ pos $text], [ 0 ]; +expect [ $text ], [ substr($stdtext2,4) ]; + + +# TESTS 50-52 +$text = $stdtext2; +expect [ extract_multiple($text,[\&extract_quotelike]) ], + [ substr($stdtext2,0,6), substr($stdtext2,7,5), substr($stdtext2,12) ]; + +expect [ pos $text], [ length($text) ]; +expect [ $text ], [ $stdtext2 ]; + +# TESTS 53-55 +$text = $stdtext2; +expect [ scalar extract_multiple($text,[\&extract_quotelike]) ], + [ substr($stdtext2,0,6) ]; + +expect [ pos $text], [ 0 ]; +expect [ $text ], [ substr($stdtext2,6) ]; + + +# TESTS 56-58 +$text = $stdtext2; +expect [ extract_multiple($text,[\&extract_quotelike],2,1) ], + [ substr($stdtext2,7,5) ]; + +expect [ pos $text], [ 23 ]; +expect [ $text ], [ $stdtext2 ]; + +# TESTS 59-61 +$text = $stdtext2; +expect [ eval{local$^W;scalar extract_multiple($text,[\&extract_quotelike],2,1)} ], + [ substr($stdtext2,7,5) ]; + +expect [ pos $text], [ 6 ]; +expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ]; + + +# TESTS 62-64 +$text = $stdtext2; +expect [ extract_multiple($text,[\&extract_quotelike],1,1) ], + [ substr($stdtext2,7,5) ]; + +expect [ pos $text], [ 12 ]; +expect [ $text ], [ $stdtext2 ]; + +# TESTS 65-67 +$text = $stdtext2; +expect [ scalar extract_multiple($text,[\&extract_quotelike],1,1) ], + [ substr($stdtext2,7,5) ]; + +expect [ pos $text], [ 6 ]; +expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ]; + +# TESTS 68-70 +my $stdtext3 = "a,b,c"; + +$_ = $stdtext3; +expect [ extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], + [ divide($stdtext3 => 1,2,3,4,5) ]; + +expect [ pos ], [ 5 ]; +expect [ $_ ], [ $stdtext3 ]; + +# TESTS 71-73 + +$_ = $stdtext3; +expect [ scalar extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], + [ divide($stdtext3 => 1) ]; + +expect [ pos ], [ 0 ]; +expect [ $_ ], [ substr($stdtext3,1) ]; + + +# TESTS 74-76 + +$_ = $stdtext3; +expect [ extract_multiple(undef, [ qr/\G[a-z]/ ]) ], + [ divide($stdtext3 => 1,2,3,4,5) ]; + +expect [ pos ], [ 5 ]; +expect [ $_ ], [ $stdtext3 ]; + +# TESTS 77-79 + +$_ = $stdtext3; +expect [ scalar extract_multiple(undef, [ qr/\G[a-z]/ ]) ], + [ divide($stdtext3 => 1) ]; + +expect [ pos ], [ 0 ]; +expect [ $_ ], [ substr($stdtext3,1) ]; + + +# TESTS 80-82 + +$_ = $stdtext3; +expect [ extract_multiple(undef, [ q/([a-z]),?/ ]) ], + [ qw(a b c) ]; + +expect [ pos ], [ 5 ]; +expect [ $_ ], [ $stdtext3 ]; + +# TESTS 83-85 + +$_ = $stdtext3; +expect [ scalar extract_multiple(undef, [ q/([a-z]),?/ ]) ], + [ divide($stdtext3 => 1) ]; + +expect [ pos ], [ 0 ]; +expect [ $_ ], [ substr($stdtext3,2) ]; diff --git a/lib/Text/Balanced/t/xquot.t b/lib/Text/Balanced/t/xquot.t new file mode 100644 index 0000000000..567e0a54b8 --- /dev/null +++ b/lib/Text/Balanced/t/xquot.t @@ -0,0 +1,118 @@ +#!./perl -ws + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..89\n"; } +END {print "not ok 1\n" unless $loaded;} +use Text::Balanced qw ( extract_quotelike ); +$loaded = 1; +print "ok 1\n"; +$count=2; +use vars qw( $DEBUG ); +# $DEBUG=1; +sub debug { print "\t>>>",@_ if $DEBUG } + +######################### End of black magic. + + +$cmd = "print"; +$neg = 0; +while (defined($str = <DATA>)) +{ + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; + $str =~ s/\\n/\n/g; + my $orig = $str; + + my @res; + eval qq{\@res = $cmd; }; + debug "\t got:\n" . join "", map { $res[$_]=~s/\n/\\n/g; "\t\t\t$_: [$res[$_]]\n"} (0..$#res); + debug "\t left: " . (map { s/\n/\\n/g; "[$_]\n" } my $cpy1 = $str)[0]; + debug "\t pos: " . (map { s/\n/\\n/g; "[$_]\n" } my $cpy2 = substr($str,pos($str)))[0] . "...]\n"; + print "not " if (substr($str,pos($str),1) eq ';')==$neg; + print "ok ", $count++; + print "\n"; + + $str = $orig; + debug "\tUsing: scalar $cmd\n"; + debug "\t on: [$str]\n"; + $var = eval $cmd; + print " ($@)" if $@ && $DEBUG; + $var = "<undef>" unless defined $var; + debug "\t scalar got: " . (map { s/\n/\\n/g; "[$_]\n" } $var)[0]; + debug "\t scalar left: " . (map { s/\n/\\n/g; "[$_]\n" } $str)[0]; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print "\n"; +} + +__DATA__ + +# USING: extract_quotelike($str); +''; +""; +"a"; +'b'; +`cc`; + + +<<EOHERE; done();\nline1\nline2\nEOHERE\n; next; + <<EOHERE; done();\nline1\nline2\nEOHERE\n; next; +<<"EOHERE"; done()\nline1\nline2\nEOHERE\n and next +<<`EOHERE`; done()\nline1\nline2\nEOHERE\n and next +<<'EOHERE'; done()\nline1\n'line2'\nEOHERE\n and next +<<'EOHERE;'; done()\nline1\nline2\nEOHERE;\n and next +<<" EOHERE"; done() \nline1\nline2\n EOHERE\nand next +<<""; done()\nline1\nline2\n\n and next +<<; done()\nline1\nline2\n\n and next + + +"this is a nested $var[$x] {"; +/a/gci; +m/a/gci; + +q(d); +qq(e); +qx(f); +qr(g); +qw(h i j); +q{d}; +qq{e}; +qx{f}; +qr{g}; +qq{a nested { and } are okay as are () and <> pairs and escaped \}'s }; +q/slash/; +q # slash #; +qr qw qx; + +s/x/y/; +s/x/y/cgimsox; +s{a}{b}; +s{a}\n {b}; +s(a){b}; +s(a)/b/; +s/'/\\'/g; +tr/x/y/; +y/x/y/; + +# THESE SHOULD FAIL +s<$self->{pat}>{$self->{sub}}; # CAN'T HANDLE '>' in '->' +s-$self->{pap}-$self->{sub}-; # CAN'T HANDLE '-' in '->' +<<EOHERE; done();\nline1\nline2\nEOHERE;\n; next; # RDEL HAS NO ';' +<<'EOHERE'; done();\nline1\nline2\nEOHERE;\n; next; # RDEF HAS NO ';' + << EOTHERE; done();\nline1\nline2\n EOTHERE\n; next; # RDEL IS "" (!) diff --git a/lib/Text/Balanced/t/xtagg.t b/lib/Text/Balanced/t/xtagg.t new file mode 100644 index 0000000000..c883181c24 --- /dev/null +++ b/lib/Text/Balanced/t/xtagg.t @@ -0,0 +1,118 @@ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..53\n"; } +END {print "not ok 1\n" unless $loaded;} +use Text::Balanced qw ( extract_tagged gen_extract_tagged ); +$loaded = 1; +print "ok 1\n"; +$count=2; +use vars qw( $DEBUG ); +sub debug { print "\t>>>",@_ if $DEBUG } + +######################### End of black magic. + + +$cmd = "print"; +$neg = 0; +while (defined($str = <DATA>)) +{ + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; + + my @res; + $var = eval "\@res = $cmd"; + debug "\t list got: [" . join("|",@res) . "]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; + + pos $str = 0; + $var = eval $cmd; + $var = "<undef>" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; +} + +__DATA__ +# USING: gen_extract_tagged("BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)")->($str); + ignore\n this and then BEGINHERE at the ENDHERE; + ignore\n this and then BEGINTHIS at the ENDTHIS; + +# USING: extract_tagged($str,"BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)"); + ignore\n this and then BEGINHERE at the ENDHERE; + ignore\n this and then BEGINTHIS at the ENDTHIS; + +# USING: extract_tagged($str,"BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)"); + ignore\n this and then BEGINHERE at the ENDHERE; + ignore\n this and then BEGINTHIS at the ENDTHIS; + +# THIS SHOULD FAIL + ignore\n this and then BEGINTHIS at the ENDTHAT; + +# USING: extract_tagged($str,"BEGIN","END","(?s).*?(?=BEGIN)"); + ignore\n this and then BEGIN at the END; + +# USING: extract_tagged($str); + <A-1 HREF="#section2">some text</A-1>; + +# USING: extract_tagged($str,qr/<[A-Z]+>/,undef, undef, {ignore=>["<BR>"]}); + <A>aaa<B>bbb<BR>ccc</B>ddd</A>; + +# USING: extract_tagged($str,"BEGIN","END"); + BEGIN at the BEGIN keyword and END at the END; + BEGIN at the beginning and end at the END; + +# USING: extract_tagged($str,undef,undef,undef,{ignore=>["<[^>]*/>"]}); + <A>aaa<B>bbb<BR/>ccc</B>ddd</A>; + +# USING: extract_tagged($str,";","-",undef,{reject=>[";"],fail=>"MAX"}); + ; at the ;-) keyword + +# USING: extract_tagged($str,"<[A-Z]+>",undef, undef, {ignore=>["<BR>"]}); + <A>aaa<B>bbb<BR>ccc</B>ddd</A>; + +# THESE SHOULD FAIL + BEGIN at the beginning and end at the end; + BEGIN at the BEGIN keyword and END at the end; + +# TEST EXTRACTION OF TAGGED STRINGS +# USING: extract_tagged($str,"BEGIN","END",undef,{reject=>["BEGIN","END"]}); +# THESE SHOULD FAIL + BEGIN at the BEGIN keyword and END at the end; + +# USING: extract_tagged($str,";","-",undef,{reject=>[";"],fail=>"PARA"}); + ; at the ;-) keyword + + +# USING: extract_tagged($str); + <A>some text</A>; + <B>some text<A>other text</A></B>; + <A>some text<A>other text</A></A>; + <A HREF="#section2">some text</A>; + +# THESE SHOULD FAIL + <A>some text + <A>some text<A>other text</A>; + <B>some text<A>other text</B>; diff --git a/lib/Text/Balanced/t/xvari.t b/lib/Text/Balanced/t/xvari.t new file mode 100644 index 0000000000..dd35b9c032 --- /dev/null +++ b/lib/Text/Balanced/t/xvari.t @@ -0,0 +1,107 @@ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..81\n"; } +END {print "not ok 1\n" unless $loaded;} +use Text::Balanced qw ( extract_variable ); +$loaded = 1; +print "ok 1\n"; +$count=2; +use vars qw( $DEBUG ); +sub debug { print "\t>>>",@_ if $DEBUG } + +######################### End of black magic. + + +$cmd = "print"; +$neg = 0; +while (defined($str = <DATA>)) +{ + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; + + my @res; + $var = eval "\@res = $cmd"; + debug "\t list got: [" . join("|",@res) . "]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; + + pos $str = 0; + $var = eval $cmd; + $var = "<undef>" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; +} + +__DATA__ + +# USING: extract_variable($str); +# THESE SHOULD FAIL +$a->; +$a (1..3) { print $a }; + +# USING: extract_variable($str); +*var; +*$var; +*{var}; +*{$var}; +*var{cat}; +\&var; +\&mod::var; +\&mod'var; +$a; +$_; +$a[1]; +$_[1]; +$a{cat}; +$_{cat}; +$a->[1]; +$a->{"cat"}[1]; +@$listref; +@{$listref}; +$obj->nextval; +$obj->_nextval; +$obj->next_val_; +@{$obj->nextval}; +@{$obj->nextval($cat,$dog)->{new}}; +@{$obj->nextval($cat?$dog:$fish)->{new}}; +@{$obj->nextval(cat()?$dog:$fish)->{new}}; +$ a {'cat'}; +$a::b::c{d}->{$e->()}; +$a'b'c'd{e}->{$e->()}; +$a'b::c'd{e}->{$e->()}; +$#_; +$#array; +$#{array}; +$var[$#var]; + +# THESE SHOULD FAIL +$a->; +@{$; +$ a :: b :: c +$ a ' b ' c + +# USING: extract_variable($str,'=*'); +========$a; diff --git a/lib/Text/ParseWords.t b/lib/Text/ParseWords.t new file mode 100755 index 0000000000..261d81f3a4 --- /dev/null +++ b/lib/Text/ParseWords.t @@ -0,0 +1,110 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use warnings; +use Text::ParseWords; + +print "1..18\n"; + +@words = shellwords(qq(foo "bar quiz" zoo)); +print "not " if $words[0] ne 'foo'; +print "ok 1\n"; +print "not " if $words[1] ne 'bar quiz'; +print "ok 2\n"; +print "not " if $words[2] ne 'zoo'; +print "ok 3\n"; + +{ + # Gonna get some undefined things back + no warnings 'uninitialized' ; + + # Test quotewords() with other parameters and null last field + @words = quotewords(':+', 1, 'foo:::"bar:foo":zoo zoo:'); + print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo;); + print "ok 4\n"; +} + +# Test $keep eq 'delimiters' and last field zero +@words = quotewords('\s+', 'delimiters', '4 3 2 1 0'); +print "not " unless join(";", @words) eq qq(4; ;3; ;2; ;1; ;0); +print "ok 5\n"; + +# Big ol' nasty test (thanks, Joerk!) +$string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd" eee\\\\\\"ffff" "gg"'; + +# First with $keep == 1 +$result = join('|', parse_line('\s+', 1, $string)); +print "not " unless $result eq 'aaaa"bbbbb"|cc\\ cc|\\\\\\"dddd" eee\\\\\\"ffff"|"gg"'; +print "ok 6\n"; + +# Now, $keep == 0 +$result = join('|', parse_line('\s+', 0, $string)); +print "not " unless $result eq 'aaaabbbbb|cc cc|\\"dddd eee\\"ffff|gg'; +print "ok 7\n"; + +# Now test single quote behavior +$string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd\' eee\\\\\\"ffff\' gg'; +$result = join('|', parse_line('\s+', 0, $string)); +print "not " unless $result eq 'aaaabbbbb|cc cc|\\"dddd eee\\\\\\"ffff|gg'; +print "ok 8\n"; + +# Make sure @nested_quotewords does the right thing +@lists = nested_quotewords('\s+', 0, 'a b c', '1 2 3', 'x y z'); +print "not " unless (@lists == 3 && @{$lists[0]} == 3 && @{$lists[1]} == 3 && @{$lists[2]} == 3); +print "ok 9\n"; + +# Now test error return +$string = 'foo bar baz"bach blech boop'; + +@words = shellwords($string); +print "not " if (@words); +print "ok 10\n"; + +@words = parse_line('s+', 0, $string); +print "not " if (@words); +print "ok 11\n"; + +@words = quotewords('s+', 0, $string); +print "not " if (@words); +print "ok 12\n"; + +{ + # Gonna get some more undefined things back + no warnings 'uninitialized' ; + + @words = nested_quotewords('s+', 0, $string); + print "not " if (@words); + print "ok 13\n"; + + # Now test empty fields + $result = join('|', parse_line(':', 0, 'foo::0:"":::')); + print "not " unless ($result eq 'foo||0||||'); + print "ok 14\n"; + + # Test for 0 in quotes without $keep + $result = join('|', parse_line(':', 0, ':"0":')); + print "not " unless ($result eq '|0|'); + print "ok 15\n"; + + # Test for \001 in quoted string + $result = join('|', parse_line(':', 0, ':"' . "\001" . '":')); + print "not " unless ($result eq "|\1|"); + print "ok 16\n"; + +} + +# Now test perlish single quote behavior +$Text::ParseWords::PERL_SINGLE_QUOTE = 1; +$string = 'aaaa"bbbbb" cc\ cc \\\\\"dddd\' eee\\\\\"\\\'ffff\' gg'; +$result = join('|', parse_line('\s+', 0, $string)); +print "not " unless $result eq 'aaaabbbbb|cc cc|\"dddd eee\\\\"\'ffff|gg'; +print "ok 17\n"; + +# test whitespace in the delimiters +@words = quotewords(' ', 1, '4 3 2 1 0'); +print "not " unless join(";", @words) eq qq(4;3;2;1;0); +print "ok 18\n"; diff --git a/lib/Text/Soundex.t b/lib/Text/Soundex.t new file mode 100755 index 0000000000..d35f264c7a --- /dev/null +++ b/lib/Text/Soundex.t @@ -0,0 +1,143 @@ +#!./perl +# +# $Id: soundex.t,v 1.2 1994/03/24 00:30:27 mike Exp $ +# +# test module for soundex.pl +# +# $Log: soundex.t,v $ +# Revision 1.2 1994/03/24 00:30:27 mike +# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu> +# in the way I handles leasing characters which were different but had +# the same soundex code. This showed up comparing it with Oracle's +# soundex output. +# +# Revision 1.1 1994/03/02 13:03:02 mike +# Initial revision +# +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Text::Soundex; + +$test = 0; +print "1..13\n"; + +while (<DATA>) +{ + chop; + next if /^\s*;?#/; + next if /^\s*$/; + + ++$test; + $bad = 0; + + if (/^eval\s+/) + { + ($try = $_) =~ s/^eval\s+//; + + eval ($try); + if ($@) + { + $bad++; + print "not ok $test\n"; + print "# eval '$try' returned $@"; + } + } + elsif (/^\(/) + { + ($in, $out) = split (':'); + + $try = "\@expect = $out; \@got = &soundex $in;"; + eval ($try); + + if (@expect != @got) + { + $bad++; + print "not ok $test\n"; + print "# expected ", scalar @expect, " results, got ", scalar @got, "\n"; + print "# expected (", join (', ', @expect), + ") got (", join (', ', @got), ")\n"; + } + else + { + while (@got) + { + $expect = shift @expect; + $got = shift @got; + + if ($expect ne $got) + { + $bad++; + print "not ok $test\n"; + print "# expected $expect, got $got\n"; + } + } + } + } + else + { + ($in, $out) = split (':'); + + $try = "\$expect = $out; \$got = &soundex ($in);"; + eval ($try); + + if ($expect ne $got) + { + $bad++; + print "not ok $test\n"; + print "# expected $expect, got $got\n"; + } + } + + print "ok $test\n" unless $bad; +} + +__END__ +# +# 1..6 +# +# Knuth's test cases, scalar in, scalar out +# +'Euler':'E460' +'Gauss':'G200' +'Hilbert':'H416' +'Knuth':'K530' +'Lloyd':'L300' +'Lukasiewicz':'L222' +# +# 7..8 +# +# check default bad code +# +'2 + 2 = 4':undef +undef:undef +# +# 9 +# +# check array in, array out +# +('Ellery', 'Ghosh', 'Heilbronn', 'Kant', 'Ladd', 'Lissajous'):('E460', 'G200', 'H416', 'K530', 'L300', 'L222') +# +# 10 +# +# check array with explicit undef +# +('Mike', undef, 'Stok'):('M200', undef, 'S320') +# +# 11..12 +# +# check setting $Text::Soundex::noCode +# +eval $soundex_nocode = 'Z000'; +('Mike', undef, 'Stok'):('M200', 'Z000', 'S320') +# +# 13 +# +# a subtle difference between me & oracle, spotted by Rich Pinder +# <rpinder@hsc.usc.edu> +# +CZARKOWSKA:C622 diff --git a/lib/Text/Tabs.t b/lib/Text/Tabs.t new file mode 100755 index 0000000000..2856aff75b --- /dev/null +++ b/lib/Text/Tabs.t @@ -0,0 +1,141 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +@tests = (split(/\nEND\n/s, <<DONE)); +TEST 1 u + x +END + x +END +TEST 2 e + x +END + x +END +TEST 3 e + x + y + z +END + x + y + z +END +TEST 4 u + x + y + z +END + x + y + z +END +TEST 5 u +This Is a test of a line with many embedded tabs +END +This Is a test of a line with many embedded tabs +END +TEST 6 e +This Is a test of a line with many embedded tabs +END +This Is a test of a line with many embedded tabs +END +TEST 7 u + x +END + x +END +TEST 8 e + + + + + +END + + + + + +END +TEST 9 u + +END + +END +TEST 10 u + + + + + +END + + + + + +END +TEST 11 u +foobar IN A 140.174.82.12 + +END +foobar IN A 140.174.82.12 + +END +DONE + +$| = 1; + +my $testcount = "1.."; +$testcount .= @tests/2; +print "$testcount\n"; + +use Text::Tabs; + +$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; + +$tn = 1; +while (@tests) { + my $in = shift(@tests); + my $out = shift(@tests); + + $in =~ s/^TEST\s*(\d+)?\s*(\S+)?\n//; + + if ($2 eq 'e') { + $f = \&expand; + $fn = 'expand'; + } else { + $f = \&unexpand; + $fn = 'unexpand'; + } + + my $back = &$f($in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input ------------\n"; + print $in; + print "\$\n------------ $fn -----------\n"; + print $back; + print "\$\n------------ expected ---------\n"; + print $out; + print "\$\n-------------------------------\n"; + $Text::Tabs::debug = 1; + my $back = &$f($in); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; +} diff --git a/lib/Text/Wrap/fill.t b/lib/Text/Wrap/fill.t new file mode 100755 index 0000000000..5ff3850caf --- /dev/null +++ b/lib/Text/Wrap/fill.t @@ -0,0 +1,98 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Text::Wrap qw(&fill); + +@tests = (split(/\nEND\n/s, <<DONE)); +TEST1 +Cyberdog Information + +Cyberdog & Netscape in the news +Important Press Release regarding Cyberdog and Netscape. Check it out! + +Cyberdog Plug-in Support! +Cyberdog support for Netscape Plug-ins is now available to download! Go +to the Cyberdog Beta Download page and download it now! + +Cyberdog Book +Check out Jesse Feiler's way-cool book about Cyberdog. You can find +details out about the book as well as ordering information at Philmont +Software Mill site. + +Java! +Looking to view Java applets in Cyberdog 1.1 Beta 3? Download and install +the Mac OS Runtime for Java and try it out! + +Cyberdog 1.1 Beta 3 +We hope that Cyberdog and OpenDoc 1.1 will be available within the next +two weeks. In the meantime, we have released another version of +Cyberdog, Cyberdog 1.1 Beta 3. This version fixes several bugs that were +reported to us during out public beta period. You can check out our release +notes to see what we fixed! +END + Cyberdog Information + Cyberdog & Netscape in the news Important Press Release regarding + Cyberdog and Netscape. Check it out! + Cyberdog Plug-in Support! Cyberdog support for Netscape Plug-ins is now + available to download! Go to the Cyberdog Beta Download page and download + it now! + Cyberdog Book Check out Jesse Feiler's way-cool book about Cyberdog. + You can find details out about the book as well as ordering information at + Philmont Software Mill site. + Java! Looking to view Java applets in Cyberdog 1.1 Beta 3? Download and + install the Mac OS Runtime for Java and try it out! + Cyberdog 1.1 Beta 3 We hope that Cyberdog and OpenDoc 1.1 will be + available within the next two weeks. In the meantime, we have released + another version of Cyberdog, Cyberdog 1.1 Beta 3. This version fixes + several bugs that were reported to us during out public beta period. You + can check out our release notes to see what we fixed! +END +DONE + + +$| = 1; + +print "1..", @tests/2, "\n"; + +use Text::Wrap; + +$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; + +$tn = 1; +while (@tests) { + my $in = shift(@tests); + my $out = shift(@tests); + + $in =~ s/^TEST(\d+)?\n//; + + my $back = fill(' ', ' ', $in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + open(F,">#o") and do { print F $back; close(F) }; + open(F,">#e") and do { print F $out; close(F) }; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input ------------\n"; + print $in; + print "\n------------ output -----------\n"; + print $back; + print "\n------------ expected ---------\n"; + print $out; + print "\n-------------------------------\n"; + $Text::Wrap::debug = 1; + fill(' ', ' ', $oi); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; +} diff --git a/lib/Text/Wrap/wrap.t b/lib/Text/Wrap/wrap.t new file mode 100755 index 0000000000..fee6ce070d --- /dev/null +++ b/lib/Text/Wrap/wrap.t @@ -0,0 +1,209 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +@tests = (split(/\nEND\n/s, <<DONE)); +TEST1 +This +is +a +test +END + This + is + a + test +END +TEST2 +This is a test of a very long line. It should be broken up and put onto multiple lines. +This is a test of a very long line. It should be broken up and put onto multiple lines. + +This is a test of a very long line. It should be broken up and put onto multiple lines. +END + This is a test of a very long line. It should be broken up and put onto + multiple lines. + This is a test of a very long line. It should be broken up and put onto + multiple lines. + + This is a test of a very long line. It should be broken up and put onto + multiple lines. +END +TEST3 +This is a test of a very long line. It should be broken up and put onto multiple lines. +END + This is a test of a very long line. It should be broken up and put onto + multiple lines. +END +TEST4 +This is a test of a very long line. It should be broken up and put onto multiple lines. + +END + This is a test of a very long line. It should be broken up and put onto + multiple lines. + +END +TEST5 +This is a test of a very long line. It should be broken up and put onto multiple This is a test of a very long line. It should be broken up and put +END + This is a test of a very long line. It should be broken up and put onto + multiple This is a test of a very long line. It should be broken up and + put +END +TEST6 +11111111 22222222 33333333 44444444 55555555 66666666 77777777 888888888 999999999 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee ffffffff gggggggg hhhhhhhh iiiiiiii jjjjjjjj kkkkkkkk llllllll mmmmmmmmm nnnnnnnnn ooooooooo ppppppppp qqqqqqqqq rrrrrrrrr sssssssss +END + 11111111 22222222 33333333 44444444 55555555 66666666 77777777 888888888 + 999999999 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee ffffffff + gggggggg hhhhhhhh iiiiiiii jjjjjjjj kkkkkkkk llllllll mmmmmmmmm nnnnnnnnn + ooooooooo ppppppppp qqqqqqqqq rrrrrrrrr sssssssss +END +TEST7 +c3t1d0s6 c4t1d0s6 c5t1d0s6 c6t1d0s6 c7t1d0s6 c8t1d0s6 c9t1d0s6 c10t1d0s6 c11t1d0s6 c12t1d0s6 c13t1d0s6 c14t1d0s6 c15t1d0s6 c16t1d0s6 c3t1d0s0 c4t1d0s0 c5t1d0s0 c6t1d0s0 c7t1d0s0 c8t1d0s0 c9t1d0s0 c10t1d0s0 c11t1d0s0 c12t1d0s0 c13t1d0s0 c14t1d0s0 c15t1d0s0 c16t1d0s0 +END + c3t1d0s6 c4t1d0s6 c5t1d0s6 c6t1d0s6 c7t1d0s6 c8t1d0s6 c9t1d0s6 c10t1d0s6 + c11t1d0s6 c12t1d0s6 c13t1d0s6 c14t1d0s6 c15t1d0s6 c16t1d0s6 c3t1d0s0 + c4t1d0s0 c5t1d0s0 c6t1d0s0 c7t1d0s0 c8t1d0s0 c9t1d0s0 c10t1d0s0 c11t1d0s0 + c12t1d0s0 c13t1d0s0 c14t1d0s0 c15t1d0s0 c16t1d0s0 +END +TEST8 +A test of a very very long word. +a123456789b123456789c123456789d123456789e123456789f123456789g123456789g1234567 +END + A test of a very very long word. + a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 + 4567 +END +TEST9 +A test of a very very long word. a123456789b123456789c123456789d123456789e123456789f123456789g123456789g1234567 +END + A test of a very very long word. + a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 + 4567 +END +TEST10 +my mother once said +"never eat paste my darling" +would that I heeded +END + my mother once said + "never eat paste my darling" + would that I heeded +END +TEST11 +This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_program_does_not_crash_and_burn +END + This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_pr + ogram_does_not_crash_and_burn +END +TEST12 +This + +Has + +Blank + +Lines + +END + This + + Has + + Blank + + Lines + +END +DONE + + +$| = 1; + +print "1..", 1 +@tests, "\n"; + +use Text::Wrap; + +$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; + +$tn = 1; + +@st = @tests; +while (@st) { + my $in = shift(@st); + my $out = shift(@st); + + $in =~ s/^TEST(\d+)?\n//; + + my $back = wrap(' ', ' ', $in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input ------------\n"; + print $in; + print "\n------------ output -----------\n"; + print $back; + print "\n------------ expected ---------\n"; + print $out; + print "\n-------------------------------\n"; + $Text::Wrap::debug = 1; + wrap(' ', ' ', $oi); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; + +} + +@st = @tests; +while(@st) { + my $in = shift(@st); + my $out = shift(@st); + + $in =~ s/^TEST(\d+)?\n//; + + my @in = split("\n", $in, -1); + @in = ((map { "$_\n" } @in[0..$#in-1]), $in[-1]); + + my $back = wrap(' ', ' ', @in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input2 ------------\n"; + print $in; + print "\n------------ output2 -----------\n"; + print $back; + print "\n------------ expected2 ---------\n"; + print $out; + print "\n-------------------------------\n"; + $Text::Wrap::debug = 1; + wrap(' ', ' ', $oi); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; +} + +$Text::Wrap::huge = 'overflow'; + +my $tw = 'This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_program_does_not_crash_and_burn'; +my $w = wrap('zzz','yyy',$tw); +print (($w eq "zzz$tw") ? "ok $tn\n" : "not ok $tn"); +$tn++; + |