From: Graham Barr Date: Fri, 27 Feb 1998 04:15:04 +0000 (+0000) Subject: _60 & _04 - Add WRITE & CLOSE to TIEHANDLE X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1d603a678689f1e74cf73914a432b2a8d38be470;p=p5sagit%2Fp5-mst-13.2.git _60 & _04 - Add WRITE & CLOSE to TIEHANDLE p4raw-id: //depot/perl@595 --- diff --git a/lib/Tie/Handle.pm b/lib/Tie/Handle.pm new file mode 100644 index 0000000..c755053 --- /dev/null +++ b/lib/Tie/Handle.pm @@ -0,0 +1,161 @@ +package Tie::Handle; + +=head1 NAME + +Tie::Handle - base class definitions for tied handles + +=head1 SYNOPSIS + + package NewHandle; + require Tie::Handle; + + @ISA = (Tie::Handle); + + sub READ { ... } # Provide a needed method + sub TIEHANDLE { ... } # Overrides inherited method + + + package main; + + tie *FH, 'NewHandle'; + +=head1 DESCRIPTION + +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. + +For developers wishing to write their own tied-handle classes, the methods +are summarized below. The L section not only documents these, but +has sample code as well: + +=over + +=item TIEHANDLE classname, LIST + +The method invoked by the command C. Associates a new +glob instance with the specified class. C would represent additional +arguments (along the lines of L and compatriots) needed to +complete the association. + +=item WRITE this, scalar, length, offset + +Write I bytes of data from I starting at I. + +=item PRINT this, LIST + +Print the values in I + +=item PRINTF this, format, LIST + +Print the values in I using I + +=item READ this, scalar, length, offset + +Read I bytes of data into I starting at I. + +=item READLINE this + +Read a single line + +=item GETC this + +Get a single character + +=item DESTROY this + +Free the storage associated with the tied handle referenced by I. +This is rarely needed, as Perl manages its memory quite well. But the +option exists, should a class wish to perform specific actions upon the +destruction of an instance. + +=back + +=head1 MORE INFORMATION + +The L section contains an example of tying handles. + +=cut + +use Carp; + +sub new { + my $pkg = shift; + $pkg->TIEHANDLE(@_); +} + +# "Grandfather" the new, a la Tie::Hash + +sub TIEHANDLE { + my $pkg = shift; + if (defined &{"{$pkg}::new"}) { + carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing" + if $^W; + $pkg->new(@_); + } + else { + croak "$pkg doesn't define a TIEHANDLE method"; + } +} + +sub PRINT { + my $self = shift; + if($self->can('WRITE') != \&WRITE) { + my $buf = join(defined $, ? $, : "",@_); + $buf .= $\ if defined $\; + $self->WRITE($buf,length($buf),0); + } + else { + croak ref($self)," doesn't define a PRINT method"; + } +} + +sub PRINTF { + my $self = shift; + + if($self->can('WRITE') != \&WRITE) { + my $buf = sprintf(@_); + $self->WRITE($buf,length($buf),0); + } + else { + croak ref($self)," doesn't define a PRINTF method"; + } +} + +sub READLINE { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a READLINE method"; +} + +sub GETC { + my $self = shift; + + if($self->can('READ') != \&READ) { + my $buf; + $self->READ($buf,1); + return $buf; + } + else { + croak ref($self)," doesn't define a GETC method"; + } +} + +sub READ { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a READ method"; +} + +sub WRITE { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a WRITE method"; +} + +sub CLOSE { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a CLOSE method"; +} + +1; diff --git a/pod/perltie.pod b/pod/perltie.pod index 79a749e..398c3a0 100644 --- a/pod/perltie.pod +++ b/pod/perltie.pod @@ -620,8 +620,8 @@ 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, at least one of PRINT, PRINTF, READLINE, GETC, or READ, -and possibly DESTROY. +methods: TIEHANDLE, at least one of PRINT, PRINTF, WRITE, READLINE, GETC, +READ, and possibly CLOSE and 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,6 +641,17 @@ hold some internal information. sub TIEHANDLE { print "\n"; my $i; bless \$i, shift } +=item WRITE this, LIST + +This method will be called when the handle is written to via the +C function. + + sub WRITE { + $r = shift; + my($buf,$len,$offset) = @_; + print "WRITE called, \$buf=$buf, \$len=$len, \$offset=$offset"; + } + =item PRINT this, LIST This method will be triggered every time the tied handle is printed to @@ -663,7 +674,7 @@ passed to the printf function. print sprintf($fmt, @_)."\n"; } -=item READ this LIST +=item READ this, LIST This method will be called when the handle is read from via the C or C functions. @@ -687,6 +698,13 @@ This method will be called when the C function is called. sub GETC { print "Don't GETC, Get Perl"; return "a"; } +=item CLOSE this + +This method will be called when the handle is closed via the C +function. + + sub CLOSE { print "CLOSE called.\n" } + =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 f902992..c273c8c 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -356,11 +356,23 @@ PP(pp_close) { djSP; GV *gv; + MAGIC *mg; if (MAXARG == 0) gv = defoutgv; else gv = (GV*)POPs; + + if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { + PUSHMARK(SP); + XPUSHs(mg->mg_obj); + PUTBACK; + ENTER; + perl_call_method("CLOSE", G_SCALAR); + LEAVE; + SPAGAIN; + RETURN; + } EXTEND(SP, 1); PUSHs(boolSV(do_close(gv, TRUE))); RETURN; @@ -1319,8 +1331,25 @@ PP(pp_send) char *buffer; int length; STRLEN blen; + MAGIC *mg; gv = (GV*)*++MARK; + if (op->op_type == OP_SYSWRITE && + SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) + { + SV *sv; + + PUSHMARK(MARK-1); + *MARK = mg->mg_obj; + ENTER; + perl_call_method("WRITE", G_SCALAR); + LEAVE; + SPAGAIN; + sv = POPs; + SP = ORIGMARK; + PUSHs(sv); + RETURN; + } if (!gv) goto say_undef; bufsv = *++MARK; diff --git a/t/op/tiehandle.t b/t/op/tiehandle.t new file mode 100755 index 0000000..e3d2472 --- /dev/null +++ b/t/op/tiehandle.t @@ -0,0 +1,137 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +my @expect; +my $data = ""; +my @data = (); +my $test = 1; + +sub ok { print "not " unless shift; print "ok ",$test++,"\n"; } + +package Implement; + +BEGIN { *ok = \*main::ok } + +sub compare { + return unless @expect; + return ok(0) unless(@_ == @expect); + + my $i; + for($i = 0 ; $i < @_ ; $i++) { + next if $_[$i] eq $expect[$i]; + return ok(0); + } + + ok(1); +} + +sub TIEHANDLE { + compare(TIEHANDLE => @_); + my ($class,@val) = @_; + return bless \@val,$class; +} + +sub PRINT { + compare(PRINT => @_); + 1; +} + +sub PRINTF { + compare(PRINTF => @_); + 2; +} + +sub READLINE { + compare(READLINE => @_); + wantarray ? @data : shift @data; +} + +sub GETC { + compare(GETC => @_); + substr($data,0,1); +} + +sub READ { + compare(READ => @_); + substr($_[1],$_[3] || 0) = substr($data,0,$_[2]); + 3; +} + +sub WRITE { + compare(WRITE => @_); + $data = substr($_[1],$_[3] || 0, $_[2]); + 4; +} + +sub CLOSE { + compare(CLOSE => @_); + + 5; +} + +package main; + +use Symbol; + +print "1..23\n"; + +my $fh = gensym; + +@expect = (TIEHANDLE => 'Implement'); +my $ob = tie *$fh,'Implement'; +ok(ref($ob) eq 'Implement'); +ok(tied(*$fh) == $ob); + +@expect = (PRINT => $ob,"some","text"); +$r = print $fh @expect[2,3]; +ok($r == 1); + +@expect = (PRINTF => $ob,"%s","text"); +$r = printf $fh @expect[2,3]; +ok($r == 2); + +$text = (@data = ("the line\n"))[0]; +@expect = (READLINE => $ob); +$ln = <$fh>; +ok($ln eq $text); + +@expect = (); +@in = @data = qw(a line at a time); +@line = <$fh>; +@expect = @in; +Implement::compare(@line); + +@expect = (GETC => $ob); +$data = "abc"; +$ch = getc $fh; +ok($ch eq "a"); + +$buf = "xyz"; +@expect = (READ => $ob, $buf, 3); +$data = "abc"; +$r = read $fh,$buf,3; +ok($r == 3); +ok($buf eq "abc"); + + +$buf = "xyzasd"; +@expect = (READ => $ob, $buf, 3,3); +$data = "abc"; +$r = sysread $fh,$buf,3,3; +ok($r == 3); +ok($buf eq "xyzabc"); + +$buf = "qwerty"; +@expect = (WRITE => $ob, $buf, 4,1); +$data = ""; +$r = syswrite $fh,$buf,4,1; +ok($r == 4); +ok($data eq "wert"); + +@expect = (CLOSE => $ob); +$r = close $fh; +ok($r == 5);