STATIC I32 S_do_trans_count(pTHX_ SV * const sv) { dVAR; STRLEN len; const U8 *s = (const U8*)SvPV_const(sv, len); const U8 * const send = s + len; I32 matches = 0; const short * const tbl = (short*)cPVOP->op_pv; if (!tbl) Perl_croak(aTHX_ "panic: do_trans_count line %d",__LINE__); if (!SvUTF8(sv)) { while (s < send) { if (tbl[*s++] >= 0) matches++; } } else { const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT; while (s < send) { STRLEN ulen; const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT); if (c < 0x100) { if (tbl[c] >= 0) matches++; } else if (complement) matches++; s += ulen; } } return matches; }
static int modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) { dVAR; SV *attr; int nret; for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) { STRLEN len; const char *name = SvPV_const(attr, len); const bool negated = (*name == '-'); if (negated) { name++; len--; } switch (SvTYPE(sv)) { case SVt_PVCV: switch ((int)len) { case 6: switch (name[3]) { case 'l': if (memEQ(name, "lvalue", 6)) { if (negated) CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE; else CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE; continue; } break; case 'h': if (memEQ(name, "method", 6)) { if (negated) CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD; else CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD; continue; } break; } break; } break; default: if (memEQs(name, 6, "shared")) { if (negated) Perl_croak(aTHX_ "A variable may not be unshared"); SvSHARE(sv); continue; } break; } /* anything recognized had a 'continue' above */ *retlist++ = attr; nret++; } return nret; }
static void my_sv_copypv(pTHX_ SV *const dsv, SV *const ssv) { STRLEN len; const char * const s = SvPV_const(ssv,len); sv_setpvn(dsv,s,len); if (SvUTF8(ssv)) SvUTF8_on(dsv); else SvUTF8_off(dsv); }
void Perl_taint_env(pTHX) { dVAR; SV** svp; MAGIC* mg; const char* const *e; static const char* const misc_env[] = { "IFS", /* most shells' inter-field separators */ "CDPATH", /* ksh dain bramage #1 */ "ENV", /* ksh dain bramage #2 */ "BASH_ENV", /* bash dain bramage -- I guess it's contagious */ #ifdef WIN32 "PERL5SHELL", /* used for system() on Windows */ #endif NULL }; /* Don't bother if there's no *ENV glob */ if (!PL_envgv) return; /* If there's no %ENV hash of if it's not magical, croak, because * it probably doesn't reflect the actual environment */ if (!GvHV(PL_envgv) || !(SvRMAGICAL(GvHV(PL_envgv)) && mg_find((const SV *)GvHV(PL_envgv), PERL_MAGIC_env))) { const bool was_tainted = PL_tainted; const char * const name = GvENAME(PL_envgv); PL_tainted = TRUE; if (strEQ(name,"ENV")) /* hash alias */ taint_proper("%%ENV is aliased to %s%s", "another variable"); else /* glob alias: report it in the error message */ taint_proper("%%ENV is aliased to %%%s%s", name); /* this statement is reached under -t or -U */ PL_tainted = was_tainted; } #ifdef VMS { int i = 0; char name[10 + TYPE_DIGITS(int)] = "DCL$PATH"; STRLEN len = 8; /* strlen(name) */ while (1) { if (i) len = my_sprintf(name,"DCL$PATH;%d", i); svp = hv_fetch(GvHVn(PL_envgv), name, len, FALSE); if (!svp || *svp == &PL_sv_undef) break; if (SvTAINTED(*svp)) { TAINT; taint_proper("Insecure %s%s", "$ENV{DCL$PATH}"); } if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) { TAINT; taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}"); } i++; } } #endif /* VMS */ svp = hv_fetchs(GvHVn(PL_envgv),"PATH",FALSE); if (svp && *svp) { if (SvTAINTED(*svp)) { TAINT; taint_proper("Insecure %s%s", "$ENV{PATH}"); } if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) { TAINT; taint_proper("Insecure directory in %s%s", "$ENV{PATH}"); } } #ifndef VMS /* tainted $TERM is okay if it contains no metachars */ svp = hv_fetchs(GvHVn(PL_envgv),"TERM",FALSE); if (svp && *svp && SvTAINTED(*svp)) { STRLEN len; const bool was_tainted = PL_tainted; const char *t = SvPV_const(*svp, len); const char * const e = t + len; PL_tainted = was_tainted; if (t < e && isALNUM(*t)) t++; while (t < e && (isALNUM(*t) || strchr("-_.+", *t))) t++; if (t < e) { TAINT; taint_proper("Insecure $ENV{%s}%s", "TERM"); } } #endif /* !VMS */ for (e = misc_env; *e; e++) { SV * const * const svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE); if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) { TAINT; taint_proper("Insecure $ENV{%s}%s", *e); } } }
static int modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) { SV *attr; int nret; for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) { STRLEN len; const char *name = SvPV_const(attr, len); const bool negated = (*name == '-'); if (negated) { name++; len--; } switch (SvTYPE(sv)) { case SVt_PVCV: switch ((int)len) { #ifdef CVf_ASSERTION case 9: if (memEQ(name, "assertion", 9)) { if (negated) CvFLAGS((CV*)sv) &= ~CVf_ASSERTION; else CvFLAGS((CV*)sv) |= CVf_ASSERTION; continue; } break; #endif case 6: switch (name[3]) { case 'l': #ifdef CVf_LVALUE if (memEQ(name, "lvalue", 6)) { if (negated) CvFLAGS((CV*)sv) &= ~CVf_LVALUE; else CvFLAGS((CV*)sv) |= CVf_LVALUE; continue; } break; case 'k': #endif /* defined CVf_LVALUE */ if (memEQ(name, "locked", 6)) { if (negated) CvFLAGS((CV*)sv) &= ~CVf_LOCKED; else CvFLAGS((CV*)sv) |= CVf_LOCKED; continue; } break; case 'h': if (memEQ(name, "method", 6)) { if (negated) CvFLAGS((CV*)sv) &= ~CVf_METHOD; else CvFLAGS((CV*)sv) |= CVf_METHOD; continue; } break; } break; } break; default: switch ((int)len) { case 6: switch (name[5]) { case 'd': if (memEQ(name, "share", 5)) { if (negated) Perl_croak(aTHX_ "A variable may not be unshared"); SvSHARE(sv); continue; } break; case 'e': if (memEQ(name, "uniqu", 5)) { if (SvTYPE(sv) == SVt_PVGV) { if (negated) { GvUNIQUE_off(sv); } else { GvUNIQUE_on(sv); } } /* Hope this came from toke.c if not a GV. */ continue; } } } break; } /* anything recognized had a 'continue' above */ *retlist++ = attr; nret++; } return nret; }
/* * This is the main Load function. * It takes a yaml stream and turns it into 0 or more Perl objects. */ void Load(SV *yaml_sv) { dXSARGS; perl_yaml_loader_t loader; SV *node; const unsigned char *yaml_str; STRLEN yaml_len; yaml_str = (const unsigned char *)SvPV_const(yaml_sv, yaml_len); if (DO_UTF8(yaml_sv)) { yaml_sv = sv_mortalcopy(yaml_sv); if (!sv_utf8_downgrade(yaml_sv, TRUE)) croak("%s", "Wide character in YAML::XS::Load()"); yaml_str = (const unsigned char *)SvPV_const(yaml_sv, yaml_len); } sp = mark; if (0 && (items || ax)) {} /* XXX Quiet the -Wall warnings for now. */ yaml_parser_initialize(&loader.parser); loader.document = 0; yaml_parser_set_input_string( &loader.parser, yaml_str, yaml_len ); /* Get the first event. Must be a STREAM_START */ if (!yaml_parser_parse(&loader.parser, &loader.event)) goto load_error; if (loader.event.type != YAML_STREAM_START_EVENT) croak("%sExpected STREAM_START_EVENT; Got: %d != %d", ERRMSG, loader.event.type, YAML_STREAM_START_EVENT ); loader.anchors = newHV(); sv_2mortal((SV *)loader.anchors); /* Keep calling load_node until end of stream */ while (1) { loader.document++; /* We are through with the previous event - delete it! */ yaml_event_delete(&loader.event); if (!yaml_parser_parse(&loader.parser, &loader.event)) goto load_error; if (loader.event.type == YAML_STREAM_END_EVENT) break; node = load_node(&loader); /* We are through with the previous event - delete it! */ yaml_event_delete(&loader.event); hv_clear(loader.anchors); if (! node) break; XPUSHs(sv_2mortal(node)); if (!yaml_parser_parse(&loader.parser, &loader.event)) goto load_error; if (loader.event.type != YAML_DOCUMENT_END_EVENT) croak("%sExpected DOCUMENT_END_EVENT", ERRMSG); } /* Make sure the last event is a STREAM_END */ if (loader.event.type != YAML_STREAM_END_EVENT) croak("%sExpected STREAM_END_EVENT; Got: %d != %d", ERRMSG, loader.event.type, YAML_STREAM_END_EVENT ); yaml_parser_delete(&loader.parser); PUTBACK; return; load_error: croak("%s", loader_error_msg(&loader, NULL)); }
/* helper for the default modify handler for builtin attributes */ static int modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) { SV *attr; int nret; for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) { STRLEN len; const char *name = SvPV_const(attr, len); const bool negated = (*name == '-'); HV *typestash; if (negated) { name++; len--; } switch (SvTYPE(sv)) { case SVt_PVCV: switch ((int)len) { case 4: if (memEQ(name, "pure", 4)) { if (negated) Perl_croak(aTHX_ "Illegal :-pure attribute"); CvPURE_on(sv); goto next_attr; } break; case 5: if (memEQ(name, "const", 5)) { if (negated) CvCONST_off(sv); else { #ifndef USE_CPERL const bool warn = (!CvANON(sv) || CvCLONED(sv)) && !CvCONST(sv); CvCONST_on(sv); if (warn) break; #else CvCONST_on(sv); #endif } goto next_attr; } break; case 6: switch (name[3]) { case 'l': if (memEQ(name, "lvalue", 6)) { bool warn = !CvISXSUB(MUTABLE_CV(sv)) && CvROOT(MUTABLE_CV(sv)) && !CvLVALUE(MUTABLE_CV(sv)) != negated; if (negated) CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE; else CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE; if (warn) break; goto next_attr; } break; case 'h': if (memEQ(name, "method", 6)) { if (negated) CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD; else CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD; goto next_attr; } break; } break; default: if (len > 10 && memEQ(name, "prototype(", 10)) { SV * proto = newSVpvn(name+10,len-11); HEK *const hek = CvNAME_HEK((CV *)sv); SV *subname; if (name[len-1] != ')') Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list"); if (hek) subname = sv_2mortal(newSVhek(hek)); else subname=(SV *)CvGV((const CV *)sv); if (ckWARN(WARN_ILLEGALPROTO)) Perl_validate_proto(aTHX_ subname, proto, TRUE); Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv, (const GV *)subname, name+10, len-11, SvUTF8(attr)); sv_setpvn(MUTABLE_SV(sv), name+10, len-11); if (SvUTF8(attr)) SvUTF8_on(MUTABLE_SV(sv)); goto next_attr; } break; } if (!negated && (typestash = gv_stashpvn(name, len, SvUTF8(attr)))) { CvTYPED_on(sv); CvTYPE_set((CV*)sv, typestash); continue; } break; case SVt_IV: case SVt_PVIV: case SVt_PVMG: if (memEQ(name, "unsigned", 8) && (SvIOK(sv) || SvUOK(sv))) { if (negated) /* :-unsigned alias for :signed */ SvIsUV_off(sv); else SvIsUV_on(sv); continue; } /* fallthru - all other data types */ default: if (memEQ(name, "const", 5) && !(SvFLAGS(sv) & SVf_PROTECT)) { if (negated) SvREADONLY_off(sv); else SvREADONLY_on(sv); continue; } if (memEQs(name, len, "shared")) { if (negated) Perl_croak(aTHX_ "A variable may not be unshared"); SvSHARE(sv); continue; } break; } /* anything recognized had a 'continue' above */ *retlist++ = attr; nret++; next_attr: ; } return nret; }
void S_signals_set_handler(SV* handlersv, SV* namesv) { I32 i; /* Need to be careful with SvREFCNT_dec(), because that can have side * effects (due to closures). We must make sure that the new disposition * is in place before it is called. */ SV* to_dec = NULL; STRLEN len; const char *s; bool set_to_ignore = FALSE; bool set_to_default = FALSE; #ifdef HAS_SIGPROCMASK sigset_t set, save; SV* save_sv; #endif if ( SvROK(handlersv) ) { if ( SvTYPE(SvRV(handlersv)) != SVt_PVCV ) Perl_croak(aTHX_ "signal handler should be a code refernce, 'DEFAULT' or 'IGNORE'"); } else { const char *s = SvOK(handlersv) ? SvPV_const(handlersv, len) : "DEFAULT"; if ( strEQ(s,"IGNORE") ) set_to_ignore = TRUE; else if (strEQ(s,"DEFAULT")) set_to_default = TRUE; else Perl_croak(aTHX_ "signal handler should be a code reference or 'DEFAULT or 'IGNORE'"); } if (!PL_psig_ptr) { Newxz(PL_psig_ptr, SIG_SIZE, SV*); Newxz(PL_psig_name, SIG_SIZE, SV*); Newxz(PL_psig_pend, SIG_SIZE, int); } s = SvPV_const(namesv,len); i = whichsig(s); /* ...no, a brick */ if (i <= 0) { Perl_croak(aTHX_ "No such signal: SIG%s", s); } #ifdef HAS_SIGPROCMASK /* Avoid having the signal arrive at a bad time, if possible. */ sigemptyset(&set); sigaddset(&set,i); sigprocmask(SIG_BLOCK, &set, &save); ENTER; save_sv = newSVpvn((char *)(&save), sizeof(sigset_t)); SAVEFREESV(save_sv); SAVEDESTRUCTOR_X(restore_sigmask, save_sv); #endif PERL_ASYNC_CHECK(); #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) if (!PL_sig_handlers_initted) Perl_csighandler_init(); #endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS PL_sig_ignoring[i] = 0; #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS PL_sig_defaulting[i] = 0; #endif SvREFCNT_dec(PL_psig_name[i]); to_dec = PL_psig_ptr[i]; PL_psig_ptr[i] = NULL; PL_psig_name[i] = newSVpvn(s, len); SvREADONLY_on(PL_psig_name[i]); if (SvROK(handlersv)) { PL_psig_ptr[i] = SvREFCNT_inc(SvRV(handlersv)); (void)rsignal(i, PL_csighandlerp); #ifdef HAS_SIGPROCMASK LEAVE; #endif if(to_dec) SvREFCNT_dec(to_dec); return; } if (set_to_ignore) { #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS PL_sig_ignoring[i] = 1; (void)rsignal(i, PL_csighandlerp); #else (void)rsignal(i, (Sighandler_t) SIG_IGN); #endif } else { #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS PL_sig_defaulting[i] = 1; (void)rsignal(i, PL_csighandlerp); #else (void)rsignal(i, (Sighandler_t) SIG_DFL); #endif } #ifdef HAS_SIGPROCMASK if(i) LEAVE; #endif if(to_dec) SvREFCNT_dec(to_dec); }