This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
237c679c7092aab896d5c8545b326ae5046ca850
[perl5.git] / t / op / write.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7 }
8
9 use strict;     # Amazed that this hackery can be made strict ...
10
11 # read in a file
12 sub cat {
13     my $file = shift;
14     local $/;
15     open my $fh, $file or die "can't open '$file': $!";
16     my $data = <$fh>;
17     close $fh;
18     $data;
19 }
20
21 #-- testing numeric fields in all variants (WL)
22
23 sub swrite {
24     my $format = shift;
25     local $^A = ""; # don't litter, use a local bin
26     formline( $format, @_ );
27     return $^A;
28 }
29
30 my @NumTests = (
31     # [ format, value1, expected1, value2, expected2, .... ]
32     [ '@###',           0,   '   0',         1, '   1',     9999.6, '####',
33                 9999.4999,   '9999',    -999.6, '####',     1e+100, '####' ],
34
35     [ '@0##',           0,   '0000',         1, '0001',     9999.6, '####',
36                 -999.4999,   '-999',    -999.6, '####',     1e+100, '####' ],
37
38     [ '^###',           0,   '   0',     undef, '    ' ],
39
40     [ '^0##',           0,   '0000',     undef, '    ' ],
41
42     [ '@###.',          0,  '   0.',         1, '   1.',    9999.6, '#####',
43                 9999.4999,  '9999.',    -999.6, '#####' ],
44
45     [ '@##.##',         0, '  0.00',         1, '  1.00',  999.996, '######',
46                 999.99499, '999.99',      -100, '######' ],
47
48     [ '@0#.##',         0, '000.00',         1, '001.00',       10, '010.00',
49                   -0.0001, qr/^[\-0]00\.00$/ ],
50
51 );
52
53
54 my $num_tests = 0;
55 for my $tref ( @NumTests ){
56     $num_tests += (@$tref - 1)/2;
57 }
58 #---------------------------------------------------------
59
60 # number of tests in section 1
61 my $bas_tests = 20;
62
63 # number of tests in section 3
64 my $bug_tests = 4 + 3 * 3 * 5 * 2 * 3 + 2 + 2 + 1;
65
66 # number of tests in section 4
67 my $hmb_tests = 35;
68
69 my $tests = $bas_tests + $num_tests + $bug_tests + $hmb_tests;
70
71 plan $tests;
72
73 ############
74 ## Section 1
75 ############
76
77 use vars qw($fox $multiline $foo $good);
78
79 format OUT =
80 the quick brown @<<
81 $fox
82 jumped
83 @*
84 $multiline
85 ^<<<<<<<<<
86 $foo
87 ^<<<<<<<<<
88 $foo
89 ^<<<<<<...
90 $foo
91 now @<<the@>>>> for all@|||||men to come @<<<<
92 {
93     'i' . 's', "time\n", $good, 'to'
94 }
95 .
96
97 open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
98 END { 1 while unlink 'Op_write.tmp' }
99
100 $fox = 'foxiness';
101 $good = 'good';
102 $multiline = "forescore\nand\nseven years\n";
103 $foo = 'when in the course of human events it becomes necessary';
104 write(OUT);
105 close OUT or die "Could not close: $!";
106
107 my $right =
108 "the quick brown fox
109 jumped
110 forescore
111 and
112 seven years
113 when in
114 the course
115 of huma...
116 now is the time for all good men to come to\n";
117
118 is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp'; };
119
120 $fox = 'wolfishness';
121 my $fox = 'foxiness';           # Test a lexical variable.
122
123 format OUT2 =
124 the quick brown @<<
125 $fox
126 jumped
127 @*
128 $multiline
129 ^<<<<<<<<< ~~
130 $foo
131 now @<<the@>>>> for all@|||||men to come @<<<<
132 'i' . 's', "time\n", $good, 'to'
133 .
134
135 open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp";
136
137 $good = 'good';
138 $multiline = "forescore\nand\nseven years\n";
139 $foo = 'when in the course of human events it becomes necessary';
140 write(OUT2);
141 close OUT2 or die "Could not close: $!";
142
143 $right =
144 "the quick brown fox
145 jumped
146 forescore
147 and
148 seven years
149 when in
150 the course
151 of human
152 events it
153 becomes
154 necessary
155 now is the time for all good men to come to\n";
156
157 is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp'; };
158
159 eval <<'EOFORMAT';
160 format OUT2 =
161 the brown quick @<<
162 $fox
163 jumped
164 @*
165 $multiline
166 and
167 ^<<<<<<<<< ~~
168 $foo
169 now @<<the@>>>> for all@|||||men to come @<<<<
170 'i' . 's', "time\n", $good, 'to'
171 .
172 EOFORMAT
173
174 open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
175
176 $fox = 'foxiness';
177 $good = 'good';
178 $multiline = "forescore\nand\nseven years\n";
179 $foo = 'when in the course of human events it becomes necessary';
180 write(OUT2);
181 close OUT2 or die "Could not close: $!";
182
183 $right =
184 "the brown quick fox
185 jumped
186 forescore
187 and
188 seven years
189 and
190 when in
191 the course
192 of human
193 events it
194 becomes
195 necessary
196 now is the time for all good men to come to\n";
197
198 is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp' };
199
200 # formline tests
201
202 $right = <<EOT;
203 @ a
204 @> ab
205 @>> abc
206 @>>>  abc
207 @>>>>   abc
208 @>>>>>    abc
209 @>>>>>>     abc
210 @>>>>>>>      abc
211 @>>>>>>>>       abc
212 @>>>>>>>>>        abc
213 @>>>>>>>>>>         abc
214 EOT
215
216 my $was1 = my $was2 = '';
217 use vars '$format2';
218 for (0..10) {           
219   # lexical picture
220   $^A = '';
221   my $format1 = '@' . '>' x $_;
222   formline $format1, 'abc';
223   $was1 .= "$format1 $^A\n";
224   # global
225   $^A = '';
226   local $format2 = '@' . '>' x $_;
227   formline $format2, 'abc';
228   $was2 .= "$format2 $^A\n";
229 }
230 is $was1, $right;
231 is $was2, $right;
232
233 $^A = '';
234
235 # more test
236
237 format OUT3 =
238 ^<<<<<<...
239 $foo
240 .
241
242 open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";
243
244 $foo = 'fit          ';
245 write(OUT3);
246 close OUT3 or die "Could not close: $!";
247
248 $right =
249 "fit\n";
250
251 is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp' };
252
253
254 # test lexicals and globals
255 {
256     my $test = curr_test();
257     my $this = "ok";
258     our $that = $test;
259     format LEX =
260 @<<@|
261 $this,$that
262 .
263     open(LEX, ">&STDOUT") or die;
264     write LEX;
265     $that = ++$test;
266     write LEX;
267     close LEX or die "Could not close: $!";
268     curr_test($test + 1);
269 }
270 # LEX_INTERPNORMAL test
271 my %e = ( a => 1 );
272 format OUT4 =
273 @<<<<<<
274 "$e{a}"
275 .
276 open   OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
277 write (OUT4);
278 close  OUT4 or die "Could not close: $!";
279 is cat('Op_write.tmp'), "1\n" and do { 1 while unlink "Op_write.tmp" };
280
281 eval <<'EOFORMAT';
282 format OUT10 =
283 @####.## @0###.##
284 $test1, $test1
285 .
286 EOFORMAT
287
288 open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
289
290 use vars '$test1';
291 $test1 = 12.95;
292 write(OUT10);
293 close OUT10 or die "Could not close: $!";
294
295 $right = "   12.95 00012.95\n";
296 is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp' };
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 is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp' };
320
321 {
322     my $test = curr_test();
323     my $el;
324     format OUT12 =
325 ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze
326 $el
327 .
328     my %hash = ($test => 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     curr_test($test + 1);
337 }
338
339 {
340     my $test = curr_test();
341     # Bug report and testcase by Alexey Tourbin
342     use Tie::Scalar;
343     my $v;
344     tie $v, 'Tie::StdScalar';
345     $v = $test;
346     format OUT13 =
347 ok ^<<<<<<<<< ~~
348 $v
349 .
350     open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp";
351     write(OUT13);
352     close OUT13 or die "Could not close: $!";
353     print cat('Op_write.tmp');
354     curr_test($test + 1);
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     like $@, qr/Format not terminated/;
363 }
364
365 {   # test 15
366     # text lost in ^<<< field with \r in value (WL)
367     my $txt = "line 1\rline 2";
368     format OUT15 =
369 ^<<<<<<<<<<<<<<<<<<
370 $txt
371 ^<<<<<<<<<<<<<<<<<<
372 $txt
373 .
374     open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp";
375     write(OUT15);
376     close OUT15 or die "Could not close: $!";
377     my $res = cat('Op_write.tmp');
378     is $res, "line 1\nline 2\n";
379 }
380
381 {   # test 16: multiple use of a variable in same line with ^<
382     my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4";
383     format OUT16 =
384 ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
385 $txt,             $txt
386 ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
387 $txt,             $txt
388 .
389     open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp";
390     write(OUT16);
391     close OUT16 or die "Could not close: $!";
392     my $res = cat('Op_write.tmp');
393     is $res, <<EOD;
394 this_is_block_1   this_is_block_2
395 this_is_block_3   this_is_block_4
396 EOD
397 }
398
399 {   # test 17: @* "should be on a line of its own", but it should work
400     # cleanly with literals before and after. (WL)
401
402     my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n";
403     format OUT17 =
404 Here we go: @* That's all, folks!
405             $txt
406 .
407     open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp";
408     write(OUT17);
409     close OUT17 or die "Could not close: $!";
410     my $res = cat('Op_write.tmp');
411     chomp( $txt );
412     my $exp = <<EOD;
413 Here we go: $txt That's all, folks!
414 EOD
415     is $res, $exp;
416 }
417
418 {   # test 18: @# and ~~ would cause runaway format, but we now
419     # catch this while compiling (WL)
420
421     format OUT18 =
422 @######## ~~
423 10
424 .
425     open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp";
426     eval { write(OUT18); };
427     like $@,  qr/Repeated format line will never terminate/;
428     close OUT18 or die "Could not close: $!";
429 }
430
431 {   # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL)
432     my $v = 'gaga';
433     eval "format OUT19 = \n" .
434          '@<<<' . "\0\n" .
435          '$v' .   "\n" .
436          '@<<<' . "\0\n" .
437          '$v' . "\n.\n";
438     open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp";
439     write(OUT19);
440     close OUT19 or die "Could not close: $!";
441     my $res = cat('Op_write.tmp');
442     is $res, <<EOD;
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     close OUT20 or die "Could not close: $!";
470     my $res = cat('Op_write.tmp');
471     is $res, $exp;
472 }
473
474
475 #####################
476 ## Section 2
477 ## numeric formatting
478 #####################
479
480 curr_test($bas_tests + 1);
481
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         if (ref $expected) {
489             like $writeres, $expected, $writefmt;
490         } else {
491             is $writeres, $expected, $writefmt;
492         }       
493     }
494 }
495
496
497 #####################################
498 ## Section 3
499 ## Easiest to add new tests just here
500 #####################################
501
502 # DAPM. Exercise a couple of error codepaths
503
504 {
505     local $~ = '';
506     eval { write };
507     like $@, qr/Not a format reference/, 'format reference';
508
509     $~ = "NOSUCHFORMAT";
510     eval { write };
511     like $@, qr/Undefined format/, 'no such format';
512 }
513
514 {
515   package Count;
516
517   sub TIESCALAR {
518     my $class = shift;
519     bless [shift, 0, 0], $class;
520   }
521
522   sub FETCH {
523     my $self = shift;
524     ++$self->[1];
525     $self->[0];
526   }
527
528   sub STORE {
529     my $self = shift;
530     ++$self->[2];
531     $self->[0] = shift;
532   }
533 }
534
535 {
536   my ($pound_utf8, $pm_utf8) = map { my $a = "$_\x{100}"; chop $a; $a}
537     my ($pound, $pm) = ("\xA3", "\xB1");
538
539   foreach my $first ('N', $pound, $pound_utf8) {
540     foreach my $base ('N', $pm, $pm_utf8) {
541       foreach my $second ($base, "$base\n", "$base\nMoo!", "$base\nMoo!\n",
542                           "$base\nMoo!\n",) {
543         foreach (['^*', qr/(.+)/], ['@*', qr/(.*?)$/s]) {
544           my ($format, $re) = @$_;
545           foreach my $class ('', 'Count') {
546             my $name = "$first, $second $format $class";
547             $name =~ s/\n/\\n/g;
548
549             $first =~ /(.+)/ or die $first;
550             my $expect = "1${1}2";
551             $second =~ $re or die $second;
552             $expect .= " 3${1}4";
553
554             if ($class) {
555               my $copy1 = $first;
556               my $copy2;
557               tie $copy2, $class, $second;
558               is swrite("1^*2 3${format}4", $copy1, $copy2), $expect, $name;
559               my $obj = tied $copy2;
560               is $obj->[1], 1, 'value read exactly once';
561             } else {
562               my ($copy1, $copy2) = ($first, $second);
563               is swrite("1^*2 3${format}4", $copy1, $copy2), $expect, $name;
564             }
565           }
566         }
567       }
568     }
569   }
570 }
571
572 {
573   # This will fail an assertion in 5.10.0 built with -DDEBUGGING (because
574   # pp_formline attempts to set SvCUR() on an SVt_RV). I suspect that it will
575   # be doing something similarly out of bounds on everything from 5.000
576   my $ref = [];
577   is swrite('>^*<', $ref), ">$ref<";
578   is swrite('>@*<', $ref), ">$ref<";
579 }
580
581 format EMPTY =
582 .
583
584 my $test = curr_test();
585
586 format Comment =
587 ok @<<<<<
588 $test
589 .
590
591
592 # [ID 20020227.005] format bug with undefined _TOP
593
594 open STDOUT_DUP, ">&STDOUT";
595 my $oldfh = select STDOUT_DUP;
596 $= = 10;
597 {
598   local $~ = "Comment";
599   write;
600   curr_test($test + 1);
601   {
602     local $::TODO = '[ID 20020227.005] format bug with undefined _TOP';
603     is $-, 9;
604   }
605   is $^, "STDOUT_DUP_TOP";
606 }
607 select $oldfh;
608 close STDOUT_DUP;
609
610 *CmT =  *{$::{Comment}}{FORMAT};
611 ok  defined *{$::{CmT}}{FORMAT}, "glob assign";
612
613 {   my $buf = "";
614     open my $fh, ">", \$buf;
615     my $old_fh = select $fh;
616     local $~ = "CmT";
617     write;
618     select $old_fh;
619     close $fh;
620     is $buf, "ok $test\n", "write to duplicated format";
621 }
622
623 fresh_perl_like(<<'EOP', qr/^Format STDOUT redefined at/, {stderr => 1}, '#64562 - Segmentation fault with redefined formats and warnings');
624 #!./perl
625
626 use strict;
627 use warnings; # crashes!
628
629 format =
630 .
631
632 write;
633
634 format =
635 .
636
637 write;
638 EOP
639
640 #############################
641 ## Section 4
642 ## Add new tests *above* here
643 #############################
644
645 # scary format testing from H.Merijn Brand
646
647 # Just a complete test for format, including top-, left- and bottom marging
648 # and format detection through glob entries
649
650 if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' ||
651     ($^O eq 'os2' and not eval '$OS2::can_fork')) {
652   $test = curr_test();
653  SKIP: {
654       skip "'|-' and '-|' not supported", $tests - $test + 1;
655   }
656   exit(0);
657 }
658
659
660 $^  = "STDOUT_TOP";
661 $=  =  7;               # Page length
662 $-  =  0;               # Lines left
663 my $ps = $^L; $^L = ""; # Catch the page separator
664 my $tm =  1;            # Top margin (empty lines before first output)
665 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
666 my $lm =  4;            # Left margin (indent in spaces)
667
668 # -----------------------------------------------------------------------
669 #
670 # execute the rest of the script in a child process. The parent reads the
671 # output from the child and compares it with <DATA>.
672
673 my @data = <DATA>;
674
675 select ((select (STDOUT), $| = 1)[0]); # flush STDOUT
676
677 my $opened = open FROM_CHILD, "-|";
678 unless (defined $opened) {
679     fail "open gave $!";
680     exit 0;
681 }
682
683 if ($opened) {
684     # in parent here
685
686     pass 'open';
687     my $s = " " x $lm;
688     while (<FROM_CHILD>) {
689         unless (@data) {
690             fail 'too much output';
691             exit;
692         }
693         s/^/$s/;
694         my $exp = shift @data;
695         is $_, $exp;
696     }
697     close FROM_CHILD;
698     is "@data", "", "correct length of output";
699     exit;
700 }
701
702 # in child here
703 $::NO_ENDING = 1;
704
705     select ((select (STDOUT), $| = 1)[0]);
706 $tm = "\n" x $tm;
707 $= -= $bm + 1; # count one for the trailing "----"
708 my $lastmin = 0;
709
710 my @E;
711
712 sub wryte
713 {
714     $lastmin = $-;
715     write;
716     } # wryte;
717
718 sub footer
719 {
720     $% == 1 and return "";
721
722     $lastmin < $= and print "\n" x $lastmin;
723     print "\n" x $bm, "----\n", $ps;
724     $lastmin = $-;
725     "";
726     } # footer
727
728 # Yes, this is sick ;-)
729 format TOP =
730 @* ~
731 @{[footer]}
732 @* ~
733 $tm
734 .
735
736 format ENTRY =
737 @ @<<<<~~
738 @{(shift @E)||["",""]}
739 .
740
741 format EOR =
742 - -----
743 .
744
745 sub has_format ($)
746 {
747     my $fmt = shift;
748     exists $::{$fmt} or return 0;
749     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
750     open my $null, "> /dev/null" or die;
751     my $fh = select $null;
752     local $~ = $fmt;
753     eval "write";
754     select $fh;
755     $@?0:1;
756     } # has_format
757
758 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
759 has_format ("ENTRY") or die "No format defined for ENTRY";
760 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
761                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
762     @E = @$e;
763     local $~ = "ENTRY";
764     wryte;
765     has_format ("EOR") or next;
766     local $~ = "EOR";
767     wryte;
768     }
769 if (has_format ("EOF")) {
770     local $~ = "EOF";
771     wryte;
772     }
773
774 close STDOUT;
775
776 # That was test 48.
777
778 __END__
779     
780     1 Test1
781     2 Test2
782     3 Test3
783     
784     
785     ----
786     \f
787     4 Test4
788     5 Test5
789     6 Test6
790     
791     
792     ----
793     \f
794     7 Test7
795     - -----
796     
797     
798     
799     ----
800     \f
801     1 1tseT
802     2 2tseT
803     3 3tseT
804     
805     
806     ----
807     \f
808     4 4tseT
809     5 5tseT
810     - -----