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
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6 }
7
8 print "1..44\n";
9
10 my $CAT = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') ? 'type'
11         : ($^O eq 'MacOS') ? 'catenate'
12         : 'cat';
13
14 format OUT =
15 the quick brown @<<
16 $fox
17 jumped
18 @*
19 $multiline
20 ^<<<<<<<<<
21 $foo
22 ^<<<<<<<<<
23 $foo
24 ^<<<<<<...
25 $foo
26 now @<<the@>>>> for all@|||||men to come @<<<<
27 {
28     'i' . 's', "time\n", $good, 'to'
29 }
30 .
31
32 open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
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';
38 write(OUT);
39 close OUT;
40
41 $right =
42 "the quick brown fox
43 jumped
44 forescore
45 and
46 seven years
47 when in
48 the course
49 of huma...
50 now is the time for all good men to come to\n";
51
52 if (`$CAT Op_write.tmp` eq $right)
53     { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; }
54 else
55     { print "not ok 1\n"; }
56
57 $fox = 'wolfishness';
58 my $fox = 'foxiness';           # Test a lexical variable.
59
60 format OUT2 =
61 the quick brown @<<
62 $fox
63 jumped
64 @*
65 $multiline
66 ^<<<<<<<<< ~~
67 $foo
68 now @<<the@>>>> for all@|||||men to come @<<<<
69 'i' . 's', "time\n", $good, 'to'
70 .
71
72 open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp";
73
74 $good = 'good';
75 $multiline = "forescore\nand\nseven years\n";
76 $foo = 'when in the course of human events it becomes necessary';
77 write(OUT2);
78 close OUT2;
79
80 $right =
81 "the quick brown fox
82 jumped
83 forescore
84 and
85 seven years
86 when in
87 the course
88 of human
89 events it
90 becomes
91 necessary
92 now is the time for all good men to come to\n";
93
94 if (`$CAT Op_write.tmp` eq $right)
95     { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; }
96 else
97     { print "not ok 2\n"; }
98
99 eval <<'EOFORMAT';
100 format OUT2 =
101 the brown quick @<<
102 $fox
103 jumped
104 @*
105 $multiline
106 and
107 ^<<<<<<<<< ~~
108 $foo
109 now @<<the@>>>> for all@|||||men to come @<<<<
110 'i' . 's', "time\n", $good, 'to'
111 .
112 EOFORMAT
113
114 open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
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';
120 write(OUT2);
121 close OUT2;
122
123 $right =
124 "the brown quick fox
125 jumped
126 forescore
127 and
128 seven years
129 and
130 when in
131 the course
132 of human
133 events it
134 becomes
135 necessary
136 now is the time for all good men to come to\n";
137
138 if (`$CAT Op_write.tmp` eq $right)
139     { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; }
140 else
141     { print "not ok 3\n"; }
142
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
157 EOT
158
159 $was1 = $was2 = '';
160 for (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 }
172 print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n";
173 print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n";
174
175 $^A = '';
176
177 # more test
178
179 format OUT3 =
180 ^<<<<<<...
181 $foo
182 .
183
184 open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";
185
186 $foo = 'fit          ';
187 write(OUT3);
188 close OUT3;
189
190 $right =
191 "fit\n";
192
193 if (`$CAT Op_write.tmp` eq $right)
194     { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; }
195 else
196     { print "not ok 6\n"; }
197
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;
210     close LEX;
211 }
212 # LEX_INTERPNORMAL test
213 my %e = ( a => 1 );
214 format OUT4 =
215 @<<<<<<
216 "$e{a}"
217 .
218 open   OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
219 write (OUT4);
220 close  OUT4;
221 if (`$CAT Op_write.tmp` eq "1\n") {
222     print "ok 9\n";
223     1 while unlink "Op_write.tmp";
224     }
225 else {
226     print "not ok 9\n";
227     }
228
229 eval <<'EOFORMAT';
230 format OUT10 =
231 @####.## @0###.##
232 $test1, $test1
233 .
234 EOFORMAT
235
236 open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
237
238 $test1 = 12.95;
239 write(OUT10);
240 close OUT10;
241
242 $right = "   12.95 00012.95\n";
243 if (`$CAT Op_write.tmp` eq $right)
244     { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; }
245 else
246     { print "not ok 10\n"; }
247
248 eval <<'EOFORMAT';
249 format OUT11 =
250 @0###.## 
251 $test1
252 @ 0#
253 $test1
254 @0 # 
255 $test1
256 .
257 EOFORMAT
258
259 open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";
260
261 $test1 = 12.95;
262 write(OUT11);
263 close OUT11;
264
265 $right = 
266 "00012.95
267 1 0#
268 10 #\n";
269 if (`$CAT Op_write.tmp` eq $right)
270     { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; }
271 else
272     { print "not ok 11\n"; }
273
274 # 12..44: scary format testing from Merijn H. Brand
275
276 if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' ||
277     ($^O eq 'os2' and not eval '$OS2::can_fork')) {
278   foreach (12..44) { print "ok $_ # skipped: '|-' and '-|' not supported\n"; }
279   exit(0);
280 }
281
282 use 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
288 my $ps = $^L; $^L = ""; # Catch the page separator
289 my $tm =  1;            # Top margin (empty lines before first output)
290 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
291 my $lm =  4;            # Left margin (indent in spaces)
292
293 select ((select (STDOUT), $| = 1)[0]);
294 if ($lm > 0 and !open STDOUT, "|-") {   # Left margin (in this test ALWAYS set)
295     select ((select (STDOUT), $| = 1)[0]);
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 "----"
309 my $lastmin = 0;
310
311 my @E;
312
313 sub wryte
314 {
315     $lastmin = $-;
316     write;
317     } # wryte;
318
319 sub 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 ;-)
330 format TOP =
331 @* ~
332 @{[footer]}
333 @* ~
334 $tm
335 .
336
337 format EmptyTOP =
338 .
339
340 format ENTRY =
341 @ @<<<<~~
342 @{(shift @E)||["",""]}
343 .
344
345 format EOR =
346 - -----
347 .
348
349 sub 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";
363 has_format ("ENTRY") or die "No format defined for ENTRY";
364 foreach 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     }
373 if (has_format ("EOF")) {
374     local $~ = "EOF";
375     wryte;
376     }
377
378 close 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     - -----