This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Configure - d_sprintf_returns_strlen
[perl5.git] / t / op / write.t
CommitLineData
a687059c
LW
1#!./perl
2
9ccde9ea
JH
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
6}
7
a344b90b
DM
8# read in a file
9sub cat {
10 my $file = shift;
11 local $/;
12 open my $fh, $file or die "can't open '$file': $!";
13 my $data = <$fh>;
14 close $fh;
15 $data;
16}
17
a1b95068
LW
18#-- testing numeric fields in all variants (WL)
19
20sub swrite {
21 my $format = shift;
22 local $^A = ""; # don't litter, use a local bin
23 formline( $format, @_ );
24 return $^A;
25}
26
27my @NumTests = (
d1f6232e 28 # [ format, value1, expected1, value2, expected2, .... ]
9acd3e2c
DM
29 [ '@###', 0, ' 0', 1, ' 1', 9999.6, '####',
30 9999.4999, '9999', -999.6, '####', 1e+100, '####' ],
d1f6232e 31
9acd3e2c
DM
32 [ '@0##', 0, '0000', 1, '0001', 9999.6, '####',
33 -999.4999, '-999', -999.6, '####', 1e+100, '####' ],
d1f6232e
DM
34
35 [ '^###', 0, ' 0', undef, ' ' ],
36
37 [ '^0##', 0, '0000', undef, ' ' ],
38
9acd3e2c
DM
39 [ '@###.', 0, ' 0.', 1, ' 1.', 9999.6, '#####',
40 9999.4999, '9999.', -999.6, '#####' ],
d1f6232e 41
9acd3e2c 42 [ '@##.##', 0, ' 0.00', 1, ' 1.00', 999.996, '######',
d1f6232e
DM
43 999.99499, '999.99', -100, '######' ],
44
45 [ '@0#.##', 0, '000.00', 1, '001.00', 10, '010.00',
8975a8c2 46 -0.0001, qr/^[\-0]00\.00$/ ],
d1f6232e
DM
47
48);
49
a1b95068
LW
50
51my $num_tests = 0;
52for my $tref ( @NumTests ){
d1f6232e 53 $num_tests += (@$tref - 1)/2;
a1b95068
LW
54}
55#---------------------------------------------------------
56
57# number of tests in section 1
58my $bas_tests = 20;
59
60# number of tests in section 3
30a1e583 61my $hmb_tests = 39;
a1b95068
LW
62
63printf "1..%d\n", $bas_tests + $num_tests + $hmb_tests;
a687059c 64
a1b95068
LW
65############
66## Section 1
67############
68
a687059c
LW
69format OUT =
70the quick brown @<<
71$fox
72jumped
73@*
74$multiline
75^<<<<<<<<<
76$foo
77^<<<<<<<<<
78$foo
79^<<<<<<...
80$foo
81now @<<the@>>>> for all@|||||men to come @<<<<
a0d0e21e
LW
82{
83 'i' . 's', "time\n", $good, 'to'
84}
a687059c
LW
85.
86
a0d0e21e 87open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
19f4d710 88END { 1 while unlink 'Op_write.tmp' }
a687059c
LW
89
90$fox = 'foxiness';
91$good = 'good';
92$multiline = "forescore\nand\nseven years\n";
93$foo = 'when in the course of human events it becomes necessary';
94write(OUT);
d1e4d418 95close OUT or die "Could not close: $!";
a687059c
LW
96
97$right =
98"the quick brown fox
99jumped
100forescore
101and
102seven years
103when in
104the course
105of huma...
106now is the time for all good men to come to\n";
107
a344b90b 108if (cat('Op_write.tmp') eq $right)
784707d5 109 { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; }
a687059c
LW
110else
111 { print "not ok 1\n"; }
112
748a9306
LW
113$fox = 'wolfishness';
114my $fox = 'foxiness'; # Test a lexical variable.
115
a687059c
LW
116format OUT2 =
117the quick brown @<<
118$fox
119jumped
120@*
121$multiline
122^<<<<<<<<< ~~
123$foo
124now @<<the@>>>> for all@|||||men to come @<<<<
125'i' . 's', "time\n", $good, 'to'
126.
127
a0d0e21e 128open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp";
a687059c 129
a687059c
LW
130$good = 'good';
131$multiline = "forescore\nand\nseven years\n";
132$foo = 'when in the course of human events it becomes necessary';
133write(OUT2);
d1e4d418 134close OUT2 or die "Could not close: $!";
a687059c
LW
135
136$right =
137"the quick brown fox
138jumped
139forescore
140and
141seven years
142when in
143the course
144of human
145events it
146becomes
147necessary
148now is the time for all good men to come to\n";
149
a344b90b 150if (cat('Op_write.tmp') eq $right)
784707d5 151 { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; }
a687059c
LW
152else
153 { print "not ok 2\n"; }
154
0f85fab0
LW
155eval <<'EOFORMAT';
156format OUT2 =
157the brown quick @<<
158$fox
159jumped
160@*
161$multiline
a0d0e21e 162and
0f85fab0
LW
163^<<<<<<<<< ~~
164$foo
165now @<<the@>>>> for all@|||||men to come @<<<<
166'i' . 's', "time\n", $good, 'to'
167.
168EOFORMAT
169
a0d0e21e 170open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
0f85fab0
LW
171
172$fox = 'foxiness';
173$good = 'good';
174$multiline = "forescore\nand\nseven years\n";
175$foo = 'when in the course of human events it becomes necessary';
176write(OUT2);
d1e4d418 177close OUT2 or die "Could not close: $!";
0f85fab0
LW
178
179$right =
180"the brown quick fox
181jumped
182forescore
183and
184seven years
a0d0e21e 185and
0f85fab0
LW
186when in
187the course
188of human
189events it
190becomes
191necessary
192now is the time for all good men to come to\n";
193
a344b90b 194if (cat('Op_write.tmp') eq $right)
784707d5 195 { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; }
0f85fab0
LW
196else
197 { print "not ok 3\n"; }
198
55497cff
PP
199# formline tests
200
201$mustbe = <<EOT;
202@ a
203@> ab
204@>> abc
205@>>> abc
206@>>>> abc
207@>>>>> abc
208@>>>>>> abc
209@>>>>>>> abc
210@>>>>>>>> abc
211@>>>>>>>>> abc
212@>>>>>>>>>> abc
213EOT
214
215$was1 = $was2 = '';
216for (0..10) {
217 # lexical picture
218 $^A = '';
219 my $format1 = '@' . '>' x $_;
220 formline $format1, 'abc';
221 $was1 .= "$format1 $^A\n";
222 # global
223 $^A = '';
224 local $format2 = '@' . '>' x $_;
225 formline $format2, 'abc';
226 $was2 .= "$format2 $^A\n";
227}
228print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n";
229print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n";
230
7056ecde
URCI
231$^A = '';
232
233# more test
234
235format OUT3 =
236^<<<<<<...
237$foo
238.
239
240open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";
241
242$foo = 'fit ';
243write(OUT3);
d1e4d418 244close OUT3 or die "Could not close: $!";
7056ecde
URCI
245
246$right =
247"fit\n";
248
a344b90b 249if (cat('Op_write.tmp') eq $right)
784707d5 250 { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; }
7056ecde
URCI
251else
252 { print "not ok 6\n"; }
253
445b3f51
GS
254# test lexicals and globals
255{
256 my $this = "ok";
257 our $that = 7;
258 format LEX =
259@<<@|
260$this,$that
261.
262 open(LEX, ">&STDOUT") or die;
263 write LEX;
264 $that = 8;
265 write LEX;
d1e4d418 266 close LEX or die "Could not close: $!";
445b3f51 267}
c2e66d9e
GS
268# LEX_INTERPNORMAL test
269my %e = ( a => 1 );
270format OUT4 =
271@<<<<<<
272"$e{a}"
273.
274open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
275write (OUT4);
d1e4d418 276close OUT4 or die "Could not close: $!";
a344b90b 277if (cat('Op_write.tmp') eq "1\n") {
c2e66d9e 278 print "ok 9\n";
784707d5 279 1 while unlink "Op_write.tmp";
c2e66d9e
GS
280 }
281else {
282 print "not ok 9\n";
283 }
784707d5
JP
284
285eval <<'EOFORMAT';
286format OUT10 =
287@####.## @0###.##
288$test1, $test1
289.
290EOFORMAT
291
292open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
293
294$test1 = 12.95;
295write(OUT10);
d1e4d418 296close OUT10 or die "Could not close: $!";
784707d5
JP
297
298$right = " 12.95 00012.95\n";
a344b90b 299if (cat('Op_write.tmp') eq $right)
784707d5
JP
300 { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; }
301else
302 { print "not ok 10\n"; }
303
304eval <<'EOFORMAT';
305format OUT11 =
306@0###.##
307$test1
308@ 0#
309$test1
310@0 #
311$test1
312.
313EOFORMAT
314
315open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";
316
317$test1 = 12.95;
318write(OUT11);
d1e4d418 319close OUT11 or die "Could not close: $!";
784707d5
JP
320
321$right =
322"00012.95
3231 0#
32410 #\n";
a344b90b 325if (cat('Op_write.tmp') eq $right)
784707d5
JP
326 { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; }
327else
328 { print "not ok 11\n"; }
9ccde9ea 329
31869a79 330{
71f882da 331 my $el;
a1b95068 332 format OUT12 =
31869a79
AE
333ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze
334$el
335.
336 my %hash = (12 => 3);
a1b95068
LW
337 open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp";
338
31869a79 339 for $el (keys %hash) {
a1b95068 340 write(OUT12);
31869a79 341 }
a1b95068 342 close OUT12 or die "Could not close: $!";
a344b90b 343 print cat('Op_write.tmp');
a1b95068 344
31869a79
AE
345}
346
ea42cebc
RGS
347{
348 # Bug report and testcase by Alexey Tourbin
349 use Tie::Scalar;
350 my $v;
351 tie $v, 'Tie::StdScalar';
352 $v = 13;
353 format OUT13 =
354ok ^<<<<<<<<< ~~
355$v
356.
357 open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp";
358 write(OUT13);
359 close OUT13 or die "Could not close: $!";
a344b90b 360 print cat('Op_write.tmp');
ea42cebc
RGS
361}
362
a1b95068
LW
363{ # test 14
364 # Bug #24774 format without trailing \n failed assertion, but this
365 # must fail since we have a trailing ; in the eval'ed string (WL)
f5c235e7
DM
366 my @v = ('k');
367 eval "format OUT14 = \n@\n\@v";
ee09ed4c
NC
368 print +($@ && $@ =~ /Format not terminated/)
369 ? "ok 14\n" : "not ok 14 $@\n";
c5ee2135 370
f5c235e7
DM
371}
372
a1b95068
LW
373{ # test 15
374 # text lost in ^<<< field with \r in value (WL)
375 my $txt = "line 1\rline 2";
376 format OUT15 =
377^<<<<<<<<<<<<<<<<<<
378$txt
379^<<<<<<<<<<<<<<<<<<
380$txt
381.
382 open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp";
383 write(OUT15);
384 close OUT15 or die "Could not close: $!";
a344b90b 385 my $res = cat('Op_write.tmp');
a1b95068
LW
386 print $res eq "line 1\nline 2\n" ? "ok 15\n" : "not ok 15\n";
387}
388
389{ # test 16: multiple use of a variable in same line with ^<
390 my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4";
391 format OUT16 =
392^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
393$txt, $txt
394^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
395$txt, $txt
396.
397 open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp";
398 write(OUT16);
399 close OUT16 or die "Could not close: $!";
a344b90b 400 my $res = cat('Op_write.tmp');
a1b95068
LW
401 print $res eq <<EOD ? "ok 16\n" : "not ok 16\n";
402this_is_block_1 this_is_block_2
403this_is_block_3 this_is_block_4
404EOD
405}
406
407{ # test 17: @* "should be on a line of its own", but it should work
408 # cleanly with literals before and after. (WL)
409
410 my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n";
411 format OUT17 =
412Here we go: @* That's all, folks!
413 $txt
414.
415 open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp";
416 write(OUT17);
417 close OUT17 or die "Could not close: $!";
a344b90b 418 my $res = cat('Op_write.tmp');
a1b95068
LW
419 chomp( $txt );
420 my $exp = <<EOD;
421Here we go: $txt That's all, folks!
422EOD
423 print $res eq $exp ? "ok 17\n" : "not ok 17\n";
424}
425
426{ # test 18: @# and ~~ would cause runaway format, but we now
427 # catch this while compiling (WL)
428
429 format OUT18 =
430@######## ~~
43110
432.
433 open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp";
434 eval { write(OUT18); };
ee09ed4c
NC
435 print +($@ && $@ =~ /Repeated format line will never terminate/)
436 ? "ok 18\n" : "not ok 18: $@\n";
a1b95068
LW
437 close OUT18 or die "Could not close: $!";
438}
439
440{ # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL)
441 my $v = 'gaga';
442 eval "format OUT19 = \n" .
443 '@<<<' . "\0\n" .
444 '$v' . "\n" .
445 '@<<<' . "\0\n" .
446 '$v' . "\n.\n";
447 open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp";
448 write(OUT19);
a344b90b
DM
449 close OUT19 or die "Could not close: $!";
450 my $res = cat('Op_write.tmp');
a1b95068
LW
451 print $res eq <<EOD ? "ok 19\n" : "not ok 19\n";
452gaga\0
453gaga\0
454EOD
455}
456
457{ # test 20: hash accesses; single '}' must not terminate format '}' (WL)
458 my %h = ( xkey => 'xval', ykey => 'yval' );
459 format OUT20 =
460@>>>> @<<<< ~~
461each %h
462@>>>> @<<<<
463$h{xkey}, $h{ykey}
464@>>>> @<<<<
465{ $h{xkey}, $h{ykey}
466}
467}
468.
469 my $exp = '';
470 while( my( $k, $v ) = each( %h ) ){
471 $exp .= sprintf( "%5s %s\n", $k, $v );
472 }
473 $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
474 $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
475 $exp .= "}\n";
476 open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp";
477 write(OUT20);
a344b90b
DM
478 close OUT20 or die "Could not close: $!";
479 my $res = cat('Op_write.tmp');
a1b95068 480 print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n";
a1b95068
LW
481}
482
483
484#####################
485## Section 2
486## numeric formatting
487#####################
488
489my $nt = $bas_tests;
490for my $tref ( @NumTests ){
491 my $writefmt = shift( @$tref );
d1f6232e
DM
492 while (@$tref) {
493 my $val = shift @$tref;
494 my $expected = shift @$tref;
a1b95068 495 my $writeres = swrite( $writefmt, $val );
a1b95068 496 $nt++;
8975a8c2
DM
497 my $ok = ref($expected)
498 ? $writeres =~ $expected
499 : $writeres eq $expected;
500
501 print $ok
68ba3c2c 502 ? "ok $nt - $writefmt\n"
176ab42a 503 : "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n";
a1b95068
LW
504 }
505}
506
507
508#####################################
509## Section 3
510## Easiest to add new tests above here
ea42cebc
RGS
511#######################################
512
a1b95068 513# scary format testing from H.Merijn Brand
ea42cebc 514
a1b95068
LW
515my $test = $bas_tests + $num_tests + 1;
516my $tests = $bas_tests + $num_tests + $hmb_tests;
9ccde9ea 517
dc459aad 518if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' ||
764df951 519 ($^O eq 'os2' and not eval '$OS2::can_fork')) {
ea42cebc
RGS
520 foreach ($test..$tests) {
521 print "ok $_ # skipped: '|-' and '-|' not supported\n";
522 }
d4a0c6f3
CB
523 exit(0);
524}
525
9ccde9ea 526
ea42cebc 527use strict; # Amazed that this hackery can be made strict ...
d57f9278 528
30a1e583
DM
529# DAPM. Exercise a couple of error codepaths
530
531{
532 local $~ = '';
533 eval { write };
534 print "not " unless $@ and $@ =~ /Not a format reference/;
535 print "ok $test - Not a format reference\n";
536 $test++;
537
538 $~ = "NOSUCHFORMAT";
539 eval { write };
540 print "not " unless $@ and $@ =~ /Undefined format/;
541 print "ok $test - Undefined format\n";
542 $test++;
543}
544
9ccde9ea
JH
545# Just a complete test for format, including top-, left- and bottom marging
546# and format detection through glob entries
547
d57f9278
MB
548format EMPTY =
549.
550
551format Comment =
552ok @<<<<<
553$test
554.
555
d57f9278
MB
556
557# [ID 20020227.005] format bug with undefined _TOP
0bd0581c
DM
558
559open STDOUT_DUP, ">&STDOUT";
560my $oldfh = select STDOUT_DUP;
561$= = 10;
d57f9278
MB
562{ local $~ = "Comment";
563 write;
564 $test++;
565 print $- == 9
3444c34c 566 ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n";
d57f9278 567 $test++;
0bd0581c
DM
568 print $^ eq "STDOUT_DUP_TOP"
569 ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n";
d57f9278 570 $test++;
0bd0581c
DM
571}
572select $oldfh;
68ba3c2c 573close STDOUT_DUP;
d57f9278 574
0bd0581c
DM
575$^ = "STDOUT_TOP";
576$= = 7; # Page length
577$- = 0; # Lines left
9ccde9ea
JH
578my $ps = $^L; $^L = ""; # Catch the page separator
579my $tm = 1; # Top margin (empty lines before first output)
580my $bm = 2; # Bottom marging (empty lines between last text and footer)
581my $lm = 4; # Left margin (indent in spaces)
582
68ba3c2c
DM
583# -----------------------------------------------------------------------
584#
585# execute the rest of the script in a child process. The parent reads the
586# output from the child and compares it with <DATA>.
587
588my @data = <DATA>;
589
590select ((select (STDOUT), $| = 1)[0]); # flush STDOUT
591
592my $opened = open FROM_CHILD, "-|";
593unless (defined $opened) {
594 print "not ok $test - open gave $!\n"; exit 0;
595}
596
597if ($opened) {
598 # in parent here
599
600 print "ok $test - open\n"; $test++;
9ccde9ea 601 my $s = " " x $lm;
68ba3c2c
DM
602 while (<FROM_CHILD>) {
603 unless (@data) {
604 print "not ok $test - too much output\n";
605 exit;
606 }
9ccde9ea 607 s/^/$s/;
68ba3c2c
DM
608 my $exp = shift @data;
609 print + ($_ eq $exp ? "" : "not "), "ok ", $test++, " \n";
610 if ($_ ne $exp) {
611 s/\n/\\n/g for $_, $exp;
612 print "#expected: $exp\n#got: $_\n";
9ccde9ea 613 }
9ccde9ea 614 }
68ba3c2c 615 close FROM_CHILD;
0e528f24 616 print + (@data?"not ":""), "ok ", $test++, " - too little output\n";
68ba3c2c
DM
617 exit;
618}
619
620# in child here
621
622 select ((select (STDOUT), $| = 1)[0]);
9ccde9ea
JH
623$tm = "\n" x $tm;
624$= -= $bm + 1; # count one for the trailing "----"
625my $lastmin = 0;
626
627my @E;
628
629sub wryte
630{
631 $lastmin = $-;
632 write;
633 } # wryte;
634
635sub footer
636{
637 $% == 1 and return "";
638
639 $lastmin < $= and print "\n" x $lastmin;
640 print "\n" x $bm, "----\n", $ps;
641 $lastmin = $-;
642 "";
643 } # footer
644
645# Yes, this is sick ;-)
646format TOP =
647@* ~
648@{[footer]}
649@* ~
650$tm
651.
652
9ccde9ea
JH
653format ENTRY =
654@ @<<<<~~
655@{(shift @E)||["",""]}
656.
657
658format EOR =
659- -----
660.
661
662sub has_format ($)
663{
664 my $fmt = shift;
665 exists $::{$fmt} or return 0;
666 $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
667 open my $null, "> /dev/null" or die;
668 my $fh = select $null;
669 local $~ = $fmt;
670 eval "write";
671 select $fh;
672 $@?0:1;
673 } # has_format
674
d57f9278 675$^ = has_format ("TOP") ? "TOP" : "EMPTY";
9ccde9ea
JH
676has_format ("ENTRY") or die "No format defined for ENTRY";
677foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ],
678 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
679 @E = @$e;
680 local $~ = "ENTRY";
681 wryte;
682 has_format ("EOR") or next;
683 local $~ = "EOR";
684 wryte;
685 }
686if (has_format ("EOF")) {
687 local $~ = "EOF";
688 wryte;
689 }
690
691close STDOUT;
692
ea42cebc 693# That was test 48.
9ccde9ea
JH
694
695__END__
696
697 1 Test1
698 2 Test2
699 3 Test3
700
701
702 ----
703 \f
704 4 Test4
705 5 Test5
706 6 Test6
707
708
709 ----
710 \f
711 7 Test7
712 - -----
713
714
715
716 ----
717 \f
718 1 1tseT
719 2 2tseT
720 3 3tseT
721
722
723 ----
724 \f
725 4 4tseT
726 5 5tseT
727 - -----