Implement OPEN, EOF, SEEK, TELL, BINMODE and FILENO as TIEHANDLE methods.

Provide Tie::StdHandle
Basic update of docs.

p4raw-id: //depot/perl@3330

diff --git a/lib/Tie/Handle.pm b/lib/Tie/Handle.pm
index 3cf94ec..6181eca 100644 (file)
--- a/lib/Tie/Handle.pm
+++ b/lib/Tie/Handle.pm
@@ -2,7 +2,7 @@ package Tie::Handle;
 
 =head1 NAME
 
-Tie::Handle - base class definitions for tied handles
+Tie::Handle, Tie::StdHandle  - base class definitions for tied handles
 
 =head1 SYNOPSIS
 
@@ -24,9 +24,7 @@ Tie::Handle - base class definitions for tied handles
 This module provides some skeletal methods for handle-tying classes. See
 L<perltie> for a list of the functions required in tying a handle to a package.
 The basic B<Tie::Handle> package provides a C<new> method, as well as methods
-C<TIESCALAR>, C<FETCH> and C<STORE>. The C<new> method is provided as a means
-of grandfathering, for classes that forget to provide their own C<TIESCALAR>
-method.
+C<TIEHANDLE>, C<PRINT>, C<PRINTF> and C<GETC>. 
 
 For developers wishing to write their own tied-handle classes, the methods
 are summarized below. The L<perltie> section not only documents these, but
@@ -69,6 +67,28 @@ Get a single character
 
 Close the handle
 
+=item OPEN this, filename
+
+(Re-)open the handle
+
+=item BINMODE this
+
+Specify content is binary
+
+=item EOF this
+
+Test for end of file.
+
+=item TELL this
+
+Return position in the file.
+
+=item SEEK this, offset, whence
+
+Position the file.
+
+Test for end of file.
+
 =item DESTROY this
 
 Free the storage associated with the tied handle referenced by I<this>.
@@ -121,7 +141,7 @@ sub PRINTF {
     my $self = shift;
     
     if($self->can('WRITE') != \&WRITE) {
-       my $buf = sprintf(@_);
+       my $buf = sprintf(shift,@_);
        $self->WRITE($buf,length($buf),0);
     }
     else {
@@ -160,6 +180,44 @@ sub WRITE {
 sub CLOSE {
     my $pkg = ref $_[0];
     croak "$pkg doesn't define a CLOSE method";
+} 
+
+package Tie::StdHandle; 
+use vars qw(@ISA);
+@ISA = 'Tie::Handle';       
+use Carp;
+
+sub TIEHANDLE 
+{
+ my $class = shift;
+ my $fh    = do { \local *HANDLE};
+ bless $fh,$class;
+ $fh->OPEN(@_) if (@_);
+ return $fh;
+}         
+
+sub EOF     { eof($_[0]) }
+sub TELL    { tell($_[0]) }
+sub FILENO  { fileno($_[0]) }
+sub SEEK    { seek($_[0],$_[1],$_[2]) }
+sub CLOSE   { close($_[0]) }
+sub BINMODE { binmode($_[0]) }
+
+sub OPEN
+{         
+ $_[0]->CLOSE if defined($_[0]->FILENO);
+ open($_[0],$_[1]);
 }
 
+sub READ     { read($_[0],$_[1],$_[2]) }
+sub READLINE { my $fh = $_[0]; <$fh> }
+sub GETC     { getc($_[0]) }
+
+sub WRITE
+{        
+ my $fh = $_[0];
+ print $fh substr($_[1],0,$_[2])
+}
+
+
 1;

diff --git a/pod/perltie.pod b/pod/perltie.pod
index 6652658..581b4ab 100644 (file)
--- a/pod/perltie.pod
+++ b/pod/perltie.pod
@@ -621,7 +621,9 @@ This is partially implemented now.
 
 A class implementing a tied filehandle should define the following
 methods: TIEHANDLE, at least one of PRINT, PRINTF, WRITE, READLINE, GETC,
-READ, and possibly CLOSE and DESTROY.
+READ, and possibly CLOSE and DESTROY.  The class can also provide: BINMODE, 
+OPEN, EOF, FILENO, SEEK, TELL - if the corresponding perl operators are
+used on the handle.
 
 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

diff --git a/pp_sys.c b/pp_sys.c
index e52a864..73468e1 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -494,6 +494,7 @@ PP(pp_open)
     SV *sv;
     char *tmps;
     STRLEN len;
+    MAGIC *mg;
 
     if (MAXARG > 1)
        sv = POPs;
@@ -522,6 +523,19 @@ PP(pp_open)
     }   
 #endif /* no undef means tmpfile() yet */
 
+
+    if (mg = SvTIED_mg((SV*)gv, 'q')) {
+       PUSHMARK(SP);
+       XPUSHs(SvTIED_obj((SV*)gv, mg));
+       XPUSHs(sv);
+       PUTBACK;
+       ENTER;
+       perl_call_method("OPEN", G_SCALAR);
+       LEAVE;
+       SPAGAIN;
+       RETURN;
+    }
+
     tmps = SvPV(sv, len);
     if (do_open(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp))
        PUSHi( (I32)PL_forkprocess );
@@ -619,9 +633,23 @@ PP(pp_fileno)
     GV *gv;
     IO *io;
     PerlIO *fp;
+    MAGIC  *mg;
+
     if (MAXARG < 1)
        RETPUSHUNDEF;
     gv = (GV*)POPs;
+
+    if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
+       PUSHMARK(SP);
+       XPUSHs(SvTIED_obj((SV*)gv, mg));
+       PUTBACK;
+       ENTER;
+       perl_call_method("FILENO", G_SCALAR);
+       LEAVE;
+       SPAGAIN;
+       RETURN;
+    }
+
     if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
        RETPUSHUNDEF;
     PUSHi(PerlIO_fileno(fp));
@@ -659,11 +687,23 @@ PP(pp_binmode)
     GV *gv;
     IO *io;
     PerlIO *fp;
+    MAGIC *mg;
 
     if (MAXARG < 1)
        RETPUSHUNDEF;
 
-    gv = (GV*)POPs;
+    gv = (GV*)POPs; 
+
+    if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
+       PUSHMARK(SP);
+       XPUSHs(SvTIED_obj((SV*)gv, mg));
+       PUTBACK;
+       ENTER;
+       perl_call_method("BINMODE", G_SCALAR);
+       LEAVE;
+       SPAGAIN;
+       RETURN;
+    }
 
     EXTEND(SP, 1);
     if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
@@ -1353,6 +1393,8 @@ PP(pp_sysopen)
     sv = POPs;
     gv = (GV *)POPs;
 
+    /* Need TIEHANDLE method ? */
+
     tmps = SvPV(sv, len);
     if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
        IoLINES(GvIOp(gv)) = 0;
@@ -1622,11 +1664,24 @@ PP(pp_eof)
 {
     djSP;
     GV *gv;
+    MAGIC *mg;
 
     if (MAXARG <= 0)
        gv = PL_last_in_gv;
     else
        gv = PL_last_in_gv = (GV*)POPs;
+
+    if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
+       PUSHMARK(SP);
+       XPUSHs(SvTIED_obj((SV*)gv, mg));
+       PUTBACK;
+       ENTER;
+       perl_call_method("EOF", G_SCALAR);
+       LEAVE;
+       SPAGAIN;
+       RETURN;
+    }
+
     PUSHs(boolSV(!gv || do_eof(gv)));
     RETURN;
 }
@@ -1634,12 +1689,25 @@ PP(pp_eof)
 PP(pp_tell)
 {
     djSP; dTARGET;
-    GV *gv;
+    GV *gv;     
+    MAGIC *mg;
 
     if (MAXARG <= 0)
        gv = PL_last_in_gv;
     else
        gv = PL_last_in_gv = (GV*)POPs;
+
+    if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
+       PUSHMARK(SP);
+       XPUSHs(SvTIED_obj((SV*)gv, mg));
+       PUTBACK;
+       ENTER;
+       perl_call_method("TELL", G_SCALAR);
+       LEAVE;
+       SPAGAIN;
+       RETURN;
+    }
+
     PUSHi( do_tell(gv) );
     RETURN;
 }
@@ -1655,8 +1723,23 @@ PP(pp_sysseek)
     GV *gv;
     int whence = POPi;
     Off_t offset = POPl;
+    MAGIC *mg;
 
     gv = PL_last_in_gv = (GV*)POPs;
+
+    if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
+       PUSHMARK(SP);
+       XPUSHs(SvTIED_obj((SV*)gv, mg));
+       XPUSHs(sv_2mortal(newSViv((IV) offset)));
+       XPUSHs(sv_2mortal(newSViv((IV) whence)));
+       PUTBACK;
+       ENTER;
+       perl_call_method("SEEK", G_SCALAR);
+       LEAVE;
+       SPAGAIN;
+       RETURN;
+    }
+
     if (PL_op->op_type == OP_SEEK)
        PUSHs(boolSV(do_seek(gv, offset, whence)));
     else {

diff --git a/t/lib/tie-stdhandle.t b/t/lib/tie-stdhandle.t
new file mode 100755 (executable)
index 0000000..c74669a
--- /dev/null
+++ b/t/lib/tie-stdhandle.t
@@ -0,0 +1,49 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    unshift @INC, '../lib';
+}
+
+use Tie::Handle;
+tie *tst,Tie::StdHandle;
+
+$f = 'tst';
+
+print "1..12\n";   
+
+# my $file tests
+
+unlink("afile.new") if -f "afile";     
+print "$!\nnot " unless open($f,"+>afile");
+print "ok 1\n";
+print "$!\nnot " unless binmode($f);
+print "ok 2\n";
+print "not " unless -f "afile";     
+print "ok 3\n";
+print "not " unless print $f "SomeData\n";
+print "ok 4\n";
+print "not " unless tell($f) == 9;
+print "ok 5\n";
+print "not " unless printf $f "Some %d value\n",1234;
+print "ok 6\n";
+print "not " unless seek($f,0,0);
+print "ok 7\n";
+$b = <$f>;
+print "not " unless $b eq "SomeData\n";
+print "ok 8\n";
+print "not " if eof($f);
+print "ok 9\n";
+read($f,($b=''),4);
+print "'$b' not " unless $b eq 'Some';
+print "ok 10\n";
+print "not " unless getc($f) eq ' ';
+print "ok 11\n";
+$b = <$f>;
+print "not " unless eof($f);
+print "ok 12\n";
+print "not " unless close($f);
+print "ok 13\n";
+unlink("afile");     
+
+