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

Author: dougm

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>

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>>

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);

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"