X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=302faf108897324c15ff773776e83f0fd5784a51;hb=02c473a9139e94d6158d1e3dd9a912f3525b3b21;hp=3375099f79ce61734a55ba5b538a67586c14ff19;hpb=86207487601861597b08158d7469c885a14adc49;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 3375099..302faf1 100644 --- a/perl.c +++ b/perl.c @@ -12,6 +12,12 @@ * "A ship then new they built for him/of mithril and of elven glass" --Bilbo */ +/* This file contains the top-level functions that are used to create, use + * and destroy a perl interpreter, plus the functions used by XS code to + * call back into perl. Note that it does not contain the actual main() + * function of the interpreter; that can be found in perlmain.c + */ + /* PSz 12 Nov 03 * * Be proud that perl(1) may proclaim: @@ -190,8 +196,7 @@ perl_alloc(void) my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); INIT_TLS_AND_INTERP; - Zero(my_perl, 1, PerlInterpreter); - return my_perl; + return ZeroD(my_perl, 1, PerlInterpreter); } #endif /* PERL_IMPLICIT_SYS */ @@ -232,11 +237,15 @@ perl_construct(pTHXx) SvREFCNT(&PL_sv_undef) = (~(U32)0)/2; sv_setpv(&PL_sv_no,PL_No); + /* value lookup in void context - happens to have the side effect + of caching the numeric forms. */ + SvIV(&PL_sv_no); SvNV(&PL_sv_no); SvREADONLY_on(&PL_sv_no); SvREFCNT(&PL_sv_no) = (~(U32)0)/2; sv_setpv(&PL_sv_yes,PL_Yes); + SvIV(&PL_sv_yes); SvNV(&PL_sv_yes); SvREADONLY_on(&PL_sv_yes); SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; @@ -262,28 +271,6 @@ perl_construct(pTHXx) init_i18nl10n(1); SET_NUMERIC_STANDARD(); - { - U8 *s; - PL_patchlevel = NEWSV(0,4); - (void)SvUPGRADE(PL_patchlevel, SVt_PVNV); - if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127) - SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1); - s = (U8*)SvPVX(PL_patchlevel); - /* Build version strings using "native" characters */ - s = uvchr_to_utf8(s, (UV)PERL_REVISION); - s = uvchr_to_utf8(s, (UV)PERL_VERSION); - s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION); - *s = '\0'; - SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel)); - SvPOK_on(PL_patchlevel); - SvNVX(PL_patchlevel) = (NV)PERL_REVISION + - ((NV)PERL_VERSION / (NV)1000) + - ((NV)PERL_SUBVERSION / (NV)1000000); - SvNOK_on(PL_patchlevel); /* dual valued */ - SvUTF8_on(PL_patchlevel); - SvREADONLY_on(PL_patchlevel); - } - #if defined(LOCAL_PATCH_COUNT) PL_localpatches = local_patches; /* For possible -v */ #endif @@ -329,8 +316,9 @@ perl_construct(pTHXx) #endif /* Use sysconf(_SC_CLK_TCK) if available, if not - * available or if the sysconf() fails, use the HZ. */ -#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) + * available or if the sysconf() fails, use the HZ. + * BeOS has those, but returns the wrong value. */ +#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__) PL_clocktick = sysconf(_SC_CLK_TCK); if (PL_clocktick <= 0) #endif @@ -338,6 +326,13 @@ perl_construct(pTHXx) PL_stashcache = newHV(); + PL_patchlevel = newSVpv( + Perl_form(aTHX_ "%d.%d.%d", + (int)PERL_REVISION, + (int)PERL_VERSION, + (int)PERL_SUBVERSION ), 0 + ); + ENTER; } @@ -477,7 +472,7 @@ perl_destruct(pTHXx) */ #ifndef PERL_MICRO #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV) - if (environ != PL_origenviron + if (environ != PL_origenviron && !PL_use_safe_putenv #ifdef USE_ITHREADS /* only main thread can free environ[0] contents */ && PL_curinterp == aTHX @@ -497,6 +492,9 @@ perl_destruct(pTHXx) #endif #endif /* !PERL_MICRO */ + /* reset so print() ends up where we expect */ + setdefout(Nullgv); + #ifdef USE_ITHREADS /* the syntax tree is shared between clones * so op_free(PL_main_root) only ReREFCNT_dec's @@ -638,9 +636,6 @@ perl_destruct(pTHXx) PL_dbargs = Nullav; PL_debstash = Nullhv; - /* reset so print() ends up where we expect */ - setdefout(Nullgv); - SvREFCNT_dec(PL_argvout_stack); PL_argvout_stack = Nullav; @@ -847,9 +842,10 @@ perl_destruct(pTHXx) svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) != SVTYPEMASK) { - PerlIO_printf(Perl_debug_log, "leaked: 0x%p" - pTHX__FORMAT "\n", - sv pTHX__VALUE); + PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p" + " flags=0x08%"UVxf + " refcnt=%"UVuf pTHX__FORMAT "\n", + sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE); } } } @@ -921,7 +917,7 @@ perl_destruct(pTHXx) } } /* we know that type >= SVt_PV */ - (void)SvOOK_off(PL_mess_sv); + SvOOK_off(PL_mess_sv); Safefree(SvPVX(PL_mess_sv)); Safefree(SvANY(PL_mess_sv)); Safefree(PL_mess_sv); @@ -1364,7 +1360,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) 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\" \t%s\n\",",PL_localpatches[i]); + Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,", + 0, PL_localpatches[i], 0); } } #endif @@ -2051,7 +2048,6 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) ENTER; SAVETMPS; - push_return(Nullop); 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. */ @@ -2118,7 +2114,6 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) POPBLOCK(cx,newpm); POPEVAL(cx); - pop_return(); PL_curpm = newpm; LEAVE; } @@ -2211,6 +2206,10 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body), (OP*)&myop, TRUE); #else + /* fail now; otherwise we could fail after the JMPENV_PUSH but + * before a PUSHEVAL, which corrupts the stack after a croak */ + TAINT_PROPER("eval_sv()"); + JMPENV_PUSH(ret); #endif switch (ret) { @@ -2380,8 +2379,35 @@ NULL #ifdef DEBUGGING int -Perl_get_debug_opts(pTHX_ char **s) +Perl_get_debug_opts(pTHX_ char **s, bool givehelp) { + static char *usage_msgd[] = { + " Debugging flag values: (see also -d)", + " p Tokenizing and parsing (with v, displays parse stack)", + " s Stack snapshots (with v, displays all stacks)", + " l Context (loop) stack processing", + " t Trace execution", + " o Method and overloading resolution", + " c String/numeric conversions", + " P Print profiling info, preprocessor command for -P, source file input state", + " m Memory allocation", + " f Format processing", + " r Regular expression parsing and execution", + " x Syntax tree dump", + " u Tainting checks", + " H Hash dump -- usurps values()", + " X Scratchpad allocation", + " D Cleaning up", + " S Thread synchronization", + " T Tokenising", + " R Include reference counts of dumped variables (eg when using -Ds)", + " J Do not s,t,P-debug (Jump over) opcodes within package DB", + " v Verbose: use in conjunction with other flags", + " C Copy On Write", + " A Consistency checks on internal structures", + " q quiet - currently only suppresses the 'EXECUTING' message", + NULL + }; int i = 0; if (isALPHA(**s)) { /* if adding extra options, remember to update DEBUG_MASK */ @@ -2392,14 +2418,18 @@ Perl_get_debug_opts(pTHX_ char **s) if (d) i |= 1 << (d - debopts); else if (ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), - "invalid option -D%c\n", **s); + Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), + "invalid option -D%c, use -D'' to see choices\n", **s); } } - else { + else if (isDIGIT(**s)) { i = atoi(*s); for (; isALNUM(**s); (*s)++) ; } + else if (givehelp) { + char **p = usage_msgd; + while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++); + } # ifdef EBCDIC if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING)) Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), @@ -2480,6 +2510,13 @@ Perl_moreswitches(pTHX_ char *s) case 'd': forbid_setid("-d"); s++; + + /* -dt indicates to the debugger that threads will be used */ + if (*s == 't' && !isALNUM(s[1])) { + ++s; + my_setenv("PERL5DB_THREADED", "1"); + } + /* The following permits -d:Mod to accepts arguments following an = in the fashion that -MSome::Mod does. */ if (*s == ':' || *s == '=') { @@ -2510,11 +2547,11 @@ Perl_moreswitches(pTHX_ char *s) #ifdef DEBUGGING forbid_setid("-D"); s++; - PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG; + PL_debug = get_debug_opts(&s, 1) | DEBUG_TOP_FLAG; #else /* !DEBUGGING */ if (ckWARN_d(WARN_DEBUGGING)) Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), - "Recompile perl with -DDEBUGGING to use -D switch\n"); + "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n"); for (s++; isALNUM(*s); s++) ; #endif /*SUPPRESS 530*/ @@ -2642,7 +2679,7 @@ Perl_moreswitches(pTHX_ char *s) av_push(PL_preambleav, sv); } else - Perl_croak(aTHX_ "No space allowed after -%c", *(s-1)); + Perl_croak(aTHX_ "Missing argument to -%c", *(s-1)); return s; case 'n': PL_minus_n = TRUE; @@ -2679,14 +2716,18 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'v': + if (!sv_derived_from(PL_patchlevel, "version")) + (void *)upg_version(PL_patchlevel); #if !defined(DGUX) PerlIO_printf(PerlIO_stdout(), - Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s", - PL_patchlevel, ARCHNAME)); + Perl_form(aTHX_ "\nThis is perl, v%_ built for %s", + vstringify(PL_patchlevel), + ARCHNAME)); #else /* DGUX */ /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */ PerlIO_printf(PerlIO_stdout(), - Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel)); + Perl_form(aTHX_ "\nThis is perl, v%_\n", + vstringify(PL_patchlevel))); PerlIO_printf(PerlIO_stdout(), Perl_form(aTHX_ " built under %s at %s %s\n", OSNAME, __DATE__, __TIME__)); @@ -2775,7 +2816,7 @@ Perl may be copied only under the terms of either the Artistic License or the\n\ GNU General Public License, which may be found in the Perl 5 source kit.\n\n\ Complete documentation for Perl, including FAQ lists, should be found on\n\ this system using `man perl' or `perldoc perl'. If you have access to the\n\ -Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); +Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n"); my_exit(0); case 'w': if (! (PL_dowarn & G_WARN_ALL_MASK)) @@ -3094,9 +3135,9 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv) } #endif /* IAMSUID */ if (!PL_rsfp) { -/* PSz 16 Sep 03 Keep neat error message */ - Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", - CopFILE(PL_curcop), Strerror(errno)); + /* PSz 16 Sep 03 Keep neat error message */ + Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", + CopFILE(PL_curcop), Strerror(errno)); } } @@ -3387,7 +3428,8 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname) /* Sanity check on buffer end */ while ((*s) && !isSPACE(*s)) s++; for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 && - (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ; + (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_' + || s2[-1] == '-')); s2--) ; /* Sanity check on buffer start */ if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) && (s-9 < SvPV(PL_linestr,n_a)+2 || strnNE(s-9,"perl",4)) ) @@ -3674,7 +3716,8 @@ S_find_beginning(pTHX) s2 = s; while (*s == ' ' || *s == '\t') s++; if (*s++ == '-') { - while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--; + while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.' + || s2[-1] == '_') s2--; if (strnEQ(s2-4,"perl",4)) /*SUPPRESS 530*/ while ((s = moreswitches(s))) @@ -3860,10 +3903,6 @@ Perl_init_stacks(pTHX) New(54,PL_savestack,REASONABLE(128),ANY); PL_savestack_ix = 0; PL_savestack_max = REASONABLE(128); - - New(54,PL_retstack,REASONABLE(16),OP*); - PL_retstack_ix = 0; - PL_retstack_max = REASONABLE(16); } #undef REASONABLE @@ -3884,7 +3923,6 @@ S_nuke_stacks(pTHX) Safefree(PL_markstack); Safefree(PL_scopestack); Safefree(PL_savestack); - Safefree(PL_retstack); } STATIC void @@ -4014,6 +4052,22 @@ S_procself_val(pTHX_ SV *sv, char *arg0) #endif /* HAS_PROCSELFEXE */ STATIC void +S_set_caret_X(pTHX) { + GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */ + if (tmpgv) { +#ifdef HAS_PROCSELFEXE + S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]); +#else +#ifdef OS2 + sv_setpv(GvSV(tmpgv), os2_execname(aTHX)); +#else + sv_setpv(GvSV(tmpgv),PL_origargv[0]); +#endif +#endif + } +} + +STATIC void S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env) { char *s; @@ -4041,17 +4095,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register magicname("0", "0", 1); #endif } - if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */ -#ifdef HAS_PROCSELFEXE - S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]); -#else -#ifdef OS2 - sv_setpv(GvSV(tmpgv), os2_execname(aTHX)); -#else - sv_setpv(GvSV(tmpgv),PL_origargv[0]); -#endif -#endif - } + S_set_caret_X(aTHX); if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) { HV *hv; GvMULTI_on(PL_envgv); @@ -4074,9 +4118,10 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register { environ[0] = Nullch; } - if (env) + if (env) { + char** origenv = environ; for (; *env; env++) { - if (!(s = strchr(*env,'='))) + if (!(s = strchr(*env,'=')) || s == *env) continue; #if defined(MSDOS) && !defined(DJGPP) *s = '\0'; @@ -4087,7 +4132,13 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register (void)hv_store(hv, *env, s - *env, sv, 0); if (env != environ) mg_set(sv); + if (origenv != environ) { + /* realloc has shifted us */ + env = (env - origenv) + environ; + origenv = environ; + } } + } #endif /* USE_ENVIRON_ARRAY */ #endif /* !PERL_MICRO */ } @@ -4242,6 +4293,21 @@ S_init_perllib(pTHX) # define PERLLIB_MANGLE(s,n) (s) #endif +/* Push a directory onto @INC if it exists. + Generate a new SV if we do this, to save needing to copy the SV we push + onto @INC */ +STATIC SV * +S_incpush_if_exists(pTHX_ SV *dir) +{ + Stat_t tmpstatbuf; + if (PerlLIO_stat(SvPVX(dir), &tmpstatbuf) >= 0 && + S_ISDIR(tmpstatbuf.st_mode)) { + av_push(GvAVn(PL_incgv), dir); + dir = NEWSV(0,0); + } + return dir; +} + STATIC void S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep) { @@ -4251,7 +4317,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep) return; if (addsubdirs || addoldvers) { - subdir = sv_newmortal(); + subdir = NEWSV(0,0); } /* Break at all separators */ @@ -4297,7 +4363,6 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep) const char *incverlist[] = { PERL_INC_VERSION_LIST }; const char **incver; #endif - Stat_t tmpstatbuf; #ifdef VMS char *unix; STRLEN len; @@ -4327,23 +4392,18 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep) libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION, ARCHNAME); - if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && - S_ISDIR(tmpstatbuf.st_mode)) - av_push(GvAVn(PL_incgv), newSVsv(subdir)); + subdir = S_incpush_if_exists(aTHX_ subdir); /* .../version if -d .../version */ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION); - if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && - S_ISDIR(tmpstatbuf.st_mode)) - av_push(GvAVn(PL_incgv), newSVsv(subdir)); + subdir = S_incpush_if_exists(aTHX_ subdir); /* .../archname if -d .../archname */ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME); - if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && - S_ISDIR(tmpstatbuf.st_mode)) - av_push(GvAVn(PL_incgv), newSVsv(subdir)); + subdir = S_incpush_if_exists(aTHX_ subdir); + } #ifdef PERL_INC_VERSION_LIST @@ -4351,9 +4411,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep) for (incver = incverlist; *incver; incver++) { /* .../xxx if -d .../xxx */ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver); - if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && - S_ISDIR(tmpstatbuf.st_mode)) - av_push(GvAVn(PL_incgv), newSVsv(subdir)); + subdir = S_incpush_if_exists(aTHX_ subdir); } } #endif @@ -4362,6 +4420,10 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep) /* finally push this lib directory on the end of @INC */ av_push(GvAVn(PL_incgv), libdir); } + if (subdir) { + assert (SvREFCNT(subdir) == 1); + SvREFCNT_dec(subdir); + } } #ifdef USE_5005THREADS @@ -4583,7 +4645,7 @@ Perl_my_failure_exit(pTHX) STATUS_NATIVE_SET(44); } else { - if (!vaxc$errno && errno) /* unlikely */ + if (!vaxc$errno) /* unlikely */ STATUS_NATIVE_SET(44); else STATUS_NATIVE_SET(vaxc$errno);