X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=2dc18b2624322103e0dfb78b925f0368e1071e61;hb=14fc01c41090ee224fd726e5a5418c61e16bd662;hp=ff68dfbb116d6f33ed8be551ef9292e396035afb;hpb=e85294730ea95da49196ebe8f63ce0db11ebd231;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perlio.c b/perlio.c
index ff68dfb..2dc18b2 100644
--- a/perlio.c
+++ b/perlio.c
@@ -640,6 +640,36 @@ PerlIO_pop(pTHX_ PerlIO *f)
     }
 }
 
+/* Return as an array the stack of layers on a filehandle.  Note that
+ * the stack is returned top-first in the array, and there are three
+ * times as many array elements as there are layers in the stack: the
+ * first element of a layer triplet is the name, the second one is the
+ * arguments, and the third one is the flags. */
+
+AV *
+PerlIO_get_layers(pTHX_ PerlIO *f)
+{
+     AV *av = newAV();
+
+     if (PerlIOValid(f)) {
+          dSP;
+	  PerlIOl *l = PerlIOBase(f);
+
+	  while (l) {
+	       SV *name = l->tab && l->tab->name ?
+		    newSVpv(l->tab->name, 0) : &PL_sv_undef;
+	       SV *arg = l->tab && l->tab->Getarg ?
+		    (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
+	       av_push(av, name);
+	       av_push(av, arg);
+	       av_push(av, newSViv((IV)l->flags));
+	       l = l->next;
+	  }
+     }
+
+     return av;
+}
+
 /*--------------------------------------------------------------------------------------*/
 /*
  * XS Interface for perl code
@@ -666,8 +696,13 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
 	} else {
 	    SV *pkgsv = newSVpvn("PerlIO", 6);
 	    SV *layer = newSVpvn(name, len);
-	    ENTER;
+	    CV *cv  = get_cv("PerlIO::Layer::NoWarnings", FALSE);
+    	    ENTER;
 	    SAVEINT(PL_in_load_module);
+	    if (cv) {
+	        SAVESPTR(PL_warnhook);
+		PL_warnhook = (SV *) cv;
+	    }
 	    PL_in_load_module++;
 	    /*
 	     * The two SVs are magically freed by load_module
@@ -770,6 +805,17 @@ PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
     return sv;
 }
 
+XS(XS_PerlIO__Layer__NoWarnings)
+{
+    /* This is used as a %SIG{__WARN__} handler to supress warnings 
+       during loading of layers.
+     */
+    dXSARGS;
+    if (items)
+    	PerlIO_debug("warning:%s\n",SvPV_nolen(ST(0)));
+    XSRETURN(0);
+}
+
 XS(XS_PerlIO__Layer__find)
 {
     dXSARGS;
@@ -1012,6 +1058,7 @@ Perl_boot_core_PerlIO(pTHX)
 	  __FILE__);
 #endif
     newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
+    newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
 }
 
 PerlIO_funcs *
@@ -2719,14 +2766,19 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
        even if that would be treated as 0xFF - so will 
        a dup fail ...
      */
-    f->_file = PerlLIO_dup(fd);
+    f->_file = PerlLIO_dup(fileno(f));
 #    endif /* defined(_LP64) */
     return 1;
 #  elif defined(__hpux)
     f->__fileH = 0xff;
     f->__fileL = 0xff;
     return 1;
-#  elif defined(_AIX)
+   /* Next one ->_file seems to be a reasonable fallback, i.e. if
+      your platform does not have special entry try this one.       
+      [For OSF only have confirmation for Tru64 (alpha)
+      but assume other OSFs will be similar.]
+    */    
+#  elif defined(_AIX) || defined(__osf__) || defined(__irix__)
     f->_file = -1;
     return 1;
 #  elif defined(__FreeBSD__)
@@ -2746,6 +2798,10 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
 #  elif defined(WIN32)
 #    if defined(__BORLANDC__)
     f->fd = PerlLIO_dup(fileno(f));
+#    elif defined(UNDER_CE)
+    /* WIN_CE does not have access to FILE internals, it hardly has FILE
+       structure at all
+     */
 #    else
     f->_file = -1;
 #    endif
@@ -2773,7 +2829,7 @@ PerlIOStdio_close(pTHX_ PerlIO *f)
         int fd = fileno(stdio);
 	int socksfd = 0;
 	int invalidate = 0;
-	IV result;
+	IV result = 0;
 	int saveerr = 0;
 	int dupfd = 0;
 #ifdef SOCKS5_VERSION_NAME
@@ -2808,6 +2864,7 @@ PerlIOStdio_close(pTHX_ PerlIO *f)
 	       Use Sarathy's trick from maint-5.6 to invalidate the 
 	       fileno slot of the FILE * 
 	    */ 
+	    result = PerlIO_flush(f);
 	    saveerr = errno;
     	    if (!(invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio))) {
 	    	dupfd = PerlLIO_dup(fd);
@@ -2838,20 +2895,26 @@ PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 {
     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
     SSize_t got = 0;
-    if (count == 1) {
-	STDCHAR *buf = (STDCHAR *) vbuf;
-	/*
-	 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
-	 * stdio does not do that for fread()
-	 */
-	int ch = PerlSIO_fgetc(s);
-	if (ch != EOF) {
-	    *buf = ch;
-	    got = 1;
+    for (;;) {
+	if (count == 1) {
+	    STDCHAR *buf = (STDCHAR *) vbuf;
+	    /*
+	     * Perl is expecting PerlIO_getc() to fill the buffer Linux's
+	     * stdio does not do that for fread()
+	     */
+	    int ch = PerlSIO_fgetc(s);
+	    if (ch != EOF) {
+		*buf = ch;
+		got = 1;
+	    }
 	}
+	else
+	    got = PerlSIO_fread(vbuf, 1, count, s);
+	if (got || errno != EINTR)
+	    break;
+	PERL_ASYNC_CHECK();
+	errno = 0;	/* just in case */
     }
-    else
-	got = PerlSIO_fread(vbuf, 1, count, s);
     return got;
 }
 
@@ -2916,8 +2979,16 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 SSize_t
 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 {
-    return PerlSIO_fwrite(vbuf, 1, count,
-			  PerlIOSelf(f, PerlIOStdio)->stdio);
+    SSize_t got;
+    for (;;) {
+	got = PerlSIO_fwrite(vbuf, 1, count,
+			      PerlIOSelf(f, PerlIOStdio)->stdio);
+	if (got || errno != EINTR)
+	    break;
+	PERL_ASYNC_CHECK();
+	errno = 0;	/* just in case */
+    }
+    return got;
 }
 
 IV
@@ -3302,7 +3373,7 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 #ifdef PERLIO_USING_CRLF
 #  ifdef PERLIO_IS_BINMODE_FD
 		if (PERLIO_IS_BINMODE_FD(fd))
-		    PerlIO_binmode(f,  '<'/*not used*/, O_BINARY, Nullch);
+		    PerlIO_binmode(aTHX_ f,  '<'/*not used*/, O_BINARY, Nullch);
 		else
 #  endif
 		/*