Commit | Line | Data |
a687059c |
1 | #!./perl |
2 | |
9ccde9ea |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | } |
7 | |
8 | print "1..44\n"; |
a687059c |
9 | |
95e8664e |
10 | my $CAT = ($^O eq 'MSWin32') ? 'type' |
11 | : ($^O eq 'MacOS') ? 'catenate' : 'cat'; |
3fe9a6f1 |
12 | |
a687059c |
13 | format OUT = |
14 | the quick brown @<< |
15 | $fox |
16 | jumped |
17 | @* |
18 | $multiline |
19 | ^<<<<<<<<< |
20 | $foo |
21 | ^<<<<<<<<< |
22 | $foo |
23 | ^<<<<<<... |
24 | $foo |
25 | now @<<the@>>>> for all@|||||men to come @<<<< |
a0d0e21e |
26 | { |
27 | 'i' . 's', "time\n", $good, 'to' |
28 | } |
a687059c |
29 | . |
30 | |
a0d0e21e |
31 | open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
a687059c |
32 | |
33 | $fox = 'foxiness'; |
34 | $good = 'good'; |
35 | $multiline = "forescore\nand\nseven years\n"; |
36 | $foo = 'when in the course of human events it becomes necessary'; |
37 | write(OUT); |
38 | close OUT; |
39 | |
40 | $right = |
41 | "the quick brown fox |
42 | jumped |
43 | forescore |
44 | and |
45 | seven years |
46 | when in |
47 | the course |
48 | of huma... |
49 | now is the time for all good men to come to\n"; |
50 | |
3fe9a6f1 |
51 | if (`$CAT Op_write.tmp` eq $right) |
784707d5 |
52 | { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; } |
a687059c |
53 | else |
54 | { print "not ok 1\n"; } |
55 | |
748a9306 |
56 | $fox = 'wolfishness'; |
57 | my $fox = 'foxiness'; # Test a lexical variable. |
58 | |
a687059c |
59 | format OUT2 = |
60 | the quick brown @<< |
61 | $fox |
62 | jumped |
63 | @* |
64 | $multiline |
65 | ^<<<<<<<<< ~~ |
66 | $foo |
67 | now @<<the@>>>> for all@|||||men to come @<<<< |
68 | 'i' . 's', "time\n", $good, 'to' |
69 | . |
70 | |
a0d0e21e |
71 | open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp"; |
a687059c |
72 | |
a687059c |
73 | $good = 'good'; |
74 | $multiline = "forescore\nand\nseven years\n"; |
75 | $foo = 'when in the course of human events it becomes necessary'; |
76 | write(OUT2); |
77 | close OUT2; |
78 | |
79 | $right = |
80 | "the quick brown fox |
81 | jumped |
82 | forescore |
83 | and |
84 | seven years |
85 | when in |
86 | the course |
87 | of human |
88 | events it |
89 | becomes |
90 | necessary |
91 | now is the time for all good men to come to\n"; |
92 | |
3fe9a6f1 |
93 | if (`$CAT Op_write.tmp` eq $right) |
784707d5 |
94 | { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; } |
a687059c |
95 | else |
96 | { print "not ok 2\n"; } |
97 | |
0f85fab0 |
98 | eval <<'EOFORMAT'; |
99 | format OUT2 = |
100 | the brown quick @<< |
101 | $fox |
102 | jumped |
103 | @* |
104 | $multiline |
a0d0e21e |
105 | and |
0f85fab0 |
106 | ^<<<<<<<<< ~~ |
107 | $foo |
108 | now @<<the@>>>> for all@|||||men to come @<<<< |
109 | 'i' . 's', "time\n", $good, 'to' |
110 | . |
111 | EOFORMAT |
112 | |
a0d0e21e |
113 | open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
0f85fab0 |
114 | |
115 | $fox = 'foxiness'; |
116 | $good = 'good'; |
117 | $multiline = "forescore\nand\nseven years\n"; |
118 | $foo = 'when in the course of human events it becomes necessary'; |
119 | write(OUT2); |
120 | close OUT2; |
121 | |
122 | $right = |
123 | "the brown quick fox |
124 | jumped |
125 | forescore |
126 | and |
127 | seven years |
a0d0e21e |
128 | and |
0f85fab0 |
129 | when in |
130 | the course |
131 | of human |
132 | events it |
133 | becomes |
134 | necessary |
135 | now is the time for all good men to come to\n"; |
136 | |
3fe9a6f1 |
137 | if (`$CAT Op_write.tmp` eq $right) |
784707d5 |
138 | { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; } |
0f85fab0 |
139 | else |
140 | { print "not ok 3\n"; } |
141 | |
55497cff |
142 | # formline tests |
143 | |
144 | $mustbe = <<EOT; |
145 | @ a |
146 | @> ab |
147 | @>> abc |
148 | @>>> abc |
149 | @>>>> abc |
150 | @>>>>> abc |
151 | @>>>>>> abc |
152 | @>>>>>>> abc |
153 | @>>>>>>>> abc |
154 | @>>>>>>>>> abc |
155 | @>>>>>>>>>> abc |
156 | EOT |
157 | |
158 | $was1 = $was2 = ''; |
159 | for (0..10) { |
160 | # lexical picture |
161 | $^A = ''; |
162 | my $format1 = '@' . '>' x $_; |
163 | formline $format1, 'abc'; |
164 | $was1 .= "$format1 $^A\n"; |
165 | # global |
166 | $^A = ''; |
167 | local $format2 = '@' . '>' x $_; |
168 | formline $format2, 'abc'; |
169 | $was2 .= "$format2 $^A\n"; |
170 | } |
171 | print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n"; |
172 | print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n"; |
173 | |
7056ecde |
174 | $^A = ''; |
175 | |
176 | # more test |
177 | |
178 | format OUT3 = |
179 | ^<<<<<<... |
180 | $foo |
181 | . |
182 | |
183 | open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
184 | |
185 | $foo = 'fit '; |
186 | write(OUT3); |
187 | close OUT3; |
188 | |
189 | $right = |
190 | "fit\n"; |
191 | |
192 | if (`$CAT Op_write.tmp` eq $right) |
784707d5 |
193 | { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; } |
7056ecde |
194 | else |
195 | { print "not ok 6\n"; } |
196 | |
445b3f51 |
197 | # test lexicals and globals |
198 | { |
199 | my $this = "ok"; |
200 | our $that = 7; |
201 | format LEX = |
202 | @<<@| |
203 | $this,$that |
204 | . |
205 | open(LEX, ">&STDOUT") or die; |
206 | write LEX; |
207 | $that = 8; |
208 | write LEX; |
fdc7a9f2 |
209 | close LEX; |
445b3f51 |
210 | } |
c2e66d9e |
211 | # LEX_INTERPNORMAL test |
212 | my %e = ( a => 1 ); |
213 | format OUT4 = |
214 | @<<<<<< |
215 | "$e{a}" |
216 | . |
217 | open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; |
218 | write (OUT4); |
219 | close OUT4; |
220 | if (`$CAT Op_write.tmp` eq "1\n") { |
221 | print "ok 9\n"; |
784707d5 |
222 | 1 while unlink "Op_write.tmp"; |
c2e66d9e |
223 | } |
224 | else { |
225 | print "not ok 9\n"; |
226 | } |
784707d5 |
227 | |
228 | eval <<'EOFORMAT'; |
229 | format OUT10 = |
230 | @####.## @0###.## |
231 | $test1, $test1 |
232 | . |
233 | EOFORMAT |
234 | |
235 | open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
236 | |
237 | $test1 = 12.95; |
238 | write(OUT10); |
239 | close OUT10; |
240 | |
241 | $right = " 12.95 00012.95\n"; |
242 | if (`$CAT Op_write.tmp` eq $right) |
243 | { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; } |
244 | else |
245 | { print "not ok 10\n"; } |
246 | |
247 | eval <<'EOFORMAT'; |
248 | format OUT11 = |
249 | @0###.## |
250 | $test1 |
251 | @ 0# |
252 | $test1 |
253 | @0 # |
254 | $test1 |
255 | . |
256 | EOFORMAT |
257 | |
258 | open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
259 | |
260 | $test1 = 12.95; |
261 | write(OUT11); |
262 | close OUT11; |
263 | |
264 | $right = |
265 | "00012.95 |
266 | 1 0# |
267 | 10 #\n"; |
268 | if (`$CAT Op_write.tmp` eq $right) |
269 | { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; } |
270 | else |
271 | { print "not ok 11\n"; } |
9ccde9ea |
272 | |
273 | # 12..44: scary format testing from Merijn H. Brand |
274 | |
275 | use strict; # Amazed that this hackery can be made strict ... |
276 | |
277 | # Just a complete test for format, including top-, left- and bottom marging |
278 | # and format detection through glob entries |
279 | |
280 | $= = 7; # Page length |
281 | my $ps = $^L; $^L = ""; # Catch the page separator |
282 | my $tm = 1; # Top margin (empty lines before first output) |
283 | my $bm = 2; # Bottom marging (empty lines between last text and footer) |
284 | my $lm = 4; # Left margin (indent in spaces) |
285 | |
286 | if ($lm > 0 and !open STDOUT, "|-") { # Left margin (in this test ALWAYS set) |
287 | my $i = 12; |
288 | my $s = " " x $lm; |
289 | while (<STDIN>) { |
290 | s/^/$s/; |
291 | print + ($_ eq <DATA> ? "" : "not "), "ok ", $i++, "\n"; |
292 | } |
293 | close STDIN; |
294 | print + (<DATA>?"not ":""), "ok ", $i++, "\n"; |
295 | close STDOUT; |
296 | exit; |
297 | } |
298 | $tm = "\n" x $tm; |
299 | $= -= $bm + 1; # count one for the trailing "----" |
300 | my $lastmin = 0; |
301 | |
302 | my @E; |
303 | |
304 | sub wryte |
305 | { |
306 | $lastmin = $-; |
307 | write; |
308 | } # wryte; |
309 | |
310 | sub footer |
311 | { |
312 | $% == 1 and return ""; |
313 | |
314 | $lastmin < $= and print "\n" x $lastmin; |
315 | print "\n" x $bm, "----\n", $ps; |
316 | $lastmin = $-; |
317 | ""; |
318 | } # footer |
319 | |
320 | # Yes, this is sick ;-) |
321 | format TOP = |
322 | @* ~ |
323 | @{[footer]} |
324 | @* ~ |
325 | $tm |
326 | . |
327 | |
328 | format EmptyTOP = |
329 | . |
330 | |
331 | format ENTRY = |
332 | @ @<<<<~~ |
333 | @{(shift @E)||["",""]} |
334 | . |
335 | |
336 | format EOR = |
337 | - ----- |
338 | . |
339 | |
340 | sub has_format ($) |
341 | { |
342 | my $fmt = shift; |
343 | exists $::{$fmt} or return 0; |
344 | $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT}; |
345 | open my $null, "> /dev/null" or die; |
346 | my $fh = select $null; |
347 | local $~ = $fmt; |
348 | eval "write"; |
349 | select $fh; |
350 | $@?0:1; |
351 | } # has_format |
352 | |
353 | $^ = has_format ("TOP") ? "TOP" : "EmptyTOP"; |
354 | has_format ("ENTRY") or die "No format defined for ENTRY"; |
355 | foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ], |
356 | [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) { |
357 | @E = @$e; |
358 | local $~ = "ENTRY"; |
359 | wryte; |
360 | has_format ("EOR") or next; |
361 | local $~ = "EOR"; |
362 | wryte; |
363 | } |
364 | if (has_format ("EOF")) { |
365 | local $~ = "EOF"; |
366 | wryte; |
367 | } |
368 | |
369 | close STDOUT; |
370 | |
371 | # That was test 44. |
372 | |
373 | __END__ |
374 | |
375 | 1 Test1 |
376 | 2 Test2 |
377 | 3 Test3 |
378 | |
379 | |
380 | ---- |
381 | \f |
382 | 4 Test4 |
383 | 5 Test5 |
384 | 6 Test6 |
385 | |
386 | |
387 | ---- |
388 | \f |
389 | 7 Test7 |
390 | - ----- |
391 | |
392 | |
393 | |
394 | ---- |
395 | \f |
396 | 1 1tseT |
397 | 2 2tseT |
398 | 3 3tseT |
399 | |
400 | |
401 | ---- |
402 | \f |
403 | 4 4tseT |
404 | 5 5tseT |
405 | - ----- |