This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
(was Re: [PATCH perl@13600] cat2type in tests for VMS)
[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
8print "1..44\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";
a687059c
LW
33
34$fox = 'foxiness';
35$good = 'good';
36$multiline = "forescore\nand\nseven years\n";
37$foo = 'when in the course of human events it becomes necessary';
38write(OUT);
39close OUT;
40
41$right =
42"the quick brown fox
43jumped
44forescore
45and
46seven years
47when in
48the course
49of huma...
50now is the time for all good men to come to\n";
51
3fe9a6f1 52if (`$CAT Op_write.tmp` eq $right)
784707d5 53 { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; }
a687059c
LW
54else
55 { print "not ok 1\n"; }
56
748a9306
LW
57$fox = 'wolfishness';
58my $fox = 'foxiness'; # Test a lexical variable.
59
a687059c
LW
60format OUT2 =
61the quick brown @<<
62$fox
63jumped
64@*
65$multiline
66^<<<<<<<<< ~~
67$foo
68now @<<the@>>>> for all@|||||men to come @<<<<
69'i' . 's', "time\n", $good, 'to'
70.
71
a0d0e21e 72open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp";
a687059c 73
a687059c
LW
74$good = 'good';
75$multiline = "forescore\nand\nseven years\n";
76$foo = 'when in the course of human events it becomes necessary';
77write(OUT2);
78close OUT2;
79
80$right =
81"the quick brown fox
82jumped
83forescore
84and
85seven years
86when in
87the course
88of human
89events it
90becomes
91necessary
92now is the time for all good men to come to\n";
93
3fe9a6f1 94if (`$CAT Op_write.tmp` eq $right)
784707d5 95 { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; }
a687059c
LW
96else
97 { print "not ok 2\n"; }
98
0f85fab0
LW
99eval <<'EOFORMAT';
100format OUT2 =
101the brown quick @<<
102$fox
103jumped
104@*
105$multiline
a0d0e21e 106and
0f85fab0
LW
107^<<<<<<<<< ~~
108$foo
109now @<<the@>>>> for all@|||||men to come @<<<<
110'i' . 's', "time\n", $good, 'to'
111.
112EOFORMAT
113
a0d0e21e 114open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
0f85fab0
LW
115
116$fox = 'foxiness';
117$good = 'good';
118$multiline = "forescore\nand\nseven years\n";
119$foo = 'when in the course of human events it becomes necessary';
120write(OUT2);
121close OUT2;
122
123$right =
124"the brown quick fox
125jumped
126forescore
127and
128seven years
a0d0e21e 129and
0f85fab0
LW
130when in
131the course
132of human
133events it
134becomes
135necessary
136now is the time for all good men to come to\n";
137
3fe9a6f1 138if (`$CAT Op_write.tmp` eq $right)
784707d5 139 { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; }
0f85fab0
LW
140else
141 { print "not ok 3\n"; }
142
55497cff
PP
143# formline tests
144
145$mustbe = <<EOT;
146@ a
147@> ab
148@>> abc
149@>>> abc
150@>>>> abc
151@>>>>> abc
152@>>>>>> abc
153@>>>>>>> abc
154@>>>>>>>> abc
155@>>>>>>>>> abc
156@>>>>>>>>>> abc
157EOT
158
159$was1 = $was2 = '';
160for (0..10) {
161 # lexical picture
162 $^A = '';
163 my $format1 = '@' . '>' x $_;
164 formline $format1, 'abc';
165 $was1 .= "$format1 $^A\n";
166 # global
167 $^A = '';
168 local $format2 = '@' . '>' x $_;
169 formline $format2, 'abc';
170 $was2 .= "$format2 $^A\n";
171}
172print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n";
173print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n";
174
7056ecde
URCI
175$^A = '';
176
177# more test
178
179format OUT3 =
180^<<<<<<...
181$foo
182.
183
184open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";
185
186$foo = 'fit ';
187write(OUT3);
188close OUT3;
189
190$right =
191"fit\n";
192
193if (`$CAT Op_write.tmp` eq $right)
784707d5 194 { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; }
7056ecde
URCI
195else
196 { print "not ok 6\n"; }
197
445b3f51
GS
198# test lexicals and globals
199{
200 my $this = "ok";
201 our $that = 7;
202 format LEX =
203@<<@|
204$this,$that
205.
206 open(LEX, ">&STDOUT") or die;
207 write LEX;
208 $that = 8;
209 write LEX;
fdc7a9f2 210 close LEX;
445b3f51 211}
c2e66d9e
GS
212# LEX_INTERPNORMAL test
213my %e = ( a => 1 );
214format OUT4 =
215@<<<<<<
216"$e{a}"
217.
218open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
219write (OUT4);
220close OUT4;
221if (`$CAT Op_write.tmp` eq "1\n") {
222 print "ok 9\n";
784707d5 223 1 while unlink "Op_write.tmp";
c2e66d9e
GS
224 }
225else {
226 print "not ok 9\n";
227 }
784707d5
JP
228
229eval <<'EOFORMAT';
230format OUT10 =
231@####.## @0###.##
232$test1, $test1
233.
234EOFORMAT
235
236open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
237
238$test1 = 12.95;
239write(OUT10);
240close OUT10;
241
242$right = " 12.95 00012.95\n";
243if (`$CAT Op_write.tmp` eq $right)
244 { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; }
245else
246 { print "not ok 10\n"; }
247
248eval <<'EOFORMAT';
249format OUT11 =
250@0###.##
251$test1
252@ 0#
253$test1
254@0 #
255$test1
256.
257EOFORMAT
258
259open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";
260
261$test1 = 12.95;
262write(OUT11);
263close OUT11;
264
265$right =
266"00012.95
2671 0#
26810 #\n";
269if (`$CAT Op_write.tmp` eq $right)
270 { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; }
271else
272 { print "not ok 11\n"; }
9ccde9ea
JH
273
274# 12..44: scary format testing from Merijn H. Brand
275
764df951
IZ
276if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' ||
277 ($^O eq 'os2' and not eval '$OS2::can_fork')) {
d4a0c6f3
CB
278 foreach (12..44) { print "ok $_ # skipped: '|-' and '-|' not supported\n"; }
279 exit(0);
280}
281
9ccde9ea
JH
282use strict; # Amazed that this hackery can be made strict ...
283
284# Just a complete test for format, including top-, left- and bottom marging
285# and format detection through glob entries
286
287 $= = 7; # Page length
288my $ps = $^L; $^L = ""; # Catch the page separator
289my $tm = 1; # Top margin (empty lines before first output)
290my $bm = 2; # Bottom marging (empty lines between last text and footer)
291my $lm = 4; # Left margin (indent in spaces)
292
362819fd 293select ((select (STDOUT), $| = 1)[0]);
9ccde9ea 294if ($lm > 0 and !open STDOUT, "|-") { # Left margin (in this test ALWAYS set)
362819fd 295 select ((select (STDOUT), $| = 1)[0]);
9ccde9ea
JH
296 my $i = 12;
297 my $s = " " x $lm;
298 while (<STDIN>) {
299 s/^/$s/;
300 print + ($_ eq <DATA> ? "" : "not "), "ok ", $i++, "\n";
301 }
302 close STDIN;
303 print + (<DATA>?"not ":""), "ok ", $i++, "\n";
304 close STDOUT;
305 exit;
306 }
307$tm = "\n" x $tm;
308$= -= $bm + 1; # count one for the trailing "----"
309my $lastmin = 0;
310
311my @E;
312
313sub wryte
314{
315 $lastmin = $-;
316 write;
317 } # wryte;
318
319sub footer
320{
321 $% == 1 and return "";
322
323 $lastmin < $= and print "\n" x $lastmin;
324 print "\n" x $bm, "----\n", $ps;
325 $lastmin = $-;
326 "";
327 } # footer
328
329# Yes, this is sick ;-)
330format TOP =
331@* ~
332@{[footer]}
333@* ~
334$tm
335.
336
337format EmptyTOP =
338.
339
340format ENTRY =
341@ @<<<<~~
342@{(shift @E)||["",""]}
343.
344
345format EOR =
346- -----
347.
348
349sub has_format ($)
350{
351 my $fmt = shift;
352 exists $::{$fmt} or return 0;
353 $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
354 open my $null, "> /dev/null" or die;
355 my $fh = select $null;
356 local $~ = $fmt;
357 eval "write";
358 select $fh;
359 $@?0:1;
360 } # has_format
361
362$^ = has_format ("TOP") ? "TOP" : "EmptyTOP";
363has_format ("ENTRY") or die "No format defined for ENTRY";
364foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ],
365 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
366 @E = @$e;
367 local $~ = "ENTRY";
368 wryte;
369 has_format ("EOR") or next;
370 local $~ = "EOR";
371 wryte;
372 }
373if (has_format ("EOF")) {
374 local $~ = "EOF";
375 wryte;
376 }
377
378close STDOUT;
379
380# That was test 44.
381
382__END__
383
384 1 Test1
385 2 Test2
386 3 Test3
387
388
389 ----
390 \f
391 4 Test4
392 5 Test5
393 6 Test6
394
395
396 ----
397 \f
398 7 Test7
399 - -----
400
401
402
403 ----
404 \f
405 1 1tseT
406 2 2tseT
407 3 3tseT
408
409
410 ----
411 \f
412 4 4tseT
413 5 5tseT
414 - -----