1#!./perl 2# Test $! 3 4print "1..28\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 38# Now for the tricky bit--full record reading 39if ($^O eq 'VMS') { 40 # Create a temp file. We jump through these hoops 'cause CREATE really 41 # doesn't like our methods for some reason. 42 open FDLFILE, "> ./foo.fdl"; 43 print FDLFILE "RECORD\n FORMAT VARIABLE\n"; 44 close FDLFILE; 45 open CREATEFILE, "> ./foo.com"; 46 print CREATEFILE '$ DEFINE/USER SYS$INPUT NL:', "\n"; 47 print CREATEFILE '$ DEFINE/USER SYS$OUTPUT NL:', "\n"; 48 print CREATEFILE '$ OPEN YOW []FOO.BAR/WRITE', "\n"; 49 print CREATEFILE '$ CLOSE YOW', "\n"; 50 print CREATEFILE "\$EXIT\n"; 51 close CREATEFILE; 52 $throwaway = `\@\[\]foo`, "\n"; 53 open(TEMPFILE, ">./foo.bar") or print "# open failed $! $^E\n"; 54 print TEMPFILE "foo\nfoobar\nbaz\n"; 55 close TEMPFILE; 56 57 open TESTFILE, "<./foo.bar"; 58 $/ = \10; 59 $bar = <TESTFILE>; 60 if ($bar eq "foo\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";} 61 $test_count++; 62 $bar = <TESTFILE>; 63 if ($bar eq "foobar\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";} 64 $test_count++; 65 # can we do a short read? 66 $/ = \2; 67 $bar = <TESTFILE>; 68 if ($bar eq "ba") {print "ok $test_count\n";} else {print "not ok $test_count\n";} 69 $test_count++; 70 # do we get the rest of the record? 71 $bar = <TESTFILE>; 72 if ($bar eq "z\n") {print "ok $test_count\n";} else {print "not ok $test_count\n";} 73 $test_count++; 74 75 close TESTFILE; 76 1 while unlink qw(foo.bar foo.com foo.fdl); 77} else { 78 # Nobody else does this at the moment (well, maybe OS/390, but they can 79 # put their own tests in) so we just punt 80 foreach $test ($test_count..$test_count + 3) { 81 print "ok $test # skipped on non-VMS system\n"; 82 $test_count++; 83 } 84} 85 86$/ = "\n"; 87 88# see if open/readline/close work on our and my variables 89{ 90 if (open our $T, "./foo") { 91 my $line = <$T>; 92 print "# $line\n"; 93 length($line) == 40 or print "not "; 94 close $T or print "not "; 95 } 96 else { 97 print "not "; 98 } 99 print "ok $test_count # open/readline/close on our variable\n"; 100 $test_count++; 101} 102 103{ 104 if (open my $T, "./foo") { 105 my $line = <$T>; 106 print "# $line\n"; 107 length($line) == 40 or print "not "; 108 close $T or print "not "; 109 } 110 else { 111 print "not "; 112 } 113 print "ok $test_count # open/readline/close on my variable\n"; 114 $test_count++; 115} 116 117 118if (not eval q/use PerlIO::scalar; use PerlIO::via::scalar; 1/) { 119 # In-memory files necessitate PerlIO::via::scalar, thus a perl with 120 # perlio and dynaloading enabled. miniperl won't be able to run this 121 # test, so skip it 122 123 # PerlIO::via::scalar has to be tested as well. 124 # use PerlIO::scalar succeeds with ./TEST and with ./perl harness but not with ./perl 125 126 for $test ($test_count .. $test_count + ($test_count_end - $test_count_start - 1)) { 127 print "ok $test # skipped - Can't test in memory file with miniperl/without PerlIO::Scalar\n"; 128 $test_count++; 129 } 130} 131else { 132 # Test if a file in memory behaves the same as a real file (= re-run the test with a file in memory) 133 open TESTFILE, "<", \$teststring; 134 test_string(*TESTFILE); 135 close TESTFILE; 136 137 open TESTFILE, "<", \$teststring2; 138 test_record(*TESTFILE); 139 close TESTFILE; 140} 141 142# Get rid of the temp file 143END { unlink "./foo"; } 144 145sub test_string { 146 *FH = shift; 147 148 # Check the default $/ 149 $bar = <FH>; 150 if ($bar ne "1\n") {print "not ";} 151 print "ok $test_count # default \$/\n"; 152 $test_count++; 153 154 # explicitly set to \n 155 $/ = "\n"; 156 $bar = <FH>; 157 if ($bar ne "12\n") {print "not ";} 158 print "ok $test_count # \$/ = \"\\n\"\n"; 159 $test_count++; 160 161 # Try a non line terminator 162 $/ = 3; 163 $bar = <FH>; 164 if ($bar ne "123") {print "not ";} 165 print "ok $test_count # \$/ = 3\n"; 166 $test_count++; 167 168 # Eat the line terminator 169 $/ = "\n"; 170 $bar = <FH>; 171 172 # How about a larger terminator 173 $/ = "34"; 174 $bar = <FH>; 175 if ($bar ne "1234") {print "not ";} 176 print "ok $test_count # \$/ = \"34\"\n"; 177 $test_count++; 178 179 # Eat the line terminator 180 $/ = "\n"; 181 $bar = <FH>; 182 183 # Does paragraph mode work? 184 $/ = ''; 185 $bar = <FH>; 186 if ($bar ne "1234\n12345\n\n") {print "not ";} 187 print "ok $test_count # \$/ = ''\n"; 188 $test_count++; 189 190 # Try slurping the rest of the file 191 $/ = undef; 192 $bar = <FH>; 193 if ($bar ne "123456\n1234567\n") {print "not ";} 194 print "ok $test_count # \$/ = undef\n"; 195 $test_count++; 196} 197 198sub test_record { 199 *FH = shift; 200 201 # Test straight number 202 $/ = \2; 203 $bar = <FH>; 204 if ($bar ne "12") {print "not ";} 205 print "ok $test_count # \$/ = \\2\n"; 206 $test_count++; 207 208 # Test stringified number 209 $/ = \"2"; 210 $bar = <FH>; 211 if ($bar ne "34") {print "not ";} 212 print "ok $test_count # \$/ = \"2\"\n"; 213 $test_count++; 214 215 # Integer variable 216 $foo = 2; 217 $/ = \$foo; 218 $bar = <FH>; 219 if ($bar ne "56") {print "not ";} 220 print "ok $test_count # \$/ = \\\$foo (\$foo = 2)\n"; 221 $test_count++; 222 223 # String variable 224 $foo = "2"; 225 $/ = \$foo; 226 $bar = <FH>; 227 if ($bar ne "78") {print "not ";} 228 print "ok $test_count # \$/ = \\\$foo (\$foo = \"2\")\n"; 229 $test_count++; 230 231 # Naughty straight number - should get the rest of the file 232 $/ = \0; 233 $bar = <FH>; 234 if ($bar ne "90123456789012345678901234567890") {print "not ";} 235 print "ok $test_count # \$/ = \\0\n"; 236 $test_count++; 237} 238 239