Re: threads::shared::queue;
[p5sagit/p5-mst-13.2.git] / t / op / write.t
CommitLineData
a687059c 1#!./perl
2
9ccde9ea 3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
6}
7
a1b95068 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 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',
36 -0.0001, '-00.00' ],
37
38);
39
a1b95068 40
41my $num_tests = 0;
42for my $tref ( @NumTests ){
d1f6232e 43 $num_tests += (@$tref - 1)/2;
a1b95068 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 56 : ($^O eq 'MacOS') ? 'catenate'
57 : 'cat';
3fe9a6f1 58
a1b95068 59############
60## Section 1
61############
62
a687059c 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 76{
77 'i' . 's', "time\n", $good, 'to'
78}
a687059c 79.
80
a0d0e21e 81open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
19f4d710 82END { 1 while unlink 'Op_write.tmp' }
a687059c 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 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 104else
105 { print "not ok 1\n"; }
106
748a9306 107$fox = 'wolfishness';
108my $fox = 'foxiness'; # Test a lexical variable.
109
a687059c 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 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 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 146else
147 { print "not ok 2\n"; }
148
0f85fab0 149eval <<'EOFORMAT';
150format OUT2 =
151the brown quick @<<
152$fox
153jumped
154@*
155$multiline
a0d0e21e 156and
0f85fab0 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 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 172
173$right =
174"the brown quick fox
175jumped
176forescore
177and
178seven years
a0d0e21e 179and
0f85fab0 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 190else
191 { print "not ok 3\n"; }
192
55497cff 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 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 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 245else
246 { print "not ok 6\n"; }
247
445b3f51 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 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 271if (`$CAT Op_write.tmp` eq "1\n") {
272 print "ok 9\n";
784707d5 273 1 while unlink "Op_write.tmp";
c2e66d9e 274 }
275else {
276 print "not ok 9\n";
277 }
784707d5 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 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 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 327ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze
328$el
329.
330 my %hash = (12 => 3);
a1b95068 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 336 close OUT12 or die "Could not close: $!";
337 print `$CAT Op_write.tmp`;
338
31869a79 339}
340
ea42cebc 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 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 360 my @v = ('k');
361 eval "format OUT14 = \n@\n\@v";
c5ee2135 362 print $@ ? "ok 14\n" : "not ok 14\n";
363
f5c235e7 364}
365
a1b95068 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 484 while (@$tref) {
485 my $val = shift @$tref;
486 my $expected = shift @$tref;
a1b95068 487 my $writeres = swrite( $writefmt, $val );
a1b95068 488 $nt++;
489
d1f6232e 490 print $expected eq $writeres ? "ok $nt\n" : "not ok $nt\n";
a1b95068 491 }
492}
493
494
495#####################################
496## Section 3
497## Easiest to add new tests above here
ea42cebc 498#######################################
499
a1b95068 500# scary format testing from H.Merijn Brand
ea42cebc 501
a1b95068 502my $test = $bas_tests + $num_tests + 1;
503my $tests = $bas_tests + $num_tests + $hmb_tests;
9ccde9ea 504
dc459aad 505if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' ||
764df951 506 ($^O eq 'os2' and not eval '$OS2::can_fork')) {
ea42cebc 507 foreach ($test..$tests) {
508 print "ok $_ # skipped: '|-' and '-|' not supported\n";
509 }
d4a0c6f3 510 exit(0);
511}
512
9ccde9ea 513
ea42cebc 514use strict; # Amazed that this hackery can be made strict ...
d57f9278 515
9ccde9ea 516# Just a complete test for format, including top-, left- and bottom marging
517# and format detection through glob entries
518
d57f9278 519format EMPTY =
520.
521
522format Comment =
523ok @<<<<<
524$test
525.
526
d57f9278 527
528# [ID 20020227.005] format bug with undefined _TOP
0bd0581c 529
530open STDOUT_DUP, ">&STDOUT";
531my $oldfh = select STDOUT_DUP;
532$= = 10;
d57f9278 533{ local $~ = "Comment";
534 write;
535 $test++;
536 print $- == 9
3444c34c 537 ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n";
d57f9278 538 $test++;
0bd0581c 539 print $^ eq "STDOUT_DUP_TOP"
540 ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n";
d57f9278 541 $test++;
0bd0581c 542}
543select $oldfh;
d57f9278 544
0bd0581c 545$^ = "STDOUT_TOP";
546$= = 7; # Page length
547$- = 0; # Lines left
9ccde9ea 548my $ps = $^L; $^L = ""; # Catch the page separator
549my $tm = 1; # Top margin (empty lines before first output)
550my $bm = 2; # Bottom marging (empty lines between last text and footer)
551my $lm = 4; # Left margin (indent in spaces)
552
362819fd 553select ((select (STDOUT), $| = 1)[0]);
9ccde9ea 554if ($lm > 0 and !open STDOUT, "|-") { # Left margin (in this test ALWAYS set)
362819fd 555 select ((select (STDOUT), $| = 1)[0]);
9ccde9ea 556 my $s = " " x $lm;
557 while (<STDIN>) {
558 s/^/$s/;
d57f9278 559 print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n";
9ccde9ea 560 }
561 close STDIN;
d57f9278 562 print + (<DATA>?"not ":""), "ok ", $test++, "\n";
9ccde9ea 563 close STDOUT;
564 exit;
565 }
566$tm = "\n" x $tm;
567$= -= $bm + 1; # count one for the trailing "----"
568my $lastmin = 0;
569
570my @E;
571
572sub wryte
573{
574 $lastmin = $-;
575 write;
576 } # wryte;
577
578sub footer
579{
580 $% == 1 and return "";
581
582 $lastmin < $= and print "\n" x $lastmin;
583 print "\n" x $bm, "----\n", $ps;
584 $lastmin = $-;
585 "";
586 } # footer
587
588# Yes, this is sick ;-)
589format TOP =
590@* ~
591@{[footer]}
592@* ~
593$tm
594.
595
9ccde9ea 596format ENTRY =
597@ @<<<<~~
598@{(shift @E)||["",""]}
599.
600
601format EOR =
602- -----
603.
604
605sub has_format ($)
606{
607 my $fmt = shift;
608 exists $::{$fmt} or return 0;
609 $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
610 open my $null, "> /dev/null" or die;
611 my $fh = select $null;
612 local $~ = $fmt;
613 eval "write";
614 select $fh;
615 $@?0:1;
616 } # has_format
617
d57f9278 618$^ = has_format ("TOP") ? "TOP" : "EMPTY";
9ccde9ea 619has_format ("ENTRY") or die "No format defined for ENTRY";
620foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ],
621 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
622 @E = @$e;
623 local $~ = "ENTRY";
624 wryte;
625 has_format ("EOR") or next;
626 local $~ = "EOR";
627 wryte;
628 }
629if (has_format ("EOF")) {
630 local $~ = "EOF";
631 wryte;
632 }
633
634close STDOUT;
635
ea42cebc 636# That was test 48.
9ccde9ea 637
638__END__
639
640 1 Test1
641 2 Test2
642 3 Test3
643
644
645 ----
646 \f
647 4 Test4
648 5 Test5
649 6 Test6
650
651
652 ----
653 \f
654 7 Test7
655 - -----
656
657
658
659 ----
660 \f
661 1 1tseT
662 2 2tseT
663 3 3tseT
664
665
666 ----
667 \f
668 4 4tseT
669 5 5tseT
670 - -----