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;
}
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;
}
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;
}
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;
}
}
}
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);
}
}
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;
}
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);
}
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);
}
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);
}
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;
}
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. */
}
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;
}
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;
}
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;
}
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);
}
IV
PerlIOScalar_popped(pTHX_ PerlIO * f)
{
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
if (s->var) {
SvREFCNT_dec(s->var);
s->var = Nullsv;
}
return 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;
}
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;
}
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;
}
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;
}
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));
}
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;
}
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;
}
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;
}
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;
}
}
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;
}
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;
}