Title: "Add ERRSV, ERRHV, DEFSV and SAVE_DEFSV for XS 5.005 compatibility"

  From:  timbo@ig.co.uk (Tim Bunce)
Msg-ID:  <199804200854.JAA01482@toad.ig.co.uk>
 Files:  perl.h

 Title:  "Add WRITE & CLOSE to TIEHANDLE"
  From:  Graham Barr <gbarr@pobox.com>
Msg-ID:  <34F63DC8.CA95670F@pobox.com>
 Files:  pod/perltie.pod lib/Tie/Handle.pm pp_sys.c t/op/tiehandle.t

p4raw-id: //depot/maint-5.004/perl@911

4 files changed, 216 insertions, 3 deletions

diff --git a/lib/Tie/Handle.pm b/lib/Tie/Handle.pm
new file mode 100644
index 0000000000..c7550530b8
--- /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<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.
+
+For developers wishing to write their own tied-handle classes, the methods
+are summarized below. The L<perltie> section not only documents these, but
+has sample code as well:
+
+=over
+
+=item TIEHANDLE classname, LIST
+
+The method invoked by the command C<tie *glob, classname>. Associates a new
+glob instance with the specified class. C<LIST> would represent additional
+arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
+complete the association.
+
+=item WRITE this, scalar, length, offset
+
+Write I<length> bytes of data from I<scalar> starting at I<offset>.
+
+=item PRINT this, LIST
+
+Print the values in I<LIST>
+
+=item PRINTF this, format, LIST
+
+Print the values in I<LIST> using I<format>
+
+=item READ this, scalar, length, offset
+
+Read I<length> bytes of data into I<scalar> starting at I<offset>.
+
+=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>.
+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<perltie> 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/perl.h b/perl.h
index fe739360fe..473efc1395 100644
--- a/perl.h
+++ b/perl.h
@@ -2238,6 +2238,10 @@ EXT bool	numeric_local INIT(TRUE);    /* Assume local numerics */
 
 /* provide some backwards compatibility for XS source from 5.005 */
 #define dTHR typedef int _thr_dummy
+#define ERRSV GvSV(errgv)
+#define ERRHV GvHV(errgv)
+#define DEFSV GvSV(defgv)
+#define SAVE_DEFSV SAVESPTR(GvSV(defgv))
 
 #endif /* Include guard */
 
diff --git a/pod/perltie.pod b/pod/perltie.pod
index c6eb7156ce..9ece1b3c2e 100644
--- a/pod/perltie.pod
+++ b/pod/perltie.pod
@@ -611,8 +611,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
@@ -632,6 +632,17 @@ hold some internal information.
 
     sub TIEHANDLE { print "<shout>\n"; my $i; bless \$i, shift }
 
+=item WRITE this, LIST
+
+This method will be called when the handle is written to via the
+C<syswrite> 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
@@ -654,7 +665,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<read>
 or C<sysread> functions.
@@ -678,6 +689,13 @@ This method will be called when the C<getc> 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<close>
+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 12cc36e31b..27615690c7 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -349,11 +349,24 @@ PP(pp_close)
 {
     dSP;
     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;
@@ -1312,8 +1325,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;