X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4f185743967f505b05e12dd7c1e03858a874cc02..8ee4cf2435c265a68309f8b98520e063bbdc8e42:/perl.c diff --git a/perl.c b/perl.c index 3e7ccde..a8fd47f 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,14 +137,6 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); #endif #endif -#ifndef NO_MATHOMS -/* This reference ensure that the mathoms are linked with perl */ -void Perl_mathoms_ref() { - extern void Perl_mathoms(); - Perl_mathoms(); -} -#endif - static void S_init_tls_and_interp(PerlInterpreter *my_perl) { @@ -156,8 +148,12 @@ S_init_tls_and_interp(PerlInterpreter *my_perl) ALLOC_THREAD_KEY; PERL_SET_THX(my_perl); OP_REFCNT_INIT; + HINTS_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); @@ -186,6 +182,7 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, PL_Dir = ipD; PL_Sock = ipS; PL_Proc = ipP; + INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl); return my_perl; } @@ -210,7 +207,13 @@ perl_alloc(void) my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); S_init_tls_and_interp(my_perl); +#ifndef PERL_TRACK_MEMPOOL return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter); +#else + Zero(my_perl, 1, PerlInterpreter); + INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl); + return my_perl; +#endif } #endif /* PERL_IMPLICIT_SYS */ @@ -226,7 +229,7 @@ void perl_construct(pTHXx) { dVAR; - PERL_UNUSED_ARG(my_perl); + PERL_UNUSED_CONTEXT; #ifdef MULTIPLICITY init_interp(); PL_perl_destruct_level = 1; @@ -238,7 +241,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)) { @@ -272,7 +275,7 @@ perl_construct(pTHXx) #endif } - PL_rs = newSVpvn("\n", 1); + PL_rs = newSVpvs("\n"); init_stacks(); @@ -297,7 +300,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. */ @@ -358,7 +361,7 @@ perl_construct(pTHXx) if ((long) PL_mmap_page_size < 0) { if (errno) { SV * const error = ERRSV; - (void) SvUPGRADE(error, SVt_PV); + SvUPGRADE(error, SVt_PV); Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error)); } else @@ -387,6 +390,10 @@ perl_construct(pTHXx) PL_timesbase.tms_cstime = 0; #endif +#ifdef PERL_MAD + PL_curforce = -1; +#endif + ENTER; } @@ -402,6 +409,7 @@ no threads. int Perl_nothreadhook(pTHX) { + PERL_UNUSED_CONTEXT; return 0; } @@ -521,7 +529,7 @@ perl_destruct(pTHXx) pid_t child; #endif - PERL_UNUSED_ARG(my_perl); + PERL_UNUSED_CONTEXT; /* wait for all pseudo-forked children to finish */ PERL_WAIT_FOR_CHILDREN; @@ -727,11 +735,11 @@ perl_destruct(pTHXx) PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1); } op_free(PL_main_root); - PL_main_root = Nullop; + PL_main_root = NULL; } - PL_main_start = Nullop; + PL_main_start = NULL; SvREFCNT_dec(PL_main_cv); - PL_main_cv = Nullcv; + PL_main_cv = NULL; PL_dirty = TRUE; /* Tell PerlIO we are about to tear things apart in case @@ -750,14 +758,14 @@ perl_destruct(pTHXx) sv_clean_objs(); PL_sv_objcount = 0; if (PL_defoutgv && !SvREFCNT(PL_defoutgv)) - PL_defoutgv = Nullgv; /* may have been freed */ + PL_defoutgv = NULL; /* may have been freed */ } /* unhook hooks which will soon be, or use, destroyed data */ SvREFCNT_dec(PL_warnhook); - PL_warnhook = Nullsv; + PL_warnhook = NULL; SvREFCNT_dec(PL_diehook); - PL_diehook = Nullsv; + PL_diehook = NULL; /* call exit list functions */ while (PL_exitlistlen-- > 0) @@ -808,7 +816,7 @@ perl_destruct(pTHXx) #endif /* !PERL_MICRO */ /* reset so print() ends up where we expect */ - setdefout(Nullgv); + setdefout(NULL); #ifdef USE_ITHREADS /* the syntax tree is shared between clones @@ -839,7 +847,7 @@ perl_destruct(pTHXx) } } SvREFCNT_dec(PL_regex_padav); - PL_regex_padav = Nullav; + PL_regex_padav = NULL; PL_regex_pad = NULL; #endif @@ -850,12 +858,12 @@ perl_destruct(pTHXx) if(PL_rsfp) { (void)PerlIO_close(PL_rsfp); - PL_rsfp = Nullfp; + PL_rsfp = NULL; } /* Filters for program text */ SvREFCNT_dec(PL_rsfp_filters); - PL_rsfp_filters = Nullav; + PL_rsfp_filters = NULL; /* switches */ PL_preprocess = FALSE; @@ -871,12 +879,12 @@ perl_destruct(pTHXx) PL_unsafe = FALSE; Safefree(PL_inplace); - PL_inplace = Nullch; + PL_inplace = NULL; SvREFCNT_dec(PL_patchlevel); if (PL_e_script) { SvREFCNT_dec(PL_e_script); - PL_e_script = Nullsv; + PL_e_script = NULL; } PL_perldb = 0; @@ -884,27 +892,26 @@ perl_destruct(pTHXx) /* magical thingies */ SvREFCNT_dec(PL_ofs_sv); /* $, */ - PL_ofs_sv = Nullsv; + PL_ofs_sv = NULL; SvREFCNT_dec(PL_ors_sv); /* $\ */ - PL_ors_sv = Nullsv; + PL_ors_sv = NULL; SvREFCNT_dec(PL_rs); /* $/ */ - PL_rs = Nullsv; + PL_rs = NULL; - PL_multiline = 0; /* $* */ Safefree(PL_osname); /* $^O */ - PL_osname = Nullch; + PL_osname = NULL; SvREFCNT_dec(PL_statname); - PL_statname = Nullsv; - PL_statgv = Nullgv; + PL_statname = NULL; + PL_statgv = NULL; /* defgv, aka *_ should be taken care of elsewhere */ /* clean up after study() */ SvREFCNT_dec(PL_lastscream); - PL_lastscream = Nullsv; + PL_lastscream = NULL; Safefree(PL_screamfirst); PL_screamfirst = 0; Safefree(PL_screamnext); @@ -912,7 +919,7 @@ perl_destruct(pTHXx) /* float buffer */ Safefree(PL_efloatbuf); - PL_efloatbuf = Nullch; + PL_efloatbuf = NULL; PL_efloatsize = 0; /* startup and shutdown function lists */ @@ -922,67 +929,67 @@ 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; - PL_incgv = Nullgv; - PL_hintgv = Nullgv; - PL_errgv = Nullgv; - PL_argvgv = Nullgv; - PL_argvoutgv = Nullgv; - PL_stdingv = Nullgv; - PL_stderrgv = Nullgv; - PL_last_in_gv = Nullgv; - PL_replgv = Nullgv; - PL_DBgv = Nullgv; - PL_DBline = Nullgv; - PL_DBsub = Nullgv; - PL_DBsingle = Nullsv; - PL_DBtrace = Nullsv; - PL_DBsignal = Nullsv; - PL_DBassertion = Nullsv; - PL_DBcv = Nullcv; - PL_dbargs = Nullav; - PL_debstash = Nullhv; + PL_envgv = NULL; + PL_incgv = NULL; + PL_hintgv = NULL; + PL_errgv = NULL; + PL_argvgv = NULL; + PL_argvoutgv = NULL; + PL_stdingv = NULL; + PL_stderrgv = NULL; + PL_last_in_gv = NULL; + PL_replgv = NULL; + PL_DBgv = NULL; + PL_DBline = NULL; + PL_DBsub = NULL; + PL_DBsingle = NULL; + PL_DBtrace = NULL; + PL_DBsignal = NULL; + PL_DBassertion = NULL; + PL_DBcv = NULL; + 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; + PL_subname = NULL; SvREFCNT_dec(PL_linestr); - PL_linestr = Nullsv; + PL_linestr = NULL; #ifdef PERL_USES_PL_PIDSTATUS SvREFCNT_dec(PL_pidstatus); - PL_pidstatus = Nullhv; + PL_pidstatus = NULL; #endif SvREFCNT_dec(PL_toptarget); - PL_toptarget = Nullsv; + PL_toptarget = NULL; SvREFCNT_dec(PL_bodytarget); - PL_bodytarget = Nullsv; - PL_formtarget = Nullsv; + PL_bodytarget = NULL; + PL_formtarget = NULL; /* free locale stuff */ #ifdef USE_LOCALE_COLLATE Safefree(PL_collation_name); - PL_collation_name = Nullch; + PL_collation_name = NULL; #endif #ifdef USE_LOCALE_NUMERIC Safefree(PL_numeric_name); - PL_numeric_name = Nullch; + PL_numeric_name = NULL; SvREFCNT_dec(PL_numeric_radix_sv); - PL_numeric_radix_sv = Nullsv; + PL_numeric_radix_sv = NULL; #endif /* clear utf8 character classes */ @@ -1006,33 +1013,35 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_utf8_tofold); SvREFCNT_dec(PL_utf8_idstart); SvREFCNT_dec(PL_utf8_idcont); - PL_utf8_alnum = Nullsv; - PL_utf8_alnumc = Nullsv; - PL_utf8_ascii = Nullsv; - PL_utf8_alpha = Nullsv; - PL_utf8_space = Nullsv; - PL_utf8_cntrl = Nullsv; - PL_utf8_graph = Nullsv; - PL_utf8_digit = Nullsv; - PL_utf8_upper = Nullsv; - PL_utf8_lower = Nullsv; - PL_utf8_print = Nullsv; - PL_utf8_punct = Nullsv; - PL_utf8_xdigit = Nullsv; - PL_utf8_mark = Nullsv; - PL_utf8_toupper = Nullsv; - PL_utf8_totitle = Nullsv; - PL_utf8_tolower = Nullsv; - PL_utf8_tofold = Nullsv; - PL_utf8_idstart = Nullsv; - PL_utf8_idcont = Nullsv; + PL_utf8_alnum = NULL; + PL_utf8_alnumc = NULL; + PL_utf8_ascii = NULL; + PL_utf8_alpha = NULL; + PL_utf8_space = NULL; + PL_utf8_cntrl = NULL; + PL_utf8_graph = NULL; + PL_utf8_digit = NULL; + PL_utf8_upper = NULL; + PL_utf8_lower = NULL; + PL_utf8_print = NULL; + PL_utf8_punct = NULL; + PL_utf8_xdigit = NULL; + PL_utf8_mark = NULL; + PL_utf8_toupper = NULL; + PL_utf8_totitle = NULL; + PL_utf8_tolower = NULL; + PL_utf8_tofold = NULL; + PL_utf8_idstart = NULL; + PL_utf8_idcont = NULL; if (!specialWARN(PL_compiling.cop_warnings)) - SvREFCNT_dec(PL_compiling.cop_warnings); - PL_compiling.cop_warnings = Nullsv; + PerlMemShared_free(PL_compiling.cop_warnings); + PL_compiling.cop_warnings = NULL; if (!specialCopIO(PL_compiling.cop_io)) SvREFCNT_dec(PL_compiling.cop_io); - PL_compiling.cop_io = Nullsv; + PL_compiling.cop_io = NULL; + Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints); + PL_compiling.cop_hints = NULL; CopFILE_free(&PL_compiling); CopSTASH_free(&PL_compiling); @@ -1042,11 +1051,11 @@ perl_destruct(pTHXx) PL_defstash = 0; SvREFCNT_dec(hv); SvREFCNT_dec(PL_curstname); - PL_curstname = Nullsv; + PL_curstname = NULL; /* clear queued errors */ SvREFCNT_dec(PL_errors); - PL_errors = Nullsv; + PL_errors = NULL; FREETMPS; if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) { @@ -1081,7 +1090,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(); @@ -1105,7 +1114,7 @@ perl_destruct(pTHXx) HE * const next = HeNEXT(hent); Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Unbalanced string table refcount: (%ld) for \"%s\"", - (long)(HeVAL(hent) - Nullsv), HeKEY(hent)); + (long)hent->he_valu.hent_refcount, HeKEY(hent)); Safefree(hent); hent = next; } @@ -1211,14 +1220,14 @@ perl_destruct(pTHXx) #endif /* sv_undef needs to stay immortal until after PerlIO_cleanup - as currently layers use it rather than Nullsv as a marker + as currently layers use it rather than NULL as a marker for no arg - and will try and SvREFCNT_dec it. */ SvREFCNT(&PL_sv_undef) = 0; SvREADONLY_off(&PL_sv_undef); Safefree(PL_origfilename); - PL_origfilename = Nullch; + PL_origfilename = NULL; Safefree(PL_reg_start_tmp); PL_reg_start_tmp = (char**)NULL; PL_reg_start_tmpl = 0; @@ -1231,10 +1240,10 @@ perl_destruct(pTHXx) Safefree(PL_psig_name); PL_psig_name = (SV**)NULL; Safefree(PL_bitcount); - PL_bitcount = Nullch; + PL_bitcount = NULL; Safefree(PL_psig_pend); PL_psig_pend = (int*)NULL; - PL_formfeed = Nullsv; + PL_formfeed = NULL; nuke_stacks(); PL_tainting = FALSE; PL_taint_warn = FALSE; @@ -1249,6 +1258,12 @@ perl_destruct(pTHXx) sv_free_arenas(); + while (PL_regmatch_slab) { + regmatch_slab *s = PL_regmatch_slab; + PL_regmatch_slab = PL_regmatch_slab->next; + Safefree(s); + } + /* As the absolutely last thing, free the non-arena SV for mess() */ if (PL_mess_sv) { @@ -1269,7 +1284,7 @@ perl_destruct(pTHXx) SvPV_free(PL_mess_sv); Safefree(SvANY(PL_mess_sv)); Safefree(PL_mess_sv); - PL_mess_sv = Nullsv; + PL_mess_sv = NULL; } return STATUS_EXIT; } @@ -1285,19 +1300,37 @@ Releases a Perl interpreter. See L. void perl_free(pTHXx) { +#ifdef PERL_TRACK_MEMPOOL + { + /* + * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero + * value as we're probably hunting memory leaks then + */ + const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); + if (!s || atoi(s) == 0) { + /* Emulate the PerlHost behaviour of free()ing all memory allocated in this + thread at thread exit. */ + while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)) + safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next)); + } + } +#endif + #if defined(WIN32) || defined(NETWARE) # if defined(PERL_IMPLICIT_SYS) + { # ifdef NETWARE - void *host = nw_internal_host; + void *host = nw_internal_host; # else - void *host = w32_internal_host; + void *host = w32_internal_host; # endif - PerlMem_free(aTHXx); + PerlMem_free(aTHXx); # ifdef NETWARE - nw_delete_internal_host(host); + nw_delete_internal_host(host); # else - win32_delete_internal_host(host); + win32_delete_internal_host(host); # endif + } # else PerlMem_free(aTHXx); # endif @@ -1306,12 +1339,14 @@ perl_free(pTHXx) #endif } -#if defined(USE_5005THREADS) || defined(USE_ITHREADS) +#if defined(USE_ITHREADS) /* provide destructors to clean up the thread key when libperl is unloaded */ #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */ -#if defined(__hpux) && __ux_version > 1020 && !defined(__GNUC__) +#if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__) #pragma fini "perl_fini" +#elif defined(__sun) && !defined(__GNUC__) +#pragma fini (perl_fini) #endif static void @@ -1331,6 +1366,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; @@ -1374,7 +1410,8 @@ S_procself_val(pTHX_ SV *sv, const char *arg0) STATIC void S_set_caret_X(pTHX) { - GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */ + dVAR; + GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */ if (tmpgv) { #ifdef HAS_PROCSELFEXE S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]); @@ -1433,7 +1470,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() @@ -1481,7 +1521,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)) @@ -1498,7 +1538,7 @@ setuid perl scripts securely.\n"); s = PL_origenviron[0]; while (*s) s++; #endif - my_setenv("NoNe SuCh", Nullch); + my_setenv("NoNe SuCh", NULL); /* Force copy of environment. */ for (i = 1; PL_origenviron[i]; i++) { if (PL_origenviron[i] == s + 1 @@ -1517,7 +1557,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) { @@ -1538,11 +1578,11 @@ setuid perl scripts securely.\n"); if (PL_main_root) { op_free(PL_main_root); - PL_main_root = Nullop; + PL_main_root = NULL; } - PL_main_start = Nullop; + PL_main_start = NULL; SvREFCNT_dec(PL_main_cv); - PL_main_cv = Nullcv; + PL_main_cv = NULL; time(&PL_basetime); oldscope = PL_scopestack_ix; @@ -1589,15 +1629,13 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) const char *validarg = ""; register SV *sv; register char *s; - const char *cddir = Nullch; + const char *cddir = NULL; #ifdef USE_SITECUSTOMIZE bool minus_f = FALSE; #endif - 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(); @@ -1664,15 +1702,18 @@ 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 */ if (argv[1] && !strcmp(argv[1], "Dev:Pseudo")) break; #endif - forbid_setid("-e"); + forbid_setid('e', -1); if (!PL_e_script) { - PL_e_script = newSVpvn("",0); + PL_e_script = newSVpvs(""); filter_add(read_e_script, NULL); } if (*++s) @@ -1682,8 +1723,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': @@ -1694,29 +1735,29 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) goto reswitch; case 'I': /* -I handled both here and in moreswitches() */ - forbid_setid("-I"); - if (!*++s && (s=argv[1]) != Nullch) { + forbid_setid('I', -1); + if (!*++s && (s=argv[1]) != NULL) { argc--,argv++; } if (s && *s) { 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 Perl_croak(aTHX_ "No directory specified for -I"); break; case 'P': - forbid_setid("-P"); + forbid_setid('P', -1); PL_preprocess = TRUE; s++; goto reswitch; case 'S': - forbid_setid("-S"); + forbid_setid('S', -1); dosearch = TRUE; s++; goto reswitch; @@ -1727,15 +1768,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); @@ -1758,6 +1799,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 @@ -1770,6 +1814,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef PERL_IMPLICIT_SYS " PERL_IMPLICIT_SYS" # endif +# ifdef PERL_MAD + " PERL_MAD" +# endif # ifdef PERL_MALLOC_WRAP " PERL_MALLOC_WRAP" # endif @@ -1782,6 +1829,9 @@ 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 @@ -1791,15 +1841,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # 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 -# ifdef USE_5005THREADS - " USE_5005THREADS" -# endif # ifdef USE_64_BIT_ALL " USE_64_BIT_ALL" # endif @@ -1847,16 +1891,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]) @@ -1877,14 +1921,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\";"); } @@ -1945,7 +1989,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) PL_taint_warn = FALSE; } else { - char *popt_copy = Nullch; + char *popt_copy = NULL; while (s && *s) { char *d; while (isSPACE(*s)) @@ -1993,7 +2037,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #endif if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) { - PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize); + PL_compiling.cop_warnings + = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize); } if (!scriptname) @@ -2002,7 +2047,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) argc++,argv--; scriptname = BIT_BUCKET; /* don't look for script or read stdin */ } - else if (scriptname == Nullch) { + else if (scriptname == NULL) { #ifdef MSDOS if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) ) moreswitches("h"); @@ -2017,48 +2062,52 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) TAINT_NOT; init_perllib(); - open_script(scriptname,dosearch,sv); + { + int suidscript; + const int fdscript + = open_script(scriptname, dosearch, sv, &suidscript); - validate_suid(validarg, scriptname); + validate_suid(validarg, scriptname, fdscript, suidscript); #ifndef PERL_MICRO -#if defined(SIGCHLD) || defined(SIGCLD) - { -#ifndef SIGCHLD -# define SIGCHLD SIGCLD -#endif - Sighandler_t sigstate = rsignal_state(SIGCHLD); - if (sigstate == (Sighandler_t) SIG_IGN) { - if (ckWARN(WARN_SIGNAL)) - Perl_warner(aTHX_ packWARN(WARN_SIGNAL), - "Can't ignore signal CHLD, forcing to default"); - (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); +# if defined(SIGCHLD) || defined(SIGCLD) + { +# ifndef SIGCHLD +# define SIGCHLD SIGCLD +# endif + Sighandler_t sigstate = rsignal_state(SIGCHLD); + if (sigstate == (Sighandler_t) SIG_IGN) { + if (ckWARN(WARN_SIGNAL)) + Perl_warner(aTHX_ packWARN(WARN_SIGNAL), + "Can't ignore signal CHLD, forcing to default"); + (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); + } } - } -#endif +# endif #endif + if (PL_doextract #ifdef MACOS_TRADITIONAL - if (PL_doextract || gMacPerl_AlwaysExtract) { -#else - if (PL_doextract) { + || gMacPerl_AlwaysExtract #endif - find_beginning(); - if (cddir && PerlDir_chdir( (char *)cddir ) < 0) - Perl_croak(aTHX_ "Can't chdir to %s",cddir); + ) { + /* This will croak if suidscript is >= 0, as -x cannot be used with + setuid scripts. */ + forbid_setid('x', suidscript); + /* Hence you can't get here if suidscript >= 0 */ + + find_beginning(); + if (cddir && PerlDir_chdir( (char *)cddir ) < 0) + Perl_croak(aTHX_ "Can't chdir to %s",cddir); + } } - 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); CvPADLIST(PL_compcv) = pad_new(0); -#ifdef USE_5005THREADS - CvOWNER(PL_compcv) = 0; - Newx(CvMUTEXP(PL_compcv), 1, perl_mutex); - MUTEX_INIT(CvMUTEXP(PL_compcv)); -#endif /* USE_5005THREADS */ boot_core_PerlIO(); boot_core_UNIVERSAL(); @@ -2116,7 +2165,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) (fp = IoOFP(io))) PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) && - (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) { + (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL, + SVt_PV)))) { U32 in = PL_unicode & PERL_UNICODE_IN_FLAG; U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG; if (in) { @@ -2141,6 +2191,25 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s); } +#ifdef PERL_MAD + if ((s = PerlEnv_getenv("PERL_XMLDUMP"))) { + PL_madskills = 1; + PL_minus_c = 1; + if (!s || !s[0]) + PL_xmlfp = PerlIO_stdout(); + else { + PL_xmlfp = PerlIO_open(s, "w"); + if (!PL_xmlfp) + Perl_croak(aTHX_ "Can't open %s", s); + } + my_setenv("PERL_XMLDUMP", Nullch); /* hide from subprocs */ + } + if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) { + PL_madskills = atoi(s); + my_setenv("PERL_MADSKILLS", Nullch); /* hide from subprocs */ + } +#endif + init_lexer(); /* now parse the script */ @@ -2171,7 +2240,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) PL_preprocess = FALSE; if (PL_e_script) { SvREFCNT_dec(PL_e_script); - PL_e_script = Nullsv; + PL_e_script = NULL; } if (PL_do_undump) @@ -2207,11 +2276,12 @@ Tells a Perl interpreter to run. See L. int perl_run(pTHXx) { + dVAR; I32 oldscope; int ret = 0; dJMPENV; - PERL_UNUSED_ARG(my_perl); + PERL_UNUSED_CONTEXT; oldscope = PL_scopestack_ix; #ifdef VMS @@ -2260,10 +2330,17 @@ 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")); if (!PL_restartop) { +#ifdef PERL_MAD + if (PL_xmlfp) { + xmldump_all(); + exit(0); /* less likely to core dump than my_exit(0) */ + } +#endif DEBUG_x(dump_all()); #ifdef DEBUGGING if (!DEBUG_q_TEST) @@ -2320,17 +2397,10 @@ SV* Perl_get_sv(pTHX_ const char *name, I32 create) { GV *gv; -#ifdef USE_5005THREADS - if (name[1] == '\0' && !isALPHA(name[0])) { - PADOFFSET tmp = find_threadsv(name); - if (tmp != NOT_IN_PAD) - return THREADSV(tmp); - } -#endif /* USE_5005THREADS */ gv = gv_fetchpv(name, create, SVt_PV); if (gv) return GvSV(gv); - return Nullsv; + return NULL; } /* @@ -2353,7 +2423,7 @@ Perl_get_av(pTHX_ const char *name, I32 create) return GvAVn(gv); if (gv) return GvAV(gv); - return Nullav; + return NULL; } /* @@ -2376,7 +2446,7 @@ Perl_get_hv(pTHX_ const char *name, I32 create) return GvHVn(gv); if (gv) return GvHV(gv); - return Nullhv; + return NULL; } /* @@ -2403,11 +2473,10 @@ Perl_get_cv(pTHX_ const char *name, I32 create) if (create && !GvCVu(gv)) return newSUB(start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, newSVpv(name,0)), - Nullop, - Nullop); + NULL, NULL); if (gv) return GvCVu(gv); - return Nullcv; + return NULL; } /* Be sure to refetch the stack pointer after calling these routines. */ @@ -2429,6 +2498,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); @@ -2506,7 +2576,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) } Zero(&myop, 1, LOGOP); - myop.op_next = Nullop; + myop.op_next = NULL; if (!(flags & G_NOARGS)) myop.op_flags |= OPf_STACKED; myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID : @@ -2546,27 +2616,11 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) else { myop.op_other = (OP*)&myop; PL_markstack_ptr--; - /* we're trying to emulate pp_entertry() here */ - { - register PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; - - ENTER; - SAVETMPS; - - PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); - PUSHEVAL(cx, 0, 0); - PL_eval_root = PL_op; /* Only needed so that goto works right. */ - - PL_in_eval = EVAL_INEVAL; - if (flags & G_KEEPERR) - PL_in_eval |= EVAL_KEEPERR; - else - sv_setpvn(ERRSV,"",0); - } + create_eval_scope(flags|G_FAKINGEVAL); PL_markstack_ptr++; JMPENV_PUSH(ret); + switch (ret) { case 0: redo_body: @@ -2603,21 +2657,8 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) break; } - if (PL_scopestack_ix > oldscope) { - SV **newsp; - PMOP *newpm; - I32 gimme; - register PERL_CONTEXT *cx; - I32 optype; - - POPBLOCK(cx,newpm); - POPEVAL(cx); - PL_curpm = newpm; - LEAVE; - PERL_UNUSED_VAR(newsp); - PERL_UNUSED_VAR(gimme); - PERL_UNUSED_VAR(optype); - } + if (PL_scopestack_ix > oldscope) + delete_eval_scope(); JMPENV_POP; } @@ -2634,6 +2675,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 */ @@ -2659,6 +2701,7 @@ 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; @@ -2680,7 +2723,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) if (!(flags & G_NOARGS)) myop.op_flags = OPf_STACKED; - myop.op_next = Nullop; + myop.op_next = NULL; myop.op_type = OP_ENTEREVAL; myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID : (flags & G_ARRAY) ? OPf_WANT_LIST : @@ -2751,6 +2794,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); @@ -2784,8 +2828,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); @@ -2797,7 +2842,7 @@ Perl_require_pv(pTHX_ const char *pv) void Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen) { - register GV * const gv = gv_fetchpv(sym,TRUE, SVt_PV); + register GV * const gv = gv_fetchpv(sym, GV_ADD, SVt_PV); if (gv) sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen); @@ -2818,6 +2863,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)", @@ -2945,7 +2991,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); @@ -2958,7 +3004,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); @@ -2975,8 +3021,7 @@ Perl_moreswitches(pTHX_ char *s) PL_minus_F = TRUE; PL_splitstr = ++s; while (*s && !isSPACE(*s)) ++s; - *s = '\0'; - PL_splitstr = savepv(PL_splitstr); + PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr); return s; case 'a': PL_minus_a = TRUE; @@ -2987,7 +3032,7 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'd': - forbid_setid("-d"); + forbid_setid('d', -1); s++; /* -dt indicates to the debugger that threads will be used */ @@ -3000,7 +3045,7 @@ Perl_moreswitches(pTHX_ char *s) in the fashion that -MSome::Mod does. */ if (*s == ':' || *s == '=') { const char *start; - SV * const 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; @@ -3008,7 +3053,9 @@ Perl_moreswitches(pTHX_ char *s) sv_catpv(sv, start); else { sv_catpvn(sv, start, s-start); - Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0); + /* Don't use NUL as q// delimiter here, this string goes in the + * environment. */ + Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s); } s += strlen(s); my_setenv("PERL5DB", SvPV_nolen_const(sv)); @@ -3021,7 +3068,7 @@ Perl_moreswitches(pTHX_ char *s) case 'D': { #ifdef DEBUGGING - forbid_setid("-D"); + forbid_setid('D', -1); s++; PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG; #else /* !DEBUGGING */ @@ -3039,21 +3086,25 @@ 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__ */ - PL_inplace = savepv(s+1); - for (s = PL_inplace; *s && !isSPACE(*s); s++) - ; + { + const char * const start = ++s; + while (*s && !isSPACE(*s)) + ++s; + + PL_inplace = savepvn(start, s - start); + } if (*s) { - *s++ = '\0'; + ++s; if (*s == '-') /* Additional switches on #! line. */ - s++; + s++; } return s; case 'I': /* -I handled both here and in parse_body() */ - forbid_setid("-I"); + forbid_setid('I', -1); ++s; while (*s && isSPACE(*s)) ++s; @@ -3082,19 +3133,19 @@ Perl_moreswitches(pTHX_ char *s) s++; if (PL_ors_sv) { SvREFCNT_dec(PL_ors_sv); - PL_ors_sv = Nullsv; + PL_ors_sv = NULL; } 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); @@ -3102,16 +3153,16 @@ Perl_moreswitches(pTHX_ char *s) } return s; case 'A': - forbid_setid("-A"); + forbid_setid('A', -1); if (!PL_preambleav) PL_preambleav = newAV(); 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 == '=') { @@ -3125,10 +3176,10 @@ Perl_moreswitches(pTHX_ char *s) return s; } case 'M': - forbid_setid("-M"); /* XXX ? */ + forbid_setid('M', -1); /* XXX ? */ /* FALL THROUGH */ case 'm': - forbid_setid("-m"); /* XXX ? */ + forbid_setid('m', -1); /* XXX ? */ if (*++s) { char *start; SV *sv; @@ -3146,17 +3197,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) @@ -3175,7 +3226,7 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 's': - forbid_setid("-s"); + forbid_setid('s', -1); PL_doswitches = TRUE; s++; return s; @@ -3202,10 +3253,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 */ @@ -3231,7 +3286,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" @@ -3315,14 +3370,14 @@ Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n"); case 'W': PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; if (!specialWARN(PL_compiling.cop_warnings)) - SvREFCNT_dec(PL_compiling.cop_warnings); + PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = pWARN_ALL ; s++; return s; case 'X': PL_dowarn = G_WARN_ALL_OFF; if (!specialWARN(PL_compiling.cop_warnings)) - SvREFCNT_dec(PL_compiling.cop_warnings); + PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = pWARN_NONE ; s++; return s; @@ -3350,7 +3405,7 @@ Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n"); default: Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s); } - return Nullch; + return NULL; } /* compliments of Tom Christiansen */ @@ -3361,16 +3416,15 @@ 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; - SV* file; + SV * prog = newSVpv(BIN_EXP, 0); + SV * file = newSVpv(PL_origfilename, 0); int status = 1; extern int etext; - prog = newSVpv(BIN_EXP, 0); - sv_catpv(prog, "/perl"); - file = newSVpv(PL_origfilename, 0); - sv_catpv(file, ".perldump"); + sv_catpvs(prog, "/perl"); + sv_catpvs(file, ".perldump"); unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); /* unexec prints msg to stderr in case of failure */ @@ -3379,6 +3433,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 @@ -3389,26 +3445,19 @@ Perl_my_unexec(pTHX) STATIC void S_init_interp(pTHX) { - + dVAR; #ifdef MULTIPLICITY # define PERLVAR(var,type) # define PERLVARA(var,n,type) # if defined(PERL_IMPLICIT_CONTEXT) -# if defined(USE_5005THREADS) -# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; -# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; -# else /* !USE_5005THREADS */ -# define PERLVARI(var,type,init) aTHX->var = init; -# define PERLVARIC(var,type,init) aTHX->var = init; -# endif /* USE_5005THREADS */ +# define PERLVARI(var,type,init) aTHX->var = init; +# define PERLVARIC(var,type,init) aTHX->var = init; # else # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; # endif # include "intrpvar.h" -# ifndef USE_5005THREADS -# include "thrdvar.h" -# endif +# include "thrdvar.h" # undef PERLVAR # undef PERLVARA # undef PERLVARI @@ -3419,40 +3468,52 @@ S_init_interp(pTHX) # define PERLVARI(var,type,init) PL_##var = init; # define PERLVARIC(var,type,init) PL_##var = init; # include "intrpvar.h" -# ifndef USE_5005THREADS -# include "thrdvar.h" -# endif +# include "thrdvar.h" # undef PERLVAR # undef PERLVARA # undef PERLVARI # undef PERLVARIC #endif + /* As these are inside a structure, PERLVARI isn't capable of initialising + them */ + PL_regindent = 0; + PL_reg_oldcurpm = PL_reg_curpm = NULL; + PL_reg_poscache = PL_reg_starttry = NULL; } STATIC void S_init_main_stash(pTHX) { + dVAR; GV *gv; PL_curstash = PL_defstash = newHV(); - PL_curstname = newSVpvn("main",4); - gv = gv_fetchpv("main::",TRUE, SVt_PVHV); + /* 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_fetchpvs("main::", GV_ADD|GV_NOTQUAL, 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)); - 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 */ + GvHV(gv) = (HV*)SvREFCNT_inc_simple(PL_defstash); + SvREADONLY_on(gv); + PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL, + SVt_PVAV))); + SvREFCNT_inc_simple(PL_incgv); /* Don't allow it to be freed */ GvMULTI_on(PL_incgv); - PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */ + PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, 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); + PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV); + SvREFCNT_inc_simple(PL_defgv); + PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV)); + SvREFCNT_inc_simple(PL_errgv); GvMULTI_on(PL_errgv); - PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */ + PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */ GvMULTI_on(PL_replgv); (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */ #ifdef PERL_DONT_CREATE_GVSV @@ -3462,15 +3523,16 @@ S_init_main_stash(pTHX) sv_setpvn(ERRSV, "", 0); PL_curstash = PL_defstash; CopSTASH_set(&PL_compiling, PL_defstash); - PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); - PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV)); + PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV)); + PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI, + SVt_PVHV)); /* We must init $/ before switches are processed. */ sv_setpvn(get_sv("/", TRUE), "\n", 1); } -/* PSz 18 Nov 03 fdscript now global but do not change prototype */ -STATIC void -S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) +STATIC int +S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv, + int *suidscript) { #ifndef IAMSUID const char *quote; @@ -3478,13 +3540,13 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) const char *cpp_discard_flag; const char *perl; #endif + int fdscript = -1; dVAR; - PL_fdscript = -1; - PL_suidscript = -1; + *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 */ @@ -3492,7 +3554,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) { const char *s = scriptname + 8; - PL_fdscript = atoi(s); + fdscript = atoi(s); while (isDIGIT(*s)) s++; if (*s) { @@ -3505,7 +3567,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) * Is it a mistake to use a similar /dev/fd/ construct for * suidperl? */ - PL_suidscript = 1; + *suidscript = 1; /* PSz 20 Feb 04 * Be supersafe and do some sanity-checks. * Still, can we be sure we got the right thing? @@ -3527,8 +3589,8 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) CopFILE_set(PL_curcop, PL_origfilename); if (*PL_origfilename == '-' && PL_origfilename[1] == '\0') scriptname = (char *)""; - if (PL_fdscript >= 0) { - PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE); + if (fdscript >= 0) { + PL_rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE); # if defined(HAS_FCNTL) && defined(F_SETFD) if (PL_rsfp) /* ensure close-on-exec */ @@ -3548,14 +3610,14 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) * perl with that fd as it has always done. */ } - if (PL_suidscript != 1) { + if (*suidscript != 1) { Perl_croak(aTHX_ "suidperl needs (suid) fd script\n"); } #else /* IAMSUID */ else if (PL_preprocess) { const char * const cpp_cfg = CPPSTDIN; - SV * const cpp = newSVpvn("",0); - SV * const cmd = NEWSV(0,0); + 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"); @@ -3564,7 +3626,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 @@ -3619,7 +3681,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) SvREFCNT_dec(cpp); } else if (!*scriptname) { - forbid_setid("program input from stdin"); + forbid_setid(0, *suidscript); PL_rsfp = PerlIO_stdin(); } else { @@ -3639,6 +3701,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", CopFILE(PL_curcop), Strerror(errno)); } + return fdscript; } /* Mention @@ -3776,7 +3839,8 @@ S_fd_on_nosuid_fs(pTHX_ int fd) #endif /* IAMSUID */ STATIC void -S_validate_suid(pTHX_ const char *validarg, const char *scriptname) +S_validate_suid(pTHX_ const char *validarg, const char *scriptname, + int fdscript, int suidscript) { dVAR; #ifdef IAMSUID @@ -3818,9 +3882,10 @@ 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) + if (fdscript < 0 || suidscript != 1) Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */ /* PSz 11 Nov 03 * Since the script is opened by perl, not suidperl, some of these @@ -3915,15 +3980,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) == NULL) + 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++; @@ -3962,11 +4030,12 @@ 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 - if (PL_fdscript < 0 && + if (fdscript < 0 && PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) && PL_euid == PL_statbuf.st_uid) if (!PL_do_undump) @@ -3974,7 +4043,7 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname) FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); #endif /* IAMSUID */ - if (PL_fdscript < 0 && + if (fdscript < 0 && PL_euid) { /* oops, we're not the setuid root perl */ /* PSz 18 Feb 04 * When root runs a setuid script, we do not go through the same @@ -3987,7 +4056,7 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); * might run also non-setuid ones, and deserves what he gets. * * Or, we might drop the PL_euid check above (and rely just on - * PL_fdscript to avoid loops), and do the execs + * fdscript to avoid loops), and do the execs * even for root. */ #ifndef IAMSUID @@ -4095,7 +4164,7 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); #ifdef IAMSUID else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */ Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n"); - else if (PL_fdscript < 0 || PL_suidscript != 1) + else if (fdscript < 0 || suidscript != 1) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */ Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n"); else { @@ -4159,6 +4228,8 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n"); #endif /* IAMSUID */ #else /* !DOSUID */ + PERL_UNUSED_ARG(fdscript); + PERL_UNUSED_ARG(suidscript); if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */ @@ -4173,13 +4244,14 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); /* not set-id, must be wrapped */ } #endif /* DOSUID */ - (void)validarg; - (void)scriptname; + PERL_UNUSED_ARG(validarg); + PERL_UNUSED_ARG(scriptname); } STATIC void S_find_beginning(pTHX) { + dVAR; register char *s; register const char *s2; #ifdef MACOS_TRADITIONAL @@ -4188,12 +4260,11 @@ S_find_beginning(pTHX) /* skip forward in input to the real script? */ - forbid_setid("-x"); #ifdef MACOS_TRADITIONAL /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */ while (PL_doextract || gMacPerl_AlwaysExtract) { - if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { + if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == NULL) { if (!gMacPerl_AlwaysExtract) Perl_croak(aTHX_ "No Perl script found in input\n"); @@ -4210,7 +4281,7 @@ S_find_beginning(pTHX) } #else while (PL_doextract) { - if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) + if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == NULL) Perl_croak(aTHX_ "No Perl script found in input\n"); #endif s2 = s; @@ -4249,6 +4320,7 @@ S_find_beginning(pTHX) STATIC void S_init_ids(pTHX) { + dVAR; PL_uid = PerlProc_getuid(); PL_euid = PerlProc_geteuid(); PL_gid = PerlProc_getgid(); @@ -4308,14 +4380,27 @@ Perl_doing_taint(int argc, char *argv[], char *envp[]) return 0; } +/* Passing the flag as a single char rather than a string is a slight space + optimisation. The only message that isn't /^-.$/ is + "program input from stdin", which is substituted in place of '\0', which + could never be a command line flag. */ STATIC void -S_forbid_setid(pTHX_ const char *s) +S_forbid_setid(pTHX_ const char flag, const int suidscript) { + dVAR; + char string[3] = "-x"; + const char *message = "program input from stdin"; + + if (flag) { + string[1] = flag; + message = string; + } + #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW if (PL_euid != PL_uid) - Perl_croak(aTHX_ "No %s allowed while running setuid", s); + Perl_croak(aTHX_ "No %s allowed while running setuid", message); if (PL_egid != PL_gid) - Perl_croak(aTHX_ "No %s allowed while running setgid", s); + Perl_croak(aTHX_ "No %s allowed while running setgid", message); #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ /* PSz 29 Feb 04 * Checks for UID/GID above "wrong": why disallow @@ -4339,32 +4424,34 @@ S_forbid_setid(pTHX_ const char *s) * * Also see comments about root running a setuid script, elsewhere. */ - if (PL_suidscript >= 0) - Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s); + if (suidscript >= 0) + Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message); #ifdef IAMSUID /* PSz 11 Nov 03 Catch it in suidperl, always! */ - Perl_croak(aTHX_ "No %s allowed in suidperl", s); + Perl_croak(aTHX_ "No %s allowed in suidperl", message); #endif /* IAMSUID */ } void Perl_init_debugger(pTHX) { + dVAR; HV * const ostash = PL_curstash; PL_curstash = PL_debstash; - PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV)))); + PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", GV_ADDMULTI, + SVt_PVAV)))); AvREAL_off(PL_dbargs); - PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV); - PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV); - PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV)); - PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV))); + PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV); + PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV); + PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV)); + PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBsingle, 0); - PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV))); + PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBtrace, 0); - PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV))); + PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBsignal, 0); - PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV))); + PL_DBassertion = GvSV((gv_fetchpvs("DB::assertion", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBassertion, 0); PL_curstash = ostash; } @@ -4378,6 +4465,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)); @@ -4414,6 +4502,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) { @@ -4432,50 +4521,52 @@ S_nuke_stacks(pTHX) STATIC void S_init_lexer(pTHX) { + dVAR; PerlIO *tmpfp; tmpfp = PL_rsfp; - PL_rsfp = Nullfp; + PL_rsfp = NULL; 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; sv_setpvn(get_sv("\"", TRUE), " ", 1); - PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); + PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO); GvMULTI_on(PL_stdingv); io = GvIOp(PL_stdingv); IoTYPE(io) = IoTYPE_RDONLY; IoIFP(io) = PerlIO_stdin(); - tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV); + tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io); - tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO); + tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO); GvMULTI_on(tmpgv); io = GvIOp(tmpgv); IoTYPE(io) = IoTYPE_WRONLY; IoOFP(io) = IoIFP(io) = PerlIO_stdout(); setdefout(tmpgv); - tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV); + tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io); - PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); + PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO); GvMULTI_on(PL_stderrgv); io = GvIOp(PL_stderrgv); IoTYPE(io) = IoTYPE_WRONLY; IoOFP(io) = IoIFP(io) = PerlIO_stderr(); - tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV); + tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(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); @@ -4484,6 +4575,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++) { @@ -4495,14 +4587,15 @@ 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); + const char *const start_name = argv[0] + 1; + sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name, + TRUE, SVt_PV)), s + 1); } else - sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1); + sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1); } } - if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) { + if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) { GvMULTI_on(PL_argvgv); (void)gv_AVadd(PL_argvgv); av_clear(GvAVn(PL_argvgv)); @@ -4525,10 +4618,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; @@ -4537,7 +4630,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register init_argv_symbols(argc,argv); - if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) { + if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) { #ifdef MACOS_TRADITIONAL /* $0 is not majick on a Mac */ sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename)); @@ -4546,11 +4639,11 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register magicname("0", "0", 1); #endif } - if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) { + if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) { HV *hv; GvMULTI_on(PL_envgv); hv = GvHVn(PL_envgv); - hv_magic(hv, Nullgv, PERL_MAGIC_env); + hv_magic(hv, NULL, PERL_MAGIC_env); #ifndef PERL_MICRO #ifdef USE_ENVIRON_ARRAY /* Note that if the supplied env parameter is actually a copy @@ -4566,7 +4659,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register # endif ) { - environ[0] = Nullch; + environ[0] = NULL; } if (env) { char** origenv = environ; @@ -4595,7 +4688,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register #endif /* !PERL_MICRO */ } TAINT_NOT; - if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) { + if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) { SvREADONLY_off(GvSV(tmpgv)); sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); SvREADONLY_on(GvSV(tmpgv)); @@ -4616,6 +4709,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 @@ -4660,7 +4754,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) @@ -4704,7 +4798,8 @@ S_init_perllib(pTHX) # endif #endif -#ifdef SITELIB_STEM /* Search for version-specific dirs below here */ +#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST) + /* Search for version-specific dirs below here */ incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE); #endif @@ -4760,11 +4855,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; } @@ -4773,38 +4869,39 @@ STATIC void S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, bool canrelocate) { - SV *subdir = Nullsv; + dVAR; + SV *subdir = NULL; const char *p = dir; if (!p || !*p) 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++; } } - if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) { + if ( usesep && (s = strchr(p, PERLLIB_SEP)) != NULL ) { sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)), (STRLEN)(s - p)); p = s + 1; } else { sv_setpv(libdir, PERLLIB_MANGLE(p, 0)); - p = Nullch; /* break out */ + p = NULL; /* break out */ } #ifdef MACOS_TRADITIONAL if (!strchr(SvPVX(libdir), ':')) { @@ -4813,7 +4910,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 @@ -4928,7 +5025,7 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, char *unix; STRLEN len; - if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) { + if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) { len = strlen(unix); while (unix[len-1] == '/') len--; /* Cosmetic */ sv_usepvn(libdir,unix,len); @@ -4987,85 +5084,6 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, } } -#ifdef USE_5005THREADS -STATIC struct perl_thread * -S_init_main_thread(pTHX) -{ -#if !defined(PERL_IMPLICIT_CONTEXT) - struct perl_thread *thr; -#endif - XPV *xpv; - - Newxz(thr, 1, struct perl_thread); - PL_curcop = &PL_compiling; - thr->interp = PERL_GET_INTERP; - thr->cvcache = newHV(); - thr->threadsv = newAV(); - /* thr->threadsvp is set when find_threadsv is called */ - thr->specific = newAV(); - thr->flags = THRf_R_JOINABLE; - MUTEX_INIT(&thr->mutex); - /* Handcraft thrsv similarly to mess_sv */ - 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 */ - SvPV_set(PL_thrsvr, (char*)thr); - SvCUR_set(PL_thrsv, sizeof(thr)); - SvLEN_set(PL_thrsv, sizeof(thr)); - *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */ - thr->oursv = PL_thrsv; - PL_chopset = " \n-"; - PL_dumpindent = 4; - - MUTEX_LOCK(&PL_threads_mutex); - PL_nthreads++; - thr->tid = 0; - thr->next = thr; - thr->prev = thr; - thr->thr_done = 0; - MUTEX_UNLOCK(&PL_threads_mutex); - -#ifdef HAVE_THREAD_INTERN - Perl_init_thread_intern(thr); -#endif - -#ifdef SET_THREAD_SELF - SET_THREAD_SELF(thr); -#else - thr->self = pthread_self(); -#endif /* SET_THREAD_SELF */ - PERL_SET_THX(thr); - - /* - * These must come after the thread self setting - * because sv_setpvn does SvTAINT and the taint - * fields thread selfness being set. - */ - PL_toptarget = NEWSV(0,0); - sv_upgrade(PL_toptarget, SVt_PVFM); - sv_setpvn(PL_toptarget, "", 0); - PL_bodytarget = NEWSV(0,0); - sv_upgrade(PL_bodytarget, SVt_PVFM); - sv_setpvn(PL_bodytarget, "", 0); - PL_formtarget = PL_bodytarget; - thr->errsv = newSVpvn("", 0); - (void) find_threadsv("@"); /* Ensure $@ is initialised early */ - - PL_maxscream = -1; - PL_peepp = MEMBER_TO_FPTR(Perl_peep); - PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp); - PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags); - PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start); - PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string); - PL_regfree = MEMBER_TO_FPTR(Perl_pregfree); - PL_regindent = 0; - PL_reginterp_cnt = 0; - - return thr; -} -#endif /* USE_5005THREADS */ void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) @@ -5094,19 +5112,30 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) av_push(PL_checkav_save, (SV*)cv); } } else { - SAVEFREESV(cv); + if (!PL_madskills) + SAVEFREESV(cv); } JMPENV_PUSH(ret); switch (ret) { case 0: +#ifdef PERL_MAD + if (PL_madskills) + PL_madskills |= 16384; +#endif call_list_body(cv); +#ifdef PERL_MAD + if (PL_madskills) + PL_madskills &= ~16384; +#endif atsv = ERRSV; (void)SvPV_const(atsv, len); + if (PL_madskills && PL_minus_c && paramList == PL_beginav) + break; /* not really trying to run, so just wing it */ if (len) { 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", @@ -5131,6 +5160,8 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) PL_curcop = &PL_compiling; CopLINE_set(PL_curcop, oldline); JMPENV_POP; + if (PL_madskills && PL_minus_c && paramList == PL_beginav) + return; /* not really trying to run, so just wing it */ if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) { if (paramList == PL_beginav) Perl_croak(aTHX_ "BEGIN failed--compilation aborted"); @@ -5159,6 +5190,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; @@ -5167,6 +5199,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) { @@ -5186,6 +5219,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 @@ -5260,31 +5294,23 @@ STATIC void S_my_exit_jump(pTHX) { dVAR; - register PERL_CONTEXT *cx; - I32 gimme; - SV **newsp; if (PL_e_script) { SvREFCNT_dec(PL_e_script); - PL_e_script = Nullsv; + PL_e_script = NULL; } POPSTACK_TO(PL_mainstack); - if (cxstack_ix >= 0) { - if (cxstack_ix > 0) - dounwind(0); - POPBLOCK(cx,PL_curpm); - LEAVE; - } + dounwind(-1); + LEAVE_SCOPE(0); JMPENV_JUMP(2); - PERL_UNUSED_VAR(gimme); - PERL_UNUSED_VAR(newsp); } 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');