This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
stop t/op/write.t failures under stdio by always closing files
[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
61my $hmb_tests = 36;
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";
c5ee2135
LW
368 print $@ ? "ok 14\n" : "not ok 14\n";
369
f5c235e7
DM
370}
371
a1b95068
LW
372{ # test 15
373 # text lost in ^<<< field with \r in value (WL)
374 my $txt = "line 1\rline 2";
375 format OUT15 =
376^<<<<<<<<<<<<<<<<<<
377$txt
378^<<<<<<<<<<<<<<<<<<
379$txt
380.
381 open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp";
382 write(OUT15);
383 close OUT15 or die "Could not close: $!";
a344b90b 384 my $res = cat('Op_write.tmp');
a1b95068
LW
385 print $res eq "line 1\nline 2\n" ? "ok 15\n" : "not ok 15\n";
386}
387
388{ # test 16: multiple use of a variable in same line with ^<
389 my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4";
390 format OUT16 =
391^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
392$txt, $txt
393^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
394$txt, $txt
395.
396 open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp";
397 write(OUT16);
398 close OUT16 or die "Could not close: $!";
a344b90b 399 my $res = cat('Op_write.tmp');
a1b95068
LW
400 print $res eq <<EOD ? "ok 16\n" : "not ok 16\n";
401this_is_block_1 this_is_block_2
402this_is_block_3 this_is_block_4
403EOD
404}
405
406{ # test 17: @* "should be on a line of its own", but it should work
407 # cleanly with literals before and after. (WL)
408
409 my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n";
410 format OUT17 =
411Here we go: @* That's all, folks!
412 $txt
413.
414 open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp";
415 write(OUT17);
416 close OUT17 or die "Could not close: $!";
a344b90b 417 my $res = cat('Op_write.tmp');
a1b95068
LW
418 chomp( $txt );
419 my $exp = <<EOD;
420Here we go: $txt That's all, folks!
421EOD
422 print $res eq $exp ? "ok 17\n" : "not ok 17\n";
423}
424
425{ # test 18: @# and ~~ would cause runaway format, but we now
426 # catch this while compiling (WL)
427
428 format OUT18 =
429@######## ~~
43010
431.
432 open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp";
433 eval { write(OUT18); };
434 print $@ ? "ok 18\n" : "not ok 18\n";
435 close OUT18 or die "Could not close: $!";
436}
437
438{ # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL)
439 my $v = 'gaga';
440 eval "format OUT19 = \n" .
441 '@<<<' . "\0\n" .
442 '$v' . "\n" .
443 '@<<<' . "\0\n" .
444 '$v' . "\n.\n";
445 open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp";
446 write(OUT19);
a344b90b
DM
447 close OUT19 or die "Could not close: $!";
448 my $res = cat('Op_write.tmp');
a1b95068
LW
449 print $res eq <<EOD ? "ok 19\n" : "not ok 19\n";
450gaga\0
451gaga\0
452EOD
453}
454
455{ # test 20: hash accesses; single '}' must not terminate format '}' (WL)
456 my %h = ( xkey => 'xval', ykey => 'yval' );
457 format OUT20 =
458@>>>> @<<<< ~~
459each %h
460@>>>> @<<<<
461$h{xkey}, $h{ykey}
462@>>>> @<<<<
463{ $h{xkey}, $h{ykey}
464}
465}
466.
467 my $exp = '';
468 while( my( $k, $v ) = each( %h ) ){
469 $exp .= sprintf( "%5s %s\n", $k, $v );
470 }
471 $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
472 $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
473 $exp .= "}\n";
474 open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp";
475 write(OUT20);
a344b90b
DM
476 close OUT20 or die "Could not close: $!";
477 my $res = cat('Op_write.tmp');
a1b95068 478 print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n";
a1b95068
LW
479}
480
481
482#####################
483## Section 2
484## numeric formatting
485#####################
486
487my $nt = $bas_tests;
488for my $tref ( @NumTests ){
489 my $writefmt = shift( @$tref );
d1f6232e
DM
490 while (@$tref) {
491 my $val = shift @$tref;
492 my $expected = shift @$tref;
a1b95068 493 my $writeres = swrite( $writefmt, $val );
a1b95068 494 $nt++;
8975a8c2
DM
495 my $ok = ref($expected)
496 ? $writeres =~ $expected
497 : $writeres eq $expected;
498
499 print $ok
176ab42a
DM
500 ? "ok $nt\n"
501 : "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n";
a1b95068
LW
502 }
503}
504
505
506#####################################
507## Section 3
508## Easiest to add new tests above here
ea42cebc
RGS
509#######################################
510
a1b95068 511# scary format testing from H.Merijn Brand
ea42cebc 512
a1b95068
LW
513my $test = $bas_tests + $num_tests + 1;
514my $tests = $bas_tests + $num_tests + $hmb_tests;
9ccde9ea 515
dc459aad 516if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' ||
764df951 517 ($^O eq 'os2' and not eval '$OS2::can_fork')) {
ea42cebc
RGS
518 foreach ($test..$tests) {
519 print "ok $_ # skipped: '|-' and '-|' not supported\n";
520 }
d4a0c6f3
CB
521 exit(0);
522}
523
9ccde9ea 524
ea42cebc 525use strict; # Amazed that this hackery can be made strict ...
d57f9278 526
9ccde9ea
JH
527# Just a complete test for format, including top-, left- and bottom marging
528# and format detection through glob entries
529
d57f9278
MB
530format EMPTY =
531.
532
533format Comment =
534ok @<<<<<
535$test
536.
537
d57f9278
MB
538
539# [ID 20020227.005] format bug with undefined _TOP
0bd0581c
DM
540
541open STDOUT_DUP, ">&STDOUT";
542my $oldfh = select STDOUT_DUP;
543$= = 10;
d57f9278
MB
544{ local $~ = "Comment";
545 write;
546 $test++;
547 print $- == 9
3444c34c 548 ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n";
d57f9278 549 $test++;
0bd0581c
DM
550 print $^ eq "STDOUT_DUP_TOP"
551 ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n";
d57f9278 552 $test++;
0bd0581c
DM
553}
554select $oldfh;
d57f9278 555
0bd0581c
DM
556$^ = "STDOUT_TOP";
557$= = 7; # Page length
558$- = 0; # Lines left
9ccde9ea
JH
559my $ps = $^L; $^L = ""; # Catch the page separator
560my $tm = 1; # Top margin (empty lines before first output)
561my $bm = 2; # Bottom marging (empty lines between last text and footer)
562my $lm = 4; # Left margin (indent in spaces)
563
362819fd 564select ((select (STDOUT), $| = 1)[0]);
9ccde9ea 565if ($lm > 0 and !open STDOUT, "|-") { # Left margin (in this test ALWAYS set)
362819fd 566 select ((select (STDOUT), $| = 1)[0]);
9ccde9ea
JH
567 my $s = " " x $lm;
568 while (<STDIN>) {
569 s/^/$s/;
d57f9278 570 print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n";
9ccde9ea
JH
571 }
572 close STDIN;
d57f9278 573 print + (<DATA>?"not ":""), "ok ", $test++, "\n";
9ccde9ea
JH
574 close STDOUT;
575 exit;
576 }
577$tm = "\n" x $tm;
578$= -= $bm + 1; # count one for the trailing "----"
579my $lastmin = 0;
580
581my @E;
582
583sub wryte
584{
585 $lastmin = $-;
586 write;
587 } # wryte;
588
589sub footer
590{
591 $% == 1 and return "";
592
593 $lastmin < $= and print "\n" x $lastmin;
594 print "\n" x $bm, "----\n", $ps;
595 $lastmin = $-;
596 "";
597 } # footer
598
599# Yes, this is sick ;-)
600format TOP =
601@* ~
602@{[footer]}
603@* ~
604$tm
605.
606
9ccde9ea
JH
607format ENTRY =
608@ @<<<<~~
609@{(shift @E)||["",""]}
610.
611
612format EOR =
613- -----
614.
615
616sub has_format ($)
617{
618 my $fmt = shift;
619 exists $::{$fmt} or return 0;
620 $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
621 open my $null, "> /dev/null" or die;
622 my $fh = select $null;
623 local $~ = $fmt;
624 eval "write";
625 select $fh;
626 $@?0:1;
627 } # has_format
628
d57f9278 629$^ = has_format ("TOP") ? "TOP" : "EMPTY";
9ccde9ea
JH
630has_format ("ENTRY") or die "No format defined for ENTRY";
631foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ],
632 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
633 @E = @$e;
634 local $~ = "ENTRY";
635 wryte;
636 has_format ("EOR") or next;
637 local $~ = "EOR";
638 wryte;
639 }
640if (has_format ("EOF")) {
641 local $~ = "EOF";
642 wryte;
643 }
644
645close STDOUT;
646
ea42cebc 647# That was test 48.
9ccde9ea
JH
648
649__END__
650
651 1 Test1
652 2 Test2
653 3 Test3
654
655
656 ----
657 \f
658 4 Test4
659 5 Test5
660 6 Test6
661
662
663 ----
664 \f
665 7 Test7
666 - -----
667
668
669
670 ----
671 \f
672 1 1tseT
673 2 2tseT
674 3 3tseT
675
676
677 ----
678 \f
679 4 4tseT
680 5 5tseT
681 - -----