Commit | Line | Data |
a687059c |
1 | #!./perl |
2 | |
9ccde9ea |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | } |
7 | |
ea42cebc |
8 | print "1..49\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"; |
19f4d710 |
33 | END { 1 while unlink 'Op_write.tmp' } |
a687059c |
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'; |
39 | write(OUT); |
d1e4d418 |
40 | close OUT or die "Could not close: $!"; |
a687059c |
41 | |
42 | $right = |
43 | "the quick brown fox |
44 | jumped |
45 | forescore |
46 | and |
47 | seven years |
48 | when in |
49 | the course |
50 | of huma... |
51 | now is the time for all good men to come to\n"; |
52 | |
3fe9a6f1 |
53 | if (`$CAT Op_write.tmp` eq $right) |
784707d5 |
54 | { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; } |
a687059c |
55 | else |
56 | { print "not ok 1\n"; } |
57 | |
748a9306 |
58 | $fox = 'wolfishness'; |
59 | my $fox = 'foxiness'; # Test a lexical variable. |
60 | |
a687059c |
61 | format OUT2 = |
62 | the quick brown @<< |
63 | $fox |
64 | jumped |
65 | @* |
66 | $multiline |
67 | ^<<<<<<<<< ~~ |
68 | $foo |
69 | now @<<the@>>>> for all@|||||men to come @<<<< |
70 | 'i' . 's', "time\n", $good, 'to' |
71 | . |
72 | |
a0d0e21e |
73 | open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp"; |
a687059c |
74 | |
a687059c |
75 | $good = 'good'; |
76 | $multiline = "forescore\nand\nseven years\n"; |
77 | $foo = 'when in the course of human events it becomes necessary'; |
78 | write(OUT2); |
d1e4d418 |
79 | close OUT2 or die "Could not close: $!"; |
a687059c |
80 | |
81 | $right = |
82 | "the quick brown fox |
83 | jumped |
84 | forescore |
85 | and |
86 | seven years |
87 | when in |
88 | the course |
89 | of human |
90 | events it |
91 | becomes |
92 | necessary |
93 | now is the time for all good men to come to\n"; |
94 | |
3fe9a6f1 |
95 | if (`$CAT Op_write.tmp` eq $right) |
784707d5 |
96 | { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; } |
a687059c |
97 | else |
98 | { print "not ok 2\n"; } |
99 | |
0f85fab0 |
100 | eval <<'EOFORMAT'; |
101 | format OUT2 = |
102 | the brown quick @<< |
103 | $fox |
104 | jumped |
105 | @* |
106 | $multiline |
a0d0e21e |
107 | and |
0f85fab0 |
108 | ^<<<<<<<<< ~~ |
109 | $foo |
110 | now @<<the@>>>> for all@|||||men to come @<<<< |
111 | 'i' . 's', "time\n", $good, 'to' |
112 | . |
113 | EOFORMAT |
114 | |
a0d0e21e |
115 | open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
0f85fab0 |
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'; |
121 | write(OUT2); |
d1e4d418 |
122 | close OUT2 or die "Could not close: $!"; |
0f85fab0 |
123 | |
124 | $right = |
125 | "the brown quick fox |
126 | jumped |
127 | forescore |
128 | and |
129 | seven years |
a0d0e21e |
130 | and |
0f85fab0 |
131 | when in |
132 | the course |
133 | of human |
134 | events it |
135 | becomes |
136 | necessary |
137 | now is the time for all good men to come to\n"; |
138 | |
3fe9a6f1 |
139 | if (`$CAT Op_write.tmp` eq $right) |
784707d5 |
140 | { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; } |
0f85fab0 |
141 | else |
142 | { print "not ok 3\n"; } |
143 | |
55497cff |
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 |
158 | EOT |
159 | |
160 | $was1 = $was2 = ''; |
161 | for (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 | } |
173 | print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n"; |
174 | print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n"; |
175 | |
7056ecde |
176 | $^A = ''; |
177 | |
178 | # more test |
179 | |
180 | format OUT3 = |
181 | ^<<<<<<... |
182 | $foo |
183 | . |
184 | |
185 | open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
186 | |
187 | $foo = 'fit '; |
188 | write(OUT3); |
d1e4d418 |
189 | close OUT3 or die "Could not close: $!"; |
7056ecde |
190 | |
191 | $right = |
192 | "fit\n"; |
193 | |
194 | if (`$CAT Op_write.tmp` eq $right) |
784707d5 |
195 | { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; } |
7056ecde |
196 | else |
197 | { print "not ok 6\n"; } |
198 | |
445b3f51 |
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 |
213 | # LEX_INTERPNORMAL test |
214 | my %e = ( a => 1 ); |
215 | format OUT4 = |
216 | @<<<<<< |
217 | "$e{a}" |
218 | . |
219 | open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; |
220 | write (OUT4); |
d1e4d418 |
221 | close OUT4 or die "Could not close: $!"; |
c2e66d9e |
222 | if (`$CAT Op_write.tmp` eq "1\n") { |
223 | print "ok 9\n"; |
784707d5 |
224 | 1 while unlink "Op_write.tmp"; |
c2e66d9e |
225 | } |
226 | else { |
227 | print "not ok 9\n"; |
228 | } |
784707d5 |
229 | |
230 | eval <<'EOFORMAT'; |
231 | format OUT10 = |
232 | @####.## @0###.## |
233 | $test1, $test1 |
234 | . |
235 | EOFORMAT |
236 | |
237 | open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
238 | |
239 | $test1 = 12.95; |
240 | write(OUT10); |
d1e4d418 |
241 | close OUT10 or die "Could not close: $!"; |
784707d5 |
242 | |
243 | $right = " 12.95 00012.95\n"; |
244 | if (`$CAT Op_write.tmp` eq $right) |
245 | { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; } |
246 | else |
247 | { print "not ok 10\n"; } |
248 | |
249 | eval <<'EOFORMAT'; |
250 | format OUT11 = |
251 | @0###.## |
252 | $test1 |
253 | @ 0# |
254 | $test1 |
255 | @0 # |
256 | $test1 |
257 | . |
258 | EOFORMAT |
259 | |
260 | open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
261 | |
262 | $test1 = 12.95; |
263 | write(OUT11); |
d1e4d418 |
264 | close OUT11 or die "Could not close: $!"; |
784707d5 |
265 | |
266 | $right = |
267 | "00012.95 |
268 | 1 0# |
269 | 10 #\n"; |
270 | if (`$CAT Op_write.tmp` eq $right) |
271 | { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; } |
272 | else |
273 | { print "not ok 11\n"; } |
9ccde9ea |
274 | |
31869a79 |
275 | { |
71f882da |
276 | my $el; |
31869a79 |
277 | format STDOUT = |
278 | ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze |
279 | $el |
280 | . |
281 | my %hash = (12 => 3); |
282 | for $el (keys %hash) { |
283 | write; |
284 | } |
285 | } |
286 | |
ea42cebc |
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 = |
294 | ok ^<<<<<<<<< ~~ |
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 | |
303 | ####################################### |
304 | # Easiest to add new tests above here # |
305 | ####################################### |
306 | |
307 | # 14..49: scary format testing from Merijn H. Brand |
308 | |
309 | my $test = 14; |
475b40fd |
310 | my $tests = 49; |
9ccde9ea |
311 | |
dc459aad |
312 | if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' || |
764df951 |
313 | ($^O eq 'os2' and not eval '$OS2::can_fork')) { |
ea42cebc |
314 | foreach ($test..$tests) { |
315 | print "ok $_ # skipped: '|-' and '-|' not supported\n"; |
316 | } |
d4a0c6f3 |
317 | exit(0); |
318 | } |
319 | |
9ccde9ea |
320 | |
ea42cebc |
321 | use strict; # Amazed that this hackery can be made strict ... |
d57f9278 |
322 | |
9ccde9ea |
323 | # Just a complete test for format, including top-, left- and bottom marging |
324 | # and format detection through glob entries |
325 | |
d57f9278 |
326 | format EMPTY = |
327 | . |
328 | |
329 | format Comment = |
330 | ok @<<<<< |
331 | $test |
332 | . |
333 | |
334 | $= = 10; |
335 | |
336 | # [ID 20020227.005] format bug with undefined _TOP |
337 | { local $~ = "Comment"; |
338 | write; |
339 | $test++; |
340 | print $- == 9 |
341 | ? "ok $test\n" : "not ok $test # TODO \$- = $- instead of 9\n"; |
342 | $test++; |
343 | print $^ ne "Comment_TOP" |
344 | ? "ok $test\n" : "not ok $test # TODO \$^ = $^ instead of 'STDOUT_TOP'\n"; |
345 | $test++; |
346 | } |
347 | |
348 | $^ = "STDOUT_TOP"; |
9ccde9ea |
349 | $= = 7; # Page length |
d57f9278 |
350 | $- = 0; # Lines left |
9ccde9ea |
351 | my $ps = $^L; $^L = ""; # Catch the page separator |
352 | my $tm = 1; # Top margin (empty lines before first output) |
353 | my $bm = 2; # Bottom marging (empty lines between last text and footer) |
354 | my $lm = 4; # Left margin (indent in spaces) |
355 | |
362819fd |
356 | select ((select (STDOUT), $| = 1)[0]); |
9ccde9ea |
357 | if ($lm > 0 and !open STDOUT, "|-") { # Left margin (in this test ALWAYS set) |
362819fd |
358 | select ((select (STDOUT), $| = 1)[0]); |
9ccde9ea |
359 | my $s = " " x $lm; |
360 | while (<STDIN>) { |
361 | s/^/$s/; |
d57f9278 |
362 | print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n"; |
9ccde9ea |
363 | } |
364 | close STDIN; |
d57f9278 |
365 | print + (<DATA>?"not ":""), "ok ", $test++, "\n"; |
9ccde9ea |
366 | close STDOUT; |
367 | exit; |
368 | } |
369 | $tm = "\n" x $tm; |
370 | $= -= $bm + 1; # count one for the trailing "----" |
371 | my $lastmin = 0; |
372 | |
373 | my @E; |
374 | |
375 | sub wryte |
376 | { |
377 | $lastmin = $-; |
378 | write; |
379 | } # wryte; |
380 | |
381 | sub footer |
382 | { |
383 | $% == 1 and return ""; |
384 | |
385 | $lastmin < $= and print "\n" x $lastmin; |
386 | print "\n" x $bm, "----\n", $ps; |
387 | $lastmin = $-; |
388 | ""; |
389 | } # footer |
390 | |
391 | # Yes, this is sick ;-) |
392 | format TOP = |
393 | @* ~ |
394 | @{[footer]} |
395 | @* ~ |
396 | $tm |
397 | . |
398 | |
9ccde9ea |
399 | format ENTRY = |
400 | @ @<<<<~~ |
401 | @{(shift @E)||["",""]} |
402 | . |
403 | |
404 | format EOR = |
405 | - ----- |
406 | . |
407 | |
408 | sub has_format ($) |
409 | { |
410 | my $fmt = shift; |
411 | exists $::{$fmt} or return 0; |
412 | $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT}; |
413 | open my $null, "> /dev/null" or die; |
414 | my $fh = select $null; |
415 | local $~ = $fmt; |
416 | eval "write"; |
417 | select $fh; |
418 | $@?0:1; |
419 | } # has_format |
420 | |
d57f9278 |
421 | $^ = has_format ("TOP") ? "TOP" : "EMPTY"; |
9ccde9ea |
422 | has_format ("ENTRY") or die "No format defined for ENTRY"; |
423 | foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ], |
424 | [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) { |
425 | @E = @$e; |
426 | local $~ = "ENTRY"; |
427 | wryte; |
428 | has_format ("EOR") or next; |
429 | local $~ = "EOR"; |
430 | wryte; |
431 | } |
432 | if (has_format ("EOF")) { |
433 | local $~ = "EOF"; |
434 | wryte; |
435 | } |
436 | |
437 | close STDOUT; |
438 | |
ea42cebc |
439 | # That was test 48. |
9ccde9ea |
440 | |
441 | __END__ |
442 | |
443 | 1 Test1 |
444 | 2 Test2 |
445 | 3 Test3 |
446 | |
447 | |
448 | ---- |
449 | \f |
450 | 4 Test4 |
451 | 5 Test5 |
452 | 6 Test6 |
453 | |
454 | |
455 | ---- |
456 | \f |
457 | 7 Test7 |
458 | - ----- |
459 | |
460 | |
461 | |
462 | ---- |
463 | \f |
464 | 1 1tseT |
465 | 2 2tseT |
466 | 3 3tseT |
467 | |
468 | |
469 | ---- |
470 | \f |
471 | 4 4tseT |
472 | 5 5tseT |
473 | - ----- |