Mangled patch, needed hand-tweaks, along with binmode for rs.t:

	Message-Id: <3.0.5.32.19980605110840.009e12b0@ous.edu>
	Subject: Re: [PATCH 5.004_66]Add record read capability to <>

p4raw-id: //depot/perl@1099

diff --git a/perl.h b/perl.h
index b1f0be0..c8bd8b5 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -1818,6 +1818,7 @@ typedef enum {
 #define RsSNARF(sv)   (! SvOK(sv))
 #define RsSIMPLE(sv)  (SvOK(sv) && SvCUR(sv))
 #define RsPARA(sv)    (SvOK(sv) && ! SvCUR(sv))
+#define RsRECORD(sv)  (SvROK(sv) && (SvIV(SvRV(sv)) > 0))
 
 /* Set up PERLVAR macros for populating structs */
 #define PERLVAR(var,type) type var;

diff --git a/pod/perlvar.pod b/pod/perlvar.pod
index 2cb95af..d9edffa 100644 (file)
--- a/pod/perlvar.pod
+++ b/pod/perlvar.pod
@@ -222,6 +222,27 @@ character belongs to the next paragraph, even if it's a newline.
 Remember: the value of $/ is a string, not a regexp.  AWK has to be
 better for something :-)
 
+Setting $/ to a reference to an integer, scalar containing an integer, or
+scalar that's convertable to an integer will attempt to read records
+instead of lines, with the maximum record size being the referenced
+integer. So this:
+
+    $/ = \32768; # or \"32768", or \$var_containing_32768
+    open(FILE, $myfile);
+    $_ = <FILE>;
+
+will read a record of no more than 32768 bytes from FILE. If you're not
+reading from a record-oriented file (or your OS doesn't have
+record-oriented files), then you'll likely get a full chunk of data with
+every read. If a record is larger than the record size you've set, you'll
+get the record back in pieces.
+
+On VMS, record reads are done with the equivalent of C<sysread>, so it's
+best not to mix record and non-record reads on the same file. (This is
+likely not a problem, as any file you'd want to read in record mode is
+proably usable in line mode) Non-VMS systems perform normal I/O, so
+it's safe to mix record and non-record reads of a file.
+
 =item autoflush HANDLE EXPR
 
 =item $OUTPUT_AUTOFLUSH

diff --git a/sv.c b/sv.c
index f5a979a..023693f 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3153,6 +3153,31 @@ sv_gets(register SV *sv, register PerlIO *fp, I32 append)
        rsptr = NULL;
        rslen = 0;
     }
+    else if (RsRECORD(rs)) {
+      I32 recsize, bytesread;
+      char *buffer;
+
+      /* Grab the size of the record we're getting */
+      recsize = SvIV(SvRV(rs));
+      (void)SvPOK_only(sv);    /* Validate pointer */
+      /* Make sure we've got the room to yank in the whole thing */
+      if (SvLEN(sv) <= recsize + 3) {
+        /* No, so make it bigger */
+        SvGROW(sv, recsize + 3);
+      }
+      buffer = SvPVX(sv); /* Get the location of the final buffer */
+      /* Go yank in */
+#ifdef VMS
+      /* VMS wants read instead of fread, because fread doesn't respect */
+      /* RMS record boundaries. This is not necessarily a good thing to be */
+      /* doing, but we've got no other real choice */
+      bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
+#else
+      bytesread = PerlIO_read(fp, buffer, recsize);
+#endif
+      SvCUR_set(sv, bytesread);
+      return(SvCUR(sv) ? SvPVX(sv) : Nullch);
+    }
     else if (RsPARA(rs)) {
        rsptr = "\n\n";
        rslen = 2;

diff --git a/t/base/rs.t b/t/base/rs.t
new file mode 100755 (executable)
index 0000000..2f467a6
--- /dev/null
+++ b/t/base/rs.t
@@ -0,0 +1,122 @@
+#!./perl
+# Test $!
+
+print "1..14\n";
+
+$teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n";
+
+# Create our test datafile
+open TESTFILE, ">./foo" or die "error $! $^E opening";
+binmode TESTFILE;
+print TESTFILE $teststring;
+close TESTFILE;
+
+open TESTFILE, "<./foo";
+binmode TESTFILE;
+
+# Check the default $/
+$bar = <TESTFILE>;
+if ($bar eq "1\n") {print "ok 1\n";} else {print "not ok 1\n";}
+
+# explicitly set to \n
+$/ = "\n";
+$bar = <TESTFILE>;
+if ($bar eq "12\n") {print "ok 2\n";} else {print "not ok 2\n";}
+
+# Try a non line terminator
+$/ = "3";
+$bar = <TESTFILE>;
+if ($bar eq "123") {print "ok 3\n";} else {print "not ok 3\n";}
+
+# Eat the line terminator
+$/ = "\n";
+$bar = <TESTFILE>;
+
+# How about a larger terminator
+$/ = "34";
+$bar = <TESTFILE>;
+if ($bar eq "1234") {print "ok 4\n";} else {print "not ok 4\n";}
+
+# Eat the line terminator
+$/ = "\n";
+$bar = <TESTFILE>;
+
+# Does paragraph mode work?
+$/ = '';
+$bar = <TESTFILE>;
+if ($bar eq "1234\n12345\n\n") {print "ok 5\n";} else {print "not ok 5\n";}
+
+# Try slurping the rest of the file
+$/ = undef;
+$bar = <TESTFILE>;
+if ($bar eq "123456\n1234567\n") {print "ok 6\n";} else {print "not ok 6\n";}
+
+# try the record reading tests. New file so we don't have to worry about
+# the size of \n.
+close TESTFILE;
+unlink "./foo";
+open TESTFILE, ">./foo";
+print TESTFILE "1234567890123456789012345678901234567890";
+binmode TESTFILE;
+close TESTFILE;
+open TESTFILE, "<./foo";
+binmode TESTFILE;
+
+# Test straight number
+$/ = \2;
+$bar = <TESTFILE>;
+if ($bar eq "12") {print "ok 7\n";} else {print "not ok 7\n";}
+
+# Test stringified number
+$/ = \"2";
+$bar = <TESTFILE>;
+if ($bar eq "34") {print "ok 8\n";} else {print "not ok 8\n";}
+
+# Integer variable
+$foo = 2;
+$/ = \$foo;
+$bar = <TESTFILE>;
+if ($bar eq "56") {print "ok 9\n";} else {print "not ok 9\n";}
+
+# String variable
+$foo = "2";
+$/ = \$foo;
+$bar = <TESTFILE>;
+if ($bar eq "78") {print "ok 10\n";} else {print "not ok 10\n";}
+
+# Get rid of the temp file
+unlink "./foo";
+
+# Now for the tricky bit--full record reading
+if ($^O eq 'VMS') {
+  # Create a temp file. We jump through these hoops 'cause CREATE really
+  # doesn't like our methods for some reason.
+  open TEMPFILE, ">./foo";
+  print TEMPFILE "foo\nfoobar\nbaz\n";
+  close TEMPFILE;
+  open CREATEPIPE, "|\@sys\$input";
+  print CREATEPIPE "DEFINE SYS\$INPUT FOO./user\n";
+  print CREATEPIPE "CREATE []FOO.BAR\n";
+  close CREATEPIPE;
+  unlink "./foo";
+
+  open TESTFILE, "<./foo.bar";
+  $/ = \10;
+  $bar = <TESTFILE>;
+  if ($bar eq "foo\n") {print "ok 11\n";} else {print "not ok 11\n";}
+  $bar = <TESTFILE>;
+  if ($bar eq "foobar\n") {print "ok 12\n";} else {print "not ok 12\n";}
+  # can we do a short read?
+  $/ = \2;
+  $bar = <TESTFILE>;
+  if ($bar eq "ba") {print "ok 13\n";} else {print "not ok 13\n";}
+  # do we get the rest of the record?
+  $bar = <TESTFILE>;
+  if ($bar eq "z\n") {print "ok 14\n";} else {print "not ok 14\n";}
+
+  unlink "./foo.bar";
+} else {
+  # Nobody else does this at the moment (well, maybe OS/390, but they can
+  # put their own tests in) so we just punt
+  foreach $test (11..14) {print "ok $test # skipped on non-VMS system\n"};
+}