X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Fwrite.t;h=a86b4ebb9ab46eb8a125c3177b63c4f72ed64d11;hb=a4c04bdcc508b6a45f83e703d0f82401445aa55b;hp=35aba42eaad4a30c10f238053ddad8d3b6ea163b;hpb=79072805bf63abe5b5978b5928ab00d360ea3e7f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/op/write.t b/t/op/write.t index 35aba42..a86b4eb 100755 --- a/t/op/write.t +++ b/t/op/write.t @@ -1,8 +1,15 @@ #!./perl -# $RCSfile: write.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:38 $ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} -print "1..3\n"; +print "1..44\n"; + +my $CAT = ($^O eq 'MSWin32' || $^O eq 'NetWare') ? 'type' + : ($^O eq 'MacOS') ? 'catenate' + : 'cat'; format OUT = the quick brown @<< @@ -17,10 +24,12 @@ $foo ^<<<<<<... $foo now @<>>> for all@|||||men to come @<<<< -'i' . 's', "time\n", $good, 'to' +{ + 'i' . 's', "time\n", $good, 'to' +} . -open(OUT, '>Op.write.tmp') || die "Can't create Op.write.tmp"; +open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; $fox = 'foxiness'; $good = 'good'; @@ -40,11 +49,14 @@ the course of huma... now is the time for all good men to come to\n"; -if (`cat Op.write.tmp` eq $right) - { print "ok 1\n"; unlink 'Op.write.tmp'; } +if (`$CAT Op_write.tmp` eq $right) + { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 1\n"; } +$fox = 'wolfishness'; +my $fox = 'foxiness'; # Test a lexical variable. + format OUT2 = the quick brown @<< $fox @@ -57,9 +69,8 @@ now @<>>> for all@|||||men to come @<<<< 'i' . 's', "time\n", $good, 'to' . -open(OUT2, '>Op.write.tmp') || die "Can't create Op.write.tmp"; +open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp"; -$fox = 'foxiness'; $good = 'good'; $multiline = "forescore\nand\nseven years\n"; $foo = 'when in the course of human events it becomes necessary'; @@ -80,8 +91,8 @@ becomes necessary now is the time for all good men to come to\n"; -if (`cat Op.write.tmp` eq $right) - { print "ok 2\n"; unlink 'Op.write.tmp'; } +if (`$CAT Op_write.tmp` eq $right) + { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 2\n"; } @@ -92,6 +103,7 @@ $fox jumped @* $multiline +and ^<<<<<<<<< ~~ $foo now @<>>> for all@|||||men to come @<<<< @@ -99,7 +111,7 @@ now @<>>> for all@|||||men to come @<<<< . EOFORMAT -open(OUT2, '>Op.write.tmp') || die "Can't create Op.write.tmp"; +open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; $fox = 'foxiness'; $good = 'good'; @@ -114,6 +126,7 @@ jumped forescore and seven years +and when in the course of human @@ -122,8 +135,280 @@ becomes necessary now is the time for all good men to come to\n"; -if (`cat Op.write.tmp` eq $right) - { print "ok 3\n"; unlink 'Op.write.tmp'; } +if (`$CAT Op_write.tmp` eq $right) + { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 3\n"; } +# formline tests + +$mustbe = < ab +@>> abc +@>>> abc +@>>>> abc +@>>>>> abc +@>>>>>> abc +@>>>>>>> abc +@>>>>>>>> abc +@>>>>>>>>> abc +@>>>>>>>>>> abc +EOT + +$was1 = $was2 = ''; +for (0..10) { + # lexical picture + $^A = ''; + my $format1 = '@' . '>' x $_; + formline $format1, 'abc'; + $was1 .= "$format1 $^A\n"; + # global + $^A = ''; + local $format2 = '@' . '>' x $_; + formline $format2, 'abc'; + $was2 .= "$format2 $^A\n"; +} +print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n"; +print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n"; + +$^A = ''; + +# more test + +format OUT3 = +^<<<<<<... +$foo +. + +open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp"; + +$foo = 'fit '; +write(OUT3); +close OUT3; + +$right = +"fit\n"; + +if (`$CAT Op_write.tmp` eq $right) + { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; } +else + { print "not ok 6\n"; } + +# test lexicals and globals +{ + my $this = "ok"; + our $that = 7; + format LEX = +@<<@| +$this,$that +. + open(LEX, ">&STDOUT") or die; + write LEX; + $that = 8; + write LEX; + close LEX; +} +# LEX_INTERPNORMAL test +my %e = ( a => 1 ); +format OUT4 = +@<<<<<< +"$e{a}" +. +open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; +write (OUT4); +close OUT4; +if (`$CAT Op_write.tmp` eq "1\n") { + print "ok 9\n"; + 1 while unlink "Op_write.tmp"; + } +else { + print "not ok 9\n"; + } + +eval <<'EOFORMAT'; +format OUT10 = +@####.## @0###.## +$test1, $test1 +. +EOFORMAT + +open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp"; + +$test1 = 12.95; +write(OUT10); +close OUT10; + +$right = " 12.95 00012.95\n"; +if (`$CAT Op_write.tmp` eq $right) + { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; } +else + { print "not ok 10\n"; } + +eval <<'EOFORMAT'; +format OUT11 = +@0###.## +$test1 +@ 0# +$test1 +@0 # +$test1 +. +EOFORMAT + +open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp"; + +$test1 = 12.95; +write(OUT11); +close OUT11; + +$right = +"00012.95 +1 0# +10 #\n"; +if (`$CAT Op_write.tmp` eq $right) + { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; } +else + { print "not ok 11\n"; } + +# 12..44: scary format testing from Merijn H. Brand + +if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || + ($^O eq 'os2' and not eval '$OS2::can_fork')) { + foreach (12..44) { print "ok $_ # skipped: '|-' and '-|' not supported\n"; } + exit(0); +} + +use strict; # Amazed that this hackery can be made strict ... + +# Just a complete test for format, including top-, left- and bottom marging +# and format detection through glob entries + + $= = 7; # Page length +my $ps = $^L; $^L = ""; # Catch the page separator +my $tm = 1; # Top margin (empty lines before first output) +my $bm = 2; # Bottom marging (empty lines between last text and footer) +my $lm = 4; # Left margin (indent in spaces) + +select ((select (STDOUT), $| = 1)[0]); +if ($lm > 0 and !open STDOUT, "|-") { # Left margin (in this test ALWAYS set) + select ((select (STDOUT), $| = 1)[0]); + my $i = 12; + my $s = " " x $lm; + while () { + s/^/$s/; + print + ($_ eq ? "" : "not "), "ok ", $i++, "\n"; + } + close STDIN; + print + (?"not ":""), "ok ", $i++, "\n"; + close STDOUT; + exit; + } +$tm = "\n" x $tm; +$= -= $bm + 1; # count one for the trailing "----" +my $lastmin = 0; + +my @E; + +sub wryte +{ + $lastmin = $-; + write; + } # wryte; + +sub footer +{ + $% == 1 and return ""; + + $lastmin < $= and print "\n" x $lastmin; + print "\n" x $bm, "----\n", $ps; + $lastmin = $-; + ""; + } # footer + +# Yes, this is sick ;-) +format TOP = +@* ~ +@{[footer]} +@* ~ +$tm +. + +format EmptyTOP = +. + +format ENTRY = +@ @<<<<~~ +@{(shift @E)||["",""]} +. + +format EOR = +- ----- +. + +sub has_format ($) +{ + my $fmt = shift; + exists $::{$fmt} or return 0; + $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT}; + open my $null, "> /dev/null" or die; + my $fh = select $null; + local $~ = $fmt; + eval "write"; + select $fh; + $@?0:1; + } # has_format + +$^ = has_format ("TOP") ? "TOP" : "EmptyTOP"; +has_format ("ENTRY") or die "No format defined for ENTRY"; +foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ], + [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) { + @E = @$e; + local $~ = "ENTRY"; + wryte; + has_format ("EOR") or next; + local $~ = "EOR"; + wryte; + } +if (has_format ("EOF")) { + local $~ = "EOF"; + wryte; + } + +close STDOUT; + +# That was test 44. + +__END__ + + 1 Test1 + 2 Test2 + 3 Test3 + + + ---- + + 4 Test4 + 5 Test5 + 6 Test6 + + + ---- + + 7 Test7 + - ----- + + + + ---- + + 1 1tseT + 2 2tseT + 3 3tseT + + + ---- + + 4 4tseT + 5 5tseT + - -----