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