7 $teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n";
8 $teststring2 = "1234567890123456789012345678901234567890";
10 # Create our test datafile
11 1 while unlink 'foo'; # in case junk left around
13 open TESTFILE, ">./foo" or die "error $! $^E opening";
15 print TESTFILE $teststring;
16 close TESTFILE or die "error $! $^E closing";
18 $test_count_start = $test_count; # Needed to know how many tests to skip
19 open TESTFILE, "<./foo";
21 test_string(*TESTFILE);
25 # try the record reading tests. New file so we don't have to worry about
27 open TESTFILE, ">./foo";
28 print TESTFILE $teststring2;
31 open TESTFILE, "<./foo";
33 test_record(*TESTFILE);
35 $test_count_end = $test_count; # Needed to know how many tests to skip
38 my $note = "\$/ preserved when set to bad value";
39 # none of the setting of $/ to bad values should modify its value
41 print +($/ ne "\n" ? "not " : "") .
42 "ok $test_count # \$/ preserved when set to bad value\n";
45 # Now for the tricky bit--full record reading
47 # Create a temp file. We jump through these hoops 'cause CREATE really
48 # doesn't like our methods for some reason.
49 open FDLFILE, "> ./foo.fdl";
50 print FDLFILE "RECORD\n FORMAT VARIABLE\n";
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";
59 $throwaway = `\@\[\]foo`, "\n";
60 open(TEMPFILE, ">./foo.bar") or print "# open failed $! $^E\n";
61 print TEMPFILE "foo\nfoobar\nbaz\n";
64 open TESTFILE, "<./foo.bar";
67 if ($bar eq "foo\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";}
70 if ($bar eq "foobar\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";}
72 # can we do a short read?
75 if ($bar eq "ba") {print "ok $test_count\n";} else {print "not ok $test_count\n";}
77 # do we get the rest of the record?
79 if ($bar eq "z\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";}
83 1 while unlink qw(foo.bar foo.com foo.fdl);
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
87 foreach $test ($test_count..$test_count + 3) {
88 print "ok $test # skipped on non-VMS system\n";
95 # see if open/readline/close work on our and my variables
97 if (open our $T, "./foo") {
100 length($line) == 40 or print "not ";
101 close $T or print "not ";
106 print "ok $test_count # open/readline/close on our variable\n";
111 if (open my $T, "./foo") {
114 length($line) == 40 or print "not ";
115 close $T or print "not ";
120 print "ok $test_count # open/readline/close on my variable\n";
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);
130 if (not eval q/use PerlIO::scalar; 1/) {
131 # In-memory files necessitate PerlIO::scalar, thus a perl with
132 # perlio and dynaloading enabled. miniperl won't be able to run this
135 for $test ($test_count .. $test_count + ($test_count_end - $test_count_start - 1)) {
136 print "ok $test # skipped - Can't test in memory file with miniperl/without PerlIO::Scalar\n";
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);
146 open TESTFILE, "<", \$teststring2;
147 test_record(*TESTFILE);
152 # Get rid of the temp file
153 END { unlink "./foo"; }
158 # Check the default $/
160 if ($bar ne "1\n") {print "not ";}
161 print "ok $test_count # default \$/\n";
164 # explicitly set to \n
167 if ($bar ne "12\n") {print "not ";}
168 print "ok $test_count # \$/ = \"\\n\"\n";
171 # Try a non line terminator
174 if ($bar ne "123") {print "not ";}
175 print "ok $test_count # \$/ = 3\n";
178 # Eat the line terminator
182 # How about a larger terminator
185 if ($bar ne "1234") {print "not ";}
186 print "ok $test_count # \$/ = \"34\"\n";
189 # Eat the line terminator
193 # Does paragraph mode work?
196 if ($bar ne "1234\n12345\n\n") {print "not ";}
197 print "ok $test_count # \$/ = ''\n";
200 # Try slurping the rest of the file
203 if ($bar ne "123456\n1234567\n") {print "not ";}
204 print "ok $test_count # \$/ = undef\n";
211 # Test straight number
214 if ($bar ne "12") {print "not ";}
215 print "ok $test_count # \$/ = \\2\n";
218 # Test stringified number
221 if ($bar ne "34") {print "not ";}
222 print "ok $test_count # \$/ = \"2\"\n";
229 if ($bar ne "56") {print "not ";}
230 print "ok $test_count # \$/ = \\\$foo (\$foo = 2)\n";
237 if ($bar ne "78") {print "not ";}
238 print "ok $test_count # \$/ = \\\$foo (\$foo = \"2\")\n";
242 sub test_bad_setting {
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";
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!) {
252 print "ok ",$test_count++," # \$/ = \\0; produced expected error message\n";
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";
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!) {
263 print "ok ",$test_count++," # \$/ = \\-1; produced expected error message\n";
265 if (eval {$/ = []; 1}) {
266 print "not ok ",$test_count++," # \$/ = []; should die\n";
267 print "not ok ",$test_count++," # \$/ = []; produced expected error message\n";
269 my $msg= $@ || "Zombie Error";
270 print "ok ",$test_count++," # \$/ = []; should die\n";
271 if ($msg!~m!Setting \$\/ to an ARRAY reference is forbidden!) {
274 print "ok ",$test_count++," # \$/ = []; produced expected error message\n";
276 if (eval {$/ = {}; 1}) {
277 print "not ok ",$test_count++," # \$/ = {}; should die\n";
278 print "not ok ",$test_count++," # \$/ = {}; produced expected error message\n";
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";
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";
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";
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";
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";
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";
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";