X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=188e193f41c3e8d230e2546476aa8e1364c59598;hb=60099296ceae90f439675352184edd07019ec071;hp=5b3b7774ec9e49e727efdbd191b924d91c524a39;hpb=184f32ecbaf38a072f9e20a9a51f7eed11d1b589;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 5b3b777..188e193 100644 --- a/perl.c +++ b/perl.c @@ -165,7 +165,7 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, struct IPerlProc* ipP) { PerlInterpreter *my_perl; - /* New() needs interpreter, so call malloc() instead */ + /* Newx() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); S_init_tls_and_interp(my_perl); Zero(my_perl, 1, PerlInterpreter); @@ -198,7 +198,7 @@ perl_alloc(void) { PerlInterpreter *my_perl; - /* New() needs interpreter, so call malloc() instead */ + /* Newx() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); S_init_tls_and_interp(my_perl); @@ -258,7 +258,7 @@ perl_construct(pTHXx) SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2; } - PL_sighandlerp = Perl_sighandler; + PL_sighandlerp = (Sighandler_t) Perl_sighandler; PL_pidstatus = newHV(); } @@ -1208,8 +1208,7 @@ perl_destruct(pTHXx) Safefree(PL_reg_start_tmp); PL_reg_start_tmp = (char**)NULL; PL_reg_start_tmpl = 0; - if (PL_reg_curpm) - Safefree(PL_reg_curpm); + Safefree(PL_reg_curpm); Safefree(PL_reg_poscache); free_tied_hv_pool(); Safefree(PL_op_mask); @@ -1686,9 +1685,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) argc--,argv++; } if (s && *s) { - char *p; STRLEN len = strlen(s); - p = savepvn(s, len); + const char * const p = savepvn(s, len); incpush(p, TRUE, TRUE, FALSE, FALSE); sv_catpvn(sv, "-I", 2); sv_catpvn(sv, p, len); @@ -1709,116 +1707,172 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) s++; goto reswitch; case 'V': - if (!PL_preambleav) - PL_preambleav = newAV(); - av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0)); - if (*++s != ':') { - STRLEN opts; - - PL_Sv = newSVpv("print myconfig();",0); + { + SV *opts_prog; + + if (!PL_preambleav) + PL_preambleav = newAV(); + av_push(PL_preambleav, + newSVpv("use Config;",0)); + if (*++s != ':') { + STRLEN opts; + + opts_prog = newSVpv("print Config::myconfig(),",0); #ifdef VMS - sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\","); + sv_catpv(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n\","); #else - sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\","); + sv_catpv(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n\","); #endif - opts = SvCUR(PL_Sv); + opts = SvCUR(opts_prog); - sv_catpv(PL_Sv,"\" Compile-time options:"); + sv_catpv(opts_prog,"\" Compile-time options:"); # ifdef DEBUGGING - sv_catpv(PL_Sv," DEBUGGING"); + sv_catpv(opts_prog," DEBUGGING"); +# endif +# ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP + sv_catpv(opts_prog," DEBUG_LEAKING_SCALARS_FORK_DUMP"); +# endif +# ifdef FAKE_THREADS + sv_catpv(opts_prog," FAKE_THREADS"); # endif # ifdef MULTIPLICITY - sv_catpv(PL_Sv," MULTIPLICITY"); + sv_catpv(opts_prog," MULTIPLICITY"); +# endif +# ifdef MYMALLOC + sv_catpv(opts_prog," MYMALLOC"); +# endif +# ifdef PERL_DONT_CREATE_GVSV + sv_catpv(opts_prog," PERL_DONT_CREATE_GVSV"); +# endif +# ifdef PERL_GLOBAL_STRUCT + sv_catpv(opts_prog," PERL_GLOBAL_STRUCT"); +# endif +# ifdef PERL_IMPLICIT_CONTEXT + sv_catpv(opts_prog," PERL_IMPLICIT_CONTEXT"); +# endif +# ifdef PERL_IMPLICIT_SYS + sv_catpv(opts_prog," PERL_IMPLICIT_SYS"); +# endif +# ifdef PERL_MALLOC_WRAP + sv_catpv(opts_prog," PERL_MALLOC_WRAP"); +# endif +# ifdef PERL_NEED_APPCTX + sv_catpv(opts_prog," PERL_NEED_APPCTX"); +# endif +# ifdef PERL_NEED_TIMESBASE + sv_catpv(opts_prog," PERL_NEED_TIMESBASE"); +# endif +# ifdef PERL_OLD_COPY_ON_WRITE + sv_catpv(opts_prog," PERL_OLD_COPY_ON_WRITE"); +# endif +# ifdef PL_OP_SLAB_ALLOC + sv_catpv(opts_prog," PL_OP_SLAB_ALLOC"); +# endif +# ifdef THREADS_HAVE_PIDS + sv_catpv(opts_prog," THREADS_HAVE_PIDS"); # endif # ifdef USE_5005THREADS - sv_catpv(PL_Sv," USE_5005THREADS"); + sv_catpv(opts_prog," USE_5005THREADS"); # endif -# ifdef USE_ITHREADS - sv_catpv(PL_Sv," USE_ITHREADS"); +# ifdef USE_64_BIT_ALL + sv_catpv(opts_prog," USE_64_BIT_ALL"); # endif # ifdef USE_64_BIT_INT - sv_catpv(PL_Sv," USE_64_BIT_INT"); + sv_catpv(opts_prog," USE_64_BIT_INT"); # endif -# ifdef USE_64_BIT_ALL - sv_catpv(PL_Sv," USE_64_BIT_ALL"); +# ifdef USE_ITHREADS + sv_catpv(opts_prog," USE_ITHREADS"); +# endif +# ifdef USE_LARGE_FILES + sv_catpv(opts_prog," USE_LARGE_FILES"); # endif # ifdef USE_LONG_DOUBLE - sv_catpv(PL_Sv," USE_LONG_DOUBLE"); + sv_catpv(opts_prog," USE_LONG_DOUBLE"); # endif -# ifdef USE_LARGE_FILES - sv_catpv(PL_Sv," USE_LARGE_FILES"); +# ifdef USE_PERLIO + sv_catpv(opts_prog," USE_PERLIO"); # endif -# ifdef USE_SOCKS - sv_catpv(PL_Sv," USE_SOCKS"); +# ifdef USE_REENTRANT_API + sv_catpv(opts_prog," USE_REENTRANT_API"); +# endif +# ifdef USE_SFIO + sv_catpv(opts_prog," USE_SFIO"); # endif # ifdef USE_SITECUSTOMIZE - sv_catpv(PL_Sv," USE_SITECUSTOMIZE"); + sv_catpv(opts_prog," USE_SITECUSTOMIZE"); # endif -# ifdef PERL_IMPLICIT_CONTEXT - sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT"); -# endif -# ifdef PERL_IMPLICIT_SYS - sv_catpv(PL_Sv," PERL_IMPLICIT_SYS"); +# ifdef USE_SOCKS + sv_catpv(opts_prog," USE_SOCKS"); # endif - while (SvCUR(PL_Sv) > opts+76) { - /* find last space after "options: " and before col 76 */ + while (SvCUR(opts_prog) > opts+76) { + /* find last space after "options: " and before col 76 + */ - const char *space; - char *pv = SvPV_nolen(PL_Sv); - const char c = pv[opts+76]; - pv[opts+76] = '\0'; - space = strrchr(pv+opts+26, ' '); - pv[opts+76] = c; - if (!space) break; /* "Can't happen" */ + const char *space; + char *pv = SvPV_nolen(opts_prog); + const char c = pv[opts+76]; + pv[opts+76] = '\0'; + space = strrchr(pv+opts+26, ' '); + pv[opts+76] = c; + if (!space) break; /* "Can't happen" */ - /* break the line before that space */ + /* break the line before that space */ - opts = space - pv; - sv_insert(PL_Sv, opts, 0, - "\\n ", 25); - } + opts = space - pv; + sv_insert(opts_prog, opts, 0, + "\\n ", 25); + } - sv_catpv(PL_Sv,"\\n\","); + sv_catpv(opts_prog,"\\n\","); #if defined(LOCAL_PATCH_COUNT) - if (LOCAL_PATCH_COUNT > 0) { - int i; - sv_catpv(PL_Sv,"\" Locally applied patches:\\n\","); - for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { - if (PL_localpatches[i]) - Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,", - 0, PL_localpatches[i], 0); + if (LOCAL_PATCH_COUNT > 0) { + int i; + sv_catpv(opts_prog, + "\" Locally applied patches:\\n\","); + for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { + if (PL_localpatches[i]) + Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,", + 0, PL_localpatches[i], 0); + } } - } #endif - Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME); + Perl_sv_catpvf(aTHX_ opts_prog, + "\" Built under %s\\n\"",OSNAME); #ifdef __DATE__ # ifdef __TIME__ - Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__); + Perl_sv_catpvf(aTHX_ opts_prog, + ",\" Compiled at %s %s\\n\"",__DATE__, + __TIME__); # else - Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__); + Perl_sv_catpvf(aTHX_ opts_prog,",\" Compiled on %s\\n\"", + __DATE__); # endif #endif - sv_catpv(PL_Sv, "; \ -$\"=\"\\n \"; \ -@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; "); + sv_catpv(opts_prog, "; $\"=\"\\n \"; " + "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } " + "sort grep {/^PERL/} keys %ENV; "); #ifdef __CYGWIN__ - sv_catpv(PL_Sv,"\ -push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";"); + sv_catpv(opts_prog, + "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";"); #endif - sv_catpv(PL_Sv, "\ -print \" \\%ENV:\\n @env\\n\" if @env; \ -print \" \\@INC:\\n @INC\\n\";"); - } - else { - ++s; - PL_Sv = Perl_newSVpvf(aTHX_ "config_vars(qw%c%s%c)", 0, s, 0); - s += strlen(s); + sv_catpv(opts_prog, + "print \" \\%ENV:\\n @env\\n\" if @env;" + "print \" \\@INC:\\n @INC\\n\";"); + } + else { + ++s; + opts_prog = Perl_newSVpvf(aTHX_ + "Config::config_vars(qw%c%s%c)", + 0, s, 0); + s += strlen(s); + } + av_push(PL_preambleav, opts_prog); + /* don't look for script or read stdin */ + scriptname = BIT_BUCKET; + goto reswitch; } - av_push(PL_preambleav, PL_Sv); - scriptname = BIT_BUCKET; /* don't look for script or read stdin */ - goto reswitch; case 'x': PL_doextract = TRUE; s++; @@ -1947,7 +2001,7 @@ print \" \\@INC:\\n @INC\\n\";"); # define SIGCHLD SIGCLD #endif Sighandler_t sigstate = rsignal_state(SIGCHLD); - if (sigstate == SIG_IGN) { + if (sigstate == (Sighandler_t) SIG_IGN) { if (ckWARN(WARN_SIGNAL)) Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "Can't ignore signal CHLD, forcing to default"); @@ -1975,7 +2029,7 @@ print \" \\@INC:\\n @INC\\n\";"); CvPADLIST(PL_compcv) = pad_new(0); #ifdef USE_5005THREADS CvOWNER(PL_compcv) = 0; - New(666, CvMUTEXP(PL_compcv), 1, perl_mutex); + Newx(CvMUTEXP(PL_compcv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(PL_compcv)); #endif /* USE_5005THREADS */ @@ -2184,8 +2238,10 @@ S_run_body(pTHX_ I32 oldscope) if (!PL_restartop) { DEBUG_x(dump_all()); +#ifdef DEBUGGING if (!DEBUG_q_TEST) PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); +#endif DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n", PTR2UV(thr))); @@ -2288,7 +2344,7 @@ set and the variable does not exist then NULL is returned. HV* Perl_get_hv(pTHX_ const char *name, I32 create) { - GV* gv = gv_fetchpv(name, create, SVt_PVHV); + GV* const gv = gv_fetchpv(name, create, SVt_PVHV); if (create) return GvHVn(gv); if (gv) @@ -2705,11 +2761,8 @@ Perl_require_pv(pTHX_ const char *pv) dSP; PUSHSTACKi(PERLSI_REQUIRE); PUTBACK; - sv = sv_newmortal(); - sv_setpv(sv, "require '"); - sv_catpv(sv, pv); - sv_catpv(sv, "'"); - eval_sv(sv, G_DISCARD); + sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0); + eval_sv(sv_2mortal(sv), G_DISCARD); SPAGAIN; POPSTACK; } @@ -2929,9 +2982,7 @@ Perl_moreswitches(pTHX_ char *s) sv_catpv(sv, start); else { sv_catpvn(sv, start, s-start); - sv_catpv(sv, " split(/,/,q{"); - sv_catpv(sv, ++s); - sv_catpv(sv, "})"); + Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0); } s += strlen(s); my_setenv("PERL5DB", SvPV_nolen_const(sv)); @@ -2959,8 +3010,7 @@ Perl_moreswitches(pTHX_ char *s) usage(PL_origargv[0]); my_exit(0); case 'i': - if (PL_inplace) - Safefree(PL_inplace); + Safefree(PL_inplace); #if defined(__CYGWIN__) /* do backup extension automagically */ if (*(s+1) == '\0') { PL_inplace = savepv(".bak"); @@ -3039,9 +3089,7 @@ Perl_moreswitches(pTHX_ char *s) sv_catpvn(sv, start, s-start); } if (*s == '=') { - sv_catpvn(sv, " split(/,/,q\0", 13); - sv_catpv(sv, s+1); - sv_catpvn(sv, "\0)", 2); + Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0); s+=strlen(s); } else if (*s != '\0') { @@ -4310,22 +4358,22 @@ Perl_init_stacks(pTHX) PL_stack_sp = PL_stack_base; PL_stack_max = PL_stack_base + AvMAX(PL_curstack); - New(50,PL_tmps_stack,REASONABLE(128),SV*); + Newx(PL_tmps_stack,REASONABLE(128),SV*); PL_tmps_floor = -1; PL_tmps_ix = -1; PL_tmps_max = REASONABLE(128); - New(54,PL_markstack,REASONABLE(32),I32); + Newx(PL_markstack,REASONABLE(32),I32); PL_markstack_ptr = PL_markstack; PL_markstack_max = PL_markstack + REASONABLE(32); SET_MARK_OFFSET; - New(54,PL_scopestack,REASONABLE(32),I32); + Newx(PL_scopestack,REASONABLE(32),I32); PL_scopestack_ix = 0; PL_scopestack_max = REASONABLE(32); - New(54,PL_savestack,REASONABLE(128),ANY); + Newx(PL_savestack,REASONABLE(128),ANY); PL_savestack_ix = 0; PL_savestack_max = REASONABLE(128); } @@ -4398,18 +4446,17 @@ S_init_predump_symbols(pTHX) PL_statname = NEWSV(66,0); /* last filename we did stat on */ - if (PL_osname) - Safefree(PL_osname); + Safefree(PL_osname); PL_osname = savepv(OSNAME); } void Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) { - char *s; argc--,argv++; /* skip name of script */ if (PL_doswitches) { for (; argc > 0 && **argv == '-'; argc--,argv++) { + char *s; if (!argv[0][1]) break; if (argv[0][1] == '-' && !argv[0][2]) { @@ -4429,7 +4476,7 @@ Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) (void)gv_AVadd(PL_argvgv); av_clear(GvAVn(PL_argvgv)); for (; argc > 0; argc--,argv++) { - SV *sv = newSVpv(argv[0],0); + SV * const sv = newSVpv(argv[0],0); av_push(GvAVn(PL_argvgv),sv); if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { if (PL_unicode & PERL_UNICODE_ARGV_FLAG) @@ -4749,11 +4796,11 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, * The intent is that /usr/local/bin/perl and .../../lib/perl5 * generates /usr/local/lib/perl5 */ - char *libpath = SvPVX(libdir); + const char *libpath = SvPVX(libdir); STRLEN libpath_len = SvCUR(libdir); if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) { /* Game on! */ - SV *caret_X = get_sv("\030", 0); + SV * const caret_X = get_sv("\030", 0); /* Going to use the SV just as a scratch buffer holding a C string: */ SV *prefix_sv; @@ -4909,7 +4956,7 @@ S_init_main_thread(pTHX) #endif XPV *xpv; - Newz(53, thr, 1, struct perl_thread); + Newxz(thr, 1, struct perl_thread); PL_curcop = &PL_compiling; thr->interp = PERL_GET_INTERP; thr->cvcache = newHV(); @@ -4919,8 +4966,8 @@ S_init_main_thread(pTHX) thr->flags = THRf_R_JOINABLE; MUTEX_INIT(&thr->mutex); /* Handcraft thrsv similarly to mess_sv */ - New(53, PL_thrsv, 1, SV); - Newz(53, xpv, 1, XPV); + Newx(PL_thrsv, 1, SV); + Newxz(xpv, 1, XPV); SvFLAGS(PL_thrsv) = SVt_PV; SvANY(PL_thrsv) = (void*)xpv; SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */