This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
9f0e66b5191427dfc2f8b25f185f84482c3e50f9
[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 = 36;
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 $@ ? "ok 14\n" : "not ok 14\n";
369
370 }
371
372 {   # test 15
373     # text lost in ^<<< field with \r in value (WL)
374     my $txt = "line 1\rline 2";
375     format OUT15 =
376 ^<<<<<<<<<<<<<<<<<<
377 $txt
378 ^<<<<<<<<<<<<<<<<<<
379 $txt
380 .
381     open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp";
382     write(OUT15);
383     close OUT15 or die "Could not close: $!";
384     my $res = cat('Op_write.tmp');
385     print $res eq "line 1\nline 2\n" ? "ok 15\n" : "not ok 15\n";
386 }
387
388 {   # test 16: multiple use of a variable in same line with ^<
389     my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4";
390     format OUT16 =
391 ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
392 $txt,             $txt
393 ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
394 $txt,             $txt
395 .
396     open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp";
397     write(OUT16);
398     close OUT16 or die "Could not close: $!";
399     my $res = cat('Op_write.tmp');
400     print $res eq <<EOD ? "ok 16\n" : "not ok 16\n";
401 this_is_block_1   this_is_block_2
402 this_is_block_3   this_is_block_4
403 EOD
404 }
405
406 {   # test 17: @* "should be on a line of its own", but it should work
407     # cleanly with literals before and after. (WL)
408
409     my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n";
410     format OUT17 =
411 Here we go: @* That's all, folks!
412             $txt
413 .
414     open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp";
415     write(OUT17);
416     close OUT17 or die "Could not close: $!";
417     my $res = cat('Op_write.tmp');
418     chomp( $txt );
419     my $exp = <<EOD;
420 Here we go: $txt That's all, folks!
421 EOD
422     print $res eq $exp ? "ok 17\n" : "not ok 17\n";
423 }
424
425 {   # test 18: @# and ~~ would cause runaway format, but we now
426     # catch this while compiling (WL)
427
428     format OUT18 =
429 @######## ~~
430 10
431 .
432     open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp";
433     eval { write(OUT18); };
434     print $@ ? "ok 18\n" : "not ok 18\n";
435     close OUT18 or die "Could not close: $!";
436 }
437
438 {   # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL)
439     my $v = 'gaga';
440     eval "format OUT19 = \n" .
441          '@<<<' . "\0\n" .
442          '$v' .   "\n" .
443          '@<<<' . "\0\n" .
444          '$v' . "\n.\n";
445     open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp";
446     write(OUT19);
447     close OUT19 or die "Could not close: $!";
448     my $res = cat('Op_write.tmp');
449     print $res eq <<EOD ? "ok 19\n" : "not ok 19\n";
450 gaga\0
451 gaga\0
452 EOD
453 }
454
455 {   # test 20: hash accesses; single '}' must not terminate format '}' (WL)
456     my %h = ( xkey => 'xval', ykey => 'yval' );
457     format OUT20 =
458 @>>>> @<<<< ~~
459 each %h
460 @>>>> @<<<<
461 $h{xkey}, $h{ykey}
462 @>>>> @<<<<
463 { $h{xkey}, $h{ykey}
464 }
465 }
466 .
467     my $exp = '';
468     while( my( $k, $v ) = each( %h ) ){
469         $exp .= sprintf( "%5s %s\n", $k, $v );
470     }
471     $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
472     $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
473     $exp .= "}\n";
474     open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp";
475     write(OUT20);
476     close OUT20 or die "Could not close: $!";
477     my $res = cat('Op_write.tmp');
478     print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n";
479 }
480
481
482 #####################
483 ## Section 2
484 ## numeric formatting
485 #####################
486
487 my $nt = $bas_tests;
488 for my $tref ( @NumTests ){
489     my $writefmt = shift( @$tref );
490     while (@$tref) {
491         my $val      = shift @$tref;
492         my $expected = shift @$tref;
493         my $writeres = swrite( $writefmt, $val );
494         $nt++;
495         my $ok = ref($expected)
496                  ? $writeres =~ $expected
497                  : $writeres eq $expected;
498         
499         print $ok
500             ? "ok $nt\n"
501             : "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n";
502     }
503 }
504
505
506 #####################################
507 ## Section 3
508 ## Easiest to add new tests above here
509 #######################################
510
511 # scary format testing from H.Merijn Brand
512
513 my $test = $bas_tests + $num_tests + 1;
514 my $tests = $bas_tests + $num_tests + $hmb_tests;
515
516 if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' ||
517     ($^O eq 'os2' and not eval '$OS2::can_fork')) {
518   foreach ($test..$tests) {
519       print "ok $_ # skipped: '|-' and '-|' not supported\n";
520   }
521   exit(0);
522 }
523
524
525 use strict;     # Amazed that this hackery can be made strict ...
526
527 # Just a complete test for format, including top-, left- and bottom marging
528 # and format detection through glob entries
529
530 format EMPTY =
531 .
532
533 format Comment =
534 ok @<<<<<
535 $test
536 .
537
538
539 # [ID 20020227.005] format bug with undefined _TOP
540
541 open STDOUT_DUP, ">&STDOUT";
542 my $oldfh = select STDOUT_DUP;
543 $= = 10;
544 {   local $~ = "Comment";
545     write;
546     $test++;
547     print $- == 9
548         ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n";
549     $test++;
550     print $^ eq "STDOUT_DUP_TOP"
551         ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n";
552     $test++;
553 }
554 select $oldfh;
555
556 $^  = "STDOUT_TOP";
557 $=  =  7;               # Page length
558 $-  =  0;               # Lines left
559 my $ps = $^L; $^L = ""; # Catch the page separator
560 my $tm =  1;            # Top margin (empty lines before first output)
561 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
562 my $lm =  4;            # Left margin (indent in spaces)
563
564 select ((select (STDOUT), $| = 1)[0]);
565 if ($lm > 0 and !open STDOUT, "|-") {   # Left margin (in this test ALWAYS set)
566     select ((select (STDOUT), $| = 1)[0]);
567     my $s = " " x $lm;
568     while (<STDIN>) {
569         s/^/$s/;
570         print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n";
571         }
572     close STDIN;
573     print + (<DATA>?"not ":""), "ok ", $test++, "\n";
574     close STDOUT;
575     exit;
576     }
577 $tm = "\n" x $tm;
578 $= -= $bm + 1; # count one for the trailing "----"
579 my $lastmin = 0;
580
581 my @E;
582
583 sub wryte
584 {
585     $lastmin = $-;
586     write;
587     } # wryte;
588
589 sub footer
590 {
591     $% == 1 and return "";
592
593     $lastmin < $= and print "\n" x $lastmin;
594     print "\n" x $bm, "----\n", $ps;
595     $lastmin = $-;
596     "";
597     } # footer
598
599 # Yes, this is sick ;-)
600 format TOP =
601 @* ~
602 @{[footer]}
603 @* ~
604 $tm
605 .
606
607 format ENTRY =
608 @ @<<<<~~
609 @{(shift @E)||["",""]}
610 .
611
612 format EOR =
613 - -----
614 .
615
616 sub has_format ($)
617 {
618     my $fmt = shift;
619     exists $::{$fmt} or return 0;
620     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
621     open my $null, "> /dev/null" or die;
622     my $fh = select $null;
623     local $~ = $fmt;
624     eval "write";
625     select $fh;
626     $@?0:1;
627     } # has_format
628
629 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
630 has_format ("ENTRY") or die "No format defined for ENTRY";
631 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
632                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
633     @E = @$e;
634     local $~ = "ENTRY";
635     wryte;
636     has_format ("EOR") or next;
637     local $~ = "EOR";
638     wryte;
639     }
640 if (has_format ("EOF")) {
641     local $~ = "EOF";
642     wryte;
643     }
644
645 close STDOUT;
646
647 # That was test 48.
648
649 __END__
650     
651     1 Test1
652     2 Test2
653     3 Test3
654     
655     
656     ----
657     \f
658     4 Test4
659     5 Test5
660     6 Test6
661     
662     
663     ----
664     \f
665     7 Test7
666     - -----
667     
668     
669     
670     ----
671     \f
672     1 1tseT
673     2 2tseT
674     3 3tseT
675     
676     
677     ----
678     \f
679     4 4tseT
680     5 5tseT
681     - -----