"Clean" implementation of binmode(FH)/":raw" identity.

New function table entry so all layer definitions need tweaking.
Extra function table entry allows a layer to remain on a binmode stack
New PerlIOBase_binmode allows easy implementation of default policy.

p4raw-id: //depot/perlio@17309

4 files changed, 24 insertions, 1 deletions

diff --git a/ext/PerlIO/Scalar/Scalar.xs b/ext/PerlIO/Scalar/Scalar.xs
index c904394693..314c0f317c 100644
--- a/ext/PerlIO/Scalar/Scalar.xs
+++ b/ext/PerlIO/Scalar/Scalar.xs
@@ -265,10 +265,11 @@ PerlIOScalar_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 PerlIO_funcs PerlIO_scalar = {
  "Scalar",
  sizeof(PerlIOScalar),
- PERLIO_K_BUFFERED,
+ PERLIO_K_BUFFERED|PERLIO_K_RAW,
  PerlIOScalar_pushed,
  PerlIOScalar_popped,
  PerlIOScalar_open,
+ PerlIOBase_binmode,
  PerlIOScalar_arg,
  PerlIOScalar_fileno,
  PerlIOScalar_dup,
diff --git a/ext/PerlIO/Via/Via.pm b/ext/PerlIO/Via/Via.pm
index 01805ca197..92614b4b0a 100644
--- a/ext/PerlIO/Via/Via.pm
+++ b/ext/PerlIO/Via/Via.pm
@@ -46,6 +46,12 @@ Optional - layer is about to be removed.
 
 Not yet in use.
 
+=item $obj->BINMODE([,$fh])
+
+Optional - if not available layer is popped on binmode($fh) or when C<:raw>
+is pushed. If present it should return 0 on success -1 on error and undef
+to pop the layer.
+
 =item $class->FDOPEN($fd)
 
 Not yet in use.
diff --git a/ext/PerlIO/Via/Via.xs b/ext/PerlIO/Via/Via.xs
index 6835f5804d..d1ebab2ae3 100644
--- a/ext/PerlIO/Via/Via.xs
+++ b/ext/PerlIO/Via/Via.xs
@@ -34,6 +34,7 @@ typedef struct
  CV *CLEARERR;
  CV *mERROR;
  CV *mEOF;
+ CV *BINMODE;
 } PerlIOVia;
 
 #define MYMethod(x) #x,&s->x
@@ -318,6 +319,19 @@ PerlIOVia_fileno(pTHX_ PerlIO *f)
 }
 
 IV
+PerlIOVia_binmode(pTHX_ PerlIO *f)
+{
+ PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
+ SV *result = PerlIOVia_method(aTHX_ f,MYMethod(BINMODE),G_SCALAR,Nullsv);
+ if (!result || !SvOK(result))
+  {
+   PerlIO_pop(aTHX_ f);
+   return 0;
+  }
+ return SvIV(result);
+}
+
+IV
 PerlIOVia_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
 {
  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
@@ -551,6 +565,7 @@ PerlIO_funcs PerlIO_object = {
  PerlIOVia_pushed,
  PerlIOVia_popped,
  PerlIOVia_open, /* NULL, */
+ PerlIOVia_binmode, /* NULL, */
  PerlIOVia_getarg,
  PerlIOVia_fileno,
  PerlIOVia_dup,
diff --git a/ext/PerlIO/encoding/encoding.xs b/ext/PerlIO/encoding/encoding.xs
index 2903f72d28..df911ed705 100644
--- a/ext/PerlIO/encoding/encoding.xs
+++ b/ext/PerlIO/encoding/encoding.xs
@@ -590,6 +590,7 @@ PerlIO_funcs PerlIO_encode = {
     PerlIOEncode_pushed,
     PerlIOEncode_popped,
     PerlIOBuf_open,
+    NULL, /* binmode - always pop */
     PerlIOEncode_getarg,
     PerlIOBase_fileno,
     PerlIOEncode_dup,