Avoid calling Perl_croak_nocontext from core

Leont · mauke · commit dbd0f2f14fac · 2025-03-18T04:16:51.000+01:00
In core we almost always have a context, or we can easily get one.
diff --git a/doop.c b/doop.c
@@ -906,8 +906,8 @@ Perl_do_vecset(pTHX_ SV *sv)
     if (errflags) {
         assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
         if (errflags & LVf_NEG_OFF)
-            Perl_croak_nocontext("Negative offset to vec in lvalue context");
-        Perl_croak_nocontext("Out of memory during vec in lvalue context");
+            croak("Negative offset to vec in lvalue context");
+        croak("Out of memory during vec in lvalue context");
     }
 
     if (!targ)
@@ -937,7 +937,7 @@ Perl_do_vecset(pTHX_ SV *sv)
     else if (size > 8) {
         int n = size/8;
         if (offset > Size_t_MAX / n - 1) /* would overflow */
-            Perl_croak_nocontext("Out of memory during vec in lvalue context");
+            croak("Out of memory during vec in lvalue context");
         offset *= n;
     }
 
diff --git a/dump.c b/dump.c
@@ -2974,7 +2974,7 @@ Perl_runops_debug(pTHX)
 #endif
 #ifdef PERL_USE_HWM
         if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
-            Perl_croak_nocontext(
+            croak(
                 "panic: previous op failed to extend arg stack: "
                 "base=%p, sp=%p, hwm=%p\n",
                     PL_stack_base, PL_stack_sp,
diff --git a/embed.fnc b/embed.fnc
@@ -2443,7 +2443,7 @@ Adp	|OP *	|op_prepend_elem|I32 optype				\
 Cdp	|void	|op_refcnt_lock
 Cdp	|void	|op_refcnt_unlock
 Adpx	|OP *	|op_scope	|NULLOK OP *o
-ATdp	|OP *	|op_sibling_splice					\
+Adp	|OP *	|op_sibling_splice					\
 				|NULLOK OP *parent			\
 				|NULLOK OP *start			\
 				|int del_count				\
diff --git a/embed.h b/embed.h
@@ -505,7 +505,7 @@
 # define op_refcnt_lock()                       Perl_op_refcnt_lock(aTHX)
 # define op_refcnt_unlock()                     Perl_op_refcnt_unlock(aTHX)
 # define op_scope(a)                            Perl_op_scope(aTHX_ a)
-# define op_sibling_splice                      Perl_op_sibling_splice
+# define op_sibling_splice(a,b,c,d)             Perl_op_sibling_splice(aTHX_ a,b,c,d)
 # define op_wrap_finally(a,b)                   Perl_op_wrap_finally(aTHX_ a,b)
 # define opdump_printf(a,...)                   Perl_opdump_printf(aTHX_ a,__VA_ARGS__)
 # define packlist(a,b,c,d,e)                    Perl_packlist(aTHX_ a,b,c,d,e)
diff --git a/hv.c b/hv.c
@@ -2072,7 +2072,7 @@ Perl_hv_clear(pTHX_ HV *hv)
                     if (HeVAL(entry)) {
                         if (SvREADONLY(HeVAL(entry))) {
                             SV* const keysv = hv_iterkeysv(entry);
-                            Perl_croak_nocontext(
+                            croak(
                                 "Attempt to delete readonly key '%" SVf "' from a restricted hash",
                                 (void*)keysv);
                         }
@@ -3410,7 +3410,7 @@ S_share_hek_flags(pTHX_ const char *str, STRLEN len, U32 hash, int flags)
     assert(!(flags & HVhek_NOTSHARED));
 
     if (UNLIKELY(len > (STRLEN) I32_MAX)) {
-        Perl_croak_nocontext("Sorry, hash keys must be smaller than 2**31 bytes");
+        croak("Sorry, hash keys must be smaller than 2**31 bytes");
     }
 
     /* what follows is the moral equivalent of:
diff --git a/locale.c b/locale.c
@@ -7316,7 +7316,7 @@ S_emulate_langinfo(pTHX_ const PERL_INTMAX_T item,
              * invalid. */;
 #  if defined(I_LANGINFO)
 
-            Perl_croak_nocontext("panic: Unexpected nl_langinfo() item %jd",
+            croak("panic: Unexpected nl_langinfo() item %jd",
                                  item);
 
 #  else
diff --git a/op.c b/op.c
@@ -1590,7 +1590,7 @@ see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
 */
 
 OP *
-Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
+Perl_op_sibling_splice(pTHX_ OP *parent, OP *start, int del_count, OP* insert)
 {
     OP *first;
     OP *rest;
@@ -1673,7 +1673,7 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
     return last_del ? first : NULL;
 
   no_parent:
-    Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
+    croak("panic: op_sibling_splice(): NULL parent");
 }
 
 /*
@@ -2788,7 +2788,7 @@ Perl_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
             SSize_t keylen;
             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
             if (keylen > I32_MAX) {
-                Perl_croak_nocontext("Sorry, hash keys must be smaller than 2**31 bytes");
+                croak("Sorry, hash keys must be smaller than 2**31 bytes");
             }
 
             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -(I32)keylen : (I32)keylen, 0);
@@ -11147,12 +11147,12 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
         PL_compcv = 0;
         if (isBEGIN) {
             if (PL_in_eval & EVAL_KEEPERR)
-                Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
+                croak("BEGIN not safe after errors--compilation aborted");
             else {
                 SV * const errsv = ERRSV;
                 /* force display of errors found but not reported */
                 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
-                Perl_croak_nocontext("%" SVf, SVfARG(errsv));
+                croak("%" SVf, SVfARG(errsv));
             }
         }
         goto done;
diff --git a/pad.c b/pad.c
@@ -332,7 +332,7 @@ Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
             assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); /*unsafe is safe */
             if (CvDEPTHunsafe(&cvbody)) {
                 assert(SvTYPE(cv) == SVt_PVCV);
-                Perl_croak_nocontext("Can't undef active subroutine");
+                croak("Can't undef active subroutine");
             }
             ENTER;
 
diff --git a/perl.c b/perl.c
@@ -2276,7 +2276,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #if defined(SILENT_NO_TAINT_SUPPORT)
             /* silently ignore */
 #elif defined(NO_TAINT_SUPPORT)
-            Perl_croak_nocontext("This perl was compiled without taint support. "
+            croak("This perl was compiled without taint support. "
                        "Cowardly refusing to run with -t or -T flags");
 #else
             CHECK_MALLOC_TOO_LATE_FOR('t');
@@ -2291,7 +2291,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #if defined(SILENT_NO_TAINT_SUPPORT)
             /* silently ignore */
 #elif defined(NO_TAINT_SUPPORT)
-            Perl_croak_nocontext("This perl was compiled without taint support. "
+            croak("This perl was compiled without taint support. "
                        "Cowardly refusing to run with -t or -T flags");
 #else
             CHECK_MALLOC_TOO_LATE_FOR('T');
@@ -2409,7 +2409,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #if defined(SILENT_NO_TAINT_SUPPORT)
             /* silently ignore */
 #elif defined(NO_TAINT_SUPPORT)
-            Perl_croak_nocontext("This perl was compiled without taint support. "
+            croak("This perl was compiled without taint support. "
                        "Cowardly refusing to run with -t or -T flags");
 #else
             CHECK_MALLOC_TOO_LATE_FOR('T');
@@ -2448,7 +2448,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #if defined(SILENT_NO_TAINT_SUPPORT)
             /* silently ignore */
 #elif defined(NO_TAINT_SUPPORT)
-                    Perl_croak_nocontext("This perl was compiled without taint support. "
+                    croak("This perl was compiled without taint support. "
                                "Cowardly refusing to run with -t or -T flags");
 #else
                     if( !TAINTING_get) {
@@ -3910,7 +3910,7 @@ Perl_moreswitches(pTHX_ const char *s)
 #if defined(SILENT_NO_TAINT_SUPPORT)
             /* silently ignore */
 #elif defined(NO_TAINT_SUPPORT)
-        Perl_croak_nocontext("This perl was compiled without taint support. "
+        croak("This perl was compiled without taint support. "
                    "Cowardly refusing to run with -t or -T flags");
 #else
         if (!TAINTING_get)
@@ -4088,7 +4088,7 @@ Perl_my_unexec(pTHX)
 #  ifdef VMS
      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
 #  elif defined(WIN32) || defined(__CYGWIN__)
-    Perl_croak_nocontext("dump is not supported");
+    croak("dump is not supported");
 #  else
     ABORT();		/* for use with undump */
 #  endif
@@ -4329,7 +4329,7 @@ S_validate_suid(pTHX_ PerlIO *rsfp)
         int fd = PerlIO_fileno(rsfp);
         Stat_t statbuf;
         if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */
-            Perl_croak_nocontext( "Illegal suidscript");
+            croak( "Illegal suidscript");
         }
         if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
             ||
diff --git a/perlio.c b/perlio.c
@@ -2747,28 +2747,27 @@ PerlIOUnix_refcnt_inc(int fd)
 int
 PerlIOUnix_refcnt_dec(int fd)
 {
+    dTHX;
     int cnt = 0;
     if (fd >= 0) {
-#ifdef DEBUGGING
-        dTHX;
-#endif
+
         MUTEX_LOCK(&PL_perlio_mutex);
         if (fd >= PL_perlio_fd_refcnt_size) {
             /* diag_listed_as: refcnt_dec: fd %d%s */
-            Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
+            croak("refcnt_dec: fd %d >= refcnt_size %d\n",
                        fd, PL_perlio_fd_refcnt_size);
         }
         if (PL_perlio_fd_refcnt[fd] <= 0) {
             /* diag_listed_as: refcnt_dec: fd %d%s */
-            Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
+            croak("refcnt_dec: fd %d: %d <= 0\n",
                        fd, PL_perlio_fd_refcnt[fd]);
         }
         cnt = --PL_perlio_fd_refcnt[fd];
         DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) );
         MUTEX_UNLOCK(&PL_perlio_mutex);
     } else {
         /* diag_listed_as: refcnt_dec: fd %d%s */
-        Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
+        croak("refcnt_dec: fd %d < 0\n", fd);
     }
     return cnt;
 }
@@ -5289,8 +5288,8 @@ Perl_PerlIO_stderr(pTHX)
 char *
 PerlIO_getname(PerlIO *f, char *buf)
 {
-#ifdef VMS
     dTHX;
+#ifdef VMS
     char *name = NULL;
     bool exported = FALSE;
     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
@@ -5306,7 +5305,7 @@ PerlIO_getname(PerlIO *f, char *buf)
 #else
     PERL_UNUSED_ARG(f);
     PERL_UNUSED_ARG(buf);
-    Perl_croak_nocontext("Don't know how to get file name");
+    croak("Don't know how to get file name");
     return NULL;
 #endif
 }
diff --git a/pp_ctl.c b/pp_ctl.c
@@ -924,13 +924,13 @@ PP_wrapped(pp_formline, 0, 1)
                 {
                     int len;
                     if (!quadmath_format_valid(fmt))
-                        Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
+                        croak("panic: quadmath invalid format \"%s\"", fmt);
                     WITH_LC_NUMERIC_SET_TO_NEEDED(
                         len = quadmath_snprintf(t, max, fmt, (int) fieldsize,
                                                (int) arg, value);
                     );
                     if (len == -1)
-                        Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", fmt);
+                        croak("panic: quadmath_snprintf failed, format \"%s\"", fmt);
                 }
 #else
                 /* we generate fmt ourselves so it is safe */
diff --git a/pp_hot.c b/pp_hot.c
@@ -6551,7 +6551,7 @@ PP(pp_entersub)
          * in scalar context.
         */
         if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
-            Perl_croak_nocontext(
+            croak(
                 "panic: XSUB %s::%s (%s) failed to extend arg stack: "
                 "base=%p, sp=%p, hwm=%p\n",
                     HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)), CvFILE(cv),
diff --git a/proto.h b/proto.h
diff --git a/regcomp.c b/regcomp.c
@@ -1024,7 +1024,7 @@ S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
             SV * const errsv = ERRSV;
             if (SvTRUE_NN(errsv))
                 /* use croak_sv ? */
-                Perl_croak_nocontext("%" SVf, SVfARG(errsv));
+                croak("%" SVf, SVfARG(errsv));
         }
         assert(SvROK(qr_ref));
         qr = SvRV(qr_ref);
diff --git a/sv.c b/sv.c
@@ -12459,7 +12459,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
             width = expect_number(&q);
             if (*q == '$') {
                 if (args)
-                    Perl_croak_nocontext(
+                    croak(
                         "Cannot yet reorder sv_vcatpvfn() arguments from va_list");
                 ++q;
                 efix = (Size_t)width;
@@ -12527,7 +12527,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
                 ix = expect_number(&q);
                 if (*q++ == '$') {
                     if (args)
-                        Perl_croak_nocontext(
+                        croak(
                             "Cannot yet reorder sv_vcatpvfn() arguments from va_list");
                     no_redundant_warning = TRUE;
                 } else
@@ -12612,7 +12612,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
                     ix = expect_number(&q);
                     if (*q++ == '$') {
                         if (args)
-                            Perl_croak_nocontext(
+                            croak(
                                 "Cannot yet reorder sv_vcatpvfn() arguments from va_list");
                         no_redundant_warning = TRUE;
                     } else
@@ -13676,13 +13676,13 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
 #ifdef USE_QUADMATH
                 {
                     if (!quadmath_format_valid(ptr))
-                        Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr);
+                        croak("panic: quadmath invalid format \"%s\"", ptr);
                     WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric,
                         elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize,
                                                  ptr, nv);
                     );
                     if ((IV)elen == -1) {
-                        Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", ptr);
+                        croak("panic: quadmath_snprintf failed, format \"%s\"", ptr);
                     }
                 }
 #elif defined(HAS_LONG_DOUBLE)
@@ -13751,7 +13751,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
                 }
                 else {
                     if (arg_missing)
-                        Perl_croak_nocontext(
+                        croak(
                             "Missing argument for %%n in %s",
                                 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
                     sv_setuv_mg(argsv, has_utf8
diff --git a/universal.c b/universal.c
@@ -418,7 +418,7 @@ Perl_croak_xs_usage(const CV *const cv, const char *const params)
 
         /* Pants. I don't think that it should be possible to get here. */
         /* diag_listed_as: SKIPME */
-        croak("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
+        Perl_croak_nocontext("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
     }
 }
 
diff --git a/util.c b/util.c

Original file line number	Diff line number	Diff line change
`@@ -332,7 +332,7 @@ Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)`
`332`	`332`	`assert(SvTYPE(cv) == SVt_PVCV \|\| SvTYPE(cv) == SVt_PVFM); /unsafe is safe /`
`333`	`333`	`if (CvDEPTHunsafe(&cvbody)) {`
`334`	`334`	`assert(SvTYPE(cv) == SVt_PVCV);`
`335`		`- Perl_croak_nocontext("Can't undef active subroutine");`
	`335`	`+ croak("Can't undef active subroutine");`
`336`	`336`	`}`
`337`	`337`	`ENTER;`
`338`	`338`