This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Use ‘an’ for $/=[] error message
[perl5.git] / t / base / rs.t
CommitLineData
5b2b9c68
HM
1#!./perl
2# Test $!
3
1ab48e3a 4print "1..48\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
111 while unlink 'foo'; # in case junk left around
12rmdir 'foo';
5b2b9c68
HM
13open TESTFILE, ">./foo" or die "error $! $^E opening";
14binmode TESTFILE;
15print TESTFILE $teststring;
a3b148a7 16close 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
19open TESTFILE, "<./foo";
20binmode TESTFILE;
4dafff08
B
21test_string(*TESTFILE);
22close TESTFILE;
23unlink "./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 27open TESTFILE, ">./foo";
4dafff08 28print TESTFILE $teststring2;
5b2b9c68
HM
29binmode TESTFILE;
30close TESTFILE;
31open TESTFILE, "<./foo";
32binmode TESTFILE;
4dafff08 33test_record(*TESTFILE);
7120fed6 34close TESTFILE;
1ab48e3a 35test_bad_setting();
4dafff08
B
36$test_count_end = $test_count; # Needed to know how many tests to skip
37
5b2b9c68
HM
38
39# Now for the tricky bit--full record reading
40if ($^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.
439f5715
GS
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";
5b2b9c68
HM
55 print TEMPFILE "foo\nfoobar\nbaz\n";
56 close TEMPFILE;
5b2b9c68
HM
57
58 open TESTFILE, "<./foo.bar";
59 $/ = \10;
60 $bar = <TESTFILE>;
4dafff08
B
61 if ($bar eq "foo\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";}
62 $test_count++;
5b2b9c68 63 $bar = <TESTFILE>;
4dafff08
B
64 if ($bar eq "foobar\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";}
65 $test_count++;
5b2b9c68
HM
66 # can we do a short read?
67 $/ = \2;
68 $bar = <TESTFILE>;
4dafff08
B
69 if ($bar eq "ba") {print "ok $test_count\n";} else {print "not ok $test_count\n";}
70 $test_count++;
5b2b9c68
HM
71 # do we get the rest of the record?
72 $bar = <TESTFILE>;
4dafff08
B
73 if ($bar eq "z\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";}
74 $test_count++;
5b2b9c68 75
7120fed6 76 close TESTFILE;
1f47e8e2 77 1 while unlink qw(foo.bar foo.com foo.fdl);
5b2b9c68
HM
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
4dafff08
B
81 foreach $test ($test_count..$test_count + 3) {
82 print "ok $test # skipped on non-VMS system\n";
83 $test_count++;
84 }
5b2b9c68 85}
f558d5af
JH
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 }
4dafff08
B
100 print "ok $test_count # open/readline/close on our variable\n";
101 $test_count++;
f558d5af
JH
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 }
4dafff08
B
114 print "ok $test_count # open/readline/close on my variable\n";
115 $test_count++;
116}
117
118
20c00210
FC
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/) {
4dafff08
B
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
cd1a9f55
B
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
4dafff08 132 for $test ($test_count .. $test_count + ($test_count_end - $test_count_start - 1)) {
24ead163 133 print "ok $test # skipped - Can't test in memory file with miniperl/without PerlIO::Scalar\n";
4dafff08
B
134 $test_count++;
135 }
20c00210
FC
136 }
137 else {
4dafff08
B
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;
20c00210 146 }
f558d5af
JH
147}
148
149# Get rid of the temp file
150END { unlink "./foo"; }
4dafff08
B
151
152sub 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
205sub 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
1ab48e3a
YO
246sub 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";
a48e4205
FC
253 if ($msg!~m!Setting \$\/ to an ARRAY reference is forbidden!) {
254 print "not ";
255 }
1ab48e3a
YO
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}