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