Skip multideref for PL_check[OP_HELEM] tinkering
[perl.git] / t / base / rs.t
1 #!./perl
2 # Test $!
3
4 print "1..38\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 test_bad_setting();
38
39
40 # Now for the tricky bit--full record reading
41 if ($^O eq 'VMS') {
42   # Create a temp file. We jump through these hoops 'cause CREATE really
43   # doesn't like our methods for some reason.
44   open FDLFILE, "> ./foo.fdl";
45   print FDLFILE "RECORD\n FORMAT VARIABLE\n";
46   close FDLFILE;
47   open CREATEFILE, "> ./foo.com";
48   print CREATEFILE '$ DEFINE/USER SYS$INPUT NL:', "\n";
49   print CREATEFILE '$ DEFINE/USER SYS$OUTPUT NL:', "\n";
50   print CREATEFILE '$ OPEN YOW []FOO.BAR/WRITE', "\n";
51   print CREATEFILE '$ CLOSE YOW', "\n";
52   print CREATEFILE "\$EXIT\n";
53   close CREATEFILE;
54   $throwaway = `\@\[\]foo`, "\n";
55   open(TEMPFILE, ">./foo.bar") or print "# open failed $! $^E\n";
56   print TEMPFILE "foo\nfoobar\nbaz\n";
57   close TEMPFILE;
58
59   open TESTFILE, "<./foo.bar";
60   $/ = \10;
61   $bar = <TESTFILE>;
62   if ($bar eq "foo\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";}
63   $test_count++;
64   $bar = <TESTFILE>;
65   if ($bar eq "foobar\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";}
66   $test_count++;
67   # can we do a short read?
68   $/ = \2;
69   $bar = <TESTFILE>;
70   if ($bar eq "ba") {print "ok $test_count\n";} else {print "not ok $test_count\n";}
71   $test_count++;
72   # do we get the rest of the record?
73   $bar = <TESTFILE>;
74   if ($bar eq "z\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";}
75   $test_count++;
76
77   close TESTFILE;
78   1 while unlink qw(foo.bar foo.com foo.fdl);
79 } else {
80   # Nobody else does this at the moment (well, maybe OS/390, but they can
81   # put their own tests in) so we just punt
82   foreach $test ($test_count..$test_count + 3) {
83       print "ok $test # skipped on non-VMS system\n";
84       $test_count++;
85   }
86 }
87
88 $/ = "\n";
89
90 # see if open/readline/close work on our and my variables
91 {
92     if (open our $T, "./foo") {
93         my $line = <$T>;
94         print "# $line\n";
95         length($line) == 40 or print "not ";
96         close $T or print "not ";
97     }
98     else {
99         print "not ";
100     }
101     print "ok $test_count # open/readline/close on our variable\n";
102     $test_count++;
103 }
104
105 {
106     if (open my $T, "./foo") {
107         my $line = <$T>;
108         print "# $line\n";
109         length($line) == 40 or print "not ";
110         close $T or print "not ";
111     }
112     else {
113         print "not ";
114     }
115     print "ok $test_count # open/readline/close on my variable\n";
116     $test_count++;
117 }
118
119
120 {
121  # If we do not include the lib directories, we may end up picking up a
122  # binary-incompatible previously-installed version. The eval won’t help in
123  # intercepting a SIGTRAP.
124  local @INC = ("../lib", "lib", @INC);
125  if (not eval q/use PerelIO::scalar; 1/) {
126   # In-memory files necessitate PerlIO::scalar, thus a perl with
127   # perlio and dynaloading enabled. miniperl won't be able to run this
128   # test, so skip it
129
130   for $test ($test_count .. $test_count + ($test_count_end - $test_count_start - 1)) {
131     print "ok $test # skipped - Can't test in memory file with miniperl/without PerlIO::Scalar\n";
132     $test_count++;
133   }
134  }
135  else {
136   # Test if a file in memory behaves the same as a real file (= re-run the test with a file in memory)
137   open TESTFILE, "<", \$teststring;
138   test_string(*TESTFILE);
139   close TESTFILE;
140
141   open TESTFILE, "<", \$teststring2;
142   test_record(*TESTFILE);
143   close TESTFILE;
144  }
145 }
146
147 # Get rid of the temp file
148 END { unlink "./foo"; }
149
150 sub test_string {
151   *FH = shift;
152
153   # Check the default $/
154   $bar = <FH>;
155   if ($bar ne "1\n") {print "not ";}
156   print "ok $test_count # default \$/\n";
157   $test_count++;
158
159   # explicitly set to \n
160   $/ = "\n";
161   $bar = <FH>;
162   if ($bar ne "12\n") {print "not ";}
163   print "ok $test_count # \$/ = \"\\n\"\n";
164   $test_count++;
165
166   # Try a non line terminator
167   $/ = 3;
168   $bar = <FH>;
169   if ($bar ne "123") {print "not ";}
170   print "ok $test_count # \$/ = 3\n";
171   $test_count++;
172
173   # Eat the line terminator
174   $/ = "\n";
175   $bar = <FH>;
176
177   # How about a larger terminator
178   $/ = "34";
179   $bar = <FH>;
180   if ($bar ne "1234") {print "not ";}
181   print "ok $test_count # \$/ = \"34\"\n";
182   $test_count++;
183
184   # Eat the line terminator
185   $/ = "\n";
186   $bar = <FH>;
187
188   # Does paragraph mode work?
189   $/ = '';
190   $bar = <FH>;
191   if ($bar ne "1234\n12345\n\n") {print "not ";}
192   print "ok $test_count # \$/ = ''\n";
193   $test_count++;
194
195   # Try slurping the rest of the file
196   $/ = undef;
197   $bar = <FH>;
198   if ($bar ne "123456\n1234567\n") {print "not ";}
199   print "ok $test_count # \$/ = undef\n";
200   $test_count++;
201 }
202
203 sub test_record {
204   *FH = shift;
205
206   # Test straight number
207   $/ = \2;
208   $bar = <FH>;
209   if ($bar ne "12") {print "not ";}
210   print "ok $test_count # \$/ = \\2\n";
211   $test_count++;
212
213   # Test stringified number
214   $/ = \"2";
215   $bar = <FH>;
216   if ($bar ne "34") {print "not ";}
217   print "ok $test_count # \$/ = \"2\"\n";
218   $test_count++;
219
220   # Integer variable
221   $foo = 2;
222   $/ = \$foo;
223   $bar = <FH>;
224   if ($bar ne "56") {print "not ";}
225   print "ok $test_count # \$/ = \\\$foo (\$foo = 2)\n";
226   $test_count++;
227
228   # String variable
229   $foo = "2";
230   $/ = \$foo;
231   $bar = <FH>;
232   if ($bar ne "78") {print "not ";}
233   print "ok $test_count # \$/ = \\\$foo (\$foo = \"2\")\n";
234   $test_count++;
235
236   # Naughty straight number - should get the rest of the file
237   # no warnings 'deprecated'; # but not in t/base/*
238   { local $SIG{__WARN__} = sub {}; $/ = \0 }
239   $bar = <FH>;
240   if ($bar ne "90123456789012345678901234567890") {print "not ";}
241   print "ok $test_count # \$/ = \\0\n";
242   $test_count++;
243 }
244
245 sub test_bad_setting {
246   if (eval {$/ = []; 1}) {
247     print "not ok ",$test_count++," # \$/ = []; should die\n";
248     print "not ok ",$test_count++," # \$/ = []; produced expected error message\n";
249   } else {
250     my $msg= $@ || "Zombie Error";
251     print "ok ",$test_count++," # \$/ = []; should die\n";
252     if ($msg!~m!Setting \$\/ to an ARRAY reference is forbidden!) {
253       print "not ";
254     }
255     print "ok ",$test_count++," # \$/ = []; produced expected error message\n";
256   }
257   if (eval {$/ = {}; 1}) {
258     print "not ok ",$test_count++," # \$/ = {}; should die\n";
259     print "not ok ",$test_count++," # \$/ = {}; produced expected error message\n";
260   } else {
261     my $msg= $@ || "Zombie Error";
262     print "ok ",$test_count++," # \$/ = {}; should die\n";
263     if ($msg!~m!Setting \$\/ to a HASH reference is forbidden!) {print "not ";}
264     print "ok ",$test_count++," # \$/ = {}; produced expected error message\n";
265   }
266   if (eval {$/ = \\1; 1}) {
267     print "not ok ",$test_count++," # \$/ = \\\\1; should die\n";
268     print "not ok ",$test_count++," # \$/ = \\\\1; produced expected error message\n";
269   } else {
270     my $msg= $@ || "Zombie Error";
271     print "ok ",$test_count++," # \$/ = \\\\1; should die\n";
272     if ($msg!~m!Setting \$\/ to a REF reference is forbidden!) {print "not ";}
273     print "ok ",$test_count++," # \$/ = \\\\1; produced expected error message\n";
274   }
275   if (eval {$/ = qr/foo/; 1}) {
276     print "not ok ",$test_count++," # \$/ = qr/foo/; should die\n";
277     print "not ok ",$test_count++," # \$/ = qr/foo/; produced expected error message\n";
278   } else {
279     my $msg= $@ || "Zombie Error";
280     print "ok ",$test_count++," # \$/ = qr/foo/; should die\n";
281     if ($msg!~m!Setting \$\/ to a REGEXP reference is forbidden!) {print "not ";}
282     print "ok ",$test_count++," # \$/ = qr/foo/; produced expected error message\n";
283   }
284   if (eval {$/ = \*STDOUT; 1}) {
285     print "not ok ",$test_count++," # \$/ = \\*STDOUT; should die\n";
286     print "not ok ",$test_count++," # \$/ = \\*STDOUT; produced expected error message\n";
287   } else {
288     my $msg= $@ || "Zombie Error";
289     print "ok ",$test_count++," # \$/ = \\*STDOUT; should die\n";
290     if ($msg!~m!Setting \$\/ to a GLOB reference is forbidden!) {print "not ";}
291     print "ok ",$test_count++," # \$/ = \\*STDOUT; produced expected error message\n";
292   }
293 }