view release on metacpan or  search on metacpan

IO.xs  view on Meta::CPAN

		RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
	    }
	    else {
		RETVAL = -1;
		errno = EINVAL;
	    }
#else
	    RETVAL = PerlIO_setpos(handle, pos);
#endif
#else
	    char *p;
	    STRLEN len;
	    if ((p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
		RETVAL = fsetpos(handle, (Fpos_t*)p);
	    }
	    else {
		RETVAL = -1;
		errno = EINVAL;
	    }
#endif
	}
	else {
	    RETVAL = -1;
	    errno = EINVAL;
	}
    OUTPUT:
	RETVAL

MODULE = IO	PACKAGE = IO::File	PREFIX = f

void
new_tmpfile(packname = "IO::File")
    const char * packname
    PREINIT:
	OutputStream fp;
	GV *gv;
    CODE:
#ifdef PerlIO
	fp = PerlIO_tmpfile();
#else
	fp = tmpfile();
#endif
	gv = (GV*)SvREFCNT_inc(newGVgen(packname));
	if (gv)
	    (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_inc((SV*)gv));
	    sv_bless(ST(0), gv_stashpv(packname, TRUE));
	    SvREFCNT_dec(gv);   /* undo increment in newRV() */
	}
	else {
	    ST(0) = &PL_sv_undef;
	    SvREFCNT_dec(gv);
	}

MODULE = IO	PACKAGE = IO::Poll

void
_poll(timeout,...)
	int timeout;
PPCODE:
{
#ifdef HAS_POLL
    const int nfd = (items - 1) / 2;
    SV *tmpsv = sv_2mortal(NEWSV(999,nfd * sizeof(struct pollfd)));
    /* We should pass _some_ valid pointer even if nfd is zero, but it
     * doesn't matter what it is, since we're telling it to not check any fds.
     */
    struct pollfd *fds = nfd ? (struct pollfd *)SvPVX(tmpsv) : (struct pollfd *)tmpsv;
    int i,j,ret;
    for(i=1, j=0  ; j < nfd ; j++) {
	fds[j].fd = SvIV(ST(i));
	i++;
	fds[j].events = (short)SvIV(ST(i));
	i++;
	fds[j].revents = 0;
    }
    if((ret = poll(fds,nfd,timeout)) >= 0) {
	for(i=1, j=0 ; j < nfd ; j++) {
	    sv_setiv(ST(i), fds[j].fd); i++;
	    sv_setiv(ST(i), fds[j].revents); i++;
	}
    }
    XSRETURN_IV(ret);
#else
	not_here("IO::Poll::poll");
#endif
}

MODULE = IO	PACKAGE = IO::Handle	PREFIX = io_

void
io_blocking(handle,blk=-1)
	InputStream	handle
	int		blk
PROTOTYPE: $;$
CODE:
{
    const int ret = io_blocking(aTHX_ handle, items == 1 ? -1 : blk ? 1 : 0);
    if(ret >= 0)
	XSRETURN_IV(ret);
    else
	XSRETURN_UNDEF;
}

MODULE = IO	PACKAGE = IO::Handle	PREFIX = f

int
ungetc(handle, c)
	InputStream	handle
	SV *	        c
    CODE:
	if (handle) {
#ifdef PerlIO
            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)))

IO.xs  view on Meta::CPAN

	handle = IoOFP(sv_2io(arg));
	if (!handle)
	    handle = IoIFP(sv_2io(arg));
	if (handle) {
	    int fd = PerlIO_fileno(handle);
	    if (fd >= 0) {
#  ifdef _WIN32
                RETVAL = _commit(fd);
#  else
		RETVAL = fsync(fd);
#  endif
	    } else {
		RETVAL = -1;
		errno = EBADF;
	    }
	} else {
	    RETVAL = -1;
	    errno = EINVAL;
	}
#else
	RETVAL = (SysRet) not_here("IO::Handle::sync");
#endif
    OUTPUT:
	RETVAL

# To make these two work correctly with the open pragma, the readline op
# needs to pick up the lexical hints at the method's callsite. This doesn't
# work in pure Perl, because the hints are read from the most recent nextstate,
# and the nextstate of the Perl subroutines show *here* hold the lexical state
# for the IO package.
#
# There's no clean way to implement this - this approach, while complex, seems
# to be the most robust, and avoids manipulating external state (ie op checkers)
#
# sub getline {
#     @_ == 1 or croak 'usage: $io->getline()';
#     my $this = shift;
#     return scalar <$this>;
# }
#
# sub getlines {
#     @_ == 1 or croak 'usage: $io->getlines()';
#     wantarray or
# 	croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
#     my $this = shift;
#     return <$this>;
# }

# If this is deprecated, should it warn, and should it be removed at some point?
# *gets = \&getline;  # deprecated

void
getlines(...)
ALIAS:
    IO::Handle::getline       =  1
    IO::Handle::gets          =  2
INIT:
    UNOP myop;
    SV *io;
    OP *was = PL_op;
PPCODE:
    if (items != 1)
        Perl_croak(aTHX_ "usage: $io->%s()", ix ? "getline" : "getlines");
    if (!ix && GIMME_V != G_LIST)
        Perl_croak(aTHX_ "Can't call $io->getlines in a scalar context, use $io->getline");
    Zero(&myop, 1, UNOP);
#if PERL_VERSION_GE(5,39,6)
    myop.op_flags = (ix ? (OPf_WANT_SCALAR | OPf_STACKED) : OPf_WANT_LIST);
#else
    myop.op_flags = (ix ? OPf_WANT_SCALAR : OPf_WANT_LIST ) | OPf_STACKED;
#endif
    myop.op_ppaddr = PL_ppaddr[OP_READLINE];
    myop.op_type = OP_READLINE;
    myop.op_next = NULL; /* return from the runops loop below after 1 op */
    /* Sigh, because pp_readline calls pp_rv2gv, and *it* has this wonderful
       state check for PL_op->op_type == OP_READLINE */
    PL_op = (OP *) &myop;
    io = ST(0);
    /* For scalar functions (getline/gets), provide a target on the stack,
     * as we don't have a pad entry. */
#if PERL_VERSION_GE(5,39,6)
    if (ix)
#endif
        PUSHs(sv_newmortal());
    XPUSHs(io);
    PUTBACK;
    /* call a new runops loop for just the one op rather than just calling
     * pp_readline directly, as the former will handle the call coming
     * from a ref-counted stack */
    /* And effectively we get away with tail calling pp_readline, as it stacks
       exactly the return value(s) we need to return. */
    CALLRUNOPS(aTHX);
    PL_op = was;
    /* And we don't want to reach the line
       PL_stack_sp = sp;
       that xsubpp adds after our body becase PL_stack_sp is correct, not sp */
    return;

MODULE = IO	PACKAGE = IO::Socket

SysRet
sockatmark (sock)
   InputStream sock
   PROTOTYPE: $
   PREINIT:
     int fd;
   CODE:
     fd = PerlIO_fileno(sock);
     if (fd < 0) {
       errno = EBADF;
       RETVAL = -1;
     }
#ifdef HAS_SOCKATMARK
     else {
       RETVAL = sockatmark(fd);
     }
#else
     else {
       int flag = 0;
#   ifdef SIOCATMARK
#     if defined(NETWARE) || defined(WIN32)