X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4e4da3acc11d96d134ed1dc0effd641e7bedb0ca..e8b231c6829a16740f05a666243bfc33e1ac1514:/util.c diff --git a/util.c b/util.c index 5e7a24e..20429f7 100644 --- a/util.c +++ b/util.c @@ -70,12 +70,18 @@ S_write_no_mem(pTHX) NORETURN_FUNCTION_END; } +#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL) +# define ALWAYS_NEED_THX +#endif + /* paranoid version of system's malloc() */ Malloc_t Perl_safesysmalloc(MEM_SIZE size) { +#ifdef ALWAYS_NEED_THX dTHX; +#endif Malloc_t ptr; #ifdef HAS_64K_LIMIT if (size > 0xffff) { @@ -118,10 +124,15 @@ Perl_safesysmalloc(MEM_SIZE size) #endif return ptr; } - else if (PL_nomemok) - return NULL; else { - return write_no_mem(); +#ifndef ALWAYS_NEED_THX + dTHX; +#endif + if (PL_nomemok) + return NULL; + else { + return write_no_mem(); + } } /*NOTREACHED*/ } @@ -131,7 +142,9 @@ Perl_safesysmalloc(MEM_SIZE size) Malloc_t Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) { +#ifdef ALWAYS_NEED_THX dTHX; +#endif Malloc_t ptr; #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO) Malloc_t PerlMem_realloc(); @@ -213,10 +226,15 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) if (ptr != NULL) { return ptr; } - else if (PL_nomemok) - return NULL; else { - return write_no_mem(); +#ifndef ALWAYS_NEED_THX + dTHX; +#endif + if (PL_nomemok) + return NULL; + else { + return write_no_mem(); + } } /*NOTREACHED*/ } @@ -226,7 +244,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) Free_t Perl_safesysfree(Malloc_t where) { -#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL) +#ifdef ALWAYS_NEED_THX dTHX; #else dVAR; @@ -268,7 +286,9 @@ Perl_safesysfree(Malloc_t where) Malloc_t Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) { +#ifdef ALWAYS_NEED_THX dTHX; +#endif Malloc_t ptr; MEM_SIZE total_size = 0; @@ -330,9 +350,14 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) #endif return ptr; } - else if (PL_nomemok) - return NULL; - return write_no_mem(); + else { +#ifndef ALWAYS_NEED_THX + dTHX; +#endif + if (PL_nomemok) + return NULL; + return write_no_mem(); + } } /* These must be defined when not using Perl's malloc for binary @@ -878,37 +903,58 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift return NULL; } +/* +=for apidoc foldEQ + +Returns true if the leading len bytes of the strings s1 and s2 are the same +case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes +match themselves and their opposite case counterparts. Non-cased and non-ASCII +range bytes match only themselves. + +=cut +*/ + + I32 -Perl_ibcmp(const char *s1, const char *s2, register I32 len) +Perl_foldEQ(const char *s1, const char *s2, register I32 len) { register const U8 *a = (const U8 *)s1; register const U8 *b = (const U8 *)s2; - PERL_ARGS_ASSERT_IBCMP; + PERL_ARGS_ASSERT_FOLDEQ; while (len--) { if (*a != *b && *a != PL_fold[*b]) - return 1; + return 0; a++,b++; } - return 0; + return 1; } +/* +=for apidoc foldEQ_locale + +Returns true if the leading len bytes of the strings s1 and s2 are the same +case-insensitively in the current locale; false otherwise. + +=cut +*/ + I32 -Perl_ibcmp_locale(const char *s1, const char *s2, register I32 len) +Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len) { dVAR; register const U8 *a = (const U8 *)s1; register const U8 *b = (const U8 *)s2; - PERL_ARGS_ASSERT_IBCMP_LOCALE; + PERL_ARGS_ASSERT_FOLDEQ_LOCALE; while (len--) { if (*a != *b && *a != PL_fold_locale[*b]) - return 1; + return 0; a++,b++; } - return 0; + return 1; } /* copy a string to a safe spot */ @@ -1041,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 */ @@ -1353,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; @@ -1592,6 +1655,22 @@ Perl_croak(pTHX_ const char *pat, ...) } /* +=for apidoc Am|void|croak_no_modify + +Exactly equivalent to C, but generates +terser object code than using C. Less code used on exception code +paths reduces CPU cache pressure. + +=cut +*/ + +void +Perl_croak_no_modify(pTHX) +{ + Perl_croak(aTHX_ "%s", PL_no_modify); +} + +/* =for apidoc Am|void|warn_sv|SV *baseex This is an XS interface to Perl's C function. @@ -3766,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)) { @@ -3842,7 +3922,7 @@ Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op) char Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning) { - + U8 result; if (! isASCII(source)) { @@ -3855,16 +3935,103 @@ Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning) Perl_croak(aTHX_ "It is proposed that \"\\c{\" no longer be valid. It has historically evaluated to\n \";\". If you disagree with this proposal, send email to perl5-porters@perl.org\nOtherwise, or in the meantime, you can work around this failure by changing\n\"\\c{\" to \";\""); } else if (output_warning) { + U8 clearer[3]; + U8 i = 0; + if (! isALNUM(result)) { + clearer[i++] = '\\'; + } + clearer[i++] = result; + clearer[i++] = '\0'; + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "\"\\c%c\" more clearly written simply as \"%c\"", + "\"\\c%c\" more clearly written simply as \"%s\"", source, - result); + clearer); } } return result; } +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 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 + */ + const char* e; + STRLEN numbers_len; + I32 flags = PERL_SCAN_ALLOW_UNDERSCORES + | PERL_SCAN_DISALLOW_PREFIX + /* XXX Until the message is improved in grok_oct, handle errors + * ourselves */ + | PERL_SCAN_SILENT_ILLDIGIT; + + PERL_ARGS_ASSERT_GROK_BSLASH_O; + + + assert(*s == 'o'); + s++; + + if (*s != '{') { + *len = 1; /* Move past the o */ + *error_msg = "Missing braces on \\o{}"; + return FALSE; + } + + e = strchr(s, '}'); + if (!e) { + *len = 2; /* Move past the o{ */ + *error_msg = "Missing right brace on \\o{"; + return FALSE; + } + + /* Return past the '}' no matter what is inside the braces */ + *len = e - s + 2; /* 2 = 1 for the o + 1 for the '}' */ + + s++; /* Point to first digit */ + + numbers_len = e - s; + if (numbers_len == 0) { + *error_msg = "Number with no digits"; + return FALSE; + } + + *uv = NATIVE_TO_UNI(grok_oct(s, &numbers_len, &flags, NULL)); + /* Note that if has non-octal, will ignore everything starting with that up + * to the '}' */ + + if (output_warning && numbers_len != (STRLEN) (e - s)) { + Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT), + /* diag_listed_as: Non-octal character '%c'. Resolved as "%s" */ + "Non-octal character '%c'. Resolved as \"\\o{%.*s}\"", + *(s + numbers_len), + (int) numbers_len, + s); + } + + return TRUE; +} + /* To workaround core dumps from the uninitialised tm_zone we get the * system to give us a reasonable struct to copy. This fix means that * strftime uses the tm_zone and tm_gmtoff values returned by @@ -4164,7 +4331,7 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in const int fmtlen = strlen(fmt); int bufsize = fmtlen + buflen; - Newx(buf, bufsize, char); + Renew(buf, bufsize, char); while (buf) { buflen = strftime(buf, bufsize, fmt, &mytm); if (buflen > 0 && buflen < bufsize) @@ -4941,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; @@ -4976,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; } /* @@ -5006,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 */ @@ -5085,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 ) ) @@ -5140,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)) { @@ -5183,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 */ @@ -5571,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++) { @@ -5598,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); + } } } } @@ -5608,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)); @@ -6296,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) @@ -6340,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)); @@ -6372,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