diff options
| -rw-r--r-- | ext/PerlIO/Scalar/Scalar.xs | 3 | ||||
| -rw-r--r-- | ext/PerlIO/Via/Via.pm | 6 | ||||
| -rw-r--r-- | ext/PerlIO/Via/Via.xs | 15 | ||||
| -rw-r--r-- | ext/PerlIO/encoding/encoding.xs | 1 | ||||
| -rw-r--r-- | makedef.pl | 1 | ||||
| -rw-r--r-- | perlio.c | 137 | ||||
| -rw-r--r-- | perliol.h | 2 | ||||
| -rw-r--r-- | pod/perliol.pod | 33 | ||||
| -rw-r--r-- | win32/win32io.c | 11 |
9 files changed, 139 insertions, 70 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, diff --git a/makedef.pl b/makedef.pl index e864f68229..e8122145bf 100644 --- a/makedef.pl +++ b/makedef.pl @@ -738,6 +738,7 @@ my @layer_syms = qw( PerlIOBase_error PerlIOBase_fileno PerlIOBase_pushed + PerlIOBase_binmode PerlIOBase_popped PerlIOBase_read PerlIOBase_setlinebuf @@ -1020,33 +1020,58 @@ PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg) } IV +PerlIOBase_binmode(pTHX_ PerlIO *f) +{ + if (PerlIOValid(f)) { + /* Is layer suitable for raw stream ? */ + if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) { + /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */ + PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; + } + else { + /* Not suitable - pop it */ + PerlIO_pop(aTHX_ f); + } + return 0; + } + return -1; +} + +IV PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg) { - /* - * Remove the dummy layer - */ - PerlIO_pop(aTHX_ f); - /* - * Pop back to bottom layer - */ + if (PerlIOValid(f)) { + PerlIO *t; + PerlIOl *l; + PerlIO_pop(aTHX_ f); /* Remove the dummy layer */ PerlIO_flush(f); - while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW)) { - if (*PerlIONext(f)) { - PerlIO_pop(aTHX_ f); + /* + * Strip all layers that are not suitable for a raw stream + */ + t = f; + while (t && (l = *t)) { + if (l->tab->Binmode) { + /* Has a handler - normal case */ + if ((*l->tab->Binmode)(aTHX_ f) == 0) { + if (*t == l) { + /* Layer still there - move down a layer */ + t = PerlIONext(t); + } + } + else { + return -1; + } } else { - /* - * Nothing bellow - push unix on top then remove it - */ - if (PerlIO_push(aTHX_ f, PerlIO_default_btm(), mode, arg)) { - PerlIO_pop(aTHX_ PerlIONext(f)); - } - break; + /* No handler - pop it */ + PerlIO_pop(aTHX_ t); } } - PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name); - return 0; + if (PerlIOValid(f)) { + PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name); + return 0; + } } return -1; } @@ -1105,22 +1130,17 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE; } else { - if (*f) { - /* Turn off UTF-8-ness, to undo UTF-8 locale effects - This may be too simplistic! - */ - PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; - } - /* FIXME?: Looking down the layer stack seems wrong, - but is a way of reaching past (say) an encoding layer - to flip CRLF-ness of the layer(s) below - */ + /* Fake 5.6 legacy of using this call to turn ON O_TEXT */ #ifdef PERLIO_USING_CRLF /* Legacy binmode only has meaning if O_TEXT has a value distinct from O_BINARY so we can look for it in mode. */ if (!(mode & O_BINARY)) { /* Text mode */ + /* FIXME?: Looking down the layer stack seems wrong, + but is a way of reaching past (say) an encoding layer + to flip CRLF-ness of the layer(s) below + */ while (*f) { /* Perhaps we should turn on bottom-most aware layer e.g. Ilya's idea that UNIX TTY could serve @@ -1143,31 +1163,10 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) return FALSE; } #endif - /* Either asked for BINMODE or that is normal on this platform - see if any CRLF aware layers are present and turn off the flag - and possibly remove layer. + /* Legacy binmode is now _defined_ as being equivalent to pushing :raw + So code that used to be here is now in PerlIORaw_pushed(). */ - while (*f) { - if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) { - if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) { - /* In text mode - flush any pending stuff and flip it */ - PerlIO_flush(f); - PerlIOBase(f)->flags &= ~PERLIO_F_CRLF; -#ifndef PERLIO_USING_CRLF - /* CRLF is unusual case - if this is just the :crlf layer pop it */ - if (PerlIOBase(f)->tab == &PerlIO_crlf) { - PerlIO_pop(aTHX_ f); - } -#endif - /* Normal case is only one layer doing this, so exit on first - abnormal case can always do multiple binmode calls - */ - return TRUE; - } - } - f = PerlIONext(f); - } - return TRUE; + return PerlIO_push(aTHX_ f, &PerlIO_raw, Nullch, Nullsv) ? TRUE : FALSE; } } @@ -2373,6 +2372,7 @@ PerlIO_funcs PerlIO_unix = { PerlIOUnix_pushed, PerlIOBase_popped, PerlIOUnix_open, + PerlIOBase_binmode, /* binmode */ NULL, PerlIOUnix_fileno, PerlIOUnix_dup, @@ -2923,10 +2923,11 @@ PerlIOStdio_fill(pTHX_ PerlIO *f) PerlIO_funcs PerlIO_stdio = { "stdio", sizeof(PerlIOStdio), - PERLIO_K_BUFFERED, + PERLIO_K_BUFFERED|PERLIO_K_RAW, PerlIOBase_pushed, PerlIOBase_popped, PerlIOStdio_open, + PerlIOBase_binmode, /* binmode */ NULL, PerlIOStdio_fileno, PerlIOStdio_dup, @@ -3473,10 +3474,11 @@ PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) PerlIO_funcs PerlIO_perlio = { "perlio", sizeof(PerlIOBuf), - PERLIO_K_BUFFERED, + PERLIO_K_BUFFERED|PERLIO_K_RAW, PerlIOBuf_pushed, PerlIOBuf_popped, PerlIOBuf_open, + PerlIOBase_binmode, /* binmode */ NULL, PerlIOBase_fileno, PerlIOBuf_dup, @@ -3594,10 +3596,11 @@ PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) PerlIO_funcs PerlIO_pending = { "pending", sizeof(PerlIOBuf), - PERLIO_K_BUFFERED, + PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */ PerlIOPending_pushed, PerlIOBuf_popped, NULL, + PerlIOBase_binmode, /* binmode */ NULL, PerlIOBase_fileno, PerlIOBuf_dup, @@ -3884,13 +3887,30 @@ PerlIOCrlf_flush(pTHX_ PerlIO *f) return PerlIOBuf_flush(aTHX_ f); } +IV +PerlIOCrlf_binmode(pTHX_ PerlIO *f) +{ + if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) { + /* In text mode - flush any pending stuff and flip it */ + PerlIOBase(f)->flags &= ~PERLIO_F_CRLF; +#ifndef PERLIO_USING_CRLF + /* CRLF is unusual case - if this is just the :crlf layer pop it */ + if (PerlIOBase(f)->tab == &PerlIO_crlf) { + PerlIO_pop(aTHX_ f); + } +#endif + } + return 0; +} + PerlIO_funcs PerlIO_crlf = { "crlf", sizeof(PerlIOCrlf), - PERLIO_K_BUFFERED | PERLIO_K_CANCRLF, + PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW, PerlIOCrlf_pushed, PerlIOBuf_popped, /* popped */ PerlIOBuf_open, + PerlIOCrlf_binmode, /* binmode */ NULL, PerlIOBase_fileno, PerlIOBuf_dup, @@ -4202,10 +4222,11 @@ PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) PerlIO_funcs PerlIO_mmap = { "mmap", sizeof(PerlIOMmap), - PERLIO_K_BUFFERED, + PERLIO_K_BUFFERED|PERLIO_K_RAW, PerlIOBuf_pushed, PerlIOBuf_popped, PerlIOBuf_open, + PerlIOBase_binmode, /* binmode */ NULL, PerlIOBase_fileno, PerlIOMmap_dup, @@ -24,6 +24,7 @@ struct _PerlIO_funcs { const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args); + IV (*Binmode)(pTHX_ PerlIO *f); SV *(*Getarg) (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags); IV (*Fileno) (pTHX_ PerlIO *f); PerlIO *(*Dup) (pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags); @@ -125,6 +126,7 @@ extern IV PerlIOBase_fileno(pTHX_ PerlIO *f); extern PerlIO *PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags); extern IV PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg); extern IV PerlIOBase_popped(pTHX_ PerlIO *f); +extern IV PerlIOBase_binmode(pTHX_ PerlIO *f); extern SSize_t PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count); extern SSize_t PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count); diff --git a/pod/perliol.pod b/pod/perliol.pod index b4c8069723..81cbab17e7 100644 --- a/pod/perliol.pod +++ b/pod/perliol.pod @@ -98,6 +98,7 @@ same as the public C<PerlIO_xxxxx> functions: int fd, int imode, int perm, PerlIO *old, int narg, SV **args); + IV (*Binmode)(pTHX_ PerlIO *f); SV * (*Getarg)(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) IV (*Fileno)(pTHX_ PerlIO *f); PerlIO * (*Dup)(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) @@ -346,24 +347,31 @@ The size of the per-instance data structure, e.g.: IV kind; - XXX: explain all the available flags here - =over 4 =item * PERLIO_K_BUFFERED +The layer is buffered. + +=item * PERLIO_K_RAW + +The layer is acceptable to have in a binmode(FH) stack - i.e. it does not +(or will configure itself not to) transform bytes passing through it. + =item * PERLIO_K_CANCRLF +Layer can translate between "\n" and CRLF line ends. + =item * PERLIO_K_FASTGETS +Layer allows buffer snooping. + =item * PERLIO_K_MULTIARG Used when the layer's open() accepts more arguments than usual. The extra arguments should come not before the C<MODE> argument. When this flag is used it's up to the layer to validate the args. -=item * PERLIO_K_RAW - =back =item Pushed @@ -455,6 +463,16 @@ then push itself on top if that succeeds. Returns C<NULL> on failure. +=item Binmode + + IV (*Binmode)(pTHX_ PerlIO *f); + +Optional. Used when C<:raw> layer is pushed (explicitly or as a result +of binmode(FH)). If not present layer will be popped. If present +should configure layer as binary (or pop itself) and return 0. +If it returns -1 for error C<binmode> will fail with layer +still on the stack. + =item Getarg SV * (*Getarg)(pTHX_ PerlIO *f, @@ -700,8 +718,11 @@ and so resumes reading from layer below.) =item "raw" A dummy layer which never exists on the layer stack. Instead when -"pushed" it actually pops the stack(!), removing itself, and any other -layers until it reaches a layer with the class C<PERLIO_K_RAW> bit set. +"pushed" it actually pops the stack removing itself, it then calls +Binmode function table entry on all the layers in the stack - normally +this (via PerlIOBase_binmode) removes any layers which do not have +C<PERLIO_K_RAW> bit set. Layers can modify that behaviour by defining +their own Binmode entry. =item "utf8" diff --git a/win32/win32io.c b/win32/win32io.c index 3cf31c5629..7997658f4e 100644 --- a/win32/win32io.c +++ b/win32/win32io.c @@ -288,9 +288,9 @@ PerlIOWin32_close(pTHX_ PerlIO *f) PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); if (s->refcnt == 1) { - IV code = 0; + IV code = 0; #if 0 - /* This does not do pipes etc. correctly */ + /* This does not do pipes etc. correctly */ if (!CloseHandle(s->h)) { s->h = INVALID_HANDLE_VALUE; @@ -309,15 +309,15 @@ PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags) { PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32); HANDLE proc = GetCurrentProcess(); - HANDLE new; + HANDLE new; if (DuplicateHandle(proc, os->h, proc, &new, 0, FALSE, DUPLICATE_SAME_ACCESS)) { char mode[8]; int fd = win32_open_osfhandle((intptr_t) new, PerlIOUnix_oflags(PerlIO_modestr(o,mode))); - if (fd >= 0) + if (fd >= 0) { f = PerlIOBase_dup(aTHX_ f, o, params, flags); - if (f) + if (f) { PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32); fs->h = new; @@ -347,6 +347,7 @@ PerlIO_funcs PerlIO_win32 = { PerlIOWin32_pushed, PerlIOWin32_popped, PerlIOWin32_open, + PerlIOBase_binmode, NULL, /* getarg */ PerlIOWin32_fileno, PerlIOWin32_dup, |