X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/6ac6a52b90121db9304782c76ae9243ce4205369..3f5a5a292521388b979675247c6a3bfc1477f474:/perl.c diff --git a/perl.c b/perl.c index f9a71af..7c881c4 100644 --- a/perl.c +++ b/perl.c @@ -1,7 +1,7 @@ /* perl.c * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -137,6 +137,15 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); #endif #endif +#ifndef NO_MATHOMS +/* This reference ensures that the mathoms are linked with perl */ +extern void Perl_mathoms(void); +void Perl_mathoms_ref(void); +void Perl_mathoms_ref(void) { + Perl_mathoms(); +} +#endif + static void S_init_tls_and_interp(PerlInterpreter *my_perl) { @@ -150,6 +159,9 @@ S_init_tls_and_interp(PerlInterpreter *my_perl) OP_REFCNT_INIT; MUTEX_INIT(&PL_dollarzero_mutex); # endif +#ifdef PERL_IMPLICIT_CONTEXT + MUTEX_INIT(&PL_my_ctx_mutex); +# endif } else { PERL_SET_THX(my_perl); @@ -230,7 +242,7 @@ perl_construct(pTHXx) if (!PL_linestr) { PL_curcop = &PL_compiling; /* needed by ckWARN, right away */ - PL_linestr = NEWSV(65,79); + PL_linestr = newSV(79); sv_upgrade(PL_linestr,SVt_PVIV); if (!SvREADONLY(&PL_sv_undef)) { @@ -259,10 +271,12 @@ perl_construct(pTHXx) } PL_sighandlerp = (Sighandler_t) Perl_sighandler; +#ifdef PERL_USES_PL_PIDSTATUS PL_pidstatus = newHV(); +#endif } - PL_rs = newSVpvn("\n", 1); + PL_rs = newSVpvs("\n"); init_stacks(); @@ -287,7 +301,7 @@ perl_construct(pTHXx) PL_fdpid = newAV(); /* for remembering popen pids by fd */ PL_modglobal = newHV(); /* pointers to per-interpreter module globals */ - PL_errors = newSVpvn("",0); + PL_errors = newSVpvs(""); sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */ sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */ sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */ @@ -808,10 +822,10 @@ perl_destruct(pTHXx) */ { I32 i = AvFILLp(PL_regex_padav) + 1; - SV **ary = AvARRAY(PL_regex_padav); + SV * const * const ary = AvARRAY(PL_regex_padav); while (i) { - SV *resv = ary[--i]; + SV * const resv = ary[--i]; if (SvFLAGS(resv) & SVf_BREAK) { /* this is PL_reg_curpm, already freed @@ -829,7 +843,7 @@ perl_destruct(pTHXx) } } SvREFCNT_dec(PL_regex_padav); - PL_regex_padav = Nullav; + PL_regex_padav = NULL; PL_regex_pad = NULL; #endif @@ -845,7 +859,7 @@ perl_destruct(pTHXx) /* Filters for program text */ SvREFCNT_dec(PL_rsfp_filters); - PL_rsfp_filters = Nullav; + PL_rsfp_filters = NULL; /* switches */ PL_preprocess = FALSE; @@ -912,12 +926,12 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_checkav); SvREFCNT_dec(PL_checkav_save); SvREFCNT_dec(PL_initav); - PL_beginav = Nullav; - PL_beginav_save = Nullav; - PL_endav = Nullav; - PL_checkav = Nullav; - PL_checkav_save = Nullav; - PL_initav = Nullav; + PL_beginav = NULL; + PL_beginav_save = NULL; + PL_endav = NULL; + PL_checkav = NULL; + PL_checkav_save = NULL; + PL_initav = NULL; /* shortcuts just get cleared */ PL_envgv = Nullgv; @@ -938,22 +952,24 @@ perl_destruct(pTHXx) PL_DBsignal = Nullsv; PL_DBassertion = Nullsv; PL_DBcv = Nullcv; - PL_dbargs = Nullav; - PL_debstash = Nullhv; + PL_dbargs = NULL; + PL_debstash = NULL; SvREFCNT_dec(PL_argvout_stack); - PL_argvout_stack = Nullav; + PL_argvout_stack = NULL; SvREFCNT_dec(PL_modglobal); - PL_modglobal = Nullhv; + PL_modglobal = NULL; SvREFCNT_dec(PL_preambleav); - PL_preambleav = Nullav; + PL_preambleav = NULL; SvREFCNT_dec(PL_subname); PL_subname = Nullsv; SvREFCNT_dec(PL_linestr); PL_linestr = Nullsv; +#ifdef PERL_USES_PL_PIDSTATUS SvREFCNT_dec(PL_pidstatus); - PL_pidstatus = Nullhv; + PL_pidstatus = NULL; +#endif SvREFCNT_dec(PL_toptarget); PL_toptarget = Nullsv; SvREFCNT_dec(PL_bodytarget); @@ -1069,7 +1085,7 @@ perl_destruct(pTHXx) AvREAL_off(PL_fdpid); /* no surviving entries */ SvREFCNT_dec(PL_fdpid); /* needed in io_close() */ - PL_fdpid = Nullav; + PL_fdpid = NULL; #ifdef HAVE_INTERP_INTERN sys_intern_clear(); @@ -1085,7 +1101,7 @@ perl_destruct(pTHXx) */ I32 riter = 0; const I32 max = HvMAX(PL_strtab); - HE ** const array = HvARRAY(PL_strtab); + HE * const * const array = HvARRAY(PL_strtab); HE *hent = array[0]; for (;;) { @@ -1319,6 +1335,7 @@ 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; @@ -1362,6 +1379,7 @@ S_procself_val(pTHX_ SV *sv, const char *arg0) STATIC void S_set_caret_X(pTHX) { + dVAR; GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */ if (tmpgv) { #ifdef HAS_PROCSELFEXE @@ -1421,7 +1439,10 @@ setuid perl scripts securely.\n"); PL_origargc = argc; PL_origargv = argv; - { + if (PL_origalen != 0) { + PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */ + } + else { /* Set PL_origalen be the sum of the contiguous argv[] * elements plus the size of the env in case that it is * contiguous with the argv[]. This is used in mg.c:Perl_magic_set() @@ -1469,7 +1490,7 @@ setuid perl scripts securely.\n"); } } /* Can we grab env area too to be used as the area for $0? */ - if (PL_origenviron) { + if (s && PL_origenviron) { if ((PL_origenviron[0] == s + 1 #ifdef OS2 || (PL_origenviron[0] == s + 9 && (s += 8)) @@ -1505,7 +1526,7 @@ setuid perl scripts securely.\n"); } } } - PL_origalen = s - PL_origargv[0] + 1; + PL_origalen = s ? s - PL_origargv[0] + 1 : 0; } if (PL_do_undump) { @@ -1585,7 +1606,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) PL_fdscript = -1; PL_suidscript = -1; sv_setpvn(PL_linestr,"",0); - sv = newSVpvn("",0); /* first used for -I flags */ + sv = newSVpvs(""); /* first used for -I flags */ SAVEFREESV(sv); init_main_stash(); @@ -1652,6 +1673,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) s++; goto reswitch; + case 'E': + PL_minus_E = TRUE; + /* FALL THROUGH */ case 'e': #ifdef MACOS_TRADITIONAL /* ignore -e for Dev:Pseudo argument */ @@ -1660,7 +1684,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #endif forbid_setid("-e"); if (!PL_e_script) { - PL_e_script = newSVpvn("",0); + PL_e_script = newSVpvs(""); filter_add(read_e_script, NULL); } if (*++s) @@ -1670,8 +1694,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) argc--,argv++; } else - Perl_croak(aTHX_ "No code specified for -e"); - sv_catpv(PL_e_script, "\n"); + Perl_croak(aTHX_ "No code specified for -%c", *s); + sv_catpvs(PL_e_script, "\n"); break; case 'f': @@ -1690,9 +1714,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) STRLEN len = strlen(s); const char * const p = savepvn(s, len); incpush(p, TRUE, TRUE, FALSE, FALSE); - sv_catpvn(sv, "-I", 2); + sv_catpvs(sv, "-I"); sv_catpvn(sv, p, len); - sv_catpvn(sv, " ", 1); + sv_catpvs(sv, " "); Safefree(p); } else @@ -1715,15 +1739,15 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) if (!PL_preambleav) PL_preambleav = newAV(); av_push(PL_preambleav, - newSVpv("use Config;",0)); + newSVpvs("use Config;")); if (*++s != ':') { STRLEN opts; - opts_prog = newSVpv("print Config::myconfig(),",0); + opts_prog = newSVpvs("print Config::myconfig(),"); #ifdef VMS - sv_catpv(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n\","); + sv_catpvs(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n\","); #else - sv_catpv(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n\","); + sv_catpvs(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n\","); #endif opts = SvCUR(opts_prog); @@ -1731,6 +1755,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef DEBUGGING " DEBUGGING" # endif +# ifdef DEBUG_LEAKING_SCALARS + " DEBUG_LEAKING_SCALARS" +# endif # ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP " DEBUG_LEAKING_SCALARS_FORK_DUMP" # endif @@ -1743,6 +1770,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef MYMALLOC " MYMALLOC" # endif +# ifdef NO_MATHOMS + " NO_MATHOMS" +# endif # ifdef PERL_DONT_CREATE_GVSV " PERL_DONT_CREATE_GVSV" # endif @@ -1767,15 +1797,18 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef PERL_OLD_COPY_ON_WRITE " PERL_OLD_COPY_ON_WRITE" # endif +# ifdef PERL_TRACK_MEMPOOL + " PERL_TRACK_MEMPOOL" +# endif # ifdef PERL_USE_SAFE_PUTENV " PERL_USE_SAFE_PUTENV" # endif +#ifdef PERL_USES_PL_PIDSTATUS + " PERL_USES_PL_PIDSTATUS" +#endif # ifdef PL_OP_SLAB_ALLOC " PL_OP_SLAB_ALLOC" # endif -# ifdef SPRINTF_RETURNS_STRLEN - " SPRINTF_RETURNS_STRLEN" -# endif # ifdef THREADS_HAVE_PIDS " THREADS_HAVE_PIDS" # endif @@ -1819,7 +1852,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) */ const char *space; - char *pv = SvPV_nolen(opts_prog); + char * const pv = SvPV_nolen(opts_prog); const char c = pv[opts+76]; pv[opts+76] = '\0'; space = strrchr(pv+opts+26, ' '); @@ -1829,16 +1862,16 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) /* break the line before that space */ opts = space - pv; - sv_insert(opts_prog, opts, 0, - "\\n ", 25); + Perl_sv_insert(aTHX_ opts_prog, opts, 0, + STR_WITH_LEN("\\n ")); } - sv_catpv(opts_prog,"\\n\","); + sv_catpvs(opts_prog,"\\n\","); #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) { int i; - sv_catpv(opts_prog, + sv_catpvs(opts_prog, "\" Locally applied patches:\\n\","); for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { if (PL_localpatches[i]) @@ -1859,14 +1892,14 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) __DATE__); # endif #endif - sv_catpv(opts_prog, "; $\"=\"\\n \"; " + sv_catpvs(opts_prog, "; $\"=\"\\n \"; " "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } " "sort grep {/^PERL/} keys %ENV; "); #ifdef __CYGWIN__ - sv_catpv(opts_prog, + sv_catpvs(opts_prog, "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";"); #endif - sv_catpv(opts_prog, + sv_catpvs(opts_prog, "print \" \\%ENV:\\n @env\\n\" if @env;" "print \" \\@INC:\\n @INC\\n\";"); } @@ -2031,7 +2064,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } - PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0); + PL_main_cv = PL_compcv = (CV*)newSV(0); sv_upgrade((SV *)PL_compcv, SVt_PVCV); CvUNIQUE_on(PL_compcv); @@ -2049,7 +2082,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) if (xsinit) (*xsinit)(aTHX); /* in case linked C routines want magical variables */ #ifndef PERL_MICRO -#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) +#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN) init_os_extras(); #endif #endif @@ -2189,6 +2222,7 @@ Tells a Perl interpreter to run. See L. int perl_run(pTHXx) { + dVAR; I32 oldscope; int ret = 0; dJMPENV; @@ -2242,6 +2276,7 @@ perl_run(pTHXx) STATIC void S_run_body(pTHX_ I32 oldscope) { + dVAR; DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n", PL_sawampersand ? "Enabling" : "Omitting")); @@ -2330,12 +2365,12 @@ set and the variable does not exist then NULL is returned. AV* Perl_get_av(pTHX_ const char *name, I32 create) { - GV* gv = gv_fetchpv(name, create, SVt_PVAV); + GV* const gv = gv_fetchpv(name, create, SVt_PVAV); if (create) return GvAVn(gv); if (gv) return GvAV(gv); - return Nullav; + return NULL; } /* @@ -2358,7 +2393,7 @@ Perl_get_hv(pTHX_ const char *name, I32 create) return GvHVn(gv); if (gv) return GvHV(gv); - return Nullhv; + return NULL; } /* @@ -2377,7 +2412,7 @@ subroutine does not exist then NULL is returned. CV* Perl_get_cv(pTHX_ const char *name, I32 create) { - GV* gv = gv_fetchpv(name, create, SVt_PVCV); + GV* const gv = gv_fetchpv(name, create, SVt_PVCV); /* XXX unsafe for threads if eval_owner isn't held */ /* XXX this is probably not what they think they're getting. * It has the same effect as "sub name;", i.e. just a forward @@ -2411,6 +2446,7 @@ Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) /* See G_* flags in cop.h */ /* null terminated arg list */ { + dVAR; dSP; PUSHMARK(SP); @@ -2479,7 +2515,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) I32 oldscope; bool oldcatch = CATCH_GET; int ret; - OP* oldop = PL_op; + OP* const oldop = PL_op; dJMPENV; if (flags & G_DISCARD) { @@ -2616,6 +2652,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) STATIC void S_call_body(pTHX_ const OP *myop, bool is_eval) { + dVAR; if (PL_op == myop) { if (is_eval) PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */ @@ -2641,12 +2678,13 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) /* See G_* flags in cop.h */ { + dVAR; dSP; UNOP myop; /* fake syntax tree node */ volatile I32 oldmark = SP - PL_stack_base; volatile I32 retval = 0; int ret; - OP* oldop = PL_op; + OP* const oldop = PL_op; dJMPENV; if (flags & G_DISCARD) { @@ -2733,6 +2771,7 @@ Tells Perl to C the given string and return an SV* result. SV* Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) { + dVAR; dSP; SV* sv = newSVpv(p, 0); @@ -2766,8 +2805,9 @@ implemented that way; consider using load_module instead. void Perl_require_pv(pTHX_ const char *pv) { - SV* sv; + dVAR; dSP; + SV* sv; PUSHSTACKi(PERLSI_REQUIRE); PUTBACK; sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0); @@ -2779,9 +2819,9 @@ Perl_require_pv(pTHX_ const char *pv) void Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen) { - register GV *gv; + register GV * const gv = gv_fetchpv(sym,TRUE, SVt_PV); - if ((gv = gv_fetchpv(sym,TRUE, SVt_PV))) + if (gv) sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen); } @@ -2800,6 +2840,7 @@ S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */ "-d[:debugger] run program under debugger", "-D[number/list] set debugging flags (argument is a bit mask or alphabets)", "-e program one line of program (several -e's allowed, omit programfile)", +"-E program like -e, but enables all optional features", "-f don't do $sitelib/sitecustomize.pl at startup", "-F/pattern/ split() pattern for -a switch (//'s are optional)", "-i[extension] edit <> files in place (makes backup if extension supplied)", @@ -2873,7 +2914,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq"; for (; isALNUM(**s); (*s)++) { - const char *d = strchr(debopts,**s); + const char * const d = strchr(debopts,**s); if (d) i |= 1 << (d - debopts); else if (ckWARN_d(WARN_DEBUGGING)) @@ -2927,7 +2968,7 @@ Perl_moreswitches(pTHX_ char *s) numlen = 0; s--; } - PL_rs = newSVpvn("", 0); + PL_rs = newSVpvs(""); SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1)); tmps = (U8*)SvPVX(PL_rs); uvchr_to_utf8(tmps, rschar); @@ -2940,7 +2981,7 @@ Perl_moreswitches(pTHX_ char *s) if (rschar & ~((U8)~0)) PL_rs = &PL_sv_undef; else if (!rschar && numlen >= 2) - PL_rs = newSVpvn("", 0); + PL_rs = newSVpvs(""); else { char ch = (char)rschar; PL_rs = newSVpvn(&ch, 1); @@ -2982,8 +3023,7 @@ Perl_moreswitches(pTHX_ char *s) in the fashion that -MSome::Mod does. */ if (*s == ':' || *s == '=') { const char *start; - SV *sv; - sv = newSVpv("use Devel::", 0); + SV * const sv = newSVpvs("use Devel::"); start = ++s; /* We now allow -d:Module=Foo,Bar */ while(isALNUM(*s) || *s==':') ++s; @@ -3022,7 +3062,7 @@ Perl_moreswitches(pTHX_ char *s) Safefree(PL_inplace); #if defined(__CYGWIN__) /* do backup extension automagically */ if (*(s+1) == '\0') { - PL_inplace = savepv(".bak"); + PL_inplace = savepvs(".bak"); return s+1; } #endif /* __CYGWIN__ */ @@ -3070,14 +3110,14 @@ Perl_moreswitches(pTHX_ char *s) if (isDIGIT(*s)) { I32 flags = 0; STRLEN numlen; - PL_ors_sv = newSVpvn("\n",1); + PL_ors_sv = newSVpvs("\n"); numlen = 3 + (*s == '0'); *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL); s += numlen; } else { if (RsPARA(PL_rs)) { - PL_ors_sv = newSVpvn("\n\n",2); + PL_ors_sv = newSVpvs("\n\n"); } else { PL_ors_sv = newSVsv(PL_rs); @@ -3091,10 +3131,10 @@ Perl_moreswitches(pTHX_ char *s) s++; { char * const start = s; - SV * const sv = newSVpv("use assertions::activate", 24); + SV * const sv = newSVpvs("use assertions::activate"); while(isALNUM(*s) || *s == ':') ++s; if (s != start) { - sv_catpvn(sv, "::", 2); + sv_catpvs(sv, "::"); sv_catpvn(sv, start, s-start); } if (*s == '=') { @@ -3129,17 +3169,17 @@ Perl_moreswitches(pTHX_ char *s) if (*(start-1) == 'm') { if (*s != '\0') Perl_croak(aTHX_ "Can't use '%c' after -mname", *s); - sv_catpv( sv, " ()"); + sv_catpvs( sv, " ()"); } } else { if (s == start) Perl_croak(aTHX_ "Module name required with -%c option", s[-1]); sv_catpvn(sv, start, s-start); - sv_catpv(sv, " split(/,/,q"); - sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */ + sv_catpvs(sv, " split(/,/,q"); + sv_catpvs(sv, "\0"); /* Use NUL as q//-delimiter. */ sv_catpv(sv, ++s); - sv_catpvn(sv, "\0)", 2); + sv_catpvs(sv, "\0)"); } s += strlen(s); if (!PL_preambleav) @@ -3185,10 +3225,14 @@ Perl_moreswitches(pTHX_ char *s) return s; case 'v': if (!sv_derived_from(PL_patchlevel, "version")) - (void *)upg_version(PL_patchlevel); + upg_version(PL_patchlevel); #if !defined(DGUX) PerlIO_printf(PerlIO_stdout(), - Perl_form(aTHX_ "\nThis is perl, %"SVf" built for %s", + Perl_form(aTHX_ "\nThis is perl, %"SVf +#ifdef PERL_PATCHNUM + " DEVEL" STRINGIFY(PERL_PATCHNUM) +#endif + " built for %s", vstringify(PL_patchlevel), ARCHNAME)); #else /* DGUX */ @@ -3214,7 +3258,7 @@ Perl_moreswitches(pTHX_ char *s) #endif PerlIO_printf(PerlIO_stdout(), - "\n\nCopyright 1987-2005, Larry Wall\n"); + "\n\nCopyright 1987-2006, Larry Wall\n"); #ifdef MACOS_TRADITIONAL PerlIO_printf(PerlIO_stdout(), "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n" @@ -3351,9 +3395,9 @@ Perl_my_unexec(pTHX) extern int etext; prog = newSVpv(BIN_EXP, 0); - sv_catpv(prog, "/perl"); + sv_catpvs(prog, "/perl"); file = newSVpv(PL_origfilename, 0); - sv_catpv(file, ".perldump"); + sv_catpvs(file, ".perldump"); unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); /* unexec prints msg to stderr in case of failure */ @@ -3362,6 +3406,8 @@ Perl_my_unexec(pTHX) # ifdef VMS # include lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */ +# elif defined(WIN32) || defined(__CYGWIN__) + Perl_croak(aTHX_ "dump is not supported"); # else ABORT(); /* for use with undump */ # endif @@ -3372,7 +3418,7 @@ Perl_my_unexec(pTHX) STATIC void S_init_interp(pTHX) { - + dVAR; #ifdef MULTIPLICITY # define PERLVAR(var,type) # define PERLVARA(var,n,type) @@ -3416,21 +3462,32 @@ S_init_interp(pTHX) STATIC void S_init_main_stash(pTHX) { + dVAR; GV *gv; PL_curstash = PL_defstash = newHV(); - PL_curstname = newSVpvn("main",4); + /* We know that the string "main" will be in the global shared string + table, so it's a small saving to use it rather than allocate another + 8 bytes. */ + PL_curstname = newSVpvs_share("main"); gv = gv_fetchpv("main::",TRUE, SVt_PVHV); + /* If we hadn't caused another reference to "main" to be in the shared + string table above, then it would be worth reordering these two, + because otherwise all we do is delete "main" from it as a consequence + of the SvREFCNT_dec, only to add it again with hv_name_set */ SvREFCNT_dec(GvHV(gv)); + hv_name_set(PL_defstash, "main", 4, 0); GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash); SvREADONLY_on(gv); - hv_name_set(PL_defstash, "main", 4, 0); PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); + SvREFCNT_inc(PL_incgv); /* Don't allow it to be freed */ GvMULTI_on(PL_incgv); PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */ GvMULTI_on(PL_hintgv); PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV); + SvREFCNT_inc(PL_defgv); PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); + SvREFCNT_inc(PL_errgv); GvMULTI_on(PL_errgv); PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */ GvMULTI_on(PL_replgv); @@ -3464,7 +3521,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) PL_suidscript = -1; if (PL_e_script) { - PL_origfilename = savepvn("-e", 2); + PL_origfilename = savepvs("-e"); } else { /* if find_script() returns, it returns a malloc()-ed value */ @@ -3533,9 +3590,9 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) } #else /* IAMSUID */ else if (PL_preprocess) { - const char *cpp_cfg = CPPSTDIN; - SV *cpp = newSVpvn("",0); - SV *cmd = NEWSV(0,0); + const char * const cpp_cfg = CPPSTDIN; + SV * const cpp = newSVpvs(""); + SV * const cmd = newSV(0); if (cpp_cfg[0] == 0) /* PERL_MICRO? */ Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined"); @@ -3544,7 +3601,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) sv_catpv(cpp, cpp_cfg); # ifndef VMS - sv_catpvn(sv, "-I", 2); + sv_catpvs(sv, "-I"); sv_catpv(sv,PRIVLIB_EXP); # endif @@ -3798,6 +3855,7 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname) if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) { I32 len; const char *linestr; + const char *s_end; #ifdef IAMSUID if (PL_fdscript < 0 || PL_suidscript != 1) @@ -3895,15 +3953,18 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname) PL_doswitches = FALSE; /* -s is insecure in suid */ /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */ CopLINE_inc(PL_curcop); + if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch) + Perl_croak(aTHX_ "No #! line"); linestr = SvPV_nolen_const(PL_linestr); - if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch || - strnNE(linestr,"#!",2) ) /* required even on Sys V */ + /* required even on Sys V */ + if (!*linestr || !linestr[1] || strnNE(linestr,"#!",2)) Perl_croak(aTHX_ "No #! line"); - linestr+=2; + linestr += 2; s = linestr; /* PSz 27 Feb 04 */ /* Sanity check on line length */ - if (strlen(s) < 1 || strlen(s) > 4000) + s_end = s + strlen(s); + if (s_end == s || (s_end - s) > 4000) Perl_croak(aTHX_ "Very long #! line"); /* Allow more than a single space after #! */ while (isSPACE(*s)) s++; @@ -3942,7 +4003,8 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname) len = strlen(validarg); if (strEQ(validarg," PHOOEY ") || strnNE(s,validarg,len) || !isSPACE(s[len]) || - !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1])))) + !((s_end - s) == len+1 + || ((s_end - s) == len+2 && isSPACE(s[len+1])))) Perl_croak(aTHX_ "Args must match #! line"); #ifndef IAMSUID @@ -4160,6 +4222,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); STATIC void S_find_beginning(pTHX) { + dVAR; register char *s; register const char *s2; #ifdef MACOS_TRADITIONAL @@ -4229,6 +4292,7 @@ S_find_beginning(pTHX) STATIC void S_init_ids(pTHX) { + dVAR; PL_uid = PerlProc_getuid(); PL_euid = PerlProc_geteuid(); PL_gid = PerlProc_getgid(); @@ -4291,6 +4355,7 @@ Perl_doing_taint(int argc, char *argv[], char *envp[]) STATIC void S_forbid_setid(pTHX_ const char *s) { + dVAR; #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW if (PL_euid != PL_uid) Perl_croak(aTHX_ "No %s allowed while running setuid", s); @@ -4330,7 +4395,8 @@ S_forbid_setid(pTHX_ const char *s) void Perl_init_debugger(pTHX) { - HV *ostash = PL_curstash; + dVAR; + HV * const ostash = PL_curstash; PL_curstash = PL_debstash; PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV)))); @@ -4358,6 +4424,7 @@ 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)); @@ -4394,6 +4461,7 @@ 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) { @@ -4412,17 +4480,19 @@ S_nuke_stacks(pTHX) STATIC void S_init_lexer(pTHX) { + dVAR; PerlIO *tmpfp; tmpfp = PL_rsfp; PL_rsfp = Nullfp; lex_start(PL_linestr); PL_rsfp = tmpfp; - PL_subname = newSVpvn("main",4); + PL_subname = newSVpvs("main"); } STATIC void S_init_predump_symbols(pTHX) { + dVAR; GV *tmpgv; IO *io; @@ -4455,7 +4525,7 @@ S_init_predump_symbols(pTHX) GvMULTI_on(tmpgv); GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); - PL_statname = NEWSV(66,0); /* last filename we did stat on */ + PL_statname = newSV(0); /* last filename we did stat on */ Safefree(PL_osname); PL_osname = savepv(OSNAME); @@ -4464,6 +4534,7 @@ S_init_predump_symbols(pTHX) void Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) { + dVAR; argc--,argv++; /* skip name of script */ if (PL_doswitches) { for (; argc > 0 && **argv == '-'; argc--,argv++) { @@ -4475,8 +4546,9 @@ Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) break; } if ((s = strchr(argv[0], '='))) { - *s++ = '\0'; - sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s); + *s = '\0'; + sv_setpv(GvSV(gv_fetchpv(argv[0] + 1, TRUE, SVt_PV)), s + 1); + *s = '='; } else sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1); @@ -4505,10 +4577,10 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register dVAR; GV* tmpgv; - PL_toptarget = NEWSV(0,0); + PL_toptarget = newSV(0); sv_upgrade(PL_toptarget, SVt_PVFM); sv_setpvn(PL_toptarget, "", 0); - PL_bodytarget = NEWSV(0,0); + PL_bodytarget = newSV(0); sv_upgrade(PL_bodytarget, SVt_PVFM); sv_setpvn(PL_bodytarget, "", 0); PL_formtarget = PL_bodytarget; @@ -4596,6 +4668,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register STATIC void S_init_perllib(pTHX) { + dVAR; char *s; if (!PL_tainting) { #ifndef VMS @@ -4640,7 +4713,7 @@ S_init_perllib(pTHX) #ifdef MACOS_TRADITIONAL { Stat_t tmpstatbuf; - SV * privdir = NEWSV(55, 0); + SV * privdir = newSV(0); char * macperl = PerlEnv_getenv("MACPERL"); if (!macperl) @@ -4740,11 +4813,12 @@ S_init_perllib(pTHX) STATIC SV * S_incpush_if_exists(pTHX_ SV *dir) { + dVAR; Stat_t tmpstatbuf; if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) { av_push(GvAVn(PL_incgv), dir); - dir = NEWSV(0,0); + dir = newSV(0); } return dir; } @@ -4753,6 +4827,7 @@ STATIC void S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, bool canrelocate) { + dVAR; SV *subdir = Nullsv; const char *p = dir; @@ -4760,19 +4835,19 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, return; if (addsubdirs || addoldvers) { - subdir = NEWSV(0,0); + subdir = newSV(0); } /* Break at all separators */ while (p && *p) { - SV *libdir = NEWSV(55,0); + SV *libdir = newSV(0); const char *s; /* skip any consecutive separators */ if (usesep) { while ( *p == PERLLIB_SEP ) { /* Uncomment the next line for PATH semantics */ - /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */ + /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */ p++; } } @@ -4793,7 +4868,7 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0)); } if (SvPVX(libdir)[SvCUR(libdir)-1] != ':') - sv_catpv(libdir, ":"); + sv_catpvs(libdir, ":"); #endif /* Do the if() outside the #ifdef to avoid warnings about an unused @@ -4901,8 +4976,8 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, if (addsubdirs || addoldvers) { #ifdef PERL_INC_VERSION_LIST /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ - const char *incverlist[] = { PERL_INC_VERSION_LIST }; - const char **incver; + const char * const incverlist[] = { PERL_INC_VERSION_LIST }; + const char * const *incver; #endif #ifdef VMS char *unix; @@ -5023,14 +5098,14 @@ S_init_main_thread(pTHX) * because sv_setpvn does SvTAINT and the taint * fields thread selfness being set. */ - PL_toptarget = NEWSV(0,0); + PL_toptarget = newSV(0); sv_upgrade(PL_toptarget, SVt_PVFM); sv_setpvn(PL_toptarget, "", 0); - PL_bodytarget = NEWSV(0,0); + PL_bodytarget = newSV(0); sv_upgrade(PL_bodytarget, SVt_PVFM); sv_setpvn(PL_bodytarget, "", 0); PL_formtarget = PL_bodytarget; - thr->errsv = newSVpvn("", 0); + thr->errsv = newSVpvs(""); (void) find_threadsv("@"); /* Ensure $@ is initialised early */ PL_maxscream = -1; @@ -5086,7 +5161,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) PL_curcop = &PL_compiling; CopLINE_set(PL_curcop, oldline); if (paramList == PL_beginav) - sv_catpv(atsv, "BEGIN failed--compilation aborted"); + sv_catpvs(atsv, "BEGIN failed--compilation aborted"); else Perl_sv_catpvf(aTHX_ atsv, "%s failed--call queue aborted", @@ -5139,6 +5214,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) STATIC void * S_call_list_body(pTHX_ CV *cv) { + dVAR; PUSHMARK(PL_stack_sp); call_sv((SV*)cv, G_EVAL|G_DISCARD); return NULL; @@ -5147,6 +5223,7 @@ S_call_list_body(pTHX_ CV *cv) void Perl_my_exit(pTHX_ U32 status) { + dVAR; DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n", thr, (unsigned long) status)); switch (status) { @@ -5166,6 +5243,7 @@ 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 @@ -5265,6 +5343,7 @@ 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');