This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pp_formline(): avoid buffer overrun
[perl5.git] / t / op / write.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib');
7 }
8
9 use strict;     # Amazed that this hackery can be made strict ...
10 use Tie::Scalar;
11
12 # read in a file
13 sub cat {
14     my $file = shift;
15     local $/;
16     open my $fh, $file or die "can't open '$file': $!";
17     my $data = <$fh>;
18     close $fh;
19     $data;
20 }
21
22 # read in a utf-8 file
23 #
24 sub cat_utf8 {
25     my $file = shift;
26     local $/;
27     open my $fh, '<', $file or die "can't open '$file': $!";
28     binmode $fh, ':utf8';
29     my $data = <$fh> // die "Can't read from '$file': $!";
30     close $fh or die "error closing '$file': $!";
31     $data;
32 }
33
34 # write a format to a utf8 file, then read it back in and compare
35
36 sub is_format_utf8 {
37     my ($glob, $want, $desc) = @_;
38     local $::Level = $::Level + 1;
39     my $file = 'Op_write.tmp';
40     open $glob, '>:utf8', $file or die "Can't create '$file': $!";
41     write $glob;
42     close $glob or die "Could not close '$file': $!";
43     is(cat_utf8($file), $want, $desc);
44 }
45
46 sub like_format_utf8 {
47     my ($glob, $want, $desc) = @_;
48     local $::Level = $::Level + 1;
49     my $file = 'Op_write.tmp';
50     open $glob, '>:utf8', $file or die "Can't create '$file': $!";
51     write $glob;
52     close $glob or die "Could not close '$file': $!";
53     like(cat_utf8($file), $want, $desc);
54 }
55
56
57
58 #-- testing numeric fields in all variants (WL)
59
60 sub swrite {
61     my $format = shift;
62     local $^A = ""; # don't litter, use a local bin
63     formline( $format, @_ );
64     return $^A;
65 }
66
67 my @NumTests = (
68     # [ format, value1, expected1, value2, expected2, .... ]
69     [ '@###',           0,   '   0',         1, '   1',     9999.6, '####',
70                 9999.4999,   '9999',    -999.6, '####',     1e+100, '####' ],
71
72     [ '@0##',           0,   '0000',         1, '0001',     9999.6, '####',
73                 -999.4999,   '-999',    -999.6, '####',     1e+100, '####' ],
74
75     [ '^###',           0,   '   0',     undef, '    ' ],
76
77     [ '^0##',           0,   '0000',     undef, '    ' ],
78
79     [ '@###.',          0,  '   0.',         1, '   1.',    9999.6, '#####',
80                 9999.4999,  '9999.',    -999.6, '#####' ],
81
82     [ '@##.##',         0, '  0.00',         1, '  1.00',  999.996, '######',
83                 999.99499, '999.99',      -100, '######' ],
84
85     [ '@0#.##',         0, '000.00',         1, '001.00',       10, '010.00',
86                   -0.0001, qr/^[\-0]00\.00$/ ],
87
88 );
89
90
91 my $num_tests = 0;
92 for my $tref ( @NumTests ){
93     $num_tests += (@$tref - 1)/2;
94 }
95 #---------------------------------------------------------
96
97 # number of tests in section 1
98 my $bas_tests = 21;
99
100 # number of tests in section 3
101 my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 6 + 2 + 3 + 96 + 11 + 15;
102
103 # number of tests in section 4
104 my $hmb_tests = 37;
105
106 my $tests = $bas_tests + $num_tests + $bug_tests + $hmb_tests;
107
108 plan $tests;
109
110 ############
111 ## Section 1
112 ############
113
114 use vars qw($fox $multiline $foo $good);
115
116 format OUT =
117 the quick brown @<<
118 $fox
119 jumped
120 @*
121 $multiline
122 ^<<<<<<<<<
123 $foo
124 ^<<<<<<<<<
125 $foo
126 ^<<<<<<...
127 $foo
128 now @<<the@>>>> for all@|||||men to come @<<<<
129 {
130     'i' . 's', "time\n", $good, 'to'
131 }
132 .
133
134 open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
135 END { unlink_all 'Op_write.tmp' }
136
137 $fox = 'foxiness';
138 $good = 'good';
139 $multiline = "forescore\nand\nseven years\n";
140 $foo = 'when in the course of human events it becomes necessary';
141 write(OUT);
142 close OUT or die "Could not close: $!";
143
144 my $right =
145 "the quick brown fox
146 jumped
147 forescore
148 and
149 seven years
150 when in
151 the course
152 of huma...
153 now is the time for all good men to come to\n";
154
155 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
156
157 $fox = 'wolfishness';
158 my $fox = 'foxiness';           # Test a lexical variable.
159
160 format OUT2 =
161 the quick brown @<<
162 $fox
163 jumped
164 @*
165 $multiline
166 ^<<<<<<<<< ~~
167 $foo
168 now @<<the@>>>> for all@|||||men to come @<<<<
169 'i' . 's', "time\n", $good, 'to'
170 .
171
172 open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp";
173
174 $good = 'good';
175 $multiline = "forescore\nand\nseven years\n";
176 $foo = 'when in the course of human events it becomes necessary';
177 write(OUT2);
178 close OUT2 or die "Could not close: $!";
179
180 $right =
181 "the quick brown fox
182 jumped
183 forescore
184 and
185 seven years
186 when in
187 the course
188 of human
189 events it
190 becomes
191 necessary
192 now is the time for all good men to come to\n";
193
194 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
195
196 eval <<'EOFORMAT';
197 format OUT2 =
198 the brown quick @<<
199 $fox
200 jumped
201 @*
202 $multiline
203 and
204 ^<<<<<<<<< ~~
205 $foo
206 now @<<the@>>>> for all@|||||men to come @<<<<
207 'i' . 's', "time\n", $good, 'to'
208 .
209 EOFORMAT
210
211 open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
212
213 $fox = 'foxiness';
214 $good = 'good';
215 $multiline = "forescore\nand\nseven years\n";
216 $foo = 'when in the course of human events it becomes necessary';
217 write(OUT2);
218 close OUT2 or die "Could not close: $!";
219
220 $right =
221 "the brown quick fox
222 jumped
223 forescore
224 and
225 seven years
226 and
227 when in
228 the course
229 of human
230 events it
231 becomes
232 necessary
233 now is the time for all good men to come to\n";
234
235 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
236
237 # formline tests
238
239 $right = <<EOT;
240 @ a
241 @> ab
242 @>> abc
243 @>>>  abc
244 @>>>>   abc
245 @>>>>>    abc
246 @>>>>>>     abc
247 @>>>>>>>      abc
248 @>>>>>>>>       abc
249 @>>>>>>>>>        abc
250 @>>>>>>>>>>         abc
251 EOT
252
253 my $was1 = my $was2 = '';
254 use vars '$format2';
255 for (0..10) {           
256   # lexical picture
257   $^A = '';
258   my $format1 = '@' . '>' x $_;
259   formline $format1, 'abc';
260   $was1 .= "$format1 $^A\n";
261   # global
262   $^A = '';
263   local $format2 = '@' . '>' x $_;
264   formline $format2, 'abc';
265   $was2 .= "$format2 $^A\n";
266 }
267 is $was1, $right;
268 is $was2, $right;
269
270 $^A = '';
271
272 # more test
273
274 format OUT3 =
275 ^<<<<<<...
276 $foo
277 .
278
279 open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";
280
281 $foo = 'fit          ';
282 write(OUT3);
283 close OUT3 or die "Could not close: $!";
284
285 $right =
286 "fit\n";
287
288 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
289
290
291 # test lexicals and globals
292 {
293     my $test = curr_test();
294     my $this = "ok";
295     our $that = $test;
296     format LEX =
297 @<<@|
298 $this,$that
299 .
300     open(LEX, ">&STDOUT") or die;
301     write LEX;
302     $that = ++$test;
303     write LEX;
304     close LEX or die "Could not close: $!";
305     curr_test($test + 1);
306 }
307 # LEX_INTERPNORMAL test
308 my %e = ( a => 1 );
309 format OUT4 =
310 @<<<<<<
311 "$e{a}"
312 .
313 open   OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
314 write (OUT4);
315 close  OUT4 or die "Could not close: $!";
316 is cat('Op_write.tmp'), "1\n" and unlink_all "Op_write.tmp";
317
318 # More LEX_INTERPNORMAL
319 format OUT4a=
320 @<<<<<<<<<<<<<<<
321 "${; use
322      strict; \'Nasdaq dropping like flies'}"
323 .
324 open   OUT4a, ">Op_write.tmp" or die "Can't create Op_write.tmp";
325 write (OUT4a);
326 close  OUT4a or die "Could not close: $!";
327 is cat('Op_write.tmp'), "Nasdaq dropping\n", 'skipspace inside "${...}"'
328     and unlink_all "Op_write.tmp";
329
330 eval <<'EOFORMAT';
331 format OUT10 =
332 @####.## @0###.##
333 $test1, $test1
334 .
335 EOFORMAT
336
337 open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
338
339 use vars '$test1';
340 $test1 = 12.95;
341 write(OUT10);
342 close OUT10 or die "Could not close: $!";
343
344 $right = "   12.95 00012.95\n";
345 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
346
347 eval <<'EOFORMAT';
348 format OUT11 =
349 @0###.## 
350 $test1
351 @ 0#
352 $test1
353 @0 # 
354 $test1
355 .
356 EOFORMAT
357
358 open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";
359
360 $test1 = 12.95;
361 write(OUT11);
362 close OUT11 or die "Could not close: $!";
363
364 $right = 
365 "00012.95
366 1 0#
367 10 #\n";
368 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
369
370 {
371     my $test = curr_test();
372     my $el;
373     format OUT12 =
374 ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze
375 $el
376 .
377     my %hash = ($test => 3);
378     open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp";
379
380     for $el (keys %hash) {
381         write(OUT12);
382     }
383     close OUT12 or die "Could not close: $!";
384     print cat('Op_write.tmp');
385     curr_test($test + 1);
386 }
387
388 {
389     my $test = curr_test();
390     # Bug report and testcase by Alexey Tourbin
391     my $v;
392     tie $v, 'Tie::StdScalar';
393     $v = $test;
394     format OUT13 =
395 ok ^<<<<<<<<< ~~
396 $v
397 .
398     open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp";
399     write(OUT13);
400     close OUT13 or die "Could not close: $!";
401     print cat('Op_write.tmp');
402     curr_test($test + 1);
403 }
404
405 {   # test 14
406     # Bug #24774 format without trailing \n failed assertion, but this
407     # must fail since we have a trailing ; in the eval'ed string (WL)
408     my @v = ('k');
409     eval "format OUT14 = \n@\n\@v";
410     like $@, qr/Format not terminated/;
411 }
412
413 {   # test 15
414     # text lost in ^<<< field with \r in value (WL)
415     my $txt = "line 1\rline 2";
416     format OUT15 =
417 ^<<<<<<<<<<<<<<<<<<
418 $txt
419 ^<<<<<<<<<<<<<<<<<<
420 $txt
421 .
422     open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp";
423     write(OUT15);
424     close OUT15 or die "Could not close: $!";
425     my $res = cat('Op_write.tmp');
426     is $res, "line 1\nline 2\n";
427 }
428
429 {   # test 16: multiple use of a variable in same line with ^<
430     my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4";
431     format OUT16 =
432 ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
433 $txt,             $txt
434 ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
435 $txt,             $txt
436 .
437     open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp";
438     write(OUT16);
439     close OUT16 or die "Could not close: $!";
440     my $res = cat('Op_write.tmp');
441     is $res, <<EOD;
442 this_is_block_1   this_is_block_2
443 this_is_block_3   this_is_block_4
444 EOD
445 }
446
447 {   # test 17: @* "should be on a line of its own", but it should work
448     # cleanly with literals before and after. (WL)
449
450     my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n";
451     format OUT17 =
452 Here we go: @* That's all, folks!
453             $txt
454 .
455     open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp";
456     write(OUT17);
457     close OUT17 or die "Could not close: $!";
458     my $res = cat('Op_write.tmp');
459     chomp( $txt );
460     my $exp = <<EOD;
461 Here we go: $txt That's all, folks!
462 EOD
463     is $res, $exp;
464 }
465
466 {   # test 18: @# and ~~ would cause runaway format, but we now
467     # catch this while compiling (WL)
468
469     format OUT18 =
470 @######## ~~
471 10
472 .
473     open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp";
474     eval { write(OUT18); };
475     like $@,  qr/Repeated format line will never terminate/;
476     close OUT18 or die "Could not close: $!";
477 }
478
479 {   # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL)
480     my $v = 'gaga';
481     eval "format OUT19 = \n" .
482          '@<<<' . "\0\n" .
483          '$v' .   "\n" .
484          '@<<<' . "\0\n" .
485          '$v' . "\n.\n";
486     open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp";
487     write(OUT19);
488     close OUT19 or die "Could not close: $!";
489     my $res = cat('Op_write.tmp');
490     is $res, <<EOD;
491 gaga\0
492 gaga\0
493 EOD
494 }
495
496 {   # test 20: hash accesses; single '}' must not terminate format '}' (WL)
497     my %h = ( xkey => 'xval', ykey => 'yval' );
498     format OUT20 =
499 @>>>> @<<<< ~~
500 each %h
501 @>>>> @<<<<
502 $h{xkey}, $h{ykey}
503 @>>>> @<<<<
504 { $h{xkey}, $h{ykey}
505 }
506 }
507 .
508     my $exp = '';
509     while( my( $k, $v ) = each( %h ) ){
510         $exp .= sprintf( "%5s %s\n", $k, $v );
511     }
512     $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
513     $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
514     $exp .= "}\n";
515     open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp";
516     write(OUT20);
517     close OUT20 or die "Could not close: $!";
518     my $res = cat('Op_write.tmp');
519     is $res, $exp;
520 }
521
522
523 #####################
524 ## Section 2
525 ## numeric formatting
526 #####################
527
528 curr_test($bas_tests + 1);
529
530 for my $tref ( @NumTests ){
531     my $writefmt = shift( @$tref );
532     while (@$tref) {
533         my $val      = shift @$tref;
534         my $expected = shift @$tref;
535         my $writeres = swrite( $writefmt, $val );
536         if (ref $expected) {
537             like $writeres, $expected, $writefmt;
538         } else {
539             is $writeres, $expected, $writefmt;
540         }       
541     }
542 }
543
544
545 #####################################
546 ## Section 3
547 ## Easiest to add new tests just here
548 #####################################
549
550 # DAPM. Exercise a couple of error codepaths
551
552 {
553     local $~ = '';
554     eval { write };
555     like $@, qr/Undefined format ""/, 'format with 0-length name';
556
557     $~ = "\0foo";
558     eval { write };
559     like $@, qr/Undefined format "\0foo"/,
560         'no such format beginning with null';
561
562     $~ = "NOSUCHFORMAT";
563     eval { write };
564     like $@, qr/Undefined format "NOSUCHFORMAT"/, 'no such format';
565 }
566
567 select +(select(OUT21), do {
568     open(OUT21, '>Op_write.tmp') || die "Can't create Op_write.tmp";
569
570     format OUT21 =
571 @<<
572 $_
573 .
574
575     local $^ = '';
576     local $= = 1;
577     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
578     like $@, qr/Undefined top format ""/, 'top format with 0-length name';
579
580     $^ = "\0foo";
581     # For some reason, we have to do this twice to get the error again.
582     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
583     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
584     like $@, qr/Undefined top format "\0foo"/,
585         'no such top format beginning with null';
586
587     $^ = "NOSUCHFORMAT";
588     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
589     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
590     like $@, qr/Undefined top format "NOSUCHFORMAT"/, 'no such top format';
591
592     # reset things;
593     eval { write(OUT21) };
594     undef $^A;
595
596     close OUT21 or die "Could not close: $!";
597 })[0];
598
599
600
601 # [perl #119847],  [perl #119849], [perl #119851]
602 # Non-real vars like tied, overloaded and refs could, when stringified,
603 # fail to be processed properly, causing infinite loops on ~~, utf8
604 # warnings etc, ad nauseum.
605
606
607 my $u22a = "N" x 8;
608
609 format OUT22a =
610 '^<<<<<<<<'~~
611 $u22a
612 .
613
614 is_format_utf8(\*OUT22a,
615                "'NNNNNNNN '\n");
616
617
618 my $u22b = "N" x 8;
619 utf8::upgrade($u22b);
620
621 format OUT22b =
622 '^<<<<<<<<'~~
623 $u22b
624 .
625
626 is_format_utf8(\*OUT22b,
627                "'NNNNNNNN '\n");
628
629 my $u22c = "\x{FF}" x 8;
630
631 format OUT22c =
632 '^<<<<<<<<'~~
633 $u22c
634 .
635
636 is_format_utf8(\*OUT22c,
637                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
638
639 my $u22d = "\x{FF}" x 8;
640 utf8::upgrade($u22d);
641
642 format OUT22d =
643 '^<<<<<<<<'~~
644 $u22d
645 .
646
647 is_format_utf8(\*OUT22d,
648                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
649
650 my $u22e = "\x{100}" x 8;
651
652 format OUT22e =
653 '^<<<<<<<<'~~
654 $u22e
655 .
656
657 is_format_utf8(\*OUT22e,
658                "'\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100} '\n");
659
660
661 my $u22f = "N" x 8;
662
663 format OUT22f =
664 '^<'~~
665 $u22f
666 .
667
668 is_format_utf8(\*OUT22f,
669                "'NN'\n"x4);
670
671
672 my $u22g = "N" x 8;
673 utf8::upgrade($u22g);
674
675 format OUT22g =
676 '^<'~~
677 $u22g
678 .
679
680 is_format_utf8(\*OUT22g,
681                "'NN'\n"x4);
682
683 my $u22h = "\x{FF}" x 8;
684
685 format OUT22h =
686 '^<'~~
687 $u22h
688 .
689
690 is_format_utf8(\*OUT22h,
691                "'\x{FF}\x{FF}'\n"x4);
692
693 my $u22i = "\x{FF}" x 8;
694 utf8::upgrade($u22i);
695
696 format OUT22i =
697 '^<'~~
698 $u22i
699 .
700
701 is_format_utf8(\*OUT22i,
702                "'\x{FF}\x{FF}'\n"x4);
703
704 my $u22j = "\x{100}" x 8;
705
706 format OUT22j =
707 '^<'~~
708 $u22j
709 .
710
711 is_format_utf8(\*OUT22j,
712                "'\x{100}\x{100}'\n"x4);
713
714
715 tie my $u23a, 'Tie::StdScalar';
716 $u23a = "N" x 8;
717
718 format OUT23a =
719 '^<<<<<<<<'~~
720 $u23a
721 .
722
723 is_format_utf8(\*OUT23a,
724                "'NNNNNNNN '\n");
725
726
727 tie my $u23b, 'Tie::StdScalar';
728 $u23b = "N" x 8;
729 utf8::upgrade($u23b);
730
731 format OUT23b =
732 '^<<<<<<<<'~~
733 $u23b
734 .
735
736 is_format_utf8(\*OUT23b,
737                "'NNNNNNNN '\n");
738
739 tie my $u23c, 'Tie::StdScalar';
740 $u23c = "\x{FF}" x 8;
741
742 format OUT23c =
743 '^<<<<<<<<'~~
744 $u23c
745 .
746
747 is_format_utf8(\*OUT23c,
748                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
749
750 tie my $u23d, 'Tie::StdScalar';
751 my $temp = "\x{FF}" x 8;
752 utf8::upgrade($temp);
753 $u23d = $temp;
754
755 format OUT23d =
756 '^<<<<<<<<'~~
757 $u23d
758 .
759
760 is_format_utf8(\*OUT23d,
761                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
762
763 tie my $u23e, 'Tie::StdScalar';
764 $u23e = "\x{100}" x 8;
765
766 format OUT23e =
767 '^<<<<<<<<'~~
768 $u23e
769 .
770
771 is_format_utf8(\*OUT23e,
772                "'\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100} '\n");
773
774 tie my $u23f, 'Tie::StdScalar';
775 $u23f = "N" x 8;
776
777 format OUT23f =
778 '^<'~~
779 $u23f
780 .
781
782 is_format_utf8(\*OUT23f,
783                "'NN'\n"x4);
784
785
786 tie my $u23g, 'Tie::StdScalar';
787 my $temp = "N" x 8;
788 utf8::upgrade($temp);
789 $u23g = $temp;
790
791 format OUT23g =
792 '^<'~~
793 $u23g
794 .
795
796 is_format_utf8(\*OUT23g,
797                "'NN'\n"x4);
798
799 tie my $u23h, 'Tie::StdScalar';
800 $u23h = "\x{FF}" x 8;
801
802 format OUT23h =
803 '^<'~~
804 $u23h
805 .
806
807 is_format_utf8(\*OUT23h,
808                "'\x{FF}\x{FF}'\n"x4);
809
810 $temp = "\x{FF}" x 8;
811 utf8::upgrade($temp);
812 tie my $u23i, 'Tie::StdScalar';
813 $u23i = $temp;
814
815 format OUT23i =
816 '^<'~~
817 $u23i
818 .
819
820 is_format_utf8(\*OUT23i,
821                "'\x{FF}\x{FF}'\n"x4);
822
823 tie my $u23j, 'Tie::StdScalar';
824 $u23j = "\x{100}" x 8;
825
826 format OUT23j =
827 '^<'~~
828 $u23j
829 .
830
831 is_format_utf8(\*OUT23j,
832                "'\x{100}\x{100}'\n"x4);
833
834 {
835     package UTF8Toggle;
836
837     sub TIESCALAR {
838         my $class = shift;
839         my $value = shift;
840         my $state = shift||0;
841         return bless [$value, $state], $class;
842     }
843
844     sub FETCH {
845         my $self = shift;
846         $self->[1] = ! $self->[1];
847         if ($self->[1]) {
848            utf8::downgrade($self->[0]);
849         } else {
850            utf8::upgrade($self->[0]);
851         }
852         $self->[0];
853     }
854
855    sub STORE {
856        my $self = shift;
857        $self->[0] = shift;
858     }
859 }
860
861 tie my $u24a, 'UTF8Toggle';
862 $u24a = "N" x 8;
863
864 format OUT24a =
865 '^<<<<<<<<'~~
866 $u24a
867 .
868
869 is_format_utf8(\*OUT24a,
870                "'NNNNNNNN '\n");
871
872
873 tie my $u24b, 'UTF8Toggle';
874 $u24b = "N" x 8;
875 utf8::upgrade($u24b);
876
877 format OUT24b =
878 '^<<<<<<<<'~~
879 $u24b
880 .
881
882 is_format_utf8(\*OUT24b,
883                "'NNNNNNNN '\n");
884
885 tie my $u24c, 'UTF8Toggle';
886 $u24c = "\x{FF}" x 8;
887
888 format OUT24c =
889 '^<<<<<<<<'~~
890 $u24c
891 .
892
893 is_format_utf8(\*OUT24c,
894                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
895
896 tie my $u24d, 'UTF8Toggle', 1;
897 $u24d = "\x{FF}" x 8;
898
899 format OUT24d =
900 '^<<<<<<<<'~~
901 $u24d
902 .
903
904 is_format_utf8(\*OUT24d,
905                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
906
907
908
909 tie my $u24f, 'UTF8Toggle';
910 $u24f = "N" x 8;
911
912 format OUT24f =
913 '^<'~~
914 $u24f
915 .
916
917 is_format_utf8(\*OUT24f,
918                "'NN'\n"x4);
919
920
921 tie my $u24g, 'UTF8Toggle';
922 my $temp = "N" x 8;
923 utf8::upgrade($temp);
924 $u24g = $temp;
925
926 format OUT24g =
927 '^<'~~
928 $u24g
929 .
930
931 is_format_utf8(\*OUT24g,
932                "'NN'\n"x4);
933
934 tie my $u24h, 'UTF8Toggle';
935 $u24h = "\x{FF}" x 8;
936
937 format OUT24h =
938 '^<'~~
939 $u24h
940 .
941
942 is_format_utf8(\*OUT24h,
943                "'\x{FF}\x{FF}'\n"x4);
944
945 tie my $u24i, 'UTF8Toggle', 1;
946 $u24i = "\x{FF}" x 8;
947
948 format OUT24i =
949 '^<'~~
950 $u24i
951 .
952
953 is_format_utf8(\*OUT24i,
954                "'\x{FF}\x{FF}'\n"x4);
955
956 {
957     package OS;
958     use overload '""' => sub { ${$_[0]}; };
959
960     sub new {
961         my ($class, $value) = @_;
962         bless \$value, $class;
963     }
964 }
965
966 my $u25a = OS->new("N" x 8);
967
968 format OUT25a =
969 '^<<<<<<<<'~~
970 $u25a
971 .
972
973 is_format_utf8(\*OUT25a,
974                "'NNNNNNNN '\n");
975
976
977 my $temp = "N" x 8;
978 utf8::upgrade($temp);
979 my $u25b = OS->new($temp);
980
981 format OUT25b =
982 '^<<<<<<<<'~~
983 $u25b
984 .
985
986 is_format_utf8(\*OUT25b,
987                "'NNNNNNNN '\n");
988
989 my $u25c = OS->new("\x{FF}" x 8);
990
991 format OUT25c =
992 '^<<<<<<<<'~~
993 $u25c
994 .
995
996 is_format_utf8(\*OUT25c,
997                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
998
999 $temp = "\x{FF}" x 8;
1000 utf8::upgrade($temp);
1001 my $u25d = OS->new($temp);
1002
1003 format OUT25d =
1004 '^<<<<<<<<'~~
1005 $u25d
1006 .
1007
1008 is_format_utf8(\*OUT25d,
1009                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
1010
1011 my $u25e = OS->new("\x{100}" x 8);
1012
1013 format OUT25e =
1014 '^<<<<<<<<'~~
1015 $u25e
1016 .
1017
1018 is_format_utf8(\*OUT25e,
1019                "'\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100} '\n");
1020
1021
1022 my $u25f = OS->new("N" x 8);
1023
1024 format OUT25f =
1025 '^<'~~
1026 $u25f
1027 .
1028
1029 is_format_utf8(\*OUT25f,
1030                "'NN'\n"x4);
1031
1032
1033 $temp = "N" x 8;
1034 utf8::upgrade($temp);
1035 my $u25g = OS->new($temp);
1036
1037 format OUT25g =
1038 '^<'~~
1039 $u25g
1040 .
1041
1042 is_format_utf8(\*OUT25g,
1043                "'NN'\n"x4);
1044
1045 my $u25h = OS->new("\x{FF}" x 8);
1046
1047 format OUT25h =
1048 '^<'~~
1049 $u25h
1050 .
1051
1052 is_format_utf8(\*OUT25h,
1053                "'\x{FF}\x{FF}'\n"x4);
1054
1055 $temp = "\x{FF}" x 8;
1056 utf8::upgrade($temp);
1057 my $u25i = OS->new($temp);
1058
1059 format OUT25i =
1060 '^<'~~
1061 $u25i
1062 .
1063
1064 is_format_utf8(\*OUT25i,
1065                "'\x{FF}\x{FF}'\n"x4);
1066
1067 my $u25j = OS->new("\x{100}" x 8);
1068
1069 format OUT25j =
1070 '^<'~~
1071 $u25j
1072 .
1073
1074 is_format_utf8(\*OUT25j,
1075                "'\x{100}\x{100}'\n"x4);
1076
1077 {
1078     package OS::UTF8Toggle;
1079     use overload '""' => sub {
1080         my $self = shift;
1081         $self->[1] = ! $self->[1];
1082         if ($self->[1]) {
1083             utf8::downgrade($self->[0]);
1084         } else {
1085             utf8::upgrade($self->[0]);
1086         }
1087         $self->[0];
1088     };
1089
1090     sub new {
1091         my ($class, $value, $state) = @_;
1092         bless [$value, $state], $class;
1093     }
1094 }
1095
1096
1097 my $u26a = OS::UTF8Toggle->new("N" x 8);
1098
1099 format OUT26a =
1100 '^<<<<<<<<'~~
1101 $u26a
1102 .
1103
1104 is_format_utf8(\*OUT26a,
1105                "'NNNNNNNN '\n");
1106
1107
1108 my $u26b = OS::UTF8Toggle->new("N" x 8, 1);
1109
1110 format OUT26b =
1111 '^<<<<<<<<'~~
1112 $u26b
1113 .
1114
1115 is_format_utf8(\*OUT26b,
1116                "'NNNNNNNN '\n");
1117
1118 my $u26c = OS::UTF8Toggle->new("\x{FF}" x 8);
1119
1120 format OUT26c =
1121 '^<<<<<<<<'~~
1122 $u26c
1123 .
1124
1125 is_format_utf8(\*OUT26c,
1126                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
1127
1128 my $u26d = OS::UTF8Toggle->new("\x{FF}" x 8, 1);
1129
1130 format OUT26d =
1131 '^<<<<<<<<'~~
1132 $u26d
1133 .
1134
1135 is_format_utf8(\*OUT26d,
1136                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
1137
1138
1139 my $u26f = OS::UTF8Toggle->new("N" x 8);
1140
1141 format OUT26f =
1142 '^<'~~
1143 $u26f
1144 .
1145
1146 is_format_utf8(\*OUT26f,
1147                "'NN'\n"x4);
1148
1149
1150 my $u26g = OS::UTF8Toggle->new("N" x 8, 1);
1151
1152 format OUT26g =
1153 '^<'~~
1154 $u26g
1155 .
1156
1157 is_format_utf8(\*OUT26g,
1158                "'NN'\n"x4);
1159
1160 my $u26h = OS::UTF8Toggle->new("\x{FF}" x 8);
1161
1162 format OUT26h =
1163 '^<'~~
1164 $u26h
1165 .
1166
1167 is_format_utf8(\*OUT26h,
1168                "'\x{FF}\x{FF}'\n"x4);
1169
1170 my $u26i = OS::UTF8Toggle->new("\x{FF}" x 8, 1);
1171
1172 format OUT26i =
1173 '^<'~~
1174 $u26i
1175 .
1176
1177 is_format_utf8(\*OUT26i,
1178                "'\x{FF}\x{FF}'\n"x4);
1179
1180
1181
1182 {
1183     my $zero = $$ - $$;
1184
1185     package Number;
1186
1187     sub TIESCALAR {
1188         my $class = shift;
1189         my $value = shift;
1190         return bless \$value, $class;
1191     }
1192
1193     # The return value should always be SvNOK() only:
1194     sub FETCH {
1195         my $self = shift;
1196         # avoid "" getting converted to "0" and thus
1197         # causing an infinite loop
1198         return "" unless length ($$self);
1199         return $$self - 0.5 + $zero + 0.5;
1200     }
1201
1202    sub STORE {
1203        my $self = shift;
1204        $$self = shift;
1205     }
1206
1207    package ONumber;
1208
1209    use overload '""' => sub {
1210         my $self = shift;
1211         return $$self - 0.5 + $zero + 0.5;
1212     };
1213
1214     sub new {
1215        my $class = shift;
1216        my $value = shift;
1217        return bless \$value, $class;
1218    }
1219 }
1220
1221 my $v27a = 1/256;
1222
1223 format OUT27a =
1224 '^<<<<<<<<<'~~
1225 $v27a
1226 .
1227
1228 is_format_utf8(\*OUT27a,
1229                "'0.00390625'\n");
1230
1231 my $v27b = 1/256;
1232
1233 format OUT27b =
1234 '^<'~~
1235 $v27b
1236 .
1237
1238 is_format_utf8(\*OUT27b,
1239                "'0.'\n'00'\n'39'\n'06'\n'25'\n");
1240
1241 tie my $v27c, 'Number', 1/256;
1242
1243 format OUT27c =
1244 '^<<<<<<<<<'~~
1245 $v27c
1246 .
1247
1248 is_format_utf8(\*OUT27c,
1249                "'0.00390625'\n");
1250
1251 my $v27d = 1/256;
1252
1253 format OUT27d =
1254 '^<'~~
1255 $v27d
1256 .
1257
1258 is_format_utf8(\*OUT27d,
1259                "'0.'\n'00'\n'39'\n'06'\n'25'\n");
1260
1261 my $v27e = ONumber->new(1/256);
1262
1263 format OUT27e =
1264 '^<<<<<<<<<'~~
1265 $v27e
1266 .
1267
1268 is_format_utf8(\*OUT27e,
1269                "'0.00390625'\n");
1270
1271 my $v27f = ONumber->new(1/256);
1272
1273 format OUT27f =
1274 '^<'~~
1275 $v27f
1276 .
1277
1278 is_format_utf8(\*OUT27f,
1279                "'0.'\n'00'\n'39'\n'06'\n'25'\n");
1280
1281 {
1282     package Ref;
1283     use overload '""' => sub {
1284         return ${$_[0]};
1285     };
1286
1287     sub new {
1288        my $class = shift;
1289        my $value = shift;
1290        return bless \$value, $class;
1291    }
1292 }
1293
1294 my $v28a = {};
1295
1296 format OUT28a =
1297 '^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<'~~
1298 $v28a
1299 .
1300
1301
1302 # 'HASH(0x1716b60)     '
1303 my $qr_hash   = qr/^'HASH\(0x[0-9a-f]+\)\s+'\n$/;
1304
1305 # 'HASH'
1306 # '(0x1'
1307 # '716b'
1308 # 'c0) '
1309 my $qr_hash_m = qr/^'HASH'\n('[0-9a-fx() ]{4}'\n)+$/;
1310
1311 like_format_utf8(\*OUT28a, $qr_hash);
1312
1313 my $v28b = {};
1314
1315 format OUT28b =
1316 '^<<<'~~
1317 $v28b
1318 .
1319
1320 like_format_utf8(\*OUT28b, $qr_hash_m);
1321
1322
1323 tie my $v28c, 'Tie::StdScalar';
1324 $v28c = {};
1325
1326 format OUT28c =
1327 '^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<'~~
1328 $v28c
1329 .
1330
1331 like_format_utf8(\*OUT28c, $qr_hash);
1332
1333 tie my $v28d, 'Tie::StdScalar';
1334 $v28d = {};
1335
1336 format OUT28d =
1337 '^<<<'~~
1338 $v28d
1339 .
1340
1341 like_format_utf8(\*OUT28d, $qr_hash_m);
1342
1343 my $v28e = Ref->new({});
1344
1345 format OUT28e =
1346 '^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<'~~
1347 $v28e
1348 .
1349
1350 like_format_utf8(\*OUT28e, $qr_hash);
1351
1352 my $v28f = Ref->new({});
1353
1354 format OUT28f =
1355 '^<<<'~~
1356 $v28f
1357 .
1358
1359 like_format_utf8(\*OUT28f, $qr_hash_m);
1360
1361
1362
1363 {
1364   package Count;
1365
1366   sub TIESCALAR {
1367     my $class = shift;
1368     bless [shift, 0, 0], $class;
1369   }
1370
1371   sub FETCH {
1372     my $self = shift;
1373     ++$self->[1];
1374     $self->[0];
1375   }
1376
1377   sub STORE {
1378     my $self = shift;
1379     ++$self->[2];
1380     $self->[0] = shift;
1381   }
1382 }
1383
1384 {
1385   my ($pound_utf8, $pm_utf8) = map { my $a = "$_\x{100}"; chop $a; $a}
1386     my ($pound, $pm) = ("\xA3", "\xB1");
1387
1388   foreach my $first ('N', $pound, $pound_utf8) {
1389     foreach my $base ('N', $pm, $pm_utf8) {
1390       foreach my $second ($base, "$base\n", "$base\nMoo!", "$base\nMoo!\n",
1391                           "$base\nMoo!\n",) {
1392         foreach (['^*', qr/(.+)/], ['@*', qr/(.*?)$/s]) {
1393           my ($format, $re) = @$_;
1394           $format = "1^*2 3${format}4";
1395           foreach my $class ('', 'Count') {
1396             my $name = qq{swrite("$format", "$first", "$second") class="$class"};
1397             $name =~ s/\n/\\n/g;
1398             $name =~ s{(.)}{
1399                         ord($1) > 126 ? sprintf("\\x{%x}",ord($1)) : $1
1400                     }ge;
1401
1402             $first =~ /(.+)/ or die $first;
1403             my $expect = "1${1}2";
1404             $second =~ $re or die $second;
1405             $expect .= " 3${1}4";
1406
1407             if ($class) {
1408               my $copy1 = $first;
1409               my $copy2;
1410               tie $copy2, $class, $second;
1411               is swrite("$format", $copy1, $copy2), $expect, $name;
1412               my $obj = tied $copy2;
1413               is $obj->[1], 1, 'value read exactly once';
1414             } else {
1415               my ($copy1, $copy2) = ($first, $second);
1416               is swrite("$format", $copy1, $copy2), $expect, $name;
1417             }
1418           }
1419         }
1420       }
1421     }
1422   }
1423 }
1424
1425 {
1426   # This will fail an assertion in 5.10.0 built with -DDEBUGGING (because
1427   # pp_formline attempts to set SvCUR() on an SVt_RV). I suspect that it will
1428   # be doing something similarly out of bounds on everything from 5.000
1429   my $ref = [];
1430   my $exp = ">$ref<";
1431   is swrite('>^*<', $ref), $exp;
1432   $ref = [];
1433   my $exp = ">$ref<";
1434   is swrite('>@*<', $ref), $exp;
1435 }
1436
1437 format EMPTY =
1438 .
1439
1440 my $test = curr_test();
1441
1442 format Comment =
1443 ok @<<<<<
1444 $test
1445 .
1446
1447
1448 # RT #8698 format bug with undefined _TOP
1449
1450 open STDOUT_DUP, ">&STDOUT";
1451 my $oldfh = select STDOUT_DUP;
1452 $= = 10;
1453 {
1454   local $~ = "Comment";
1455   write;
1456   curr_test($test + 1);
1457   is $-, 9;
1458   is $^, "STDOUT_DUP_TOP";
1459 }
1460 select $oldfh;
1461 close STDOUT_DUP;
1462
1463 *CmT =  *{$::{Comment}}{FORMAT};
1464 ok  defined *{$::{CmT}}{FORMAT}, "glob assign";
1465
1466
1467 # RT #91032: Check that "non-real" strings like tie and overload work,
1468 # especially that they re-compile the pattern on each FETCH, and that
1469 # they don't overrun the buffer
1470
1471
1472 {
1473     package RT91032;
1474
1475     sub TIESCALAR { bless [] }
1476     my $i = 0;
1477     sub FETCH { $i++; "A$i @> Z\n" }
1478
1479     use overload '""' => \&FETCH;
1480
1481     tie my $f, 'RT91032';
1482
1483     formline $f, "a";
1484     formline $f, "bc";
1485     ::is $^A, "A1  a Z\nA2 bc Z\n", "RT 91032: tied";
1486     $^A = '';
1487
1488     my $g = bless []; # has overloaded stringify
1489     formline $g, "de";
1490     formline $g, "f";
1491     ::is $^A, "A3 de Z\nA4  f Z\n", "RT 91032: overloaded";
1492     $^A = '';
1493
1494     my $h = [];
1495     formline $h, "junk1";
1496     formline $h, "junk2";
1497     ::is ref($h), 'ARRAY', "RT 91032: array ref still a ref";
1498     ::like "$h", qr/^ARRAY\(0x[0-9a-f]+\)$/, "RT 91032: array stringifies ok";
1499     ::is $^A, "$h$h","RT 91032: stringified array";
1500     $^A = '';
1501
1502     # used to overwrite the ~~ in the *original SV with spaces. Naughty!
1503
1504     my $orig = my $format = "^<<<<< ~~\n";
1505     my $abc = "abc";
1506     formline $format, $abc;
1507     $^A ='';
1508     ::is $format, $orig, "RT91032: don't overwrite orig format string";
1509
1510     # check that ~ and ~~ are displayed correctly as whitespace,
1511     # under the influence of various different types of border
1512
1513     for my $n (1,2) {
1514         for my $lhs (' ', 'Y', '^<<<', '^|||', '^>>>') {
1515             for my $rhs ('', ' ', 'Z', '^<<<', '^|||', '^>>>') {
1516                 my $fmt = "^<B$lhs" . ('~' x $n) . "$rhs\n";
1517                 my $sfmt = ($fmt =~ s/~/ /gr);
1518                 my ($a, $bc, $stop);
1519                 ($a, $bc, $stop) = ('a', 'bc', 's');
1520                 # $stop is to stop '~~' deleting the whole line
1521                 formline $sfmt, $stop, $a, $bc;
1522                 my $exp = $^A;
1523                 $^A = '';
1524                 ($a, $bc, $stop) = ('a', 'bc', 's');
1525                 formline $fmt, $stop, $a, $bc;
1526                 my $got = $^A;
1527                 $^A = '';
1528                 $fmt =~ s/\n/\\n/;
1529                 ::is($got, $exp, "chop munging: [$fmt]");
1530             }
1531         }
1532     }
1533 }
1534
1535 # check that '~  (delete current line if empty) works when
1536 # the target gets upgraded to uft8 (and re-allocated) midstream.
1537
1538 {
1539     my $format = "\x{100}@~\n"; # format is utf8
1540     # this target is not utf8, but will expand (and get reallocated)
1541     # when upgraded to utf8.
1542     my $orig = "\x80\x81\x82";
1543     local $^A = $orig;
1544     my $empty = "";
1545     formline $format, $empty;
1546     is $^A , $orig, "~ and realloc";
1547
1548     # check similarly that trailing blank removal works ok
1549
1550     $format = "@<\n\x{100}"; # format is utf8
1551     chop $format;
1552     $orig = "   ";
1553     $^A = $orig;
1554     formline $format, "  ";
1555     is $^A, "$orig\n", "end-of-line blanks and realloc";
1556
1557     # and check this doesn't overflow the buffer
1558
1559     local $^A = '';
1560     $format = "@* @####\n";
1561     $orig = "x" x 100 . "\n";
1562     formline $format, $orig, 12345;
1563     is $^A, ("x" x 100) . " 12345\n", "\@* doesn't overflow";
1564
1565     # ...nor this (RT #130703).
1566     # Under 'use bytes', the two bytes (c2, 80) making up each \x80 char
1567     # each get expanded to two bytes (so four in total per \x80 char); the
1568     # buffer growth wasn't accounting for this doubling in size
1569
1570     {
1571         local $^A = '';
1572         my $format = "X\n\x{100}" . ("\x80" x 200);
1573         my $expected = $format;
1574         utf8::encode($expected);
1575         use bytes;
1576         formline($format);
1577         is $^A, $expected, "RT #130703";
1578     }
1579
1580     # further buffer overflows with RT #130703
1581
1582     {
1583         local $^A = '';
1584         my $n = 200;
1585         my $long = 'x' x 300;
1586         my $numf = ('@###' x $n);
1587         my $expected = $long . "\n" . ("   1" x $n);
1588         formline("@*\n$numf", $long, ('1') x $n);
1589
1590         is $^A, $expected, "RT #130703 part 2";
1591     }
1592
1593
1594     # make sure it can cope with formats > 64k
1595
1596     $format = 'x' x 65537;
1597     $^A = '';
1598     formline $format;
1599     # don't use 'is' here, as the diag output will be too long!
1600     ok $^A eq $format, ">64K";
1601 }
1602
1603
1604 SKIP: {
1605     skip_if_miniperl('miniperl does not support scalario');
1606     my $buf = "";
1607     open my $fh, ">", \$buf;
1608     my $old_fh = select $fh;
1609     local $~ = "CmT";
1610     write;
1611     select $old_fh;
1612     close $fh;
1613     is $buf, "ok $test\n", "write to duplicated format";
1614 }
1615
1616 format caret_A_test_TOP =
1617 T
1618 .
1619
1620 format caret_A_test =
1621 L1
1622 L2
1623 L3
1624 L4
1625 .
1626
1627 SKIP: {
1628     skip_if_miniperl('miniperl does not support scalario');
1629     my $buf = "";
1630     open my $fh, ">", \$buf;
1631     my $old_fh = select $fh;
1632     local $^ = "caret_A_test_TOP";
1633     local $~ = "caret_A_test";
1634     local $= = 3;
1635     local $^A = "A1\nA2\nA3\nA4\n";
1636     write;
1637     select $old_fh;
1638     close $fh;
1639     is $buf, "T\nA1\nA2\n\fT\nA3\nA4\n\fT\nL1\nL2\n\fT\nL3\nL4\n",
1640                     "assign to ^A sets FmLINES";
1641 }
1642
1643 fresh_perl_like(<<'EOP', qr/^Format STDOUT redefined at/, {stderr => 1}, '#64562 - Segmentation fault with redefined formats and warnings');
1644 #!./perl
1645
1646 use strict;
1647 use warnings; # crashes!
1648
1649 format =
1650 .
1651
1652 write;
1653
1654 format =
1655 .
1656
1657 write;
1658 EOP
1659
1660 fresh_perl_is(<<'EOP', ">ARRAY<\ncrunch_eth\n", {stderr => 1}, '#79532 - formline coerces its arguments');
1661 use strict;
1662 use warnings;
1663 my $zamm = ['crunch_eth'];
1664 formline $zamm;
1665 printf ">%s<\n", ref $zamm;
1666 print "$zamm->[0]\n";
1667 EOP
1668
1669 # [perl #129125] - detected by -fsanitize=address or valgrind
1670 # the compiled format would be freed when the format string was modified
1671 # by the chop operator
1672 fresh_perl_is(<<'EOP', "^", { stderr => 1 }, '#129125 - chop on format');
1673 my $x = '^@';
1674 formline$x=>$x;
1675 print $^A;
1676 EOP
1677
1678 fresh_perl_is(<<'EOP', '<^< xx AA><xx ^<><>', { stderr => 1 }, '#129125 - chop on format, later values');
1679 my $x = '^< xx ^<';
1680 my $y = 'AA';
1681 formline $x => $x, $y;
1682 print "<$^A><$x><$y>";
1683 EOP
1684
1685
1686 # [perl #73690]
1687
1688 select +(select(RT73690), do {
1689     open(RT73690, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1690     format RT73690 =
1691 @<< @<<
1692 11, 22
1693 .
1694
1695     my @ret;
1696
1697     @ret = write;
1698     is(scalar(@ret), 1);
1699     ok($ret[0]);
1700     @ret = scalar(write);
1701     is(scalar(@ret), 1);
1702     ok($ret[0]);
1703     @ret = write(RT73690);
1704     is(scalar(@ret), 1);
1705     ok($ret[0]);
1706     @ret = scalar(write(RT73690));
1707     is(scalar(@ret), 1);
1708     ok($ret[0]);
1709
1710     @ret = ('a', write, 'z');
1711     is(scalar(@ret), 3);
1712     is($ret[0], 'a');
1713     ok($ret[1]);
1714     is($ret[2], 'z');
1715     @ret = ('b', scalar(write), 'y');
1716     is(scalar(@ret), 3);
1717     is($ret[0], 'b');
1718     ok($ret[1]);
1719     is($ret[2], 'y');
1720     @ret = ('c', write(RT73690), 'x');
1721     is(scalar(@ret), 3);
1722     is($ret[0], 'c');
1723     ok($ret[1]);
1724     is($ret[2], 'x');
1725     @ret = ('d', scalar(write(RT73690)), 'w');
1726     is(scalar(@ret), 3);
1727     is($ret[0], 'd');
1728     ok($ret[1]);
1729     is($ret[2], 'w');
1730
1731     @ret = do { write; 'foo' };
1732     is(scalar(@ret), 1);
1733     is($ret[0], 'foo');
1734     @ret = do { scalar(write); 'bar' };
1735     is(scalar(@ret), 1);
1736     is($ret[0], 'bar');
1737     @ret = do { write(RT73690); 'baz' };
1738     is(scalar(@ret), 1);
1739     is($ret[0], 'baz');
1740     @ret = do { scalar(write(RT73690)); 'quux' };
1741     is(scalar(@ret), 1);
1742     is($ret[0], 'quux');
1743
1744     @ret = ('a', do { write; 'foo' }, 'z');
1745     is(scalar(@ret), 3);
1746     is($ret[0], 'a');
1747     is($ret[1], 'foo');
1748     is($ret[2], 'z');
1749     @ret = ('b', do { scalar(write); 'bar' }, 'y');
1750     is(scalar(@ret), 3);
1751     is($ret[0], 'b');
1752     is($ret[1], 'bar');
1753     is($ret[2], 'y');
1754     @ret = ('c', do { write(RT73690); 'baz' }, 'x');
1755     is(scalar(@ret), 3);
1756     is($ret[0], 'c');
1757     is($ret[1], 'baz');
1758     is($ret[2], 'x');
1759     @ret = ('d', do { scalar(write(RT73690)); 'quux' }, 'w');
1760     is(scalar(@ret), 3);
1761     is($ret[0], 'd');
1762     is($ret[1], 'quux');
1763     is($ret[2], 'w');
1764
1765     close RT73690 or die "Could not close: $!";
1766 })[0];
1767
1768 select +(select(RT73690_2), do {
1769     open(RT73690_2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1770     format RT73690_2 =
1771 @<< @<<
1772 return
1773 .
1774
1775     my @ret;
1776
1777     @ret = write;
1778     is(scalar(@ret), 1);
1779     ok(!$ret[0]);
1780     @ret = scalar(write);
1781     is(scalar(@ret), 1);
1782     ok(!$ret[0]);
1783     @ret = write(RT73690_2);
1784     is(scalar(@ret), 1);
1785     ok(!$ret[0]);
1786     @ret = scalar(write(RT73690_2));
1787     is(scalar(@ret), 1);
1788     ok(!$ret[0]);
1789
1790     @ret = ('a', write, 'z');
1791     is(scalar(@ret), 3);
1792     is($ret[0], 'a');
1793     ok(!$ret[1]);
1794     is($ret[2], 'z');
1795     @ret = ('b', scalar(write), 'y');
1796     is(scalar(@ret), 3);
1797     is($ret[0], 'b');
1798     ok(!$ret[1]);
1799     is($ret[2], 'y');
1800     @ret = ('c', write(RT73690_2), 'x');
1801     is(scalar(@ret), 3);
1802     is($ret[0], 'c');
1803     ok(!$ret[1]);
1804     is($ret[2], 'x');
1805     @ret = ('d', scalar(write(RT73690_2)), 'w');
1806     is(scalar(@ret), 3);
1807     is($ret[0], 'd');
1808     ok(!$ret[1]);
1809     is($ret[2], 'w');
1810
1811     @ret = do { write; 'foo' };
1812     is(scalar(@ret), 1);
1813     is($ret[0], 'foo');
1814     @ret = do { scalar(write); 'bar' };
1815     is(scalar(@ret), 1);
1816     is($ret[0], 'bar');
1817     @ret = do { write(RT73690_2); 'baz' };
1818     is(scalar(@ret), 1);
1819     is($ret[0], 'baz');
1820     @ret = do { scalar(write(RT73690_2)); 'quux' };
1821     is(scalar(@ret), 1);
1822     is($ret[0], 'quux');
1823
1824     @ret = ('a', do { write; 'foo' }, 'z');
1825     is(scalar(@ret), 3);
1826     is($ret[0], 'a');
1827     is($ret[1], 'foo');
1828     is($ret[2], 'z');
1829     @ret = ('b', do { scalar(write); 'bar' }, 'y');
1830     is(scalar(@ret), 3);
1831     is($ret[0], 'b');
1832     is($ret[1], 'bar');
1833     is($ret[2], 'y');
1834     @ret = ('c', do { write(RT73690_2); 'baz' }, 'x');
1835     is(scalar(@ret), 3);
1836     is($ret[0], 'c');
1837     is($ret[1], 'baz');
1838     is($ret[2], 'x');
1839     @ret = ('d', do { scalar(write(RT73690_2)); 'quux' }, 'w');
1840     is(scalar(@ret), 3);
1841     is($ret[0], 'd');
1842     is($ret[1], 'quux');
1843     is($ret[2], 'w');
1844
1845     close RT73690_2 or die "Could not close: $!";
1846 })[0];
1847
1848 open(UNDEF, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1849 select +(select(UNDEF), $~ = "UNDEFFORMAT")[0];
1850 format UNDEFFORMAT =
1851 @
1852 undef *UNDEFFORMAT
1853 .
1854 write UNDEF;
1855 pass "active format cannot be freed";
1856
1857 select +(select(UNDEF), $~ = "UNDEFFORMAT2")[0];
1858 format UNDEFFORMAT2 =
1859 @
1860 close UNDEF or die "Could not close: $!"; undef *UNDEF
1861 .
1862 write UNDEF;
1863 pass "freeing current handle in format";
1864 undef $^A;
1865
1866 ok !eval q|
1867 format foo {
1868 @<<<
1869 $a
1870 }
1871 ;1
1872 |, 'format foo { ... } is not allowed';
1873
1874 ok !eval q|
1875 format =
1876 @<<<
1877 }
1878 ;1
1879 |, 'format = ... } is not allowed';
1880
1881 open(NEST, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1882 format NEST =
1883 @<<<
1884 {
1885     my $birds = "birds";
1886     local *NEST = *BIRDS{FORMAT};
1887     write NEST;
1888     format BIRDS =
1889 @<<<<<
1890 $birds;
1891 .
1892     "nest"
1893 }
1894 .
1895 write NEST;
1896 close NEST or die "Could not close: $!";
1897 is cat('Op_write.tmp'), "birds\nnest\n", 'nested formats';
1898
1899 # A compilation error should not create a format
1900 eval q|
1901 format ERROR =
1902 @
1903 @_ =~ s///
1904 .
1905 |;
1906 eval { write ERROR };
1907 like $@, qr'Undefined format',
1908     'formats with compilation errors are not created';
1909
1910 # This syntax error used to cause a crash, double free, or a least
1911 # a bad read.
1912 # See the long-winded explanation at:
1913 #   https://rt.perl.org/rt3/Ticket/Display.html?id=43425#txn-1144500
1914 eval q|
1915 format =
1916 @
1917 use;format
1918 strict
1919 .
1920 |;
1921 pass('no crash with invalid use/format inside format');
1922
1923
1924 # Low-precedence operators on argument line
1925 format AND =
1926 @
1927 0 and die
1928 .
1929 $- = $=;
1930 ok eval { local $~ = "AND"; print "# "; write; 1 },
1931     "low-prec ops on arg line" or diag $@;
1932
1933 # Anonymous hashes
1934 open(HASH, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1935 format HASH =
1936 @<<<
1937 ${{qw[ Sun 0 Mon 1 Tue 2 Wed 3 Thu 4 Fri 5 Sat 6 ]}}{"Wed"}
1938 .
1939 write HASH;
1940 close HASH or die "Could not close: $!";
1941 is cat('Op_write.tmp'), "3\n", 'anonymous hashes';
1942
1943 open(HASH2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1944 format HASH2 =
1945 @<<<
1946 +{foo=>"bar"}
1947 .
1948 write HASH2;
1949 close HASH2 or die "Could not close: $!";
1950 is cat('Op_write.tmp'), "HASH\n", '+{...} is interpreted as anon hash';
1951
1952 # Anonymous hashes
1953 open(BLOCK, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1954 format BLOCK =
1955 @<<< @<<<
1956 {foo=>"bar"} # this is a block, not a hash!
1957 .
1958 write BLOCK;
1959 close BLOCK or die "Could not close: $!";
1960 is cat('Op_write.tmp'), "foo  bar\n", 'initial { is always BLOCK';
1961
1962 # pragmata inside argument line
1963 open(STRICT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1964 format STRICT =
1965 @<<<
1966 no strict; $foo
1967 .
1968 $::foo = 'oof::$';
1969 write STRICT;
1970 close STRICT or die "Could not close: $!";
1971 is cat('Op_write.tmp'), "oof:\n", 'pragmata on format line';
1972
1973 SKIP: {
1974    skip "no weak refs" unless eval { require Scalar::Util };
1975    sub Potshriggley {
1976 format Potshriggley =
1977 .
1978    }
1979    Scalar::Util::weaken(my $x = *Potshriggley{FORMAT});
1980    undef *Potshriggley;
1981    is $x, undef, 'formats in subs do not leak';
1982 }
1983
1984 fresh_perl_is(<<'EOP', <<'EXPECT',
1985 use warnings 'syntax' ;
1986 format STDOUT =
1987 ^*|^*
1988 my $x = q/dd/, $x
1989 .
1990 write;
1991 EOP
1992 dd|
1993 EXPECT
1994               { stderr => 1 }, '#123245 panic in sv_chop');
1995
1996 fresh_perl_is(<<'EOP', <<'EXPECT',
1997 use warnings 'syntax' ;
1998 format STDOUT =
1999 ^*|^*
2000 my $x = q/dd/
2001 .
2002 write;
2003 EOP
2004 Not enough format arguments at - line 4.
2005 dd|
2006 EXPECT
2007               { stderr => 1 }, '#123245 different panic in sv_chop');
2008
2009 fresh_perl_is(<<'EOP', <<'EXPECT',
2010 format STDOUT =
2011 # x at the end to make the spaces visible
2012 @... x
2013 q/a/
2014 .
2015 write;
2016 EOP
2017 a    x
2018 EXPECT
2019               { stderr => 1 }, '#123538 crash in FF_MORE');
2020
2021 # this used to assert fail
2022 fresh_perl_like(<<'EOP',
2023 format STDOUT =
2024 @
2025 0"$x"
2026 .
2027 print "got here\n";
2028 EOP
2029     qr/Use of comma-less variable list is deprecated.*got here/s,
2030     { stderr => 1 },
2031     '#128255 Assert fail in S_sublex_done');
2032
2033 {
2034     $^A = "";
2035     my $a = *globcopy;
2036     my $r = eval { formline "^<<", $a };
2037     is $@, "";
2038     ok $r, "^ format with glob copy";
2039     is $^A, "*ma", "^ format with glob copy";
2040     is $a, "in::globcopy", "^ format with glob copy";
2041 }
2042
2043 {
2044     $^A = "";
2045     my $r = eval { formline "^<<", *realglob };
2046     like $@, qr/\AModification of a read-only value attempted /;
2047     is $r, undef, "^ format with real glob";
2048     is $^A, "*ma", "^ format with real glob";
2049     is ref(\*realglob), "GLOB";
2050 }
2051
2052 $^A = "";
2053
2054 # [perl #130722] assertion failure
2055 fresh_perl_is('for(1..2){formline*0}', '', { stderr => 1 } , "#130722 - assertion failure");
2056
2057 #############################
2058 ## Section 4
2059 ## Add new tests *above* here
2060 #############################
2061
2062 # scary format testing from H.Merijn Brand
2063
2064 # Just a complete test for format, including top-, left- and bottom marging
2065 # and format detection through glob entries
2066
2067 if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' ||
2068     ($^O eq 'os2' and not eval '$OS2::can_fork')) {
2069   $test = curr_test();
2070  SKIP: {
2071       skip "'|-' and '-|' not supported", $tests - $test + 1;
2072   }
2073   exit(0);
2074 }
2075
2076
2077 $^  = "STDOUT_TOP";
2078 $=  =  7;               # Page length
2079 $-  =  0;               # Lines left
2080 my $ps = $^L; $^L = ""; # Catch the page separator
2081 my $tm =  1;            # Top margin (empty lines before first output)
2082 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
2083 my $lm =  4;            # Left margin (indent in spaces)
2084
2085 # -----------------------------------------------------------------------
2086 #
2087 # execute the rest of the script in a child process. The parent reads the
2088 # output from the child and compares it with <DATA>.
2089
2090 my @data = <DATA>;
2091
2092 select ((select (STDOUT), $| = 1)[0]); # flush STDOUT
2093
2094 my $opened = open FROM_CHILD, "-|";
2095 unless (defined $opened) {
2096     fail "open gave $!";
2097     exit 0;
2098 }
2099
2100 if ($opened) {
2101     # in parent here
2102
2103     pass 'open';
2104     my $s = " " x $lm;
2105     while (<FROM_CHILD>) {
2106         unless (@data) {
2107             fail 'too much output';
2108             exit;
2109         }
2110         s/^/$s/;
2111         my $exp = shift @data;
2112         is $_, $exp;
2113     }
2114     close FROM_CHILD;
2115     is "@data", "", "correct length of output";
2116     exit;
2117 }
2118
2119 # in child here
2120 $::NO_ENDING = 1;
2121
2122     select ((select (STDOUT), $| = 1)[0]);
2123 $tm = "\n" x $tm;
2124 $= -= $bm + 1; # count one for the trailing "----"
2125 my $lastmin = 0;
2126
2127 my @E;
2128
2129 sub wryte
2130 {
2131     $lastmin = $-;
2132     write;
2133     } # wryte;
2134
2135 sub footer
2136 {
2137     $% == 1 and return "";
2138
2139     $lastmin < $= and print "\n" x $lastmin;
2140     print "\n" x $bm, "----\n", $ps;
2141     $lastmin = $-;
2142     "";
2143     } # footer
2144
2145 # Yes, this is sick ;-)
2146 format TOP =
2147 @* ~
2148 @{[footer]}
2149 @* ~
2150 $tm
2151 .
2152
2153 format ENTRY =
2154 @ @<<<<~~
2155 @{(shift @E)||["",""]}
2156 .
2157
2158 format EOR =
2159 - -----
2160 .
2161
2162 sub has_format ($)
2163 {
2164     my $fmt = shift;
2165     exists $::{$fmt} or return 0;
2166     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
2167     open my $null, "> /dev/null" or die;
2168     my $fh = select $null;
2169     local $~ = $fmt;
2170     eval "write";
2171     select $fh;
2172     $@?0:1;
2173     } # has_format
2174
2175 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
2176 has_format ("ENTRY") or die "No format defined for ENTRY";
2177 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
2178                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
2179     @E = @$e;
2180     local $~ = "ENTRY";
2181     wryte;
2182     has_format ("EOR") or next;
2183     local $~ = "EOR";
2184     wryte;
2185     }
2186 if (has_format ("EOF")) {
2187     local $~ = "EOF";
2188     wryte;
2189     }
2190
2191 close STDOUT;
2192
2193 # That was test 48.
2194
2195 __END__
2196     
2197     1 Test1
2198     2 Test2
2199     3 Test3
2200     
2201     
2202     ----
2203     \f
2204     4 Test4
2205     5 Test5
2206     6 Test6
2207     
2208     
2209     ----
2210     \f
2211     7 Test7
2212     - -----
2213     
2214     
2215     
2216     ----
2217     \f
2218     1 1tseT
2219     2 2tseT
2220     3 3tseT
2221     
2222     
2223     ----
2224     \f
2225     4 4tseT
2226     5 5tseT
2227     - -----