t/base/rs.t

   1 #!./perl
   2 # Test $/
   3
   4 print "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
  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 $/ = "\n";
  38 my $note = "\$/ preserved when set to bad value";
  39 # none of the setting of $/ to bad values should modify its value
  40 test_bad_setting();
  41 print +($/ 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
  46 if ($^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
 153 END { unlink "./foo"; }
 154
 155 sub 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
 208 sub 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   # Naughty straight number - should get the rest of the file
 242   # no warnings 'deprecated'; # but not in t/base/*
 243   { local $SIG{__WARN__} = sub {}; $/ = \0 }
 244   $bar = <FH>;
 245   if ($bar ne "90123456789012345678901234567890") {print "not ";}
 246   print "ok $test_count # \$/ = \\0\n";
 247   $test_count++;
 248 }
 249
 250 sub test_bad_setting {
 251   if (eval {$/ = []; 1}) {
 252     print "not ok ",$test_count++," # \$/ = []; should die\n";
 253     print "not ok ",$test_count++," # \$/ = []; produced expected error message\n";
 254   } else {
 255     my $msg= $@ || "Zombie Error";
 256     print "ok ",$test_count++," # \$/ = []; should die\n";
 257     if ($msg!~m!Setting \$\/ to an ARRAY reference is forbidden!) {
 258       print "not ";
 259     }
 260     print "ok ",$test_count++," # \$/ = []; produced expected error message\n";
 261   }
 262   if (eval {$/ = {}; 1}) {
 263     print "not ok ",$test_count++," # \$/ = {}; should die\n";
 264     print "not ok ",$test_count++," # \$/ = {}; produced expected error message\n";
 265   } else {
 266     my $msg= $@ || "Zombie Error";
 267     print "ok ",$test_count++," # \$/ = {}; should die\n";
 268     if ($msg!~m!Setting \$\/ to a HASH reference is forbidden!) {print "not ";}
 269     print "ok ",$test_count++," # \$/ = {}; produced expected error message\n";
 270   }
 271   if (eval {$/ = \\1; 1}) {
 272     print "not ok ",$test_count++," # \$/ = \\\\1; should die\n";
 273     print "not ok ",$test_count++," # \$/ = \\\\1; produced expected error message\n";
 274   } else {
 275     my $msg= $@ || "Zombie Error";
 276     print "ok ",$test_count++," # \$/ = \\\\1; should die\n";
 277     if ($msg!~m!Setting \$\/ to a REF reference is forbidden!) {print "not ";}
 278     print "ok ",$test_count++," # \$/ = \\\\1; produced expected error message\n";
 279   }
 280   if (eval {$/ = qr/foo/; 1}) {
 281     print "not ok ",$test_count++," # \$/ = qr/foo/; should die\n";
 282     print "not ok ",$test_count++," # \$/ = qr/foo/; produced expected error message\n";
 283   } else {
 284     my $msg= $@ || "Zombie Error";
 285     print "ok ",$test_count++," # \$/ = qr/foo/; should die\n";
 286     if ($msg!~m!Setting \$\/ to a REGEXP reference is forbidden!) {print "not ";}
 287     print "ok ",$test_count++," # \$/ = qr/foo/; produced expected error message\n";
 288   }
 289   if (eval {$/ = \*STDOUT; 1}) {
 290     print "not ok ",$test_count++," # \$/ = \\*STDOUT; should die\n";
 291     print "not ok ",$test_count++," # \$/ = \\*STDOUT; produced expected error message\n";
 292   } else {
 293     my $msg= $@ || "Zombie Error";
 294     print "ok ",$test_count++," # \$/ = \\*STDOUT; should die\n";
 295     if ($msg!~m!Setting \$\/ to a GLOB reference is forbidden!) {print "not ";}
 296     print "ok ",$test_count++," # \$/ = \\*STDOUT; produced expected error message\n";
 297   }
 298 }