X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=e1730c8ac397a79a880c199e69d20c66bcecd277;hb=055bb491aa1c61403cb7de2ea930a89a362e1807;hp=ac5ace88db6cc7c8bf49c8f48c7fbc0ba022e23b;hpb=e06a3afbe255226c27f480b83177014c2fe65464;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perlio.c b/perlio.c
index ac5ace8..e1730c8 100644
--- a/perlio.c
+++ b/perlio.c
@@ -39,6 +39,8 @@
 #define PERL_IN_PERLIO_C
 #include "perl.h"
 
+#include "XSUB.h"
+
 #undef PerlMemShared_calloc
 #define PerlMemShared_calloc(x,y) calloc(x,y)
 #undef PerlMemShared_free
@@ -60,7 +62,11 @@ perlsio_binmode(FILE *fp, int iotype, int mode)
     return 0;
 #  else
     dTHX;
+	#ifdef NETWARE
+	if (PerlLIO_setmode(fp, mode) != -1) {
+	#else
     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
+	#endif
 #    if defined(WIN32) && defined(__BORLANDC__)
 	/* The translation mode of the stream is maintained independent
 	 * of the translation mode of the fd in the Borland RTL (heavy
@@ -154,6 +160,26 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int
  return NULL;
 }
 
+XS(XS_PerlIO__Layer__find)
+{
+ dXSARGS;
+ if (items < 2)
+  Perl_croak(aTHX_ "Usage class->find(name[,load])");
+ else
+  {
+   char *name = SvPV_nolen(ST(1));
+   ST(0) = (strEQ(name,"crlf") || strEQ(name,"raw")) ? &PL_sv_yes : &PL_sv_undef;
+   XSRETURN(1);
+  }
+}
+
+
+void
+Perl_boot_core_PerlIO(pTHX)
+{
+ newXS("PerlIO::Layer::find",XS_PerlIO__Layer__find,__FILE__);
+}
+
 #endif
 
 
@@ -247,7 +273,6 @@ PerlIO_findFILE(PerlIO *pio)
 #include <sys/mman.h>
 #endif
 
-#include "XSUB.h"
 
 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
 
@@ -382,6 +407,7 @@ PerlIO_list_free(PerlIO_list_t *list)
 void
 PerlIO_list_push(PerlIO_list_t *list,PerlIO_funcs *funcs,SV *arg)
 {
+ dTHX;
  PerlIO_pair_t *p;
  if (list->cur >= list->len)
   {
@@ -394,7 +420,6 @@ PerlIO_list_push(PerlIO_list_t *list,PerlIO_funcs *funcs,SV *arg)
  p = &(list->array[list->cur++]);
  p->funcs = funcs;
  if ((p->arg = arg)) {
-  dTHX; 
   SvREFCNT_inc(arg);
  }
 }
@@ -455,8 +480,14 @@ PerlIO_pop(pTHX_ PerlIO *f)
   {
    PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
    if (l->tab->Popped)
-    (*l->tab->Popped)(f);
-   *f = l->next;
+    {
+     /* If popped returns non-zero do not free its layer structure
+        it has either done so itself, or it is shared and still in use
+      */
+     if ((*l->tab->Popped)(f) != 0)
+      return;
+    }
+   *f = l->next;;
    PerlMemShared_free(l);
   }
 }
@@ -473,7 +504,7 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
  for (i=0; i < PerlIO_known_layers->cur; i++)
   {
    PerlIO_funcs *f = PerlIO_known_layers->array[i].funcs;
-   if (strEQ(f->name,name))
+   if (memEQ(f->name,name,len))
     {
      PerlIO_debug("%.*s => %p\n",(int)len,name,f);
      return f;
@@ -586,6 +617,22 @@ PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
  return sv;
 }
 
+XS(XS_PerlIO__Layer__find)
+{
+ dXSARGS;
+ if (items < 2)
+  Perl_croak(aTHX_ "Usage class->find(name[,load])");
+ else
+  {
+   STRLEN len = 0;
+   char *name = SvPV(ST(1),len);
+   bool load  = (items > 2) ? SvTRUE(ST(2)) : 0;
+   PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load);
+   ST(0) = (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : &PL_sv_undef;
+   XSRETURN(1);
+  }
+}
+
 void
 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
 {
@@ -707,7 +754,7 @@ PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av,IV n,PerlIO_funcs *def)
 {
  if (n >= 0 && n < av->cur)
   {
-   PerlIO_debug("Layer %ld is %s\n",n,av->array[n].funcs->name);
+   PerlIO_debug("Layer %"IVdf" is %s\n",n,av->array[n].funcs->name);
    return av->array[n].funcs;
   }
  if (!def)
@@ -721,14 +768,16 @@ PerlIO_default_layers(pTHX)
  if (!PerlIO_def_layerlist)
   {
    const char *s  = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
-   PerlIO_def_layerlist = PerlIO_list_alloc();
-
-#ifdef USE_ATTRIBUTES_FOR_PERLIO
-   newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
+   PerlIO_funcs *osLayer = &PerlIO_unix;
+   PerlIO_def_layerlist  = PerlIO_list_alloc();
+   PerlIO_define_layer(aTHX_ &PerlIO_unix);
+#if defined(WIN32) && !defined(UNDER_CE)
+   PerlIO_define_layer(aTHX_ &PerlIO_win32);
+#if 0
+   osLayer = &PerlIO_win32;
+#endif
 #endif
-
    PerlIO_define_layer(aTHX_ &PerlIO_raw);
-   PerlIO_define_layer(aTHX_ &PerlIO_unix);
    PerlIO_define_layer(aTHX_ &PerlIO_perlio);
    PerlIO_define_layer(aTHX_ &PerlIO_stdio);
    PerlIO_define_layer(aTHX_ &PerlIO_crlf);
@@ -737,7 +786,7 @@ PerlIO_default_layers(pTHX)
 #endif
    PerlIO_define_layer(aTHX_ &PerlIO_utf8);
    PerlIO_define_layer(aTHX_ &PerlIO_byte);
-   PerlIO_list_push(PerlIO_def_layerlist,PerlIO_find_layer(aTHX_ PerlIO_unix.name,0,0),&PL_sv_undef);
+   PerlIO_list_push(PerlIO_def_layerlist,PerlIO_find_layer(aTHX_ osLayer->name,0,0),&PL_sv_undef);
    if (s)
     {
      PerlIO_parse_layers(aTHX_ PerlIO_def_layerlist,s);
@@ -754,6 +803,14 @@ PerlIO_default_layers(pTHX)
  return PerlIO_def_layerlist;
 }
 
+void
+Perl_boot_core_PerlIO(pTHX)
+{
+#ifdef USE_ATTRIBUTES_FOR_PERLIO
+   newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
+#endif
+   newXS("PerlIO::Layer::find",XS_PerlIO__Layer__find,__FILE__);
+}
 
 PerlIO_funcs *
 PerlIO_default_layer(pTHX_ I32 n)
@@ -897,8 +954,7 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
  if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
   {
    PerlIO *top = f;
-   PerlIOl *l;
-   while ((l = *top))
+   while (*top)
     {
      if (PerlIOBase(top)->tab == &PerlIO_crlf)
       {
@@ -1719,11 +1775,12 @@ SSize_t
 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
 {
  dTHX;
+ /* Save the position as current head considers it */
  Off_t old = PerlIO_tell(f);
  SSize_t done;
  PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
+ PerlIOSelf(f,PerlIOBuf)->posn = old;
  done = PerlIOBuf_unread(f,vbuf,count);
- PerlIOSelf(f,PerlIOBuf)->posn = old - done;
  return done;
 }
 
@@ -1840,6 +1897,8 @@ int
 PerlIOUnix_oflags(const char *mode)
 {
  int oflags = -1;
+ if (*mode == 'I' || *mode == '#')
+  mode++;
  switch(*mode)
   {
    case 'r':
@@ -2570,7 +2629,7 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char
    if (*mode == 'I')
     {
      init = 1;
-     mode++;
+     /* mode++; */
     }
    f = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,NULL,narg,args);
    if (f)
@@ -2740,22 +2799,31 @@ PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
   {
    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
     {
+     /* Buffer is already a read buffer, we can overwrite any chars
+        which have been read back to buffer start
+      */
      avail = (b->ptr - b->buf);
     }
    else
     {
-     avail = b->bufsiz;
+     /* Buffer is idle, set it up so whole buffer is available for unread */
+     avail  = b->bufsiz;
      b->end = b->buf + avail;
      b->ptr = b->end;
      PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
+     /* Buffer extends _back_ from where we are now */
      b->posn -= b->bufsiz;
     }
    if (avail > (SSize_t) count)
-    avail = count;
+    {
+     /* If we have space for more than count, just move count */
+     avail = count;
+    }
    if (avail > 0)
     {
      b->ptr -= avail;
      buf    -= avail;
+     /* In simple stdio-like ungetc() case chars will be already there */
      if (buf != b->ptr)
       {
        Copy(buf,b->ptr,avail,STDCHAR);
@@ -2840,9 +2908,13 @@ Off_t
 PerlIOBuf_tell(PerlIO *f)
 {
  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ /* b->posn is file position where b->buf was read, or will be written */
  Off_t posn = b->posn;
  if (b->buf)
-  posn += (b->ptr - b->buf);
+  {
+   /* If buffer is valid adjust position by amount in buffer */
+   posn += (b->ptr - b->buf);
+  }
  return posn;
 }