This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Beginings of PerlIO_dup support (unstable)
authorNick Ing-Simmons <nik@tiuk.ti.com>
Mon, 15 Oct 2001 20:27:53 +0000 (20:27 +0000)
committerNick Ing-Simmons <nik@tiuk.ti.com>
Mon, 15 Oct 2001 20:27:53 +0000 (20:27 +0000)
p4raw-id: //depot/perlio@12447

perlio.c
perliol.h

index eb32a04..c849dd2 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -1,13 +1,13 @@
 /*
- * perlio.c Copyright (c) 1996-2001, Nick Ing-Simmons You may distribute 
+ * perlio.c Copyright (c) 1996-2001, Nick Ing-Simmons You may distribute
  * under the terms of either the GNU General Public License or the
- * Artistic License, as specified in the README file. 
+ * Artistic License, as specified in the README file.
  */
 
 /*
- * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get 
+ * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
  * at the dispatch tables, even when we do not need it for other reasons.
- * Invent a dSYS macro to abstract this out 
+ * Invent a dSYS macro to abstract this out
  */
 #ifdef PERL_IMPLICIT_SYS
 #define dSYS dTHX
@@ -25,7 +25,7 @@
 #define PERLIO_NOT_STDIO 0
 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
 /*
- * #define PerlIO FILE 
+ * #define PerlIO FILE
  */
 #endif
 /*
@@ -49,7 +49,7 @@ int
 perlsio_binmode(FILE *fp, int iotype, int mode)
 {
     /*
-     * This used to be contents of do_binmode in doio.c 
+     * This used to be contents of do_binmode in doio.c
      */
 #ifdef DOSISH
 #  if defined(atarist) || defined(__MINT__)
@@ -70,11 +70,11 @@ perlsio_binmode(FILE *fp, int iotype, int mode)
 #endif
 #    if defined(WIN32) && defined(__BORLANDC__)
        /*
-        * The translation mode of the stream is maintained independent of 
+        * The translation mode of the stream is maintained independent of
         * the translation mode of the fd in the Borland RTL (heavy
-        * digging through their runtime sources reveal).  User has to set 
+        * digging through their runtime sources reveal).  User has to set
         * the mode explicitly for the stream (though they don't document
-        * this anywhere). GSAR 97-5-24 
+        * this anywhere). GSAR 97-5-24
         */
        fseek(fp, 0L, 0);
        if (mode & O_BINARY)
@@ -108,7 +108,7 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
     }
     Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
     /*
-     * NOTREACHED 
+     * NOTREACHED
      */
     return -1;
 }
@@ -129,7 +129,7 @@ PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
 }
 
 /*
- * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries 
+ * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
  */
 
 PerlIO *
@@ -190,9 +190,9 @@ PerlIO_init(void)
 {
     /*
      * Does nothing (yet) except force this file to be included in perl
-     * binary. That allows this file to force inclusion of other functions 
+     * binary. That allows this file to force inclusion of other functions
      * that may be required by loadable extensions e.g. for
-     * FileHandle::tmpfile 
+     * FileHandle::tmpfile
      */
 }
 
@@ -212,7 +212,7 @@ PerlIO_tmpfile(void)
 
 /*
  * This section is just to make sure these functions get pulled in from
- * libsfio.a 
+ * libsfio.a
  */
 
 #undef PerlIO_tmpfile
@@ -228,13 +228,13 @@ PerlIO_init(void)
     /*
      * Force this file to be included in perl binary. Which allows this
      * file to force inclusion of other functions that may be required by
-     * loadable extensions e.g. for FileHandle::tmpfile 
+     * loadable extensions e.g. for FileHandle::tmpfile
      */
 
     /*
-     * Hack sfio does its own 'autoflush' on stdout in common cases. Flush 
+     * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
      * results in a lot of lseek()s to regular files and lot of small
-     * writes to pipes. 
+     * writes to pipes.
      */
     sfset(sfstdout, SF_SHARE, 0);
 }
@@ -264,14 +264,14 @@ PerlIO_findFILE(PerlIO *pio)
 #else                          /* USE_SFIO */
 /*======================================================================================*/
 /*
- * Implement all the PerlIO interface ourselves. 
+ * Implement all the PerlIO interface ourselves.
  */
 
 #include "perliol.h"
 
 /*
  * We _MUST_ have <unistd.h> if we are using lseek() and may have large
- * files 
+ * files
  */
 #ifdef I_UNISTD
 #include <unistd.h>
@@ -320,11 +320,11 @@ PerlIO_debug(const char *fmt, ...)
 /*--------------------------------------------------------------------------------------*/
 
 /*
- * Inner level routines 
+ * Inner level routines
  */
 
 /*
- * Table of pointers to the PerlIO structs (malloc'ed) 
+ * Table of pointers to the PerlIO structs (malloc'ed)
  */
 PerlIO *_perlio = NULL;
 #define PERLIO_TABLE_SIZE 64
@@ -335,7 +335,7 @@ PerlIO *
 PerlIO_allocate(pTHX)
 {
     /*
-     * Find a free slot in the table, allocating new table as necessary 
+     * Find a free slot in the table, allocating new table as necessary
      */
     PerlIO **last;
     PerlIO *f;
@@ -478,7 +478,7 @@ PerlIO_pop(pTHX_ PerlIO *f)
            /*
             * If popped returns non-zero do not free its layer structure
             * it has either done so itself, or it is shared and still in
-            * use 
+            * use
             */
            if ((*l->tab->Popped) (f) != 0)
                return;
@@ -490,7 +490,7 @@ PerlIO_pop(pTHX_ PerlIO *f)
 
 /*--------------------------------------------------------------------------------------*/
 /*
- * XS Interface for perl code 
+ * XS Interface for perl code
  */
 
 PerlIO_funcs *
@@ -512,7 +512,7 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
        SV *layer = newSVpvn(name, len);
        ENTER;
        /*
-        * The two SVs are magically freed by load_module 
+        * The two SVs are magically freed by load_module
         */
        Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
        LEAVE;
@@ -653,7 +653,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
                    /*
                     * Message is consistent with how attribute lists are
                     * passed. Even though this means "foo : : bar" is
-                    * seen as an invalid separator character.  
+                    * seen as an invalid separator character.
                     */
                    char q = ((*s == '\'') ? '"' : '\'');
                    Perl_warn(aTHX_
@@ -681,13 +681,13 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
                            /*
                             * It's a nul terminated string, not allowed
                             * to \ the terminating null. Anything other
-                            * character is passed over.  
+                            * character is passed over.
                             */
                            if (*e++) {
                                break;
                            }
                            /*
-                            * Drop through 
+                            * Drop through
                             */
                        case '\0':
                            e--;
@@ -697,7 +697,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
                            return -1;
                        default:
                            /*
-                            * boring.  
+                            * boring.
                             */
                            break;
                        }
@@ -870,12 +870,12 @@ IV
 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
 {
     /*
-     * Remove the dummy layer 
+     * Remove the dummy layer
      */
     dTHX;
     PerlIO_pop(aTHX_ f);
     /*
-     * Pop back to bottom layer 
+     * Pop back to bottom layer
      */
     if (f && *f) {
        PerlIO_flush(f);
@@ -885,7 +885,7 @@ PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
            }
            else {
                /*
-                * Nothing bellow - push unix on top then remove it 
+                * Nothing bellow - push unix on top then remove it
                 */
                if (PerlIO_push(aTHX_ f, PerlIO_default_btm(), mode, arg)) {
                    PerlIO_pop(aTHX_ PerlIONext(f));
@@ -936,7 +936,7 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 
 /*--------------------------------------------------------------------------------------*/
 /*
- * Given the abstraction above the public API functions 
+ * Given the abstraction above the public API functions
  */
 
 int
@@ -1024,7 +1024,7 @@ PerlIO_context_layers(pTHX_ const char *mode)
 {
     const char *type = NULL;
     /*
-     * Need to supply default layer info from open.pm 
+     * Need to supply default layer info from open.pm
      */
     if (PL_curcop) {
        SV *layers = PL_curcop->cop_io;
@@ -1033,7 +1033,7 @@ PerlIO_context_layers(pTHX_ const char *mode)
            type = SvPV(layers, len);
            if (type && mode[0] != 'r') {
                /*
-                * Skip to write part 
+                * Skip to write part
                 */
                const char *s = strchr(type, 0);
                if (s && (s - type) < len) {
@@ -1049,13 +1049,13 @@ static PerlIO_funcs *
 PerlIO_layer_from_ref(pTHX_ SV *sv)
 {
     /*
-     * For any scalar type load the handler which is bundled with perl 
+     * For any scalar type load the handler which is bundled with perl
      */
     if (SvTYPE(sv) < SVt_PVAV)
        return PerlIO_find_layer(aTHX_ "Scalar", 6, 1);
 
     /*
-     * For other types allow if layer is known but don't try and load it 
+     * For other types allow if layer is known but don't try and load it
      */
     switch (SvTYPE(sv)) {
     case SVt_PVAV:
@@ -1081,8 +1081,8 @@ PerlIO_resolve_layers(pTHX_ const char *layers,
     if (narg) {
        SV *arg = *args;
        /*
-        * If it is a reference but not an object see if we have a handler 
-        * for it 
+        * If it is a reference but not an object see if we have a handler
+        * for it
         */
        if (SvROK(arg) && !sv_isobject(arg)) {
            PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
@@ -1092,9 +1092,9 @@ PerlIO_resolve_layers(pTHX_ const char *layers,
                incdef = 0;
            }
            /*
-            * Don't fail if handler cannot be found :Via(...) etc. may do 
+            * Don't fail if handler cannot be found :Via(...) etc. may do
             * something sensible else we will just stringfy and open
-            * resulting string. 
+            * resulting string.
             */
        }
     }
@@ -1141,8 +1141,8 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
        PerlIO_funcs *tab = NULL;
        if (f && *f) {
            /*
-            * This is "reopen" - it is not tested as perl does not use it 
-            * yet 
+            * This is "reopen" - it is not tested as perl does not use it
+            * yet
             */
            PerlIOl *l = *f;
            layera = PerlIO_list_alloc();
@@ -1158,7 +1158,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
            layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
        }
        /*
-        * Start at "top" of layer stack 
+        * Start at "top" of layer stack
         */
        n = layera->cur - 1;
        while (n >= 0) {
@@ -1171,7 +1171,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
        }
        if (tab) {
            /*
-            * Found that layer 'n' can do opens - call it 
+            * Found that layer 'n' can do opens - call it
             */
            PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
                         tab->name, layers, mode, fd, imode, perm, f, narg,
@@ -1182,7 +1182,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
                if (n + 1 < layera->cur) {
                    /*
                     * More layers above the one that we used to open -
-                    * apply them now 
+                    * apply them now
                     */
                    if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1)
                        != 0) {
@@ -1311,7 +1311,7 @@ PerlIO_flush(PerlIO *f)
         * errorneous input? Maybe some magical value (PerlIO*
         * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
         * things on fflush(NULL), but should we be bound by their design
-        * decisions? --jhi 
+        * decisions? --jhi
         */
        PerlIO **table = &_perlio;
        int code = 0;
@@ -1517,7 +1517,7 @@ PerlIO_set_ptrcnt(PerlIO *f, STDCHAR * ptr, int cnt)
 
 /*--------------------------------------------------------------------------------------*/
 /*
- * utf8 and raw dummy layers 
+ * utf8 and raw dummy layers
  */
 
 IV
@@ -1632,7 +1632,7 @@ PerlIO_funcs PerlIO_raw = {
 /*--------------------------------------------------------------------------------------*/
 /*--------------------------------------------------------------------------------------*/
 /*
- * "Methods" of the "base class" 
+ * "Methods" of the "base class"
  */
 
 IV
@@ -1744,7 +1744,7 @@ PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
 {
     dTHX;
     /*
-     * Save the position as current head considers it 
+     * Save the position as current head considers it
      */
     Off_t old = PerlIO_tell(f);
     SSize_t done;
@@ -1848,7 +1848,7 @@ PerlIOBase_setlinebuf(PerlIO *f)
 
 /*--------------------------------------------------------------------------------------*/
 /*
- * Bottom-most level for UNIX-like case 
+ * Bottom-most level for UNIX-like case
  */
 
 typedef struct {
@@ -1903,7 +1903,7 @@ PerlIOUnix_oflags(const char *mode)
        mode++;
     }
     /*
-     * Always open in binary mode 
+     * Always open in binary mode
      */
     oflags |= O_BINARY;
     if (*mode || oflags == -1) {
@@ -1927,9 +1927,9 @@ PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
        PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
        s->fd = PerlIO_fileno(PerlIONext(f));
        /*
-        * XXX could (or should) we retrieve the oflags from the open file 
+        * XXX could (or should) we retrieve the oflags from the open file
         * handle rather than believing the "mode" we are passed in? XXX
-        * Should the value on NULL mode be 0 or -1? 
+        * Should the value on NULL mode be 0 or -1?
         */
        s->oflags = mode ? PerlIOUnix_oflags(mode) : -1;
     }
@@ -1977,13 +1977,55 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
     else {
        if (f) {
            /*
-            * FIXME: pop layers ??? 
+            * FIXME: pop layers ???
             */
        }
        return NULL;
     }
 }
 
+PerlIO *
+PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, clone_params *param)
+{
+    PerlIO_funcs *self = PerlIOBase(o)->tab;
+    SV *arg = Nullsv;
+    char buf[8];
+    if (self->Getarg) {
+       arg = (*self->Getarg)(o);
+#ifdef sv_dup
+       if (arg) {
+           arg = sv_dup(arg, param);
+       }
+#endif
+    }
+    if (!f) {
+       f = PerlIO_allocate(aTHX);
+    }
+    f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
+    return f;
+}
+
+PerlIO *
+PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, clone_params *param)
+{
+    PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
+    int fd = PerlLIO_dup(os->fd);
+    if (fd >= 0) {
+       f = PerlIOBase_dup(aTHX_ f, o, param);
+       if (f) {
+           /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
+           PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
+           s->fd = fd;
+           return f;
+       }
+       else {
+           PerlLIO_close(fd);
+       }
+    }
+    return NULL;
+}
+
+
 SSize_t
 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
 {
@@ -2037,6 +2079,7 @@ PerlIOUnix_tell(PerlIO *f)
     return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
 }
 
+
 IV
 PerlIOUnix_close(PerlIO *f)
 {
@@ -2065,6 +2108,7 @@ PerlIO_funcs PerlIO_unix = {
     PerlIOUnix_open,
     NULL,
     PerlIOUnix_fileno,
+    PerlIOUnix_dup,
     PerlIOUnix_read,
     PerlIOBase_unread,
     PerlIOUnix_write,
@@ -2086,7 +2130,7 @@ PerlIO_funcs PerlIO_unix = {
 
 /*--------------------------------------------------------------------------------------*/
 /*
- * stdio as a layer 
+ * stdio as a layer
  */
 
 typedef struct {
@@ -2116,7 +2160,7 @@ PerlIOStdio_mode(const char *mode, char *tmode)
 }
 
 /*
- * This isn't used yet ... 
+ * This isn't used yet ...
  */
 IV
 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
@@ -2237,7 +2281,7 @@ PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
        STDCHAR *buf = (STDCHAR *) vbuf;
        /*
         * Perl is expecting PerlIO_getc() to fill the buffer Linux's
-        * stdio does not do that for fread() 
+        * stdio does not do that for fread()
         */
        int ch = PerlSIO_fgetc(s);
        if (ch != EOF) {
@@ -2325,12 +2369,12 @@ PerlIOStdio_flush(PerlIO *f)
 #if 0
        /*
         * FIXME: This discards ungetc() and pre-read stuff which is not
-        * right if this is just a "sync" from a layer above Suspect right 
+        * right if this is just a "sync" from a layer above Suspect right
         * design is to do _this_ but not have layer above flush this
-        * layer read-to-read 
+        * layer read-to-read
         */
        /*
-        * Not writeable - sync by attempting a seek 
+        * Not writeable - sync by attempting a seek
         */
        int err = errno;
        if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
@@ -2347,7 +2391,7 @@ PerlIOStdio_fill(PerlIO *f)
     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
     int c;
     /*
-     * fflush()ing read-only streams can cause trouble on some stdio-s 
+     * fflush()ing read-only streams can cause trouble on some stdio-s
      */
     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
        if (PerlSIO_fflush(stdio) != 0)
@@ -2442,7 +2486,7 @@ PerlIOStdio_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
 #endif
 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
        /*
-        * Setting ptr _does_ change cnt - we are done 
+        * Setting ptr _does_ change cnt - we are done
         */
        return;
 #endif
@@ -2451,7 +2495,7 @@ PerlIOStdio_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
 #endif                         /* STDIO_PTR_LVALUE */
     }
     /*
-     * Now (or only) set cnt 
+     * Now (or only) set cnt
      */
 #ifdef STDIO_CNT_LVALUE
     PerlSIO_set_cnt(stdio, cnt);
@@ -2468,6 +2512,12 @@ PerlIOStdio_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
 
 #endif
 
+PerlIO *
+PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, clone_params *param)
+{
+ return NULL;
+}
+
 PerlIO_funcs PerlIO_stdio = {
     "stdio",
     sizeof(PerlIOStdio),
@@ -2477,6 +2527,7 @@ PerlIO_funcs PerlIO_stdio = {
     PerlIOStdio_open,
     NULL,
     PerlIOStdio_fileno,
+    PerlIOStdio_dup,
     PerlIOStdio_read,
     PerlIOStdio_unread,
     PerlIOStdio_write,
@@ -2551,7 +2602,7 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f)
 
 /*--------------------------------------------------------------------------------------*/
 /*
- * perlio buffer layer 
+ * perlio buffer layer
  */
 
 IV
@@ -2595,7 +2646,7 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
        if (*mode == 'I') {
            init = 1;
            /*
-            * mode++; 
+            * mode++;
             */
        }
        f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
@@ -2605,13 +2656,13 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
            fd = PerlIO_fileno(f);
 #if O_BINARY != O_TEXT
            /*
-            * do something about failing setmode()? --jhi 
+            * do something about failing setmode()? --jhi
             */
            PerlLIO_setmode(fd, O_BINARY);
 #endif
            if (init && fd == 2) {
                /*
-                * Initial stderr is unbuffered 
+                * Initial stderr is unbuffered
                 */
                PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
            }
@@ -2622,7 +2673,7 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 
 /*
  * This "flush" is akin to sfio's sync in that it handles files in either
- * read or write state 
+ * read or write state
  */
 IV
 PerlIOBuf_flush(PerlIO *f)
@@ -2631,7 +2682,7 @@ PerlIOBuf_flush(PerlIO *f)
     int code = 0;
     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
        /*
-        * write() the buffer 
+        * write() the buffer
         */
        STDCHAR *buf = b->buf;
        STDCHAR *p = buf;
@@ -2652,12 +2703,12 @@ PerlIOBuf_flush(PerlIO *f)
     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
        STDCHAR *buf = PerlIO_get_base(f);
        /*
-        * Note position change 
+        * Note position change
         */
        b->posn += (b->ptr - buf);
        if (b->ptr < b->end) {
            /*
-            * We did not consume all of it 
+            * We did not consume all of it
             */
            if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) == 0) {
                b->posn = PerlIO_tell(PerlIONext(f));
@@ -2667,7 +2718,7 @@ PerlIOBuf_flush(PerlIO *f)
     b->ptr = b->end = b->buf;
     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
     /*
-     * FIXME: Is this right for read case ? 
+     * FIXME: Is this right for read case ?
      */
     if (PerlIO_flush(PerlIONext(f)) != 0)
        code = -1;
@@ -2684,7 +2735,7 @@ PerlIOBuf_fill(PerlIO *f)
      * FIXME: doing the down-stream flush is a bad idea if it causes
      * pre-read data in stdio buffer to be discarded but this is too
      * simplistic - as it skips _our_ hosekeeping and breaks tell tests.
-     * if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { } 
+     * if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { }
      */
     if (PerlIO_flush(f) != 0)
        return -1;
@@ -2700,7 +2751,7 @@ PerlIOBuf_fill(PerlIO *f)
         * Layer below is also buffered We do _NOT_ want to call its
         * ->Read() because that will loop till it gets what we asked for
         * which may hang on a pipe etc. Instead take anything it has to
-        * hand, or ask it to fill _once_. 
+        * hand, or ask it to fill _once_.
         */
        avail = PerlIO_get_cnt(n);
        if (avail <= 0) {
@@ -2763,27 +2814,27 @@ PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
        if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
            /*
             * Buffer is already a read buffer, we can overwrite any chars
-            * which have been read back to buffer start 
+            * which have been read back to buffer start
             */
            avail = (b->ptr - b->buf);
        }
        else {
            /*
             * Buffer is idle, set it up so whole buffer is available for
-            * unread 
+            * unread
             */
            avail = b->bufsiz;
            b->end = b->buf + avail;
            b->ptr = b->end;
            PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
            /*
-            * Buffer extends _back_ from where we are now 
+            * Buffer extends _back_ from where we are now
             */
            b->posn -= b->bufsiz;
        }
        if (avail > (SSize_t) count) {
            /*
-            * If we have space for more than count, just move count 
+            * If we have space for more than count, just move count
             */
            avail = count;
        }
@@ -2792,7 +2843,7 @@ PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
            buf -= avail;
            /*
             * In simple stdio-like ungetc() case chars will be already
-            * there 
+            * there
             */
            if (buf != b->ptr) {
                Copy(buf, b->ptr, avail, STDCHAR);
@@ -2870,12 +2921,12 @@ PerlIOBuf_tell(PerlIO *f)
 {
     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
     /*
-     * b->posn is file position where b->buf was read, or will be written 
+     * b->posn is file position where b->buf was read, or will be written
      */
     Off_t posn = b->posn;
     if (b->buf) {
        /*
-        * If buffer is valid adjust position by amount in buffer 
+        * If buffer is valid adjust position by amount in buffer
         */
        posn += (b->ptr - b->buf);
     }
@@ -2958,6 +3009,14 @@ PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
 }
 
+PerlIO *
+PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, clone_params *param)
+{
+ return NULL;
+}
+
+
+
 PerlIO_funcs PerlIO_perlio = {
     "perlio",
     sizeof(PerlIOBuf),
@@ -2967,6 +3026,7 @@ PerlIO_funcs PerlIO_perlio = {
     PerlIOBuf_open,
     NULL,
     PerlIOBase_fileno,
+    PerlIOBuf_dup,
     PerlIOBuf_read,
     PerlIOBuf_unread,
     PerlIOBuf_write,
@@ -2988,14 +3048,14 @@ PerlIO_funcs PerlIO_perlio = {
 
 /*--------------------------------------------------------------------------------------*/
 /*
- * Temp layer to hold unread chars when cannot do it any other way 
+ * Temp layer to hold unread chars when cannot do it any other way
  */
 
 IV
 PerlIOPending_fill(PerlIO *f)
 {
     /*
-     * Should never happen 
+     * Should never happen
      */
     PerlIO_flush(f);
     return 0;
@@ -3005,7 +3065,7 @@ IV
 PerlIOPending_close(PerlIO *f)
 {
     /*
-     * A tad tricky - flush pops us, then we close new top 
+     * A tad tricky - flush pops us, then we close new top
      */
     PerlIO_flush(f);
     return PerlIO_close(f);
@@ -3015,7 +3075,7 @@ IV
 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
 {
     /*
-     * A tad tricky - flush pops us, then we seek new top 
+     * A tad tricky - flush pops us, then we seek new top
      */
     PerlIO_flush(f);
     return PerlIO_seek(f, offset, whence);
@@ -3052,8 +3112,8 @@ PerlIOPending_pushed(PerlIO *f, const char *mode, SV *arg)
     IV code = PerlIOBase_pushed(f, mode, arg);
     PerlIOl *l = PerlIOBase(f);
     /*
-     * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets() 
-     * etc. get muddled when it changes mid-string when we auto-pop. 
+     * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
+     * etc. get muddled when it changes mid-string when we auto-pop.
      */
     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
        (PerlIOBase(PerlIONext(f))->
@@ -3088,6 +3148,7 @@ PerlIO_funcs PerlIO_pending = {
     NULL,
     NULL,
     PerlIOBase_fileno,
+    PerlIOBuf_dup,
     PerlIOPending_read,
     PerlIOBuf_unread,
     PerlIOBuf_write,
@@ -3113,12 +3174,12 @@ PerlIO_funcs PerlIO_pending = {
 /*
  * crlf - translation On read translate CR,LF to "\n" we do this by
  * overriding ptr/cnt entries to hand back a line at a time and keeping a
- * record of which nl we "lied" about. On write translate "\n" to CR,LF 
+ * record of which nl we "lied" about. On write translate "\n" to CR,LF
  */
 
 typedef struct {
     PerlIOBuf base;            /* PerlIOBuf stuff */
-    STDCHAR *nl;               /* Position of crlf we "lied" about in the 
+    STDCHAR *nl;               /* Position of crlf we "lied" about in the
                                 * buffer */
 } PerlIOCrlf;
 
@@ -3208,7 +3269,7 @@ PerlIOCrlf_get_cnt(PerlIO *f)
                    }
                    else {
                        /*
-                        * Not CR,LF but just CR 
+                        * Not CR,LF but just CR
                         */
                        nl++;
                        goto scan;
@@ -3216,12 +3277,12 @@ PerlIOCrlf_get_cnt(PerlIO *f)
                }
                else {
                    /*
-                    * Blast - found CR as last char in buffer 
+                    * Blast - found CR as last char in buffer
                     */
                    if (b->ptr < nl) {
                        /*
                         * They may not care, defer work as long as
-                        * possible 
+                        * possible
                         */
                        return (nl - b->ptr);
                    }
@@ -3241,7 +3302,7 @@ PerlIOCrlf_get_cnt(PerlIO *f)
                        if (code == 0)
                            goto test;  /* fill() call worked */
                        /*
-                        * CR at EOF - just fall through 
+                        * CR at EOF - just fall through
                         */
                    }
                }
@@ -3272,7 +3333,7 @@ PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
     }
     else {
        /*
-        * Test code - delete when it works ... 
+        * Test code - delete when it works ...
         */
        STDCHAR *chk;
        if (c->nl)
@@ -3294,7 +3355,7 @@ PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
     if (c->nl) {
        if (ptr > c->nl) {
            /*
-            * They have taken what we lied about 
+            * They have taken what we lied about
             */
            *(c->nl) = 0xd;
            c->nl = NULL;
@@ -3325,7 +3386,7 @@ PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
                if (*buf == '\n') {
                    if ((b->ptr + 2) > eptr) {
                        /*
-                        * Not room for both 
+                        * Not room for both
                         */
                        PerlIO_flush(f);
                        break;
@@ -3376,6 +3437,7 @@ PerlIO_funcs PerlIO_crlf = {
     PerlIOBuf_open,
     NULL,
     PerlIOBase_fileno,
+    PerlIOBuf_dup,
     PerlIOBuf_read,            /* generic read works with ptr/cnt lies
                                 * ... */
     PerlIOCrlf_unread,         /* Put CR,LF in buffer for each '\n' */
@@ -3399,7 +3461,7 @@ PerlIO_funcs PerlIO_crlf = {
 #ifdef HAS_MMAP
 /*--------------------------------------------------------------------------------------*/
 /*
- * mmap as "buffer" layer 
+ * mmap as "buffer" layer
  */
 
 typedef struct {
@@ -3469,7 +3531,7 @@ PerlIOMmap_map(PerlIO *f)
                if (b->posn < 0) {
                    /*
                     * This is a hack - should never happen - open should
-                    * have set it ! 
+                    * have set it !
                     */
                    b->posn = PerlIO_tell(PerlIONext(f));
                }
@@ -3534,13 +3596,13 @@ PerlIOMmap_get_base(PerlIO *f)
     PerlIOBuf *b = &m->base;
     if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
        /*
-        * Already have a readbuffer in progress 
+        * Already have a readbuffer in progress
         */
        return b->buf;
     }
     if (b->buf) {
        /*
-        * We have a write buffer or flushed PerlIOBuf read buffer 
+        * We have a write buffer or flushed PerlIOBuf read buffer
         */
        m->bbuf = b->buf;       /* save it in case we need it again */
        b->buf = NULL;          /* Clear to trigger below */
@@ -3549,7 +3611,7 @@ PerlIOMmap_get_base(PerlIO *f)
        PerlIOMmap_map(f);      /* Try and map it */
        if (!b->buf) {
            /*
-            * Map did not work - recover PerlIOBuf buffer if we have one 
+            * Map did not work - recover PerlIOBuf buffer if we have one
             */
            b->buf = m->bbuf;
        }
@@ -3575,11 +3637,11 @@ PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
     }
     if (m->len) {
        /*
-        * Loose the unwritable mapped buffer 
+        * Loose the unwritable mapped buffer
         */
        PerlIO_flush(f);
        /*
-        * If flush took the "buffer" see if we have one from before 
+        * If flush took the "buffer" see if we have one from before
         */
        if (!b->buf && m->bbuf)
            b->buf = m->bbuf;
@@ -3598,14 +3660,14 @@ PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
     PerlIOBuf *b = &m->base;
     if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
        /*
-        * No, or wrong sort of, buffer 
+        * No, or wrong sort of, buffer
         */
        if (m->len) {
            if (PerlIOMmap_unmap(f) != 0)
                return 0;
        }
        /*
-        * If unmap took the "buffer" see if we have one from before 
+        * If unmap took the "buffer" see if we have one from before
         */
        if (!b->buf && m->bbuf)
            b->buf = m->bbuf;
@@ -3624,12 +3686,12 @@ PerlIOMmap_flush(PerlIO *f)
     PerlIOBuf *b = &m->base;
     IV code = PerlIOBuf_flush(f);
     /*
-     * Now we are "synced" at PerlIOBuf level 
+     * Now we are "synced" at PerlIOBuf level
      */
     if (b->buf) {
        if (m->len) {
            /*
-            * Unmap the buffer 
+            * Unmap the buffer
             */
            if (PerlIOMmap_unmap(f) != 0)
                code = -1;
@@ -3637,7 +3699,7 @@ PerlIOMmap_flush(PerlIO *f)
        else {
            /*
             * We seem to have a PerlIOBuf buffer which was not mapped
-            * remember it in case we need one later 
+            * remember it in case we need one later
             */
            m->bbuf = b->buf;
        }
@@ -3675,6 +3737,12 @@ PerlIOMmap_close(PerlIO *f)
     return code;
 }
 
+PerlIO *
+PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, clone_params *param)
+{
+ return NULL;
+}
+
 
 PerlIO_funcs PerlIO_mmap = {
     "mmap",
@@ -3685,6 +3753,7 @@ PerlIO_funcs PerlIO_mmap = {
     PerlIOBuf_open,
     NULL,
     PerlIOBase_fileno,
+    PerlIOMmap_dup,
     PerlIOBuf_read,
     PerlIOMmap_unread,
     PerlIOMmap_write,
@@ -3775,7 +3844,7 @@ PerlIO_getname(PerlIO *f, char *buf)
 /*--------------------------------------------------------------------------------------*/
 /*
  * Functions which can be called on any kind of PerlIO implemented in
- * terms of above 
+ * terms of above
  */
 
 #undef PerlIO_getc
@@ -3877,7 +3946,7 @@ PerlIO *
 PerlIO_tmpfile(void)
 {
     /*
-     * I have no idea how portable mkstemp() is ... 
+     * I have no idea how portable mkstemp() is ...
      */
 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
     dTHX;
@@ -3916,8 +3985,8 @@ PerlIO_tmpfile(void)
 
 /*======================================================================================*/
 /*
- * Now some functions in terms of above which may be needed even if we are 
- * not in true PerlIO mode 
+ * Now some functions in terms of above which may be needed even if we are
+ * not in true PerlIO mode
  */
 
 #ifndef HAS_FSETPOS
index eb6a415..4c86661 100644 (file)
--- a/perliol.h
+++ b/perliol.h
@@ -26,6 +26,7 @@ struct _PerlIO_funcs {
                     PerlIO *old, int narg, SV **args);
     SV *(*Getarg) (PerlIO *f);
     IV (*Fileno) (PerlIO *f);
+    PerlIO *(*Dup) (pTHX_ PerlIO *f, PerlIO *o, clone_params *param);
     /* Unix-like functions - cf sfio line disciplines */
      SSize_t(*Read) (PerlIO *f, void *vbuf, Size_t count);
      SSize_t(*Unread) (PerlIO *f, const void *vbuf, Size_t count);
@@ -119,6 +120,7 @@ extern SV *PerlIO_arg_fetch(PerlIO_list_t *av, IV n);
 /* Generic, or stub layer functions */
 
 extern IV PerlIOBase_fileno(PerlIO *f);
+extern PerlIO *PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, clone_params *param);
 extern IV PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg);
 extern IV PerlIOBase_popped(PerlIO *f);
 extern SSize_t PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count);