X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/375ed12a42c6092b1af1d8e395bf3dadd9a66e48..42d92f4a6420c9e925e441055e97be24645d0a52:/perlio.c

diff --git a/perlio.c b/perlio.c
index 29c4bf7..11a66d0 100644
--- a/perlio.c
+++ b/perlio.c
@@ -199,10 +199,12 @@ PerlIO_intmode2str(int rawmode, char *mode, int *writing)
 	    mode[ix++] = '+';
 	}
     }
-#ifdef PERLIO_BINARY_AND_TEXT_DIFFERENT_AND_EFFECTIVE
+#if O_BINARY != 0
+    /* Unless O_BINARY is different from zero, bit-and:ing
+     * with it won't do much good. */
     if (rawmode & O_BINARY)
 	mode[ix++] = 'b';
-#endif
+# endif
     mode[ix] = '\0';
     return ptype;
 }
@@ -336,29 +338,6 @@ Perl_boot_core_PerlIO(pTHX)
 #endif
 
 
-#ifdef PERLIO_IS_STDIO
-
-void
-PerlIO_init(pTHX)
-{
-    PERL_UNUSED_CONTEXT;
-    /*
-     * Does nothing (yet) except force this file to be included in perl
-     * binary. That allows this file to force inclusion of other functions
-     * that may be required by loadable extensions e.g. for
-     * FileHandle::tmpfile
-     */
-}
-
-#undef PerlIO_tmpfile
-PerlIO *
-PerlIO_tmpfile(void)
-{
-    return tmpfile();
-}
-
-#else                           /* PERLIO_IS_STDIO */
-
 /*======================================================================================*/
 /*
  * Implement all the PerlIO interface ourselves.
@@ -389,14 +368,13 @@ PerlIO_debug(const char *fmt, ...)
 	}
     }
     if (PL_perlio_debug_fd > 0) {
-        int rc = 0;
 #ifdef USE_ITHREADS
 	const char * const s = CopFILE(PL_curcop);
 	/* Use fixed buffer as sv_catpvf etc. needs SVs */
 	char buffer[1024];
 	const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
 	const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
-	rc = PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2);
+	PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
 #else
 	const char *s = CopFILE(PL_curcop);
 	STRLEN len;
@@ -405,11 +383,9 @@ PerlIO_debug(const char *fmt, ...)
 	Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
 
 	s = SvPV_const(sv, len);
-	rc = PerlLIO_write(PL_perlio_debug_fd, s, len);
+	PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len));
 	SvREFCNT_dec(sv);
 #endif
-        /* silently ignore failures */
-        PERL_UNUSED_VAR(rc);
     }
     va_end(ap);
 }
@@ -429,6 +405,9 @@ PerlIO_verify_head(pTHX_ PerlIO *f)
 {
     PerlIOl *head, *p;
     int seen = 0;
+#ifndef PERL_IMPLICIT_SYS
+    PERL_UNUSED_CONTEXT;
+#endif
     if (!PerlIOValid(f))
 	return;
     p = head = PerlIOBase(f)->head;
@@ -464,7 +443,6 @@ PerlIO_init_table(pTHX)
 PerlIO *
 PerlIO_allocate(pTHX)
 {
-    dVAR;
     /*
      * Find a free slot in the table, allocating new table as necessary
      */
@@ -476,10 +454,7 @@ PerlIO_allocate(pTHX)
 	last = (PerlIOl **) (f);
 	for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
 	    if (!((++f)->next)) {
-		f->flags = 0; /* lockcnt */
-		f->tab = NULL;
-		f->head = f;
-		return (PerlIO *)f;
+		goto good_exit;
 	    }
 	}
     }
@@ -488,6 +463,8 @@ PerlIO_allocate(pTHX)
 	return NULL;
     }
     *last = (PerlIOl*) f++;
+
+    good_exit:
     f->flags = 0; /* lockcnt */
     f->tab = NULL;
     f->head = f;
@@ -561,7 +538,6 @@ PerlIO_list_free(pTHX_ PerlIO_list_t *list)
 void
 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
 {
-    dVAR;
     PerlIO_pair_t *p;
     PERL_UNUSED_CONTEXT;
 
@@ -631,7 +607,6 @@ PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
 void
 PerlIO_destruct(pTHX)
 {
-    dVAR;
     PerlIOl **table = &PL_perlio;
     PerlIOl *f;
 #ifdef USE_ITHREADS
@@ -697,7 +672,6 @@ PerlIO_pop(pTHX_ PerlIO *f)
 AV *
 PerlIO_get_layers(pTHX_ PerlIO *f)
 {
-    dVAR;
     AV * const av = newAV();
 
     if (PerlIOValid(f)) {
@@ -731,7 +705,7 @@ PerlIO_get_layers(pTHX_ PerlIO *f)
 PerlIO_funcs *
 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
 {
-    dVAR;
+
     IV i;
     if ((SSize_t) len <= 0)
 	len = strlen(name);
@@ -852,7 +826,7 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
     XSRETURN(count);
 }
 
-#endif                          /* USE_ATTIBUTES_FOR_PERLIO */
+#endif                          /* USE_ATTRIBUTES_FOR_PERLIO */
 
 SV *
 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
@@ -868,7 +842,6 @@ XS(XS_PerlIO__Layer__NoWarnings)
     /* This is used as a %SIG{__WARN__} handler to suppress warnings
        during loading of layers.
      */
-    dVAR;
     dXSARGS;
     PERL_UNUSED_ARG(cv);
     if (items)
@@ -879,7 +852,6 @@ XS(XS_PerlIO__Layer__NoWarnings)
 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
 XS(XS_PerlIO__Layer__find)
 {
-    dVAR;
     dXSARGS;
     PERL_UNUSED_ARG(cv);
     if (items < 2)
@@ -887,7 +859,7 @@ XS(XS_PerlIO__Layer__find)
     else {
 	STRLEN len;
 	const char * const name = SvPV_const(ST(1), len);
-	const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
+	const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0;
 	PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
 	ST(0) =
 	    (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
@@ -899,7 +871,6 @@ XS(XS_PerlIO__Layer__find)
 void
 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
 {
-    dVAR;
     if (!PL_known_layers)
 	PL_known_layers = PerlIO_list_alloc(aTHX);
     PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
@@ -909,7 +880,6 @@ PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
 int
 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
 {
-    dVAR;
     if (names) {
 	const char *s = names;
 	while (*s) {
@@ -1002,7 +972,6 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
 void
 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
 {
-    dVAR;
     PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
 #ifdef PERLIO_USING_CRLF
     tab = &PerlIO_crlf;
@@ -1011,8 +980,7 @@ PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
 	tab = &PerlIO_stdio;
 #endif
     PerlIO_debug("Pushing %s\n", tab->name);
-    PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
-		     &PL_sv_undef);
+    PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
 }
 
 SV *
@@ -1082,7 +1050,6 @@ PERLIO_FUNCS_DECL(PerlIO_remove) = {
 PerlIO_list_t *
 PerlIO_default_layers(pTHX)
 {
-    dVAR;
     if (!PL_def_layerlist) {
 	const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
 	PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
@@ -1101,9 +1068,8 @@ PerlIO_default_layers(pTHX)
 	PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
 	PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
 	PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
-	PerlIO_list_push(aTHX_ PL_def_layerlist,
-			 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
-			 &PL_sv_undef);
+	PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer,
+                         &PL_sv_undef);
 	if (s) {
 	    PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
 	}
@@ -1131,7 +1097,6 @@ Perl_boot_core_PerlIO(pTHX)
 PerlIO_funcs *
 PerlIO_default_layer(pTHX_ I32 n)
 {
-    dVAR;
     PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
     if (n < 0)
 	n += av->cur;
@@ -1144,7 +1109,6 @@ PerlIO_default_layer(pTHX_ I32 n)
 void
 PerlIO_stdstreams(pTHX)
 {
-    dVAR;
     if (!PL_perlio) {
 	PerlIO_init_table(aTHX);
 	PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
@@ -1418,15 +1382,13 @@ Perl_PerlIO_close(pTHX_ PerlIO *f)
 int
 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
 {
-    dVAR;
-     Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
+    Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
 }
 
 
 static PerlIO_funcs *
 PerlIO_layer_from_ref(pTHX_ SV *sv)
 {
-    dVAR;
     /*
      * For any scalar type load the handler which is bundled with perl
      */
@@ -1461,7 +1423,6 @@ PerlIO_list_t *
 PerlIO_resolve_layers(pTHX_ const char *layers,
 		      const char *mode, int narg, SV **args)
 {
-    dVAR;
     PerlIO_list_t *def = PerlIO_default_layers(aTHX);
     int incdef = 1;
     if (!PL_perlio)
@@ -1472,7 +1433,7 @@ PerlIO_resolve_layers(pTHX_ const char *layers,
 	 * If it is a reference but not an object see if we have a handler
 	 * for it
 	 */
-	if (SvROK(arg) && !sv_isobject(arg)) {
+	if (SvROK(arg) && !SvOBJECT(SvRV(arg))) {
 	    PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
 	    if (handler) {
 		def = PerlIO_list_alloc(aTHX);
@@ -1515,7 +1476,6 @@ PerlIO *
 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
 	     int imode, int perm, PerlIO *f, int narg, SV **args)
 {
-    dVAR;
     if (!f && narg == 1 && *args == &PL_sv_undef) {
 	if ((f = PerlIO_tmpfile())) {
 	    if (!layers || !*layers)
@@ -1639,7 +1599,6 @@ Perl_PerlIO_tell(pTHX_ PerlIO *f)
 int
 Perl_PerlIO_flush(pTHX_ PerlIO *f)
 {
-    dVAR;
     if (f) {
 	if (*f) {
 	    const PerlIO_funcs *tab = PerlIOBase(f)->tab;
@@ -1682,7 +1641,6 @@ Perl_PerlIO_flush(pTHX_ PerlIO *f)
 void
 PerlIOBase_flush_linebuf(pTHX)
 {
-    dVAR;
     PerlIOl **table = &PL_perlio;
     PerlIOl *f;
     while ((f = *table)) {
@@ -2078,6 +2036,7 @@ PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
         if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
 	    PerlIOBase(f)->flags |= PERLIO_F_ERROR;
 	    SETERRNO(EBADF, SS_IVCHAN);
+	    PerlIO_save_errno(f);
 	    return 0;
 	}
 	while (count > 0) {
@@ -2229,10 +2188,10 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 	char buf[8];
 	assert(self);
 	PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
-		     self ? self->name : "(Null)",
+		     self->name,
 		     (void*)f, (void*)o, (void*)param);
-	if (self && self->Getarg)
-	    arg = (*self->Getarg)(aTHX_ o, param, flags);
+	if (self->Getarg)
+	  arg = (*self->Getarg)(aTHX_ o, param, flags);
 	f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
 	if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
 	    PerlIOBase(f)->flags |= PERLIO_F_UTF8;
@@ -2245,12 +2204,18 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 
 /* Must be called with PL_perlio_mutex locked. */
 static void
-S_more_refcounted_fds(pTHX_ const int new_fd) {
+S_more_refcounted_fds(pTHX_ const int new_fd)
+  PERL_TSA_REQUIRES(PL_perlio_mutex)
+{
     dVAR;
     const int old_max = PL_perlio_fd_refcnt_size;
     const int new_max = 16 + (new_fd & ~15);
     int *new_array;
 
+#ifndef PERL_IMPLICIT_SYS
+    PERL_UNUSED_CONTEXT;
+#endif
+
     PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
 		 old_max, new_fd, new_max);
 
@@ -2385,7 +2350,6 @@ PerlIOUnix_refcnt(int fd)
 void
 PerlIO_cleanup(pTHX)
 {
-    dVAR;
     int i;
 #ifdef USE_ITHREADS
     PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
@@ -2465,6 +2429,9 @@ typedef struct {
 static void
 S_lockcnt_dec(pTHX_ const void* f)
 {
+#ifndef PERL_IMPLICIT_SYS
+    PERL_UNUSED_CONTEXT;
+#endif
     PerlIO_lockcnt((PerlIO*)f)--;
 }
 
@@ -2532,25 +2499,42 @@ PerlIOUnix_oflags(const char *mode)
 	    oflags |= O_WRONLY;
 	break;
     }
-#ifdef PERLIO_BINARY_AND_TEXT_DIFFERENT_AND_EFFECTIVE
-    if (*mode == 'b') {
-	oflags |= O_BINARY;
+
+    /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
+
+    /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
+     * of them in, and then bit-and-masking the other them away, won't
+     * have much of an effect. */
+    switch (*mode) {
+    case 'b':
+#if O_TEXT != O_BINARY
+        oflags |= O_BINARY;
 	oflags &= ~O_TEXT;
-	mode++;
-    }
-    else if (*mode == 't') {
+#endif
+        mode++;
+        break;
+    case 't':
+#if O_TEXT != O_BINARY
 	oflags |= O_TEXT;
 	oflags &= ~O_BINARY;
-	mode++;
-    }
-    else {
+#endif
+        mode++;
+        break;
+    default:
+#  if O_BINARY != 0
+        /* bit-or:ing with zero O_BINARY would be useless. */
 	/*
 	 * If neither "t" nor "b" was specified, open the file
 	 * in O_BINARY mode.
+         *
+         * Note that if something else than the zero byte was seen
+         * here (e.g. bogus mode "rx"), just few lines later we will
+         * set the errno and invalidate the flags.
 	 */
 	oflags |= O_BINARY;
+#  endif
+        break;
     }
-#endif
     if (*mode || oflags == -1) {
 	SETERRNO(EINVAL, LIB_INVARG);
 	oflags = -1;
@@ -2709,7 +2693,6 @@ PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 SSize_t
 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 {
-    dVAR;
     int fd;
     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
 	return -1;
@@ -2728,6 +2711,7 @@ PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 	    if (len < 0) {
 		if (errno != EAGAIN) {
 		    PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+		    PerlIO_save_errno(f);
 		}
 	    }
 	    else if (len == 0 && count != 0) {
@@ -2740,13 +2724,12 @@ PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 	if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
 	    return -1;
     }
-    /*NOTREACHED*/
+    NOT_REACHED; /*NOTREACHED*/
 }
 
 SSize_t
 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 {
-    dVAR;
     int fd;
     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
 	return -1;
@@ -2761,6 +2744,7 @@ PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 	    if (len < 0) {
 		if (errno != EAGAIN) {
 		    PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+		    PerlIO_save_errno(f);
 		}
 	    }
 	    return len;
@@ -2769,7 +2753,7 @@ PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 	if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
 	    return -1;
     }
-    /*NOTREACHED*/
+    NOT_REACHED; /*NOTREACHED*/
 }
 
 Off_t
@@ -2784,7 +2768,6 @@ PerlIOUnix_tell(pTHX_ PerlIO *f)
 IV
 PerlIOUnix_close(pTHX_ PerlIO *f)
 {
-    dVAR;
     const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
     int code = 0;
     if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
@@ -2926,11 +2909,27 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
 {
     dTHX;
     PerlIO *f = NULL;
+#ifdef EBCDIC
+	 int rc;
+	 char filename[FILENAME_MAX];
+	 fldata_t fileinfo;
+#endif
     if (stdio) {
 	PerlIOStdio *s;
         int fd0 = fileno(stdio);
         if (fd0 < 0) {
+#ifdef EBCDIC
+			  rc = fldata(stdio,filename,&fileinfo);
+			  if(rc != 0){
+				  return NULL;
+			  }
+			  if(fileinfo.__dsorgHFS){
+            return NULL;
+        }
+			  /*This MVS dataset , OK!*/
+#else
             return NULL;
+#endif
         }
 	if (!mode || !*mode) {
 	    /* We need to probe to see how we can open the stream
@@ -2962,7 +2961,24 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
 	if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
 	    s = PerlIOSelf(f, PerlIOStdio);
 	    s->stdio = stdio;
+#ifdef EBCDIC
+		fd0 = fileno(stdio);
+		if(fd0 != -1){
+			PerlIOUnix_refcnt_inc(fd0);
+		}
+		else{
+			rc = fldata(stdio,filename,&fileinfo);
+			if(rc != 0){
+				PerlIOUnix_refcnt_inc(fd0);
+			}
+			if(fileinfo.__dsorgHFS){
+				PerlIOUnix_refcnt_inc(fd0);
+			}
+			  /*This MVS dataset , OK!*/
+		}
+#else
 	    PerlIOUnix_refcnt_inc(fileno(stdio));
+#endif
 	}
     }
     return f;
@@ -3110,7 +3126,9 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
     /* XXX this could use PerlIO_canset_fileno() and
      * PerlIO_set_fileno() support from Configure
      */
-#  if defined(__UCLIBC__)
+#  if defined(HAS_FDCLOSE)
+    return fdclose(f, NULL) == 0 ? 1 : 0;
+#  elif defined(__UCLIBC__)
     /* uClibc must come before glibc because it defines __GLIBC__ as well. */
     f->__filedes = -1;
     return 1;
@@ -3223,6 +3241,28 @@ PerlIOStdio_close(pTHX_ PerlIO *f)
 		return 0;
 	    if (stdio == stdout || stdio == stderr)
 		return PerlIO_flush(f);
+        }
+#ifdef USE_ITHREADS
+        MUTEX_LOCK(&PL_perlio_mutex);
+        /* Right. We need a mutex here because for a brief while we
+           will have the situation that fd is actually closed. Hence if
+           a second thread were to get into this block, its dup() would
+           likely return our fd as its dupfd. (after all, it is closed)
+           Then if we get to the dup2() first, we blat the fd back
+           (messing up its temporary as a side effect) only for it to
+           then close its dupfd (== our fd) in its close(dupfd) */
+
+        /* There is, of course, a race condition, that any other thread
+           trying to input/output/whatever on this fd will be stuffed
+           for the duration of this little manoeuvrer. Perhaps we
+           should hold an IO mutex for the duration of every IO
+           operation if we know that invalidate doesn't work on this
+           platform, but that would suck, and could kill performance.
+
+           Except that correctness trumps speed.
+           Advice from klortho #11912. */
+#endif
+	if (invalidate) {
             /* Tricky - must fclose(stdio) to free memory but not close(fd)
 	       Use Sarathy's trick from maint-5.6 to invalidate the
 	       fileno slot of the FILE *
@@ -3231,30 +3271,9 @@ PerlIOStdio_close(pTHX_ PerlIO *f)
 	    SAVE_ERRNO;
 	    invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
 	    if (!invalidate) {
-#ifdef USE_ITHREADS
-		MUTEX_LOCK(&PL_perlio_mutex);
-		/* Right. We need a mutex here because for a brief while we
-		   will have the situation that fd is actually closed. Hence if
-		   a second thread were to get into this block, its dup() would
-		   likely return our fd as its dupfd. (after all, it is closed)
-		   Then if we get to the dup2() first, we blat the fd back
-		   (messing up its temporary as a side effect) only for it to
-		   then close its dupfd (== our fd) in its close(dupfd) */
-
-		/* There is, of course, a race condition, that any other thread
-		   trying to input/output/whatever on this fd will be stuffed
-		   for the duration of this little manoeuvrer. Perhaps we
-		   should hold an IO mutex for the duration of every IO
-		   operation if we know that invalidate doesn't work on this
-		   platform, but that would suck, and could kill performance.
-
-		   Except that correctness trumps speed.
-		   Advice from klortho #11912. */
-#endif
 		dupfd = PerlLIO_dup(fd);
 #ifdef USE_ITHREADS
 		if (dupfd < 0) {
-		    MUTEX_UNLOCK(&PL_perlio_mutex);
 		    /* Oh cXap. This isn't going to go well. Not sure if we can
 		       recover from here, or if closing this particular FILE *
 		       is a good idea now.  */
@@ -3279,10 +3298,10 @@ PerlIOStdio_close(pTHX_ PerlIO *f)
 	if (dupfd >= 0) {
 	    PerlLIO_dup2(dupfd,fd);
 	    PerlLIO_close(dupfd);
+	}
 #ifdef USE_ITHREADS
-	    MUTEX_UNLOCK(&PL_perlio_mutex);
+        MUTEX_UNLOCK(&PL_perlio_mutex);
 #endif
-	}
 	return result;
     }
 }
@@ -3290,7 +3309,6 @@ PerlIOStdio_close(pTHX_ PerlIO *f)
 SSize_t
 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 {
-    dVAR;
     FILE * s;
     SSize_t got = 0;
     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
@@ -3319,6 +3337,12 @@ PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 	    return -1;
 	SETERRNO(0,0);	/* just in case */
     }
+#ifdef __sgi
+    /* Under some circumstances IRIX stdio fgetc() and fread()
+     * set the errno to ENOENT, which makes no sense according
+     * to either IRIX or POSIX.  [rt.perl.org #123977] */
+    if (errno == ENOENT) SETERRNO(0,0);
+#endif
     return got;
 }
 
@@ -3383,7 +3407,6 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 SSize_t
 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 {
-    dVAR;
     SSize_t got;
     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
 	return -1;
@@ -3519,7 +3542,20 @@ 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
+        /* This is a long-standing infamous mess.  The root of the
+         * problem is that one cannot know the signedness of char, and
+         * more precisely the signedness of FILE._ptr.  The following
+         * things have been tried, and they have all failed (across
+         * different compilers (remember that core needs to to build
+         * also with c++) and compiler options:
+         *
+         * - casting the RHS to (void*) -- works in *some* places
+         * - casting the LHS to (void*) -- totally unportable
+         *
+         * So let's try silencing the warning at least for gcc. */
+        GCC_DIAG_IGNORE(-Wpointer-sign);
 	PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
+        GCC_DIAG_RESTORE;
 #ifdef STDIO_PTR_LVAL_SETS_CNT
 	assert(PerlSIO_get_cnt(stdio) == (cnt));
 #endif
@@ -3608,20 +3644,12 @@ PerlIOStdio_fill(pTHX_ PerlIO *f)
     }
 #endif
 
-#if defined(VMS)
-    /* An ungetc()d char is handled separately from the regular
-     * buffer, so we stuff it in the buffer ourselves.
-     * Should never get called as should hit code above
-     */
-    *(--((*stdio)->_ptr)) = (unsigned char) c;
-    (*stdio)->_cnt++;
-#else
     /* If buffer snoop scheme above fails fall back to
        using ungetc().
      */
     if (PerlSIO_ungetc(c, stdio) != c)
 	return EOF;
-#endif
+
     return 0;
 }
 
@@ -3745,7 +3773,6 @@ PerlIO_findFILE(PerlIO *f)
 void
 PerlIO_releaseFILE(PerlIO *p, FILE *f)
 {
-    dVAR;
     PerlIOl *l;
     while ((l = *p)) {
 	if (l->tab == &PerlIO_stdio) {
@@ -3893,6 +3920,7 @@ PerlIOBuf_flush(pTHX_ PerlIO *f)
 	    }
 	    else if (count < 0 || PerlIO_error(n)) {
 		PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+		PerlIO_save_errno(f);
 		code = -1;
 		break;
 	    }
@@ -3995,7 +4023,10 @@ PerlIOBuf_fill(pTHX_ PerlIO *f)
 	if (avail == 0)
 	    PerlIOBase(f)->flags |= PERLIO_F_EOF;
 	else
+	{
 	    PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+	    PerlIO_save_errno(f);
+	}
 	return -1;
     }
     b->end = b->buf + avail;
@@ -4777,7 +4808,6 @@ PERLIO_FUNCS_DECL(PerlIO_crlf) = {
 PerlIO *
 Perl_PerlIO_stdin(pTHX)
 {
-    dVAR;
     if (!PL_perlio) {
 	PerlIO_stdstreams(aTHX);
     }
@@ -4787,7 +4817,6 @@ Perl_PerlIO_stdin(pTHX)
 PerlIO *
 Perl_PerlIO_stdout(pTHX)
 {
-    dVAR;
     if (!PL_perlio) {
 	PerlIO_stdstreams(aTHX);
     }
@@ -4797,7 +4826,6 @@ Perl_PerlIO_stdout(pTHX)
 PerlIO *
 Perl_PerlIO_stderr(pTHX)
 {
-    dVAR;
     if (!PL_perlio) {
 	PerlIO_stdstreams(aTHX);
     }
@@ -4981,7 +5009,7 @@ PerlIO_tmpfile(void)
      char tempname[] = "/tmp/PerlIO_XXXXXX";
      const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
      SV * sv = NULL;
-     int old_umask = umask(0600);
+     int old_umask = umask(0177);
      /*
       * I have no idea how portable mkstemp() is ... NI-S
       */
@@ -5022,10 +5050,37 @@ PerlIO_tmpfile(void)
      return f;
 }
 
+void
+Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
+{
+    if (!PerlIOValid(f))
+	return;
+    PerlIOBase(f)->err = errno;
+#ifdef VMS
+    PerlIOBase(f)->os_err = vaxc$errno;
+#elif defined(OS2)
+    PerlIOBase(f)->os_err = Perl_rc;
+#elif defined(WIN32)
+    PerlIOBase(f)->os_err = GetLastError();
+#endif
+}
+
+void
+Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
+{
+    if (!PerlIOValid(f))
+	return;
+    SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
+#ifdef OS2
+    Perl_rc = PerlIOBase(f)->os_err);
+#elif defined(WIN32)
+    SetLastError(PerlIOBase(f)->os_err);
+#endif
+}
+
 #undef HAS_FSETPOS
 #undef HAS_FGETPOS
 
-#endif                          /* PERLIO_IS_STDIO */
 
 /*======================================================================================*/
 /*
@@ -5035,7 +5090,6 @@ PerlIO_tmpfile(void)
 const char *
 Perl_PerlIO_context_layers(pTHX_ const char *mode)
 {
-    dVAR;
     const char *direction = NULL;
     SV *layers;
     /*
@@ -5068,11 +5122,13 @@ int
 PerlIO_setpos(PerlIO *f, SV *pos)
 {
     if (SvOK(pos)) {
-	STRLEN len;
-	dTHX;
-	const Off_t * const posn = (Off_t *) SvPV(pos, len);
-	if (f && len == sizeof(Off_t))
-	    return PerlIO_seek(f, *posn, SEEK_SET);
+	if (f) {
+	    dTHX;
+	    STRLEN len;
+	    const Off_t * const posn = (Off_t *) SvPV(pos, len);
+	    if(len == sizeof(Off_t))
+		return PerlIO_seek(f, *posn, SEEK_SET);
+	}
     }
     SETERRNO(EINVAL, SS_IVCHAN);
     return -1;
@@ -5082,15 +5138,16 @@ PerlIO_setpos(PerlIO *f, SV *pos)
 int
 PerlIO_setpos(PerlIO *f, SV *pos)
 {
-    dTHX;
     if (SvOK(pos)) {
-	STRLEN len;
-	Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
-	if (f && len == sizeof(Fpos_t)) {
+	if (f) {
+	    dTHX;
+	    STRLEN len;
+	    Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
+	    if(len == sizeof(Fpos_t))
 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
-	    return fsetpos64(f, fpos);
+		return fsetpos64(f, fpos);
 #else
-	    return fsetpos(f, fpos);
+		return fsetpos(f, fpos);
 #endif
 	}
     }
@@ -5147,12 +5204,22 @@ vfprintf(FILE *fd, char *pat, char *args)
 
 #endif
 
+/* print a failure format string message to stderr and fail exit the process
+   using only libc without depending on any perl data structures being
+   initialized.
+*/
+
+void
+Perl_noperl_die(const char* pat, ...)
+{
+    va_list(arglist);
+    PERL_ARGS_ASSERT_NOPERL_DIE;
+    va_start(arglist, pat);
+    vfprintf(stderr, pat, arglist);
+    va_end(arglist);
+    exit(1);
+}
+
 /*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
  * ex: set ts=8 sts=4 sw=4 et:
  */