X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=e29b1c68040088658f67520b98d39c04b3f154d1;hb=80008eb3e450496f17610b8bfc820f627a758a13;hp=39d608bb5ce0f758ad90ec98b2b8d3500044fe51;hpb=099be4f1d597471eb719c9a344b7c1b55e11ba24;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mg.c b/mg.c index 39d608b..e29b1c6 100644 --- a/mg.c +++ b/mg.c @@ -57,6 +57,10 @@ tie. # include #endif +#ifdef HAS_PRCTL_SET_NAME +# include +#endif + #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) Signal_t Perl_csighandler(int sig, siginfo_t *, void *); #else @@ -193,7 +197,7 @@ Perl_mg_get(pTHX_ SV *sv) { dVAR; const I32 mgs_ix = SSNEW(sizeof(MGS)); - const bool was_temp = (bool)SvTEMP(sv); + const bool was_temp = cBOOL(SvTEMP(sv)); bool have_new = 0; MAGIC *newmg, *head, *cur, *mg; /* guard against sv having being freed midway by holding a private @@ -1638,55 +1642,109 @@ Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) return 0; } -/* caller is responsible for stack switching/cleanup */ -STATIC int -S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val) +/* +=for apidoc magic_methcall + +Invoke a magic method (like FETCH). + +* sv and mg are the tied thinggy and the tie magic; +* meth is the name of the method to call; +* n, arg1, arg2 are the number of args (in addition to $self) to pass to + the method, and the args themselves (negative n is special-cased); +* flags: + G_DISCARD: invoke method with G_DISCARD flag and don't return a value + +Returns the SV (if any) returned by the method, or NULL on failure. + + +=cut +*/ + +SV* +Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags, + int n, SV *arg1, SV *arg2) { dVAR; dSP; + SV* ret = NULL; PERL_ARGS_ASSERT_MAGIC_METHCALL; + ENTER; + PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); - EXTEND(SP, n); - PUSHs(SvTIED_obj(sv, mg)); - if (n > 1) { - if (mg->mg_ptr) { - if (mg->mg_len >= 0) - mPUSHp(mg->mg_ptr, mg->mg_len); - else if (mg->mg_len == HEf_SVKEY) - PUSHs(MUTABLE_SV(mg->mg_ptr)); - } - else if (mg->mg_type == PERL_MAGIC_tiedelem) { - mPUSHi(mg->mg_len); + + if (n < 0) { + /* special case for UNSHIFT */ + EXTEND(SP,-n+1); + PUSHs(SvTIED_obj(sv, mg)); + while (n++ < 0) { + PUSHs(&PL_sv_undef); } } - if (n > 2) { - PUSHs(val); + else { + EXTEND(SP,n+1); + PUSHs(SvTIED_obj(sv, mg)); + if (n > 0) { + PUSHs(arg1); + if (n > 1) PUSHs(arg2); + assert(n <= 2); + } } PUTBACK; + if (flags & G_DISCARD) { + call_method(meth, G_SCALAR|G_DISCARD); + } + else { + if (call_method(meth, G_SCALAR)) + ret = *PL_stack_sp--; + } + POPSTACK; + LEAVE; + return ret; +} + + +/* wrapper for magic_methcall that creates the first arg */ + +STATIC SV* +S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags, + int n, SV *val) +{ + dVAR; + SV* arg1 = NULL; + + PERL_ARGS_ASSERT_MAGIC_METHCALL1; - return call_method(meth, flags); + if (mg->mg_ptr) { + if (mg->mg_len >= 0) { + arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); + } + else if (mg->mg_len == HEf_SVKEY) + arg1 = MUTABLE_SV(mg->mg_ptr); + } + else if (mg->mg_type == PERL_MAGIC_tiedelem) { + arg1 = newSViv((IV)(mg->mg_len)); + sv_2mortal(arg1); + } + if (!arg1) { + arg1 = val; + n--; + } + return magic_methcall(sv, mg, meth, flags, n, arg1, val); } STATIC int S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth) { - dVAR; dSP; + dVAR; + SV* ret; PERL_ARGS_ASSERT_MAGIC_METHPACK; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - - if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) { - sv_setsv(sv, *PL_stack_sp--); - } - - POPSTACK; - FREETMPS; - LEAVE; + ret = magic_methcall1(sv, mg, meth, 0, 1, NULL); + if (ret) + sv_setsv(sv, ret); return 0; } @@ -1704,7 +1762,7 @@ Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) { - dVAR; dSP; + dVAR; MAGIC *tmg; SV *val; @@ -1729,11 +1787,7 @@ Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) else val = sv; - ENTER; - PUSHSTACKi(PERLSI_MAGIC); - magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, val); - POPSTACK; - LEAVE; + magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val); return 0; } @@ -1749,69 +1803,46 @@ Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) U32 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) { - dVAR; dSP; + dVAR; I32 retval = 0; + SV* retsv; PERL_ARGS_ASSERT_MAGIC_SIZEPACK; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) { - sv = *PL_stack_sp--; - retval = SvIV(sv)-1; + retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL); + if (retsv) { + retval = SvIV(retsv)-1; if (retval < -1) Perl_croak(aTHX_ "FETCHSIZE returned a negative value"); } - POPSTACK; - FREETMPS; - LEAVE; return (U32) retval; } int Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) { - dVAR; dSP; + dVAR; PERL_ARGS_ASSERT_MAGIC_WIPEPACK; - ENTER; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - XPUSHs(SvTIED_obj(sv, mg)); - PUTBACK; - call_method("CLEAR", G_SCALAR|G_DISCARD); - POPSTACK; - LEAVE; - + magic_methcall(sv, mg, "CLEAR", G_DISCARD, 0, NULL, NULL); return 0; } int Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) { - dVAR; dSP; - const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY"; + dVAR; + SV* ret; PERL_ARGS_ASSERT_MAGIC_NEXTPACK; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP, 2); - PUSHs(SvTIED_obj(sv, mg)); - if (SvOK(key)) - PUSHs(key); - PUTBACK; - - if (call_method(meth, G_SCALAR)) - sv_setsv(key, *PL_stack_sp--); - - POPSTACK; - FREETMPS; - LEAVE; + ret = magic_methcall(sv, mg, + (SvOK(key) ? "NEXTKEY" : "FIRSTKEY"), + 0, + (SvOK(key) ? 1 : 0), key, NULL); + if (ret) + sv_setsv(key,ret); return 0; } @@ -1826,7 +1857,7 @@ Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg) SV * Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) { - dVAR; dSP; + dVAR; SV *retval; SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg); HV * const pkg = SvSTASH((const SV *)SvRV(tied)); @@ -1846,19 +1877,9 @@ Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) } /* there is a SCALAR method that we can call */ - ENTER; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP, 1); - PUSHs(tied); - PUTBACK; - - if (call_method("SCALAR", G_SCALAR)) - retval = *PL_stack_sp--; - else + retval = magic_methcall(MUTABLE_SV(hv), mg, "SCALAR", 0, 0, NULL, NULL); + if (!retval) retval = &PL_sv_undef; - POPSTACK; - LEAVE; return retval; } @@ -2359,7 +2380,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) sv_setsv(PL_bodytarget, sv); break; case '\003': /* ^C */ - PL_minus_c = (bool)SvIV(sv); + PL_minus_c = cBOOL(SvIV(sv)); break; case '\004': /* ^D */ @@ -2645,7 +2666,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #endif #endif PL_uid = PerlProc_getuid(); - PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case '>': PL_euid = SvIV(sv); @@ -2672,7 +2692,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #endif #endif PL_euid = PerlProc_geteuid(); - PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case '(': PL_gid = SvIV(sv); @@ -2699,7 +2718,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #endif #endif PL_gid = PerlProc_getgid(); - PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case ')': #ifdef HAS_SETGROUPS @@ -2761,7 +2779,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #endif #endif PL_egid = PerlProc_getegid(); - PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case ':': PL_chopset = SvPV_force(sv,len); @@ -2827,6 +2844,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_origargv[0][PL_origalen-1] = 0; for (i = 1; i < PL_origargc; i++) PL_origargv[i] = 0; +#ifdef HAS_PRCTL_SET_NAME + /* Set the legacy process name in addition to the POSIX name on Linux */ + if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) { + /* diag_listed_as: SKIPME */ + Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno)); + } +#endif } #endif UNLOCK_DOLLARZERO_MUTEX;