diff options
Diffstat (limited to 'util.c')
| -rw-r--r-- | util.c | 387 |
1 files changed, 288 insertions, 99 deletions
@@ -1124,6 +1124,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</mess_sv>. + +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 +1201,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<basemsg> 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<at +foo.pl line 37> 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<consume> is true, then the function is permitted (but not +required) to modify and return C<basemsg> 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,6 +1285,34 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) return sv; } +/* +=for apidoc Am|SV *|vmess|const char *pat|va_list *args + +C<pat> and C<args> 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</mess_sv>. + +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_ SV* msv) { @@ -1279,10 +1364,26 @@ Perl_write_to_stderr(pTHX_ SV* msv) } } -/* 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_ SV *message, bool warn) +S_invoke_exception_hook(pTHX_ SV *ex, bool warn) { dVAR; HV *stash; @@ -1292,7 +1393,8 @@ S_vdie_common(pTHX_ SV *message, bool warn) /* sv_2cv might call Perl_croak() or Perl_warner() */ SV * const oldhook = *hook; - assert(oldhook); + if (!oldhook) + return FALSE; ENTER; SAVESPTR(*hook); @@ -1301,7 +1403,7 @@ S_vdie_common(pTHX_ SV *message, bool warn) LEAVE; if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; - SV *msg; + SV *exarg; ENTER; save_re_context(); @@ -1309,18 +1411,13 @@ S_vdie_common(pTHX_ SV *message, bool warn) SAVESPTR(*hook); *hook = NULL; } - if (warn || message) { - msg = newSVsv(message); - 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; @@ -1330,81 +1427,147 @@ S_vdie_common(pTHX_ SV *message, bool warn) return FALSE; } -STATIC SV * -S_vdie_croak_common(pTHX_ const char* pat, va_list* args) -{ - dVAR; - SV *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 = sv_mortalcopy(PL_errors); - SvCUR_set(PL_errors, 0); - } - else - message = msv; - } - else { - message = NULL; - } +Behaves the same as L</croak_sv>, except for the return type. +It should be used only where the C<OP *> return type is required. +The function never actually returns. - if (PL_diehook) { - S_vdie_common(aTHX_ message, FALSE); - } - return message; -} +=cut +*/ -static OP * -S_vdie(pTHX_ const char* pat, va_list *args) +OP * +Perl_die_sv(pTHX_ SV *baseex) { - dVAR; - SV *message; - - message = vdie_croak_common(pat, args); - - die_where(message); + PERL_ARGS_ASSERT_DIE_SV; + croak_sv(baseex); /* NOTREACHED */ return NULL; } +/* +=for apidoc Am|OP *|die|const char *pat|... + +Behaves the same as L</croak>, except for the return type. +It should be used only where the C<OP *> 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<die> function. + +C<baseex> 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</mess_sv>. + +The error message or object will be used as an exception, by default +returning control to the nearest enclosing C<eval>, but subject to +modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv> +function never returns normally. + +To die with a simple string message, the L</croak> function may be +more convenient. + +=cut +*/ + void -Perl_vcroak(pTHX_ const char* pat, va_list *args) +Perl_croak_sv(pTHX_ SV *baseex) { - dVAR; - SV *msv; + 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<die> function. + +C<pat> and C<args> 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</mess_sv>. - msv = S_vdie_croak_common(aTHX_ pat, args); +The error message will be used as an exception, by default +returning control to the nearest enclosing C<eval>, but subject to +modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak> +function never returns normally. - die_where(msv); +For historical reasons, if C<pat> is null then the contents of C<ERRSV> +(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</croak_sv> function, which does not involve clobbering C<ERRSV>. + +=cut +*/ + +void +Perl_vcroak(pTHX_ const char* pat, va_list *args) +{ + 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|... + +This is an XS interface to Perl's C<die> 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</mess_sv>. + +The error message will be used as an exception, by default +returning control to the nearest enclosing C<eval>, but subject to +modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak> +function never returns normally. + +For historical reasons, if C<pat> is null then the contents of C<ERRSV> +(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</croak_sv> function, which does not involve clobbering C<ERRSV>. + +=cut +*/ + #if defined(PERL_IMPLICIT_CONTEXT) void Perl_croak_nocontext(const char *pat, ...) @@ -1418,51 +1581,89 @@ 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|warn_sv|SV *baseex -=for apidoc croak +This is an XS interface to Perl's C<warn> function. -This is the XSUB-writer's interface to Perl's C<die> function. -Normally call this function the same way you call the C C<printf> -function. Calling C<croak> returns control directly to Perl, -sidestepping the normal C order of execution. See C<warn>. +C<baseex> 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</mess_sv>. -If you want to throw an exception object, assign the object to -C<$@> and then pass C<NULL> to croak(): +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. - errsv = get_sv("@", GV_ADD); - sv_setsv(errsv, exception_object); - croak(NULL); +To warn with a simple string message, the L</warn> 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<warn> function. + +C<pat> and C<args> 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</mess_sv>. + +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</vcroak>, C<pat> is not permitted to be null. + +=cut +*/ + void Perl_vwarn(pTHX_ const char* pat, va_list *args) { - dVAR; - SV * const msv = vmess(pat, args); - + 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(msv, TRUE)) - return; - } +/* +=for apidoc Am|void|warn|const char *pat|... - write_to_stderr(msv); -} +This is an XS interface to Perl's C<warn> 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</mess_sv>. + +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</croak>, C<pat> is not permitted to be null. + +=cut +*/ #if defined(PERL_IMPLICIT_CONTEXT) void @@ -1477,15 +1678,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<warn> function. Call this -function the same way you call the C C<printf> function. See C<croak>. - -=cut -*/ - void Perl_warn(pTHX_ const char *pat, ...) { @@ -1553,11 +1745,8 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) { SV * const msv = vmess(pat, args); - if (PL_diehook) { - assert(msv); - S_vdie_common(aTHX_ msv, FALSE); - } - die_where(msv); + invoke_exception_hook(msv, FALSE); + die_unwind(msv); } else { Perl_vwarn(aTHX_ pat, args); |