This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Nested formats
[perl5.git] / t / op / write.t
CommitLineData
a687059c
LW
1#!./perl
2
9ccde9ea
JH
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
6108250c 6 require './test.pl';
9ccde9ea
JH
7}
8
90f67b00
NC
9use strict; # Amazed that this hackery can be made strict ...
10
a344b90b
DM
11# read in a file
12sub cat {
13 my $file = shift;
14 local $/;
15 open my $fh, $file or die "can't open '$file': $!";
16 my $data = <$fh>;
17 close $fh;
18 $data;
19}
20
a1b95068
LW
21#-- testing numeric fields in all variants (WL)
22
23sub swrite {
24 my $format = shift;
25 local $^A = ""; # don't litter, use a local bin
26 formline( $format, @_ );
27 return $^A;
28}
29
30my @NumTests = (
d1f6232e 31 # [ format, value1, expected1, value2, expected2, .... ]
9acd3e2c
DM
32 [ '@###', 0, ' 0', 1, ' 1', 9999.6, '####',
33 9999.4999, '9999', -999.6, '####', 1e+100, '####' ],
d1f6232e 34
9acd3e2c
DM
35 [ '@0##', 0, '0000', 1, '0001', 9999.6, '####',
36 -999.4999, '-999', -999.6, '####', 1e+100, '####' ],
d1f6232e
DM
37
38 [ '^###', 0, ' 0', undef, ' ' ],
39
40 [ '^0##', 0, '0000', undef, ' ' ],
41
9acd3e2c
DM
42 [ '@###.', 0, ' 0.', 1, ' 1.', 9999.6, '#####',
43 9999.4999, '9999.', -999.6, '#####' ],
d1f6232e 44
9acd3e2c 45 [ '@##.##', 0, ' 0.00', 1, ' 1.00', 999.996, '######',
d1f6232e
DM
46 999.99499, '999.99', -100, '######' ],
47
48 [ '@0#.##', 0, '000.00', 1, '001.00', 10, '010.00',
8975a8c2 49 -0.0001, qr/^[\-0]00\.00$/ ],
d1f6232e
DM
50
51);
52
a1b95068
LW
53
54my $num_tests = 0;
55for my $tref ( @NumTests ){
d1f6232e 56 $num_tests += (@$tref - 1)/2;
a1b95068
LW
57}
58#---------------------------------------------------------
59
60# number of tests in section 1
61my $bas_tests = 20;
62
63# number of tests in section 3
64a40898 64my $bug_tests = 8 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3 + 96 + 5;
a1b95068 65
f5b75c1c
NC
66# number of tests in section 4
67my $hmb_tests = 35;
68
69my $tests = $bas_tests + $num_tests + $bug_tests + $hmb_tests;
6108250c
NC
70
71plan $tests;
a687059c 72
a1b95068
LW
73############
74## Section 1
75############
76
90f67b00
NC
77use vars qw($fox $multiline $foo $good);
78
a687059c
LW
79format OUT =
80the quick brown @<<
81$fox
82jumped
83@*
84$multiline
85^<<<<<<<<<
86$foo
87^<<<<<<<<<
88$foo
89^<<<<<<...
90$foo
91now @<<the@>>>> for all@|||||men to come @<<<<
a0d0e21e
LW
92{
93 'i' . 's', "time\n", $good, 'to'
94}
a687059c
LW
95.
96
a0d0e21e 97open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
951af6b5 98END { unlink_all 'Op_write.tmp' }
a687059c
LW
99
100$fox = 'foxiness';
101$good = 'good';
102$multiline = "forescore\nand\nseven years\n";
103$foo = 'when in the course of human events it becomes necessary';
104write(OUT);
d1e4d418 105close OUT or die "Could not close: $!";
a687059c 106
90f67b00 107my $right =
a687059c
LW
108"the quick brown fox
109jumped
110forescore
111and
112seven years
113when in
114the course
115of huma...
116now is the time for all good men to come to\n";
117
951af6b5 118is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
a687059c 119
748a9306
LW
120$fox = 'wolfishness';
121my $fox = 'foxiness'; # Test a lexical variable.
122
a687059c
LW
123format OUT2 =
124the quick brown @<<
125$fox
126jumped
127@*
128$multiline
129^<<<<<<<<< ~~
130$foo
131now @<<the@>>>> for all@|||||men to come @<<<<
132'i' . 's', "time\n", $good, 'to'
133.
134
a0d0e21e 135open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp";
a687059c 136
a687059c
LW
137$good = 'good';
138$multiline = "forescore\nand\nseven years\n";
139$foo = 'when in the course of human events it becomes necessary';
140write(OUT2);
d1e4d418 141close OUT2 or die "Could not close: $!";
a687059c
LW
142
143$right =
144"the quick brown fox
145jumped
146forescore
147and
148seven years
149when in
150the course
151of human
152events it
153becomes
154necessary
155now is the time for all good men to come to\n";
156
951af6b5 157is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
a687059c 158
0f85fab0
LW
159eval <<'EOFORMAT';
160format OUT2 =
161the brown quick @<<
162$fox
163jumped
164@*
165$multiline
a0d0e21e 166and
0f85fab0
LW
167^<<<<<<<<< ~~
168$foo
169now @<<the@>>>> for all@|||||men to come @<<<<
170'i' . 's', "time\n", $good, 'to'
171.
172EOFORMAT
173
a0d0e21e 174open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
0f85fab0
LW
175
176$fox = 'foxiness';
177$good = 'good';
178$multiline = "forescore\nand\nseven years\n";
179$foo = 'when in the course of human events it becomes necessary';
180write(OUT2);
d1e4d418 181close OUT2 or die "Could not close: $!";
0f85fab0
LW
182
183$right =
184"the brown quick fox
185jumped
186forescore
187and
188seven years
a0d0e21e 189and
0f85fab0
LW
190when in
191the course
192of human
193events it
194becomes
195necessary
196now is the time for all good men to come to\n";
197
951af6b5 198is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
0f85fab0 199
55497cff
PP
200# formline tests
201
90f67b00 202$right = <<EOT;
55497cff
PP
203@ a
204@> ab
205@>> abc
206@>>> abc
207@>>>> abc
208@>>>>> abc
209@>>>>>> abc
210@>>>>>>> abc
211@>>>>>>>> abc
212@>>>>>>>>> abc
213@>>>>>>>>>> abc
214EOT
215
90f67b00
NC
216my $was1 = my $was2 = '';
217use vars '$format2';
55497cff
PP
218for (0..10) {
219 # lexical picture
220 $^A = '';
221 my $format1 = '@' . '>' x $_;
222 formline $format1, 'abc';
223 $was1 .= "$format1 $^A\n";
224 # global
225 $^A = '';
226 local $format2 = '@' . '>' x $_;
227 formline $format2, 'abc';
228 $was2 .= "$format2 $^A\n";
229}
90f67b00
NC
230is $was1, $right;
231is $was2, $right;
55497cff 232
7056ecde
URCI
233$^A = '';
234
235# more test
236
237format OUT3 =
238^<<<<<<...
239$foo
240.
241
242open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";
243
244$foo = 'fit ';
245write(OUT3);
d1e4d418 246close OUT3 or die "Could not close: $!";
7056ecde
URCI
247
248$right =
249"fit\n";
250
951af6b5 251is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
2027357e 252
7056ecde 253
445b3f51
GS
254# test lexicals and globals
255{
2027357e 256 my $test = curr_test();
445b3f51 257 my $this = "ok";
2027357e 258 our $that = $test;
445b3f51
GS
259 format LEX =
260@<<@|
261$this,$that
262.
263 open(LEX, ">&STDOUT") or die;
264 write LEX;
2027357e 265 $that = ++$test;
445b3f51 266 write LEX;
d1e4d418 267 close LEX or die "Could not close: $!";
2027357e 268 curr_test($test + 1);
445b3f51 269}
c2e66d9e
GS
270# LEX_INTERPNORMAL test
271my %e = ( a => 1 );
272format OUT4 =
273@<<<<<<
274"$e{a}"
275.
276open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
277write (OUT4);
d1e4d418 278close OUT4 or die "Could not close: $!";
951af6b5 279is cat('Op_write.tmp'), "1\n" and unlink_all "Op_write.tmp";
784707d5
JP
280
281eval <<'EOFORMAT';
282format OUT10 =
283@####.## @0###.##
284$test1, $test1
285.
286EOFORMAT
287
288open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
289
90f67b00 290use vars '$test1';
784707d5
JP
291$test1 = 12.95;
292write(OUT10);
d1e4d418 293close OUT10 or die "Could not close: $!";
784707d5
JP
294
295$right = " 12.95 00012.95\n";
951af6b5 296is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
784707d5
JP
297
298eval <<'EOFORMAT';
299format OUT11 =
300@0###.##
301$test1
302@ 0#
303$test1
304@0 #
305$test1
306.
307EOFORMAT
308
309open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";
310
311$test1 = 12.95;
312write(OUT11);
d1e4d418 313close OUT11 or die "Could not close: $!";
784707d5
JP
314
315$right =
316"00012.95
3171 0#
31810 #\n";
951af6b5 319is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
9ccde9ea 320
31869a79 321{
2027357e 322 my $test = curr_test();
71f882da 323 my $el;
a1b95068 324 format OUT12 =
31869a79
AE
325ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze
326$el
327.
2027357e 328 my %hash = ($test => 3);
a1b95068
LW
329 open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp";
330
31869a79 331 for $el (keys %hash) {
a1b95068 332 write(OUT12);
31869a79 333 }
a1b95068 334 close OUT12 or die "Could not close: $!";
a344b90b 335 print cat('Op_write.tmp');
2027357e 336 curr_test($test + 1);
31869a79
AE
337}
338
ea42cebc 339{
2027357e 340 my $test = curr_test();
ea42cebc
RGS
341 # Bug report and testcase by Alexey Tourbin
342 use Tie::Scalar;
343 my $v;
344 tie $v, 'Tie::StdScalar';
2027357e 345 $v = $test;
ea42cebc
RGS
346 format OUT13 =
347ok ^<<<<<<<<< ~~
348$v
349.
350 open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp";
351 write(OUT13);
352 close OUT13 or die "Could not close: $!";
a344b90b 353 print cat('Op_write.tmp');
2027357e 354 curr_test($test + 1);
ea42cebc
RGS
355}
356
a1b95068
LW
357{ # test 14
358 # Bug #24774 format without trailing \n failed assertion, but this
359 # must fail since we have a trailing ; in the eval'ed string (WL)
f5c235e7
DM
360 my @v = ('k');
361 eval "format OUT14 = \n@\n\@v";
2027357e 362 like $@, qr/Format not terminated/;
f5c235e7
DM
363}
364
a1b95068
LW
365{ # test 15
366 # text lost in ^<<< field with \r in value (WL)
367 my $txt = "line 1\rline 2";
368 format OUT15 =
369^<<<<<<<<<<<<<<<<<<
370$txt
371^<<<<<<<<<<<<<<<<<<
372$txt
373.
374 open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp";
375 write(OUT15);
376 close OUT15 or die "Could not close: $!";
a344b90b 377 my $res = cat('Op_write.tmp');
2027357e 378 is $res, "line 1\nline 2\n";
a1b95068
LW
379}
380
381{ # test 16: multiple use of a variable in same line with ^<
382 my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4";
383 format OUT16 =
384^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
385$txt, $txt
386^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
387$txt, $txt
388.
389 open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp";
390 write(OUT16);
391 close OUT16 or die "Could not close: $!";
a344b90b 392 my $res = cat('Op_write.tmp');
2027357e 393 is $res, <<EOD;
a1b95068
LW
394this_is_block_1 this_is_block_2
395this_is_block_3 this_is_block_4
396EOD
397}
398
399{ # test 17: @* "should be on a line of its own", but it should work
400 # cleanly with literals before and after. (WL)
401
402 my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n";
403 format OUT17 =
404Here we go: @* That's all, folks!
405 $txt
406.
407 open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp";
408 write(OUT17);
409 close OUT17 or die "Could not close: $!";
a344b90b 410 my $res = cat('Op_write.tmp');
a1b95068
LW
411 chomp( $txt );
412 my $exp = <<EOD;
413Here we go: $txt That's all, folks!
414EOD
2027357e 415 is $res, $exp;
a1b95068
LW
416}
417
418{ # test 18: @# and ~~ would cause runaway format, but we now
419 # catch this while compiling (WL)
420
421 format OUT18 =
422@######## ~~
42310
424.
425 open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp";
426 eval { write(OUT18); };
2027357e 427 like $@, qr/Repeated format line will never terminate/;
a1b95068
LW
428 close OUT18 or die "Could not close: $!";
429}
430
431{ # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL)
432 my $v = 'gaga';
433 eval "format OUT19 = \n" .
434 '@<<<' . "\0\n" .
435 '$v' . "\n" .
436 '@<<<' . "\0\n" .
437 '$v' . "\n.\n";
438 open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp";
439 write(OUT19);
a344b90b
DM
440 close OUT19 or die "Could not close: $!";
441 my $res = cat('Op_write.tmp');
2027357e 442 is $res, <<EOD;
a1b95068
LW
443gaga\0
444gaga\0
445EOD
446}
447
448{ # test 20: hash accesses; single '}' must not terminate format '}' (WL)
449 my %h = ( xkey => 'xval', ykey => 'yval' );
450 format OUT20 =
451@>>>> @<<<< ~~
452each %h
453@>>>> @<<<<
454$h{xkey}, $h{ykey}
455@>>>> @<<<<
456{ $h{xkey}, $h{ykey}
457}
458}
459.
460 my $exp = '';
461 while( my( $k, $v ) = each( %h ) ){
462 $exp .= sprintf( "%5s %s\n", $k, $v );
463 }
464 $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
465 $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
466 $exp .= "}\n";
467 open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp";
468 write(OUT20);
a344b90b
DM
469 close OUT20 or die "Could not close: $!";
470 my $res = cat('Op_write.tmp');
2027357e 471 is $res, $exp;
a1b95068
LW
472}
473
474
475#####################
476## Section 2
477## numeric formatting
478#####################
479
2027357e
NC
480curr_test($bas_tests + 1);
481
a1b95068
LW
482for my $tref ( @NumTests ){
483 my $writefmt = shift( @$tref );
d1f6232e
DM
484 while (@$tref) {
485 my $val = shift @$tref;
486 my $expected = shift @$tref;
a1b95068 487 my $writeres = swrite( $writefmt, $val );
2027357e
NC
488 if (ref $expected) {
489 like $writeres, $expected, $writefmt;
490 } else {
491 is $writeres, $expected, $writefmt;
492 }
a1b95068
LW
493 }
494}
495
496
497#####################################
498## Section 3
f5b75c1c 499## Easiest to add new tests just here
2027357e 500#####################################
9ccde9ea 501
30a1e583
DM
502# DAPM. Exercise a couple of error codepaths
503
504{
505 local $~ = '';
506 eval { write };
2d1ebc9b 507 like $@, qr/Undefined format ""/, 'format with 0-length name';
30a1e583 508
44b7e78a
FC
509 $~ = "\0foo";
510 eval { write };
511 like $@, qr/Undefined format "\0foo"/,
512 'no such format beginning with null';
513
30a1e583
DM
514 $~ = "NOSUCHFORMAT";
515 eval { write };
44b7e78a 516 like $@, qr/Undefined format "NOSUCHFORMAT"/, 'no such format';
30a1e583
DM
517}
518
44b7e78a
FC
519select +(select(OUT21), do {
520 open(OUT21, '>Op_write.tmp') || die "Can't create Op_write.tmp";
521
522 format OUT21 =
523@<<
524$_
525.
526
527 local $^ = '';
528 local $= = 1;
529 $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
530 like $@, qr/Undefined top format ""/, 'top format with 0-length name';
531
532 $^ = "\0foo";
533 # For some reason, we have to do this twice to get the error again.
534 $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
535 $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
536 like $@, qr/Undefined top format "\0foo"/,
537 'no such top format beginning with null';
538
539 $^ = "NOSUCHFORMAT";
540 $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
541 $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
542 like $@, qr/Undefined top format "NOSUCHFORMAT"/, 'no such top format';
543
544 # reset things;
545 eval { write(OUT21) };
546 undef $^A;
547
548 close OUT21 or die "Could not close: $!";
549})[0];
550
f3f2f1a3 551{
e8e72d41
NC
552 package Count;
553
554 sub TIESCALAR {
555 my $class = shift;
556 bless [shift, 0, 0], $class;
557 }
558
559 sub FETCH {
560 my $self = shift;
561 ++$self->[1];
562 $self->[0];
563 }
564
565 sub STORE {
566 my $self = shift;
567 ++$self->[2];
568 $self->[0] = shift;
569 }
570}
571
572{
573 my ($pound_utf8, $pm_utf8) = map { my $a = "$_\x{100}"; chop $a; $a}
f3f2f1a3
NC
574 my ($pound, $pm) = ("\xA3", "\xB1");
575
576 foreach my $first ('N', $pound, $pound_utf8) {
577 foreach my $base ('N', $pm, $pm_utf8) {
003d2c64
NC
578 foreach my $second ($base, "$base\n", "$base\nMoo!", "$base\nMoo!\n",
579 "$base\nMoo!\n",) {
580 foreach (['^*', qr/(.+)/], ['@*', qr/(.*?)$/s]) {
581 my ($format, $re) = @$_;
b57b1734 582 $format = "1^*2 3${format}4";
e8e72d41 583 foreach my $class ('', 'Count') {
b57b1734 584 my $name = qq{swrite("$format", "$first", "$second") class="$class"};
e8e72d41 585 $name =~ s/\n/\\n/g;
b57b1734
DM
586 $name =~ s{(.)}{
587 ord($1) > 126 ? sprintf("\\x{%x}",ord($1)) : $1
588 }ge;
e8e72d41
NC
589
590 $first =~ /(.+)/ or die $first;
591 my $expect = "1${1}2";
592 $second =~ $re or die $second;
593 $expect .= " 3${1}4";
594
595 if ($class) {
596 my $copy1 = $first;
597 my $copy2;
598 tie $copy2, $class, $second;
b57b1734 599 is swrite("$format", $copy1, $copy2), $expect, $name;
e8e72d41
NC
600 my $obj = tied $copy2;
601 is $obj->[1], 1, 'value read exactly once';
602 } else {
603 my ($copy1, $copy2) = ($first, $second);
b57b1734 604 is swrite("$format", $copy1, $copy2), $expect, $name;
e8e72d41
NC
605 }
606 }
003d2c64 607 }
f3f2f1a3
NC
608 }
609 }
610 }
611}
9ccde9ea 612
35c6393c
NC
613{
614 # This will fail an assertion in 5.10.0 built with -DDEBUGGING (because
615 # pp_formline attempts to set SvCUR() on an SVt_RV). I suspect that it will
616 # be doing something similarly out of bounds on everything from 5.000
617 my $ref = [];
618 is swrite('>^*<', $ref), ">$ref<";
619 is swrite('>@*<', $ref), ">$ref<";
620}
621
d57f9278
MB
622format EMPTY =
623.
624
f5b75c1c 625my $test = curr_test();
6108250c 626
d57f9278
MB
627format Comment =
628ok @<<<<<
629$test
630.
631
d57f9278 632
64eff8b7 633# RT #8698 format bug with undefined _TOP
0bd0581c
DM
634
635open STDOUT_DUP, ">&STDOUT";
636my $oldfh = select STDOUT_DUP;
637$= = 10;
6108250c
NC
638{
639 local $~ = "Comment";
640 write;
641 curr_test($test + 1);
64eff8b7 642 is $-, 9;
6108250c 643 is $^, "STDOUT_DUP_TOP";
0bd0581c
DM
644}
645select $oldfh;
68ba3c2c 646close STDOUT_DUP;
d57f9278 647
ef595a33
MB
648*CmT = *{$::{Comment}}{FORMAT};
649ok defined *{$::{CmT}}{FORMAT}, "glob assign";
650
3808a683
DM
651
652# RT #91032: Check that "non-real" strings like tie and overload work,
653# especially that they re-compile the pattern on each FETCH, and that
654# they don't overrun the buffer
655
656
657{
658 package RT91032;
659
660 sub TIESCALAR { bless [] }
661 my $i = 0;
662 sub FETCH { $i++; "A$i @> Z\n" }
663
664 use overload '""' => \&FETCH;
665
666 tie my $f, 'RT91032';
667
668 formline $f, "a";
669 formline $f, "bc";
670 ::is $^A, "A1 a Z\nA2 bc Z\n", "RT 91032: tied";
671 $^A = '';
672
673 my $g = bless []; # has overloaded stringify
674 formline $g, "de";
675 formline $g, "f";
676 ::is $^A, "A3 de Z\nA4 f Z\n", "RT 91032: overloaded";
677 $^A = '';
678
679 my $h = [];
680 formline $h, "junk1";
681 formline $h, "junk2";
682 ::is ref($h), 'ARRAY', "RT 91032: array ref still a ref";
683 ::like "$h", qr/^ARRAY\(0x[0-9a-f]+\)$/, "RT 91032: array stringifies ok";
684 ::is $^A, "$h$h","RT 91032: stringified array";
685 $^A = '';
686
687 # used to overwrite the ~~ in the *original SV with spaces. Naughty!
688
689 my $orig = my $format = "^<<<<< ~~\n";
690 my $abc = "abc";
691 formline $format, $abc;
692 $^A ='';
693 ::is $format, $orig, "RT91032: don't overwrite orig format string";
694
b57b1734
DM
695 # check that ~ and ~~ are displayed correctly as whitespace,
696 # under the influence of various different types of border
697
698 for my $n (1,2) {
699 for my $lhs (' ', 'Y', '^<<<', '^|||', '^>>>') {
700 for my $rhs ('', ' ', 'Z', '^<<<', '^|||', '^>>>') {
701 my $fmt = "^<B$lhs" . ('~' x $n) . "$rhs\n";
702 my $sfmt = ($fmt =~ s/~/ /gr);
703 my ($a, $bc, $stop);
704 ($a, $bc, $stop) = ('a', 'bc', 's');
705 # $stop is to stop '~~' deleting the whole line
706 formline $sfmt, $stop, $a, $bc;
707 my $exp = $^A;
708 $^A = '';
709 ($a, $bc, $stop) = ('a', 'bc', 's');
710 formline $fmt, $stop, $a, $bc;
711 my $got = $^A;
712 $^A = '';
713 $fmt =~ s/\n/\\n/;
714 ::is($got, $exp, "chop munging: [$fmt]");
715 }
716 }
717 }
3808a683
DM
718}
719
f5ada144
DM
720# check that '~ (delete current line if empty) works when
721# the target gets upgraded to uft8 (and re-allocated) midstream.
722
723{
724 my $format = "\x{100}@~\n"; # format is utf8
725 # this target is not utf8, but will expand (and get reallocated)
726 # when upgraded to utf8.
727 my $orig = "\x80\x81\x82";
728 local $^A = $orig;
729 my $empty = "";
730 formline $format, $empty;
731 is $^A , $orig, "~ and realloc";
732
733 # check similarly that trailing blank removal works ok
734
735 $format = "@<\n\x{100}"; # format is utf8
736 chop $format;
737 $orig = " ";
738 $^A = $orig;
739 formline $format, " ";
740 is $^A, "$orig\n", "end-of-line blanks and realloc";
26e935cf
DM
741
742 # and check this doesn't overflow the buffer
743
744 local $^A = '';
745 $format = "@* @####\n";
746 $orig = "x" x 100 . "\n";
747 formline $format, $orig, 12345;
748 is $^A, ("x" x 100) . " 12345\n", "\@* doesn't overflow";
76912796
DM
749
750 # make sure it can cope with formats > 64k
751
752 $format = 'x' x 65537;
753 $^A = '';
754 formline $format;
755 # don't use 'is' here, as the diag output will be too long!
756 ok $^A eq $format, ">64K";
f5ada144
DM
757}
758
3808a683 759
d3d1232e
NC
760SKIP: {
761 skip_if_miniperl('miniperl does not support scalario');
60fe2d11 762 my $buf = "";
fda0c190
MB
763 open my $fh, ">", \$buf;
764 my $old_fh = select $fh;
765 local $~ = "CmT";
766 write;
767 select $old_fh;
768 close $fh;
769 is $buf, "ok $test\n", "write to duplicated format";
770}
771
64eff8b7
DM
772format caret_A_test_TOP =
773T
774.
775
776format caret_A_test =
777L1
778L2
779L3
780L4
781.
782
783SKIP: {
784 skip_if_miniperl('miniperl does not support scalario');
785 my $buf = "";
786 open my $fh, ">", \$buf;
787 my $old_fh = select $fh;
788 local $^ = "caret_A_test_TOP";
789 local $~ = "caret_A_test";
790 local $= = 3;
791 local $^A = "A1\nA2\nA3\nA4\n";
792 write;
793 select $old_fh;
794 close $fh;
795 is $buf, "T\nA1\nA2\n\fT\nA3\nA4\n\fT\nL1\nL2\n\fT\nL3\nL4\n",
796 "assign to ^A sets FmLINES";
797}
798
ee6d2783
NC
799fresh_perl_like(<<'EOP', qr/^Format STDOUT redefined at/, {stderr => 1}, '#64562 - Segmentation fault with redefined formats and warnings');
800#!./perl
801
802use strict;
803use warnings; # crashes!
804
805format =
806.
807
808write;
809
810format =
811.
812
813write;
814EOP
815
37ffbfcc
NC
816fresh_perl_is(<<'EOP', ">ARRAY<\ncrunch_eth\n", {stderr => 1}, '#79532 - formline coerces its arguments');
817use strict;
818use warnings;
819my $zamm = ['crunch_eth'];
820formline $zamm;
821printf ">%s<\n", ref $zamm;
822print "$zamm->[0]\n";
823EOP
824
8e4ecf23
JL
825# [perl #73690]
826
827select +(select(RT73690), do {
828 open(RT73690, '>Op_write.tmp') || die "Can't create Op_write.tmp";
829 format RT73690 =
830@<< @<<
83111, 22
832.
833
834 my @ret;
591097e0 835
8e4ecf23
JL
836 @ret = write;
837 is(scalar(@ret), 1);
838 ok($ret[0]);
839 @ret = scalar(write);
840 is(scalar(@ret), 1);
841 ok($ret[0]);
842 @ret = write(RT73690);
843 is(scalar(@ret), 1);
844 ok($ret[0]);
845 @ret = scalar(write(RT73690));
846 is(scalar(@ret), 1);
847 ok($ret[0]);
848
591097e0
JL
849 @ret = ('a', write, 'z');
850 is(scalar(@ret), 3);
851 is($ret[0], 'a');
852 ok($ret[1]);
853 is($ret[2], 'z');
854 @ret = ('b', scalar(write), 'y');
855 is(scalar(@ret), 3);
856 is($ret[0], 'b');
857 ok($ret[1]);
858 is($ret[2], 'y');
859 @ret = ('c', write(RT73690), 'x');
860 is(scalar(@ret), 3);
861 is($ret[0], 'c');
862 ok($ret[1]);
863 is($ret[2], 'x');
864 @ret = ('d', scalar(write(RT73690)), 'w');
865 is(scalar(@ret), 3);
866 is($ret[0], 'd');
867 ok($ret[1]);
868 is($ret[2], 'w');
869
870 @ret = do { write; 'foo' };
871 is(scalar(@ret), 1);
872 is($ret[0], 'foo');
873 @ret = do { scalar(write); 'bar' };
874 is(scalar(@ret), 1);
875 is($ret[0], 'bar');
876 @ret = do { write(RT73690); 'baz' };
877 is(scalar(@ret), 1);
878 is($ret[0], 'baz');
879 @ret = do { scalar(write(RT73690)); 'quux' };
880 is(scalar(@ret), 1);
881 is($ret[0], 'quux');
882
883 @ret = ('a', do { write; 'foo' }, 'z');
884 is(scalar(@ret), 3);
885 is($ret[0], 'a');
886 is($ret[1], 'foo');
887 is($ret[2], 'z');
888 @ret = ('b', do { scalar(write); 'bar' }, 'y');
889 is(scalar(@ret), 3);
890 is($ret[0], 'b');
891 is($ret[1], 'bar');
892 is($ret[2], 'y');
893 @ret = ('c', do { write(RT73690); 'baz' }, 'x');
894 is(scalar(@ret), 3);
895 is($ret[0], 'c');
896 is($ret[1], 'baz');
897 is($ret[2], 'x');
898 @ret = ('d', do { scalar(write(RT73690)); 'quux' }, 'w');
899 is(scalar(@ret), 3);
900 is($ret[0], 'd');
901 is($ret[1], 'quux');
902 is($ret[2], 'w');
903
8e4ecf23
JL
904 close RT73690 or die "Could not close: $!";
905})[0];
906
907select +(select(RT73690_2), do {
908 open(RT73690_2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
909 format RT73690_2 =
910@<< @<<
911return
912.
913
914 my @ret;
591097e0 915
8e4ecf23
JL
916 @ret = write;
917 is(scalar(@ret), 1);
918 ok(!$ret[0]);
919 @ret = scalar(write);
920 is(scalar(@ret), 1);
921 ok(!$ret[0]);
922 @ret = write(RT73690_2);
923 is(scalar(@ret), 1);
924 ok(!$ret[0]);
925 @ret = scalar(write(RT73690_2));
926 is(scalar(@ret), 1);
927 ok(!$ret[0]);
928
591097e0
JL
929 @ret = ('a', write, 'z');
930 is(scalar(@ret), 3);
931 is($ret[0], 'a');
932 ok(!$ret[1]);
933 is($ret[2], 'z');
934 @ret = ('b', scalar(write), 'y');
935 is(scalar(@ret), 3);
936 is($ret[0], 'b');
937 ok(!$ret[1]);
938 is($ret[2], 'y');
939 @ret = ('c', write(RT73690_2), 'x');
940 is(scalar(@ret), 3);
941 is($ret[0], 'c');
942 ok(!$ret[1]);
943 is($ret[2], 'x');
944 @ret = ('d', scalar(write(RT73690_2)), 'w');
945 is(scalar(@ret), 3);
946 is($ret[0], 'd');
947 ok(!$ret[1]);
948 is($ret[2], 'w');
949
950 @ret = do { write; 'foo' };
951 is(scalar(@ret), 1);
952 is($ret[0], 'foo');
953 @ret = do { scalar(write); 'bar' };
954 is(scalar(@ret), 1);
955 is($ret[0], 'bar');
956 @ret = do { write(RT73690_2); 'baz' };
957 is(scalar(@ret), 1);
958 is($ret[0], 'baz');
959 @ret = do { scalar(write(RT73690_2)); 'quux' };
960 is(scalar(@ret), 1);
961 is($ret[0], 'quux');
962
963 @ret = ('a', do { write; 'foo' }, 'z');
964 is(scalar(@ret), 3);
965 is($ret[0], 'a');
966 is($ret[1], 'foo');
967 is($ret[2], 'z');
968 @ret = ('b', do { scalar(write); 'bar' }, 'y');
969 is(scalar(@ret), 3);
970 is($ret[0], 'b');
971 is($ret[1], 'bar');
972 is($ret[2], 'y');
973 @ret = ('c', do { write(RT73690_2); 'baz' }, 'x');
974 is(scalar(@ret), 3);
975 is($ret[0], 'c');
976 is($ret[1], 'baz');
977 is($ret[2], 'x');
978 @ret = ('d', do { scalar(write(RT73690_2)); 'quux' }, 'w');
979 is(scalar(@ret), 3);
980 is($ret[0], 'd');
981 is($ret[1], 'quux');
982 is($ret[2], 'w');
983
8e4ecf23
JL
984 close RT73690_2 or die "Could not close: $!";
985})[0];
986
ee23553f
FC
987open(UNDEF, '>Op_write.tmp') || die "Can't create Op_write.tmp";
988select +(select(UNDEF), $~ = "UNDEFFORMAT")[0];
989format UNDEFFORMAT =
990@
991undef *UNDEFFORMAT
992.
993write UNDEF;
994pass "active format cannot be freed";
c782dc1d
FC
995
996select +(select(UNDEF), $~ = "UNDEFFORMAT2")[0];
997format UNDEFFORMAT2 =
998@
999close UNDEF or die "Could not close: $!"; undef *UNDEF
1000.
1001write UNDEF;
1002pass "freeing current handle in format";
1003undef $^A;
ee23553f 1004
7c70caa5
FC
1005ok !eval q|
1006format foo {
1007@<<<
1008$a
1009}
1010;1
1011|, 'format foo { ... } is not allowed';
1012
1013ok !eval q|
1014format =
1015@<<<
1016}
1017;1
1018|, 'format = ... } is not allowed';
1019
64a40898
FC
1020open(NEST, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1021format NEST =
1022@<<<
1023{
1024 my $birds = "birds";
1025 local *NEST = *BIRDS{FORMAT};
1026 write NEST;
1027 format BIRDS =
1028@<<<<<
1029$birds;
1030.
1031 "nest"
1032}
1033.
1034write NEST;
1035close NEST or die "Could not close: $!";
1036is cat('Op_write.tmp'), "birds\nnest\n", 'nested formats';
1037
ee23553f 1038
2027357e
NC
1039#############################
1040## Section 4
1041## Add new tests *above* here
1042#############################
1043
f5b75c1c
NC
1044# scary format testing from H.Merijn Brand
1045
1046# Just a complete test for format, including top-, left- and bottom marging
1047# and format detection through glob entries
1048
7b903762 1049if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' ||
f5b75c1c
NC
1050 ($^O eq 'os2' and not eval '$OS2::can_fork')) {
1051 $test = curr_test();
1052 SKIP: {
1053 skip "'|-' and '-|' not supported", $tests - $test + 1;
1054 }
1055 exit(0);
1056}
1057
1058
0bd0581c
DM
1059$^ = "STDOUT_TOP";
1060$= = 7; # Page length
1061$- = 0; # Lines left
9ccde9ea
JH
1062my $ps = $^L; $^L = ""; # Catch the page separator
1063my $tm = 1; # Top margin (empty lines before first output)
1064my $bm = 2; # Bottom marging (empty lines between last text and footer)
1065my $lm = 4; # Left margin (indent in spaces)
1066
68ba3c2c
DM
1067# -----------------------------------------------------------------------
1068#
1069# execute the rest of the script in a child process. The parent reads the
1070# output from the child and compares it with <DATA>.
1071
1072my @data = <DATA>;
1073
1074select ((select (STDOUT), $| = 1)[0]); # flush STDOUT
1075
1076my $opened = open FROM_CHILD, "-|";
1077unless (defined $opened) {
6108250c
NC
1078 fail "open gave $!";
1079 exit 0;
68ba3c2c
DM
1080}
1081
1082if ($opened) {
1083 # in parent here
1084
6108250c 1085 pass 'open';
9ccde9ea 1086 my $s = " " x $lm;
68ba3c2c
DM
1087 while (<FROM_CHILD>) {
1088 unless (@data) {
6108250c 1089 fail 'too much output';
68ba3c2c
DM
1090 exit;
1091 }
9ccde9ea 1092 s/^/$s/;
68ba3c2c 1093 my $exp = shift @data;
6108250c 1094 is $_, $exp;
9ccde9ea 1095 }
68ba3c2c 1096 close FROM_CHILD;
6108250c 1097 is "@data", "", "correct length of output";
68ba3c2c
DM
1098 exit;
1099}
1100
1101# in child here
6108250c 1102$::NO_ENDING = 1;
68ba3c2c
DM
1103
1104 select ((select (STDOUT), $| = 1)[0]);
9ccde9ea
JH
1105$tm = "\n" x $tm;
1106$= -= $bm + 1; # count one for the trailing "----"
1107my $lastmin = 0;
1108
1109my @E;
1110
1111sub wryte
1112{
1113 $lastmin = $-;
1114 write;
1115 } # wryte;
1116
1117sub footer
1118{
1119 $% == 1 and return "";
1120
1121 $lastmin < $= and print "\n" x $lastmin;
1122 print "\n" x $bm, "----\n", $ps;
1123 $lastmin = $-;
1124 "";
1125 } # footer
1126
1127# Yes, this is sick ;-)
1128format TOP =
1129@* ~
1130@{[footer]}
1131@* ~
1132$tm
1133.
1134
9ccde9ea
JH
1135format ENTRY =
1136@ @<<<<~~
1137@{(shift @E)||["",""]}
1138.
1139
1140format EOR =
1141- -----
1142.
1143
1144sub has_format ($)
1145{
1146 my $fmt = shift;
1147 exists $::{$fmt} or return 0;
1148 $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
1149 open my $null, "> /dev/null" or die;
1150 my $fh = select $null;
1151 local $~ = $fmt;
1152 eval "write";
1153 select $fh;
1154 $@?0:1;
1155 } # has_format
1156
d57f9278 1157$^ = has_format ("TOP") ? "TOP" : "EMPTY";
9ccde9ea
JH
1158has_format ("ENTRY") or die "No format defined for ENTRY";
1159foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ],
1160 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
1161 @E = @$e;
1162 local $~ = "ENTRY";
1163 wryte;
1164 has_format ("EOR") or next;
1165 local $~ = "EOR";
1166 wryte;
1167 }
1168if (has_format ("EOF")) {
1169 local $~ = "EOF";
1170 wryte;
1171 }
1172
1173close STDOUT;
1174
ea42cebc 1175# That was test 48.
9ccde9ea
JH
1176
1177__END__
1178
1179 1 Test1
1180 2 Test2
1181 3 Test3
1182
1183
1184 ----
1185 \f
1186 4 Test4
1187 5 Test5
1188 6 Test6
1189
1190
1191 ----
1192 \f
1193 7 Test7
1194 - -----
1195
1196
1197
1198 ----
1199 \f
1200 1 1tseT
1201 2 2tseT
1202 3 3tseT
1203
1204
1205 ----
1206 \f
1207 4 4tseT
1208 5 5tseT
1209 - -----