This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Prevent double frees/crashes with format syntax errs
[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 = 21;
62
63 # number of tests in section 3
64 my $bug_tests = 8 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3 + 96 + 7;
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 { unlink_all '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 unlink_all '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 unlink_all '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 unlink_all '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 unlink_all '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 unlink_all "Op_write.tmp";
280
281 # More LEX_INTERPNORMAL
282 format OUT4a=
283 @<<<<<<<<<<<<<<<
284 "${; use
285      strict; \'Nasdaq dropping like flies'}"
286 .
287 open   OUT4a, ">Op_write.tmp" or die "Can't create Op_write.tmp";
288 write (OUT4a);
289 close  OUT4a or die "Could not close: $!";
290 is cat('Op_write.tmp'), "Nasdaq dropping\n", 'skipspace inside "${...}"'
291     and unlink_all "Op_write.tmp";
292
293 eval <<'EOFORMAT';
294 format OUT10 =
295 @####.## @0###.##
296 $test1, $test1
297 .
298 EOFORMAT
299
300 open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
301
302 use vars '$test1';
303 $test1 = 12.95;
304 write(OUT10);
305 close OUT10 or die "Could not close: $!";
306
307 $right = "   12.95 00012.95\n";
308 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
309
310 eval <<'EOFORMAT';
311 format OUT11 =
312 @0###.## 
313 $test1
314 @ 0#
315 $test1
316 @0 # 
317 $test1
318 .
319 EOFORMAT
320
321 open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";
322
323 $test1 = 12.95;
324 write(OUT11);
325 close OUT11 or die "Could not close: $!";
326
327 $right = 
328 "00012.95
329 1 0#
330 10 #\n";
331 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
332
333 {
334     my $test = curr_test();
335     my $el;
336     format OUT12 =
337 ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze
338 $el
339 .
340     my %hash = ($test => 3);
341     open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp";
342
343     for $el (keys %hash) {
344         write(OUT12);
345     }
346     close OUT12 or die "Could not close: $!";
347     print cat('Op_write.tmp');
348     curr_test($test + 1);
349 }
350
351 {
352     my $test = curr_test();
353     # Bug report and testcase by Alexey Tourbin
354     use Tie::Scalar;
355     my $v;
356     tie $v, 'Tie::StdScalar';
357     $v = $test;
358     format OUT13 =
359 ok ^<<<<<<<<< ~~
360 $v
361 .
362     open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp";
363     write(OUT13);
364     close OUT13 or die "Could not close: $!";
365     print cat('Op_write.tmp');
366     curr_test($test + 1);
367 }
368
369 {   # test 14
370     # Bug #24774 format without trailing \n failed assertion, but this
371     # must fail since we have a trailing ; in the eval'ed string (WL)
372     my @v = ('k');
373     eval "format OUT14 = \n@\n\@v";
374     like $@, qr/Format not terminated/;
375 }
376
377 {   # test 15
378     # text lost in ^<<< field with \r in value (WL)
379     my $txt = "line 1\rline 2";
380     format OUT15 =
381 ^<<<<<<<<<<<<<<<<<<
382 $txt
383 ^<<<<<<<<<<<<<<<<<<
384 $txt
385 .
386     open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp";
387     write(OUT15);
388     close OUT15 or die "Could not close: $!";
389     my $res = cat('Op_write.tmp');
390     is $res, "line 1\nline 2\n";
391 }
392
393 {   # test 16: multiple use of a variable in same line with ^<
394     my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4";
395     format OUT16 =
396 ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
397 $txt,             $txt
398 ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
399 $txt,             $txt
400 .
401     open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp";
402     write(OUT16);
403     close OUT16 or die "Could not close: $!";
404     my $res = cat('Op_write.tmp');
405     is $res, <<EOD;
406 this_is_block_1   this_is_block_2
407 this_is_block_3   this_is_block_4
408 EOD
409 }
410
411 {   # test 17: @* "should be on a line of its own", but it should work
412     # cleanly with literals before and after. (WL)
413
414     my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n";
415     format OUT17 =
416 Here we go: @* That's all, folks!
417             $txt
418 .
419     open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp";
420     write(OUT17);
421     close OUT17 or die "Could not close: $!";
422     my $res = cat('Op_write.tmp');
423     chomp( $txt );
424     my $exp = <<EOD;
425 Here we go: $txt That's all, folks!
426 EOD
427     is $res, $exp;
428 }
429
430 {   # test 18: @# and ~~ would cause runaway format, but we now
431     # catch this while compiling (WL)
432
433     format OUT18 =
434 @######## ~~
435 10
436 .
437     open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp";
438     eval { write(OUT18); };
439     like $@,  qr/Repeated format line will never terminate/;
440     close OUT18 or die "Could not close: $!";
441 }
442
443 {   # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL)
444     my $v = 'gaga';
445     eval "format OUT19 = \n" .
446          '@<<<' . "\0\n" .
447          '$v' .   "\n" .
448          '@<<<' . "\0\n" .
449          '$v' . "\n.\n";
450     open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp";
451     write(OUT19);
452     close OUT19 or die "Could not close: $!";
453     my $res = cat('Op_write.tmp');
454     is $res, <<EOD;
455 gaga\0
456 gaga\0
457 EOD
458 }
459
460 {   # test 20: hash accesses; single '}' must not terminate format '}' (WL)
461     my %h = ( xkey => 'xval', ykey => 'yval' );
462     format OUT20 =
463 @>>>> @<<<< ~~
464 each %h
465 @>>>> @<<<<
466 $h{xkey}, $h{ykey}
467 @>>>> @<<<<
468 { $h{xkey}, $h{ykey}
469 }
470 }
471 .
472     my $exp = '';
473     while( my( $k, $v ) = each( %h ) ){
474         $exp .= sprintf( "%5s %s\n", $k, $v );
475     }
476     $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
477     $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
478     $exp .= "}\n";
479     open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp";
480     write(OUT20);
481     close OUT20 or die "Could not close: $!";
482     my $res = cat('Op_write.tmp');
483     is $res, $exp;
484 }
485
486
487 #####################
488 ## Section 2
489 ## numeric formatting
490 #####################
491
492 curr_test($bas_tests + 1);
493
494 for my $tref ( @NumTests ){
495     my $writefmt = shift( @$tref );
496     while (@$tref) {
497         my $val      = shift @$tref;
498         my $expected = shift @$tref;
499         my $writeres = swrite( $writefmt, $val );
500         if (ref $expected) {
501             like $writeres, $expected, $writefmt;
502         } else {
503             is $writeres, $expected, $writefmt;
504         }       
505     }
506 }
507
508
509 #####################################
510 ## Section 3
511 ## Easiest to add new tests just here
512 #####################################
513
514 # DAPM. Exercise a couple of error codepaths
515
516 {
517     local $~ = '';
518     eval { write };
519     like $@, qr/Undefined format ""/, 'format with 0-length name';
520
521     $~ = "\0foo";
522     eval { write };
523     like $@, qr/Undefined format "\0foo"/,
524         'no such format beginning with null';
525
526     $~ = "NOSUCHFORMAT";
527     eval { write };
528     like $@, qr/Undefined format "NOSUCHFORMAT"/, 'no such format';
529 }
530
531 select +(select(OUT21), do {
532     open(OUT21, '>Op_write.tmp') || die "Can't create Op_write.tmp";
533
534     format OUT21 =
535 @<<
536 $_
537 .
538
539     local $^ = '';
540     local $= = 1;
541     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
542     like $@, qr/Undefined top format ""/, 'top format with 0-length name';
543
544     $^ = "\0foo";
545     # For some reason, we have to do this twice to get the error again.
546     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
547     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
548     like $@, qr/Undefined top format "\0foo"/,
549         'no such top format beginning with null';
550
551     $^ = "NOSUCHFORMAT";
552     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
553     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
554     like $@, qr/Undefined top format "NOSUCHFORMAT"/, 'no such top format';
555
556     # reset things;
557     eval { write(OUT21) };
558     undef $^A;
559
560     close OUT21 or die "Could not close: $!";
561 })[0];
562
563 {
564   package Count;
565
566   sub TIESCALAR {
567     my $class = shift;
568     bless [shift, 0, 0], $class;
569   }
570
571   sub FETCH {
572     my $self = shift;
573     ++$self->[1];
574     $self->[0];
575   }
576
577   sub STORE {
578     my $self = shift;
579     ++$self->[2];
580     $self->[0] = shift;
581   }
582 }
583
584 {
585   my ($pound_utf8, $pm_utf8) = map { my $a = "$_\x{100}"; chop $a; $a}
586     my ($pound, $pm) = ("\xA3", "\xB1");
587
588   foreach my $first ('N', $pound, $pound_utf8) {
589     foreach my $base ('N', $pm, $pm_utf8) {
590       foreach my $second ($base, "$base\n", "$base\nMoo!", "$base\nMoo!\n",
591                           "$base\nMoo!\n",) {
592         foreach (['^*', qr/(.+)/], ['@*', qr/(.*?)$/s]) {
593           my ($format, $re) = @$_;
594           $format = "1^*2 3${format}4";
595           foreach my $class ('', 'Count') {
596             my $name = qq{swrite("$format", "$first", "$second") class="$class"};
597             $name =~ s/\n/\\n/g;
598             $name =~ s{(.)}{
599                         ord($1) > 126 ? sprintf("\\x{%x}",ord($1)) : $1
600                     }ge;
601
602             $first =~ /(.+)/ or die $first;
603             my $expect = "1${1}2";
604             $second =~ $re or die $second;
605             $expect .= " 3${1}4";
606
607             if ($class) {
608               my $copy1 = $first;
609               my $copy2;
610               tie $copy2, $class, $second;
611               is swrite("$format", $copy1, $copy2), $expect, $name;
612               my $obj = tied $copy2;
613               is $obj->[1], 1, 'value read exactly once';
614             } else {
615               my ($copy1, $copy2) = ($first, $second);
616               is swrite("$format", $copy1, $copy2), $expect, $name;
617             }
618           }
619         }
620       }
621     }
622   }
623 }
624
625 {
626   # This will fail an assertion in 5.10.0 built with -DDEBUGGING (because
627   # pp_formline attempts to set SvCUR() on an SVt_RV). I suspect that it will
628   # be doing something similarly out of bounds on everything from 5.000
629   my $ref = [];
630   is swrite('>^*<', $ref), ">$ref<";
631   is swrite('>@*<', $ref), ">$ref<";
632 }
633
634 format EMPTY =
635 .
636
637 my $test = curr_test();
638
639 format Comment =
640 ok @<<<<<
641 $test
642 .
643
644
645 # RT #8698 format bug with undefined _TOP
646
647 open STDOUT_DUP, ">&STDOUT";
648 my $oldfh = select STDOUT_DUP;
649 $= = 10;
650 {
651   local $~ = "Comment";
652   write;
653   curr_test($test + 1);
654   is $-, 9;
655   is $^, "STDOUT_DUP_TOP";
656 }
657 select $oldfh;
658 close STDOUT_DUP;
659
660 *CmT =  *{$::{Comment}}{FORMAT};
661 ok  defined *{$::{CmT}}{FORMAT}, "glob assign";
662
663
664 # RT #91032: Check that "non-real" strings like tie and overload work,
665 # especially that they re-compile the pattern on each FETCH, and that
666 # they don't overrun the buffer
667
668
669 {
670     package RT91032;
671
672     sub TIESCALAR { bless [] }
673     my $i = 0;
674     sub FETCH { $i++; "A$i @> Z\n" }
675
676     use overload '""' => \&FETCH;
677
678     tie my $f, 'RT91032';
679
680     formline $f, "a";
681     formline $f, "bc";
682     ::is $^A, "A1  a Z\nA2 bc Z\n", "RT 91032: tied";
683     $^A = '';
684
685     my $g = bless []; # has overloaded stringify
686     formline $g, "de";
687     formline $g, "f";
688     ::is $^A, "A3 de Z\nA4  f Z\n", "RT 91032: overloaded";
689     $^A = '';
690
691     my $h = [];
692     formline $h, "junk1";
693     formline $h, "junk2";
694     ::is ref($h), 'ARRAY', "RT 91032: array ref still a ref";
695     ::like "$h", qr/^ARRAY\(0x[0-9a-f]+\)$/, "RT 91032: array stringifies ok";
696     ::is $^A, "$h$h","RT 91032: stringified array";
697     $^A = '';
698
699     # used to overwrite the ~~ in the *original SV with spaces. Naughty!
700
701     my $orig = my $format = "^<<<<< ~~\n";
702     my $abc = "abc";
703     formline $format, $abc;
704     $^A ='';
705     ::is $format, $orig, "RT91032: don't overwrite orig format string";
706
707     # check that ~ and ~~ are displayed correctly as whitespace,
708     # under the influence of various different types of border
709
710     for my $n (1,2) {
711         for my $lhs (' ', 'Y', '^<<<', '^|||', '^>>>') {
712             for my $rhs ('', ' ', 'Z', '^<<<', '^|||', '^>>>') {
713                 my $fmt = "^<B$lhs" . ('~' x $n) . "$rhs\n";
714                 my $sfmt = ($fmt =~ s/~/ /gr);
715                 my ($a, $bc, $stop);
716                 ($a, $bc, $stop) = ('a', 'bc', 's');
717                 # $stop is to stop '~~' deleting the whole line
718                 formline $sfmt, $stop, $a, $bc;
719                 my $exp = $^A;
720                 $^A = '';
721                 ($a, $bc, $stop) = ('a', 'bc', 's');
722                 formline $fmt, $stop, $a, $bc;
723                 my $got = $^A;
724                 $^A = '';
725                 $fmt =~ s/\n/\\n/;
726                 ::is($got, $exp, "chop munging: [$fmt]");
727             }
728         }
729     }
730 }
731
732 # check that '~  (delete current line if empty) works when
733 # the target gets upgraded to uft8 (and re-allocated) midstream.
734
735 {
736     my $format = "\x{100}@~\n"; # format is utf8
737     # this target is not utf8, but will expand (and get reallocated)
738     # when upgraded to utf8.
739     my $orig = "\x80\x81\x82";
740     local $^A = $orig;
741     my $empty = "";
742     formline $format, $empty;
743     is $^A , $orig, "~ and realloc";
744
745     # check similarly that trailing blank removal works ok
746
747     $format = "@<\n\x{100}"; # format is utf8
748     chop $format;
749     $orig = "   ";
750     $^A = $orig;
751     formline $format, "  ";
752     is $^A, "$orig\n", "end-of-line blanks and realloc";
753
754     # and check this doesn't overflow the buffer
755
756     local $^A = '';
757     $format = "@* @####\n";
758     $orig = "x" x 100 . "\n";
759     formline $format, $orig, 12345;
760     is $^A, ("x" x 100) . " 12345\n", "\@* doesn't overflow";
761
762     # make sure it can cope with formats > 64k
763
764     $format = 'x' x 65537;
765     $^A = '';
766     formline $format;
767     # don't use 'is' here, as the diag output will be too long!
768     ok $^A eq $format, ">64K";
769 }
770
771
772 SKIP: {
773     skip_if_miniperl('miniperl does not support scalario');
774     my $buf = "";
775     open my $fh, ">", \$buf;
776     my $old_fh = select $fh;
777     local $~ = "CmT";
778     write;
779     select $old_fh;
780     close $fh;
781     is $buf, "ok $test\n", "write to duplicated format";
782 }
783
784 format caret_A_test_TOP =
785 T
786 .
787
788 format caret_A_test =
789 L1
790 L2
791 L3
792 L4
793 .
794
795 SKIP: {
796     skip_if_miniperl('miniperl does not support scalario');
797     my $buf = "";
798     open my $fh, ">", \$buf;
799     my $old_fh = select $fh;
800     local $^ = "caret_A_test_TOP";
801     local $~ = "caret_A_test";
802     local $= = 3;
803     local $^A = "A1\nA2\nA3\nA4\n";
804     write;
805     select $old_fh;
806     close $fh;
807     is $buf, "T\nA1\nA2\n\fT\nA3\nA4\n\fT\nL1\nL2\n\fT\nL3\nL4\n",
808                     "assign to ^A sets FmLINES";
809 }
810
811 fresh_perl_like(<<'EOP', qr/^Format STDOUT redefined at/, {stderr => 1}, '#64562 - Segmentation fault with redefined formats and warnings');
812 #!./perl
813
814 use strict;
815 use warnings; # crashes!
816
817 format =
818 .
819
820 write;
821
822 format =
823 .
824
825 write;
826 EOP
827
828 fresh_perl_is(<<'EOP', ">ARRAY<\ncrunch_eth\n", {stderr => 1}, '#79532 - formline coerces its arguments');
829 use strict;
830 use warnings;
831 my $zamm = ['crunch_eth'];
832 formline $zamm;
833 printf ">%s<\n", ref $zamm;
834 print "$zamm->[0]\n";
835 EOP
836
837 # [perl #73690]
838
839 select +(select(RT73690), do {
840     open(RT73690, '>Op_write.tmp') || die "Can't create Op_write.tmp";
841     format RT73690 =
842 @<< @<<
843 11, 22
844 .
845
846     my @ret;
847
848     @ret = write;
849     is(scalar(@ret), 1);
850     ok($ret[0]);
851     @ret = scalar(write);
852     is(scalar(@ret), 1);
853     ok($ret[0]);
854     @ret = write(RT73690);
855     is(scalar(@ret), 1);
856     ok($ret[0]);
857     @ret = scalar(write(RT73690));
858     is(scalar(@ret), 1);
859     ok($ret[0]);
860
861     @ret = ('a', write, 'z');
862     is(scalar(@ret), 3);
863     is($ret[0], 'a');
864     ok($ret[1]);
865     is($ret[2], 'z');
866     @ret = ('b', scalar(write), 'y');
867     is(scalar(@ret), 3);
868     is($ret[0], 'b');
869     ok($ret[1]);
870     is($ret[2], 'y');
871     @ret = ('c', write(RT73690), 'x');
872     is(scalar(@ret), 3);
873     is($ret[0], 'c');
874     ok($ret[1]);
875     is($ret[2], 'x');
876     @ret = ('d', scalar(write(RT73690)), 'w');
877     is(scalar(@ret), 3);
878     is($ret[0], 'd');
879     ok($ret[1]);
880     is($ret[2], 'w');
881
882     @ret = do { write; 'foo' };
883     is(scalar(@ret), 1);
884     is($ret[0], 'foo');
885     @ret = do { scalar(write); 'bar' };
886     is(scalar(@ret), 1);
887     is($ret[0], 'bar');
888     @ret = do { write(RT73690); 'baz' };
889     is(scalar(@ret), 1);
890     is($ret[0], 'baz');
891     @ret = do { scalar(write(RT73690)); 'quux' };
892     is(scalar(@ret), 1);
893     is($ret[0], 'quux');
894
895     @ret = ('a', do { write; 'foo' }, 'z');
896     is(scalar(@ret), 3);
897     is($ret[0], 'a');
898     is($ret[1], 'foo');
899     is($ret[2], 'z');
900     @ret = ('b', do { scalar(write); 'bar' }, 'y');
901     is(scalar(@ret), 3);
902     is($ret[0], 'b');
903     is($ret[1], 'bar');
904     is($ret[2], 'y');
905     @ret = ('c', do { write(RT73690); 'baz' }, 'x');
906     is(scalar(@ret), 3);
907     is($ret[0], 'c');
908     is($ret[1], 'baz');
909     is($ret[2], 'x');
910     @ret = ('d', do { scalar(write(RT73690)); 'quux' }, 'w');
911     is(scalar(@ret), 3);
912     is($ret[0], 'd');
913     is($ret[1], 'quux');
914     is($ret[2], 'w');
915
916     close RT73690 or die "Could not close: $!";
917 })[0];
918
919 select +(select(RT73690_2), do {
920     open(RT73690_2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
921     format RT73690_2 =
922 @<< @<<
923 return
924 .
925
926     my @ret;
927
928     @ret = write;
929     is(scalar(@ret), 1);
930     ok(!$ret[0]);
931     @ret = scalar(write);
932     is(scalar(@ret), 1);
933     ok(!$ret[0]);
934     @ret = write(RT73690_2);
935     is(scalar(@ret), 1);
936     ok(!$ret[0]);
937     @ret = scalar(write(RT73690_2));
938     is(scalar(@ret), 1);
939     ok(!$ret[0]);
940
941     @ret = ('a', write, 'z');
942     is(scalar(@ret), 3);
943     is($ret[0], 'a');
944     ok(!$ret[1]);
945     is($ret[2], 'z');
946     @ret = ('b', scalar(write), 'y');
947     is(scalar(@ret), 3);
948     is($ret[0], 'b');
949     ok(!$ret[1]);
950     is($ret[2], 'y');
951     @ret = ('c', write(RT73690_2), 'x');
952     is(scalar(@ret), 3);
953     is($ret[0], 'c');
954     ok(!$ret[1]);
955     is($ret[2], 'x');
956     @ret = ('d', scalar(write(RT73690_2)), 'w');
957     is(scalar(@ret), 3);
958     is($ret[0], 'd');
959     ok(!$ret[1]);
960     is($ret[2], 'w');
961
962     @ret = do { write; 'foo' };
963     is(scalar(@ret), 1);
964     is($ret[0], 'foo');
965     @ret = do { scalar(write); 'bar' };
966     is(scalar(@ret), 1);
967     is($ret[0], 'bar');
968     @ret = do { write(RT73690_2); 'baz' };
969     is(scalar(@ret), 1);
970     is($ret[0], 'baz');
971     @ret = do { scalar(write(RT73690_2)); 'quux' };
972     is(scalar(@ret), 1);
973     is($ret[0], 'quux');
974
975     @ret = ('a', do { write; 'foo' }, 'z');
976     is(scalar(@ret), 3);
977     is($ret[0], 'a');
978     is($ret[1], 'foo');
979     is($ret[2], 'z');
980     @ret = ('b', do { scalar(write); 'bar' }, 'y');
981     is(scalar(@ret), 3);
982     is($ret[0], 'b');
983     is($ret[1], 'bar');
984     is($ret[2], 'y');
985     @ret = ('c', do { write(RT73690_2); 'baz' }, 'x');
986     is(scalar(@ret), 3);
987     is($ret[0], 'c');
988     is($ret[1], 'baz');
989     is($ret[2], 'x');
990     @ret = ('d', do { scalar(write(RT73690_2)); 'quux' }, 'w');
991     is(scalar(@ret), 3);
992     is($ret[0], 'd');
993     is($ret[1], 'quux');
994     is($ret[2], 'w');
995
996     close RT73690_2 or die "Could not close: $!";
997 })[0];
998
999 open(UNDEF, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1000 select +(select(UNDEF), $~ = "UNDEFFORMAT")[0];
1001 format UNDEFFORMAT =
1002 @
1003 undef *UNDEFFORMAT
1004 .
1005 write UNDEF;
1006 pass "active format cannot be freed";
1007
1008 select +(select(UNDEF), $~ = "UNDEFFORMAT2")[0];
1009 format UNDEFFORMAT2 =
1010 @
1011 close UNDEF or die "Could not close: $!"; undef *UNDEF
1012 .
1013 write UNDEF;
1014 pass "freeing current handle in format";
1015 undef $^A;
1016
1017 ok !eval q|
1018 format foo {
1019 @<<<
1020 $a
1021 }
1022 ;1
1023 |, 'format foo { ... } is not allowed';
1024
1025 ok !eval q|
1026 format =
1027 @<<<
1028 }
1029 ;1
1030 |, 'format = ... } is not allowed';
1031
1032 open(NEST, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1033 format NEST =
1034 @<<<
1035 {
1036     my $birds = "birds";
1037     local *NEST = *BIRDS{FORMAT};
1038     write NEST;
1039     format BIRDS =
1040 @<<<<<
1041 $birds;
1042 .
1043     "nest"
1044 }
1045 .
1046 write NEST;
1047 close NEST or die "Could not close: $!";
1048 is cat('Op_write.tmp'), "birds\nnest\n", 'nested formats';
1049
1050 # A compilation error should not create a format
1051 eval q|
1052 format ERROR =
1053 @
1054 @_ =~ s///
1055 .
1056 |;
1057 eval { write ERROR };
1058 like $@, qr'Undefined format',
1059     'formats with compilation errors are not created';
1060
1061 # This syntax error used to cause a crash, double free, or a least
1062 # a bad read.
1063 # See the long-winded explanation at:
1064 #   https://rt.perl.org/rt3/Ticket/Display.html?id=43425#txn-1144500
1065 eval q|
1066 format =
1067 @
1068 use;format
1069 strict
1070 .
1071 |;
1072 pass('no crash with invalid use/format inside format');
1073
1074
1075 #############################
1076 ## Section 4
1077 ## Add new tests *above* here
1078 #############################
1079
1080 # scary format testing from H.Merijn Brand
1081
1082 # Just a complete test for format, including top-, left- and bottom marging
1083 # and format detection through glob entries
1084
1085 if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' ||
1086     ($^O eq 'os2' and not eval '$OS2::can_fork')) {
1087   $test = curr_test();
1088  SKIP: {
1089       skip "'|-' and '-|' not supported", $tests - $test + 1;
1090   }
1091   exit(0);
1092 }
1093
1094
1095 $^  = "STDOUT_TOP";
1096 $=  =  7;               # Page length
1097 $-  =  0;               # Lines left
1098 my $ps = $^L; $^L = ""; # Catch the page separator
1099 my $tm =  1;            # Top margin (empty lines before first output)
1100 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
1101 my $lm =  4;            # Left margin (indent in spaces)
1102
1103 # -----------------------------------------------------------------------
1104 #
1105 # execute the rest of the script in a child process. The parent reads the
1106 # output from the child and compares it with <DATA>.
1107
1108 my @data = <DATA>;
1109
1110 select ((select (STDOUT), $| = 1)[0]); # flush STDOUT
1111
1112 my $opened = open FROM_CHILD, "-|";
1113 unless (defined $opened) {
1114     fail "open gave $!";
1115     exit 0;
1116 }
1117
1118 if ($opened) {
1119     # in parent here
1120
1121     pass 'open';
1122     my $s = " " x $lm;
1123     while (<FROM_CHILD>) {
1124         unless (@data) {
1125             fail 'too much output';
1126             exit;
1127         }
1128         s/^/$s/;
1129         my $exp = shift @data;
1130         is $_, $exp;
1131     }
1132     close FROM_CHILD;
1133     is "@data", "", "correct length of output";
1134     exit;
1135 }
1136
1137 # in child here
1138 $::NO_ENDING = 1;
1139
1140     select ((select (STDOUT), $| = 1)[0]);
1141 $tm = "\n" x $tm;
1142 $= -= $bm + 1; # count one for the trailing "----"
1143 my $lastmin = 0;
1144
1145 my @E;
1146
1147 sub wryte
1148 {
1149     $lastmin = $-;
1150     write;
1151     } # wryte;
1152
1153 sub footer
1154 {
1155     $% == 1 and return "";
1156
1157     $lastmin < $= and print "\n" x $lastmin;
1158     print "\n" x $bm, "----\n", $ps;
1159     $lastmin = $-;
1160     "";
1161     } # footer
1162
1163 # Yes, this is sick ;-)
1164 format TOP =
1165 @* ~
1166 @{[footer]}
1167 @* ~
1168 $tm
1169 .
1170
1171 format ENTRY =
1172 @ @<<<<~~
1173 @{(shift @E)||["",""]}
1174 .
1175
1176 format EOR =
1177 - -----
1178 .
1179
1180 sub has_format ($)
1181 {
1182     my $fmt = shift;
1183     exists $::{$fmt} or return 0;
1184     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
1185     open my $null, "> /dev/null" or die;
1186     my $fh = select $null;
1187     local $~ = $fmt;
1188     eval "write";
1189     select $fh;
1190     $@?0:1;
1191     } # has_format
1192
1193 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
1194 has_format ("ENTRY") or die "No format defined for ENTRY";
1195 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
1196                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
1197     @E = @$e;
1198     local $~ = "ENTRY";
1199     wryte;
1200     has_format ("EOR") or next;
1201     local $~ = "EOR";
1202     wryte;
1203     }
1204 if (has_format ("EOF")) {
1205     local $~ = "EOF";
1206     wryte;
1207     }
1208
1209 close STDOUT;
1210
1211 # That was test 48.
1212
1213 __END__
1214     
1215     1 Test1
1216     2 Test2
1217     3 Test3
1218     
1219     
1220     ----
1221     \f
1222     4 Test4
1223     5 Test5
1224     6 Test6
1225     
1226     
1227     ----
1228     \f
1229     7 Test7
1230     - -----
1231     
1232     
1233     
1234     ----
1235     \f
1236     1 1tseT
1237     2 2tseT
1238     3 3tseT
1239     
1240     
1241     ----
1242     \f
1243     4 4tseT
1244     5 5tseT
1245     - -----