This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Reduce the -| skip back to just the tests that use it, and re-align the
[perl5.git] / t / op / write.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7 }
8
9 # read in a file
10 sub cat {
11     my $file = shift;
12     local $/;
13     open my $fh, $file or die "can't open '$file': $!";
14     my $data = <$fh>;
15     close $fh;
16     $data;
17 }
18
19 #-- testing numeric fields in all variants (WL)
20
21 sub swrite {
22     my $format = shift;
23     local $^A = ""; # don't litter, use a local bin
24     formline( $format, @_ );
25     return $^A;
26 }
27
28 my @NumTests = (
29     # [ format, value1, expected1, value2, expected2, .... ]
30     [ '@###',           0,   '   0',         1, '   1',     9999.6, '####',
31                 9999.4999,   '9999',    -999.6, '####',     1e+100, '####' ],
32
33     [ '@0##',           0,   '0000',         1, '0001',     9999.6, '####',
34                 -999.4999,   '-999',    -999.6, '####',     1e+100, '####' ],
35
36     [ '^###',           0,   '   0',     undef, '    ' ],
37
38     [ '^0##',           0,   '0000',     undef, '    ' ],
39
40     [ '@###.',          0,  '   0.',         1, '   1.',    9999.6, '#####',
41                 9999.4999,  '9999.',    -999.6, '#####' ],
42
43     [ '@##.##',         0, '  0.00',         1, '  1.00',  999.996, '######',
44                 999.99499, '999.99',      -100, '######' ],
45
46     [ '@0#.##',         0, '000.00',         1, '001.00',       10, '010.00',
47                   -0.0001, qr/^[\-0]00\.00$/ ],
48
49 );
50
51
52 my $num_tests = 0;
53 for my $tref ( @NumTests ){
54     $num_tests += (@$tref - 1)/2;
55 }
56 #---------------------------------------------------------
57
58 # number of tests in section 1
59 my $bas_tests = 20;
60
61 # number of tests in section 3
62 my $bug_tests = 4;
63
64 # number of tests in section 4
65 my $hmb_tests = 35;
66
67 my $tests = $bas_tests + $num_tests + $bug_tests + $hmb_tests;
68
69 plan $tests;
70
71 ############
72 ## Section 1
73 ############
74
75 format OUT =
76 the quick brown @<<
77 $fox
78 jumped
79 @*
80 $multiline
81 ^<<<<<<<<<
82 $foo
83 ^<<<<<<<<<
84 $foo
85 ^<<<<<<...
86 $foo
87 now @<<the@>>>> for all@|||||men to come @<<<<
88 {
89     'i' . 's', "time\n", $good, 'to'
90 }
91 .
92
93 open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
94 END { 1 while unlink 'Op_write.tmp' }
95
96 $fox = 'foxiness';
97 $good = 'good';
98 $multiline = "forescore\nand\nseven years\n";
99 $foo = 'when in the course of human events it becomes necessary';
100 write(OUT);
101 close OUT or die "Could not close: $!";
102
103 $right =
104 "the quick brown fox
105 jumped
106 forescore
107 and
108 seven years
109 when in
110 the course
111 of huma...
112 now is the time for all good men to come to\n";
113
114 if (cat('Op_write.tmp') eq $right)
115     { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; }
116 else
117     { print "not ok 1\n"; }
118
119 $fox = 'wolfishness';
120 my $fox = 'foxiness';           # Test a lexical variable.
121
122 format OUT2 =
123 the quick brown @<<
124 $fox
125 jumped
126 @*
127 $multiline
128 ^<<<<<<<<< ~~
129 $foo
130 now @<<the@>>>> for all@|||||men to come @<<<<
131 'i' . 's', "time\n", $good, 'to'
132 .
133
134 open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp";
135
136 $good = 'good';
137 $multiline = "forescore\nand\nseven years\n";
138 $foo = 'when in the course of human events it becomes necessary';
139 write(OUT2);
140 close OUT2 or die "Could not close: $!";
141
142 $right =
143 "the quick brown fox
144 jumped
145 forescore
146 and
147 seven years
148 when in
149 the course
150 of human
151 events it
152 becomes
153 necessary
154 now is the time for all good men to come to\n";
155
156 if (cat('Op_write.tmp') eq $right)
157     { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; }
158 else
159     { print "not ok 2\n"; }
160
161 eval <<'EOFORMAT';
162 format OUT2 =
163 the brown quick @<<
164 $fox
165 jumped
166 @*
167 $multiline
168 and
169 ^<<<<<<<<< ~~
170 $foo
171 now @<<the@>>>> for all@|||||men to come @<<<<
172 'i' . 's', "time\n", $good, 'to'
173 .
174 EOFORMAT
175
176 open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
177
178 $fox = 'foxiness';
179 $good = 'good';
180 $multiline = "forescore\nand\nseven years\n";
181 $foo = 'when in the course of human events it becomes necessary';
182 write(OUT2);
183 close OUT2 or die "Could not close: $!";
184
185 $right =
186 "the brown quick fox
187 jumped
188 forescore
189 and
190 seven years
191 and
192 when in
193 the course
194 of human
195 events it
196 becomes
197 necessary
198 now is the time for all good men to come to\n";
199
200 if (cat('Op_write.tmp') eq $right)
201     { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; }
202 else
203     { print "not ok 3\n"; }
204
205 # formline tests
206
207 $mustbe = <<EOT;
208 @ a
209 @> ab
210 @>> abc
211 @>>>  abc
212 @>>>>   abc
213 @>>>>>    abc
214 @>>>>>>     abc
215 @>>>>>>>      abc
216 @>>>>>>>>       abc
217 @>>>>>>>>>        abc
218 @>>>>>>>>>>         abc
219 EOT
220
221 $was1 = $was2 = '';
222 for (0..10) {           
223   # lexical picture
224   $^A = '';
225   my $format1 = '@' . '>' x $_;
226   formline $format1, 'abc';
227   $was1 .= "$format1 $^A\n";
228   # global
229   $^A = '';
230   local $format2 = '@' . '>' x $_;
231   formline $format2, 'abc';
232   $was2 .= "$format2 $^A\n";
233 }
234 print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n";
235 print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n";
236
237 $^A = '';
238
239 # more test
240
241 format OUT3 =
242 ^<<<<<<...
243 $foo
244 .
245
246 open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";
247
248 $foo = 'fit          ';
249 write(OUT3);
250 close OUT3 or die "Could not close: $!";
251
252 $right =
253 "fit\n";
254
255 if (cat('Op_write.tmp') eq $right)
256     { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; }
257 else
258     { print "not ok 6\n"; }
259
260 # test lexicals and globals
261 {
262     my $this = "ok";
263     our $that = 7;
264     format LEX =
265 @<<@|
266 $this,$that
267 .
268     open(LEX, ">&STDOUT") or die;
269     write LEX;
270     $that = 8;
271     write LEX;
272     close LEX or die "Could not close: $!";
273 }
274 # LEX_INTERPNORMAL test
275 my %e = ( a => 1 );
276 format OUT4 =
277 @<<<<<<
278 "$e{a}"
279 .
280 open   OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
281 write (OUT4);
282 close  OUT4 or die "Could not close: $!";
283 if (cat('Op_write.tmp') eq "1\n") {
284     print "ok 9\n";
285     1 while unlink "Op_write.tmp";
286     }
287 else {
288     print "not ok 9\n";
289     }
290
291 eval <<'EOFORMAT';
292 format OUT10 =
293 @####.## @0###.##
294 $test1, $test1
295 .
296 EOFORMAT
297
298 open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
299
300 $test1 = 12.95;
301 write(OUT10);
302 close OUT10 or die "Could not close: $!";
303
304 $right = "   12.95 00012.95\n";
305 if (cat('Op_write.tmp') eq $right)
306     { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; }
307 else
308     { print "not ok 10\n"; }
309
310 eval <<'EOFORMAT';
311 format OUT11 =
312 @0###.## 
313 $test1
314 @ 0#
315 $test1
316 @0 # 
317 $test1
318 .
319 EOFORMAT
320
321 open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";
322
323 $test1 = 12.95;
324 write(OUT11);
325 close OUT11 or die "Could not close: $!";
326
327 $right = 
328 "00012.95
329 1 0#
330 10 #\n";
331 if (cat('Op_write.tmp') eq $right)
332     { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; }
333 else
334     { print "not ok 11\n"; }
335
336 {
337     my $el;
338     format OUT12 =
339 ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze
340 $el
341 .
342     my %hash = (12 => 3);
343     open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp";
344
345     for $el (keys %hash) {
346         write(OUT12);
347     }
348     close OUT12 or die "Could not close: $!";
349     print cat('Op_write.tmp');
350
351 }
352
353 {
354     # Bug report and testcase by Alexey Tourbin
355     use Tie::Scalar;
356     my $v;
357     tie $v, 'Tie::StdScalar';
358     $v = 13;
359     format OUT13 =
360 ok ^<<<<<<<<< ~~
361 $v
362 .
363     open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp";
364     write(OUT13);
365     close OUT13 or die "Could not close: $!";
366     print cat('Op_write.tmp');
367 }
368
369 {   # test 14
370     # Bug #24774 format without trailing \n failed assertion, but this
371     # must fail since we have a trailing ; in the eval'ed string (WL)
372     my @v = ('k');
373     eval "format OUT14 = \n@\n\@v";
374     print +($@ && $@ =~ /Format not terminated/)
375       ? "ok 14\n" : "not ok 14 $@\n";
376
377 }
378
379 {   # test 15
380     # text lost in ^<<< field with \r in value (WL)
381     my $txt = "line 1\rline 2";
382     format OUT15 =
383 ^<<<<<<<<<<<<<<<<<<
384 $txt
385 ^<<<<<<<<<<<<<<<<<<
386 $txt
387 .
388     open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp";
389     write(OUT15);
390     close OUT15 or die "Could not close: $!";
391     my $res = cat('Op_write.tmp');
392     print $res eq "line 1\nline 2\n" ? "ok 15\n" : "not ok 15\n";
393 }
394
395 {   # test 16: multiple use of a variable in same line with ^<
396     my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4";
397     format OUT16 =
398 ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
399 $txt,             $txt
400 ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
401 $txt,             $txt
402 .
403     open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp";
404     write(OUT16);
405     close OUT16 or die "Could not close: $!";
406     my $res = cat('Op_write.tmp');
407     print $res eq <<EOD ? "ok 16\n" : "not ok 16\n";
408 this_is_block_1   this_is_block_2
409 this_is_block_3   this_is_block_4
410 EOD
411 }
412
413 {   # test 17: @* "should be on a line of its own", but it should work
414     # cleanly with literals before and after. (WL)
415
416     my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n";
417     format OUT17 =
418 Here we go: @* That's all, folks!
419             $txt
420 .
421     open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp";
422     write(OUT17);
423     close OUT17 or die "Could not close: $!";
424     my $res = cat('Op_write.tmp');
425     chomp( $txt );
426     my $exp = <<EOD;
427 Here we go: $txt That's all, folks!
428 EOD
429     print $res eq $exp ? "ok 17\n" : "not ok 17\n";
430 }
431
432 {   # test 18: @# and ~~ would cause runaway format, but we now
433     # catch this while compiling (WL)
434
435     format OUT18 =
436 @######## ~~
437 10
438 .
439     open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp";
440     eval { write(OUT18); };
441     print +($@ && $@ =~ /Repeated format line will never terminate/)
442       ? "ok 18\n" : "not ok 18: $@\n";
443     close OUT18 or die "Could not close: $!";
444 }
445
446 {   # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL)
447     my $v = 'gaga';
448     eval "format OUT19 = \n" .
449          '@<<<' . "\0\n" .
450          '$v' .   "\n" .
451          '@<<<' . "\0\n" .
452          '$v' . "\n.\n";
453     open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp";
454     write(OUT19);
455     close OUT19 or die "Could not close: $!";
456     my $res = cat('Op_write.tmp');
457     print $res eq <<EOD ? "ok 19\n" : "not ok 19\n";
458 gaga\0
459 gaga\0
460 EOD
461 }
462
463 {   # test 20: hash accesses; single '}' must not terminate format '}' (WL)
464     my %h = ( xkey => 'xval', ykey => 'yval' );
465     format OUT20 =
466 @>>>> @<<<< ~~
467 each %h
468 @>>>> @<<<<
469 $h{xkey}, $h{ykey}
470 @>>>> @<<<<
471 { $h{xkey}, $h{ykey}
472 }
473 }
474 .
475     my $exp = '';
476     while( my( $k, $v ) = each( %h ) ){
477         $exp .= sprintf( "%5s %s\n", $k, $v );
478     }
479     $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
480     $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
481     $exp .= "}\n";
482     open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp";
483     write(OUT20);
484     close OUT20 or die "Could not close: $!";
485     my $res = cat('Op_write.tmp');
486     print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n";
487 }
488
489
490 #####################
491 ## Section 2
492 ## numeric formatting
493 #####################
494
495 my $nt = $bas_tests;
496 for my $tref ( @NumTests ){
497     my $writefmt = shift( @$tref );
498     while (@$tref) {
499         my $val      = shift @$tref;
500         my $expected = shift @$tref;
501         my $writeres = swrite( $writefmt, $val );
502         $nt++;
503         my $ok = ref($expected)
504                  ? $writeres =~ $expected
505                  : $writeres eq $expected;
506         
507         print $ok
508             ? "ok $nt - $writefmt\n"
509             : "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n";
510     }
511 }
512
513
514 #####################################
515 ## Section 3
516 ## Easiest to add new tests just here
517 #######################################
518
519 curr_test($bas_tests + $num_tests + 1);
520
521 use strict;     # Amazed that this hackery can be made strict ...
522
523 # DAPM. Exercise a couple of error codepaths
524
525 {
526     local $~ = '';
527     eval { write };
528     like $@, qr/Not a format reference/, 'format reference';
529
530     $~ = "NOSUCHFORMAT";
531     eval { write };
532     like $@, qr/Undefined format/, 'no such format';
533 }
534
535
536 format EMPTY =
537 .
538
539 my $test = curr_test();
540
541 format Comment =
542 ok @<<<<<
543 $test
544 .
545
546
547 # [ID 20020227.005] format bug with undefined _TOP
548
549 open STDOUT_DUP, ">&STDOUT";
550 my $oldfh = select STDOUT_DUP;
551 $= = 10;
552 {
553   local $~ = "Comment";
554   write;
555   curr_test($test + 1);
556   {
557     local $::TODO = '[ID 20020227.005] format bug with undefined _TOP';
558     is $-, 9;
559   }
560   is $^, "STDOUT_DUP_TOP";
561 }
562 select $oldfh;
563 close STDOUT_DUP;
564
565 # scary format testing from H.Merijn Brand
566
567 # Just a complete test for format, including top-, left- and bottom marging
568 # and format detection through glob entries
569
570 if (1 || $^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' ||
571     ($^O eq 'os2' and not eval '$OS2::can_fork')) {
572   $test = curr_test();
573  SKIP: {
574       skip "'|-' and '-|' not supported", $tests - $test + 1;
575   }
576   exit(0);
577 }
578
579
580 $^  = "STDOUT_TOP";
581 $=  =  7;               # Page length
582 $-  =  0;               # Lines left
583 my $ps = $^L; $^L = ""; # Catch the page separator
584 my $tm =  1;            # Top margin (empty lines before first output)
585 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
586 my $lm =  4;            # Left margin (indent in spaces)
587
588 # -----------------------------------------------------------------------
589 #
590 # execute the rest of the script in a child process. The parent reads the
591 # output from the child and compares it with <DATA>.
592
593 my @data = <DATA>;
594
595 select ((select (STDOUT), $| = 1)[0]); # flush STDOUT
596
597 my $opened = open FROM_CHILD, "-|";
598 unless (defined $opened) {
599     fail "open gave $!";
600     exit 0;
601 }
602
603 if ($opened) {
604     # in parent here
605
606     pass 'open';
607     my $s = " " x $lm;
608     while (<FROM_CHILD>) {
609         unless (@data) {
610             fail 'too much output';
611             exit;
612         }
613         s/^/$s/;
614         my $exp = shift @data;
615         is $_, $exp;
616     }
617     close FROM_CHILD;
618     is "@data", "", "correct length of output";
619     exit;
620 }
621
622 # in child here
623 $::NO_ENDING = 1;
624
625     select ((select (STDOUT), $| = 1)[0]);
626 $tm = "\n" x $tm;
627 $= -= $bm + 1; # count one for the trailing "----"
628 my $lastmin = 0;
629
630 my @E;
631
632 sub wryte
633 {
634     $lastmin = $-;
635     write;
636     } # wryte;
637
638 sub footer
639 {
640     $% == 1 and return "";
641
642     $lastmin < $= and print "\n" x $lastmin;
643     print "\n" x $bm, "----\n", $ps;
644     $lastmin = $-;
645     "";
646     } # footer
647
648 # Yes, this is sick ;-)
649 format TOP =
650 @* ~
651 @{[footer]}
652 @* ~
653 $tm
654 .
655
656 format ENTRY =
657 @ @<<<<~~
658 @{(shift @E)||["",""]}
659 .
660
661 format EOR =
662 - -----
663 .
664
665 sub has_format ($)
666 {
667     my $fmt = shift;
668     exists $::{$fmt} or return 0;
669     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
670     open my $null, "> /dev/null" or die;
671     my $fh = select $null;
672     local $~ = $fmt;
673     eval "write";
674     select $fh;
675     $@?0:1;
676     } # has_format
677
678 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
679 has_format ("ENTRY") or die "No format defined for ENTRY";
680 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
681                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
682     @E = @$e;
683     local $~ = "ENTRY";
684     wryte;
685     has_format ("EOR") or next;
686     local $~ = "EOR";
687     wryte;
688     }
689 if (has_format ("EOF")) {
690     local $~ = "EOF";
691     wryte;
692     }
693
694 close STDOUT;
695
696 # That was test 48.
697
698 __END__
699     
700     1 Test1
701     2 Test2
702     3 Test3
703     
704     
705     ----
706     \f
707     4 Test4
708     5 Test5
709     6 Test6
710     
711     
712     ----
713     \f
714     7 Test7
715     - -----
716     
717     
718     
719     ----
720     \f
721     1 1tseT
722     2 2tseT
723     3 3tseT
724     
725     
726     ----
727     \f
728     4 4tseT
729     5 5tseT
730     - -----