From: Nick Ing-Simmons Date: Sat, 8 May 1999 14:16:30 +0000 (+0000) Subject: Implement OPEN, EOF, SEEK, TELL, BINMODE and FILENO as TIEHANDLE methods. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4592e6caefc41a75573f112714d170071892a537;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 for a list of the functions required in tying a handle to a package. The basic B package provides a C method, as well as methods -C, C and C. The C method is provided as a means -of grandfathering, for classes that forget to provide their own C -method. +C, C, C and C. For developers wishing to write their own tied-handle classes, the methods are summarized below. The L 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. @@ -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 --- 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 --- 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 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"); + +