This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix write test: -small_number may be displayed as 00.00 or -0.00
[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, qr/^[\-0]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         my $ok = ref($expected)
490                  ? $writeres =~ $expected
491                  : $writeres eq $expected;
492         
493         print $ok
494             ? "ok $nt\n"
495             : "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n";
496     }
497 }
498
499
500 #####################################
501 ## Section 3
502 ## Easiest to add new tests above here
503 #######################################
504
505 # scary format testing from H.Merijn Brand
506
507 my $test = $bas_tests + $num_tests + 1;
508 my $tests = $bas_tests + $num_tests + $hmb_tests;
509
510 if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' ||
511     ($^O eq 'os2' and not eval '$OS2::can_fork')) {
512   foreach ($test..$tests) {
513       print "ok $_ # skipped: '|-' and '-|' not supported\n";
514   }
515   exit(0);
516 }
517
518
519 use strict;     # Amazed that this hackery can be made strict ...
520
521 # Just a complete test for format, including top-, left- and bottom marging
522 # and format detection through glob entries
523
524 format EMPTY =
525 .
526
527 format Comment =
528 ok @<<<<<
529 $test
530 .
531
532
533 # [ID 20020227.005] format bug with undefined _TOP
534
535 open STDOUT_DUP, ">&STDOUT";
536 my $oldfh = select STDOUT_DUP;
537 $= = 10;
538 {   local $~ = "Comment";
539     write;
540     $test++;
541     print $- == 9
542         ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n";
543     $test++;
544     print $^ eq "STDOUT_DUP_TOP"
545         ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n";
546     $test++;
547 }
548 select $oldfh;
549
550 $^  = "STDOUT_TOP";
551 $=  =  7;               # Page length
552 $-  =  0;               # Lines left
553 my $ps = $^L; $^L = ""; # Catch the page separator
554 my $tm =  1;            # Top margin (empty lines before first output)
555 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
556 my $lm =  4;            # Left margin (indent in spaces)
557
558 select ((select (STDOUT), $| = 1)[0]);
559 if ($lm > 0 and !open STDOUT, "|-") {   # Left margin (in this test ALWAYS set)
560     select ((select (STDOUT), $| = 1)[0]);
561     my $s = " " x $lm;
562     while (<STDIN>) {
563         s/^/$s/;
564         print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n";
565         }
566     close STDIN;
567     print + (<DATA>?"not ":""), "ok ", $test++, "\n";
568     close STDOUT;
569     exit;
570     }
571 $tm = "\n" x $tm;
572 $= -= $bm + 1; # count one for the trailing "----"
573 my $lastmin = 0;
574
575 my @E;
576
577 sub wryte
578 {
579     $lastmin = $-;
580     write;
581     } # wryte;
582
583 sub footer
584 {
585     $% == 1 and return "";
586
587     $lastmin < $= and print "\n" x $lastmin;
588     print "\n" x $bm, "----\n", $ps;
589     $lastmin = $-;
590     "";
591     } # footer
592
593 # Yes, this is sick ;-)
594 format TOP =
595 @* ~
596 @{[footer]}
597 @* ~
598 $tm
599 .
600
601 format ENTRY =
602 @ @<<<<~~
603 @{(shift @E)||["",""]}
604 .
605
606 format EOR =
607 - -----
608 .
609
610 sub has_format ($)
611 {
612     my $fmt = shift;
613     exists $::{$fmt} or return 0;
614     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
615     open my $null, "> /dev/null" or die;
616     my $fh = select $null;
617     local $~ = $fmt;
618     eval "write";
619     select $fh;
620     $@?0:1;
621     } # has_format
622
623 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
624 has_format ("ENTRY") or die "No format defined for ENTRY";
625 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
626                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
627     @E = @$e;
628     local $~ = "ENTRY";
629     wryte;
630     has_format ("EOR") or next;
631     local $~ = "EOR";
632     wryte;
633     }
634 if (has_format ("EOF")) {
635     local $~ = "EOF";
636     wryte;
637     }
638
639 close STDOUT;
640
641 # That was test 48.
642
643 __END__
644     
645     1 Test1
646     2 Test2
647     3 Test3
648     
649     
650     ----
651     \f
652     4 Test4
653     5 Test5
654     6 Test6
655     
656     
657     ----
658     \f
659     7 Test7
660     - -----
661     
662     
663     
664     ----
665     \f
666     1 1tseT
667     2 2tseT
668     3 3tseT
669     
670     
671     ----
672     \f
673     4 4tseT
674     5 5tseT
675     - -----