*
*/
+/* If we have ActivePerl-like PERL_IMPLICIT_SYS then we need
+ a dTHX to get at the dispatch tables, even when we do not
+ need it for other reasons.
+ Invent a dSYS macro to abstract this out
+*/
+#ifdef PERL_IMPLICIT_SYS
+#define dSYS dTHX
+#else
+#define dSYS dNOOP
+#endif
+
#define VOIDUSED 1
#ifdef PERL_MICRO
# include "uconfig.h"
int
PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
{
+#ifdef USE_SFIO
+ return 1;
+#else
return perlsio_binmode(fp,iotype,mode);
+#endif
}
/* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */
{
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;
}
sfset(sfstdout,SF_SHARE,0);
}
+PerlIO *
+PerlIO_importFILE(FILE *stdio, int fl)
+{
+ int fd = fileno(stdio);
+ PerlIO *r = PerlIO_fdopen(fd,"r+");
+ return r;
+}
+
+FILE *
+PerlIO_findFILE(PerlIO *pio)
+{
+ int fd = PerlIO_fileno(pio);
+ FILE *f = fdopen(fd,"r+");
+ PerlIO_flush(pio);
+ if (!f && errno == EINVAL)
+ f = fdopen(fd,"w");
+ if (!f && errno == EINVAL)
+ f = fdopen(fd,"r");
+ return f;
+}
+
+
#else /* USE_SFIO */
/*======================================================================================*/
/* Implement all the PerlIO interface ourselves.
void
PerlIO_debug(const char *fmt,...)
{
- dTHX;
static int dbg = 0;
va_list ap;
+ dSYS;
va_start(ap,fmt);
if (!dbg)
{
AV *PerlIO_layer_av;
void
+PerlIO_cleanup_layers(pTHXo_ void *data)
+{
+ PerlIO_layer_hv = Nullhv;
+ PerlIO_layer_av = Nullav;
+}
+
+void
PerlIO_cleanup()
{
dTHX;
return Nullsv;
}
+#ifdef USE_ATTRIBUTES_FOR_PERLIO
static int
perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
IO *io = GvIOn((GV *)SvRV(sv));
PerlIO *ifp = IoIFP(io);
PerlIO *ofp = IoOFP(io);
- AV *av = (AV *) mg->mg_obj;
Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
}
return 0;
IO *io = GvIOn((GV *)SvRV(sv));
PerlIO *ifp = IoIFP(io);
PerlIO *ofp = IoOFP(io);
- AV *av = (AV *) mg->mg_obj;
Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
}
return 0;
perlio_mg_get,
perlio_mg_set,
NULL, /* len */
- NULL,
+ perlio_mg_clear,
perlio_mg_free
};
MAGIC *mg;
int count = 0;
int i;
- sv_magic(sv, (SV *)av, '~', NULL, 0);
+ sv_magic(sv, (SV *)av, PERL_MAGIC_ext, NULL, 0);
SvRMAGICAL_off(sv);
- mg = mg_find(sv,'~');
+ mg = mg_find(sv, PERL_MAGIC_ext);
mg->mg_virtual = &perlio_vtab;
mg_magical(sv);
Perl_warn(aTHX_ "attrib %"SVf,sv);
XSRETURN(count);
}
+#endif /* USE_ATTIBUTES_FOR_PERLIO */
+
SV *
PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
{
return INT2PTR(PerlIO_funcs *, SvIV(layer));
}
if (!def)
- Perl_croak(aTHX_ "panic:PerlIO layer array corrupt");
+ Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
return def;
}
{
const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
-#if 0
+
+#ifdef USE_ATTRIBUTES_FOR_PERLIO
newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
#endif
+
PerlIO_define_layer(aTHX_ &PerlIO_raw);
PerlIO_define_layer(aTHX_ &PerlIO_unix);
PerlIO_define_layer(aTHX_ &PerlIO_perlio);
/* Pop back to bottom layer */
if (f && *f)
{
- int code = 0;
PerlIO_flush(f);
while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
{
{
PerlIO *top = f;
PerlIOl *l;
- while (l = *top)
+ while ((l = *top))
{
if (PerlIOBase(top)->tab == &PerlIO_crlf)
{
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 *
{
AV *layera;
IV n;
- PerlIO_funcs *tab;
+ PerlIO_funcs *tab = NULL;
if (f && *f)
{
/* This is "reopen" - it is not tested as perl does not use it yet */
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
{
+ /* 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))
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
PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
{
PerlIOl *l = PerlIOBase(f);
+#if 0
const char *omode = mode;
char temp[8];
+#endif
PerlIO_funcs *tab = PerlIOBase(f)->tab;
l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
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;
IV
PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
{
- dTHX;
+ dSYS;
Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
return (new == (Off_t) -1) ? -1 : 0;
Off_t
PerlIOUnix_tell(PerlIO *f)
{
- dTHX;
- Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
+ dSYS;
return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
}
IV
PerlIOStdio_fileno(PerlIO *f)
{
- dTHX;
+ dSYS;
return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
}
IV
PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
{
- dTHX;
if (*PerlIONext(f))
{
+ dSYS;
PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
char tmode[8];
FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
SSize_t
PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
{
- dTHX;
+ dSYS;
FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
SSize_t got = 0;
if (count == 1)
SSize_t
PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
{
- dTHX;
+ dSYS;
FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
SSize_t unread = 0;
SSize_t
PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
{
- dTHX;
+ dSYS;
return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
}
IV
PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
{
- dTHX;
+ dSYS;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_fseek(stdio,offset,whence);
}
Off_t
PerlIOStdio_tell(PerlIO *f)
{
- dTHX;
+ dSYS;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_ftell(stdio);
}
IV
PerlIOStdio_close(PerlIO *f)
{
- dTHX;
-#ifdef HAS_SOCKS5_INIT
+ dSYS;
+#ifdef SOCKS5_VERSION_NAME
int optval;
Sock_size_t optlen = sizeof(int);
#endif
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return(
-#ifdef HAS_SOCKS5_INIT
+#ifdef SOCKS5_VERSION_NAME
(getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
PerlSIO_fclose(stdio) :
close(PerlIO_fileno(f))
IV
PerlIOStdio_flush(PerlIO *f)
{
- dTHX;
+ dSYS;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
{
IV
PerlIOStdio_fill(PerlIO *f)
{
- dTHX;
+ dSYS;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
int c;
/* fflush()ing read-only streams can cause trouble on some stdio-s */
IV
PerlIOStdio_eof(PerlIO *f)
{
- dTHX;
+ dSYS;
return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
}
IV
PerlIOStdio_error(PerlIO *f)
{
- dTHX;
+ dSYS;
return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
}
void
PerlIOStdio_clearerr(PerlIO *f)
{
- dTHX;
+ dSYS;
PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
}
void
PerlIOStdio_setlinebuf(PerlIO *f)
{
- dTHX;
+ dSYS;
#ifdef HAS_SETLINEBUF
PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
#else
STDCHAR *
PerlIOStdio_get_base(PerlIO *f)
{
- dTHX;
+ dSYS;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_get_base(stdio);
}
Size_t
PerlIOStdio_get_bufsiz(PerlIO *f)
{
- dTHX;
+ dSYS;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_get_bufsiz(stdio);
}
STDCHAR *
PerlIOStdio_get_ptr(PerlIO *f)
{
- dTHX;
+ dSYS;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_get_ptr(stdio);
}
SSize_t
PerlIOStdio_get_cnt(PerlIO *f)
{
- dTHX;
+ dSYS;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
return PerlSIO_get_cnt(stdio);
}
void
PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
{
- dTHX;
FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ dSYS;
if (ptr != NULL)
{
#ifdef STDIO_PTR_LVALUE
IV
PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
{
+ dSYS;
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|PERLIO_F_TTY;
f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
if (f)
{
- PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf);
+ PerlIO_push(aTHX_ f,self,mode,PerlIOArg);
fd = PerlIO_fileno(f);
#if O_BINARY != O_TEXT
/* do something about failing setmode()? --jhi */
IV
PerlIOBuf_close(PerlIO *f)
{
- dTHX;
IV code = PerlIOBase_close(f);
PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
if (b->buf && b->buf != (STDCHAR *) &b->oneword)
PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
if (!b->buf)
{
- dTHX;
if (!b->bufsiz)
b->bufsiz = 4096;
b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
else
{
int code;
- dTHX;
b->ptr++; /* say we have read it as far as flush() is concerned */
b->buf++; /* Leave space an front of buffer */
b->bufsiz--; /* Buffer is thus smaller */
{
dTHX;
PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
- PerlIOBuf *b = &m->base;
IV flags = PerlIOBase(f)->flags;
IV code = 0;
if (m->len)
void
PerlIO_init(void)
{
+ dTHX;
+#ifndef WIN32
+ call_atexit(PerlIO_cleanup_layers, NULL);
+#endif
if (!_perlio)
{
#ifndef WIN32
PerlIO_getname(PerlIO *f, char *buf)
{
dTHX;
+ char *name = NULL;
+#ifdef VMS
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ if (stdio) name = fgetname(stdio, buf);
+#else
Perl_croak(aTHX_ "Don't know how to get file name");
- return NULL;
+#endif
+ return name;
}
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
#endif
+
+
+
projects / p5sagit/p5-mst-13.2.git / blobdiff