#include <sys/mman.h>
#endif
+/*
+ * Why is this here - not in perlio.h? RMB
+ */
+void PerlIO_debug(const char *fmt, ...)
+ __attribute__format__(__printf__, 1, 2);
void
PerlIO_debug(const char *fmt, ...)
return def;
}
-PerlIO *
-PerlIO_syslayer(pTHX_ PerlIO *f)
-{
- if (PerlIOValid(f)) {
- PerlIOl *l;
- while (*PerlIONext(f)) {
- f = PerlIONext(f);
- }
- l = *f;
-#if 0
- Perl_warn(aTHX_ "syslayer %s",l->tab->name);
-#endif
- return f;
- }
- else {
- SETERRNO(EBADF, SS_IVCHAN);
- return NULL;
- }
-}
-
-
IV
PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
PerlIO_funcs *osLayer = &PerlIO_unix;
PL_def_layerlist = PerlIO_list_alloc(aTHX);
PerlIO_define_layer(aTHX_ & PerlIO_unix);
-#if defined(WIN32) && !defined(UNDER_CE)
+#if defined(WIN32)
PerlIO_define_layer(aTHX_ & PerlIO_win32);
#if 0
osLayer = &PerlIO_win32;
f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
l->flags, PerlIO_modestr(f, temp));
#endif
- if (l->next) {
- l->flags |= l->next->flags &
- (PERLIO_F_TTY | PERLIO_F_NOTREG | PERLIO_F_SOCKET);
- }
return 0;
}
{
STDCHAR *buf = (STDCHAR *) vbuf;
if (f) {
- if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
+ if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
+ PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ SETERRNO(EBADF, SS_IVCHAN);
return 0;
+ }
while (count > 0) {
SSize_t avail = PerlIO_get_cnt(f);
SSize_t take = 0;
PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
{
PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
-
-#if 1 || defined(WIN32) || defined(HAS_SOCKET) && \
- (defined(PERL_SOCK_SYSREAD_IS_RECV) || \
- defined(PERL_SOCK_SYSWRITE_IS_SEND))
+#if defined(WIN32)
Stat_t st;
if (PerlLIO_fstat(fd, &st) == 0) {
-#if defined(WIN32)
- /* WIN32 needs to know about non-regular files
- as only regular files can be lseek()ed
- */
if (!S_ISREG(st.st_mode)) {
PerlIO_debug("%d is not regular file\n",fd);
PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
else {
PerlIO_debug("%d _is_ a regular file\n",fd);
}
-#endif
- /* If read/write are to be mapped to recv/send we need
- to know this is a socket.
- Lifted from code in doio.c that handles socket detection on dup
- */
-#ifndef PERL_MICRO
- if (S_ISSOCK(st.st_mode))
- PerlIOBase(f)->flags |= PERLIO_F_SOCKET;
- else if (
-#ifdef S_IFMT
- !(st.st_mode & S_IFMT)
-#else
- !st.st_mode
-#endif
- ) {
- char tmpbuf[256];
- Sock_size_t buflen = sizeof tmpbuf;
- if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0
- || errno != ENOTSOCK)
- PerlIOBase(f)->flags |= PERLIO_F_SOCKET; /* some OS's return 0 on fstat()ed socket */
- /* but some return 0 for streams too, sigh */
- }
-#endif /* !PERL_MICRO */
}
-#endif /* HAS_SOCKET ... */
-
+#endif
s->fd = fd;
s->oflags = imode;
PerlIOUnix_refcnt_inc(fd);
return 0;
}
while (1) {
- SSize_t len;
-#ifdef PERL_SOCK_SYSREAD_IS_RECV
- if (PerlIOBase(f)->flags & PERLIO_F_SOCKET) {
- len = PerlSock_recv(fd, vbuf, count, 0);
- }
- else
-#endif
- {
- len = PerlLIO_read(fd, vbuf, count);
- }
+ SSize_t len = PerlLIO_read(fd, vbuf, count);
if (len >= 0 || errno != EINTR) {
if (len < 0) {
if (errno != EAGAIN) {
}
else
got = PerlSIO_fread(vbuf, 1, count, s);
+ if (got == 0 && PerlSIO_ferror(s))
+ got = -1;
if (got >= 0 || errno != EINTR)
break;
PERL_ASYNC_CHECK();
stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
if (stdio) {
PerlIOl *l = *f;
+ PerlIO *f2;
/* De-link any lower layers so new :stdio sticks */
*f = NULL;
- if ((f = PerlIO_push(aTHX_ f, &PerlIO_stdio, buf, Nullsv))) {
- PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
+ if ((f2 = PerlIO_push(aTHX_ f, &PerlIO_stdio, buf, Nullsv))) {
+ PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
s->stdio = stdio;
/* Link previous lower layers under new one */
*PerlIONext(f) = l;
{
if (PerlIOValid(f)) {
PerlIO *next = PerlIONext(f);
- PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
- next = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
- next, narg, args);
+ PerlIO_funcs *tab =
+ PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
+ if (tab && tab->Open)
+ next =
+ (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
+ next, narg, args);
if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
return NULL;
}
* mode++;
*/
}
- f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
- f, narg, args);
+ if (tab && tab->Open)
+ f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
+ f, narg, args);
+ else
+ SETERRNO(EINVAL, LIB_INVARG);
if (f) {
if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
/*
dTHX;
PerlIO *f = NULL;
int fd = -1;
- SV *sv = Nullsv;
- GV *gv = gv_fetchpv("File::Temp::tempfile", FALSE, SVt_PVCV);
-
- if (!gv) {
- ENTER;
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvn("File::Temp", 10), Nullsv, Nullsv, Nullsv);
- gv = gv_fetchpv("File::Temp::tempfile", FALSE, SVt_PVCV);
- GvIMPORTED_CV_on(gv);
- LEAVE;
- }
-
- if (gv && GvCV(gv)) {
- dSP;
- ENTER;
- SAVETMPS;
- PUSHMARK(SP);
- PUTBACK;
- if (call_sv((SV*)GvCV(gv), G_SCALAR)) {
- GV *gv = (GV*)SvRV(newSVsv(*PL_stack_sp--));
- IO *io = gv ? GvIO(gv) : 0;
- fd = io ? PerlIO_fileno(IoIFP(io)) : -1;
- }
- SPAGAIN;
- PUTBACK;
- FREETMPS;
- LEAVE;
- }
-
+#ifdef WIN32
+ fd = win32_tmpfd();
+ if (fd >= 0)
+ f = PerlIO_fdopen(fd, "w+b");
+#else /* WIN32 */
+# ifdef HAS_MKSTEMP
+ SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
+
+ /*
+ * I have no idea how portable mkstemp() is ... NI-S
+ */
+ fd = mkstemp(SvPVX(sv));
if (fd >= 0) {
f = PerlIO_fdopen(fd, "w+");
- if (sv) {
- if (f)
- PerlIOBase(f)->flags |= PERLIO_F_TEMP;
- PerlLIO_unlink(SvPVX(sv));
- SvREFCNT_dec(sv);
- }
+ if (f)
+ PerlIOBase(f)->flags |= PERLIO_F_TEMP;
+ PerlLIO_unlink(SvPVX(sv));
+ SvREFCNT_dec(sv);
}
+# else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
+ FILE *stdio = PerlSIO_tmpfile();
+ if (stdio) {
+ if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)),
+ &PerlIO_stdio, "w+", Nullsv))) {
+ PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
+
+ if (s)
+ s->stdio = stdio;
+ }
+ }
+# endif /* else HAS_MKSTEMP */
+#endif /* else WIN32 */
return f;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff