X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/199670db6c499615e0f5f53e3c84aa6f11584ff1..61b16eb90f32a2433d6de43e477a03b8d9fed039:/mg.c diff --git a/mg.c b/mg.c index 6538003..1859391 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 */ @@ -390,8 +390,6 @@ S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags) if (sv) { MAGIC *mg; - assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv))); - for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) { return mg; @@ -405,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 */ @@ -420,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 */ @@ -449,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 */ @@ -488,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) +SV. Container magic (eg C<%ENV>, C<$1>, C) gets copied, value magic doesn't (eg -taint, pos). +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 @@ -555,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 */ @@ -581,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 */ @@ -751,15 +749,16 @@ S_fixup_errno_string(pTHX_ SV* sv) * case we should turn on that flag. This didn't use to happen, and to * avoid as many possible backward compatibility issues as possible, we * don't turn on the flag unless we have to. So the flag stays off for - * an entirely ASCII string. We assume that if the string looks like - * UTF-8, it really is UTF-8: "text in any other encoding that uses - * bytes with the high bit set is extremely unlikely to pass a UTF-8 - * validity test" (http://en.wikipedia.org/wiki/Charset_detection). - * There is a potential that we will get it wrong however, especially - * on short error message text. (If it turns out to be necessary, we - * could also keep track if the current LC_MESSAGES locale is UTF-8) */ + * an entirely invariant string. We assume that if the string looks + * like UTF-8, it really is UTF-8: "text in any other encoding that + * uses bytes with the high bit set is extremely unlikely to pass a + * UTF-8 validity test" + * (http://en.wikipedia.org/wiki/Charset_detection). There is a + * potential that we will get it wrong however, especially on short + * error message text. (If it turns out to be necessary, we could also + * keep track if the current LC_MESSAGES locale is UTF-8) */ if (! IN_BYTES /* respect 'use bytes' */ - && ! is_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv)) + && ! is_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv)) && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv))) { SvUTF8_on(sv); @@ -1104,7 +1103,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); break; case ':': - break; case '/': break; case '[': @@ -1390,12 +1388,14 @@ Perl_csighandler(int sig) #else dTHX; #endif +#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) #if defined(__cplusplus) && defined(__GNUC__) /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap * parameters would be warned about. */ PERL_UNUSED_ARG(sip); PERL_UNUSED_ARG(uap); #endif +#endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS (void) rsignal(sig, PL_csighandlerp); if (PL_sig_ignoring[sig]) return; @@ -1782,7 +1782,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 @@ -1802,6 +1802,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; } @@ -2546,8 +2547,8 @@ Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg) SvREFCNT_inc_simple_NN(SvRV(sv))); break; case SVt_PVHV: - hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr, - SvREFCNT_inc_simple_NN(SvRV(sv)), 0); + (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr, + SvREFCNT_inc_simple_NN(SvRV(sv)), 0); } if (mg->mg_flags & MGf_PERSIST) NOOP; /* This sv is in use as an iterator var and will be reused, @@ -2867,6 +2868,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); @@ -3012,6 +3014,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 @@ -3019,6 +3027,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); @@ -3030,7 +3039,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; @@ -3043,7 +3057,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)); @@ -3260,7 +3279,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", @@ -3351,7 +3370,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) @@ -3376,12 +3395,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 @@ -3438,7 +3451,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. @@ -3470,7 +3483,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 @@ -3494,7 +3507,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 */ @@ -3558,11 +3571,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: */