void
PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
{
dTHX;
#ifdef FILE_bufsiz
STDCHAR *e = FILE_base(f) + FILE_bufsiz(f);
int ec = e - ptr;
if (ptr > e + 1 && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ WARN_INTERNAL, "Setting ptr %p > end+1 %p\n", ptr, e + 1);
if (cnt != ec && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d, ptr implies %d\n",cnt,ec);
#endif
#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE)
FILE_ptr(f) = ptr;
#else
Perl_croak(aTHX_ "Cannot set 'ptr' of FILE * on this system");
#endif
#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) && defined (STDIO_PTR_LVAL_NOCHANGE_CNT)
FILE_cnt(f) = cnt;
#else
#if defined(STDIO_PTR_LVAL_SETS_CNT)
assert (FILE_cnt(f) == cnt);
#else
Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system when setting 'ptr'");
#endif
#endif
}
int
Perl_runops_debug(pTHX)
{
#ifdef DEBUGGING
if (!PL_op) {
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ WARN_DEBUGGING, "NULL OP IN RUN");
return 0;
}
do {
PERL_ASYNC_CHECK();
if (PL_debug) {
if (PL_watchaddr != 0 && *PL_watchaddr != PL_watchok)
PerlIO_printf(Perl_debug_log,
"WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
PTR2UV(*PL_watchaddr));
DEBUG_s(debstack());
DEBUG_t(debop(PL_op));
DEBUG_P(debprof(PL_op));
}
} while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
TAINT_NOT;
return 0;
#else
return runops_standard();
#endif /* DEBUGGING */
}
void
Perl_av_reify(pTHX_ AV *av)
{
I32 key;
SV* sv;
if (AvREAL(av))
return;
#ifdef DEBUGGING
if (SvTIED_mg((SV*)av, PERL_MAGIC_tied) && ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
#endif
key = AvMAX(av) + 1;
while (key > AvFILLp(av) + 1)
AvARRAY(av)[--key] = &PL_sv_undef;
while (key) {
sv = AvARRAY(av)[--key];
assert(sv);
if (sv != &PL_sv_undef)
(void)SvREFCNT_inc(sv);
}
key = AvARRAY(av) - AvALLOC(av);
while (key)
AvALLOC(av)[--key] = &PL_sv_undef;
AvREIFY_off(av);
AvREAL_on(av);
}
void
Perl_av_reify(pTHX_ AV *av)
{
dVAR;
I32 key;
PERL_ARGS_ASSERT_AV_REIFY;
assert(SvTYPE(av) == SVt_PVAV);
if (AvREAL(av))
return;
#ifdef DEBUGGING
if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied) && ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
#endif
key = AvMAX(av) + 1;
while (key > AvFILLp(av) + 1)
AvARRAY(av)[--key] = &PL_sv_undef;
while (key) {
SV * const sv = AvARRAY(av)[--key];
assert(sv);
if (sv != &PL_sv_undef)
SvREFCNT_inc_simple_void_NN(sv);
}
key = AvARRAY(av) - AvALLOC(av);
while (key)
AvALLOC(av)[--key] = &PL_sv_undef;
AvREIFY_off(av);
AvREAL_on(av);
}
void
PerlIO_set_cnt(PerlIO *f, int cnt)
{
dTHX;
if (cnt < -1 && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d\n",cnt);
#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
FILE_cnt(f) = cnt;
#else
Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system");
#endif
}
void
Perl_taint_proper(pTHX_ const char *f, const char *const s)
{
#if defined(HAS_SETEUID) && defined(DEBUGGING)
dVAR;
PERL_ARGS_ASSERT_TAINT_PROPER;
# if Uid_t_size == 1
{
const UV uid = PL_uid;
const UV euid = PL_euid;
DEBUG_u(PerlIO_printf(Perl_debug_log,
"%s %d %"UVuf" %"UVuf"\n",
s, PL_tainted, uid, euid));
}
# else
{
const IV uid = PL_uid;
const IV euid = PL_euid;
DEBUG_u(PerlIO_printf(Perl_debug_log,
"%s %d %"IVdf" %"IVdf"\n",
s, PL_tainted, uid, euid));
}
# endif
#endif
if (PL_tainted) {
const char *ug;
if (!f)
f = PL_no_security;
if (PL_euid != PL_uid)
ug = " while running setuid";
else if (PL_egid != PL_gid)
ug = " while running setgid";
else if (PL_taint_warn)
ug = " while running with -t switch";
else
ug = " while running with -T switch";
if (PL_unsafe || PL_taint_warn) {
if(ckWARN_d(WARN_TAINT))
Perl_warner(aTHX_ packWARN(WARN_TAINT), f, s, ug);
}
else {
Perl_croak(aTHX_ f, s, ug);
}
}
}
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;
}
