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);
}
MP_INLINE static void
modperl_io_perlio_restore_stdhandle(pTHX_ int mode)
{
GV *handle_orig = gv_fetchpv(mode == O_RDONLY ? "STDIN" : "STDOUT",
FALSE, SVt_PVIO);
MP_TRACE_o(MP_FUNC, "start STD%s", mode == O_RDONLY ? "IN" : "OUT");
/* since closing unflushed STDOUT may trigger a subrequest
* (e.g. via mod_include), resulting in potential another response
* handler call, which may try to close STDOUT too. We will
* segfault, if that subrequest doesn't return before the the top
* level STDOUT is attempted to be closed. To prevent this
* situation always explicitly flush STDOUT, before reopening it.
*/
if (mode != O_RDONLY &&
GvIOn(handle_orig) && IoOFP(GvIOn(handle_orig)) &&
(PerlIO_flush(IoOFP(GvIOn(handle_orig))) == -1)) {
Perl_croak(aTHX_ "Failed to flush STDOUT: %" SVf, get_sv("!", TRUE));
}
/* close the overriding filehandle */
do_close(handle_orig, FALSE);
MP_TRACE_o(MP_FUNC, "end STD%s", mode == O_RDONLY ? "IN" : "OUT");
}
int
perl_main(int argc, char **argv, char **env)
{
int r;
iperl = perl_alloc();
perl_construct(iperl);
perl_parse(iperl, xs_init, argc, argv, (char **)NULL);
r = perl_run(iperl);
PerlIO_flush(PerlIO_stdout());
PerlIO_flush(PerlIO_stderr());
perl_destruct(iperl);
perl_free(iperl);
return (r);
}
static IV
PerlIOFlock_pushed(pTHX_ PerlIO* fp, const char* mode, SV* arg,
PerlIO_funcs* tab){
int lock_mode;
int fd;
int ret;
PERL_UNUSED_ARG(mode);
PERL_UNUSED_ARG(tab);
if(!PerlIOValid(fp)){
SETERRNO(EBADF, SS_IVCHAN);
return -1;
}
lock_mode = IOLflag(fp, PERLIO_F_CANWRITE) ? LOCK_EX : LOCK_SH;
if(arg && SvOK(arg)){
const char* const blocking = SvPV_nolen_const(arg);
if(strEQ(blocking, "blocking")){
/* noop */
}
else if(strEQ(blocking, "non-blocking")
|| strEQ(blocking, "LOCK_NB")){
lock_mode |= LOCK_NB;
}
else{
Perl_croak(aTHX_ "Unrecognized :flock handler '%s' "
"(it must be 'blocking' or 'non-blocking')",
blocking);
}
}
fd = PerlIO_fileno(fp);
if(fd == -1){ /* :scalar, :dir, etc. */
return 0; /* success */
}
PerlIO_flush(fp);
ret = PerlLIO_flock(fd, lock_mode);
PerlIO_debug(STRINGIFY(FLOCK) "(%d, %s) -> %d\n", fd,
( lock_mode == (LOCK_SH) ? "LOCK_SH"
: lock_mode == (LOCK_SH|LOCK_NB) ? "LOCK_SH|LOCK_NB"
: lock_mode == (LOCK_EX) ? "LOCK_EX"
: lock_mode == (LOCK_EX|LOCK_NB) ? "LOCK_EX|LOCK_NB"
: "(UNKNOWN)" ),
ret);
return ret;
}
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));
}
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;
}
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;
}
THREAD_RET_TYPE
Perl_ithread_run(LPVOID arg) {
#else
void*
Perl_ithread_run(void * arg) {
#endif
ithread* thread = (ithread*) arg;
dTHXa(thread->interp);
PERL_SET_CONTEXT(thread->interp);
Perl_ithread_set(aTHX_ thread);
#if 0
/* Far from clear messing with ->thr child-side is a good idea */
MUTEX_LOCK(&thread->mutex);
#ifdef WIN32
thread->thr = GetCurrentThreadId();
#else
thread->thr = pthread_self();
#endif
MUTEX_UNLOCK(&thread->mutex);
#endif
PL_perl_destruct_level = 2;
{
AV* params = (AV*) SvRV(thread->params);
I32 len = av_len(params)+1;
int i;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
for(i = 0; i < len; i++) {
XPUSHs(av_shift(params));
}
PUTBACK;
len = call_sv(thread->init_function, thread->gimme|G_EVAL);
SPAGAIN;
for (i=len-1; i >= 0; i--) {
SV *sv = POPs;
av_store(params, i, SvREFCNT_inc(sv));
}
if (SvTRUE(ERRSV)) {
Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
}
FREETMPS;
LEAVE;
SvREFCNT_dec(thread->init_function);
}
PerlIO_flush((PerlIO*)NULL);
MUTEX_LOCK(&thread->mutex);
thread->state |= PERL_ITHR_FINISHED;
if (thread->state & PERL_ITHR_DETACHED) {
MUTEX_UNLOCK(&thread->mutex);
Perl_ithread_destruct(aTHX_ thread, "detached finish");
} else {
MUTEX_UNLOCK(&thread->mutex);
}
MUTEX_LOCK(&create_destruct_mutex);
active_threads--;
assert( active_threads >= 0 );
MUTEX_UNLOCK(&create_destruct_mutex);
#ifdef WIN32
return (DWORD)0;
#else
return 0;
#endif
}
IV
PerlIOEncode_flush(pTHX_ PerlIO * f)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
IV code = 0;
if (e->bufsv) {
dSP;
SV *str;
char *s;
STRLEN len;
SSize_t count = 0;
if ((PerlIOBase(f)->flags & PERLIO_F_WRBUF) && (e->base.ptr > e->base.buf)) {
if (e->inEncodeCall) return 0;
/* Write case - encode the buffer and write() to layer below */
PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(e->enc);
SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
SvUTF8_on(e->bufsv);
XPUSHs(e->bufsv);
XPUSHs(e->chk);
PUTBACK;
e->inEncodeCall = 1;
if (call_method("encode", G_SCALAR) != 1) {
e->inEncodeCall = 0;
Perl_die(aTHX_ "panic: encode did not return a value");
}
e->inEncodeCall = 0;
SPAGAIN;
str = POPs;
PUTBACK;
s = SvPV(str, len);
count = PerlIO_write(PerlIONext(f),s,len);
if ((STRLEN)count != len) {
code = -1;
}
FREETMPS;
LEAVE;
POPSTACK;
if (PerlIO_flush(PerlIONext(f)) != 0) {
code = -1;
}
if (SvCUR(e->bufsv)) {
/* Did not all translate */
e->base.ptr = e->base.buf+SvCUR(e->bufsv);
return code;
}
}
else if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
/* read case */
/* if we have any untranslated stuff then unread that first */
/* FIXME - unread is fragile is there a better way ? */
if (e->dataSV && SvCUR(e->dataSV)) {
s = SvPV(e->dataSV, len);
count = PerlIO_unread(PerlIONext(f),s,len);
if ((STRLEN)count != len) {
code = -1;
}
SvCUR_set(e->dataSV,0);
}
/* See if there is anything left in the buffer */
if (e->base.ptr < e->base.end) {
if (e->inEncodeCall) return 0;
/* Bother - have unread data.
re-encode and unread() to layer below
*/
PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
ENTER;
SAVETMPS;
str = sv_newmortal();
sv_upgrade(str, SVt_PV);
SvPV_set(str, (char*)e->base.ptr);
SvLEN_set(str, 0);
SvCUR_set(str, e->base.end - e->base.ptr);
SvPOK_only(str);
SvUTF8_on(str);
PUSHMARK(sp);
XPUSHs(e->enc);
XPUSHs(str);
XPUSHs(e->chk);
PUTBACK;
e->inEncodeCall = 1;
if (call_method("encode", G_SCALAR) != 1) {
e->inEncodeCall = 0;
Perl_die(aTHX_ "panic: encode did not return a value");
}
e->inEncodeCall = 0;
SPAGAIN;
str = POPs;
PUTBACK;
s = SvPV(str, len);
count = PerlIO_unread(PerlIONext(f),s,len);
if ((STRLEN)count != len) {
code = -1;
}
FREETMPS;
LEAVE;
POPSTACK;
}
}
e->base.ptr = e->base.end = e->base.buf;
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
}
return code;
}
IV
PerlIOEncode_fill(pTHX_ PerlIO * f)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
dSP;
IV code = 0;
PerlIO *n;
SSize_t avail;
if (PerlIO_flush(f) != 0)
return -1;
n = PerlIONext(f);
if (!PerlIO_fast_gets(n)) {
/* Things get too messy if we don't have a buffer layer
push a :perlio to do the job */
char mode[8];
n = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
if (!n) {
Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
}
}
PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
ENTER;
SAVETMPS;
retry:
avail = PerlIO_get_cnt(n);
if (avail <= 0) {
avail = PerlIO_fill(n);
if (avail == 0) {
avail = PerlIO_get_cnt(n);
}
else {
if (!PerlIO_error(n) && PerlIO_eof(n))
avail = 0;
}
}
if (avail > 0 || (e->flags & NEEDS_LINES)) {
STDCHAR *ptr = PerlIO_get_ptr(n);
SSize_t use = (avail >= 0) ? avail : 0;
SV *uni;
char *s = NULL;
STRLEN len = 0;
e->base.ptr = e->base.end = (STDCHAR *) NULL;
(void) PerlIOEncode_get_base(aTHX_ f);
if (!e->dataSV)
e->dataSV = newSV(0);
if (SvTYPE(e->dataSV) < SVt_PV) {
sv_upgrade(e->dataSV,SVt_PV);
}
if (e->flags & NEEDS_LINES) {
/* Encoding needs whole lines (e.g. iso-2022-*)
search back from end of available data for
and line marker
*/
STDCHAR *nl = ptr+use-1;
while (nl >= ptr) {
if (*nl == '\n') {
break;
}
nl--;
}
if (nl >= ptr && *nl == '\n') {
/* found a line - take up to and including that */
use = (nl+1)-ptr;
}
else if (avail > 0) {
/* No line, but not EOF - append avail to the pending data */
sv_catpvn(e->dataSV, (char*)ptr, use);
PerlIO_set_ptrcnt(n, ptr+use, 0);
goto retry;
}
else if (!SvCUR(e->dataSV)) {
goto end_of_file;
}
}
if (SvCUR(e->dataSV)) {
/* something left over from last time - create a normal
SV with new data appended
*/
if (use + SvCUR(e->dataSV) > e->base.bufsiz) {
if (e->flags & NEEDS_LINES) {
/* Have to grow buffer */
e->base.bufsiz = use + SvCUR(e->dataSV);
PerlIOEncode_get_base(aTHX_ f);
}
else {
use = e->base.bufsiz - SvCUR(e->dataSV);
}
}
sv_catpvn(e->dataSV,(char*)ptr,use);
}
else {
/* Create a "dummy" SV to represent the available data from layer below */
if (SvLEN(e->dataSV) && SvPVX_const(e->dataSV)) {
Safefree(SvPVX_mutable(e->dataSV));
}
if (use > (SSize_t)e->base.bufsiz) {
if (e->flags & NEEDS_LINES) {
/* Have to grow buffer */
e->base.bufsiz = use;
PerlIOEncode_get_base(aTHX_ f);
}
else {
use = e->base.bufsiz;
}
}
SvPV_set(e->dataSV, (char *) ptr);
SvLEN_set(e->dataSV, 0); /* Hands off sv.c - it isn't yours */
SvCUR_set(e->dataSV,use);
SvPOK_only(e->dataSV);
}
SvUTF8_off(e->dataSV);
PUSHMARK(sp);
XPUSHs(e->enc);
XPUSHs(e->dataSV);
XPUSHs(e->chk);
PUTBACK;
if (call_method("decode", G_SCALAR) != 1) {
Perl_die(aTHX_ "panic: decode did not return a value");
}
SPAGAIN;
uni = POPs;
PUTBACK;
/* Now get translated string (forced to UTF-8) and use as buffer */
if (SvPOK(uni)) {
s = SvPVutf8(uni, len);
#ifdef PARANOID_ENCODE_CHECKS
if (len && !is_utf8_string((U8*)s,len)) {
Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s);
}
#endif
}
if (len > 0) {
/* Got _something */
/* if decode gave us back dataSV then data may vanish when
we do ptrcnt adjust - so take our copy now.
(The copy is a pain - need a put-it-here option for decode.)
*/
sv_setpvn(e->bufsv,s,len);
e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv);
e->base.end = e->base.ptr + SvCUR(e->bufsv);
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
SvUTF8_on(e->bufsv);
/* Adjust ptr/cnt not taking anything which
did not translate - not clear this is a win */
/* compute amount we took */
use -= SvCUR(e->dataSV);
PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
/* and as we did not take it it isn't pending */
SvCUR_set(e->dataSV,0);
} else {
/* Got nothing - assume partial character so we need some more */
/* Make sure e->dataSV is a normal SV before re-filling as
buffer alias will change under us
*/
s = SvPV(e->dataSV,len);
sv_setpvn(e->dataSV,s,len);
PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
goto retry;
}
}
else {
end_of_file:
code = -1;
if (avail == 0)
PerlIOBase(f)->flags |= PERLIO_F_EOF;
else
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
}
FREETMPS;
LEAVE;
POPSTACK;
return code;
}
