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