#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
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
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
#include <sys/mman.h>
#endif
-#include "XSUB.h"
void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
void
PerlIO_list_push(PerlIO_list_t *list,PerlIO_funcs *funcs,SV *arg)
{
+ dTHX;
PerlIO_pair_t *p;
if (list->cur >= list->len)
{
}
p = &(list->array[list->cur++]);
p->funcs = funcs;
- if ((p->arg = arg))
+ if ((p->arg = arg)) {
SvREFCNT_inc(arg);
+ }
}
{
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);
}
}
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;
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)
{
{
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)
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);
#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);
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)
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)
{
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;
}
PerlIOUnix_oflags(const char *mode)
{
int oflags = -1;
+ if (*mode == 'I' || *mode == '#')
+ mode++;
switch(*mode)
{
case 'r':
if (*mode == 'I')
{
init = 1;
- mode++;
+ /* mode++; */
}
f = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,NULL,narg,args);
if (f)
{
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);
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;
}
+