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