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