X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=ba932f3d6978cab7fde42c3e7d86dc07eed763ce;hb=b7dad2dc25528ee3fc23c1bca51116d48f988b04;hp=94b7c17fcd521f8a2e4b6c8627906806c9d6d884;hpb=8c0134a884f927d58f584b87281e5a27133cbf8f;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perlio.c b/perlio.c
index 94b7c17..ba932f3 100644
--- a/perlio.c
+++ b/perlio.c
@@ -93,6 +93,11 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
  return -1;
 }
 
+void
+PerlIO_destruct(pTHX)
+{
+}
+
 int
 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
 {
@@ -115,7 +120,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int
       {
        fd = PerlLIO_open3(name,imode,perm);
        if (fd >= 0)
-        return PerlIO_fdopen(fd,mode+1);
+        return PerlIO_fdopen(fd,(char *)mode+1);
       }
      else if (old)
       {
@@ -129,7 +134,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int
   }
  else
   {
-   return PerlIO_fdopen(fd,mode);
+   return PerlIO_fdopen(fd,(char *)mode);
   }
  return NULL;
 }
@@ -313,6 +318,37 @@ PerlIO_cleanup()
 }
 
 void
+PerlIO_destruct(pTHX)
+{
+ PerlIO **table = &_perlio;
+ PerlIO *f;
+ while ((f = *table))
+  {
+   int i;
+   table = (PerlIO **)(f++);
+   for (i=1; i < PERLIO_TABLE_SIZE; i++)
+    {
+     PerlIO *x = f;
+     PerlIOl *l;
+     while ((l = *x))
+      {
+       if (l->tab->kind & PERLIO_K_DESTRUCT)
+        {
+         PerlIO_debug("Destruct popping %s\n",l->tab->name);
+         PerlIO_flush(x);
+         PerlIO_pop(aTHX_ x);
+        }
+       else
+        {
+         x = PerlIONext(x);
+        }
+      }
+     f++;
+    }
+  }
+}
+
+void
 PerlIO_pop(pTHX_ PerlIO *f)
 {
  PerlIOl *l = *f;
@@ -329,35 +365,15 @@ PerlIO_pop(pTHX_ PerlIO *f)
 /*--------------------------------------------------------------------------------------*/
 /* XS Interface for perl code */
 
-XS(XS_perlio_import)
-{
- dXSARGS;
- GV *gv = CvGV(cv);
- char *s = GvNAME(gv);
- STRLEN l = GvNAMELEN(gv);
- PerlIO_debug("%.*s\n",(int) l,s);
- XSRETURN_EMPTY;
-}
-
-XS(XS_perlio_unimport)
-{
- dXSARGS;
- GV *gv = CvGV(cv);
- char *s = GvNAME(gv);
- STRLEN l = GvNAMELEN(gv);
- PerlIO_debug("%.*s\n",(int) l,s);
- XSRETURN_EMPTY;
-}
-
 SV *
-PerlIO_find_layer(pTHX_ const char *name, STRLEN len)
+PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
 {
  SV **svp;
  SV *sv;
  if ((SSize_t) len <= 0)
   len = strlen(name);
  svp  = hv_fetch(PerlIO_layer_hv,name,len,0);
- if (!svp && PL_subname && PerlIO_layer_av && av_len(PerlIO_layer_av)+1 >= 2)
+ if (!svp && load && PL_subname && PerlIO_layer_av && av_len(PerlIO_layer_av)+1 >= 2)
   {
    SV *pkgsv  = newSVpvn("PerlIO",6);
    SV *layer  = newSVpvn(name,len);
@@ -373,7 +389,7 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len)
    if (SvROK(sv))
     return *svp;
   }
- return NULL;
+ return Nullsv;
 }
 
 
@@ -445,7 +461,7 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
   {
    STRLEN len;
    const char *name = SvPV(ST(i),len);
-   SV *layer  = PerlIO_find_layer(aTHX_ name,len);
+   SV *layer  = PerlIO_find_layer(aTHX_ name,len,1);
    if (layer)
     {
      av_push(av,SvREFCNT_inc(layer));
@@ -463,7 +479,7 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
 SV *
 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
 {
- HV *stash = gv_stashpv("perlio::Layer", TRUE);
+ HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
  SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
  return sv;
 }
@@ -544,7 +560,7 @@ PerlIO_parse_layers(pTHX_ AV *av, const char *names)
         }
        if (e > s)
         {
-         SV *layer = PerlIO_find_layer(aTHX_ s,llen);
+         SV *layer = PerlIO_find_layer(aTHX_ s,llen,1);
          if (layer)
           {
            av_push(av,SvREFCNT_inc(layer));
@@ -578,7 +594,7 @@ PerlIO_default_buffer(pTHX_ AV *av)
     }
   }
  PerlIO_debug("Pushing %s\n",tab->name);
- av_push(av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0)));
+ av_push(av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0,0)));
  av_push(av,&PL_sv_undef);
 }
 
@@ -612,8 +628,6 @@ PerlIO_default_layers(pTHX)
   {
    const char *s  = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
    PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
-   newXS("perlio::import",XS_perlio_import,__FILE__);
-   newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
 #if 0
    newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
 #endif
@@ -627,7 +641,7 @@ PerlIO_default_layers(pTHX)
 #endif
    PerlIO_define_layer(aTHX_ &PerlIO_utf8);
    PerlIO_define_layer(aTHX_ &PerlIO_byte);
-   av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ PerlIO_unix.name,0)));
+   av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ PerlIO_unix.name,0,0)));
    av_push(PerlIO_layer_av,&PL_sv_undef);
    if (s)
     {
@@ -811,22 +825,36 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
 int
 PerlIO__close(PerlIO *f)
 {
- return (*PerlIOBase(f)->tab->Close)(f);
+ if (f && *f)
+   return (*PerlIOBase(f)->tab->Close)(f);
+ else
+  {
+   SETERRNO(EBADF,SS$_IVCHAN);
+   return -1;
+  }
 }
 
 #undef PerlIO_fdupopen
 PerlIO *
 PerlIO_fdupopen(pTHX_ PerlIO *f)
 {
- char buf[8];
- int fd = PerlLIO_dup(PerlIO_fileno(f));
- PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
- if (new)
+ if (f && *f)
   {
-   Off_t posn = PerlIO_tell(f);
-   PerlIO_seek(new,posn,SEEK_SET);
+   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);
+    }
+   return new;
+  }
+ else
+  {
+   SETERRNO(EBADF,SS$_IVCHAN);
+   return NULL;
   }
- return new;
 }
 
 #undef PerlIO_close
@@ -850,7 +878,13 @@ PerlIO_close(PerlIO *f)
 int
 PerlIO_fileno(PerlIO *f)
 {
- return (*PerlIOBase(f)->tab->Fileno)(f);
+ if (f && *f)
+  return (*PerlIOBase(f)->tab->Fileno)(f);
+ else
+  {
+   SETERRNO(EBADF,SS$_IVCHAN);
+   return -1;
+  }
 }
 
 static const char *
@@ -879,6 +913,28 @@ PerlIO_context_layers(pTHX_ const char *mode)
  return type;
 }
 
+static SV *
+PerlIO_layer_from_ref(pTHX_ SV *sv)
+{
+ /* For any scalar type load the handler which is bundled with perl */
+ if (SvTYPE(sv) < SVt_PVAV)
+  return PerlIO_find_layer(aTHX_ "Scalar",6, 1);
+
+ /* For other types allow if layer is known but don't try and load it */
+ switch (SvTYPE(sv))
+  {
+   case SVt_PVAV:
+    return PerlIO_find_layer(aTHX_ "Array",5, 0);
+   case SVt_PVHV:
+    return PerlIO_find_layer(aTHX_ "Hash",4, 0);
+   case SVt_PVCV:
+    return PerlIO_find_layer(aTHX_ "Code",4, 0);
+   case SVt_PVGV:
+    return PerlIO_find_layer(aTHX_ "Glob",4, 0);
+  }
+ return Nullsv;
+}
+
 AV *
 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
 {
@@ -888,37 +944,22 @@ PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **a
   PerlIO_stdstreams(aTHX);
  if (narg)
   {
-   if (SvROK(*args))
+   SV *arg = *args;
+   /* If it is a reference but not an object see if we have a handler for it */
+   if (SvROK(arg) && !sv_isobject(arg))
     {
-     if (sv_isobject(*args))
+     SV *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
+     if (handler)
       {
-       SV *handler = PerlIO_find_layer(aTHX_ "object",6);
-       if (handler)
-        {
-         def    = newAV();
-         av_push(def,handler);
-         av_push(def,&PL_sv_undef);
-         incdef = 0;
-        }
-      }
-     else
-      {
-       if (SvTYPE(SvRV(*args)) < SVt_PVAV)
-        {
-         SV *handler = PerlIO_find_layer(aTHX_ "Scalar",6);
-         if (handler)
-          {
-           def    = newAV();
-           av_push(def,handler);
-           av_push(def,&PL_sv_undef);
-           incdef = 0;
-          }
-        }
-       else
-        {
-         Perl_croak(aTHX_ "Unsupported reference arg to open()");
-        }
+       def = newAV();
+       av_push(def,SvREFCNT_inc(handler));
+       av_push(def,&PL_sv_undef);
+       incdef = 0;
       }
+     /* Don't fail if handler cannot be found
+      * :Via(...) etc. may do something sensible
+      * else we will just stringfy and open resulting string.
+      */
     }
   }
  if (!layers)
@@ -1050,35 +1091,65 @@ PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
 SSize_t
 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
 {
- return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
+ if (f && *f)
+  return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
+ else
+  {
+   SETERRNO(EBADF,SS$_IVCHAN);
+   return -1;
+  }
 }
 
 #undef PerlIO_unread
 SSize_t
 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
 {
- return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
+ if (f && *f)
+  return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
+ else
+  {
+   SETERRNO(EBADF,SS$_IVCHAN);
+   return -1;
+  }
 }
 
 #undef PerlIO_write
 SSize_t
 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
 {
- return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
+ if (f && *f)
+  return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
+ else
+  {
+   SETERRNO(EBADF,SS$_IVCHAN);
+   return -1;
+  }
 }
 
 #undef PerlIO_seek
 int
 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
 {
- return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
+ if (f && *f)
+  return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
+ else
+  {
+   SETERRNO(EBADF,SS$_IVCHAN);
+   return -1;
+  }
 }
 
 #undef PerlIO_tell
 Off_t
 PerlIO_tell(PerlIO *f)
 {
- return (*PerlIOBase(f)->tab->Tell)(f);
+  if (f && *f)
+   return (*PerlIOBase(f)->tab->Tell)(f);
+  else
+   {
+    SETERRNO(EBADF,SS$_IVCHAN);
+    return -1;
+   }
 }
 
 #undef PerlIO_flush
@@ -1087,20 +1158,35 @@ PerlIO_flush(PerlIO *f)
 {
  if (f)
   {
-   PerlIO_funcs *tab = PerlIOBase(f)->tab;
-   if (tab && tab->Flush)
+   if (*f)
     {
-     return (*tab->Flush)(f);
+     PerlIO_funcs *tab = PerlIOBase(f)->tab;
+     if (tab && tab->Flush)
+      {
+       return (*tab->Flush)(f);
+      }
+     else
+      {
+       PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
+       SETERRNO(EBADF,SS$_IVCHAN);
+       return -1;
+      }
     }
    else
     {
-     PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
-     errno = EINVAL;
+     PerlIO_debug("Cannot flush f=%p\n",f);
+     SETERRNO(EBADF,SS$_IVCHAN);
      return -1;
     }
   }
- else
-  {
+ else  
+  {   
+   /* Is it good API design to do flush-all on NULL,
+    * a potentially errorneous input?  Maybe some magical
+    * value (PerlIO* PERLIO_FLUSH_ALL = (PerlIO*)-1;)?
+    * Yes, stdio does similar things on fflush(NULL),
+    * but should we be bound by their design decisions?
+    * --jhi */
    PerlIO **table = &_perlio;
    int code = 0;
    while ((f = *table))
@@ -1118,32 +1204,75 @@ PerlIO_flush(PerlIO *f)
   }
 }
 
+void
+PerlIOBase_flush_linebuf()
+{
+ PerlIO **table = &_perlio;
+ PerlIO *f;
+ while ((f = *table))
+  {
+   int i;
+   table = (PerlIO **)(f++);
+   for (i=1; i < PERLIO_TABLE_SIZE; i++)
+    {
+     if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
+                == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
+      PerlIO_flush(f);
+     f++;
+    }
+  }
+}
+
 #undef PerlIO_fill
 int
 PerlIO_fill(PerlIO *f)
 {
- return (*PerlIOBase(f)->tab->Fill)(f);
+ if (f && *f)
+  return (*PerlIOBase(f)->tab->Fill)(f);
+ else
+  {
+   SETERRNO(EBADF,SS$_IVCHAN);
+   return -1;
+  } 
 }
 
 #undef PerlIO_isutf8
 int
 PerlIO_isutf8(PerlIO *f)
 {
- return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
+ if (f && *f)
+  return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
+ else
+  {
+   SETERRNO(EBADF,SS$_IVCHAN);
+   return -1;
+  }
 }
 
 #undef PerlIO_eof
 int
 PerlIO_eof(PerlIO *f)
 {
- return (*PerlIOBase(f)->tab->Eof)(f);
+ if (f && *f)
+  return (*PerlIOBase(f)->tab->Eof)(f);
+ else
+  {
+   SETERRNO(EBADF,SS$_IVCHAN);
+   return -1;
+  }
 }
 
 #undef PerlIO_error
 int
 PerlIO_error(PerlIO *f)
 {
- return (*PerlIOBase(f)->tab->Error)(f);
+ if (f && *f)
+  return (*PerlIOBase(f)->tab->Error)(f);
+ else
+  {
+   SETERRNO(EBADF,SS$_IVCHAN);
+   return -1;
+  }
 }
 
 #undef PerlIO_clearerr
@@ -1152,23 +1281,25 @@ PerlIO_clearerr(PerlIO *f)
 {
  if (f && *f)
   (*PerlIOBase(f)->tab->Clearerr)(f);
+ else
+  SETERRNO(EBADF,SS$_IVCHAN);
 }
 
 #undef PerlIO_setlinebuf
 void
 PerlIO_setlinebuf(PerlIO *f)
 {
- (*PerlIOBase(f)->tab->Setlinebuf)(f);
+ if (f && *f)
+  (*PerlIOBase(f)->tab->Setlinebuf)(f);
+ else
+  SETERRNO(EBADF,SS$_IVCHAN);
 }
 
 #undef PerlIO_has_base
 int
 PerlIO_has_base(PerlIO *f)
 {
- if (f && *f)
-  {
-   return (PerlIOBase(f)->tab->Get_base != NULL);
-  }
+ if (f && *f) { return (PerlIOBase(f)->tab->Get_base != NULL); }
  return 0;
 }
 
@@ -1212,14 +1343,18 @@ PerlIO_canset_cnt(PerlIO *f)
 STDCHAR *
 PerlIO_get_base(PerlIO *f)
 {
- return (*PerlIOBase(f)->tab->Get_base)(f);
+ if (f && *f)
+  return (*PerlIOBase(f)->tab->Get_base)(f);
+ return NULL;
 }
 
 #undef PerlIO_get_bufsiz
 int
 PerlIO_get_bufsiz(PerlIO *f)
 {
- return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
+ if (f && *f)
+  return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
+ return 0;
 }
 
 #undef PerlIO_get_ptr
@@ -1430,6 +1565,8 @@ PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
   l->flags |= PERLIO_F_FASTGETS;
  if (mode)
   {
+   if (*mode == '#' || *mode == 'I')
+    mode++;
    switch (*mode++)
     {
      case 'r':
@@ -1442,7 +1579,7 @@ PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
       l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
       break;
      default:
-      errno = EINVAL;
+      SETERRNO(EINVAL,LIB$_INVARG);
       return -1;
     }
    while (*mode)
@@ -1459,8 +1596,8 @@ PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
         l->flags |= PERLIO_F_CRLF;
         break;
       default:
-       errno = EINVAL;
-       return -1;
+        SETERRNO(EINVAL,LIB$_INVARG);
+        return -1;
       }
     }
   }
@@ -1509,7 +1646,9 @@ PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
    while (count > 0)
     {
      SSize_t avail = PerlIO_get_cnt(f);
-     SSize_t take  = (count < avail) ? count : avail;
+     SSize_t take = 0;
+     if (avail > 0)
+       take = (count < avail) ? count : avail;
      if (take > 0)
       {
        STDCHAR *ptr = PerlIO_get_ptr(f);
@@ -1658,7 +1797,7 @@ PerlIOUnix_oflags(const char *mode)
  oflags |= O_BINARY;
  if (*mode || oflags == -1)
   {
-   errno = EINVAL;
+   SETERRNO(EINVAL,LIB$_INVARG);
    oflags = -1;
   }
  return oflags;
@@ -2050,13 +2189,14 @@ IV
 PerlIOStdio_close(PerlIO *f)
 {
  dTHX;
-#ifdef HAS_SOCKS5_INIT
- int optval, optlen = sizeof(int);
+#ifdef SOCKS5_VERSION_NAME
+ int optval;
+ Sock_size_t optlen = sizeof(int);
 #endif
  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
  return(
-#ifdef HAS_SOCKS5_INIT
-   (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
+#ifdef SOCKS5_VERSION_NAME
+   (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
        PerlSIO_fclose(stdio) :
        close(PerlIO_fileno(f))
 #else
@@ -2309,7 +2449,7 @@ PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
  dTHX;
  if (fd >= 0 && PerlLIO_isatty(fd))
   {
-   PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
+   PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
   }
  posn = PerlIO_tell(PerlIONext(f));
  if (posn != (Off_t) -1)
@@ -2428,6 +2568,8 @@ PerlIOBuf_fill(PerlIO *f)
   */
  if (PerlIO_flush(f) != 0)
   return -1;
+ if (PerlIOBase(f)->flags & PERLIO_F_TTY)
+  PerlIOBase_flush_linebuf();
 
  if (!b->buf)
   PerlIO_get_base(f); /* allocate via vtable */
@@ -3669,7 +3811,7 @@ PerlIO_setpos(PerlIO *f, SV *pos)
    if (f && len == sizeof(Off_t))
     return PerlIO_seek(f,*posn,SEEK_SET);
   }
- errno = EINVAL;
+ SETERRNO(EINVAL,SS$_IVCHAN);
  return -1;
 }
 #else
@@ -3691,7 +3833,7 @@ PerlIO_setpos(PerlIO *f, SV *pos)
 #endif
     }
   }
- errno = EINVAL;
+ SETERRNO(EINVAL,SS$_IVCHAN);
  return -1;
 }
 #endif