This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
When expecting an error, it's best to check the text you got, rather
[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
WL
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
WL
50
51my $num_tests = 0;
52for my $tref ( @NumTests ){
d1f6232e 53 $num_tests += (@$tref - 1)/2;
a1b95068
WL
54}
55#---------------------------------------------------------
56
57# number of tests in section 1
58my $bas_tests = 20;
59
60# number of tests in section 3
68ba3c2c 61my $hmb_tests = 37;
a1b95068
WL
62
63printf "1..%d\n", $bas_tests + $num_tests + $hmb_tests;
a687059c 64
a1b95068
WL
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 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
KM
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
KM
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
KM
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
WL
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
WL
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
WL
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
WL
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
WL
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
WL
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
WL
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
WL
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
WL
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
WL
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
WL
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
9ccde9ea
JH
529# Just a complete test for format, including top-, left- and bottom marging
530# and format detection through glob entries
531
d57f9278
MB
532format EMPTY =
533.
534
535format Comment =
536ok @<<<<<
537$test
538.
539
d57f9278
MB
540
541# [ID 20020227.005] format bug with undefined _TOP
0bd0581c
DM
542
543open STDOUT_DUP, ">&STDOUT";
544my $oldfh = select STDOUT_DUP;
545$= = 10;
d57f9278
MB
546{ local $~ = "Comment";
547 write;
548 $test++;
549 print $- == 9
3444c34c 550 ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n";
d57f9278 551 $test++;
0bd0581c
DM
552 print $^ eq "STDOUT_DUP_TOP"
553 ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n";
d57f9278 554 $test++;
0bd0581c
DM
555}
556select $oldfh;
68ba3c2c 557close STDOUT_DUP;
d57f9278 558
0bd0581c
DM
559$^ = "STDOUT_TOP";
560$= = 7; # Page length
561$- = 0; # Lines left
9ccde9ea
JH
562my $ps = $^L; $^L = ""; # Catch the page separator
563my $tm = 1; # Top margin (empty lines before first output)
564my $bm = 2; # Bottom marging (empty lines between last text and footer)
565my $lm = 4; # Left margin (indent in spaces)
566
68ba3c2c
DM
567# -----------------------------------------------------------------------
568#
569# execute the rest of the script in a child process. The parent reads the
570# output from the child and compares it with <DATA>.
571
572my @data = <DATA>;
573
574select ((select (STDOUT), $| = 1)[0]); # flush STDOUT
575
576my $opened = open FROM_CHILD, "-|";
577unless (defined $opened) {
578 print "not ok $test - open gave $!\n"; exit 0;
579}
580
581if ($opened) {
582 # in parent here
583
584 print "ok $test - open\n"; $test++;
9ccde9ea 585 my $s = " " x $lm;
68ba3c2c
DM
586 while (<FROM_CHILD>) {
587 unless (@data) {
588 print "not ok $test - too much output\n";
589 exit;
590 }
9ccde9ea 591 s/^/$s/;
68ba3c2c
DM
592 my $exp = shift @data;
593 print + ($_ eq $exp ? "" : "not "), "ok ", $test++, " \n";
594 if ($_ ne $exp) {
595 s/\n/\\n/g for $_, $exp;
596 print "#expected: $exp\n#got: $_\n";
9ccde9ea 597 }
9ccde9ea 598 }
68ba3c2c
DM
599 close FROM_CHILD;
600 print + (@data?"not ":""), "ok ", $test++, " - too litle output\n";
601 exit;
602}
603
604# in child here
605
606 select ((select (STDOUT), $| = 1)[0]);
9ccde9ea
JH
607$tm = "\n" x $tm;
608$= -= $bm + 1; # count one for the trailing "----"
609my $lastmin = 0;
610
611my @E;
612
613sub wryte
614{
615 $lastmin = $-;
616 write;
617 } # wryte;
618
619sub footer
620{
621 $% == 1 and return "";
622
623 $lastmin < $= and print "\n" x $lastmin;
624 print "\n" x $bm, "----\n", $ps;
625 $lastmin = $-;
626 "";
627 } # footer
628
629# Yes, this is sick ;-)
630format TOP =
631@* ~
632@{[footer]}
633@* ~
634$tm
635.
636
9ccde9ea
JH
637format ENTRY =
638@ @<<<<~~
639@{(shift @E)||["",""]}
640.
641
642format EOR =
643- -----
644.
645
646sub has_format ($)
647{
648 my $fmt = shift;
649 exists $::{$fmt} or return 0;
650 $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
651 open my $null, "> /dev/null" or die;
652 my $fh = select $null;
653 local $~ = $fmt;
654 eval "write";
655 select $fh;
656 $@?0:1;
657 } # has_format
658
d57f9278 659$^ = has_format ("TOP") ? "TOP" : "EMPTY";
9ccde9ea
JH
660has_format ("ENTRY") or die "No format defined for ENTRY";
661foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ],
662 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
663 @E = @$e;
664 local $~ = "ENTRY";
665 wryte;
666 has_format ("EOR") or next;
667 local $~ = "EOR";
668 wryte;
669 }
670if (has_format ("EOF")) {
671 local $~ = "EOF";
672 wryte;
673 }
674
675close STDOUT;
676
ea42cebc 677# That was test 48.
9ccde9ea
JH
678
679__END__
680
681 1 Test1
682 2 Test2
683 3 Test3
684
685
686 ----
687 \f
688 4 Test4
689 5 Test5
690 6 Test6
691
692
693 ----
694 \f
695 7 Test7
696 - -----
697
698
699
700 ----
701 \f
702 1 1tseT
703 2 2tseT
704 3 3tseT
705
706
707 ----
708 \f
709 4 4tseT
710 5 5tseT
711 - -----