fix Storable test for pre-5.19.2 threaded perls
[perl.git] / t / base / rs.t
1 #!./perl
2 # Test $/
3
4 print "1..41\n";
5
6 $test_count = 1;
7 $teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n";
8 $teststring2 = "1234567890123456789012345678901234567890";
9
10 # Create our test datafile
11 1 while unlink 'foo';                # in case junk left around
12 rmdir 'foo';
13 open TESTFILE, ">./foo" or die "error $! $^E opening";
14 binmode TESTFILE;
15 print TESTFILE $teststring;
16 close TESTFILE or die "error $! $^E closing";
17
18 $test_count_start = $test_count;  # Needed to know how many tests to skip
19 open TESTFILE, "<./foo";
20 binmode TESTFILE;
21 test_string(*TESTFILE);
22 close TESTFILE;
23 unlink "./foo";
24
25 # try the record reading tests. New file so we don't have to worry about
26 # the size of \n.
27 open TESTFILE, ">./foo";
28 print TESTFILE $teststring2;
29 binmode TESTFILE;
30 close TESTFILE;
31 open TESTFILE, "<./foo";
32 binmode TESTFILE;
33 test_record(*TESTFILE);
34 close TESTFILE;
35 $test_count_end = $test_count;  # Needed to know how many tests to skip
36
37 $/ = "\n";
38 my $note = "\$/ preserved when set to bad value";
39 # none of the setting of $/ to bad values should modify its value
40 test_bad_setting();
41 print +($/ ne "\n" ? "not " : "") .
42   "ok $test_count # \$/ preserved when set to bad value\n";
43 ++$test_count;
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.
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";
61   print TEMPFILE "foo\nfoobar\nbaz\n";
62   close TEMPFILE;
63
64   open TESTFILE, "<./foo.bar";
65   $/ = \10;
66   $bar = <TESTFILE>;
67   if ($bar eq "foo\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";}
68   $test_count++;
69   $bar = <TESTFILE>;
70   if ($bar eq "foobar\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";}
71   $test_count++;
72   # can we do a short read?
73   $/ = \2;
74   $bar = <TESTFILE>;
75   if ($bar eq "ba") {print "ok $test_count\n";} else {print "not ok $test_count\n";}
76   $test_count++;
77   # do we get the rest of the record?
78   $bar = <TESTFILE>;
79   if ($bar eq "z\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";}
80   $test_count++;
81
82   close TESTFILE;
83   1 while unlink qw(foo.bar foo.com foo.fdl);
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
87   foreach $test ($test_count..$test_count + 3) {
88       print "ok $test # skipped on non-VMS system\n";
89       $test_count++;
90   }
91 }
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     }
106     print "ok $test_count # open/readline/close on our variable\n";
107     $test_count++;
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     }
120     print "ok $test_count # open/readline/close on my variable\n";
121     $test_count++;
122 }
123
124
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);
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
133   # test, so skip it
134
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";
137     $test_count++;
138   }
139  }
140  else {
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;
149  }
150 }
151
152 # Get rid of the temp file
153 END { unlink "./foo"; }
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++;
240 }
241
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";
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   }
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";
271     if ($msg!~m!Setting \$\/ to an ARRAY reference is forbidden!) {
272       print "not ";
273     }
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 }