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