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