PERL_MM_USE_DEFAULT

[p5sagit/p5-mst-13.2.git] / perlio.c

diff --git a/perlio.c b/perlio.c
index c849dd2..dd9f394 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -300,6 +300,19 @@ PerlIO_debug(const char *fmt, ...)
     }
     if (dbg > 0) {
        dTHX;
+#ifdef USE_ITHREADS
+       /* Use fixed buffer as sv_catpvf etc. needs SVs */
+       char buffer[1024];
+       char *s;
+       STRLEN len;
+       s = CopFILE(PL_curcop);
+       if (!s)
+           s = "(none)";
+       sprintf(buffer, "%s:%" IVdf " ", s, (IV) CopLINE(PL_curcop));
+        len = strlen(buffer);
+       vsprintf(buffer+len, fmt, ap);
+       PerlLIO_write(dbg, buffer, strlen(buffer));
+#else
        SV *sv = newSVpvn("", 0);
        char *s;
        STRLEN len;
@@ -313,6 +326,7 @@ PerlIO_debug(const char *fmt, ...)
        s = SvPV(sv, len);
        PerlLIO_write(dbg, s, len);
        SvREFCNT_dec(sv);
+#endif
     }
     va_end(ap);
 }
@@ -974,16 +988,13 @@ PerlIO__close(PerlIO *f)
 
 #undef PerlIO_fdupopen
 PerlIO *
-PerlIO_fdupopen(pTHX_ PerlIO *f)
+PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param)
 {
     if (f && *f) {
-       char buf[8];
-       int fd = PerlLIO_dup(PerlIO_fileno(f));
-       PerlIO *new = PerlIO_fdopen(fd, PerlIO_modestr(f, buf));
-       if (new) {
-           Off_t posn = PerlIO_tell(f);
-           PerlIO_seek(new, posn, SEEK_SET);
-       }
+       PerlIO_funcs *tab = PerlIOBase(f)->tab;
+       PerlIO *new;
+       PerlIO_debug("fdupopen f=%p param=%p\n",f,param);
+        new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param);
        return new;
     }
     else {
@@ -1984,29 +1995,52 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
     }
 }
 
-PerlIO *
-PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, clone_params *param)
+SV *
+PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
 {
-    PerlIO_funcs *self = PerlIOBase(o)->tab;
-    SV *arg = Nullsv;
-    char buf[8];
-    if (self->Getarg) {
-       arg = (*self->Getarg)(o);
+    if (!arg)
+       return Nullsv;
 #ifdef sv_dup
-       if (arg) {
-           arg = sv_dup(arg, param);
-       }
+    if (param) {
+       return sv_dup(arg, param);
+    }
+    else {
+       return newSVsv(arg);
+    }
+#else
+    return newSVsv(arg);
 #endif
+}
+
+PerlIO *
+PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+{
+    PerlIO *nexto = PerlIONext(o);
+    if (*nexto) {
+       PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
+       f = (*tab->Dup)(aTHX_ f, nexto, param);
     }
-    if (!f) {
-       f = PerlIO_allocate(aTHX);
+    if (f) {
+       PerlIO_funcs *self = PerlIOBase(o)->tab;
+       SV *arg = Nullsv;
+       char buf[8];
+       PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",self->name,f,o,param);
+       if (self->Getarg) {
+           arg = (*self->Getarg)(o);
+           if (arg) {
+               arg = PerlIO_sv_dup(aTHX_ arg, param);
+           }
+       }
+       f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
+       if (!f && arg) {
+           SvREFCNT_dec(arg);
+       }
     }
-    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_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
 {
     PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
     int fd = PerlLIO_dup(os->fd);
@@ -2513,9 +2547,29 @@ PerlIOStdio_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
 #endif
 
 PerlIO *
-PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, clone_params *param)
+PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
 {
- return NULL;
+    /* This assumes no layers underneath - which is what
+       happens, but is not how I remember it. NI-S 2001/10/16
+     */
+    int fd = PerlLIO_dup(PerlIO_fileno(o));
+    if (fd >= 0) {
+       char buf[8];
+       FILE *stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o, buf));
+       if (stdio) {
+           if ((f = PerlIOBase_dup(aTHX_ f, o, param))) {
+               PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
+           }
+           else {
+               PerlSIO_fclose(stdio);
+           }
+       }
+       else {
+           PerlLIO_close(fd);
+           f = NULL;
+       }
+    }
+    return f;
 }
 
 PerlIO_funcs PerlIO_stdio = {
@@ -3010,9 +3064,9 @@ PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
 }
 
 PerlIO *
-PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, clone_params *param)
+PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
 {
- return NULL;
+ return PerlIOBase_dup(aTHX_ f, o, param);
 }
 
 
@@ -3738,9 +3792,9 @@ PerlIOMmap_close(PerlIO *f)
 }
 
 PerlIO *
-PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, clone_params *param)
+PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
 {
- return NULL;
+ return PerlIOBase_dup(aTHX_ f, o, param);
 }