return -1;
}
+void
+PerlIO_destruct(pTHX)
+{
+}
+
int
PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
{
{
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)
{
}
else
{
- return PerlIO_fdopen(fd,mode);
+ return PerlIO_fdopen(fd,(char *)mode);
}
return NULL;
}
}
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;
/*--------------------------------------------------------------------------------------*/
/* 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);
if (SvROK(sv))
return *svp;
}
- return NULL;
+ return Nullsv;
}
{
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));
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;
}
}
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));
}
}
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);
}
{
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
#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)
{
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
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 *
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)
{
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)
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
{
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))
}
}
+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
{
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;
}
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
l->flags |= PERLIO_F_FASTGETS;
if (mode)
{
+ if (*mode == '#' || *mode == 'I')
+ mode++;
switch (*mode++)
{
case 'r':
l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
break;
default:
- errno = EINVAL;
+ SETERRNO(EINVAL,LIB$_INVARG);
return -1;
}
while (*mode)
l->flags |= PERLIO_F_CRLF;
break;
default:
- errno = EINVAL;
- return -1;
+ SETERRNO(EINVAL,LIB$_INVARG);
+ return -1;
}
}
}
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);
oflags |= O_BINARY;
if (*mode || oflags == -1)
{
- errno = EINVAL;
+ SETERRNO(EINVAL,LIB$_INVARG);
oflags = -1;
}
return oflags;
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
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)
*/
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 */
if (f && len == sizeof(Off_t))
return PerlIO_seek(f,*posn,SEEK_SET);
}
- errno = EINVAL;
+ SETERRNO(EINVAL,SS$_IVCHAN);
return -1;
}
#else
#endif
}
}
- errno = EINVAL;
+ SETERRNO(EINVAL,SS$_IVCHAN);
return -1;
}
#endif
projects / p5sagit/p5-mst-13.2.git / blobdiff