This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Directly create the SV with Perl_newSVpvf() rather than using
[perl5.git] / perlio.c
diff --git a/perlio.c b/perlio.c
index 63164c4..7c0abfc 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -1,7 +1,10 @@
 /*
 /*
- * perlio.c Copyright (c) 1996-2006, 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.
+ * perlio.c
+ * Copyright (c) 1996-2006, Nick Ing-Simmons
+ * Copyright (c) 2006, 2007, Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public License
+ * or the Artistic License, as specified in the README file.
  */
 
 /*
  */
 
 /*
@@ -131,6 +134,7 @@ perlsio_binmode(FILE *fp, int iotype, int mode)
      */
 #ifdef DOSISH
 #  if defined(atarist) || defined(__MINT__)
      */
 #ifdef DOSISH
 #  if defined(atarist) || defined(__MINT__)
+    PERL_UNUSED_ARG(iotype);
     if (!fflush(fp)) {
         if (mode & O_BINARY)
             ((FILE *) fp)->_flag |= _IOBIN;
     if (!fflush(fp)) {
         if (mode & O_BINARY)
             ((FILE *) fp)->_flag |= _IOBIN;
@@ -141,6 +145,7 @@ perlsio_binmode(FILE *fp, int iotype, int mode)
     return 0;
 #  else
     dTHX;
     return 0;
 #  else
     dTHX;
+    PERL_UNUSED_ARG(iotype);
 #ifdef NETWARE
     if (PerlLIO_setmode(fp, mode) != -1) {
 #else
 #ifdef NETWARE
     if (PerlLIO_setmode(fp, mode) != -1) {
 #else
@@ -171,6 +176,9 @@ document
 #else
 #  if defined(USEMYBINMODE)
     dTHX;
 #else
 #  if defined(USEMYBINMODE)
     dTHX;
+#    if defined(__CYGWIN__)
+    PERL_UNUSED_ARG(iotype);
+#    endif
     if (my_binmode(fp, iotype, mode) != FALSE)
         return 1;
     else
     if (my_binmode(fp, iotype, mode) != FALSE)
         return 1;
     else
@@ -499,9 +507,8 @@ PerlIO_debug(const char *fmt, ...)
 #else
        const char *s = CopFILE(PL_curcop);
        STRLEN len;
 #else
        const char *s = CopFILE(PL_curcop);
        STRLEN len;
-       SV * const sv = newSVpvs("");
-       Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s ? s : "(none)",
-                      (IV) CopLINE(PL_curcop));
+       SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
+                                     (IV) CopLINE(PL_curcop));
        Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
 
        s = SvPV_const(sv, len);
        Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
 
        s = SvPV_const(sv, len);
@@ -645,9 +652,13 @@ PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
        int i;
        list = PerlIO_list_alloc(aTHX);
        for (i=0; i < proto->cur; i++) {
        int i;
        list = PerlIO_list_alloc(aTHX);
        for (i=0; i < proto->cur; i++) {
-           SV *arg = NULL;
-           if (proto->array[i].arg)
-               arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
+           SV *arg = proto->array[i].arg;
+#ifdef sv_dup
+           if (arg && param)
+               arg = sv_dup(arg, param);
+#else
+           PERL_UNUSED_ARG(param);
+#endif
            PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
        }
     }
            PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
        }
     }
@@ -789,7 +800,7 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
        } else {
            SV * const pkgsv = newSVpvs("PerlIO");
            SV * const layer = newSVpvn(name, len);
        } else {
            SV * const pkgsv = newSVpvs("PerlIO");
            SV * const layer = newSVpvn(name, len);
-           CV * const cv    = get_cv("PerlIO::Layer::NoWarnings", FALSE);
+           CV * const cv    = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("PerlIO::Layer::NoWarnings"), 0);
            ENTER;
            SAVEINT(PL_in_load_module);
            if (cv) {
            ENTER;
            SAVEINT(PL_in_load_module);
            if (cv) {
@@ -819,7 +830,8 @@ perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
        IO * const io = GvIOn((GV *) SvRV(sv));
        PerlIO * const ifp = IoIFP(io);
        PerlIO * const ofp = IoOFP(io);
        IO * const io = GvIOn((GV *) SvRV(sv));
        PerlIO * const ifp = IoIFP(io);
        PerlIO * const ofp = IoOFP(io);
-       Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp);
+       Perl_warn(aTHX_ "set %" SVf " %p %p %p",
+                 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
     }
     return 0;
 }
     }
     return 0;
 }
@@ -831,7 +843,8 @@ perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
        IO * const io = GvIOn((GV *) SvRV(sv));
        PerlIO * const ifp = IoIFP(io);
        PerlIO * const ofp = IoOFP(io);
        IO * const io = GvIOn((GV *) SvRV(sv));
        PerlIO * const ifp = IoIFP(io);
        PerlIO * const ofp = IoOFP(io);
-       Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp);
+       Perl_warn(aTHX_ "get %" SVf " %p %p %p",
+                 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
     }
     return 0;
 }
     }
     return 0;
 }
@@ -839,14 +852,14 @@ perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
 static int
 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 {
 static int
 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 {
-    Perl_warn(aTHX_ "clear %" SVf, sv);
+    Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
     return 0;
 }
 
 static int
 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
 {
     return 0;
 }
 
 static int
 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
 {
-    Perl_warn(aTHX_ "free %" SVf, sv);
+    Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
     return 0;
 }
 
     return 0;
 }
 
@@ -871,7 +884,7 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
     mg = mg_find(sv, PERL_MAGIC_ext);
     mg->mg_virtual = &perlio_vtab;
     mg_magical(sv);
     mg = mg_find(sv, PERL_MAGIC_ext);
     mg->mg_virtual = &perlio_vtab;
     mg_magical(sv);
-    Perl_warn(aTHX_ "attrib %" SVf, sv);
+    Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
     for (i = 2; i < items; i++) {
        STRLEN len;
        const char * const name = SvPV_const(ST(i), len);
     for (i = 2; i < items; i++) {
        STRLEN len;
        const char * const name = SvPV_const(ST(i), len);
@@ -893,7 +906,7 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
 SV *
 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
 {
 SV *
 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
 {
-    HV * const stash = gv_stashpvs("PerlIO::Layer", TRUE);
+    HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
     SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
     return sv;
 }
     SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
     return sv;
 }
@@ -905,6 +918,7 @@ XS(XS_PerlIO__Layer__NoWarnings)
      */
     dVAR;
     dXSARGS;
      */
     dVAR;
     dXSARGS;
+    PERL_UNUSED_ARG(cv);
     if (items)
        PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
     XSRETURN(0);
     if (items)
        PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
     XSRETURN(0);
@@ -914,6 +928,7 @@ XS(XS_PerlIO__Layer__find)
 {
     dVAR;
     dXSARGS;
 {
     dVAR;
     dXSARGS;
+    PERL_UNUSED_ARG(cv);
     if (items < 2)
        Perl_croak(aTHX_ "Usage class->find(name[,load])");
     else {
     if (items < 2)
        Perl_croak(aTHX_ "Usage class->find(name[,load])");
     else {
@@ -1013,10 +1028,13 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
                    PerlIO_funcs * const layer =
                        PerlIO_find_layer(aTHX_ s, llen, 1);
                    if (layer) {
                    PerlIO_funcs * const layer =
                        PerlIO_find_layer(aTHX_ s, llen, 1);
                    if (layer) {
+                       SV *arg = NULL;
+                       if (as)
+                           arg = newSVpvn(as, alen);
                        PerlIO_list_push(aTHX_ av, layer,
                        PerlIO_list_push(aTHX_ av, layer,
-                                        (as) ? newSVpvn(as,
-                                                        alen) :
-                                        &PL_sv_undef);
+                                        (arg) ? arg : &PL_sv_undef);
+                       if (arg)
+                           SvREFCNT_dec(arg);
                    }
                    else {
                        if (ckWARN(WARN_LAYER))
                    }
                    else {
                        if (ckWARN(WARN_LAYER))
@@ -1431,8 +1449,14 @@ 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_ STR_WITH_LEN("scalar"), 1);
+    if (SvTYPE(sv) < SVt_PVAV) {
+       PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
+       /* This isn't supposed to happen, since PerlIO::scalar is core,
+        * but could happen anyway in smaller installs or with PAR */
+       if (!f && ckWARN(WARN_LAYER))
+           Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
+       return f;
+    }
 
     /*
      * 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
@@ -1485,12 +1509,7 @@ PerlIO_resolve_layers(pTHX_ const char *layers,
     if (layers && *layers) {
        PerlIO_list_t *av;
        if (incdef) {
     if (layers && *layers) {
        PerlIO_list_t *av;
        if (incdef) {
-           IV i;
-           av = PerlIO_list_alloc(aTHX);
-           for (i = 0; i < def->cur; i++) {
-               PerlIO_list_push(aTHX_ av, def->array[i].funcs,
-                                def->array[i].arg);
-           }
+           av = PerlIO_clone_list(aTHX_ def, NULL);
        }
        else {
            av = def;
        }
        else {
            av = def;
@@ -1535,10 +1554,13 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
            PerlIOl *l = *f;
            layera = PerlIO_list_alloc(aTHX);
            while (l) {
            PerlIOl *l = *f;
            layera = PerlIO_list_alloc(aTHX);
            while (l) {
-               SV * const arg = (l->tab->Getarg)
-                       ? (*l->tab->Getarg) (aTHX_ &l, NULL, 0)
-                       : &PL_sv_undef;
-               PerlIO_list_push(aTHX_ layera, l->tab, arg);
+               SV *arg = NULL;
+               if (l->tab->Getarg)
+                   arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
+               PerlIO_list_push(aTHX_ layera, l->tab,
+                                (arg) ? arg : &PL_sv_undef);
+               if (arg)
+                   SvREFCNT_dec(arg);
                l = *PerlIONext(&l);
            }
        }
                l = *PerlIONext(&l);
            }
        }
@@ -2057,7 +2079,7 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
     }
 #if 0
     PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
     }
 #if 0
     PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
-                f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
+                (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
                 l->flags, PerlIO_modestr(f, temp));
 #endif
     return 0;
                 l->flags, PerlIO_modestr(f, temp));
 #endif
     return 0;
@@ -2212,7 +2234,9 @@ PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
        return NULL;
 #ifdef sv_dup
     if (param) {
        return NULL;
 #ifdef sv_dup
     if (param) {
-       return sv_dup(arg, param);
+       arg = sv_dup(arg, param);
+       SvREFCNT_inc_simple_void_NN(arg);
+       return arg;
     }
     else {
        return newSVsv(arg);
     }
     else {
        return newSVsv(arg);
@@ -2236,30 +2260,24 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
     }
     if (f) {
        PerlIO_funcs * const self = PerlIOBase(o)->tab;
     }
     if (f) {
        PerlIO_funcs * const self = PerlIOBase(o)->tab;
-       SV *arg;
+       SV *arg = NULL;
        char buf[8];
        PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
                     self->name, (void*)f, (void*)o, (void*)param);
        if (self->Getarg)
            arg = (*self->Getarg)(aTHX_ o, param, flags);
        char buf[8];
        PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
                     self->name, (void*)f, (void*)o, (void*)param);
        if (self->Getarg)
            arg = (*self->Getarg)(aTHX_ o, param, flags);
-       else {
-           arg = NULL;
-       }
        f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
        f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
-       if (arg) {
+       if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
+           PerlIOBase(f)->flags |= PERLIO_F_UTF8;
+       if (arg)
            SvREFCNT_dec(arg);
            SvREFCNT_dec(arg);
-       }
     }
     return f;
 }
 
     }
     return f;
 }
 
-#ifdef USE_THREADS
-perl_mutex PerlIO_mutex;
-#endif
-
 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
 
 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
 
-/* Must be called with PerlIO_mutex locked.  */
+/* Must be called with PL_perlio_mutex locked. */
 static void
 S_more_refcounted_fds(pTHX_ const int new_fd) {
     dVAR;
 static void
 S_more_refcounted_fds(pTHX_ const int new_fd) {
     dVAR;
@@ -2276,12 +2294,13 @@ S_more_refcounted_fds(pTHX_ const int new_fd) {
 
     assert (new_max > new_fd);
 
 
     assert (new_max > new_fd);
 
-    new_array =
-       (int*) PerlMemShared_realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
+    /* Use plain realloc() since we need this memory to be really
+     * global and visible to all the interpreters and/or threads. */
+    new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
 
     if (!new_array) {
 
     if (!new_array) {
-#ifdef USE_THREADS
-       MUTEX_UNLOCK(&PerlIO_mutex);
+#ifdef USE_ITHREADS
+       MUTEX_UNLOCK(&PL_perlio_mutex);
 #endif
        /* Can't use PerlIO to write as it allocates memory */
        PerlLIO_write(PerlIO_fileno(Perl_error_log),
 #endif
        /* Can't use PerlIO to write as it allocates memory */
        PerlLIO_write(PerlIO_fileno(Perl_error_log),
@@ -2303,12 +2322,8 @@ S_more_refcounted_fds(pTHX_ const int new_fd) {
 void
 PerlIO_init(pTHX)
 {
 void
 PerlIO_init(pTHX)
 {
- /* Place holder for stdstreams call ??? */
-#ifdef USE_THREADS
-    MUTEX_INIT(&PerlIO_mutex);
-#else
+    /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
     PERL_UNUSED_CONTEXT;
     PERL_UNUSED_CONTEXT;
-#endif
 }
 
 void
 }
 
 void
@@ -2318,18 +2333,25 @@ PerlIOUnix_refcnt_inc(int fd)
     if (fd >= 0) {
        dVAR;
 
     if (fd >= 0) {
        dVAR;
 
-#ifdef USE_THREADS
-       MUTEX_LOCK(&PerlIO_mutex);
+#ifdef USE_ITHREADS
+       MUTEX_LOCK(&PL_perlio_mutex);
 #endif
        if (fd >= PL_perlio_fd_refcnt_size)
            S_more_refcounted_fds(aTHX_ fd);
 
        PL_perlio_fd_refcnt[fd]++;
 #endif
        if (fd >= PL_perlio_fd_refcnt_size)
            S_more_refcounted_fds(aTHX_ fd);
 
        PL_perlio_fd_refcnt[fd]++;
-       PerlIO_debug("fd %d refcnt=%d\n",fd,PL_perlio_fd_refcnt[fd]);
+       if (PL_perlio_fd_refcnt[fd] <= 0) {
+           Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
+                      fd, PL_perlio_fd_refcnt[fd]);
+       }
+       PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
+                    fd, PL_perlio_fd_refcnt[fd]);
 
 
-#ifdef USE_THREADS
-       MUTEX_UNLOCK(&PerlIO_mutex);
+#ifdef USE_ITHREADS
+       MUTEX_UNLOCK(&PL_perlio_mutex);
 #endif
 #endif
+    } else {
+       Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
     }
 }
 
     }
 }
 
@@ -2340,19 +2362,24 @@ PerlIOUnix_refcnt_dec(int fd)
     int cnt = 0;
     if (fd >= 0) {
        dVAR;
     int cnt = 0;
     if (fd >= 0) {
        dVAR;
-#ifdef USE_THREADS
-       MUTEX_LOCK(&PerlIO_mutex);
+#ifdef USE_ITHREADS
+       MUTEX_LOCK(&PL_perlio_mutex);
 #endif
 #endif
-       /* XXX should this be a panic?  */
-       if (fd >= PL_perlio_fd_refcnt_size)
-           S_more_refcounted_fds(aTHX_ fd);
-
-       /* XXX should this be a panic if it drops below 0?  */
+       if (fd >= PL_perlio_fd_refcnt_size) {
+           Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
+                      fd, PL_perlio_fd_refcnt_size);
+       }
+       if (PL_perlio_fd_refcnt[fd] <= 0) {
+           Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
+                      fd, PL_perlio_fd_refcnt[fd]);
+       }
        cnt = --PL_perlio_fd_refcnt[fd];
        cnt = --PL_perlio_fd_refcnt[fd];
-       PerlIO_debug("fd %d refcnt=%d\n",fd,cnt);
-#ifdef USE_THREADS
-       MUTEX_UNLOCK(&PerlIO_mutex);
+       PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
+#ifdef USE_ITHREADS
+       MUTEX_UNLOCK(&PL_perlio_mutex);
 #endif
 #endif
+    } else {
+       Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
     }
     return cnt;
 }
     }
     return cnt;
 }
@@ -2368,19 +2395,6 @@ PerlIO_cleanup(pTHX)
     PerlIO_debug("Cleanup layers\n");
 #endif
 
     PerlIO_debug("Cleanup layers\n");
 #endif
 
-#ifdef DEBUGGING
-    {
-       /* By now all filehandles should have been closed, so any
-        * stray (non-STD-)filehandles indicate *possible* (PerlIO)
-        * errors. */
-       for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
-           if (PL_perlio_fd_refcnt[i])
-               PerlIO_debug("PerlIO_cleanup: fd %d refcnt=%d\n",
-                            i, PL_perlio_fd_refcnt[i]);
-       }
-    }
-#endif
-
     /* Raise STDIN..STDERR refcount so we don't close them */
     for (i=0; i < 3; i++)
        PerlIOUnix_refcnt_inc(i);
     /* Raise STDIN..STDERR refcount so we don't close them */
     for (i=0; i < 3; i++)
        PerlIOUnix_refcnt_inc(i);
@@ -2397,19 +2411,34 @@ PerlIO_cleanup(pTHX)
        PerlIO_list_free(aTHX_ PL_def_layerlist);
        PL_def_layerlist = NULL;
     }
        PerlIO_list_free(aTHX_ PL_def_layerlist);
        PL_def_layerlist = NULL;
     }
+}
 
 
-#ifdef USE_ITHREADS
-    /* only main thread can free refcnt table */
-    if (PL_curinterp == aTHX)
-#endif
+void PerlIO_teardown(pTHX) /* Call only from PERL_SYS_TERM(). */
+{
+    dVAR;
+#ifdef DEBUGGING
     {
     {
-       Safefree(PL_perlio_fd_refcnt);
+       /* By now all filehandles should have been closed, so any
+        * stray (non-STD-)filehandles indicate *possible* (PerlIO)
+        * errors. */
+       int i;
+       for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
+           if (PL_perlio_fd_refcnt[i])
+               PerlIO_debug("PerlIO_cleanup: fd %d refcnt=%d\n",
+                            i, PL_perlio_fd_refcnt[i]);
+       }
+    }
+#endif
+    /* Not bothering with PL_perlio_mutex since by now
+     * all the interpreters are gone. */
+    if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
+        && PL_perlio_fd_refcnt) {
+       free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
        PL_perlio_fd_refcnt = NULL;
        PL_perlio_fd_refcnt = NULL;
+       PL_perlio_fd_refcnt_size = 0;
     }
 }
 
     }
 }
 
-
-
 /*--------------------------------------------------------------------------------------*/
 /*
  * Bottom-most level for UNIX-like case
 /*--------------------------------------------------------------------------------------*/
 /*
  * Bottom-most level for UNIX-like case
@@ -2851,6 +2880,7 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
        if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
            s = PerlIOSelf(f, PerlIOStdio);
            s->stdio = stdio;
        if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
            s = PerlIOSelf(f, PerlIOStdio);
            s->stdio = stdio;
+           PerlIOUnix_refcnt_inc(fileno(stdio));
        }
     }
     return f;
        }
     }
     return f;
@@ -3349,7 +3379,7 @@ PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
     if (ptr != NULL) {
 #ifdef STDIO_PTR_LVALUE
     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
     if (ptr != NULL) {
 #ifdef STDIO_PTR_LVALUE
-       PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
+       PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
 #ifdef STDIO_PTR_LVAL_SETS_CNT
        if (PerlSIO_get_cnt(stdio) != (cnt)) {
            assert(PerlSIO_get_cnt(stdio) == (cnt));
 #ifdef STDIO_PTR_LVAL_SETS_CNT
        if (PerlSIO_get_cnt(stdio) != (cnt)) {
            assert(PerlSIO_get_cnt(stdio) == (cnt));
@@ -3398,9 +3428,15 @@ PerlIOStdio_fill(pTHX_ PerlIO *f)
        if (PerlSIO_fflush(stdio) != 0)
            return EOF;
     }
        if (PerlSIO_fflush(stdio) != 0)
            return EOF;
     }
-    c = PerlSIO_fgetc(stdio);
-    if (c == EOF)
-       return EOF;
+    for (;;) {
+       c = PerlSIO_fgetc(stdio);
+       if (c != EOF)
+           break;
+       if (! PerlSIO_ferror(stdio) || errno != EINTR)
+           return EOF;
+       PERL_ASYNC_CHECK();
+       SETERRNO(0,0);
+    }
 
 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
 
 
 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
 
@@ -3517,6 +3553,7 @@ PerlIO_exportFILE(PerlIO * f, const char *mode)
            if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
                PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
                s->stdio = stdio;
            if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
                PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
                s->stdio = stdio;
+               PerlIOUnix_refcnt_inc(fileno(stdio));
                /* Link previous lower layers under new one */
                *PerlIONext(f) = l;
            }
                /* Link previous lower layers under new one */
                *PerlIONext(f) = l;
            }
@@ -3556,6 +3593,9 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f)
            PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
            if (s->stdio == f) {
                dTHX;
            PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
            if (s->stdio == f) {
                dTHX;
+               const int fd = fileno(f);
+               if (fd >= 0)
+                   PerlIOUnix_refcnt_dec(fd);
                PerlIO_pop(aTHX_ p);
                return;
            }
                PerlIO_pop(aTHX_ p);
                return;
            }
@@ -4245,7 +4285,7 @@ PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
     code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
 #if 0
     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
     code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
 #if 0
     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
-                f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
+                (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
                 PerlIOBase(f)->flags);
 #endif
     {
                 PerlIOBase(f)->flags);
 #endif
     {
@@ -4431,8 +4471,8 @@ PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
 
        if (ptr != chk ) {
            Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
 
        if (ptr != chk ) {
            Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
-                      " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
-                      b->end, cnt);
+                      " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
+                      flags, c->nl, b->end, cnt);
        }
 #endif
     }
        }
 #endif
     }
@@ -4601,7 +4641,7 @@ PerlIOMmap_map(pTHX_ PerlIO *f)
                }
                posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
                len = st.st_size - posn;
                }
                posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
                len = st.st_size - posn;
-               m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
+               m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
                if (m->mptr && m->mptr != (Mmap_t) - 1) {
 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
                    madvise(m->mptr, len, MADV_SEQUENTIAL);
                if (m->mptr && m->mptr != (Mmap_t) - 1) {
 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
                    madvise(m->mptr, len, MADV_SEQUENTIAL);
@@ -5059,21 +5099,14 @@ PerlIO_tmpfile(void)
          if (f)
               PerlIOBase(f)->flags |= PERLIO_F_TEMP;
          PerlLIO_unlink(SvPVX_const(sv));
          if (f)
               PerlIOBase(f)->flags |= PERLIO_F_TEMP;
          PerlLIO_unlink(SvPVX_const(sv));
-         SvREFCNT_dec(sv);
      }
      }
+     SvREFCNT_dec(sv);
 #    else      /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
      FILE * const stdio = PerlSIO_tmpfile();
 
 #    else      /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
      FILE * const stdio = PerlSIO_tmpfile();
 
-     if (stdio) {
-         if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)),
-                               PERLIO_FUNCS_CAST(&PerlIO_stdio),
-                              "w+", NULL))) {
-              PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
+     if (stdio)
+         f = PerlIO_fdopen(fileno(stdio), "w+");
 
 
-               if (s)
-                    s->stdio = stdio;
-          }
-     }
 #    endif /* else HAS_MKSTEMP */
 #endif /* else WIN32 */
      return f;
 #    endif /* else HAS_MKSTEMP */
 #endif /* else WIN32 */
      return f;
@@ -5094,30 +5127,30 @@ const char *
 Perl_PerlIO_context_layers(pTHX_ const char *mode)
 {
     dVAR;
 Perl_PerlIO_context_layers(pTHX_ const char *mode)
 {
     dVAR;
-    const char *type = NULL;
+    const char *direction = NULL;
+    SV *layers;
     /*
      * Need to supply default layer info from open.pm
      */
     /*
      * Need to supply default layer info from open.pm
      */
-    if (PL_curcop && PL_curcop->cop_hints & HINT_LEXICAL_IO) {
-       SV * const layers
-           = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
-                                      "open", 4, 0, 0);
-       assert(layers);
-       if (SvOK(layers)) {
-           STRLEN len;
-           type = SvPV_const(layers, len);
-           if (type && mode && mode[0] != 'r') {
-               /*
-                * Skip to write part, which is separated by a '\0'
-                */
-               STRLEN read_len = strlen(type);
-               if (read_len < len) {
-                   type += read_len + 1;
-               }
-           }
-       }
+
+    if (!PL_curcop)
+       return NULL;
+
+    if (mode && mode[0] != 'r') {
+       if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
+           direction = "open>";
+    } else {
+       if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
+           direction = "open<";
     }
     }
-    return type;
+    if (!direction)
+       return NULL;
+
+    layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
+                                     0, direction, 5, 0, 0);
+
+    assert(layers);
+    return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
 }
 
 
 }
 
 
Unnamed repository; edit this file 'description' to name the repository.