Symbian sync

[perl5.git] / perlio.c

diff --git a/perlio.c b/perlio.c
index ce20542..bbb12db 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__)
+    PERL_UNUSED_ARG(iotype);
     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;
+    PERL_UNUSED_ARG(iotype);
 #ifdef NETWARE
     if (PerlLIO_setmode(fp, mode) != -1) {
 #else
@@ -171,6 +176,9 @@ document
 #else
 #  if defined(USEMYBINMODE)
     dTHX;
+#    if defined(__CYGWIN__)
+    PERL_UNUSED_ARG(iotype);
+#    endif
     if (my_binmode(fp, iotype, mode) != FALSE)
         return 1;
     else
@@ -793,7 +801,7 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
        } 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) {
@@ -899,7 +907,7 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
 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;
 }
@@ -911,6 +919,7 @@ XS(XS_PerlIO__Layer__NoWarnings)
      */
     dVAR;
     dXSARGS;
+    PERL_UNUSED_ARG(cv);
     if (items)
        PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
     XSRETURN(0);
@@ -920,6 +929,7 @@ XS(XS_PerlIO__Layer__find)
 {
     dVAR;
     dXSARGS;
+    PERL_UNUSED_ARG(cv);
     if (items < 2)
        Perl_croak(aTHX_ "Usage class->find(name[,load])");
     else {
@@ -2258,6 +2268,8 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
        if (self->Getarg)
            arg = (*self->Getarg)(aTHX_ o, param, flags);
        f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
+       if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
+           PerlIOBase(f)->flags |= PERLIO_F_UTF8;
        if (arg)
            SvREFCNT_dec(arg);
     }
@@ -2869,6 +2881,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;
+           PerlIOUnix_refcnt_inc(fileno(stdio));
        }
     }
     return f;
@@ -3416,9 +3429,15 @@ PerlIOStdio_fill(pTHX_ PerlIO *f)
        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)))
 
@@ -3535,6 +3554,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;
+               PerlIOUnix_refcnt_inc(fileno(stdio));
                /* Link previous lower layers under new one */
                *PerlIONext(f) = l;
            }
@@ -3574,6 +3594,9 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f)
            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;
            }
@@ -5077,8 +5100,8 @@ PerlIO_tmpfile(void)
          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();
 
@@ -5105,30 +5128,30 @@ const char *
 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
      */
-    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;
 }