# define NORETURN_FUNCTION_END /* NOT REACHED */ return 0
#endif
+#ifndef dVAR
+# define dVAR dNOOP
+#endif
+
static int not_here(const char *s) __attribute__noreturn__;
static int
not_here(const char *s)
NORETURN_FUNCTION_END;
}
+#ifndef UVCHR_IS_INVARIANT /* For use with Perls without this macro */
+# if ('A' == 65)
+# define UVCHR_IS_INVARIANT(cp) ((cp) < 128)
+# elif (defined(NATIVE_IS_INVARIANT)) /* EBCDIC on old Perl */
+# define UVCHR_IS_INVARIANT(cp) ((cp) < 256 && NATIVE_IS_INVARIANT(cp))
+# elif defined(isASCII) /* EBCDIC on very old Perl */
+ /* In EBCDIC, the invariants are the code points corresponding to ASCII,
+ * plus all the controls. All but one EBCDIC control is below SPACE; it
+ * varies depending on the code page, determined by the ord of '^' */
+# define UVCHR_IS_INVARIANT(cp) (isASCII(cp) \
+ || (cp) < ' ' \
+ || (('^' == 106) /* POSIX-BC */ \
+ ? (cp) == 95 \
+ : (cp) == 0xFF)) /* 1047 or 037 */
+# else /* EBCDIC on very very old Perl */
+ /* This assumes isascii() is available, but that could be fixed by
+ * having the macro test for each printable ASCII char */
+# define UVCHR_IS_INVARIANT(cp) (isascii(cp) \
+ || (cp) < ' ' \
+ || (('^' == 106) /* POSIX-BC */ \
+ ? (cp) == 95 \
+ : (cp) == 0xFF)) /* 1047 or 037 */
+# endif
+#endif
+
#ifndef PerlIO
#define PerlIO_fileno(f) fileno(f)
static int
io_blocking(pTHX_ InputStream f, int block)
{
+ int fd = -1;
#if defined(HAS_FCNTL)
int RETVAL;
- if(!f) {
+ if (!f) {
errno = EBADF;
return -1;
}
- RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0);
+ fd = PerlIO_fileno(f);
+ if (fd < 0) {
+ errno = EBADF;
+ return -1;
+ }
+ RETVAL = fcntl(fd, F_GETFL, 0);
if (RETVAL >= 0) {
int mode = RETVAL;
int newmode = mode;
}
#endif
if (newmode != mode) {
- const int ret = fcntl(PerlIO_fileno(f),F_SETFL,newmode);
+ const int ret = fcntl(fd, F_SETFL, newmode);
if (ret < 0)
RETVAL = ret;
}
return RETVAL;
#else
# ifdef WIN32
- char flags = (char)block;
- return ioctl(PerlIO_fileno(f), FIONBIO, &flags);
+ if (block >= 0) {
+ unsigned long flags = !block;
+ /* ioctl claims to take char* but really needs a u_long sized buffer */
+ const int ret = ioctl(fd, FIONBIO, (char*)&flags);
+ if (ret != 0)
+ return -1;
+ /* Win32 has no way to get the current blocking status of a socket.
+ * However, we don't want to just return undef, because there's no way
+ * to tell that the ioctl succeeded.
+ */
+ return flags;
+ }
+ /* TODO: Perhaps set $! to ENOTSUP? */
+ return -1;
# else
return -1;
# endif
#endif
}
+static OP *
+io_pp_nextstate(pTHX)
+{
+ dVAR;
+ COP *old_curcop = PL_curcop;
+ OP *next = PL_ppaddr[PL_op->op_type](aTHX);
+ PL_curcop = old_curcop;
+ return next;
+}
+
+static OP *
+io_ck_lineseq(pTHX_ OP *o)
+{
+ OP *kid = cBINOPo->op_first;
+ for (; kid; kid = kid->op_sibling)
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
+ kid->op_ppaddr = io_pp_nextstate;
+ return o;
+}
+
+
MODULE = IO PACKAGE = IO::Seekable PREFIX = f
void
#endif
gv = (GV*)SvREFCNT_inc(newGVgen(packname));
if (gv)
- hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
+ (void) hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
if (gv && do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
ST(0) = sv_2mortal(newRV((SV*)gv));
sv_bless(ST(0), gv_stashpv(packname, TRUE));
int
ungetc(handle, c)
InputStream handle
- int c
+ SV * c
CODE:
- if (handle)
+ if (handle) {
#ifdef PerlIO
- RETVAL = PerlIO_ungetc(handle, c);
+ UV v;
+
+ if ((SvIOK_notUV(c) && SvIV(c) < 0) || (SvNOK(c) && SvNV(c) < 0.0))
+ croak("Negative character number in ungetc()");
+
+ v = SvUV(c);
+ if (UVCHR_IS_INVARIANT(v) || (v <= 0xFF && !PerlIO_isutf8(handle)))
+ RETVAL = PerlIO_ungetc(handle, (int)v);
+ else {
+ U8 buf[UTF8_MAXBYTES + 1], *end;
+ Size_t len;
+
+ if (!PerlIO_isutf8(handle))
+ croak("Wide character number in ungetc()");
+
+ /* This doesn't warn for non-chars, surrogate, and
+ * above-Unicodes */
+ end = uvchr_to_utf8_flags(buf, v, 0);
+ len = end - buf;
+ if ((Size_t)PerlIO_unread(handle, &buf, len) == len)
+ XSRETURN_UV(v);
+ else
+ RETVAL = EOF;
+ }
#else
- RETVAL = ungetc(c, handle);
+ RETVAL = ungetc((int)SvIV(c), handle);
#endif
+ }
else {
RETVAL = -1;
errno = EINVAL;
SysRet
-fsync(handle)
- OutputStream handle
+fsync(arg)
+ SV * arg
+ PREINIT:
+ OutputStream handle = NULL;
CODE:
#ifdef HAS_FSYNC
- if(handle)
- RETVAL = fsync(PerlIO_fileno(handle));
- else {
+ handle = IoOFP(sv_2io(arg));
+ if (!handle)
+ handle = IoIFP(sv_2io(arg));
+ if (handle) {
+ int fd = PerlIO_fileno(handle);
+ if (fd >= 0) {
+ RETVAL = fsync(fd);
+ } else {
+ RETVAL = -1;
+ errno = EBADF;
+ }
+ } else {
RETVAL = -1;
errno = EINVAL;
}
OUTPUT:
RETVAL
+SV *
+_create_getline_subs(const char *code)
+ CODE:
+ OP *(*io_old_ck_lineseq)(pTHX_ OP *) = PL_check[OP_LINESEQ];
+ PL_check[OP_LINESEQ] = io_ck_lineseq;
+ RETVAL = SvREFCNT_inc(eval_pv(code,FALSE));
+ PL_check[OP_LINESEQ] = io_old_ck_lineseq;
+ OUTPUT:
+ RETVAL
+
MODULE = IO PACKAGE = IO::Socket
InputStream sock
PROTOTYPE: $
PREINIT:
- int fd;
+ int fd = PerlIO_fileno(sock);
CODE:
{
- fd = PerlIO_fileno(sock);
#ifdef HAS_SOCKATMARK
- RETVAL = sockatmark(fd);
+ if (fd < 0) {
+ errno = EBADF;
+ RETVAL = -1;
+ } else {
+ RETVAL = sockatmark(fd);
+ }
#else
{
+ if (fd < 0) {
+ errno = EBADF;
+ RETVAL = -1;
+ }
+ else {
int flag = 0;
# ifdef SIOCATMARK
# if defined(NETWARE) || defined(WIN32)
- if (ioctl(fd, SIOCATMARK, (void*)&flag) != 0)
+ if (ioctl(fd, SIOCATMARK, (char*)&flag) != 0)
# else
if (ioctl(fd, SIOCATMARK, &flag) != 0)
# endif
# endif
RETVAL = flag;
}
+ }
#endif
}
OUTPUT:
https://perl5.git.perl.org / perl5.git / blobdiff