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