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