Support PRINTF for tied handles

A mod_perl user just asked why "print ..." is sent to the browser but
"printf ..." goes to the term window.  Sorry this is coming in late,
this question has been asked a few times in the past, but I forgot
about it :-(  

p5p-msgid: 199704202226.SAA08032@postman.osf.org

4 files changed, 59 insertions, 3 deletions

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 0613412bcd..d02125b9af 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -490,6 +490,19 @@ the print function.
 	return print join( $, => map {uc} @_), $\;
     }
 
+=item PRINTF this, LIST
+
+This method will be triggered every time the tied handle is printed to
+with the C<printf()> function.
+Beyond its self reference it also expects the format and list that was
+passed to the printf function.
+
+    sub PRINTF {
+        shift;
+	  my $fmt = shift;
+        print sprintf($fmt, @_)."\n";
+    }
+
 =item READ this LIST
 
 This method will be called when the handle is read from via the C<read>
diff --git a/pod/perltie.pod b/pod/perltie.pod
index 847340d182..ccc1156982 100644
--- 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, at least one of PRINT, READLINE, GETC, or READ,
+methods: TIEHANDLE, at least one of PRINT, PRINTF, READLINE, GETC, or READ,
 and possibly DESTROY.
 
 It is especially useful when perl is embedded in some other program,
@@ -634,12 +634,26 @@ hold some internal information.
 
 =item PRINT this, LIST
 
-This method will be triggered every time the tied handle is printed to.
+This method will be triggered every time the tied handle is printed to
+with the C<print()> function.
 Beyond its self reference it also expects the list that was passed to
 the print function.
 
     sub PRINT { $r = shift; $$r++; print join($,,map(uc($_),@_)),$\ }
 
+=item PRINTF this, LIST
+
+This method will be triggered every time the tied handle is printed to
+with the C<printf()> function.
+Beyond its self reference it also expects the format and list that was
+passed to the printf function.
+
+    sub PRINTF {
+        shift;
+        my $fmt = shift;
+        print sprintf($fmt, @_)."\n";
+    }
+
 =item READ this LIST
 
 This method will be called when the handle is read from via the C<read>
@@ -832,4 +846,4 @@ source code to MLDBM.
 
 Tom Christiansen
 
-TIEHANDLE by Sven Verdoolaege <F<skimo@dns.ufsia.ac.be>>
+TIEHANDLE by Sven Verdoolaege <F<skimo@dns.ufsia.ac.be>> and Doug MacEachern <F<dougm@osf.org>>
diff --git a/pp_sys.c b/pp_sys.c
index 6d18ac96bc..270d2f2103 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1072,11 +1072,33 @@ PP(pp_prtf)
     IO *io;
     PerlIO *fp;
     SV *sv = NEWSV(0,0);
+    MAGIC *mg;
 
     if (op->op_flags & OPf_STACKED)
 	gv = (GV*)*++MARK;
     else
 	gv = defoutgv;
+
+    if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
+	if (MARK == ORIGMARK) {
+	    EXTEND(SP, 1);
+	    ++MARK;
+	    Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
+	    ++SP;
+	}
+	PUSHMARK(MARK - 1);
+	*MARK = mg->mg_obj;
+	PUTBACK;
+	ENTER;
+	perl_call_method("PRINTF", G_SCALAR);
+	LEAVE;
+	SPAGAIN;
+	MARK = ORIGMARK + 1;
+	*MARK = *SP;
+	SP = MARK;
+	RETURN;
+    }
+
     if (!(io = GvIO(gv))) {
 	if (dowarn) {
 	    gv_fullname3(sv, gv, Nullch);
diff --git a/t/op/misc.t b/t/op/misc.t
index 1a5afe544a..660049b3f1 100755
--- a/t/op/misc.t
+++ b/t/op/misc.t
@@ -196,6 +196,11 @@ BEGIN failed--compilation aborted at - line 1.
         shift;
         print join(' ', reverse @_)."\n";
     }
+    sub PRINTF {
+        shift;
+	  my $fmt = shift;
+        print sprintf($fmt, @_)."\n";
+    }
     sub TIEHANDLE {
         bless {}, shift;
     }
@@ -226,12 +231,14 @@ BEGIN failed--compilation aborted at - line 1.
     $len = 10; $offset = 1;
     read(FOO, $buf, $len, $offset) == 100 or die "foo->READ failed";
     getc(FOO) eq "a" or die "foo->GETC failed";
+    printf "%s is number %d\n", "Perl", 1;
 }
 EXPECT
 This is a reversed sentence.
 -- Out of inspiration --
 foo->can(READ)(string 10 1)
 Don't GETC, Get Perl
+Perl is number 1
 and destroyed as well
 ########
 my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n"