Ejemplo n.º 1
0
PerlIO *
PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags)
{
 PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32);
 HANDLE proc = GetCurrentProcess();
 HANDLE new_h;
 if (DuplicateHandle(proc, os->h, proc, &new_h, 0, FALSE,  DUPLICATE_SAME_ACCESS))
  {
   char mode[8];
   int fd = win32_open_osfhandle((intptr_t) new_h, PerlIOUnix_oflags(PerlIO_modestr(o,mode)));
   if (fd >= 0)
    {
     f = PerlIOBase_dup(aTHX_ f, o, params, flags);
     if (f)
      {
       PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32);
       fs->h  = new_h;
       fs->fd = fd;
       fs->refcnt = 1;
       fdtable[fd] = fs;
       if (fd > max_open_fd)
        max_open_fd = fd;
      }
     else
      {
       win32_close(fd);
      }
    }
   else
    {
     CloseHandle(new_h);
    }
  }
 return f;
}
Ejemplo n.º 2
0
IV
PerlIOMmap_map(pTHX_ PerlIO *f)
{
    dVAR;
    PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
    const IV flags = PerlIOBase(f)->flags;
    IV code = 0;
    if (m->len)
	abort();
    if (flags & PERLIO_F_CANREAD) {
	PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
	const int fd = PerlIO_fileno(f);
	Stat_t st;
	code = Fstat(fd, &st);
	if (code == 0 && S_ISREG(st.st_mode)) {
	    SSize_t len = st.st_size - b->posn;
	    if (len > 0) {
		Off_t posn;
		if (PL_mmap_page_size <= 0)
		  Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
			     PL_mmap_page_size);
		if (b->posn < 0) {
		    /*
		     * This is a hack - should never happen - open should
		     * have set it !
		     */
		    b->posn = PerlIO_tell(PerlIONext(f));
		}
		posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
		len = st.st_size - posn;
		m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
		if (m->mptr && m->mptr != (Mmap_t) - 1) {
#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
		    madvise(m->mptr, len, MADV_SEQUENTIAL);
#endif
#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
		    madvise(m->mptr, len, MADV_WILLNEED);
#endif
		    PerlIOBase(f)->flags =
			(flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
		    b->end = ((STDCHAR *) m->mptr) + len;
		    b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
		    b->ptr = b->buf;
		    m->len = len;
		}
		else {
		    b->buf = NULL;
		}
	    }
	    else {
		PerlIOBase(f)->flags =
		    flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
		b->buf = NULL;
		b->ptr = b->end = b->ptr;
		code = -1;
	    }
	}
    }
    return code;
}
Ejemplo n.º 3
0
PerlIO *
PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o,
		 CLONE_PARAMS * params, int flags)
{
    if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) {
	PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode);
	PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode);
	if (oe->enc) {
	    fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
	}
    }
    return f;
}
Ejemplo n.º 4
0
SSize_t
PerlIOWin32_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 DWORD len;
 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
  return 0;
 if (ReadFile(s->h,vbuf,count,&len,NULL))
  {
   return len;
  }
 else
  {
   if (GetLastError() != NO_ERROR)
    {
     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
     PerlIO_save_errno(f);
     return -1;
    }
   else
    {
     if (count != 0)
      PerlIOBase(f)->flags |= PERLIO_F_EOF;
     return 0;
    }
  }
}
Ejemplo n.º 5
0
SSize_t
PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    if (e->flags & NEEDS_LINES) {
	SSize_t done = 0;
	const char *ptr = (const char *) vbuf;
	const char *end = ptr+count;
	while (ptr < end) {
	    const char *nl = ptr;
	    while (nl < end && *nl++ != '\n') /* empty body */;
	    done = PerlIOBuf_write(aTHX_ f, ptr, nl-ptr);
	    if (done != nl-ptr) {
		if (done > 0) {
		    ptr += done;
		}
		break;
	    }
	    ptr += done;
	    if (ptr[-1] == '\n') {
		if (PerlIOEncode_flush(aTHX_ f) != 0) {
		    break;
		}
	    }
	}
	return (SSize_t) (ptr - (const char *) vbuf);
    }
    else {
	return PerlIOBuf_write(aTHX_ f, vbuf, count);
    }
}
Ejemplo n.º 6
0
IV
PerlIOMmap_flush(pTHX_ PerlIO *f)
{
    PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
    PerlIOBuf * const b = &m->base;
    IV code = PerlIOBuf_flush(aTHX_ f);
    /*
     * Now we are "synced" at PerlIOBuf level
     */
    if (b->buf) {
	if (m->len) {
	    /*
	     * Unmap the buffer
	     */
	    if (PerlIOMmap_unmap(aTHX_ f) != 0)
		code = -1;
	}
	else {
	    /*
	     * We seem to have a PerlIOBuf buffer which was not mapped
	     * remember it in case we need one later
	     */
	    m->bbuf = b->buf;
	}
    }
    return code;
}
Ejemplo n.º 7
0
SSize_t
PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
    PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
    PerlIOBuf * const b = &m->base;

    if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
	/*
	 * No, or wrong sort of, buffer
	 */
	if (m->len) {
	    if (PerlIOMmap_unmap(aTHX_ f) != 0)
		return 0;
	}
	/*
	 * If unmap took the "buffer" see if we have one from before
	 */
	if (!b->buf && m->bbuf)
	    b->buf = m->bbuf;
	if (!b->buf) {
	    PerlIOBuf_get_base(aTHX_ f);
	    m->bbuf = b->buf;
	}
    }
    return PerlIOBuf_write(aTHX_ f, vbuf, count);
}
Ejemplo n.º 8
0
SSize_t
PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
    PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
    PerlIOBuf * const b = &m->base;
    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
	PerlIO_flush(f);
    if (b->ptr && (b->ptr - count) >= b->buf
	&& memEQ(b->ptr - count, vbuf, count)) {
	b->ptr -= count;
	PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
	return count;
    }
    if (m->len) {
	/*
	 * Loose the unwritable mapped buffer
	 */
	PerlIO_flush(f);
	/*
	 * If flush took the "buffer" see if we have one from before
	 */
	if (!b->buf && m->bbuf)
	    b->buf = m->bbuf;
	if (!b->buf) {
	    PerlIOBuf_get_base(aTHX_ f);
	    m->bbuf = b->buf;
	}
    }
    return PerlIOBuf_unread(aTHX_ f, vbuf, count);
}
Ejemplo n.º 9
0
STDCHAR *
PerlIOMmap_get_base(pTHX_ PerlIO *f)
{
    PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
    PerlIOBuf * const b = &m->base;
    if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
	/*
	 * Already have a readbuffer in progress
	 */
	return b->buf;
    }
    if (b->buf) {
	/*
	 * We have a write buffer or flushed PerlIOBuf read buffer
	 */
	m->bbuf = b->buf;       /* save it in case we need it again */
	b->buf = NULL;          /* Clear to trigger below */
    }
    if (!b->buf) {
	PerlIOMmap_map(aTHX_ f);        /* Try and map it */
	if (!b->buf) {
	    /*
	     * Map did not work - recover PerlIOBuf buffer if we have one
	     */
	    b->buf = m->bbuf;
	}
    }
    b->ptr = b->end = b->buf;
    if (b->buf)
	return b->buf;
    return PerlIOBuf_get_base(aTHX_ f);
}
Ejemplo n.º 10
0
IV
PerlIOMmap_unmap(pTHX_ PerlIO *f)
{
    PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
    IV code = 0;
    if (m->len) {
	PerlIOBuf * const b = &m->base;
	if (b->buf) {
	    /* The munmap address argument is tricky: depending on the
	     * standard it is either "void *" or "caddr_t" (which is
	     * usually "char *" (signed or unsigned).  If we cast it
	     * to "void *", those that have it caddr_t and an uptight
	     * C++ compiler, will freak out.  But casting it as char*
	     * should work.  Maybe.  (Using Mmap_t figured out by
	     * Configure doesn't always work, apparently.) */
	    code = munmap((char*)m->mptr, m->len);
	    b->buf = NULL;
	    m->len = 0;
	    m->mptr = NULL;
	    if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
		code = -1;
	}
	b->ptr = b->end = b->buf;
	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
    }
    return code;
}
Ejemplo n.º 11
0
IV
PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
{
    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
    STRLEN oldcur = SvCUR(s->var);
    STRLEN newlen;
    switch (whence) {
    case SEEK_SET:
	s->posn = offset;
	break;
    case SEEK_CUR:
	s->posn = offset + s->posn;
	break;
    case SEEK_END:
	s->posn = offset + SvCUR(s->var);
	break;
    }
    if (s->posn < 0) {
        if (ckWARN(WARN_LAYER))
	    Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
	SETERRNO(EINVAL, SS_IVCHAN);
	return -1;
    }
    newlen = (STRLEN) s->posn;
    if (newlen > oldcur) {
	(void) SvGROW(s->var, newlen);
	Zero(SvPVX(s->var) + oldcur, newlen - oldcur, char);
	/* No SvCUR_set(), though.  This is just a seek, not a write. */
    }
Ejemplo n.º 12
0
SV *
PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    SV *sv = &PL_sv_undef;
    if (e->enc) {
	dSP;
	/* Not 100% sure stack swap is right thing to do during dup ... */
	PUSHSTACKi(PERLSI_MAGIC);
	SPAGAIN;
	ENTER;
	SAVETMPS;
	PUSHMARK(sp);
	XPUSHs(e->enc);
	PUTBACK;
	if (call_method("name", G_SCALAR) == 1) {
	    SPAGAIN;
	    sv = newSVsv(POPs);
	    PUTBACK;
	}
	FREETMPS;
	LEAVE;
	POPSTACK;
    }
    return sv;
}
Ejemplo n.º 13
0
SSize_t
PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
{
    if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
	Off_t offset;
	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
	SV *sv = s->var;
	char *dst;
	if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
	    dst = SvGROW(sv, SvCUR(sv) + count);
	    offset = SvCUR(sv);
	    s->posn = offset + count;
	}
	else {
	    if ((s->posn + count) > SvCUR(sv))
		dst = SvGROW(sv, (STRLEN)s->posn + count);
	    else
		dst = SvPV_nolen(sv);
	    offset = s->posn;
	    s->posn += count;
	}
	Move(vbuf, dst + offset, count, char);
	if ((STRLEN) s->posn > SvCUR(sv))
	    SvCUR_set(sv, (STRLEN)s->posn);
	SvPOK_on(s->var);
	return count;
    }
Ejemplo n.º 14
0
IV
PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
		    PerlIO_funcs * tab)
{
    IV code;
    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
    /* If called (normally) via open() then arg is ref to scalar we are
     * using, otherwise arg (from binmode presumably) is either NULL
     * or the _name_ of the scalar
     */
    if (arg) {
	if (SvROK(arg)) {
	    s->var = SvREFCNT_inc(SvRV(arg));
	    if (!SvPOK(s->var) && SvTYPE(SvRV(arg)) > SVt_NULL)
		(void)SvPV_nolen(s->var);
	}
	else {
	    s->var =
		SvREFCNT_inc(perl_get_sv
			     (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
	}
    }
    else {
	s->var = newSVpvn("", 0);
    }
    SvUPGRADE(s->var, SVt_PV);
    code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
    if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
	SvCUR(s->var) = 0;
    if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
	s->posn = SvCUR(s->var);
    else
	s->posn = 0;
    return code;
}
SSize_t
PerlIONginxInput_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
    PerlIONginxInput *st = PerlIOSelf(f, PerlIONginxInput);
    ngx_http_request_t *r = st->r;

    if (r->request_body == NULL
            || r->request_body->temp_file
            || r->request_body->bufs == NULL)
    {
        return 0;
    }

    off_t len = r->request_body->bufs->buf->last - r->request_body->bufs->buf->pos - st->pos;

    if (len == 0) {
        return 0;
    }

    len = len > count ? count : len;

    Copy(r->request_body->bufs->buf->pos + st->pos, vbuf, len, STDCHAR);

    st->pos+= len;
    return len;
}
Ejemplo n.º 16
0
IV
PerlIOEncode_close(pTHX_ PerlIO * f)
{
    PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
    IV code;
    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
	/* Discard partial character */
	if (e->dataSV) {
	    SvCUR_set(e->dataSV,0);
	}
	/* Don't back decode and unread any pending data */
	e->base.ptr = e->base.end = e->base.buf;
    }
    code = PerlIOBase_close(aTHX_ f);
    if (e->bufsv) {
	/* This should only fire for write case */
	if (e->base.buf && e->base.ptr > e->base.buf) {
	    Perl_croak(aTHX_ "Close with partial character");
	}
	SvREFCNT_dec(e->bufsv);
	e->bufsv = Nullsv;
    }
    e->base.buf = NULL;
    e->base.ptr = NULL;
    e->base.end = NULL;
    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
    return code;
}
SV *PerlIONginxInput_newhandle(pTHX_ ngx_http_request_t *r)
{
    ngx_log_t *log = r->connection->log;

    GV *gv = (GV*)SvREFCNT_inc(newGVgen("Nginx::PSGI::Input"));
    if (!gv)
        return &PL_sv_undef;

    (void) hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);

    /* Body in memory */
    if (r->request_body == NULL || r->request_body->temp_file == NULL) {
        ngx_log_debug0(NGX_LOG_DEBUG_HTTP, r->connection->log, 0,
                "Open filehandle with 'ngx_input' layer to read from buffers");

        PerlIO *f = PerlIO_allocate(aTHX);

        if (!(f = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_nginx_input), "<", NULL)) ) {
            ngx_log_error(NGX_LOG_ERR, log, 0,
                    "Error pushing layer to FH"
                    );
            return &PL_sv_undef;
        }

        if (!do_open(gv, "+<&", 3, FALSE, O_RDONLY, 0, f)) {
            ngx_log_error(NGX_LOG_ERR, log, 0,
                    "Error opening GV"
                    );
            // FIXME PerlIO_close
            return &PL_sv_undef;
        }

        PerlIONginxInput *st = PerlIOSelf(f, PerlIONginxInput);
        st->r = r;

    } else {
        /* Body in temp file */

        ngx_log_debug1(NGX_LOG_DEBUG_HTTP, r->connection->log, 0,
                "Open PSGI request body temp file '%s'",
                r->request_body->temp_file->file.name.data
                );
        bool result = do_open(gv,(char*)r->request_body->temp_file->file.name.data, r->request_body->temp_file->file.name.len,FALSE,O_RDONLY,0,NULL);

        if (!result) {
            ngx_log_error(NGX_LOG_ERR, log, 0,
                    "Error opening file"
                    );
            // FIXME PerlIO_close
            return NULL;

        }
    }

    return (SV*)newRV_noinc((SV *)gv);
}
Ejemplo n.º 18
0
IV
PerlIOScalar_popped(pTHX_ PerlIO * f)
{
    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
    if (s->var) {
	SvREFCNT_dec(s->var);
	s->var = Nullsv;
    }
    return 0;
}
Ejemplo n.º 19
0
SSize_t
PerlIONginxError_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
{
    PerlIONginxError *st = PerlIOSelf(f, PerlIONginxError);

    // I need to quote '%' characters or disable printf in logging somehow
    ngx_log_error(NGX_LOG_ERR, st->log, 0,
            "%s", (const char *)vbuf);

    return count;
}
IV
PerlIONginxInput_eof(pTHX_ PerlIO *f)
{

    PerlIONginxInput *st = PerlIOSelf(f, PerlIONginxInput);

    if (st->r->headers_in.content_length_n <= st->pos) {
        return 1;
    }
    return 0;
}
Ejemplo n.º 21
0
SSize_t
PerlIOScalar_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
{
    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
    char *dst = SvGROW(s->var, (STRLEN)s->posn + count);
    Move(vbuf, dst + s->posn, count, char);
    s->posn += count;
    SvCUR_set(s->var, (STRLEN)s->posn);
    SvPOK_on(s->var);
    return count;
}
Ejemplo n.º 22
0
IV
PerlIOWin32_popped(pTHX_ PerlIO *f)
{
 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 if (--s->refcnt > 0)
  {
   *f = PerlIOBase(f)->next;
   return 1;
  }
 fdtable[s->fd] = NULL;
 return 0;
}
Ejemplo n.º 23
0
IV
PerlIOMmap_fill(pTHX_ PerlIO *f)
{
    PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
    IV code = PerlIO_flush(f);
    if (code == 0 && !b->buf) {
	code = PerlIOMmap_map(aTHX_ f);
    }
    if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
	code = PerlIOBuf_fill(aTHX_ f);
    }
    return code;
}
Ejemplo n.º 24
0
Off_t
PerlIOEncode_tell(pTHX_ PerlIO * f)
{
    PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
    /* Unfortunately the only way to get a postion is to (re-)translate,
       the UTF8 we have in bufefr and then ask layer below
     */
    PerlIO_flush(f);
    if (b->buf && b->ptr > b->buf) {
	Perl_croak(aTHX_ "Cannot tell at partial character");
    }
    return PerlIO_tell(PerlIONext(f));
}
Ejemplo n.º 25
0
SV *
PerlIOVia_method(pTHX_ PerlIO * f, char *method, CV ** save, int flags,
		 ...)
{
    PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
    CV *cv =
	(*save) ? *save : PerlIOVia_fetchmethod(aTHX_ s, method, save);
    SV *result = Nullsv;
    va_list ap;
    va_start(ap, flags);
    if (cv != (CV *) - 1) {
	IV count;
	dSP;
	SV *arg;
	PUSHSTACKi(PERLSI_MAGIC);
	ENTER;
	SPAGAIN;
	PUSHMARK(sp);
	XPUSHs(s->obj);
	while ((arg = va_arg(ap, SV *))) {
	    XPUSHs(arg);
	}
	if (*PerlIONext(f)) {
	    if (!s->fh) {
		GV *gv = newGVgen(HvNAME(s->stash));
		GvIOp(gv) = newIO();
		s->fh = newRV_noinc((SV *) gv);
		s->io = GvIOp(gv);
	    }
	    IoIFP(s->io) = PerlIONext(f);
	    IoOFP(s->io) = PerlIONext(f);
	    XPUSHs(s->fh);
	}
	else {
	    PerlIO_debug("No next\n");
	    /* FIXME: How should this work for OPEN etc? */
	}
	PUTBACK;
	count = call_sv((SV *) cv, flags);
	if (count) {
	    SPAGAIN;
	    result = POPs;
	    PUTBACK;
	}
	else {
	    result = &PL_sv_undef;
	}
	LEAVE;
	POPSTACK;
    }
Ejemplo n.º 26
0
SSize_t PerlIOmIRC_write( pTHX_ PerlIO * f, const void *vbuf, Size_t count ) {
    PerlIOmIRC * e = PerlIOSelf( f, PerlIOmIRC );
    AV * av = newAV();
    const char * fh = "UNKNOWN";
    if      ( f == PerlIO_stdin( ) )
        fh = "STDIN"; /* Should never get write */
    else if ( f == PerlIO_stdout( ) )
        fh = "STDOUT";
    else if ( f == PerlIO_stderr( ) )
        fh = "STDERR";
    mIRC_execute( form( "/.signal -n PERL_%s %s%s", fh,
                        ( isdigit( *( const char * )vbuf ) ? " " : "" ),
                        vbuf ) );
    return count;
}
Ejemplo n.º 27
0
IV
PerlIOMmap_close(pTHX_ PerlIO *f)
{
    PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
    PerlIOBuf * const b = &m->base;
    IV code = PerlIO_flush(f);
    if (m->bbuf) {
	b->buf = m->bbuf;
	m->bbuf = NULL;
	b->ptr = b->end = b->buf;
    }
    if (PerlIOBuf_close(aTHX_ f) != 0)
	code = -1;
    return code;
}
Ejemplo n.º 28
0
SSize_t
PerlIOWin32_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 DWORD len;
 if (WriteFile(s->h,vbuf,count,&len,NULL))
  {
   return len;
  }
 else
  {
   PerlIOBase(f)->flags |= PERLIO_F_ERROR;
   PerlIO_save_errno(f);
   return -1;
  }
}
Ejemplo n.º 29
0
Off_t
PerlIOWin32_tell(pTHX_ PerlIO *f)
{
 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 DWORD high = 0;
 DWORD res  = SetFilePointer(s->h,0,(LONG *)&high,FILE_CURRENT);
 if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
  {
#if Off_t_size >= 8
   return ((Off_t) high << 32) | res;
#else
   return res;
#endif
  }
 return (Off_t) -1;
}
Ejemplo n.º 30
0
IV
PerlIOWin32_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
 IV code = PerlIOBase_pushed(aTHX_ f,mode,arg,tab);
 if (*PerlIONext(f))
  {
   PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
   s->fd     = PerlIO_fileno(PerlIONext(f));
  }
 PerlIOBase(f)->flags |= PERLIO_F_OPEN;

 Perl_ck_warner_d(aTHX_
                  packWARN(WARN_EXPERIMENTAL__WIN32_PERLIO),
                  "PerlIO layer ':win32' is experimental");

 return code;
}