t/base/rs.t

   1 #!./perl
   2 # Test $!
   3
   4 print "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
  11 1 while unlink 'foo';                # in case junk left around
  12 rmdir 'foo';
  13 open TESTFILE, ">./foo" or die "error $! $^E opening";
  14 binmode TESTFILE;
  15 print TESTFILE $teststring;
  16 close TESTFILE or die "error $! $^E closing";
  17
  18 $test_count_start = $test_count;  # Needed to know how many tests to skip
  19 open TESTFILE, "<./foo";
  20 binmode TESTFILE;
  21 test_string(*TESTFILE);
  22 close TESTFILE;
  23 unlink "./foo";
  24
  25 # try the record reading tests. New file so we don't have to worry about
  26 # the size of \n.
  27 open TESTFILE, ">./foo";
  28 print TESTFILE $teststring2;
  29 binmode TESTFILE;
  30 close TESTFILE;
  31 open TESTFILE, "<./foo";
  32 binmode TESTFILE;
  33 test_record(*TESTFILE);
  34 close 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
  39 if ($^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
 118 {
 119  # If we do not include the lib directories, we may end up picking up a
 120  # binary-incompatible previously-installed version. The eval won’t help in
 121  # intercepting a SIGTRAP.
 122  local @INC = ("../lib", "lib", @INC);
 123  if (not eval q/use PerlIO::scalar; use PerlIO::via::scalar; 1/) {
 124   # In-memory files necessitate PerlIO::via::scalar, thus a perl with
 125   # perlio and dynaloading enabled. miniperl won't be able to run this
 126   # test, so skip it
 127
 128   # PerlIO::via::scalar has to be tested as well.
 129   # use PerlIO::scalar succeeds with ./TEST and with ./perl harness but not with ./perl
 130
 131   for $test ($test_count .. $test_count + ($test_count_end - $test_count_start - 1)) {
 132     print "ok $test # skipped - Can't test in memory file with miniperl/without PerlIO::Scalar\n";
 133     $test_count++;
 134   }
 135  }
 136  else {
 137   # Test if a file in memory behaves the same as a real file (= re-run the test with a file in memory)
 138   open TESTFILE, "<", \$teststring;
 139   test_string(*TESTFILE);
 140   close TESTFILE;
 141
 142   open TESTFILE, "<", \$teststring2;
 143   test_record(*TESTFILE);
 144   close TESTFILE;
 145  }
 146 }
 147
 148 # Get rid of the temp file
 149 END { unlink "./foo"; }
 150
 151 sub test_string {
 152   *FH = shift;
 153
 154   # Check the default $/
 155   $bar = <FH>;
 156   if ($bar ne "1\n") {print "not ";}
 157   print "ok $test_count # default \$/\n";
 158   $test_count++;
 159
 160   # explicitly set to \n
 161   $/ = "\n";
 162   $bar = <FH>;
 163   if ($bar ne "12\n") {print "not ";}
 164   print "ok $test_count # \$/ = \"\\n\"\n";
 165   $test_count++;
 166
 167   # Try a non line terminator
 168   $/ = 3;
 169   $bar = <FH>;
 170   if ($bar ne "123") {print "not ";}
 171   print "ok $test_count # \$/ = 3\n";
 172   $test_count++;
 173
 174   # Eat the line terminator
 175   $/ = "\n";
 176   $bar = <FH>;
 177
 178   # How about a larger terminator
 179   $/ = "34";
 180   $bar = <FH>;
 181   if ($bar ne "1234") {print "not ";}
 182   print "ok $test_count # \$/ = \"34\"\n";
 183   $test_count++;
 184
 185   # Eat the line terminator
 186   $/ = "\n";
 187   $bar = <FH>;
 188
 189   # Does paragraph mode work?
 190   $/ = '';
 191   $bar = <FH>;
 192   if ($bar ne "1234\n12345\n\n") {print "not ";}
 193   print "ok $test_count # \$/ = ''\n";
 194   $test_count++;
 195
 196   # Try slurping the rest of the file
 197   $/ = undef;
 198   $bar = <FH>;
 199   if ($bar ne "123456\n1234567\n") {print "not ";}
 200   print "ok $test_count # \$/ = undef\n";
 201   $test_count++;
 202 }
 203
 204 sub test_record {
 205   *FH = shift;
 206
 207   # Test straight number
 208   $/ = \2;
 209   $bar = <FH>;
 210   if ($bar ne "12") {print "not ";}
 211   print "ok $test_count # \$/ = \\2\n";
 212   $test_count++;
 213
 214   # Test stringified number
 215   $/ = \"2";
 216   $bar = <FH>;
 217   if ($bar ne "34") {print "not ";}
 218   print "ok $test_count # \$/ = \"2\"\n";
 219   $test_count++;
 220
 221   # Integer variable
 222   $foo = 2;
 223   $/ = \$foo;
 224   $bar = <FH>;
 225   if ($bar ne "56") {print "not ";}
 226   print "ok $test_count # \$/ = \\\$foo (\$foo = 2)\n";
 227   $test_count++;
 228
 229   # String variable
 230   $foo = "2";
 231   $/ = \$foo;
 232   $bar = <FH>;
 233   if ($bar ne "78") {print "not ";}
 234   print "ok $test_count # \$/ = \\\$foo (\$foo = \"2\")\n";
 235   $test_count++;
 236
 237   # Naughty straight number - should get the rest of the file
 238   $/ = \0;
 239   $bar = <FH>;
 240   if ($bar ne "90123456789012345678901234567890") {print "not ";}
 241   print "ok $test_count # \$/ = \\0\n";
 242   $test_count++;
 243 }
 244