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; }