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