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