This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix typo in patch #22188
[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
535 # [ID 20020227.005] format bug with undefined _TOP
536
537 open STDOUT_DUP, ">&STDOUT";
538 my $oldfh = select STDOUT_DUP;
539 $= = 10;
540 {   local $~ = "Comment";
541     write;
542     $test++;
543     print $- == 9
544         ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n";
545     $test++;
546     print $^ eq "STDOUT_DUP_TOP"
547         ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n";
548     $test++;
549 }
550 select $oldfh;
551
552 $^  = "STDOUT_TOP";
553 $=  =  7;               # Page length
554 $-  =  0;               # Lines left
555 my $ps = $^L; $^L = ""; # Catch the page separator
556 my $tm =  1;            # Top margin (empty lines before first output)
557 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
558 my $lm =  4;            # Left margin (indent in spaces)
559
560 select ((select (STDOUT), $| = 1)[0]);
561 if ($lm > 0 and !open STDOUT, "|-") {   # Left margin (in this test ALWAYS set)
562     select ((select (STDOUT), $| = 1)[0]);
563     my $s = " " x $lm;
564     while (<STDIN>) {
565         s/^/$s/;
566         print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n";
567         }
568     close STDIN;
569     print + (<DATA>?"not ":""), "ok ", $test++, "\n";
570     close STDOUT;
571     exit;
572     }
573 $tm = "\n" x $tm;
574 $= -= $bm + 1; # count one for the trailing "----"
575 my $lastmin = 0;
576
577 my @E;
578
579 sub wryte
580 {
581     $lastmin = $-;
582     write;
583     } # wryte;
584
585 sub footer
586 {
587     $% == 1 and return "";
588
589     $lastmin < $= and print "\n" x $lastmin;
590     print "\n" x $bm, "----\n", $ps;
591     $lastmin = $-;
592     "";
593     } # footer
594
595 # Yes, this is sick ;-)
596 format TOP =
597 @* ~
598 @{[footer]}
599 @* ~
600 $tm
601 .
602
603 format ENTRY =
604 @ @<<<<~~
605 @{(shift @E)||["",""]}
606 .
607
608 format EOR =
609 - -----
610 .
611
612 sub has_format ($)
613 {
614     my $fmt = shift;
615     exists $::{$fmt} or return 0;
616     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
617     open my $null, "> /dev/null" or die;
618     my $fh = select $null;
619     local $~ = $fmt;
620     eval "write";
621     select $fh;
622     $@?0:1;
623     } # has_format
624
625 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
626 has_format ("ENTRY") or die "No format defined for ENTRY";
627 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
628                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
629     @E = @$e;
630     local $~ = "ENTRY";
631     wryte;
632     has_format ("EOR") or next;
633     local $~ = "EOR";
634     wryte;
635     }
636 if (has_format ("EOF")) {
637     local $~ = "EOF";
638     wryte;
639     }
640
641 close STDOUT;
642
643 # That was test 48.
644
645 __END__
646     
647     1 Test1
648     2 Test2
649     3 Test3
650     
651     
652     ----
653     \f
654     4 Test4
655     5 Test5
656     6 Test6
657     
658     
659     ----
660     \f
661     7 Test7
662     - -----
663     
664     
665     
666     ----
667     \f
668     1 1tseT
669     2 2tseT
670     3 3tseT
671     
672     
673     ----
674     \f
675     4 4tseT
676     5 5tseT
677     - -----