This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH] h2xs and extra_libraries
[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
31869a79 8print "1..48\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);
d1e4d418 39close OUT or die "Could not close: $!";
a687059c
LW
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);
d1e4d418 78close OUT2 or die "Could not close: $!";
a687059c
LW
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);
d1e4d418 121close OUT2 or die "Could not close: $!";
0f85fab0
LW
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);
d1e4d418 188close OUT3 or die "Could not close: $!";
7056ecde
URCI
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;
d1e4d418 210 close LEX or die "Could not close: $!";
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);
d1e4d418 220close OUT4 or die "Could not close: $!";
c2e66d9e
GS
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);
d1e4d418 240close OUT10 or die "Could not close: $!";
784707d5
JP
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);
d1e4d418 263close OUT11 or die "Could not close: $!";
784707d5
JP
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 273
31869a79 274{
71f882da 275 my $el;
31869a79
AE
276 format STDOUT =
277ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze
278$el
279.
280 my %hash = (12 => 3);
281 for $el (keys %hash) {
282 write;
283 }
284}
285
286# 13..48: scary format testing from Merijn H. Brand
9ccde9ea 287
dc459aad 288if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' ||
764df951 289 ($^O eq 'os2' and not eval '$OS2::can_fork')) {
c4e2b39b 290 foreach (13..48) { print "ok $_ # skipped: '|-' and '-|' not supported\n"; }
d4a0c6f3
CB
291 exit(0);
292}
293
9ccde9ea
JH
294use strict; # Amazed that this hackery can be made strict ...
295
31869a79 296my $test = 13;
d57f9278 297
9ccde9ea
JH
298# Just a complete test for format, including top-, left- and bottom marging
299# and format detection through glob entries
300
d57f9278
MB
301format EMPTY =
302.
303
304format Comment =
305ok @<<<<<
306$test
307.
308
309$= = 10;
310
311# [ID 20020227.005] format bug with undefined _TOP
312{ local $~ = "Comment";
313 write;
314 $test++;
315 print $- == 9
316 ? "ok $test\n" : "not ok $test # TODO \$- = $- instead of 9\n";
317 $test++;
318 print $^ ne "Comment_TOP"
319 ? "ok $test\n" : "not ok $test # TODO \$^ = $^ instead of 'STDOUT_TOP'\n";
320 $test++;
321 }
322
323 $^ = "STDOUT_TOP";
9ccde9ea 324 $= = 7; # Page length
d57f9278 325 $- = 0; # Lines left
9ccde9ea
JH
326my $ps = $^L; $^L = ""; # Catch the page separator
327my $tm = 1; # Top margin (empty lines before first output)
328my $bm = 2; # Bottom marging (empty lines between last text and footer)
329my $lm = 4; # Left margin (indent in spaces)
330
362819fd 331select ((select (STDOUT), $| = 1)[0]);
9ccde9ea 332if ($lm > 0 and !open STDOUT, "|-") { # Left margin (in this test ALWAYS set)
362819fd 333 select ((select (STDOUT), $| = 1)[0]);
9ccde9ea
JH
334 my $s = " " x $lm;
335 while (<STDIN>) {
336 s/^/$s/;
d57f9278 337 print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n";
9ccde9ea
JH
338 }
339 close STDIN;
d57f9278 340 print + (<DATA>?"not ":""), "ok ", $test++, "\n";
9ccde9ea
JH
341 close STDOUT;
342 exit;
343 }
344$tm = "\n" x $tm;
345$= -= $bm + 1; # count one for the trailing "----"
346my $lastmin = 0;
347
348my @E;
349
350sub wryte
351{
352 $lastmin = $-;
353 write;
354 } # wryte;
355
356sub footer
357{
358 $% == 1 and return "";
359
360 $lastmin < $= and print "\n" x $lastmin;
361 print "\n" x $bm, "----\n", $ps;
362 $lastmin = $-;
363 "";
364 } # footer
365
366# Yes, this is sick ;-)
367format TOP =
368@* ~
369@{[footer]}
370@* ~
371$tm
372.
373
9ccde9ea
JH
374format ENTRY =
375@ @<<<<~~
376@{(shift @E)||["",""]}
377.
378
379format EOR =
380- -----
381.
382
383sub has_format ($)
384{
385 my $fmt = shift;
386 exists $::{$fmt} or return 0;
387 $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
388 open my $null, "> /dev/null" or die;
389 my $fh = select $null;
390 local $~ = $fmt;
391 eval "write";
392 select $fh;
393 $@?0:1;
394 } # has_format
395
d57f9278 396$^ = has_format ("TOP") ? "TOP" : "EMPTY";
9ccde9ea
JH
397has_format ("ENTRY") or die "No format defined for ENTRY";
398foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ],
399 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
400 @E = @$e;
401 local $~ = "ENTRY";
402 wryte;
403 has_format ("EOR") or next;
404 local $~ = "EOR";
405 wryte;
406 }
407if (has_format ("EOF")) {
408 local $~ = "EOF";
409 wryte;
410 }
411
412close STDOUT;
413
67525708 414# That was test 47.
9ccde9ea
JH
415
416__END__
417
418 1 Test1
419 2 Test2
420 3 Test3
421
422
423 ----
424 \f
425 4 Test4
426 5 Test5
427 6 Test6
428
429
430 ----
431 \f
432 7 Test7
433 - -----
434
435
436
437 ----
438 \f
439 1 1tseT
440 2 2tseT
441 3 3tseT
442
443
444 ----
445 \f
446 4 4tseT
447 5 5tseT
448 - -----