X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/df052ff84a4fc5e49545a6877ffa22ba4d4e31db..50a9fad1a8ce99fe48223ca407d09d01f8c4bef6:/util.c diff --git a/util.c b/util.c index 50675d3..652e868 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 */ @@ -1124,6 +1170,21 @@ Perl_vform(pTHX_ const char *pat, va_list *args) return SvPVX(sv); } +/* +=for apidoc Am|SV *|mess|const char *pat|... + +Take a sprintf-style format pattern and argument list. These are used to +generate a string message. If the message does not end with a newline, +then it will be extended with some indication of the current location +in the code, as described for L. + +Normally, the resulting message is returned in a new mortal SV. +During global destruction a single SV may be shared between uses of +this function. + +=cut +*/ + #if defined(PERL_IMPLICIT_CONTEXT) SV * Perl_mess_nocontext(const char *pat, ...) @@ -1186,15 +1247,57 @@ S_closest_cop(pTHX_ const COP *cop, const OP *o) return NULL; } +/* +=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume + +Expands a message, intended for the user, to include an indication of +the current location in the code, if the message does not already appear +to be complete. + +C is the initial message or object. If it is a reference, it +will be used as-is and will be the result of this function. Otherwise it +is used as a string, and if it already ends with a newline, it is taken +to be complete, and the result of this function will be the same string. +If the message does not end with a newline, then a segment such as C will be appended, and possibly other clauses indicating +the current state of execution. The resulting message will end with a +dot and a newline. + +Normally, the resulting message is returned in a new mortal SV. +During global destruction a single SV may be shared between uses of this +function. If C is true, then the function is permitted (but not +required) to modify and return C instead of allocating a new SV. + +=cut +*/ + SV * -Perl_vmess(pTHX_ const char *pat, va_list *args) +Perl_mess_sv(pTHX_ SV *basemsg, bool consume) { dVAR; - SV * const sv = mess_alloc(); + SV *sv; - PERL_ARGS_ASSERT_VMESS; + PERL_ARGS_ASSERT_MESS_SV; + + if (SvROK(basemsg)) { + if (consume) { + sv = basemsg; + } + else { + sv = mess_alloc(); + sv_setsv(sv, basemsg); + } + return sv; + } + + if (SvPOK(basemsg) && consume) { + sv = basemsg; + } + else { + sv = mess_alloc(); + sv_copypv(sv, basemsg); + } - sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { /* * Try and find the file and line for PL_op. This will usually be @@ -1228,8 +1331,36 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) return sv; } +/* +=for apidoc Am|SV *|vmess|const char *pat|va_list *args + +C and C are a sprintf-style format pattern and encapsulated +argument list. These are used to generate a string message. If the +message does not end with a newline, then it will be extended with +some indication of the current location in the code, as described for +L. + +Normally, the resulting message is returned in a new mortal SV. +During global destruction a single SV may be shared between uses of +this function. + +=cut +*/ + +SV * +Perl_vmess(pTHX_ const char *pat, va_list *args) +{ + dVAR; + SV * const sv = mess_alloc(); + + PERL_ARGS_ASSERT_VMESS; + + sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); + return mess_sv(sv, 1); +} + void -Perl_write_to_stderr(pTHX_ const char* message, int msglen) +Perl_write_to_stderr(pTHX_ SV* msv) { dVAR; IO *io; @@ -1254,7 +1385,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) PUSHMARK(SP); EXTEND(SP,2); PUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); - mPUSHp(message, msglen); + PUSHs(msv); PUTBACK; call_method("PRINT", G_SCALAR); @@ -1268,6 +1399,8 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) 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); (void)PerlIO_flush(serr); @@ -1277,10 +1410,26 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) } } -/* Common code used by vcroak, vdie, vwarn and vwarner */ +/* +=head1 Warning and Dieing +*/ + +/* Common code used in dieing and warning */ + +STATIC SV * +S_with_queued_errors(pTHX_ SV *ex) +{ + PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS; + if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) { + sv_catsv(PL_errors, ex); + ex = sv_mortalcopy(PL_errors); + SvCUR_set(PL_errors, 0); + } + return ex; +} STATIC bool -S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) +S_invoke_exception_hook(pTHX_ SV *ex, bool warn) { dVAR; HV *stash; @@ -1290,7 +1439,8 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) /* sv_2cv might call Perl_croak() or Perl_warner() */ SV * const oldhook = *hook; - assert(oldhook); + if (!oldhook) + return FALSE; ENTER; SAVESPTR(*hook); @@ -1299,7 +1449,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) LEAVE; if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; - SV *msg; + SV *exarg; ENTER; save_re_context(); @@ -1307,18 +1457,13 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) SAVESPTR(*hook); *hook = NULL; } - if (warn || message) { - msg = newSVpvn_flags(message, msglen, utf8); - SvREADONLY_on(msg); - SAVEFREESV(msg); - } - else { - msg = ERRSV; - } + exarg = newSVsv(ex); + SvREADONLY_on(exarg); + SAVEFREESV(exarg); PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK); PUSHMARK(SP); - XPUSHs(msg); + XPUSHs(exarg); PUTBACK; call_sv(MUTABLE_SV(cv), G_DISCARD); POPSTACK; @@ -1328,98 +1473,146 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) return FALSE; } -STATIC const char * -S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, - I32* utf8) -{ - dVAR; - const char *message; +/* +=for apidoc Am|OP *|die_sv|SV *baseex - if (pat) { - SV * const msv = vmess(pat, args); - if (PL_errors && SvCUR(PL_errors)) { - sv_catsv(PL_errors, msv); - message = SvPV_const(PL_errors, *msglen); - SvCUR_set(PL_errors, 0); - } - else - message = SvPV_const(msv,*msglen); - *utf8 = SvUTF8(msv); - } - else { - message = NULL; - } +Behaves the same as L, except for the return type. +It should be used only where the C return type is required. +The function never actually returns. - if (PL_diehook) { - S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE); - } - return message; -} +=cut +*/ -static OP * -S_vdie(pTHX_ const char* pat, va_list *args) +OP * +Perl_die_sv(pTHX_ SV *baseex) { - dVAR; - const char *message; - const int was_in_eval = PL_in_eval; - STRLEN msglen; - I32 utf8 = 0; + PERL_ARGS_ASSERT_DIE_SV; + croak_sv(baseex); + /* NOTREACHED */ + return NULL; +} - message = vdie_croak_common(pat, args, &msglen, &utf8); +/* +=for apidoc Am|OP *|die|const char *pat|... - PL_restartop = die_where(message, msglen); - SvFLAGS(ERRSV) |= utf8; - if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev) - JMPENV_JUMP(3); - return PL_restartop; -} +Behaves the same as L, except for the return type. +It should be used only where the C return type is required. +The function never actually returns. + +=cut +*/ #if defined(PERL_IMPLICIT_CONTEXT) OP * Perl_die_nocontext(const char* pat, ...) { dTHX; - OP *o; va_list args; va_start(args, pat); - o = vdie(pat, &args); + vcroak(pat, &args); + /* NOTREACHED */ va_end(args); - return o; + return NULL; } #endif /* PERL_IMPLICIT_CONTEXT */ OP * Perl_die(pTHX_ const char* pat, ...) { - OP *o; va_list args; va_start(args, pat); - o = vdie(pat, &args); + vcroak(pat, &args); + /* NOTREACHED */ va_end(args); - return o; + return NULL; +} + +/* +=for apidoc Am|void|croak_sv|SV *baseex + +This is an XS interface to Perl's C function. + +C is the error message or object. If it is a reference, it +will be used as-is. Otherwise it is used as a string, and if it does +not end with a newline then it will be extended with some indication of +the current location in the code, as described for L. + +The error message or object will be used as an exception, by default +returning control to the nearest enclosing C, but subject to +modification by a C<$SIG{__DIE__}> handler. In any case, the C +function never returns normally. + +To die with a simple string message, the L function may be +more convenient. + +=cut +*/ + +void +Perl_croak_sv(pTHX_ SV *baseex) +{ + SV *ex = with_queued_errors(mess_sv(baseex, 0)); + PERL_ARGS_ASSERT_CROAK_SV; + invoke_exception_hook(ex, FALSE); + die_unwind(ex); } +/* +=for apidoc Am|void|vcroak|const char *pat|va_list *args + +This is an XS interface to Perl's C function. + +C and C are a sprintf-style format pattern and encapsulated +argument list. These are used to generate a string message. If the +message does not end with a newline, then it will be extended with +some indication of the current location in the code, as described for +L. + +The error message will be used as an exception, by default +returning control to the nearest enclosing C, but subject to +modification by a C<$SIG{__DIE__}> handler. In any case, the C +function never returns normally. + +For historical reasons, if C is null then the contents of C +(C<$@>) will be used as an error message or object instead of building an +error message from arguments. If you want to throw a non-string object, +or build an error message in an SV yourself, it is preferable to use +the L function, which does not involve clobbering C. + +=cut +*/ + void Perl_vcroak(pTHX_ const char* pat, va_list *args) { - dVAR; - const char *message; - STRLEN msglen; - I32 utf8 = 0; + SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0)); + invoke_exception_hook(ex, FALSE); + die_unwind(ex); +} + +/* +=for apidoc Am|void|croak|const char *pat|... - message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); +This is an XS interface to Perl's C function. - if (PL_in_eval) { - PL_restartop = die_where(message, msglen); - SvFLAGS(ERRSV) |= utf8; - JMPENV_JUMP(3); - } - else if (!message) - message = SvPVx_const(ERRSV, msglen); +Take a sprintf-style format pattern and argument list. These are used to +generate a string message. If the message does not end with a newline, +then it will be extended with some indication of the current location +in the code, as described for L. - write_to_stderr(message, msglen); - my_failure_exit(); -} +The error message will be used as an exception, by default +returning control to the nearest enclosing C, but subject to +modification by a C<$SIG{__DIE__}> handler. In any case, the C +function never returns normally. + +For historical reasons, if C is null then the contents of C +(C<$@>) will be used as an error message or object instead of building an +error message from arguments. If you want to throw a non-string object, +or build an error message in an SV yourself, it is preferable to use +the L function, which does not involve clobbering C. + +=cut +*/ #if defined(PERL_IMPLICIT_CONTEXT) void @@ -1434,54 +1627,105 @@ Perl_croak_nocontext(const char *pat, ...) } #endif /* PERL_IMPLICIT_CONTEXT */ +void +Perl_croak(pTHX_ const char *pat, ...) +{ + va_list args; + va_start(args, pat); + vcroak(pat, &args); + /* NOTREACHED */ + va_end(args); +} + /* -=head1 Warning and Dieing +=for apidoc Am|void|croak_no_modify -=for apidoc croak +Exactly equivalent to C, but generates +terser object code than using C. Less code used on exception code +paths reduces CPU cache pressure. -This is the XSUB-writer's interface to Perl's C function. -Normally call this function the same way you call the C C -function. Calling C returns control directly to Perl, -sidestepping the normal C order of execution. See C. +=cut +*/ -If you want to throw an exception object, assign the object to -C<$@> and then pass C to croak(): +void +Perl_croak_no_modify(pTHX) +{ + Perl_croak(aTHX_ "%s", PL_no_modify); +} - errsv = get_sv("@", GV_ADD); - sv_setsv(errsv, exception_object); - croak(NULL); +/* +=for apidoc Am|void|warn_sv|SV *baseex + +This is an XS interface to Perl's C function. + +C is the error message or object. If it is a reference, it +will be used as-is. Otherwise it is used as a string, and if it does +not end with a newline then it will be extended with some indication of +the current location in the code, as described for L. + +The error message or object will by default be written to standard error, +but this is subject to modification by a C<$SIG{__WARN__}> handler. + +To warn with a simple string message, the L function may be +more convenient. =cut */ void -Perl_croak(pTHX_ const char *pat, ...) +Perl_warn_sv(pTHX_ SV *baseex) { - va_list args; - va_start(args, pat); - vcroak(pat, &args); - /* NOTREACHED */ - va_end(args); + SV *ex = mess_sv(baseex, 0); + PERL_ARGS_ASSERT_WARN_SV; + if (!invoke_exception_hook(ex, TRUE)) + write_to_stderr(ex); } +/* +=for apidoc Am|void|vwarn|const char *pat|va_list *args + +This is an XS interface to Perl's C function. + +C and C are a sprintf-style format pattern and encapsulated +argument list. These are used to generate a string message. If the +message does not end with a newline, then it will be extended with +some indication of the current location in the code, as described for +L. + +The error message or object will by default be written to standard error, +but this is subject to modification by a C<$SIG{__WARN__}> handler. + +Unlike with L, C is not permitted to be null. + +=cut +*/ + void Perl_vwarn(pTHX_ const char* pat, va_list *args) { - dVAR; - STRLEN msglen; - SV * const msv = vmess(pat, args); - const I32 utf8 = SvUTF8(msv); - const char * const message = SvPV_const(msv, msglen); - + SV *ex = vmess(pat, args); PERL_ARGS_ASSERT_VWARN; + if (!invoke_exception_hook(ex, TRUE)) + write_to_stderr(ex); +} - if (PL_warnhook) { - if (vdie_common(message, msglen, utf8, TRUE)) - return; - } +/* +=for apidoc Am|void|warn|const char *pat|... - write_to_stderr(message, msglen); -} +This is an XS interface to Perl's C function. + +Take a sprintf-style format pattern and argument list. These are used to +generate a string message. If the message does not end with a newline, +then it will be extended with some indication of the current location +in the code, as described for L. + +The error message or object will by default be written to standard error, +but this is subject to modification by a C<$SIG{__WARN__}> handler. + +Unlike with L, C is not permitted to be null. + +=cut +*/ #if defined(PERL_IMPLICIT_CONTEXT) void @@ -1496,15 +1740,6 @@ Perl_warn_nocontext(const char *pat, ...) } #endif /* PERL_IMPLICIT_CONTEXT */ -/* -=for apidoc warn - -This is the XSUB-writer's interface to Perl's C function. Call this -function the same way you call the C C function. See C. - -=cut -*/ - void Perl_warn(pTHX_ const char *pat, ...) { @@ -1571,21 +1806,9 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) PERL_ARGS_ASSERT_VWARNER; if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) { SV * const msv = vmess(pat, args); - STRLEN msglen; - const char * const message = SvPV_const(msv, msglen); - const I32 utf8 = SvUTF8(msv); - if (PL_diehook) { - assert(message); - S_vdie_common(aTHX_ message, msglen, utf8, FALSE); - } - if (PL_in_eval) { - PL_restartop = die_where(message, msglen); - SvFLAGS(ERRSV) |= utf8; - JMPENV_JUMP(3); - } - write_to_stderr(message, msglen); - my_failure_exit(); + invoke_exception_hook(msv, FALSE); + die_unwind(msv); } else { Perl_vwarn(aTHX_ pat, args); @@ -3671,45 +3894,46 @@ Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op) } } -#ifdef EBCDIC -/* in ASCII order, not that it matters */ -static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"; +/* XXX Add documentation after final interface and behavior is decided */ +/* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning) + U8 source = *current; -int -Perl_ebcdic_control(pTHX_ int ch) + May want to add eg, WARN_REGEX +*/ + +char +Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning) { - if (ch > 'a') { - const char *ctlp; + + U8 result; - if (islower(ch)) - ch = toupper(ch); + if (! isASCII(source)) { + Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII"); + } - if ((ctlp = strchr(controllablechars, ch)) == 0) { - Perl_die(aTHX_ "unrecognised control character '%c'\n", ch); + result = toCTRL(source); + if (! isCNTRL(result)) { + if (source == '{') { + 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'; - if (ctlp == controllablechars) - return('\177'); /* DEL */ - else - return((unsigned char)(ctlp - controllablechars - 1)); - } else { /* Want uncontrol */ - if (ch == '\177' || ch == -1) - return('?'); - else if (ch == '\157') - return('\177'); - else if (ch == '\174') - return('\000'); - else if (ch == '^') /* '\137' in 1047, '\260' in 819 */ - return('\036'); - else if (ch == '\155') - return('\037'); - else if (0 < ch && ch < (sizeof(controllablechars) - 1)) - return(controllablechars[ch+1]); - else - Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "\"\\c%c\" more clearly written simply as \"%s\"", + source, + clearer); + } } + + return result; } -#endif /* 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 @@ -4209,6 +4433,210 @@ Perl_getcwd_sv(pTHX_ register SV *sv) } #define VERSION_MAX 0x7FFFFFFF + +/* +=for apidoc prescan_version + +=cut +*/ +const char * +Perl_prescan_version(pTHX_ const char *s, bool strict, + const char **errstr, + bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) { + bool qv = (sqv ? *sqv : FALSE); + int width = 3; + int saw_decimal = 0; + bool alpha = FALSE; + const char *d = s; + + PERL_ARGS_ASSERT_PRESCAN_VERSION; + + if (qv && isDIGIT(*d)) + goto dotted_decimal_version; + + if (*d == 'v') { /* explicit v-string */ + d++; + if (isDIGIT(*d)) { + qv = TRUE; + } + else { /* degenerate v-string */ + /* requires v1.2.3 */ + BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + +dotted_decimal_version: + if (strict && d[0] == '0' && isDIGIT(d[1])) { + /* no leading zeros allowed */ + BADVERSION(s,errstr,"Invalid version format (no leading zeros)"); + } + + while (isDIGIT(*d)) /* integer part */ + d++; + + if (*d == '.') + { + saw_decimal++; + d++; /* decimal point */ + } + else + { + if (strict) { + /* require v1.2.3 */ + BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + else { + goto version_prescan_finish; + } + } + + { + int i = 0; + int j = 0; + while (isDIGIT(*d)) { /* just keep reading */ + i++; + while (isDIGIT(*d)) { + d++; j++; + /* maximum 3 digits between decimal */ + if (strict && j > 3) { + BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)"); + } + } + if (*d == '_') { + if (strict) { + BADVERSION(s,errstr,"Invalid version format (no underscores)"); + } + if ( alpha ) { + BADVERSION(s,errstr,"Invalid version format (multiple underscores)"); + } + d++; + alpha = TRUE; + } + else if (*d == '.') { + if (alpha) { + BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); + } + saw_decimal++; + d++; + } + else if (!isDIGIT(*d)) { + break; + } + j = 0; + } + + if (strict && i < 2) { + /* requires v1.2.3 */ + BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + } + } /* end if dotted-decimal */ + else + { /* decimal versions */ + /* special strict case for leading '.' or '0' */ + if (strict) { + if (*d == '.') { + BADVERSION(s,errstr,"Invalid version format (0 before decimal required)"); + } + if (*d == '0' && isDIGIT(d[1])) { + BADVERSION(s,errstr,"Invalid version format (no leading zeros)"); + } + } + + /* consume all of the integer part */ + while (isDIGIT(*d)) + d++; + + /* look for a fractional part */ + if (*d == '.') { + /* we found it, so consume it */ + saw_decimal++; + d++; + } + else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') { + if ( d == s ) { + /* found nothing */ + BADVERSION(s,errstr,"Invalid version format (version required)"); + } + /* found just an integer */ + goto version_prescan_finish; + } + else if ( d == s ) { + /* didn't find either integer or period */ + BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); + } + else if (*d == '_') { + /* underscore can't come after integer part */ + if (strict) { + BADVERSION(s,errstr,"Invalid version format (no underscores)"); + } + else if (isDIGIT(d[1])) { + BADVERSION(s,errstr,"Invalid version format (alpha without decimal)"); + } + else { + BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); + } + } + else { + /* anything else after integer part is just invalid data */ + BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); + } + + /* scan the fractional part after the decimal point*/ + + if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) { + /* strict or lax-but-not-the-end */ + BADVERSION(s,errstr,"Invalid version format (fractional part required)"); + } + + while (isDIGIT(*d)) { + d++; + if (*d == '.' && isDIGIT(d[-1])) { + if (alpha) { + BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); + } + if (strict) { + BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); + } + d = (char *)s; /* start all over again */ + qv = TRUE; + goto dotted_decimal_version; + } + if (*d == '_') { + if (strict) { + BADVERSION(s,errstr,"Invalid version format (no underscores)"); + } + if ( alpha ) { + BADVERSION(s,errstr,"Invalid version format (multiple underscores)"); + } + if ( ! isDIGIT(d[1]) ) { + BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); + } + d++; + alpha = TRUE; + } + } + } + +version_prescan_finish: + while (isSPACE(*d)) + d++; + + if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) { + /* trailing non-numeric data */ + BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); + } + + if (sqv) + *sqv = qv; + if (swidth) + *swidth = width; + if (ssaw_decimal) + *ssaw_decimal = saw_decimal; + if (salpha) + *salpha = alpha; + return d; +} + /* =for apidoc scan_version @@ -4237,9 +4665,10 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) const char *start; const char *pos; const char *last; - int saw_period = 0; - int alpha = 0; + const char *errstr = NULL; + int saw_decimal = 0; int width = 3; + bool alpha = FALSE; bool vinf = FALSE; AV * const av = newAV(); SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ @@ -4248,54 +4677,24 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ +#ifndef NODEFAULT_SHAREKEYS + HvSHAREKEYS_on(hv); /* key-sharing on by default */ +#endif + while (isSPACE(*s)) /* leading whitespace is OK */ s++; - start = last = s; - - if (*s == 'v') { - s++; /* get past 'v' */ - qv = 1; /* force quoted version processing */ - } - - pos = s; - - /* pre-scan the input string to check for decimals/underbars */ - while ( *pos == '.' || *pos == '_' || *pos == ',' || isDIGIT(*pos) ) - { - if ( *pos == '.' ) - { - if ( alpha ) - Perl_croak(aTHX_ "Invalid version format (underscores before decimal)"); - saw_period++ ; - last = pos; - } - else if ( *pos == '_' ) - { - if ( alpha ) - Perl_croak(aTHX_ "Invalid version format (multiple underscores)"); - alpha = 1; - width = pos - last - 1; /* natural width of sub-version */ - } - else if ( *pos == ',' && isDIGIT(pos[1]) ) - { - saw_period++ ; - last = pos; + last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha); + if (errstr) { + /* "undef" is a special case and not an error */ + if ( ! ( *s == 'u' && strEQ(s,"undef")) ) { + Perl_croak(aTHX_ "%s", errstr); } - - pos++; } - if ( alpha && !saw_period ) - Perl_croak(aTHX_ "Invalid version format (alpha without decimal)"); - - if ( alpha && saw_period && width == 0 ) - Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)"); - - if ( saw_period > 1 ) - qv = 1; /* force quoted version processing */ - - last = pos; + start = s; + if (*s == 'v') + s++; pos = s; if ( qv ) @@ -4322,7 +4721,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) * point of a version originally created with a bare * floating point number, i.e. not quoted in any way */ - if ( !qv && s > start && saw_period == 1 ) { + if ( !qv && s > start && saw_decimal == 1 ) { mult *= 100; while ( s < end ) { orev = rev; @@ -4412,7 +4811,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) } else if ( s > start ) { SV * orig = newSVpvn(start,s-start); - if ( qv && saw_period == 1 && *start != 'v' ) { + if ( qv && saw_decimal == 1 && *start != 'v' ) { /* need to insert a v to be consistent */ sv_insert(orig, 0, 0, "v", 1); } @@ -4461,6 +4860,9 @@ Perl_new_version(pTHX_ SV *ver) /* This will get reblessed later if a derived class*/ SV * const hv = newSVrv(rv, "version"); (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ +#ifndef NODEFAULT_SHAREKEYS + HvSHAREKEYS_on(hv); /* key-sharing on by default */ +#endif if ( SvROK(ver) ) ver = SvRV(ver); @@ -4503,7 +4905,7 @@ Perl_new_version(pTHX_ SV *ver) char * const version = savepvn( (const char*)mg->mg_ptr, len); sv_setpvn(rv,version,len); /* this is for consistency with the pure Perl class */ - if ( *version != 'v' ) + if ( isDIGIT(*version) ) sv_insert(rv, 0, 0, "v", 1); Safefree(version); } @@ -4558,7 +4960,7 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) #ifdef SvVOK else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */ version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); - qv = 1; + qv = TRUE; } #endif else /* must be a string or something like a string */ @@ -4568,12 +4970,14 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) #ifndef SvVOK # if PERL_VERSION > 5 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */ - if ( len == 3 && !instr(version,".") && !instr(version,"_") ) { + if ( len >= 3 && !instr(version,".") && !instr(version,"_") + && !(*version == 'u' && strEQ(version, "undef")) + && (*version < '0' || *version > '9') ) { /* may be a v-string */ SV * const nsv = sv_newmortal(); const char *nver; const char *pos; - int saw_period = 0; + int saw_decimal = 0; sv_setpvf(nsv,"v%vd",ver); pos = nver = savepv(SvPV_nolen(nsv)); @@ -4581,12 +4985,12 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) pos++; /* skip the leading 'v' */ while ( *pos == '.' || isDIGIT(*pos) ) { if ( *pos == '.' ) - saw_period++ ; + saw_decimal++ ; pos++; } /* is definitely a v-string */ - if ( saw_period == 2 ) { + if ( saw_decimal >= 2 ) { Safefree(version); version = nver; } @@ -4667,7 +5071,7 @@ Perl_vnumify(pTHX_ SV *vs) I32 i, len, digit; int width; bool alpha = FALSE; - SV * const sv = newSV(0); + SV *sv; AV *av; PERL_ARGS_ASSERT_VNUMIFY; @@ -4689,19 +5093,17 @@ Perl_vnumify(pTHX_ SV *vs) /* attempt to retrieve the version array */ if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) { - sv_catpvs(sv,"0"); - return sv; + return newSVpvs("0"); } len = av_len(av); if ( len == -1 ) { - sv_catpvs(sv,"0"); - return sv; + return newSVpvs("0"); } digit = SvIV(*av_fetch(av, 0, 0)); - Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit)); + sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit)); for ( i = 1 ; i < len ; i++ ) { digit = SvIV(*av_fetch(av, i, 0)); @@ -4748,7 +5150,7 @@ Perl_vnormal(pTHX_ SV *vs) { I32 i, len, digit; bool alpha = FALSE; - SV * const sv = newSV(0); + SV *sv; AV *av; PERL_ARGS_ASSERT_VNORMAL; @@ -4766,11 +5168,10 @@ Perl_vnormal(pTHX_ SV *vs) len = av_len(av); if ( len == -1 ) { - sv_catpvs(sv,""); - return sv; + return newSVpvs(""); } digit = SvIV(*av_fetch(av, 0, 0)); - Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit); + sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit); for ( i = 1 ; i < len ; i++ ) { digit = SvIV(*av_fetch(av, i, 0)); Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); @@ -5394,7 +5795,7 @@ Perl_get_hash_seed(pTHX) * help. Sum in another random number that will * fill in the low bits. */ myseed += - (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1)); + (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1)); #endif /* RANDBITS < (UVSIZE * 8) */ if (myseed == 0) { /* Superparanoia. */ myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */ @@ -5865,9 +6266,13 @@ Perl_my_cxt_init(pTHX_ int *index, size_t size) PERL_ARGS_ASSERT_MY_CXT_INIT; if (*index == -1) { /* this module hasn't been allocated an index yet */ +#if defined(USE_ITHREADS) MUTEX_LOCK(&PL_my_ctx_mutex); +#endif *index = PL_my_cxt_index++; +#if defined(USE_ITHREADS) MUTEX_UNLOCK(&PL_my_ctx_mutex); +#endif } /* make sure the array is big enough */ @@ -5922,9 +6327,13 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) index = Perl_my_cxt_index(aTHX_ my_cxt_key); if (index == -1) { /* this module hasn't been allocated an index yet */ +#if defined(USE_ITHREADS) MUTEX_LOCK(&PL_my_ctx_mutex); +#endif index = PL_my_cxt_index++; +#if defined(USE_ITHREADS) MUTEX_UNLOCK(&PL_my_ctx_mutex); +#endif } /* make sure the array is big enough */