Commit | Line | Data |
---|---|---|
a687059c LW |
1 | #!./perl |
2 | ||
9ccde9ea JH |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
6 | } | |
7 | ||
f5c235e7 | 8 | print "1..50\n"; |
a687059c | 9 | |
da405c16 | 10 | my $CAT = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') ? 'type' |
2986a63f JH |
11 | : ($^O eq 'MacOS') ? 'catenate' |
12 | : 'cat'; | |
3fe9a6f1 | 13 | |
a687059c LW |
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 LW |
27 | { |
28 | 'i' . 's', "time\n", $good, 'to' | |
29 | } | |
a687059c LW |
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 LW |
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 LW |
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 LW |
55 | else |
56 | { print "not ok 1\n"; } | |
57 | ||
748a9306 LW |
58 | $fox = 'wolfishness'; |
59 | my $fox = 'foxiness'; # Test a lexical variable. | |
60 | ||
a687059c LW |
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 LW |
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 LW |
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 LW |
97 | else |
98 | { print "not ok 2\n"; } | |
99 | ||
0f85fab0 LW |
100 | eval <<'EOFORMAT'; |
101 | format OUT2 = | |
102 | the brown quick @<< | |
103 | $fox | |
104 | jumped | |
105 | @* | |
106 | $multiline | |
a0d0e21e | 107 | and |
0f85fab0 LW |
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 LW |
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 LW |
123 | |
124 | $right = | |
125 | "the brown quick fox | |
126 | jumped | |
127 | forescore | |
128 | and | |
129 | seven years | |
a0d0e21e | 130 | and |
0f85fab0 LW |
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 LW |
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 KM |
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 KM |
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 KM |
196 | else |
197 | { print "not ok 6\n"; } | |
198 | ||
445b3f51 GS |
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 GS |
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 GS |
222 | if (`$CAT Op_write.tmp` eq "1\n") { |
223 | print "ok 9\n"; | |
784707d5 | 224 | 1 while unlink "Op_write.tmp"; |
c2e66d9e GS |
225 | } |
226 | else { | |
227 | print "not ok 9\n"; | |
228 | } | |
784707d5 JP |
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 JP |
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 JP |
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 AE |
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 RGS |
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 | ||
f5c235e7 DM |
303 | { |
304 | # Bug #24774 format without trailing \n failed assertion | |
c5ee2135 WL |
305 | # but this must not compile because we'd get a ';' into the format |
306 | ||
f5c235e7 DM |
307 | my @v = ('k'); |
308 | eval "format OUT14 = \n@\n\@v"; | |
c5ee2135 WL |
309 | print $@ ? "ok 14\n" : "not ok 14\n"; |
310 | ||
f5c235e7 DM |
311 | } |
312 | ||
ea42cebc RGS |
313 | ####################################### |
314 | # Easiest to add new tests above here # | |
315 | ####################################### | |
316 | ||
f5c235e7 | 317 | # 15..50: scary format testing from Merijn H. Brand |
ea42cebc | 318 | |
f5c235e7 DM |
319 | my $test = 15; |
320 | my $tests = 50; | |
9ccde9ea | 321 | |
dc459aad | 322 | if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' || |
764df951 | 323 | ($^O eq 'os2' and not eval '$OS2::can_fork')) { |
ea42cebc RGS |
324 | foreach ($test..$tests) { |
325 | print "ok $_ # skipped: '|-' and '-|' not supported\n"; | |
326 | } | |
d4a0c6f3 CB |
327 | exit(0); |
328 | } | |
329 | ||
9ccde9ea | 330 | |
ea42cebc | 331 | use strict; # Amazed that this hackery can be made strict ... |
d57f9278 | 332 | |
9ccde9ea JH |
333 | # Just a complete test for format, including top-, left- and bottom marging |
334 | # and format detection through glob entries | |
335 | ||
d57f9278 MB |
336 | format EMPTY = |
337 | . | |
338 | ||
339 | format Comment = | |
340 | ok @<<<<< | |
341 | $test | |
342 | . | |
343 | ||
344 | $= = 10; | |
345 | ||
346 | # [ID 20020227.005] format bug with undefined _TOP | |
347 | { local $~ = "Comment"; | |
348 | write; | |
349 | $test++; | |
350 | print $- == 9 | |
3444c34c | 351 | ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n"; |
d57f9278 MB |
352 | $test++; |
353 | print $^ ne "Comment_TOP" | |
cfcd312a | 354 | ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_TOP'\n"; |
d57f9278 MB |
355 | $test++; |
356 | } | |
357 | ||
358 | $^ = "STDOUT_TOP"; | |
9ccde9ea | 359 | $= = 7; # Page length |
d57f9278 | 360 | $- = 0; # Lines left |
9ccde9ea JH |
361 | my $ps = $^L; $^L = ""; # Catch the page separator |
362 | my $tm = 1; # Top margin (empty lines before first output) | |
363 | my $bm = 2; # Bottom marging (empty lines between last text and footer) | |
364 | my $lm = 4; # Left margin (indent in spaces) | |
365 | ||
362819fd | 366 | select ((select (STDOUT), $| = 1)[0]); |
9ccde9ea | 367 | if ($lm > 0 and !open STDOUT, "|-") { # Left margin (in this test ALWAYS set) |
362819fd | 368 | select ((select (STDOUT), $| = 1)[0]); |
9ccde9ea JH |
369 | my $s = " " x $lm; |
370 | while (<STDIN>) { | |
371 | s/^/$s/; | |
d57f9278 | 372 | print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n"; |
9ccde9ea JH |
373 | } |
374 | close STDIN; | |
d57f9278 | 375 | print + (<DATA>?"not ":""), "ok ", $test++, "\n"; |
9ccde9ea JH |
376 | close STDOUT; |
377 | exit; | |
378 | } | |
379 | $tm = "\n" x $tm; | |
380 | $= -= $bm + 1; # count one for the trailing "----" | |
381 | my $lastmin = 0; | |
382 | ||
383 | my @E; | |
384 | ||
385 | sub wryte | |
386 | { | |
387 | $lastmin = $-; | |
388 | write; | |
389 | } # wryte; | |
390 | ||
391 | sub footer | |
392 | { | |
393 | $% == 1 and return ""; | |
394 | ||
395 | $lastmin < $= and print "\n" x $lastmin; | |
396 | print "\n" x $bm, "----\n", $ps; | |
397 | $lastmin = $-; | |
398 | ""; | |
399 | } # footer | |
400 | ||
401 | # Yes, this is sick ;-) | |
402 | format TOP = | |
403 | @* ~ | |
404 | @{[footer]} | |
405 | @* ~ | |
406 | $tm | |
407 | . | |
408 | ||
9ccde9ea JH |
409 | format ENTRY = |
410 | @ @<<<<~~ | |
411 | @{(shift @E)||["",""]} | |
412 | . | |
413 | ||
414 | format EOR = | |
415 | - ----- | |
416 | . | |
417 | ||
418 | sub has_format ($) | |
419 | { | |
420 | my $fmt = shift; | |
421 | exists $::{$fmt} or return 0; | |
422 | $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT}; | |
423 | open my $null, "> /dev/null" or die; | |
424 | my $fh = select $null; | |
425 | local $~ = $fmt; | |
426 | eval "write"; | |
427 | select $fh; | |
428 | $@?0:1; | |
429 | } # has_format | |
430 | ||
d57f9278 | 431 | $^ = has_format ("TOP") ? "TOP" : "EMPTY"; |
9ccde9ea JH |
432 | has_format ("ENTRY") or die "No format defined for ENTRY"; |
433 | foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ], | |
434 | [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) { | |
435 | @E = @$e; | |
436 | local $~ = "ENTRY"; | |
437 | wryte; | |
438 | has_format ("EOR") or next; | |
439 | local $~ = "EOR"; | |
440 | wryte; | |
441 | } | |
442 | if (has_format ("EOF")) { | |
443 | local $~ = "EOF"; | |
444 | wryte; | |
445 | } | |
446 | ||
447 | close STDOUT; | |
448 | ||
ea42cebc | 449 | # That was test 48. |
9ccde9ea JH |
450 | |
451 | __END__ | |
452 | ||
453 | 1 Test1 | |
454 | 2 Test2 | |
455 | 3 Test3 | |
456 | ||
457 | ||
458 | ---- | |
459 | \f | |
460 | 4 Test4 | |
461 | 5 Test5 | |
462 | 6 Test6 | |
463 | ||
464 | ||
465 | ---- | |
466 | \f | |
467 | 7 Test7 | |
468 | - ----- | |
469 | ||
470 | ||
471 | ||
472 | ---- | |
473 | \f | |
474 | 1 1tseT | |
475 | 2 2tseT | |
476 | 3 3tseT | |
477 | ||
478 | ||
479 | ---- | |
480 | \f | |
481 | 4 4tseT | |
482 | 5 5tseT | |
483 | - ----- |