This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
buigid #24905 - the code planted to call glob() retained an
[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
f5c235e7 8print "1..50\n";
a687059c 9
da405c16 10my $CAT = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') ? 'type'
2986a63f
JH
11 : ($^O eq 'MacOS') ? 'catenate'
12 : 'cat';
3fe9a6f1 13
a687059c
LW
14format OUT =
15the quick brown @<<
16$fox
17jumped
18@*
19$multiline
20^<<<<<<<<<
21$foo
22^<<<<<<<<<
23$foo
24^<<<<<<...
25$foo
26now @<<the@>>>> for all@|||||men to come @<<<<
a0d0e21e
LW
27{
28 'i' . 's', "time\n", $good, 'to'
29}
a687059c
LW
30.
31
a0d0e21e 32open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
19f4d710 33END { 1 while unlink 'Op_write.tmp' }
a687059c
LW
34
35$fox = 'foxiness';
36$good = 'good';
37$multiline = "forescore\nand\nseven years\n";
38$foo = 'when in the course of human events it becomes necessary';
39write(OUT);
d1e4d418 40close OUT or die "Could not close: $!";
a687059c
LW
41
42$right =
43"the quick brown fox
44jumped
45forescore
46and
47seven years
48when in
49the course
50of huma...
51now is the time for all good men to come to\n";
52
3fe9a6f1 53if (`$CAT Op_write.tmp` eq $right)
784707d5 54 { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; }
a687059c
LW
55else
56 { print "not ok 1\n"; }
57
748a9306
LW
58$fox = 'wolfishness';
59my $fox = 'foxiness'; # Test a lexical variable.
60
a687059c
LW
61format OUT2 =
62the quick brown @<<
63$fox
64jumped
65@*
66$multiline
67^<<<<<<<<< ~~
68$foo
69now @<<the@>>>> for all@|||||men to come @<<<<
70'i' . 's', "time\n", $good, 'to'
71.
72
a0d0e21e 73open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp";
a687059c 74
a687059c
LW
75$good = 'good';
76$multiline = "forescore\nand\nseven years\n";
77$foo = 'when in the course of human events it becomes necessary';
78write(OUT2);
d1e4d418 79close OUT2 or die "Could not close: $!";
a687059c
LW
80
81$right =
82"the quick brown fox
83jumped
84forescore
85and
86seven years
87when in
88the course
89of human
90events it
91becomes
92necessary
93now is the time for all good men to come to\n";
94
3fe9a6f1 95if (`$CAT Op_write.tmp` eq $right)
784707d5 96 { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; }
a687059c
LW
97else
98 { print "not ok 2\n"; }
99
0f85fab0
LW
100eval <<'EOFORMAT';
101format OUT2 =
102the brown quick @<<
103$fox
104jumped
105@*
106$multiline
a0d0e21e 107and
0f85fab0
LW
108^<<<<<<<<< ~~
109$foo
110now @<<the@>>>> for all@|||||men to come @<<<<
111'i' . 's', "time\n", $good, 'to'
112.
113EOFORMAT
114
a0d0e21e 115open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
0f85fab0
LW
116
117$fox = 'foxiness';
118$good = 'good';
119$multiline = "forescore\nand\nseven years\n";
120$foo = 'when in the course of human events it becomes necessary';
121write(OUT2);
d1e4d418 122close OUT2 or die "Could not close: $!";
0f85fab0
LW
123
124$right =
125"the brown quick fox
126jumped
127forescore
128and
129seven years
a0d0e21e 130and
0f85fab0
LW
131when in
132the course
133of human
134events it
135becomes
136necessary
137now is the time for all good men to come to\n";
138
3fe9a6f1 139if (`$CAT Op_write.tmp` eq $right)
784707d5 140 { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; }
0f85fab0
LW
141else
142 { print "not ok 3\n"; }
143
55497cff
PP
144# formline tests
145
146$mustbe = <<EOT;
147@ a
148@> ab
149@>> abc
150@>>> abc
151@>>>> abc
152@>>>>> abc
153@>>>>>> abc
154@>>>>>>> abc
155@>>>>>>>> abc
156@>>>>>>>>> abc
157@>>>>>>>>>> abc
158EOT
159
160$was1 = $was2 = '';
161for (0..10) {
162 # lexical picture
163 $^A = '';
164 my $format1 = '@' . '>' x $_;
165 formline $format1, 'abc';
166 $was1 .= "$format1 $^A\n";
167 # global
168 $^A = '';
169 local $format2 = '@' . '>' x $_;
170 formline $format2, 'abc';
171 $was2 .= "$format2 $^A\n";
172}
173print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n";
174print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n";
175
7056ecde
URCI
176$^A = '';
177
178# more test
179
180format OUT3 =
181^<<<<<<...
182$foo
183.
184
185open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";
186
187$foo = 'fit ';
188write(OUT3);
d1e4d418 189close OUT3 or die "Could not close: $!";
7056ecde
URCI
190
191$right =
192"fit\n";
193
194if (`$CAT Op_write.tmp` eq $right)
784707d5 195 { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; }
7056ecde
URCI
196else
197 { print "not ok 6\n"; }
198
445b3f51
GS
199# test lexicals and globals
200{
201 my $this = "ok";
202 our $that = 7;
203 format LEX =
204@<<@|
205$this,$that
206.
207 open(LEX, ">&STDOUT") or die;
208 write LEX;
209 $that = 8;
210 write LEX;
d1e4d418 211 close LEX or die "Could not close: $!";
445b3f51 212}
c2e66d9e
GS
213# LEX_INTERPNORMAL test
214my %e = ( a => 1 );
215format OUT4 =
216@<<<<<<
217"$e{a}"
218.
219open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
220write (OUT4);
d1e4d418 221close OUT4 or die "Could not close: $!";
c2e66d9e
GS
222if (`$CAT Op_write.tmp` eq "1\n") {
223 print "ok 9\n";
784707d5 224 1 while unlink "Op_write.tmp";
c2e66d9e
GS
225 }
226else {
227 print "not ok 9\n";
228 }
784707d5
JP
229
230eval <<'EOFORMAT';
231format OUT10 =
232@####.## @0###.##
233$test1, $test1
234.
235EOFORMAT
236
237open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
238
239$test1 = 12.95;
240write(OUT10);
d1e4d418 241close OUT10 or die "Could not close: $!";
784707d5
JP
242
243$right = " 12.95 00012.95\n";
244if (`$CAT Op_write.tmp` eq $right)
245 { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; }
246else
247 { print "not ok 10\n"; }
248
249eval <<'EOFORMAT';
250format OUT11 =
251@0###.##
252$test1
253@ 0#
254$test1
255@0 #
256$test1
257.
258EOFORMAT
259
260open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";
261
262$test1 = 12.95;
263write(OUT11);
d1e4d418 264close OUT11 or die "Could not close: $!";
784707d5
JP
265
266$right =
267"00012.95
2681 0#
26910 #\n";
270if (`$CAT Op_write.tmp` eq $right)
271 { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; }
272else
273 { print "not ok 11\n"; }
9ccde9ea 274
31869a79 275{
71f882da 276 my $el;
31869a79
AE
277 format STDOUT =
278ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze
279$el
280.
281 my %hash = (12 => 3);
282 for $el (keys %hash) {
283 write;
284 }
285}
286
ea42cebc
RGS
287{
288 # Bug report and testcase by Alexey Tourbin
289 use Tie::Scalar;
290 my $v;
291 tie $v, 'Tie::StdScalar';
292 $v = 13;
293 format OUT13 =
294ok ^<<<<<<<<< ~~
295$v
296.
297 open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp";
298 write(OUT13);
299 close OUT13 or die "Could not close: $!";
300 print `$CAT Op_write.tmp`;
301}
302
f5c235e7
DM
303{
304 # Bug #24774 format without trailing \n failed assertion
c5ee2135
LW
305 # but this must not compile because we'd get a ';' into the format
306
f5c235e7
DM
307 my @v = ('k');
308 eval "format OUT14 = \n@\n\@v";
c5ee2135
LW
309 print $@ ? "ok 14\n" : "not ok 14\n";
310
f5c235e7
DM
311}
312
ea42cebc
RGS
313#######################################
314# Easiest to add new tests above here #
315#######################################
316
f5c235e7 317# 15..50: scary format testing from Merijn H. Brand
ea42cebc 318
f5c235e7
DM
319my $test = 15;
320my $tests = 50;
9ccde9ea 321
dc459aad 322if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' ||
764df951 323 ($^O eq 'os2' and not eval '$OS2::can_fork')) {
ea42cebc
RGS
324 foreach ($test..$tests) {
325 print "ok $_ # skipped: '|-' and '-|' not supported\n";
326 }
d4a0c6f3
CB
327 exit(0);
328}
329
9ccde9ea 330
ea42cebc 331use strict; # Amazed that this hackery can be made strict ...
d57f9278 332
9ccde9ea
JH
333# Just a complete test for format, including top-, left- and bottom marging
334# and format detection through glob entries
335
d57f9278
MB
336format EMPTY =
337.
338
339format Comment =
340ok @<<<<<
341$test
342.
343
344$= = 10;
345
346# [ID 20020227.005] format bug with undefined _TOP
347{ local $~ = "Comment";
348 write;
349 $test++;
350 print $- == 9
3444c34c 351 ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n";
d57f9278
MB
352 $test++;
353 print $^ ne "Comment_TOP"
cfcd312a 354 ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_TOP'\n";
d57f9278
MB
355 $test++;
356 }
357
358 $^ = "STDOUT_TOP";
9ccde9ea 359 $= = 7; # Page length
d57f9278 360 $- = 0; # Lines left
9ccde9ea
JH
361my $ps = $^L; $^L = ""; # Catch the page separator
362my $tm = 1; # Top margin (empty lines before first output)
363my $bm = 2; # Bottom marging (empty lines between last text and footer)
364my $lm = 4; # Left margin (indent in spaces)
365
362819fd 366select ((select (STDOUT), $| = 1)[0]);
9ccde9ea 367if ($lm > 0 and !open STDOUT, "|-") { # Left margin (in this test ALWAYS set)
362819fd 368 select ((select (STDOUT), $| = 1)[0]);
9ccde9ea
JH
369 my $s = " " x $lm;
370 while (<STDIN>) {
371 s/^/$s/;
d57f9278 372 print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n";
9ccde9ea
JH
373 }
374 close STDIN;
d57f9278 375 print + (<DATA>?"not ":""), "ok ", $test++, "\n";
9ccde9ea
JH
376 close STDOUT;
377 exit;
378 }
379$tm = "\n" x $tm;
380$= -= $bm + 1; # count one for the trailing "----"
381my $lastmin = 0;
382
383my @E;
384
385sub wryte
386{
387 $lastmin = $-;
388 write;
389 } # wryte;
390
391sub footer
392{
393 $% == 1 and return "";
394
395 $lastmin < $= and print "\n" x $lastmin;
396 print "\n" x $bm, "----\n", $ps;
397 $lastmin = $-;
398 "";
399 } # footer
400
401# Yes, this is sick ;-)
402format TOP =
403@* ~
404@{[footer]}
405@* ~
406$tm
407.
408
9ccde9ea
JH
409format ENTRY =
410@ @<<<<~~
411@{(shift @E)||["",""]}
412.
413
414format EOR =
415- -----
416.
417
418sub has_format ($)
419{
420 my $fmt = shift;
421 exists $::{$fmt} or return 0;
422 $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
423 open my $null, "> /dev/null" or die;
424 my $fh = select $null;
425 local $~ = $fmt;
426 eval "write";
427 select $fh;
428 $@?0:1;
429 } # has_format
430
d57f9278 431$^ = has_format ("TOP") ? "TOP" : "EMPTY";
9ccde9ea
JH
432has_format ("ENTRY") or die "No format defined for ENTRY";
433foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ],
434 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
435 @E = @$e;
436 local $~ = "ENTRY";
437 wryte;
438 has_format ("EOR") or next;
439 local $~ = "EOR";
440 wryte;
441 }
442if (has_format ("EOF")) {
443 local $~ = "EOF";
444 wryte;
445 }
446
447close STDOUT;
448
ea42cebc 449# That was test 48.
9ccde9ea
JH
450
451__END__
452
453 1 Test1
454 2 Test2
455 3 Test3
456
457
458 ----
459 \f
460 4 Test4
461 5 Test5
462 6 Test6
463
464
465 ----
466 \f
467 7 Test7
468 - -----
469
470
471
472 ----
473 \f
474 1 1tseT
475 2 2tseT
476 3 3tseT
477
478
479 ----
480 \f
481 4 4tseT
482 5 5tseT
483 - -----