This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Don’t crash when undefining handle of active format
[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 = 8 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3 + 96 + 2;
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 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 unlink_all '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 unlink_all '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/Undefined format ""/, 'format with 0-length name';
508
509     $~ = "\0foo";
510     eval { write };
511     like $@, qr/Undefined format "\0foo"/,
512         'no such format beginning with null';
513
514     $~ = "NOSUCHFORMAT";
515     eval { write };
516     like $@, qr/Undefined format "NOSUCHFORMAT"/, 'no such format';
517 }
518
519 select +(select(OUT21), do {
520     open(OUT21, '>Op_write.tmp') || die "Can't create Op_write.tmp";
521
522     format OUT21 =
523 @<<
524 $_
525 .
526
527     local $^ = '';
528     local $= = 1;
529     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
530     like $@, qr/Undefined top format ""/, 'top format with 0-length name';
531
532     $^ = "\0foo";
533     # For some reason, we have to do this twice to get the error again.
534     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
535     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
536     like $@, qr/Undefined top format "\0foo"/,
537         'no such top format beginning with null';
538
539     $^ = "NOSUCHFORMAT";
540     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
541     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
542     like $@, qr/Undefined top format "NOSUCHFORMAT"/, 'no such top format';
543
544     # reset things;
545     eval { write(OUT21) };
546     undef $^A;
547
548     close OUT21 or die "Could not close: $!";
549 })[0];
550
551 {
552   package Count;
553
554   sub TIESCALAR {
555     my $class = shift;
556     bless [shift, 0, 0], $class;
557   }
558
559   sub FETCH {
560     my $self = shift;
561     ++$self->[1];
562     $self->[0];
563   }
564
565   sub STORE {
566     my $self = shift;
567     ++$self->[2];
568     $self->[0] = shift;
569   }
570 }
571
572 {
573   my ($pound_utf8, $pm_utf8) = map { my $a = "$_\x{100}"; chop $a; $a}
574     my ($pound, $pm) = ("\xA3", "\xB1");
575
576   foreach my $first ('N', $pound, $pound_utf8) {
577     foreach my $base ('N', $pm, $pm_utf8) {
578       foreach my $second ($base, "$base\n", "$base\nMoo!", "$base\nMoo!\n",
579                           "$base\nMoo!\n",) {
580         foreach (['^*', qr/(.+)/], ['@*', qr/(.*?)$/s]) {
581           my ($format, $re) = @$_;
582           $format = "1^*2 3${format}4";
583           foreach my $class ('', 'Count') {
584             my $name = qq{swrite("$format", "$first", "$second") class="$class"};
585             $name =~ s/\n/\\n/g;
586             $name =~ s{(.)}{
587                         ord($1) > 126 ? sprintf("\\x{%x}",ord($1)) : $1
588                     }ge;
589
590             $first =~ /(.+)/ or die $first;
591             my $expect = "1${1}2";
592             $second =~ $re or die $second;
593             $expect .= " 3${1}4";
594
595             if ($class) {
596               my $copy1 = $first;
597               my $copy2;
598               tie $copy2, $class, $second;
599               is swrite("$format", $copy1, $copy2), $expect, $name;
600               my $obj = tied $copy2;
601               is $obj->[1], 1, 'value read exactly once';
602             } else {
603               my ($copy1, $copy2) = ($first, $second);
604               is swrite("$format", $copy1, $copy2), $expect, $name;
605             }
606           }
607         }
608       }
609     }
610   }
611 }
612
613 {
614   # This will fail an assertion in 5.10.0 built with -DDEBUGGING (because
615   # pp_formline attempts to set SvCUR() on an SVt_RV). I suspect that it will
616   # be doing something similarly out of bounds on everything from 5.000
617   my $ref = [];
618   is swrite('>^*<', $ref), ">$ref<";
619   is swrite('>@*<', $ref), ">$ref<";
620 }
621
622 format EMPTY =
623 .
624
625 my $test = curr_test();
626
627 format Comment =
628 ok @<<<<<
629 $test
630 .
631
632
633 # RT #8698 format bug with undefined _TOP
634
635 open STDOUT_DUP, ">&STDOUT";
636 my $oldfh = select STDOUT_DUP;
637 $= = 10;
638 {
639   local $~ = "Comment";
640   write;
641   curr_test($test + 1);
642   is $-, 9;
643   is $^, "STDOUT_DUP_TOP";
644 }
645 select $oldfh;
646 close STDOUT_DUP;
647
648 *CmT =  *{$::{Comment}}{FORMAT};
649 ok  defined *{$::{CmT}}{FORMAT}, "glob assign";
650
651
652 # RT #91032: Check that "non-real" strings like tie and overload work,
653 # especially that they re-compile the pattern on each FETCH, and that
654 # they don't overrun the buffer
655
656
657 {
658     package RT91032;
659
660     sub TIESCALAR { bless [] }
661     my $i = 0;
662     sub FETCH { $i++; "A$i @> Z\n" }
663
664     use overload '""' => \&FETCH;
665
666     tie my $f, 'RT91032';
667
668     formline $f, "a";
669     formline $f, "bc";
670     ::is $^A, "A1  a Z\nA2 bc Z\n", "RT 91032: tied";
671     $^A = '';
672
673     my $g = bless []; # has overloaded stringify
674     formline $g, "de";
675     formline $g, "f";
676     ::is $^A, "A3 de Z\nA4  f Z\n", "RT 91032: overloaded";
677     $^A = '';
678
679     my $h = [];
680     formline $h, "junk1";
681     formline $h, "junk2";
682     ::is ref($h), 'ARRAY', "RT 91032: array ref still a ref";
683     ::like "$h", qr/^ARRAY\(0x[0-9a-f]+\)$/, "RT 91032: array stringifies ok";
684     ::is $^A, "$h$h","RT 91032: stringified array";
685     $^A = '';
686
687     # used to overwrite the ~~ in the *original SV with spaces. Naughty!
688
689     my $orig = my $format = "^<<<<< ~~\n";
690     my $abc = "abc";
691     formline $format, $abc;
692     $^A ='';
693     ::is $format, $orig, "RT91032: don't overwrite orig format string";
694
695     # check that ~ and ~~ are displayed correctly as whitespace,
696     # under the influence of various different types of border
697
698     for my $n (1,2) {
699         for my $lhs (' ', 'Y', '^<<<', '^|||', '^>>>') {
700             for my $rhs ('', ' ', 'Z', '^<<<', '^|||', '^>>>') {
701                 my $fmt = "^<B$lhs" . ('~' x $n) . "$rhs\n";
702                 my $sfmt = ($fmt =~ s/~/ /gr);
703                 my ($a, $bc, $stop);
704                 ($a, $bc, $stop) = ('a', 'bc', 's');
705                 # $stop is to stop '~~' deleting the whole line
706                 formline $sfmt, $stop, $a, $bc;
707                 my $exp = $^A;
708                 $^A = '';
709                 ($a, $bc, $stop) = ('a', 'bc', 's');
710                 formline $fmt, $stop, $a, $bc;
711                 my $got = $^A;
712                 $^A = '';
713                 $fmt =~ s/\n/\\n/;
714                 ::is($got, $exp, "chop munging: [$fmt]");
715             }
716         }
717     }
718 }
719
720 # check that '~  (delete current line if empty) works when
721 # the target gets upgraded to uft8 (and re-allocated) midstream.
722
723 {
724     my $format = "\x{100}@~\n"; # format is utf8
725     # this target is not utf8, but will expand (and get reallocated)
726     # when upgraded to utf8.
727     my $orig = "\x80\x81\x82";
728     local $^A = $orig;
729     my $empty = "";
730     formline $format, $empty;
731     is $^A , $orig, "~ and realloc";
732
733     # check similarly that trailing blank removal works ok
734
735     $format = "@<\n\x{100}"; # format is utf8
736     chop $format;
737     $orig = "   ";
738     $^A = $orig;
739     formline $format, "  ";
740     is $^A, "$orig\n", "end-of-line blanks and realloc";
741
742     # and check this doesn't overflow the buffer
743
744     local $^A = '';
745     $format = "@* @####\n";
746     $orig = "x" x 100 . "\n";
747     formline $format, $orig, 12345;
748     is $^A, ("x" x 100) . " 12345\n", "\@* doesn't overflow";
749
750     # make sure it can cope with formats > 64k
751
752     $format = 'x' x 65537;
753     $^A = '';
754     formline $format;
755     # don't use 'is' here, as the diag output will be too long!
756     ok $^A eq $format, ">64K";
757 }
758
759
760 SKIP: {
761     skip_if_miniperl('miniperl does not support scalario');
762     my $buf = "";
763     open my $fh, ">", \$buf;
764     my $old_fh = select $fh;
765     local $~ = "CmT";
766     write;
767     select $old_fh;
768     close $fh;
769     is $buf, "ok $test\n", "write to duplicated format";
770 }
771
772 format caret_A_test_TOP =
773 T
774 .
775
776 format caret_A_test =
777 L1
778 L2
779 L3
780 L4
781 .
782
783 SKIP: {
784     skip_if_miniperl('miniperl does not support scalario');
785     my $buf = "";
786     open my $fh, ">", \$buf;
787     my $old_fh = select $fh;
788     local $^ = "caret_A_test_TOP";
789     local $~ = "caret_A_test";
790     local $= = 3;
791     local $^A = "A1\nA2\nA3\nA4\n";
792     write;
793     select $old_fh;
794     close $fh;
795     is $buf, "T\nA1\nA2\n\fT\nA3\nA4\n\fT\nL1\nL2\n\fT\nL3\nL4\n",
796                     "assign to ^A sets FmLINES";
797 }
798
799 fresh_perl_like(<<'EOP', qr/^Format STDOUT redefined at/, {stderr => 1}, '#64562 - Segmentation fault with redefined formats and warnings');
800 #!./perl
801
802 use strict;
803 use warnings; # crashes!
804
805 format =
806 .
807
808 write;
809
810 format =
811 .
812
813 write;
814 EOP
815
816 fresh_perl_is(<<'EOP', ">ARRAY<\ncrunch_eth\n", {stderr => 1}, '#79532 - formline coerces its arguments');
817 use strict;
818 use warnings;
819 my $zamm = ['crunch_eth'];
820 formline $zamm;
821 printf ">%s<\n", ref $zamm;
822 print "$zamm->[0]\n";
823 EOP
824
825 # [perl #73690]
826
827 select +(select(RT73690), do {
828     open(RT73690, '>Op_write.tmp') || die "Can't create Op_write.tmp";
829     format RT73690 =
830 @<< @<<
831 11, 22
832 .
833
834     my @ret;
835
836     @ret = write;
837     is(scalar(@ret), 1);
838     ok($ret[0]);
839     @ret = scalar(write);
840     is(scalar(@ret), 1);
841     ok($ret[0]);
842     @ret = write(RT73690);
843     is(scalar(@ret), 1);
844     ok($ret[0]);
845     @ret = scalar(write(RT73690));
846     is(scalar(@ret), 1);
847     ok($ret[0]);
848
849     @ret = ('a', write, 'z');
850     is(scalar(@ret), 3);
851     is($ret[0], 'a');
852     ok($ret[1]);
853     is($ret[2], 'z');
854     @ret = ('b', scalar(write), 'y');
855     is(scalar(@ret), 3);
856     is($ret[0], 'b');
857     ok($ret[1]);
858     is($ret[2], 'y');
859     @ret = ('c', write(RT73690), 'x');
860     is(scalar(@ret), 3);
861     is($ret[0], 'c');
862     ok($ret[1]);
863     is($ret[2], 'x');
864     @ret = ('d', scalar(write(RT73690)), 'w');
865     is(scalar(@ret), 3);
866     is($ret[0], 'd');
867     ok($ret[1]);
868     is($ret[2], 'w');
869
870     @ret = do { write; 'foo' };
871     is(scalar(@ret), 1);
872     is($ret[0], 'foo');
873     @ret = do { scalar(write); 'bar' };
874     is(scalar(@ret), 1);
875     is($ret[0], 'bar');
876     @ret = do { write(RT73690); 'baz' };
877     is(scalar(@ret), 1);
878     is($ret[0], 'baz');
879     @ret = do { scalar(write(RT73690)); 'quux' };
880     is(scalar(@ret), 1);
881     is($ret[0], 'quux');
882
883     @ret = ('a', do { write; 'foo' }, 'z');
884     is(scalar(@ret), 3);
885     is($ret[0], 'a');
886     is($ret[1], 'foo');
887     is($ret[2], 'z');
888     @ret = ('b', do { scalar(write); 'bar' }, 'y');
889     is(scalar(@ret), 3);
890     is($ret[0], 'b');
891     is($ret[1], 'bar');
892     is($ret[2], 'y');
893     @ret = ('c', do { write(RT73690); 'baz' }, 'x');
894     is(scalar(@ret), 3);
895     is($ret[0], 'c');
896     is($ret[1], 'baz');
897     is($ret[2], 'x');
898     @ret = ('d', do { scalar(write(RT73690)); 'quux' }, 'w');
899     is(scalar(@ret), 3);
900     is($ret[0], 'd');
901     is($ret[1], 'quux');
902     is($ret[2], 'w');
903
904     close RT73690 or die "Could not close: $!";
905 })[0];
906
907 select +(select(RT73690_2), do {
908     open(RT73690_2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
909     format RT73690_2 =
910 @<< @<<
911 return
912 .
913
914     my @ret;
915
916     @ret = write;
917     is(scalar(@ret), 1);
918     ok(!$ret[0]);
919     @ret = scalar(write);
920     is(scalar(@ret), 1);
921     ok(!$ret[0]);
922     @ret = write(RT73690_2);
923     is(scalar(@ret), 1);
924     ok(!$ret[0]);
925     @ret = scalar(write(RT73690_2));
926     is(scalar(@ret), 1);
927     ok(!$ret[0]);
928
929     @ret = ('a', write, 'z');
930     is(scalar(@ret), 3);
931     is($ret[0], 'a');
932     ok(!$ret[1]);
933     is($ret[2], 'z');
934     @ret = ('b', scalar(write), 'y');
935     is(scalar(@ret), 3);
936     is($ret[0], 'b');
937     ok(!$ret[1]);
938     is($ret[2], 'y');
939     @ret = ('c', write(RT73690_2), 'x');
940     is(scalar(@ret), 3);
941     is($ret[0], 'c');
942     ok(!$ret[1]);
943     is($ret[2], 'x');
944     @ret = ('d', scalar(write(RT73690_2)), 'w');
945     is(scalar(@ret), 3);
946     is($ret[0], 'd');
947     ok(!$ret[1]);
948     is($ret[2], 'w');
949
950     @ret = do { write; 'foo' };
951     is(scalar(@ret), 1);
952     is($ret[0], 'foo');
953     @ret = do { scalar(write); 'bar' };
954     is(scalar(@ret), 1);
955     is($ret[0], 'bar');
956     @ret = do { write(RT73690_2); 'baz' };
957     is(scalar(@ret), 1);
958     is($ret[0], 'baz');
959     @ret = do { scalar(write(RT73690_2)); 'quux' };
960     is(scalar(@ret), 1);
961     is($ret[0], 'quux');
962
963     @ret = ('a', do { write; 'foo' }, 'z');
964     is(scalar(@ret), 3);
965     is($ret[0], 'a');
966     is($ret[1], 'foo');
967     is($ret[2], 'z');
968     @ret = ('b', do { scalar(write); 'bar' }, 'y');
969     is(scalar(@ret), 3);
970     is($ret[0], 'b');
971     is($ret[1], 'bar');
972     is($ret[2], 'y');
973     @ret = ('c', do { write(RT73690_2); 'baz' }, 'x');
974     is(scalar(@ret), 3);
975     is($ret[0], 'c');
976     is($ret[1], 'baz');
977     is($ret[2], 'x');
978     @ret = ('d', do { scalar(write(RT73690_2)); 'quux' }, 'w');
979     is(scalar(@ret), 3);
980     is($ret[0], 'd');
981     is($ret[1], 'quux');
982     is($ret[2], 'w');
983
984     close RT73690_2 or die "Could not close: $!";
985 })[0];
986
987 open(UNDEF, '>Op_write.tmp') || die "Can't create Op_write.tmp";
988 select +(select(UNDEF), $~ = "UNDEFFORMAT")[0];
989 format UNDEFFORMAT =
990 @
991 undef *UNDEFFORMAT
992 .
993 write UNDEF;
994 pass "active format cannot be freed";
995
996 select +(select(UNDEF), $~ = "UNDEFFORMAT2")[0];
997 format UNDEFFORMAT2 =
998 @
999 close UNDEF or die "Could not close: $!"; undef *UNDEF
1000 .
1001 write UNDEF;
1002 pass "freeing current handle in format";
1003 undef $^A;
1004
1005
1006 #############################
1007 ## Section 4
1008 ## Add new tests *above* here
1009 #############################
1010
1011 # scary format testing from H.Merijn Brand
1012
1013 # Just a complete test for format, including top-, left- and bottom marging
1014 # and format detection through glob entries
1015
1016 if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' ||
1017     ($^O eq 'os2' and not eval '$OS2::can_fork')) {
1018   $test = curr_test();
1019  SKIP: {
1020       skip "'|-' and '-|' not supported", $tests - $test + 1;
1021   }
1022   exit(0);
1023 }
1024
1025
1026 $^  = "STDOUT_TOP";
1027 $=  =  7;               # Page length
1028 $-  =  0;               # Lines left
1029 my $ps = $^L; $^L = ""; # Catch the page separator
1030 my $tm =  1;            # Top margin (empty lines before first output)
1031 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
1032 my $lm =  4;            # Left margin (indent in spaces)
1033
1034 # -----------------------------------------------------------------------
1035 #
1036 # execute the rest of the script in a child process. The parent reads the
1037 # output from the child and compares it with <DATA>.
1038
1039 my @data = <DATA>;
1040
1041 select ((select (STDOUT), $| = 1)[0]); # flush STDOUT
1042
1043 my $opened = open FROM_CHILD, "-|";
1044 unless (defined $opened) {
1045     fail "open gave $!";
1046     exit 0;
1047 }
1048
1049 if ($opened) {
1050     # in parent here
1051
1052     pass 'open';
1053     my $s = " " x $lm;
1054     while (<FROM_CHILD>) {
1055         unless (@data) {
1056             fail 'too much output';
1057             exit;
1058         }
1059         s/^/$s/;
1060         my $exp = shift @data;
1061         is $_, $exp;
1062     }
1063     close FROM_CHILD;
1064     is "@data", "", "correct length of output";
1065     exit;
1066 }
1067
1068 # in child here
1069 $::NO_ENDING = 1;
1070
1071     select ((select (STDOUT), $| = 1)[0]);
1072 $tm = "\n" x $tm;
1073 $= -= $bm + 1; # count one for the trailing "----"
1074 my $lastmin = 0;
1075
1076 my @E;
1077
1078 sub wryte
1079 {
1080     $lastmin = $-;
1081     write;
1082     } # wryte;
1083
1084 sub footer
1085 {
1086     $% == 1 and return "";
1087
1088     $lastmin < $= and print "\n" x $lastmin;
1089     print "\n" x $bm, "----\n", $ps;
1090     $lastmin = $-;
1091     "";
1092     } # footer
1093
1094 # Yes, this is sick ;-)
1095 format TOP =
1096 @* ~
1097 @{[footer]}
1098 @* ~
1099 $tm
1100 .
1101
1102 format ENTRY =
1103 @ @<<<<~~
1104 @{(shift @E)||["",""]}
1105 .
1106
1107 format EOR =
1108 - -----
1109 .
1110
1111 sub has_format ($)
1112 {
1113     my $fmt = shift;
1114     exists $::{$fmt} or return 0;
1115     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
1116     open my $null, "> /dev/null" or die;
1117     my $fh = select $null;
1118     local $~ = $fmt;
1119     eval "write";
1120     select $fh;
1121     $@?0:1;
1122     } # has_format
1123
1124 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
1125 has_format ("ENTRY") or die "No format defined for ENTRY";
1126 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
1127                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
1128     @E = @$e;
1129     local $~ = "ENTRY";
1130     wryte;
1131     has_format ("EOR") or next;
1132     local $~ = "EOR";
1133     wryte;
1134     }
1135 if (has_format ("EOF")) {
1136     local $~ = "EOF";
1137     wryte;
1138     }
1139
1140 close STDOUT;
1141
1142 # That was test 48.
1143
1144 __END__
1145     
1146     1 Test1
1147     2 Test2
1148     3 Test3
1149     
1150     
1151     ----
1152     \f
1153     4 Test4
1154     5 Test5
1155     6 Test6
1156     
1157     
1158     ----
1159     \f
1160     7 Test7
1161     - -----
1162     
1163     
1164     
1165     ----
1166     \f
1167     1 1tseT
1168     2 2tseT
1169     3 3tseT
1170     
1171     
1172     ----
1173     \f
1174     4 4tseT
1175     5 5tseT
1176     - -----