Commit | Line | Data |
a687059c |
1 | #!./perl |
2 | |
9ccde9ea |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | } |
7 | |
d57f9278 |
8 | print "1..47\n"; |
a687059c |
9 | |
da405c16 |
10 | my $CAT = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') ? 'type' |
2986a63f |
11 | : ($^O eq 'MacOS') ? 'catenate' |
12 | : 'cat'; |
3fe9a6f1 |
13 | |
a687059c |
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 @<<<< |
a0d0e21e |
27 | { |
28 | 'i' . 's', "time\n", $good, 'to' |
29 | } |
a687059c |
30 | . |
31 | |
a0d0e21e |
32 | open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
a687059c |
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); |
d1e4d418 |
39 | close OUT or die "Could not close: $!"; |
a687059c |
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 | |
3fe9a6f1 |
52 | if (`$CAT Op_write.tmp` eq $right) |
784707d5 |
53 | { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; } |
a687059c |
54 | else |
55 | { print "not ok 1\n"; } |
56 | |
748a9306 |
57 | $fox = 'wolfishness'; |
58 | my $fox = 'foxiness'; # Test a lexical variable. |
59 | |
a687059c |
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 | |
a0d0e21e |
72 | open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp"; |
a687059c |
73 | |
a687059c |
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); |
d1e4d418 |
78 | close OUT2 or die "Could not close: $!"; |
a687059c |
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 | |
3fe9a6f1 |
94 | if (`$CAT Op_write.tmp` eq $right) |
784707d5 |
95 | { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; } |
a687059c |
96 | else |
97 | { print "not ok 2\n"; } |
98 | |
0f85fab0 |
99 | eval <<'EOFORMAT'; |
100 | format OUT2 = |
101 | the brown quick @<< |
102 | $fox |
103 | jumped |
104 | @* |
105 | $multiline |
a0d0e21e |
106 | and |
0f85fab0 |
107 | ^<<<<<<<<< ~~ |
108 | $foo |
109 | now @<<the@>>>> for all@|||||men to come @<<<< |
110 | 'i' . 's', "time\n", $good, 'to' |
111 | . |
112 | EOFORMAT |
113 | |
a0d0e21e |
114 | open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
0f85fab0 |
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); |
d1e4d418 |
121 | close OUT2 or die "Could not close: $!"; |
0f85fab0 |
122 | |
123 | $right = |
124 | "the brown quick fox |
125 | jumped |
126 | forescore |
127 | and |
128 | seven years |
a0d0e21e |
129 | and |
0f85fab0 |
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 | |
3fe9a6f1 |
138 | if (`$CAT Op_write.tmp` eq $right) |
784707d5 |
139 | { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; } |
0f85fab0 |
140 | else |
141 | { print "not ok 3\n"; } |
142 | |
55497cff |
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 | |
7056ecde |
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); |
d1e4d418 |
188 | close OUT3 or die "Could not close: $!"; |
7056ecde |
189 | |
190 | $right = |
191 | "fit\n"; |
192 | |
193 | if (`$CAT Op_write.tmp` eq $right) |
784707d5 |
194 | { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; } |
7056ecde |
195 | else |
196 | { print "not ok 6\n"; } |
197 | |
445b3f51 |
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 |
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); |
d1e4d418 |
220 | close OUT4 or die "Could not close: $!"; |
c2e66d9e |
221 | if (`$CAT Op_write.tmp` eq "1\n") { |
222 | print "ok 9\n"; |
784707d5 |
223 | 1 while unlink "Op_write.tmp"; |
c2e66d9e |
224 | } |
225 | else { |
226 | print "not ok 9\n"; |
227 | } |
784707d5 |
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); |
d1e4d418 |
240 | close OUT10 or die "Could not close: $!"; |
784707d5 |
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); |
d1e4d418 |
263 | close OUT11 or die "Could not close: $!"; |
784707d5 |
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"; } |
9ccde9ea |
273 | |
67525708 |
274 | # 12..47: scary format testing from Merijn H. Brand |
9ccde9ea |
275 | |
dc459aad |
276 | if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' || |
764df951 |
277 | ($^O eq 'os2' and not eval '$OS2::can_fork')) { |
67525708 |
278 | foreach (12..47) { print "ok $_ # skipped: '|-' and '-|' not supported\n"; } |
d4a0c6f3 |
279 | exit(0); |
280 | } |
281 | |
9ccde9ea |
282 | use strict; # Amazed that this hackery can be made strict ... |
283 | |
d57f9278 |
284 | my $test = 12; |
285 | |
9ccde9ea |
286 | # Just a complete test for format, including top-, left- and bottom marging |
287 | # and format detection through glob entries |
288 | |
d57f9278 |
289 | format EMPTY = |
290 | . |
291 | |
292 | format Comment = |
293 | ok @<<<<< |
294 | $test |
295 | . |
296 | |
297 | $= = 10; |
298 | |
299 | # [ID 20020227.005] format bug with undefined _TOP |
300 | { local $~ = "Comment"; |
301 | write; |
302 | $test++; |
303 | print $- == 9 |
304 | ? "ok $test\n" : "not ok $test # TODO \$- = $- instead of 9\n"; |
305 | $test++; |
306 | print $^ ne "Comment_TOP" |
307 | ? "ok $test\n" : "not ok $test # TODO \$^ = $^ instead of 'STDOUT_TOP'\n"; |
308 | $test++; |
309 | } |
310 | |
311 | $^ = "STDOUT_TOP"; |
9ccde9ea |
312 | $= = 7; # Page length |
d57f9278 |
313 | $- = 0; # Lines left |
9ccde9ea |
314 | my $ps = $^L; $^L = ""; # Catch the page separator |
315 | my $tm = 1; # Top margin (empty lines before first output) |
316 | my $bm = 2; # Bottom marging (empty lines between last text and footer) |
317 | my $lm = 4; # Left margin (indent in spaces) |
318 | |
362819fd |
319 | select ((select (STDOUT), $| = 1)[0]); |
9ccde9ea |
320 | if ($lm > 0 and !open STDOUT, "|-") { # Left margin (in this test ALWAYS set) |
362819fd |
321 | select ((select (STDOUT), $| = 1)[0]); |
9ccde9ea |
322 | my $s = " " x $lm; |
323 | while (<STDIN>) { |
324 | s/^/$s/; |
d57f9278 |
325 | print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n"; |
9ccde9ea |
326 | } |
327 | close STDIN; |
d57f9278 |
328 | print + (<DATA>?"not ":""), "ok ", $test++, "\n"; |
9ccde9ea |
329 | close STDOUT; |
330 | exit; |
331 | } |
332 | $tm = "\n" x $tm; |
333 | $= -= $bm + 1; # count one for the trailing "----" |
334 | my $lastmin = 0; |
335 | |
336 | my @E; |
337 | |
338 | sub wryte |
339 | { |
340 | $lastmin = $-; |
341 | write; |
342 | } # wryte; |
343 | |
344 | sub footer |
345 | { |
346 | $% == 1 and return ""; |
347 | |
348 | $lastmin < $= and print "\n" x $lastmin; |
349 | print "\n" x $bm, "----\n", $ps; |
350 | $lastmin = $-; |
351 | ""; |
352 | } # footer |
353 | |
354 | # Yes, this is sick ;-) |
355 | format TOP = |
356 | @* ~ |
357 | @{[footer]} |
358 | @* ~ |
359 | $tm |
360 | . |
361 | |
9ccde9ea |
362 | format ENTRY = |
363 | @ @<<<<~~ |
364 | @{(shift @E)||["",""]} |
365 | . |
366 | |
367 | format EOR = |
368 | - ----- |
369 | . |
370 | |
371 | sub has_format ($) |
372 | { |
373 | my $fmt = shift; |
374 | exists $::{$fmt} or return 0; |
375 | $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT}; |
376 | open my $null, "> /dev/null" or die; |
377 | my $fh = select $null; |
378 | local $~ = $fmt; |
379 | eval "write"; |
380 | select $fh; |
381 | $@?0:1; |
382 | } # has_format |
383 | |
d57f9278 |
384 | $^ = has_format ("TOP") ? "TOP" : "EMPTY"; |
9ccde9ea |
385 | has_format ("ENTRY") or die "No format defined for ENTRY"; |
386 | foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ], |
387 | [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) { |
388 | @E = @$e; |
389 | local $~ = "ENTRY"; |
390 | wryte; |
391 | has_format ("EOR") or next; |
392 | local $~ = "EOR"; |
393 | wryte; |
394 | } |
395 | if (has_format ("EOF")) { |
396 | local $~ = "EOF"; |
397 | wryte; |
398 | } |
399 | |
400 | close STDOUT; |
401 | |
67525708 |
402 | # That was test 47. |
9ccde9ea |
403 | |
404 | __END__ |
405 | |
406 | 1 Test1 |
407 | 2 Test2 |
408 | 3 Test3 |
409 | |
410 | |
411 | ---- |
412 | \f |
413 | 4 Test4 |
414 | 5 Test5 |
415 | 6 Test6 |
416 | |
417 | |
418 | ---- |
419 | \f |
420 | 7 Test7 |
421 | - ----- |
422 | |
423 | |
424 | |
425 | ---- |
426 | \f |
427 | 1 1tseT |
428 | 2 2tseT |
429 | 3 3tseT |
430 | |
431 | |
432 | ---- |
433 | \f |
434 | 4 4tseT |
435 | 5 5tseT |
436 | - ----- |