#include "XSUB.h"
#define U8 U8
+#define OUR_DEFAULT_FB "Encode::PERLQQ"
+
#if defined(USE_PERLIO) && !defined(USE_SFIO)
/* Define an encoding "layer" in the perliol.h sense.
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);
sv = newSVsv(POPs);
PUTBACK;
}
+ FREETMPS;
+ LEAVE;
+ POPSTACK;
}
return sv;
}
IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
SV *result = Nullsv;
- /*
- * we now "use Encode qw(:fallbacks)" here instead of
- * PerlIO/encoding.pm. This avoids SEGV when ":encoding()"
- * is invoked without prior "use Encode". -- dankogai
- */
- require_pv("Encode.pm");
+ PUSHSTACKi(PERLSI_MAGIC);
+ SPAGAIN;
ENTER;
SAVETMPS;
if (!SvROK(result) || !SvOBJECT(SvRV(result))) {
e->enc = Nullsv;
Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
- arg);
+ arg);
errno = EINVAL;
code = -1;
}
PerlIOBase(f)->flags |= PERLIO_F_UTF8;
}
- if (SvIV(result = get_sv("PerlIO::encoding::check", 1)) == 0){
- PUSHMARK(sp);
- PUTBACK;
- if (call_pv("Encode::FB_QUIET", G_SCALAR) != 1) {
- /* should never happen */
- Perl_die(aTHX_ "Encode::FB_QUIET did not return a value");
- return -1;
- }
- SPAGAIN;
- e->chk = newSVsv(POPs);
- PUTBACK;
- sv_setsv(result, e->chk);
- }else{
- e->chk = newSVsv(result);
- }
+ e->chk = newSVsv(get_sv("PerlIO::encoding::fallback", 0));
+
FREETMPS;
LEAVE;
+ POPSTACK;
return code;
}
}
if (e->chk) {
SvREFCNT_dec(e->chk);
- e->dataSV = Nullsv;
+ e->chk = Nullsv;
}
return 0;
}
Perl_die(aTHX_ "panic: cannot push :perlio for %p",f);
}
}
+ PUSHSTACKi(PERLSI_MAGIC);
+ SPAGAIN;
ENTER;
SAVETMPS;
retry:
PerlIO_set_ptrcnt(n, ptr+use, (avail-use));
goto retry;
}
- FREETMPS;
- LEAVE;
- return code;
}
else {
end_of_file:
+ code = -1;
if (avail == 0)
PerlIOBase(f)->flags |= PERLIO_F_EOF;
else
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
- return -1;
}
+ FREETMPS;
+ LEAVE;
+ POPSTACK;
+ return code;
}
IV
SSize_t count = 0;
if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
/* Write case encode the buffer and write() to layer below */
+ PUSHSTACKi(PERLSI_MAGIC);
+ SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK(sp);
}
FREETMPS;
LEAVE;
+ POPSTACK;
if (PerlIO_flush(PerlIONext(f)) != 0) {
code = -1;
}
/* Bother - have unread data.
re-encode and unread() to layer below
*/
+ PUSHSTACKi(PERLSI_MAGIC);
+ SPAGAIN;
ENTER;
SAVETMPS;
str = sv_newmortal();
}
FREETMPS;
LEAVE;
+ POPSTACK;
}
}
e->base.ptr = e->base.end = e->base.buf;
BOOT:
{
+ SV *chk = get_sv("PerlIO::encoding::fallback", GV_ADD|GV_ADDMULTI);
+ /*
+ * we now "use Encode ()" here instead of
+ * PerlIO/encoding.pm. This avoids SEGV when ":encoding()"
+ * is invoked without prior "use Encode". -- dankogai
+ */
+ PUSHSTACKi(PERLSI_MAGIC);
+ SPAGAIN;
+ if (!get_cv(OUR_DEFAULT_FB, 0)) {
+#if 0
+ /* This would just be an irritant now loading works */
+ Perl_warner(aTHX_ packWARN(WARN_IO), ":encoding without 'use Encode'");
+#endif
+ ENTER;
+ /* Encode needs a lot of stack - it is likely to move ... */
+ PUTBACK;
+ /* The SV is magically freed by load_module */
+ load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("Encode", 6), Nullsv, Nullsv);
+ SPAGAIN;
+ LEAVE;
+ }
+ PUSHMARK(sp);
+ PUTBACK;
+ if (call_pv(OUR_DEFAULT_FB, G_SCALAR) != 1) {
+ /* should never happen */
+ Perl_die(aTHX_ "%s did not return a value",OUR_DEFAULT_FB);
+ }
+ SPAGAIN;
+ sv_setsv(chk, POPs);
+ PUTBACK;
#ifdef PERLIO_LAYERS
- PerlIO_define_layer(aTHX_ &PerlIO_encode);
+ PerlIO_define_layer(aTHX_ &PerlIO_encode);
#endif
+ POPSTACK;
}