X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/710891042a142a482afd4eed1f3b1feb27a9c504..e8b231c6829a16740f05a666243bfc33e1ac1514:/util.c diff --git a/util.c b/util.c index 5bfe354..20429f7 100644 --- a/util.c +++ b/util.c @@ -1087,6 +1087,25 @@ Perl_savesvpv(pTHX_ SV *sv) return (char *) CopyD(pv,newaddr,len,char); } +/* +=for apidoc savesharedsvpv + +A version of C which allocates the duplicate string in +memory which is shared between threads. + +=cut +*/ + +char * +Perl_savesharedsvpv(pTHX_ SV *sv) +{ + STRLEN len; + const char * const pv = SvPV_const(sv, len); + + PERL_ARGS_ASSERT_SAVESHAREDSVPV; + + return savesharedpvn(pv, len); +} /* the SV for Perl_form() and mess() is not kept in an arena */ @@ -1399,10 +1418,8 @@ Perl_write_to_stderr(pTHX_ SV* msv) dSAVED_ERRNO; #endif PerlIO * const serr = Perl_error_log; - STRLEN msglen; - const char* message = SvPVx_const(msv, msglen); - PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); + do_print(msv, serr); (void)PerlIO_flush(serr); #ifdef USE_SFIO RESTORE_ERRNO; @@ -3828,7 +3845,8 @@ Perl_my_fflush_all(pTHX) void Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op) { - const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL; + const char * const name + = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL; if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) { if (ckWARN(WARN_IO)) { @@ -3935,18 +3953,28 @@ Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning) return result; } -char * -Perl_grok_bslash_o(pTHX_ const char *s, UV *uv, STRLEN *len, const bool output_warning) +bool +Perl_grok_bslash_o(pTHX_ const char *s, + UV *uv, + STRLEN *len, + const char** error_msg, + const bool output_warning) { /* Documentation to be supplied when interface nailed down finally - * This returns NULL on success, otherwise a pointer to an internal constant - * error message. On input: - * s points to a string that begins with o, and the previous character was - * a backslash. - * uv points to a UV that will hold the output value - * len will point to the next character in the string past the end of this - * construct + * This returns FALSE if there is an error which the caller need not recover + * from; , otherwise TRUE. In either case the caller should look at *len + * On input: + * s points to a string that begins with 'o', and the previous character + * was a backslash. + * uv points to a UV that will hold the output value, valid only if the + * return from the function is TRUE + * len on success will point to the next character in the string past the + * end of this construct. + * on failure, it will point to the failure + * error_msg is a pointer that will be set to an internal buffer giving an + * error message upon failure (the return is FALSE). Untouched if + * function succeeds * output_warning says whether to output any warning messages, or suppress * them */ @@ -3966,13 +3994,15 @@ Perl_grok_bslash_o(pTHX_ const char *s, UV *uv, STRLEN *len, const bool output_w if (*s != '{') { *len = 1; /* Move past the o */ - return "Missing braces on \\o{}"; + *error_msg = "Missing braces on \\o{}"; + return FALSE; } e = strchr(s, '}'); if (!e) { *len = 2; /* Move past the o{ */ - return "Missing right brace on \\o{"; + *error_msg = "Missing right brace on \\o{"; + return FALSE; } /* Return past the '}' no matter what is inside the braces */ @@ -3982,7 +4012,8 @@ Perl_grok_bslash_o(pTHX_ const char *s, UV *uv, STRLEN *len, const bool output_w numbers_len = e - s; if (numbers_len == 0) { - return "Number with no digits"; + *error_msg = "Number with no digits"; + return FALSE; } *uv = NATIVE_TO_UNI(grok_oct(s, &numbers_len, &flags, NULL)); @@ -3998,7 +4029,7 @@ Perl_grok_bslash_o(pTHX_ const char *s, UV *uv, STRLEN *len, const bool output_w s); } - return NULL; + return TRUE; } /* To workaround core dumps from the uninitialised tm_zone we get the @@ -5077,27 +5108,30 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) /* =for apidoc vverify -Validates that the SV contains a valid version object. +Validates that the SV contains valid internal structure for a version object. +It may be passed either the version object (RV) or the hash itself (HV). If +the structure is valid, it returns the HV. If the structure is invalid, +it returns NULL. - bool vverify(SV *vobj); + SV *hv = vverify(sv); Note that it only confirms the bare minimum structure (so as not to get confused by derived classes which may contain additional hash entries): =over 4 -=item * The SV contains a [reference to a] hash +=item * The SV is an HV or a reference to an HV =item * The hash contains a "version" key -=item * The "version" key has [a reference to] an AV as its value +=item * The "version" key has a reference to an AV as its value =back =cut */ -bool +SV * Perl_vverify(pTHX_ SV *vs) { SV *sv; @@ -5112,9 +5146,9 @@ Perl_vverify(pTHX_ SV *vs) && hv_exists(MUTABLE_HV(vs), "version", 7) && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) && SvTYPE(sv) == SVt_PVAV ) - return TRUE; + return vs; else - return FALSE; + return NULL; } /* @@ -5142,10 +5176,9 @@ Perl_vnumify(pTHX_ SV *vs) PERL_ARGS_ASSERT_VNUMIFY; - if ( SvROK(vs) ) - vs = SvRV(vs); - - if ( !vverify(vs) ) + /* extract the HV from the object */ + vs = vverify(vs); + if ( ! vs ) Perl_croak(aTHX_ "Invalid version object"); /* see if various flags exist */ @@ -5221,10 +5254,9 @@ Perl_vnormal(pTHX_ SV *vs) PERL_ARGS_ASSERT_VNORMAL; - if ( SvROK(vs) ) - vs = SvRV(vs); - - if ( !vverify(vs) ) + /* extract the HV from the object */ + vs = vverify(vs); + if ( ! vs ) Perl_croak(aTHX_ "Invalid version object"); if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) @@ -5276,10 +5308,9 @@ Perl_vstringify(pTHX_ SV *vs) { PERL_ARGS_ASSERT_VSTRINGIFY; - if ( SvROK(vs) ) - vs = SvRV(vs); - - if ( !vverify(vs) ) + /* extract the HV from the object */ + vs = vverify(vs); + if ( ! vs ) Perl_croak(aTHX_ "Invalid version object"); if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) { @@ -5319,15 +5350,10 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) PERL_ARGS_ASSERT_VCMP; - if ( SvROK(lhv) ) - lhv = SvRV(lhv); - if ( SvROK(rhv) ) - rhv = SvRV(rhv); - - if ( !vverify(lhv) ) - Perl_croak(aTHX_ "Invalid version object"); - - if ( !vverify(rhv) ) + /* extract the HVs from the objects */ + lhv = vverify(lhv); + rhv = vverify(rhv); + if ( ! ( lhv && rhv ) ) Perl_croak(aTHX_ "Invalid version object"); /* get the left hand term */ @@ -5707,8 +5733,11 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) opt = (U32) atoi(p); while (isDIGIT(*p)) p++; - if (*p && *p != '\n' && *p != '\r') + if (*p && *p != '\n' && *p != '\r') { + if(isSPACE(*p)) goto the_end_of_the_opts_parser; + else Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); + } } else { for (; *p; p++) { @@ -5734,9 +5763,12 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) case PERL_UNICODE_UTF8CACHEASSERT: opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break; default: - if (*p != '\n' && *p != '\r') + if (*p != '\n' && *p != '\r') { + if(isSPACE(*p)) goto the_end_of_the_opts_parser; + else Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); + } } } } @@ -5744,6 +5776,8 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) else opt = PERL_UNICODE_DEFAULT_FLAGS; + the_end_of_the_opts_parser: + if (opt & ~PERL_UNICODE_ALL_FLAGS) Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf, (UV) (opt & ~PERL_UNICODE_ALL_FLAGS)); @@ -6432,6 +6466,84 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ #endif /* PERL_IMPLICIT_CONTEXT */ +void +Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, + STRLEN xs_len) +{ + SV *sv; + const char *vn = NULL; + SV *const module = PL_stack_base[ax]; + + PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK; + + if (items >= 2) /* version supplied as bootstrap arg */ + sv = PL_stack_base[ax + 1]; + else { + /* XXX GV_ADDWARN */ + vn = "XS_VERSION"; + sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0); + if (!sv || !SvOK(sv)) { + vn = "VERSION"; + sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0); + } + } + if (sv) { + SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP); + SV *pmsv = sv_derived_from(sv, "version") + ? sv : sv_2mortal(new_version(sv)); + xssv = upg_version(xssv, 0); + if ( vcmp(pmsv,xssv) ) { + SV *string = vstringify(xssv); + SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf + " does not match ", module, string); + + SvREFCNT_dec(string); + string = vstringify(pmsv); + + if (vn) { + Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn, + string); + } else { + Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string); + } + SvREFCNT_dec(string); + + Perl_sv_2mortal(aTHX_ xpt); + Perl_croak_sv(aTHX_ xpt); + } + } +} + +void +Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p, + STRLEN api_len) +{ + SV *xpt = NULL; + SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP); + SV *runver; + + PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK; + + /* This might croak */ + compver = upg_version(compver, 0); + /* This should never croak */ + runver = new_version(PL_apiversion); + if (vcmp(compver, runver)) { + SV *compver_string = vstringify(compver); + SV *runver_string = vstringify(runver); + xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf + " of %"SVf" does not match %"SVf, + compver_string, module, runver_string); + Perl_sv_2mortal(aTHX_ xpt); + + SvREFCNT_dec(compver_string); + SvREFCNT_dec(runver_string); + } + SvREFCNT_dec(runver); + if (xpt) + Perl_croak_sv(aTHX_ xpt); +} + #ifndef HAS_STRLCAT Size_t Perl_my_strlcat(char *dst, const char *src, Size_t size) @@ -6476,21 +6588,28 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) { dVAR; SV * const dbsv = GvSVn(PL_DBsub); + const bool save_taint = PL_tainted; + /* We do not care about using sv to call CV; * it's for informational purposes only. */ PERL_ARGS_ASSERT_GET_DB_SUB; + PL_tainted = FALSE; save_item(dbsv); if (!PERLDB_SUB_NN) { - GV * const gv = CvGV(cv); + GV *gv = CvGV(cv); if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || strEQ(GvNAME(gv), "END") || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ !( (SvTYPE(*svp) == SVt_PVGV) - && (GvCV((const GV *)*svp) == cv) )))) { + && (GvCV((const GV *)*svp) == cv) + && (gv = (GV *)*svp) + ) + ) + )) { /* Use GV from the stack as a fallback. */ /* GV is potentially non-unique, or contain different CV. */ SV * const tmp = newRV(MUTABLE_SV(cv)); @@ -6508,6 +6627,7 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) (void)SvIOK_on(dbsv); SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */ } + TAINT_IF(save_taint); } int