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