X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/fd503f5cfcafd1bd5c45f898cce12ece8d1d368a..a09afec511396f7ac9116e5db10cfb3e8a1d8e78:/mg.c diff --git a/mg.c b/mg.c index 3a2210d..64e450f 100644 --- a/mg.c +++ b/mg.c @@ -626,6 +626,42 @@ Perl_mg_free_type(pTHX_ SV *sv, int how) mg_magical(sv); } +/* +=for apidoc mg_freeext + +Remove any magic of type C using virtual table C from the +SV C. See L. + +C is equivalent to C. + +=cut +*/ + +void +Perl_mg_freeext(pTHX_ SV *sv, int how, const MGVTBL *vtbl) +{ + MAGIC *mg, *prevmg, *moremg; + PERL_ARGS_ASSERT_MG_FREEEXT; + for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) { + MAGIC *newhead; + moremg = mg->mg_moremagic; + if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) { + /* temporarily move to the head of the magic chain, in case + custom free code relies on this historical aspect of mg_free */ + if (prevmg) { + prevmg->mg_moremagic = moremg; + mg->mg_moremagic = SvMAGIC(sv); + SvMAGIC_set(sv, mg); + } + newhead = mg->mg_moremagic; + mg_free_struct(sv, mg); + SvMAGIC_set(sv, newhead); + mg = prevmg; + } + } + mg_magical(sv); +} + #include U32 @@ -638,8 +674,8 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm) { REGEXP * const rx = PM_GETRE(PL_curpm); if (rx) { - UV uv = (UV)mg->mg_obj; - if (uv == '+') { /* @+ */ + const SSize_t n = (SSize_t)mg->mg_obj; + if (n == '+') { /* @+ */ /* return the number possible */ return RX_NPARENS(rx); } else { /* @- @^CAPTURE @{^CAPTURE} */ @@ -650,7 +686,7 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) && (RX_OFFS(rx)[paren].start == -1 || RX_OFFS(rx)[paren].end == -1) ) paren--; - if (uv == '-') { + if (n == '-') { /* @- */ return (U32)paren; } else { @@ -674,10 +710,10 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm) { REGEXP * const rx = PM_GETRE(PL_curpm); if (rx) { - const UV uv = (UV)mg->mg_obj; + const SSize_t n = (SSize_t)mg->mg_obj; /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */ const I32 paren = mg->mg_len - + (uv == '\003' ? 1 : 0); + + (n == '\003' ? 1 : 0); SSize_t s; SSize_t t; if (paren < 0) @@ -688,9 +724,9 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) { SSize_t i; - if (uv == '+') /* @+ */ + if (n == '+') /* @+ */ i = t; - else if (uv == '-') /* @- */ + else if (n == '-') /* @- */ i = s; else { /* @^CAPTURE @{^CAPTURE} */ CALLREG_NUMBUF_FETCH(rx,paren,sv); @@ -710,7 +746,7 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) } } } - sv_setsv(sv, NULL); + sv_set_undef(sv); return 0; } @@ -787,17 +823,74 @@ S_fixup_errno_string(pTHX_ SV* sv) * 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_utf8_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv)) - && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv))) - { + * error message text, so do an additional check. */ + if ( ! IN_BYTES /* respect 'use bytes' */ + && is_utf8_non_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv)) + +#ifdef USE_LOCALE_MESSAGES + + && _is_cur_LC_category_utf8(LC_MESSAGES) + +#elif defined(USE_LOCLAE_CTYPE) + + /* For systems that don't have a separate message category, + * this assumes that they follow the CTYPE one */ + && _is_cur_LC_category_utf8(LC_CTYPE) + +#endif + + ) { SvUTF8_on(sv); } } } +/* +=for apidoc Am|SV *|sv_string_from_errnum|int errnum|SV *tgtsv + +Generates the message string describing an OS error and returns it as +an SV. C must be a value that C could take, identifying +the type of error. + +If C is non-null then the string will be written into that SV +(overwriting existing content) and it will be returned. If C +is a null pointer then the string will be written into a new mortal SV +which will be returned. + +The message will be taken from whatever locale would be used by C<$!>, +and will be encoded in the SV in whatever manner would be used by C<$!>. +The details of this process are subject to future change. Currently, +the message is taken from the C locale by default (usually producing an +English message), and from the currently selected locale when in the scope +of the C pragma. A heuristic attempt is made to decode the +message from the locale's character encoding, but it will only be decoded +as either UTF-8 or ISO-8859-1. It is always correctly decoded in a UTF-8 +locale, usually in an ISO-8859-1 locale, and never in any other locale. + +The SV is always returned containing an actual string, and with no other +OK bits set. Unlike C<$!>, a message is even yielded for C zero +(meaning success), and if no useful message is available then a useless +string (currently empty) is returned. + +=cut +*/ + +SV * +Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv) +{ + char const *errstr; + if(!tgtsv) + tgtsv = sv_newmortal(); + errstr = my_strerror(errnum); + if(errstr) { + sv_setpv(tgtsv, errstr); + fixup_errno_string(tgtsv); + } else { + SvPVCLEAR(tgtsv); + } + return tgtsv; +} + #ifdef VMS #include #include @@ -849,7 +942,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\005': /* ^E */ if (nextchar != '\0') { if (strEQ(remaining, "NCODING")) - sv_setsv(sv, NULL); + sv_set_undef(sv); break; } @@ -900,6 +993,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; #endif /* End of platforms with special handling for $^E; others just fall through to $! */ + /* FALLTHROUGH */ case '!': { @@ -918,14 +1012,12 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) SvPVCLEAR(sv); } else { - - /* Strerror can return NULL on some platforms, which will - * result in 'sv' not being considered SvOK. The SvNOK_on() + sv_string_from_errnum(errno, sv); + /* If no useful string is available, don't + * claim to have a string part. The SvNOK_on() * below will cause just the number part to be valid */ - sv_setpv(sv, my_strerror(errno)); - if (SvOK(sv)) { - fixup_errno_string(sv); - } + if (!SvCUR(sv)) + SvPOK_off(sv); } RESTORE_ERRNO; } @@ -951,7 +1043,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; case '\014': /* ^LAST_FH */ if (strEQ(remaining, "AST_FH")) { - if (PL_last_in_gv) { + if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) { assert(isGV_with_GP(PL_last_in_gv)); SV_CHECK_THINKFIRST_COW_DROP(sv); prepare_SV_for_RV(sv); @@ -960,7 +1052,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) SvROK_on(sv); sv_rvweaken(sv); } - else sv_setsv_nomg(sv, NULL); + else + sv_set_undef(sv); } break; case '\017': /* ^O & ^OPEN */ @@ -1017,14 +1110,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) goto set_undef; } else if (PL_compiling.cop_warnings == pWARN_ALL) { - /* Get the bit mask for $warnings::Bits{all}, because - * it could have been extended by warnings::register */ - HV * const bits = get_hv("warnings::Bits", 0); - SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL; - if (bits_all) - sv_copypv(sv, *bits_all); - else - sv_setpvn(sv, WARN_ALLstring, WARNsize); + sv_setpvn(sv, WARN_ALLstring, WARNsize); } else { sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1), @@ -1656,7 +1742,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) * access to a known hint bit in a known OP, we can't * tell whether HINT_STRICT_REFS is in force or not. */ - if (!strchr(s,':') && !strchr(s,'\'')) + if (!memchr(s, ':', len) && !memchr(s, '\'', len)) Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"), SV_GMAGIC); if (i) @@ -2061,7 +2147,7 @@ Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) if (obj) { sv_setiv(sv, AvFILL(obj)); } else { - sv_setsv(sv, NULL); + sv_set_undef(sv); } return 0; } @@ -2090,12 +2176,12 @@ Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_CONTEXT; /* Reset the iterator when the array is cleared */ -#if IVSIZE == I32SIZE - *((IV *) &(mg->mg_len)) = 0; -#else - if (mg->mg_ptr) - *((IV *) mg->mg_ptr) = 0; -#endif + if (sizeof(IV) == sizeof(SSize_t)) { + *((IV *) &(mg->mg_len)) = 0; + } else { + if (mg->mg_ptr) + *((IV *) mg->mg_ptr) = 0; + } return 0; } @@ -2139,7 +2225,7 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) sv_setuv(sv, i); return 0; } - sv_setsv(sv,NULL); + sv_set_undef(sv); return 0; } @@ -2681,7 +2767,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) FmLINES(PL_bodytarget) = 0; if (SvPOK(PL_bodytarget)) { char *s = SvPVX(PL_bodytarget); - while ( ((s = strchr(s, '\n'))) ) { + char *e = SvEND(PL_bodytarget); + while ( ((s = (char *) memchr(s, '\n', e - s))) ) { FmLINES(PL_bodytarget)++; s++; } @@ -2714,17 +2801,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (*(mg->mg_ptr+1) == '\0') { #ifdef VMS set_vaxc_errno(SvIV(sv)); -#else -# ifdef WIN32 +#elif defined(WIN32) SetLastError( SvIV(sv) ); -# else -# ifdef OS2 +#elif defined(OS2) os2_setsyserrno(SvIV(sv)); -# else +#else /* will anyone ever use this? */ SETERRNO(SvIV(sv), 4); -# endif -# endif #endif } else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv)) @@ -2818,25 +2901,18 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } { STRLEN len, i; - int accumulate = 0 ; - int any_fatals = 0 ; - const char * const ptr = SvPV_const(sv, len) ; + int not_none = 0, not_all = 0; + const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ; for (i = 0 ; i < len ; ++i) { - accumulate |= ptr[i] ; - any_fatals |= (ptr[i] & 0xAA) ; + not_none |= ptr[i]; + not_all |= ptr[i] ^ 0x55; } - if (!accumulate) { + if (!not_none) { if (!specialWARN(PL_compiling.cop_warnings)) 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)) + } else if (len >= WARNsize && !not_all) { + if (!specialWARN(PL_compiling.cop_warnings)) PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = pWARN_ALL; PL_dowarn |= G_WARN_ONCE ; @@ -2994,26 +3070,22 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } #ifdef HAS_SETRUID PERL_UNUSED_RESULT(setruid(new_uid)); -#else -#ifdef HAS_SETREUID +#elif defined(HAS_SETREUID) PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1)); -#else -#ifdef HAS_SETRESUID +#elif defined(HAS_SETRESUID) PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1)); #else if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */ -#ifdef PERL_DARWIN +# ifdef PERL_DARWIN /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */ if (new_uid != 0 && PerlProc_getuid() == 0) PERL_UNUSED_RESULT(PerlProc_setuid(0)); -#endif +# endif PERL_UNUSED_RESULT(PerlProc_setuid(new_uid)); } else { Perl_croak(aTHX_ "setruid() not implemented"); } #endif -#endif -#endif break; } case '>': @@ -3027,11 +3099,9 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } #ifdef HAS_SETEUID PERL_UNUSED_RESULT(seteuid(new_euid)); -#else -#ifdef HAS_SETREUID +#elif defined(HAS_SETREUID) PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid)); -#else -#ifdef HAS_SETRESUID +#elif defined(HAS_SETRESUID) PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1)); #else if (new_euid == PerlProc_getuid()) /* special case $> = $< */ @@ -3040,8 +3110,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "seteuid() not implemented"); } #endif -#endif -#endif break; } case '(': @@ -3055,11 +3123,9 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } #ifdef HAS_SETRGID PERL_UNUSED_RESULT(setrgid(new_gid)); -#else -#ifdef HAS_SETREGID +#elif defined(HAS_SETREGID) PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1)); -#else -#ifdef HAS_SETRESGID +#elif defined(HAS_SETRESGID) PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1)); #else if (new_gid == PerlProc_getegid()) /* special case $( = $) */ @@ -3068,8 +3134,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "setrgid() not implemented"); } #endif -#endif -#endif break; } case ')': @@ -3138,11 +3202,9 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } #ifdef HAS_SETEGID PERL_UNUSED_RESULT(setegid(new_egid)); -#else -#ifdef HAS_SETREGID +#elif defined(HAS_SETREGID) PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid)); -#else -#ifdef HAS_SETRESGID +#elif defined(HAS_SETRESGID) PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1)); #else if (new_egid == PerlProc_getgid()) /* special case $) = $( */ @@ -3151,8 +3213,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "setegid() not implemented"); } #endif -#endif -#endif break; } case ':':