Support READ and GETC for tied handles

Subject: Re: Seeds of _93: planting TIEHANDLE/READ

Ilya Zakharevich <ilya@math.ohio-state.edu> wrote:

> Doug MacEachern writes:
> >
> > Chip Salzenberg <salzench@nielsenmedia.com> wrote:
> >
> > > Here's what I have for _93.  Speak now, etc.
> >
> > sorry to plant this seed so late, but I think it's important for the
> > growth of young TIEHANDLE.  We have PRINT and READLINE, why no READ?
>
> If you added READ, where is getc? Or is it covered by the patch?

sorry, I was being selfish, I don't care about getc :-)  new patch
against fresh _92 below.  I know this all came up in the past, there
are more missing, why where they not covered before?

p5p-msgid: 199703090019.TAA32591@postman.osf.org

diff --git a/pod/perltie.pod b/pod/perltie.pod
index ffd348f..8201c04 100644 (file)
--- a/pod/perltie.pod
+++ b/pod/perltie.pod
@@ -611,7 +611,7 @@ use the each() function to iterate over such.  Example:
 This is partially implemented now.
 
 A class implementing a tied filehandle should define the following methods:
-TIEHANDLE, PRINT and/or READLINE, and possibly DESTROY.
+TIEHANDLE, at least one of PRINT, READLINE, GETC or READ, and possibly DESTROY.
 
 It is especially useful when perl is embedded in some other program,
 where output to STDOUT and STDERR may have to be redirected in some
@@ -641,11 +641,28 @@ the print function.
 
 =item READLINE this
 
-This method will be called when the handle is read from. The method
-should return undef when there is no more data.
+This method will be called when the handle is read from via <HANDLE>.
+The method should return undef when there is no more data.
 
     sub READLINE { $r = shift; "PRINT called $$r times\n"; }
+ 
+=item READ this LIST
 
+This method will be called when the handle is read from via the C<read>
+or C<sysread> functions.
+
+    sub READ { 
+       $r = shift; 
+       my($buf,$len,$offset) = @_; 
+       print "READ called, \$buf=$buf, \$len=$len, \$offset=$offset";
+    }
+
+=item GETC this
+
+This method will be called when the C<getc> function is called.
+
+    sub GETC { print "Don't GETC, Get Perl"; return "a"; }
+ 
 =item DESTROY this
 
 As with the other types of ties, this method will be called when the

diff --git a/pp_sys.c b/pp_sys.c
index a1153c6..6cbca14 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -829,6 +829,7 @@ PP(pp_getc)
 {
     dSP; dTARGET;
     GV *gv;
+    MAGIC *mg;
 
     if (MAXARG <= 0)
        gv = stdingv;
@@ -836,6 +837,19 @@ PP(pp_getc)
        gv = (GV*)POPs;
     if (!gv)
        gv = argvgv;
+
+    if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
+       PUSHMARK(SP);
+       XPUSHs(mg->mg_obj);
+       PUTBACK;
+       ENTER;
+       perl_call_method("GETC", GIMME);
+       LEAVE;
+       SPAGAIN;
+       if (GIMME == G_SCALAR)
+           SvSetSV_nosteal(TARG, TOPs);
+       RETURN;
+    }
     if (!gv || do_eof(gv)) /* make sure we have fp with something */
        RETPUSHUNDEF;
     TAINT;
@@ -1126,8 +1140,24 @@ PP(pp_sysread)
     Sock_size_t bufsize;
     SV *bufsv;
     STRLEN blen;
+    MAGIC *mg;
 
     gv = (GV*)*++MARK;
+    if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
+       SV *sv;
+       
+       PUSHMARK(MARK-1);
+       *MARK = mg->mg_obj;
+       ENTER;
+       perl_call_method("READ", G_SCALAR);
+       LEAVE;
+       SPAGAIN;
+       sv = POPs;
+       SP = ORIGMARK;
+       PUSHs(sv);
+       RETURN;
+    }
+
     if (!gv)
        goto say_undef;
     bufsv = *++MARK;

diff --git a/t/op/misc.t b/t/op/misc.t
index d7a62dc..0f251ea 100755 (executable)
--- a/t/op/misc.t
+++ b/t/op/misc.t
@@ -196,17 +196,34 @@ BEGIN failed--compilation aborted at - line 1.
     }
     sub DESTROY {
        print "and destroyed as well\n";
-    }
+  }
+  sub READ {
+      shift;
+      print STDOUT "foo->can(READ)(@_)\n";
+      return 100; 
+  }
+  sub GETC {
+      shift;
+      print STDOUT "Don't GETC, Get Perl\n";
+      return "a"; 
+  }    
 }
 {
     local(*FOO);
     tie(*FOO,'foo');
     print FOO "sentence.", "reversed", "a", "is", "This";
     print "-- ", <FOO>, " --\n";
+    my($buf,$len,$offset);
+    $buf = "string";
+    $len = 10; $offset = 1;
+    read(FOO, $buf, $len, $offset) == 100 or die "foo->READ failed";
+    getc(FOO) eq "a" or die "foo->GETC failed";
 }
 EXPECT
 This is a reversed sentence.
 -- Out of inspiration --
+foo->can(READ)(string 10 1)
+Don't GETC, Get Perl
 and destroyed as well
 ########
 my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n"