From: Nick Ing-Simmons <nik@tiuk.ti.com>
Date: Mon, 11 Aug 2003 12:14:55 +0000 (+0000)
Subject: Allow via layer to affect the PERLIO_F_UTF8 flag.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=802588c38f93bc20e6e27335acb9575e1c5e053e;p=p5sagit%2Fp5-mst-13.2.git

Allow via layer to affect the PERLIO_F_UTF8 flag.

p4raw-id: //depot/perl@20614
---

diff --git a/ext/PerlIO/via/via.pm b/ext/PerlIO/via/via.pm
index 8cf854b..833c14a 100644
--- a/ext/PerlIO/via/via.pm
+++ b/ext/PerlIO/via/via.pm
@@ -1,5 +1,5 @@
 package PerlIO::via;
-our $VERSION = '0.01';
+our $VERSION = '0.02';
 use XSLoader ();
 XSLoader::load 'PerlIO::via';
 1;
@@ -57,7 +57,7 @@ a reference to a glob which can be treated as a perl file handle.
 It refers to the layer below. I<$fh> is not passed if the layer
 is at the bottom of the stack, for this reason and to maintain
 some level of "compatibility" with TIEHANDLE classes it is passed last.
-  
+
 =over 4
 
 =item $class->PUSHED([$mode[,$fh]])
@@ -66,19 +66,33 @@ Should return an object or the class, or -1 on failure.  (Compare
 TIEHANDLE.)  The arguments are an optional mode string ("r", "w",
 "w+", ...) and a filehandle for the PerlIO layer below.  Mandatory.
 
-When layer is pushed as part of an C<open> call, C<PUSHED> will be called 
+When layer is pushed as part of an C<open> call, C<PUSHED> will be called
 I<before> the actual open occurs whether than be via C<OPEN>, C<SYSOPEN>,
-C<FDOPEN> or by letting lower layer do the open. 
+C<FDOPEN> or by letting lower layer do the open.
 
 =item $obj->POPPED([$fh])
 
 Optional - layer is about to be removed.
 
+=item $obj->UTF8($bellowFlag,[$fh])
+
+Optional - if present it will be called immediately after PUSHED has
+returned. It should return true value if the layer expects data to be
+UTF-8 encoded. If it returns true result is as if caller had done
+
+   ":via(YourClass):utf8"
+
+If not present of it it returns false, then stream is left with
+flag clear.
+The I<$bellowFlag> argument will be true if there is a layer below
+and that layer was expecting UTF-8.
+
+
 =item $obj->OPEN($path,$mode[,$fh])
 
 Optional - if not present lower layer does open.
 If present called for normal opens after layer is pushed.
-This function is subject to change as there is no easy way 
+This function is subject to change as there is no easy way
 to get lower layer to do open and then regain control.
 
 =item $obj->BINMODE([,$fh])
@@ -90,17 +104,17 @@ to pop the layer.
 =item $obj->FDOPEN($fd[,$fh])
 
 Optional - if not present lower layer does open.
-If present called for opens which pass a numeric file 
-descriptor after layer is pushed. 
-This function is subject to change as there is no easy way 
+If present called for opens which pass a numeric file
+descriptor after layer is pushed.
+This function is subject to change as there is no easy way
 to get lower layer to do open and then regain control.
 
 =item $obj->SYSOPEN($path,$imode,$perm,[,$fh])
 
 Optional - if not present lower layer does open.
-If present called for sysopen style opens which pass a numeric mode 
+If present called for sysopen style opens which pass a numeric mode
 and permissions after layer is pushed.
-This function is subject to change as there is no easy way 
+This function is subject to change as there is no easy way
 to get lower layer to do open and then regain control.
 
 =item $obj->FILENO($fh)
diff --git a/ext/PerlIO/via/via.xs b/ext/PerlIO/via/via.xs
index 4c50d5f..d95d631 100644
--- a/ext/PerlIO/via/via.xs
+++ b/ext/PerlIO/via/via.xs
@@ -35,6 +35,7 @@ typedef struct
  CV *mERROR;
  CV *mEOF;
  CV *BINMODE;
+ CV *UTF8;
 } PerlIOVia;
 
 #define MYMethod(x) #x,&s->x
@@ -164,6 +165,15 @@ PerlIOVia_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
 		else {
 		    goto push_failed;
 		}
+		modesv = (*PerlIONext(f) && (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_UTF8))
+                           ? &PL_sv_yes : &PL_sv_no;
+		result = PerlIOVia_method(aTHX_ f, MYMethod(UTF8), G_SCALAR, modesv, Nullsv);
+		if (result && SvTRUE(result)) {
+		    PerlIOBase(f)->flags |= ~PERLIO_F_UTF8;
+		}
+		else {
+		    PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
+		}
 		if (PerlIOVia_fetchmethod(aTHX_ s, MYMethod(FILL)) ==
 		    (CV *) - 1)
 		    PerlIOBase(f)->flags &= ~PERLIO_F_FASTGETS;