rs.t revision 1.2 
1#!./perl
2# Test $/
3
4print "1..39\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
111 while unlink 'foo';                # in case junk left around
12rmdir 'foo';
13open TESTFILE, ">./foo" or die "error $! $^E opening";
14binmode TESTFILE;
15print TESTFILE $teststring;
16close TESTFILE or die "error $! $^E closing";
17
18$test_count_start = $test_count;  # Needed to know how many tests to skip
19open TESTFILE, "<./foo";
20binmode TESTFILE;
21test_string(*TESTFILE);
22close TESTFILE;
23unlink "./foo";
24
25# try the record reading tests. New file so we don't have to worry about
26# the size of \n.
27open TESTFILE, ">./foo";
28print TESTFILE $teststring2;
29binmode TESTFILE;
30close TESTFILE;
31open TESTFILE, "<./foo";
32binmode TESTFILE;
33test_record(*TESTFILE);
34close TESTFILE;
35$test_count_end = $test_count;  # Needed to know how many tests to skip
36
37$/ = "\n";
38my $note = "\$/ preserved when set to bad value";
39# none of the setting of $/ to bad values should modify its value
40test_bad_setting();
41print +($/ 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
46if ($^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; use PerlIO::via::scalar; 1/) {
131  # In-memory files necessitate PerlIO::via::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  # PerlIO::via::scalar has to be tested as well.
136  # use PerlIO::scalar succeeds with ./TEST and with ./perl harness but not with ./perl
137
138  for $test ($test_count .. $test_count + ($test_count_end - $test_count_start - 1)) {
139    print "ok $test # skipped - Can't test in memory file with miniperl/without PerlIO::Scalar\n";
140    $test_count++;
141  }
142 }
143 else {
144  # Test if a file in memory behaves the same as a real file (= re-run the test with a file in memory)
145  open TESTFILE, "<", \$teststring;
146  test_string(*TESTFILE);
147  close TESTFILE;
148
149  open TESTFILE, "<", \$teststring2;
150  test_record(*TESTFILE);
151  close TESTFILE;
152 }
153}
154
155# Get rid of the temp file
156END { unlink "./foo"; }
157
158sub test_string {
159  *FH = shift;
160
161  # Check the default $/
162  $bar = <FH>;
163  if ($bar ne "1\n") {print "not ";}
164  print "ok $test_count # default \$/\n";
165  $test_count++;
166
167  # explicitly set to \n
168  $/ = "\n";
169  $bar = <FH>;
170  if ($bar ne "12\n") {print "not ";}
171  print "ok $test_count # \$/ = \"\\n\"\n";
172  $test_count++;
173
174  # Try a non line terminator
175  $/ = 3;
176  $bar = <FH>;
177  if ($bar ne "123") {print "not ";}
178  print "ok $test_count # \$/ = 3\n";
179  $test_count++;
180
181  # Eat the line terminator
182  $/ = "\n";
183  $bar = <FH>;
184
185  # How about a larger terminator
186  $/ = "34";
187  $bar = <FH>;
188  if ($bar ne "1234") {print "not ";}
189  print "ok $test_count # \$/ = \"34\"\n";
190  $test_count++;
191
192  # Eat the line terminator
193  $/ = "\n";
194  $bar = <FH>;
195
196  # Does paragraph mode work?
197  $/ = '';
198  $bar = <FH>;
199  if ($bar ne "1234\n12345\n\n") {print "not ";}
200  print "ok $test_count # \$/ = ''\n";
201  $test_count++;
202
203  # Try slurping the rest of the file
204  $/ = undef;
205  $bar = <FH>;
206  if ($bar ne "123456\n1234567\n") {print "not ";}
207  print "ok $test_count # \$/ = undef\n";
208  $test_count++;
209}
210
211sub test_record {
212  *FH = shift;
213
214  # Test straight number
215  $/ = \2;
216  $bar = <FH>;
217  if ($bar ne "12") {print "not ";}
218  print "ok $test_count # \$/ = \\2\n";
219  $test_count++;
220
221  # Test stringified number
222  $/ = \"2";
223  $bar = <FH>;
224  if ($bar ne "34") {print "not ";}
225  print "ok $test_count # \$/ = \"2\"\n";
226  $test_count++;
227
228  # Integer variable
229  $foo = 2;
230  $/ = \$foo;
231  $bar = <FH>;
232  if ($bar ne "56") {print "not ";}
233  print "ok $test_count # \$/ = \\\$foo (\$foo = 2)\n";
234  $test_count++;
235
236  # String variable
237  $foo = "2";
238  $/ = \$foo;
239  $bar = <FH>;
240  if ($bar ne "78") {print "not ";}
241  print "ok $test_count # \$/ = \\\$foo (\$foo = \"2\")\n";
242  $test_count++;
243
244  # Naughty straight number - should get the rest of the file
245  $/ = \0;
246  $bar = <FH>;
247  if ($bar ne "90123456789012345678901234567890") {print "not ";}
248  print "ok $test_count # \$/ = \\0\n";
249  $test_count++;
250}
251
252sub test_bad_setting {
253  if (eval {$/ = []; 1}) {
254    print "not ok ",$test_count++," # \$/ = []; should die\n";
255    print "not ok ",$test_count++," # \$/ = []; produced expected error message\n";
256  } else {
257    my $msg= $@ || "Zombie Error";
258    print "ok ",$test_count++," # \$/ = []; should die\n";
259    if ($msg!~m!Setting \$\/ to an ARRAY reference is forbidden!) {
260      print "not ";
261    }
262    print "ok ",$test_count++," # \$/ = []; produced expected error message\n";
263  }
264  if (eval {$/ = {}; 1}) {
265    print "not ok ",$test_count++," # \$/ = {}; should die\n";
266    print "not ok ",$test_count++," # \$/ = {}; produced expected error message\n";
267  } else {
268    my $msg= $@ || "Zombie Error";
269    print "ok ",$test_count++," # \$/ = {}; should die\n";
270    if ($msg!~m!Setting \$\/ to a HASH reference is forbidden!) {print "not ";}
271    print "ok ",$test_count++," # \$/ = {}; produced expected error message\n";
272  }
273  if (eval {$/ = \\1; 1}) {
274    print "not ok ",$test_count++," # \$/ = \\\\1; should die\n";
275    print "not ok ",$test_count++," # \$/ = \\\\1; produced expected error message\n";
276  } else {
277    my $msg= $@ || "Zombie Error";
278    print "ok ",$test_count++," # \$/ = \\\\1; should die\n";
279    if ($msg!~m!Setting \$\/ to a REF reference is forbidden!) {print "not ";}
280    print "ok ",$test_count++," # \$/ = \\\\1; produced expected error message\n";
281  }
282  if (eval {$/ = qr/foo/; 1}) {
283    print "not ok ",$test_count++," # \$/ = qr/foo/; should die\n";
284    print "not ok ",$test_count++," # \$/ = qr/foo/; produced expected error message\n";
285  } else {
286    my $msg= $@ || "Zombie Error";
287    print "ok ",$test_count++," # \$/ = qr/foo/; should die\n";
288    if ($msg!~m!Setting \$\/ to a REGEXP reference is forbidden!) {print "not ";}
289    print "ok ",$test_count++," # \$/ = qr/foo/; produced expected error message\n";
290  }
291  if (eval {$/ = \*STDOUT; 1}) {
292    print "not ok ",$test_count++," # \$/ = \\*STDOUT; should die\n";
293    print "not ok ",$test_count++," # \$/ = \\*STDOUT; produced expected error message\n";
294  } else {
295    my $msg= $@ || "Zombie Error";
296    print "ok ",$test_count++," # \$/ = \\*STDOUT; should die\n";
297    if ($msg!~m!Setting \$\/ to a GLOB reference is forbidden!) {print "not ";}
298    print "ok ",$test_count++," # \$/ = \\*STDOUT; produced expected error message\n";
299  }
300}
301