X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/ea5519d61c4e7f31f98e6f49013cbdadbfa26308..0d27008512a08caa599cdcef55d814a6c0e41985:/mg.c diff --git a/mg.c b/mg.c index a64801e..62b4f18 100644 --- a/mg.c +++ b/mg.c @@ -127,7 +127,7 @@ S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags) /* =for apidoc mg_magical -Turns on the magical status of an SV. See C. +Turns on the magical status of an SV. See C>. =cut */ @@ -160,7 +160,7 @@ Perl_mg_magical(SV *sv) =for apidoc mg_get Do magic before a value is retrieved from the SV. The type of SV must -be >= SVt_PVMG. See C. +be >= C. See C>. =cut */ @@ -245,7 +245,7 @@ Perl_mg_get(pTHX_ SV *sv) /* =for apidoc mg_set -Do magic after a value is assigned to the SV. See C. +Do magic after a value is assigned to the SV. See C>. =cut */ @@ -285,10 +285,10 @@ Perl_mg_set(pTHX_ SV *sv) =for apidoc mg_length Reports on the SV's length in bytes, calling length magic if available, -but does not set the UTF8 flag on the sv. It will fall back to 'get' +but does not set the UTF8 flag on C. It will fall back to 'get' magic if there is no 'length' magic, but with no indication as to -whether it called 'get' magic. It assumes the sv is a PVMG or -higher. Use sv_len() instead. +whether it called 'get' magic. It assumes C is a C or +higher. Use C instead. =cut */ @@ -352,7 +352,7 @@ Perl_mg_size(pTHX_ SV *sv) /* =for apidoc mg_clear -Clear something magical that the SV represents. See C. +Clear something magical that the SV represents. See C>. =cut */ @@ -403,7 +403,7 @@ S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags) /* =for apidoc mg_find -Finds the magic pointer for type matching the SV. See C. +Finds the magic pointer for C matching the SV. See C>. =cut */ @@ -418,7 +418,7 @@ Perl_mg_find(const SV *sv, int type) =for apidoc mg_findext Finds the magic pointer of C with the given C for the C. See -C. +C>. =cut */ @@ -447,7 +447,7 @@ Perl_mg_find_mglob(pTHX_ SV *sv) /* =for apidoc mg_copy -Copies the magic from one SV to another. See C. +Copies the magic from one SV to another. See C>. =cut */ @@ -486,12 +486,12 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) =for apidoc mg_localize Copy some of the magic from an existing SV to new localized version of that -SV. Container magic (eg %ENV, $1, tie) -gets copied, value magic doesn't (eg -taint, pos). +SV. Container magic (I, C<%ENV>, C<$1>, C) +gets copied, value magic doesn't (I, +C, C). -If setmagic is false then no set magic will be called on the new (empty) SV. -This typically means that assignment will soon follow (e.g. 'local $x = $y'), +If C is false then no set magic will be called on the new (empty) SV. +This typically means that assignment will soon follow (e.g. S>), and that will handle the magic. =cut @@ -553,7 +553,7 @@ S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg) /* =for apidoc mg_free -Free any magic storage used by the SV. See C. +Free any magic storage used by the SV. See C>. =cut */ @@ -579,7 +579,7 @@ Perl_mg_free(pTHX_ SV *sv) /* =for apidoc Am|void|mg_free_type|SV *sv|int how -Remove any magic of type I from the SV I. See L. +Remove any magic of type C from the SV C. See L. =cut */ @@ -1041,6 +1041,11 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) *PL_compiling.cop_warnings); } } +#ifdef WIN32 + else if (strEQ(remaining, "IN32_SLOPPY_STAT")) { + sv_setiv(sv, w32_sloppystat); + } +#endif break; case '+': if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { @@ -1103,7 +1108,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); break; case ':': - break; case '/': break; case '[': @@ -1211,7 +1215,7 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) } #endif -#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS) +#if !defined(OS2) && !defined(WIN32) && !defined(MSDOS) /* And you'll never guess what the dog had */ /* in its mouth... */ if (TAINTING_get) { @@ -1271,7 +1275,7 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) } } } -#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */ +#endif /* neither OS2 nor WIN32 nor MSDOS */ return 0; } @@ -1783,7 +1787,7 @@ The C can be: The arguments themselves are any values following the C argument. -Returns the SV (if any) returned by the method, or NULL on failure. +Returns the SV (if any) returned by the method, or C on failure. =cut @@ -1803,6 +1807,7 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, if (flags & G_WRITING_TO_STDERR) { SAVETMPS; + save_re_context(); SAVESPTR(PL_stderrgv); PL_stderrgv = NULL; } @@ -1810,7 +1815,9 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); - EXTEND(SP, argc+1); + /* EXTEND() expects a signed argc; don't wrap when casting */ + assert(argc <= I32_MAX); + EXTEND(SP, (I32)argc+1); PUSHs(SvTIED_obj(sv, mg)); if (flags & G_UNDEF_FILL) { while (argc--) { @@ -2561,6 +2568,86 @@ Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg) return 0; } +static void +S_set_dollarzero(pTHX_ SV *sv) + PERL_TSA_REQUIRES(PL_dollarzero_mutex) +{ +#ifdef USE_ITHREADS + dVAR; +#endif + const char *s; + STRLEN len; + I32 i; +#ifdef HAS_SETPROCTITLE + /* The BSDs don't show the argv[] in ps(1) output, they + * show a string from the process struct and provide + * the setproctitle() routine to manipulate that. */ + if (PL_origalen != 1) { + s = SvPV_const(sv, len); +# if __FreeBSD_version > 410001 + /* The leading "-" removes the "perl: " prefix, + * but not the "(perl) suffix from the ps(1) + * output, because that's what ps(1) shows if the + * argv[] is modified. */ + setproctitle("-%s", s); +# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */ + /* This doesn't really work if you assume that + * $0 = 'foobar'; will wipe out 'perl' from the $0 + * because in ps(1) output the result will be like + * sprintf("perl: %s (perl)", s) + * I guess this is a security feature: + * one (a user process) cannot get rid of the original name. + * --jhi */ + setproctitle("%s", s); +# endif + } +#elif defined(__hpux) && defined(PSTAT_SETCMD) + if (PL_origalen != 1) { + union pstun un; + s = SvPV_const(sv, len); + un.pst_command = (char *)s; + pstat(PSTAT_SETCMD, un, len, 0, 0); + } +#else + if (PL_origalen > 1) { + /* PL_origalen is set in perl_parse(). */ + s = SvPV_force(sv,len); + if (len >= (STRLEN)PL_origalen-1) { + /* Longer than original, will be truncated. We assume that + * PL_origalen bytes are available. */ + Copy(s, PL_origargv[0], PL_origalen-1, char); + } + else { + /* Shorter than original, will be padded. */ +#ifdef PERL_DARWIN + /* Special case for Mac OS X: see [perl #38868] */ + const int pad = 0; +#else + /* Is the space counterintuitive? Yes. + * (You were expecting \0?) + * Does it work? Seems to. (In Linux 2.4.20 at least.) + * --jhi */ + const int pad = ' '; +#endif + Copy(s, PL_origargv[0], len, char); + PL_origargv[0][len] = 0; + memset(PL_origargv[0] + len + 1, + pad, PL_origalen - len - 1); + } + 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 +} + int Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) { @@ -2774,6 +2861,17 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = pWARN_NONE; } + /* Yuck. I can't see how to abstract this: */ + else if (isWARN_on( + ((STRLEN *)SvPV_nolen_const(sv)) - 1, + WARN_ALL) + && !any_fatals) + { + if (!specialWARN(PL_compiling.cop_warnings)) + PerlMemShared_free(PL_compiling.cop_warnings); + PL_compiling.cop_warnings = pWARN_ALL; + PL_dowarn |= G_WARN_ONCE ; + } else { STRLEN len; const char *const p = SvPV_const(sv, len); @@ -2789,6 +2887,11 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } } } +#ifdef WIN32 + else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) { + w32_sloppystat = (bool)sv_true(sv); + } +#endif break; case '.': if (PL_localizing) { @@ -2857,6 +2960,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) ); } } else { + sv_setsv(sv, PL_rs); /* diag_listed_as: Setting $/ to %s reference is forbidden */ Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden", *reftype == 'A' ? "n" : "", reftype); @@ -3002,6 +3106,12 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } case ')': { +/* (hv) best guess: maybe we'll need configure probes to do a better job, + * but you can override it if you need to. + */ +#ifndef INVALID_GID +#define INVALID_GID ((Gid_t)-1) +#endif /* XXX $) currently silently ignores failures */ Gid_t new_egid; #ifdef HAS_SETGROUPS @@ -3009,6 +3119,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) const char *p = SvPV_const(sv, len); Groups_t *gary = NULL; const char* endptr; + UV uv; #ifdef _SC_NGROUPS_MAX int maxgrp = sysconf(_SC_NGROUPS_MAX); @@ -3020,7 +3131,12 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) while (isSPACE(*p)) ++p; - new_egid = (Gid_t)grok_atou(p, &endptr); + if (grok_atoUV(p, &uv, &endptr)) + new_egid = (Gid_t)uv; + else { + new_egid = INVALID_GID; + endptr = NULL; + } for (i = 0; i < maxgrp; ++i) { if (endptr == NULL) break; @@ -3033,7 +3149,12 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Newx(gary, i + 1, Groups_t); else Renew(gary, i + 1, Groups_t); - gary[i] = (Groups_t)grok_atou(p, &endptr); + if (grok_atoUV(p, &uv, &endptr)) + gary[i] = (Groups_t)uv; + else { + gary[i] = INVALID_GID; + endptr = NULL; + } } if (i) PERL_UNUSED_RESULT(setgroups(i, gary)); @@ -3082,74 +3203,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '0': LOCK_DOLLARZERO_MUTEX; -#ifdef HAS_SETPROCTITLE - /* The BSDs don't show the argv[] in ps(1) output, they - * show a string from the process struct and provide - * the setproctitle() routine to manipulate that. */ - if (PL_origalen != 1) { - s = SvPV_const(sv, len); -# if __FreeBSD_version > 410001 - /* The leading "-" removes the "perl: " prefix, - * but not the "(perl) suffix from the ps(1) - * output, because that's what ps(1) shows if the - * argv[] is modified. */ - setproctitle("-%s", s); -# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */ - /* This doesn't really work if you assume that - * $0 = 'foobar'; will wipe out 'perl' from the $0 - * because in ps(1) output the result will be like - * sprintf("perl: %s (perl)", s) - * I guess this is a security feature: - * one (a user process) cannot get rid of the original name. - * --jhi */ - setproctitle("%s", s); -# endif - } -#elif defined(__hpux) && defined(PSTAT_SETCMD) - if (PL_origalen != 1) { - union pstun un; - s = SvPV_const(sv, len); - un.pst_command = (char *)s; - pstat(PSTAT_SETCMD, un, len, 0, 0); - } -#else - if (PL_origalen > 1) { - /* PL_origalen is set in perl_parse(). */ - s = SvPV_force(sv,len); - if (len >= (STRLEN)PL_origalen-1) { - /* Longer than original, will be truncated. We assume that - * PL_origalen bytes are available. */ - Copy(s, PL_origargv[0], PL_origalen-1, char); - } - else { - /* Shorter than original, will be padded. */ -#ifdef PERL_DARWIN - /* Special case for Mac OS X: see [perl #38868] */ - const int pad = 0; -#else - /* Is the space counterintuitive? Yes. - * (You were expecting \0?) - * Does it work? Seems to. (In Linux 2.4.20 at least.) - * --jhi */ - const int pad = ' '; -#endif - Copy(s, PL_origargv[0], len, char); - PL_origargv[0][len] = 0; - memset(PL_origargv[0] + len + 1, - pad, PL_origalen - len - 1); - } - 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 + S_set_dollarzero(aTHX_ sv); UNLOCK_DOLLARZERO_MUTEX; break; } @@ -3250,7 +3304,7 @@ Perl_sighandler(int sig) if (hek) Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%"HEKf"\" not defined.\n", - PL_sig_name[sig], hek); + PL_sig_name[sig], HEKfARG(hek)); /* diag_listed_as: SIG%s handler "%s" not defined */ else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"__ANON__\" not defined.\n", @@ -3341,7 +3395,7 @@ Perl_sighandler(int sig) } } -cleanup: + cleanup: /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */ PL_savestack_ix = old_ss_ix; if (flags & 8) @@ -3366,12 +3420,6 @@ S_restore_magic(pTHX_ const void *p) if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */ -#ifdef PERL_OLD_COPY_ON_WRITE - /* While magic was saved (and off) sv_setsv may well have seen - this SV as a prime candidate for COW. */ - if (SvIsCOW(sv)) - sv_force_normal_flags(sv, 0); -#endif if (mgs->mgs_flags) SvFLAGS(sv) |= mgs->mgs_flags; else @@ -3428,7 +3476,7 @@ S_unwind_handler_stack(pTHX_ const void *p) /* =for apidoc magic_sethint -Triggered by a store to %^H, records the key/value pair to +Triggered by a store to C<%^H>, records the key/value pair to C. It is assumed that hints aren't storing anything that would need a deep copy. Maybe we should warn if we find a reference. @@ -3460,7 +3508,7 @@ Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) /* =for apidoc magic_clearhint -Triggered by a delete from %^H, records the key to +Triggered by a delete from C<%^H>, records the key to C. =cut @@ -3484,7 +3532,7 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) /* =for apidoc magic_clearhints -Triggered by clearing %^H, resets C. +Triggered by clearing C<%^H>, resets C. =cut */ @@ -3548,11 +3596,5 @@ Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) { } /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */