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;
}
int modperl_require_module(pTHX_ const char *pv, int logfailure)
{
SV *sv;
dSP;
PUSHSTACKi(PERLSI_REQUIRE);
ENTER;SAVETMPS;
PUTBACK;
sv = sv_newmortal();
sv_setpv(sv, "require ");
sv_catpv(sv, pv);
eval_sv(sv, G_DISCARD);
SPAGAIN;
POPSTACK;
FREETMPS;LEAVE;
if (SvTRUE(ERRSV)) {
if (logfailure) {
(void)modperl_errsv(aTHX_ HTTP_INTERNAL_SERVER_ERROR,
NULL, NULL);
}
return FALSE;
}
return TRUE;
}
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;
}
void
Perl_av_extend(pTHX_ AV *av, I32 key)
{
dVAR;
MAGIC *mg;
PERL_ARGS_ASSERT_AV_EXTEND;
assert(SvTYPE(av) == SVt_PVAV);
mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
if (mg) {
dSP;
ENTER;
SAVETMPS;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,2);
PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
mPUSHi(key + 1);
PUTBACK;
call_method("EXTEND", G_SCALAR|G_DISCARD);
POPSTACK;
FREETMPS;
LEAVE;
return;
}
if (key > AvMAX(av)) {
SV** ary;
I32 tmp;
I32 newmax;
if (AvALLOC(av) != AvARRAY(av)) {
ary = AvALLOC(av) + AvFILLp(av) + 1;
tmp = AvARRAY(av) - AvALLOC(av);
Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
AvMAX(av) += tmp;
AvARRAY(av) = AvALLOC(av);
if (AvREAL(av)) {
while (tmp)
ary[--tmp] = &PL_sv_undef;
}
if (key > AvMAX(av) - 10) {
newmax = key + AvMAX(av);
goto resize;
}
}
void
Perl_av_extend(pTHX_ AV *av, I32 key)
{
MAGIC *mg;
if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
dSP;
ENTER;
SAVETMPS;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,2);
PUSHs(SvTIED_obj((SV*)av, mg));
PUSHs(sv_2mortal(newSViv(key+1)));
PUTBACK;
call_method("EXTEND", G_SCALAR|G_DISCARD);
POPSTACK;
FREETMPS;
LEAVE;
return;
}
if (key > AvMAX(av)) {
SV** ary;
I32 tmp;
I32 newmax;
if (AvALLOC(av) != AvARRAY(av)) {
ary = AvALLOC(av) + AvFILLp(av) + 1;
tmp = AvARRAY(av) - AvALLOC(av);
Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
AvMAX(av) += tmp;
SvPVX(av) = (char*)AvALLOC(av);
if (AvREAL(av)) {
while (tmp)
ary[--tmp] = &PL_sv_undef;
}
if (key > AvMAX(av) - 10) {
newmax = key + AvMAX(av);
goto resize;
}
}
IV
PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs *tab)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
dSP;
IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv,tab);
SV *result = Nullsv;
PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(arg);
PUTBACK;
if (call_pv("Encode::find_encoding", G_SCALAR) != 1) {
/* should never happen */
Perl_die(aTHX_ "Encode::find_encoding did not return a value");
return -1;
}
SPAGAIN;
result = POPs;
PUTBACK;
if (!SvROK(result) || !SvOBJECT(SvRV(result))) {
e->enc = Nullsv;
if (ckWARN_d(WARN_IO))
Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
arg);
errno = EINVAL;
code = -1;
}
else {
/* $enc->renew */
PUSHMARK(sp);
XPUSHs(result);
PUTBACK;
if (call_method("renew",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
if (ckWARN_d(WARN_IO))
Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support renew method",
arg);
}
else {
SPAGAIN;
result = POPs;
PUTBACK;
}
e->enc = newSVsv(result);
PUSHMARK(sp);
XPUSHs(e->enc);
PUTBACK;
if (call_method("needs_lines",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
if (ckWARN_d(WARN_IO))
Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support needs_lines",
arg);
}
else {
SPAGAIN;
result = POPs;
PUTBACK;
if (SvTRUE(result)) {
e->flags |= NEEDS_LINES;
}
}
PerlIOBase(f)->flags |= PERLIO_F_UTF8;
}
e->chk = newSVsv(get_sv("PerlIO::encoding::fallback", 0));
e->inEncodeCall = 0;
FREETMPS;
LEAVE;
POPSTACK;
return code;
}
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;
}
