1#!./perl 2# Test $/ 3 4print "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 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; 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 153END { unlink "./foo"; } 154 155sub 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 208sub 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 242sub 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} 313