X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=a2289e3806d474618a7b86d26f13dc75744f2483;hb=679ac26e110ef97fbf30ce13479d7051699b4a34;hp=46cafa0d3bd49c1a162949951b036556c3378148;hpb=f6c77cf1bf4d7cb2c7a64dd7608120b471f84062;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perlio.c b/perlio.c
index 46cafa0..a2289e3 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)
 {
@@ -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)
     {
@@ -684,8 +698,8 @@ PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
    l->next = *f;
    l->tab  = tab;
    *f      = l;
-   PerlIO_debug("PerlIO_push f=%p %s %s '%s'\n",f,tab->name,
-                 (mode) ? mode : "(Null)",(arg) ? SvPV_nolen(arg) : "(Null)");
+   PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
+                 (mode) ? mode : "(Null)",arg);
    if ((*l->tab->Pushed)(f,mode,arg) != 0)
     {
      PerlIO_pop(aTHX_ f);
@@ -754,7 +768,7 @@ PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, AV *layers, IV n)
     {
      if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
       {
-       code -1;
+       code = -1;
        break;
       }
     }
@@ -879,6 +893,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 +924,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_find_layer(aTHX_ "object",6);
-       if (handler)
-        {
-         def    = newAV();
-         av_push(def,handler);
-         av_push(def,&PL_sv_undef);
-         incdef = 0;
-        }
-      }
-     else
+     SV *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
+     if (handler)
       {
-       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)
@@ -1118,6 +1139,25 @@ 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)
@@ -1430,6 +1470,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':
@@ -2051,12 +2093,13 @@ PerlIOStdio_close(PerlIO *f)
 {
  dTHX;
 #ifdef HAS_SOCKS5_INIT
- int optval, optlen = sizeof(int);
+ 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) ?
+   (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
        PerlSIO_fclose(stdio) :
        close(PerlIO_fileno(f))
 #else
@@ -2306,9 +2349,10 @@ PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
  int fd  = PerlIO_fileno(f);
  Off_t posn;
+ 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)
@@ -2427,6 +2471,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 */