X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a25b59276cf9505a41280bad7847c33234f7e7c6..44b2d6d61b5b1b85de1be347091e97d57de8ae0c:/perl.c

diff --git a/perl.c b/perl.c
index 9e0d2b5..478b415 100644
--- a/perl.c
+++ b/perl.c
@@ -546,7 +546,12 @@ perl_destruct(pTHXx)
     {
 	const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
 	if (s) {
-            const int i = atoi(s);
+            int i;
+            if (strEQ(s, "-1")) { /* Special case: modperl folklore. */
+                i = -1;
+            } else {
+                i = grok_atou(s, NULL);
+            }
 #ifdef DEBUGGING
 	    if (destruct_level < i) destruct_level = i;
 #endif
@@ -1029,6 +1034,7 @@ perl_destruct(pTHXx)
     SvREFCNT_dec(PL_utf8_foldable);
     SvREFCNT_dec(PL_utf8_foldclosures);
     SvREFCNT_dec(PL_AboveLatin1);
+    SvREFCNT_dec(PL_InBitmap);
     SvREFCNT_dec(PL_UpperLatin1);
     SvREFCNT_dec(PL_Latin1);
     SvREFCNT_dec(PL_NonL1NonFinalFold);
@@ -1042,6 +1048,7 @@ perl_destruct(pTHXx)
     PL_utf8_idcont	= NULL;
     PL_utf8_foldclosures = NULL;
     PL_AboveLatin1       = NULL;
+    PL_InBitmap          = NULL;
     PL_HasMultiCharFold  = NULL;
     PL_Latin1            = NULL;
     PL_NonL1NonFinalFold = NULL;
@@ -1415,7 +1422,6 @@ perl_fini(void)
 void
 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
 {
-    dVAR;
     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
     PL_exitlist[PL_exitlistlen].fn = fn;
     PL_exitlist[PL_exitlistlen].ptr = ptr;
@@ -1452,7 +1458,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
     {
         const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
 
-        if (s && (atoi(s) == 1)) {
+        if (s && (grok_atou(s, NULL) == 1)) {
             unsigned char *seed= PERL_HASH_SEED;
             unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
             PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
@@ -2066,9 +2072,10 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
                it should be reported immediately as a build failure.  */
 	    (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
 						 Perl_newSVpvf(aTHX_
-        "BEGIN { do {local $!; -f q%c%"SVf"/buildcustomize.pl%c} and do q%c%"SVf"/buildcustomize.pl%c || die $@ }",
-							       0, SVfARG(*inc0), 0,
-							       0, SVfARG(*inc0), 0));
+		"BEGIN { my $f = q%c%s%"SVf"/buildcustomize.pl%c; "
+			"do {local $!; -f $f }"
+			" and do $f || die $@ || qq '$f: $!' }",
+                                0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0));
 	}
 #  else
 	/* SITELIB_EXP is a function call on Win32.  */
@@ -2286,8 +2293,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #ifdef MYMALLOC
     {
 	const char *s;
-    if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
-	dump_mstats("after compilation:");
+        if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && grok_atou(s, NULL) >= 2)
+            dump_mstats("after compilation:");
     }
 #endif
 
@@ -2308,7 +2315,6 @@ Tells a Perl interpreter to run.  See L<perlembed>.
 int
 perl_run(pTHXx)
 {
-    dVAR;
     I32 oldscope;
     int ret = 0;
     dJMPENV;
@@ -2366,7 +2372,6 @@ perl_run(pTHXx)
 STATIC void
 S_run_body(pTHX_ I32 oldscope)
 {
-    dVAR;
     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
                     PL_sawampersand ? "Enabling" : "Omitting",
                     (unsigned int)(PL_sawampersand)));
@@ -2566,7 +2571,6 @@ Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
           		/* See G_* flags in cop.h */
                      	/* null terminated arg list */
 {
-    dVAR;
     dSP;
 
     PERL_ARGS_ASSERT_CALL_ARGV;
@@ -2880,7 +2884,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
 /*
 =for apidoc p||eval_pv
 
-Tells Perl to C<eval> the given string and return an SV* result.
+Tells Perl to C<eval> the given string in scalar context and return an SV* result.
 
 =cut
 */
@@ -2888,7 +2892,6 @@ Tells Perl to C<eval> the given string and return an SV* result.
 SV*
 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
 {
-    dVAR;
     SV* sv = newSVpv(p, 0);
 
     PERL_ARGS_ASSERT_EVAL_PV;
@@ -2929,7 +2932,6 @@ implemented that way; consider using load_module instead.
 void
 Perl_require_pv(pTHX_ const char *pv)
 {
-    dVAR;
     dSP;
     SV* sv;
 
@@ -3048,7 +3050,10 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
 	}
     }
     else if (isDIGIT(**s)) {
-	i = atoi(*s);
+        const char* e;
+	i = grok_atou(*s, &e);
+        if (e)
+            *s = e;
 	for (; isWORDCHAR(**s); (*s)++) ;
     }
     else if (givehelp) {
@@ -3531,7 +3536,6 @@ Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
 void
 Perl_my_unexec(pTHX)
 {
-    PERL_UNUSED_CONTEXT;
 #ifdef UNEXEC
     SV *    prog = newSVpv(BIN_EXP, 0);
     SV *    file = newSVpv(PL_origfilename, 0);
@@ -3545,10 +3549,11 @@ Perl_my_unexec(pTHX)
     /* unexec prints msg to stderr in case of failure */
     PerlProc_exit(status);
 #else
+    PERL_UNUSED_CONTEXT;
 #  ifdef VMS
      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
 #  elif defined(WIN32) || defined(__CYGWIN__)
-    Perl_croak(aTHX_ "dump is not supported");
+    Perl_croak_nocontext("dump is not supported");
 #  else
     ABORT();		/* for use with undump */
 #  endif
@@ -3559,7 +3564,6 @@ Perl_my_unexec(pTHX)
 STATIC void
 S_init_interp(pTHX)
 {
-    dVAR;
 #ifdef MULTIPLICITY
 #  define PERLVAR(prefix,var,type)
 #  define PERLVARA(prefix,var,n,type)
@@ -3592,7 +3596,6 @@ S_init_interp(pTHX)
 STATIC void
 S_init_main_stash(pTHX)
 {
-    dVAR;
     GV *gv;
 
     PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
@@ -3644,7 +3647,6 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
 {
     int fdscript = -1;
     PerlIO *rsfp = NULL;
-    dVAR;
     Stat_t tmpstatbuf;
     int fd;
 
@@ -3659,9 +3661,9 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
 
 	if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
             const char *s = scriptname + 8;
-	    fdscript = atoi(s);
-	    while (isDIGIT(*s))
-		s++;
+            const char* e;
+	    fdscript = grok_atou(s, &e);
+	    s = e;
 	    if (*s) {
 		/* PSz 18 Feb 04
 		 * Tell apart "normal" usage of fdscript, e.g.
@@ -3821,7 +3823,6 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 STATIC void
 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
 {
-    dVAR;
     const char *s;
     const char *s2;
 
@@ -3854,12 +3855,13 @@ S_init_ids(pTHX)
     /* no need to do anything here any more if we don't
      * do tainting. */
 #ifndef NO_TAINT_SUPPORT
-    dVAR;
     const Uid_t my_uid = PerlProc_getuid();
     const Uid_t my_euid = PerlProc_geteuid();
     const Gid_t my_gid = PerlProc_getgid();
     const Gid_t my_egid = PerlProc_getegid();
 
+    PERL_UNUSED_CONTEXT;
+
     /* Should not happen: */
     CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
     TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
@@ -3907,7 +3909,7 @@ Perl_doing_taint(int argc, char *argv[], char *envp[])
      * if -T are the first chars together; otherwise one gets
      *  "Too late" message. */
     if ( argc > 1 && argv[1][0] == '-'
-         && (argv[1][1] == 't' || argv[1][1] == 'T') )
+         && isALPHA_FOLD_EQ(argv[1][1], 't'))
 	return 1;
     return 0;
 }
@@ -3919,10 +3921,10 @@ Perl_doing_taint(int argc, char *argv[], char *envp[])
 STATIC void
 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
 {
-    dVAR;
     char string[3] = "-x";
     const char *message = "program input from stdin";
 
+    PERL_UNUSED_CONTEXT;
     if (flag) {
 	string[1] = flag;
 	message = string;
@@ -3959,7 +3961,6 @@ Perl_init_dbargs(pTHX)
 void
 Perl_init_debugger(pTHX)
 {
-    dVAR;
     HV * const ostash = PL_curstash;
 
     PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
@@ -3998,7 +3999,6 @@ Perl_init_debugger(pTHX)
 void
 Perl_init_stacks(pTHX)
 {
-    dVAR;
     /* start with 128-item stack and 8K cxstack */
     PL_curstackinfo = new_stackinfo(REASONABLE(128),
 				 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
@@ -4038,7 +4038,6 @@ Perl_init_stacks(pTHX)
 STATIC void
 S_nuke_stacks(pTHX)
 {
-    dVAR;
     while (PL_curstackinfo->si_next)
 	PL_curstackinfo = PL_curstackinfo->si_next;
     while (PL_curstackinfo) {
@@ -4094,7 +4093,6 @@ Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
 STATIC void
 S_init_predump_symbols(pTHX)
 {
-    dVAR;
     GV *tmpgv;
     IO *io;
 
@@ -4155,8 +4153,6 @@ S_init_predump_symbols(pTHX)
 void
 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
 {
-    dVAR;
-
     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
 
     argc--,argv++;	/* skip name of script */
@@ -4203,7 +4199,9 @@ Perl_init_argv_symbols(pTHX_ int argc, char **argv)
 STATIC void
 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
 {
+#ifdef USE_ITHREADS
     dVAR;
+#endif
     GV* tmpgv;
 
     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
@@ -4280,7 +4278,6 @@ S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
 STATIC void
 S_init_perllib(pTHX)
 {
-    dVAR;
 #ifndef VMS
     const char *perl5lib = NULL;
 #endif
@@ -4486,7 +4483,6 @@ S_init_perllib(pTHX)
 STATIC SV *
 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
 {
-    dVAR;
     Stat_t tmpstatbuf;
 
     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
@@ -4641,7 +4637,6 @@ S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
 STATIC void
 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
 {
-    dVAR;
 #ifndef PERL_IS_MINIPERL
     const U8 using_sub_dirs
 	= (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
@@ -4800,7 +4795,6 @@ S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
 void
 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
 {
-    dVAR;
     SV *atsv;
     volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
     CV *cv;
@@ -4883,7 +4877,6 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
 void
 Perl_my_exit(pTHX_ U32 status)
 {
-    dVAR;
     if (PL_exit_flags & PERL_EXIT_ABORT) {
 	abort();
     }
@@ -4909,7 +4902,6 @@ Perl_my_exit(pTHX_ U32 status)
 void
 Perl_my_failure_exit(pTHX)
 {
-    dVAR;
 #ifdef VMS
      /* We have been called to fall on our sword.  The desired exit code
       * should be already set in STATUS_UNIX, but could be shifted over
@@ -5003,8 +4995,6 @@ Perl_my_failure_exit(pTHX)
 STATIC void
 S_my_exit_jump(pTHX)
 {
-    dVAR;
-
     if (PL_e_script) {
 	SvREFCNT_dec(PL_e_script);
 	PL_e_script = NULL;
@@ -5020,7 +5010,6 @@ S_my_exit_jump(pTHX)
 static I32
 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
 {
-    dVAR;
     const char * const p  = SvPVX_const(PL_e_script);
     const char *nl = strchr(p, '\n');