Commit | Line | Data |
---|---|---|
5b2b9c68 | 1 | #!./perl |
5fe499a8 | 2 | # Test $/ |
5b2b9c68 | 3 | |
520b6fb6 | 4 | print "1..41\n"; |
5b2b9c68 | 5 | |
4dafff08 | 6 | $test_count = 1; |
5b2b9c68 | 7 | $teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n"; |
4dafff08 | 8 | $teststring2 = "1234567890123456789012345678901234567890"; |
5b2b9c68 HM |
9 | |
10 | # Create our test datafile | |
a3318c00 MG |
11 | 1 while unlink 'foo'; # in case junk left around |
12 | rmdir 'foo'; | |
5b2b9c68 HM |
13 | open TESTFILE, ">./foo" or die "error $! $^E opening"; |
14 | binmode TESTFILE; | |
15 | print TESTFILE $teststring; | |
a3b148a7 | 16 | close TESTFILE or die "error $! $^E closing"; |
5b2b9c68 | 17 | |
4dafff08 | 18 | $test_count_start = $test_count; # Needed to know how many tests to skip |
5b2b9c68 HM |
19 | open TESTFILE, "<./foo"; |
20 | binmode TESTFILE; | |
4dafff08 B |
21 | test_string(*TESTFILE); |
22 | close TESTFILE; | |
23 | unlink "./foo"; | |
5b2b9c68 HM |
24 | |
25 | # try the record reading tests. New file so we don't have to worry about | |
26 | # the size of \n. | |
5b2b9c68 | 27 | open TESTFILE, ">./foo"; |
4dafff08 | 28 | print TESTFILE $teststring2; |
5b2b9c68 HM |
29 | binmode TESTFILE; |
30 | close TESTFILE; | |
31 | open TESTFILE, "<./foo"; | |
32 | binmode TESTFILE; | |
4dafff08 | 33 | test_record(*TESTFILE); |
7120fed6 | 34 | close TESTFILE; |
4dafff08 B |
35 | $test_count_end = $test_count; # Needed to know how many tests to skip |
36 | ||
5fe499a8 TC |
37 | $/ = "\n"; |
38 | my $note = "\$/ preserved when set to bad value"; | |
39 | # none of the setting of $/ to bad values should modify its value | |
0b81c0dd | 40 | test_bad_setting(); |
5fe499a8 TC |
41 | print +($/ ne "\n" ? "not " : "") . |
42 | "ok $test_count # \$/ preserved when set to bad value\n"; | |
43 | ++$test_count; | |
5b2b9c68 HM |
44 | |
45 | # Now for the tricky bit--full record reading | |
46 | if ($^O eq 'VMS') { | |
47 | # Create a temp file. We jump through these hoops 'cause CREATE really | |
48 | # doesn't like our methods for some reason. | |
439f5715 GS |
49 | open FDLFILE, "> ./foo.fdl"; |
50 | print FDLFILE "RECORD\n FORMAT VARIABLE\n"; | |
51 | close FDLFILE; | |
52 | open CREATEFILE, "> ./foo.com"; | |
53 | print CREATEFILE '$ DEFINE/USER SYS$INPUT NL:', "\n"; | |
54 | print CREATEFILE '$ DEFINE/USER SYS$OUTPUT NL:', "\n"; | |
55 | print CREATEFILE '$ OPEN YOW []FOO.BAR/WRITE', "\n"; | |
56 | print CREATEFILE '$ CLOSE YOW', "\n"; | |
57 | print CREATEFILE "\$EXIT\n"; | |
58 | close CREATEFILE; | |
59 | $throwaway = `\@\[\]foo`, "\n"; | |
60 | open(TEMPFILE, ">./foo.bar") or print "# open failed $! $^E\n"; | |
5b2b9c68 HM |
61 | print TEMPFILE "foo\nfoobar\nbaz\n"; |
62 | close TEMPFILE; | |
5b2b9c68 HM |
63 | |
64 | open TESTFILE, "<./foo.bar"; | |
65 | $/ = \10; | |
66 | $bar = <TESTFILE>; | |
4dafff08 B |
67 | if ($bar eq "foo\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";} |
68 | $test_count++; | |
5b2b9c68 | 69 | $bar = <TESTFILE>; |
4dafff08 B |
70 | if ($bar eq "foobar\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";} |
71 | $test_count++; | |
5b2b9c68 HM |
72 | # can we do a short read? |
73 | $/ = \2; | |
74 | $bar = <TESTFILE>; | |
4dafff08 B |
75 | if ($bar eq "ba") {print "ok $test_count\n";} else {print "not ok $test_count\n";} |
76 | $test_count++; | |
5b2b9c68 HM |
77 | # do we get the rest of the record? |
78 | $bar = <TESTFILE>; | |
4dafff08 B |
79 | if ($bar eq "z\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";} |
80 | $test_count++; | |
5b2b9c68 | 81 | |
7120fed6 | 82 | close TESTFILE; |
1f47e8e2 | 83 | 1 while unlink qw(foo.bar foo.com foo.fdl); |
5b2b9c68 HM |
84 | } else { |
85 | # Nobody else does this at the moment (well, maybe OS/390, but they can | |
86 | # put their own tests in) so we just punt | |
4dafff08 B |
87 | foreach $test ($test_count..$test_count + 3) { |
88 | print "ok $test # skipped on non-VMS system\n"; | |
89 | $test_count++; | |
90 | } | |
5b2b9c68 | 91 | } |
f558d5af JH |
92 | |
93 | $/ = "\n"; | |
94 | ||
95 | # see if open/readline/close work on our and my variables | |
96 | { | |
97 | if (open our $T, "./foo") { | |
98 | my $line = <$T>; | |
99 | print "# $line\n"; | |
100 | length($line) == 40 or print "not "; | |
101 | close $T or print "not "; | |
102 | } | |
103 | else { | |
104 | print "not "; | |
105 | } | |
4dafff08 B |
106 | print "ok $test_count # open/readline/close on our variable\n"; |
107 | $test_count++; | |
f558d5af JH |
108 | } |
109 | ||
110 | { | |
111 | if (open my $T, "./foo") { | |
112 | my $line = <$T>; | |
113 | print "# $line\n"; | |
114 | length($line) == 40 or print "not "; | |
115 | close $T or print "not "; | |
116 | } | |
117 | else { | |
118 | print "not "; | |
119 | } | |
4dafff08 B |
120 | print "ok $test_count # open/readline/close on my variable\n"; |
121 | $test_count++; | |
122 | } | |
123 | ||
124 | ||
20c00210 FC |
125 | { |
126 | # If we do not include the lib directories, we may end up picking up a | |
127 | # binary-incompatible previously-installed version. The eval won’t help in | |
128 | # intercepting a SIGTRAP. | |
129 | local @INC = ("../lib", "lib", @INC); | |
d29663db | 130 | if (not eval q/use PerlIO::scalar; 1/) { |
0b81c0dd | 131 | # In-memory files necessitate PerlIO::scalar, thus a perl with |
4dafff08 B |
132 | # perlio and dynaloading enabled. miniperl won't be able to run this |
133 | # test, so skip it | |
134 | ||
135 | for $test ($test_count .. $test_count + ($test_count_end - $test_count_start - 1)) { | |
24ead163 | 136 | print "ok $test # skipped - Can't test in memory file with miniperl/without PerlIO::Scalar\n"; |
4dafff08 B |
137 | $test_count++; |
138 | } | |
20c00210 FC |
139 | } |
140 | else { | |
4dafff08 B |
141 | # Test if a file in memory behaves the same as a real file (= re-run the test with a file in memory) |
142 | open TESTFILE, "<", \$teststring; | |
143 | test_string(*TESTFILE); | |
144 | close TESTFILE; | |
145 | ||
146 | open TESTFILE, "<", \$teststring2; | |
147 | test_record(*TESTFILE); | |
148 | close TESTFILE; | |
20c00210 | 149 | } |
f558d5af JH |
150 | } |
151 | ||
152 | # Get rid of the temp file | |
153 | END { unlink "./foo"; } | |
4dafff08 B |
154 | |
155 | sub test_string { | |
156 | *FH = shift; | |
157 | ||
158 | # Check the default $/ | |
159 | $bar = <FH>; | |
160 | if ($bar ne "1\n") {print "not ";} | |
161 | print "ok $test_count # default \$/\n"; | |
162 | $test_count++; | |
163 | ||
164 | # explicitly set to \n | |
165 | $/ = "\n"; | |
166 | $bar = <FH>; | |
167 | if ($bar ne "12\n") {print "not ";} | |
168 | print "ok $test_count # \$/ = \"\\n\"\n"; | |
169 | $test_count++; | |
170 | ||
171 | # Try a non line terminator | |
172 | $/ = 3; | |
173 | $bar = <FH>; | |
174 | if ($bar ne "123") {print "not ";} | |
175 | print "ok $test_count # \$/ = 3\n"; | |
176 | $test_count++; | |
177 | ||
178 | # Eat the line terminator | |
179 | $/ = "\n"; | |
180 | $bar = <FH>; | |
181 | ||
182 | # How about a larger terminator | |
183 | $/ = "34"; | |
184 | $bar = <FH>; | |
185 | if ($bar ne "1234") {print "not ";} | |
186 | print "ok $test_count # \$/ = \"34\"\n"; | |
187 | $test_count++; | |
188 | ||
189 | # Eat the line terminator | |
190 | $/ = "\n"; | |
191 | $bar = <FH>; | |
192 | ||
193 | # Does paragraph mode work? | |
194 | $/ = ''; | |
195 | $bar = <FH>; | |
196 | if ($bar ne "1234\n12345\n\n") {print "not ";} | |
197 | print "ok $test_count # \$/ = ''\n"; | |
198 | $test_count++; | |
199 | ||
200 | # Try slurping the rest of the file | |
201 | $/ = undef; | |
202 | $bar = <FH>; | |
203 | if ($bar ne "123456\n1234567\n") {print "not ";} | |
204 | print "ok $test_count # \$/ = undef\n"; | |
205 | $test_count++; | |
206 | } | |
207 | ||
208 | sub test_record { | |
209 | *FH = shift; | |
210 | ||
211 | # Test straight number | |
212 | $/ = \2; | |
213 | $bar = <FH>; | |
214 | if ($bar ne "12") {print "not ";} | |
215 | print "ok $test_count # \$/ = \\2\n"; | |
216 | $test_count++; | |
217 | ||
218 | # Test stringified number | |
219 | $/ = \"2"; | |
220 | $bar = <FH>; | |
221 | if ($bar ne "34") {print "not ";} | |
222 | print "ok $test_count # \$/ = \"2\"\n"; | |
223 | $test_count++; | |
224 | ||
225 | # Integer variable | |
226 | $foo = 2; | |
227 | $/ = \$foo; | |
228 | $bar = <FH>; | |
229 | if ($bar ne "56") {print "not ";} | |
230 | print "ok $test_count # \$/ = \\\$foo (\$foo = 2)\n"; | |
231 | $test_count++; | |
232 | ||
233 | # String variable | |
234 | $foo = "2"; | |
235 | $/ = \$foo; | |
236 | $bar = <FH>; | |
237 | if ($bar ne "78") {print "not ";} | |
238 | print "ok $test_count # \$/ = \\\$foo (\$foo = \"2\")\n"; | |
239 | $test_count++; | |
4dafff08 B |
240 | } |
241 | ||
1ab48e3a | 242 | sub test_bad_setting { |
520b6fb6 DIM |
243 | if (eval {$/ = \0; 1}) { |
244 | print "not ok ",$test_count++," # \$/ = \\0; should die\n"; | |
245 | print "not ok ",$test_count++," # \$/ = \\0; produced expected error message\n"; | |
246 | } else { | |
247 | my $msg= $@ || "Zombie Error"; | |
248 | print "ok ",$test_count++," # \$/ = \\0; should die\n"; | |
249 | if ($msg!~m!Setting \$\/ to a reference to zero is forbidden!) { | |
250 | print "not "; | |
251 | } | |
252 | print "ok ",$test_count++," # \$/ = \\0; produced expected error message\n"; | |
253 | } | |
254 | if (eval {$/ = \-1; 1}) { | |
255 | print "not ok ",$test_count++," # \$/ = \\-1; should die\n"; | |
256 | print "not ok ",$test_count++," # \$/ = \\-1; produced expected error message\n"; | |
257 | } else { | |
258 | my $msg= $@ || "Zombie Error"; | |
259 | print "ok ",$test_count++," # \$/ = \\-1; should die\n"; | |
260 | if ($msg!~m!Setting \$\/ to a reference to a negative integer is forbidden!) { | |
261 | print "not "; | |
262 | } | |
263 | print "ok ",$test_count++," # \$/ = \\-1; produced expected error message\n"; | |
264 | } | |
1ab48e3a YO |
265 | if (eval {$/ = []; 1}) { |
266 | print "not ok ",$test_count++," # \$/ = []; should die\n"; | |
267 | print "not ok ",$test_count++," # \$/ = []; produced expected error message\n"; | |
268 | } else { | |
269 | my $msg= $@ || "Zombie Error"; | |
270 | print "ok ",$test_count++," # \$/ = []; should die\n"; | |
a48e4205 FC |
271 | if ($msg!~m!Setting \$\/ to an ARRAY reference is forbidden!) { |
272 | print "not "; | |
273 | } | |
1ab48e3a YO |
274 | print "ok ",$test_count++," # \$/ = []; produced expected error message\n"; |
275 | } | |
276 | if (eval {$/ = {}; 1}) { | |
277 | print "not ok ",$test_count++," # \$/ = {}; should die\n"; | |
278 | print "not ok ",$test_count++," # \$/ = {}; produced expected error message\n"; | |
279 | } else { | |
280 | my $msg= $@ || "Zombie Error"; | |
281 | print "ok ",$test_count++," # \$/ = {}; should die\n"; | |
282 | if ($msg!~m!Setting \$\/ to a HASH reference is forbidden!) {print "not ";} | |
283 | print "ok ",$test_count++," # \$/ = {}; produced expected error message\n"; | |
284 | } | |
285 | if (eval {$/ = \\1; 1}) { | |
286 | print "not ok ",$test_count++," # \$/ = \\\\1; should die\n"; | |
287 | print "not ok ",$test_count++," # \$/ = \\\\1; produced expected error message\n"; | |
288 | } else { | |
289 | my $msg= $@ || "Zombie Error"; | |
290 | print "ok ",$test_count++," # \$/ = \\\\1; should die\n"; | |
291 | if ($msg!~m!Setting \$\/ to a REF reference is forbidden!) {print "not ";} | |
292 | print "ok ",$test_count++," # \$/ = \\\\1; produced expected error message\n"; | |
293 | } | |
294 | if (eval {$/ = qr/foo/; 1}) { | |
295 | print "not ok ",$test_count++," # \$/ = qr/foo/; should die\n"; | |
296 | print "not ok ",$test_count++," # \$/ = qr/foo/; produced expected error message\n"; | |
297 | } else { | |
298 | my $msg= $@ || "Zombie Error"; | |
299 | print "ok ",$test_count++," # \$/ = qr/foo/; should die\n"; | |
300 | if ($msg!~m!Setting \$\/ to a REGEXP reference is forbidden!) {print "not ";} | |
301 | print "ok ",$test_count++," # \$/ = qr/foo/; produced expected error message\n"; | |
302 | } | |
303 | if (eval {$/ = \*STDOUT; 1}) { | |
304 | print "not ok ",$test_count++," # \$/ = \\*STDOUT; should die\n"; | |
305 | print "not ok ",$test_count++," # \$/ = \\*STDOUT; produced expected error message\n"; | |
306 | } else { | |
307 | my $msg= $@ || "Zombie Error"; | |
308 | print "ok ",$test_count++," # \$/ = \\*STDOUT; should die\n"; | |
309 | if ($msg!~m!Setting \$\/ to a GLOB reference is forbidden!) {print "not ";} | |
310 | print "ok ",$test_count++," # \$/ = \\*STDOUT; produced expected error message\n"; | |
311 | } | |
312 | } |