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 # Test if a file in memory behaves the same as a real file (= re-run the test with a file in memory) 131 open TESTFILE, "<", \$teststring; 132 test_string(*TESTFILE); 133 close TESTFILE; 134 135 open TESTFILE, "<", \$teststring2; 136 test_record(*TESTFILE); 137 close TESTFILE; 138} 139 140# Get rid of the temp file 141END { unlink "./foo"; } 142 143sub test_string { 144 *FH = shift; 145 146 # Check the default $/ 147 $bar = <FH>; 148 if ($bar ne "1\n") {print "not ";} 149 print "ok $test_count # default \$/\n"; 150 $test_count++; 151 152 # explicitly set to \n 153 $/ = "\n"; 154 $bar = <FH>; 155 if ($bar ne "12\n") {print "not ";} 156 print "ok $test_count # \$/ = \"\\n\"\n"; 157 $test_count++; 158 159 # Try a non line terminator 160 $/ = 3; 161 $bar = <FH>; 162 if ($bar ne "123") {print "not ";} 163 print "ok $test_count # \$/ = 3\n"; 164 $test_count++; 165 166 # Eat the line terminator 167 $/ = "\n"; 168 $bar = <FH>; 169 170 # How about a larger terminator 171 $/ = "34"; 172 $bar = <FH>; 173 if ($bar ne "1234") {print "not ";} 174 print "ok $test_count # \$/ = \"34\"\n"; 175 $test_count++; 176 177 # Eat the line terminator 178 $/ = "\n"; 179 $bar = <FH>; 180 181 # Does paragraph mode work? 182 $/ = ''; 183 $bar = <FH>; 184 if ($bar ne "1234\n12345\n\n") {print "not ";} 185 print "ok $test_count # \$/ = ''\n"; 186 $test_count++; 187 188 # Try slurping the rest of the file 189 $/ = undef; 190 $bar = <FH>; 191 if ($bar ne "123456\n1234567\n") {print "not ";} 192 print "ok $test_count # \$/ = undef\n"; 193 $test_count++; 194} 195 196sub test_record { 197 *FH = shift; 198 199 # Test straight number 200 $/ = \2; 201 $bar = <FH>; 202 if ($bar ne "12") {print "not ";} 203 print "ok $test_count # \$/ = \\2\n"; 204 $test_count++; 205 206 # Test stringified number 207 $/ = \"2"; 208 $bar = <FH>; 209 if ($bar ne "34") {print "not ";} 210 print "ok $test_count # \$/ = \"2\"\n"; 211 $test_count++; 212 213 # Integer variable 214 $foo = 2; 215 $/ = \$foo; 216 $bar = <FH>; 217 if ($bar ne "56") {print "not ";} 218 print "ok $test_count # \$/ = \\\$foo (\$foo = 2)\n"; 219 $test_count++; 220 221 # String variable 222 $foo = "2"; 223 $/ = \$foo; 224 $bar = <FH>; 225 if ($bar ne "78") {print "not ";} 226 print "ok $test_count # \$/ = \\\$foo (\$foo = \"2\")\n"; 227 $test_count++; 228} 229 230sub test_bad_setting { 231 if (eval {$/ = \0; 1}) { 232 print "not ok ",$test_count++," # \$/ = \\0; should die\n"; 233 print "not ok ",$test_count++," # \$/ = \\0; produced expected error message\n"; 234 } else { 235 my $msg= $@ || "Zombie Error"; 236 print "ok ",$test_count++," # \$/ = \\0; should die\n"; 237 if ($msg!~m!Setting \$\/ to a reference to zero is forbidden!) { 238 print "not "; 239 } 240 print "ok ",$test_count++," # \$/ = \\0; produced expected error message\n"; 241 } 242 if (eval {$/ = \-1; 1}) { 243 print "not ok ",$test_count++," # \$/ = \\-1; should die\n"; 244 print "not ok ",$test_count++," # \$/ = \\-1; produced expected error message\n"; 245 } else { 246 my $msg= $@ || "Zombie Error"; 247 print "ok ",$test_count++," # \$/ = \\-1; should die\n"; 248 if ($msg!~m!Setting \$\/ to a reference to a negative integer is forbidden!) { 249 print "not "; 250 } 251 print "ok ",$test_count++," # \$/ = \\-1; produced expected error message\n"; 252 } 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