X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/82ba1be6639bfd31cc63b76f90d26dc1dafd9221..18b095192e336ba31465f4d3dab1ecc90871c3a9:/perl.c diff --git a/perl.c b/perl.c index d811879..186b85c 100644 --- a/perl.c +++ b/perl.c @@ -14,6 +14,7 @@ #include "EXTERN.h" #define PERL_IN_PERL_C #include "perl.h" +#include "patchlevel.h" /* for local_patches */ /* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD @@ -46,26 +47,74 @@ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen); #endif #ifdef PERL_OBJECT -CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd, - IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP) +#define perl_construct Perl_construct +#define perl_parse Perl_parse +#define perl_run Perl_run +#define perl_destruct Perl_destruct +#define perl_free Perl_free +#endif + +#ifdef PERL_IMPLICIT_SYS +PerlInterpreter * +perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, + struct IPerlMem* ipMP, struct IPerlEnv* ipE, + struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, + struct IPerlDir* ipD, struct IPerlSock* ipS, + struct IPerlProc* ipP) { - CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP); - if(pPerl != NULL) - pPerl->Init(); + PerlInterpreter *my_perl; +#ifdef PERL_OBJECT + my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, + ipLIO, ipD, ipS, ipP); + PERL_SET_INTERP(my_perl); +#else + /* New() needs interpreter, so call malloc() instead */ + my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); + PERL_SET_INTERP(my_perl); + Zero(my_perl, 1, PerlInterpreter); + PL_Mem = ipM; + PL_MemShared = ipMS; + PL_MemParse = ipMP; + PL_Env = ipE; + PL_StdIO = ipStd; + PL_LIO = ipLIO; + PL_Dir = ipD; + PL_Sock = ipS; + PL_Proc = ipP; +#endif - return pPerl; + return my_perl; } #else + +/* +=for apidoc perl_alloc + +Allocates a new Perl interpreter. See L. + +=cut +*/ + PerlInterpreter * perl_alloc(void) { PerlInterpreter *my_perl; - New(53, my_perl, 1, PerlInterpreter); + /* New() needs interpreter, so call malloc() instead */ + my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); PERL_SET_INTERP(my_perl); + Zero(my_perl, 1, PerlInterpreter); return my_perl; } -#endif /* PERL_OBJECT */ +#endif /* PERL_IMPLICIT_SYS */ + +/* +=for apidoc perl_construct + +Initializes a new Perl interpreter. See L. + +=cut +*/ void perl_construct(pTHXx) @@ -73,19 +122,22 @@ perl_construct(pTHXx) #ifdef USE_THREADS int i; #ifndef FAKE_THREADS - struct perl_thread *thr; + struct perl_thread *thr = NULL; #endif /* FAKE_THREADS */ #endif /* USE_THREADS */ #ifdef MULTIPLICITY - Zero(my_perl, 1, PerlInterpreter); + init_interp(); + PL_perl_destruct_level = 1; +#else + if (PL_perl_destruct_level > 0) + init_interp(); #endif /* Init the real globals (and main thread)? */ if (!PL_linestr) { -#ifdef USE_THREADS - INIT_THREADS; +#ifdef USE_THREADS #ifdef ALLOC_THREAD_KEY ALLOC_THREAD_KEY; #else @@ -158,13 +210,6 @@ perl_construct(pTHXx) PL_rs = SvREFCNT_inc(PL_nrs); init_stacks(); -#ifdef MULTIPLICITY - init_interp(); - PL_perl_destruct_level = 1; -#else - if (PL_perl_destruct_level > 0) - init_interp(); -#endif init_ids(); PL_lex_state = LEX_NOTPARSING; @@ -174,14 +219,30 @@ perl_construct(pTHXx) init_i18nl10n(1); SET_NUMERIC_STANDARD(); + + { + U8 *s; + PL_patchlevel = NEWSV(0,4); + SvUPGRADE(PL_patchlevel, SVt_PVNV); + if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127) + SvGROW(PL_patchlevel,24); + s = (U8*)SvPVX(PL_patchlevel); + s = uv_to_utf8(s, (UV)PERL_REVISION); + s = uv_to_utf8(s, (UV)PERL_VERSION); + s = uv_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) #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0 - sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION - + ((double) PERL_VERSION / (double) 1000) - + ((double) PERL_SUBVERSION / (double) 100000)); -#else - sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION + - ((double) PERL_VERSION / (double) 1000)); + + ((NV)PERL_SUBVERSION / (NV)1000000) #endif + ; + 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 */ @@ -192,14 +253,17 @@ perl_construct(pTHXx) PL_fdpid = newAV(); /* for remembering popen pids by fd */ PL_modglobal = newHV(); /* pointers to per-interpreter module globals */ - DEBUG( { - New(51,PL_debname,128,char); - New(52,PL_debdelim,128,char); - } ) - ENTER; } +/* +=for apidoc perl_destruct + +Shuts down a Perl interpreter. See L. + +=cut +*/ + void perl_destruct(pTHXx) { @@ -212,12 +276,15 @@ perl_destruct(pTHXx) dTHX; #endif /* USE_THREADS */ + /* wait for all pseudo-forked children to finish */ + PERL_WAIT_FOR_CHILDREN; + #ifdef USE_THREADS #ifndef FAKE_THREADS /* Pass 1 on any remaining threads: detach joinables, join zombies */ retry_cleanup: MUTEX_LOCK(&PL_threads_mutex); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: waiting for %d threads...\n", PL_nthreads - 1)); for (t = thr->next; t != thr; t = t->next) { @@ -225,7 +292,7 @@ perl_destruct(pTHXx) switch (ThrSTATE(t)) { AV *av; case THRf_ZOMBIE: - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: joining zombie %p\n", t)); ThrSETSTATE(t, THRf_DEAD); MUTEX_UNLOCK(&t->mutex); @@ -239,11 +306,11 @@ perl_destruct(pTHXx) MUTEX_UNLOCK(&PL_threads_mutex); JOIN(t, &av); SvREFCNT_dec((SV*)av); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: joined zombie %p OK\n", t)); goto retry_cleanup; case THRf_R_JOINABLE: - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: detaching thread %p\n", t)); ThrSETSTATE(t, THRf_R_DETACHED); /* @@ -257,7 +324,7 @@ perl_destruct(pTHXx) MUTEX_UNLOCK(&t->mutex); goto retry_cleanup; default: - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: ignoring %p (state %u)\n", t, ThrSTATE(t))); MUTEX_UNLOCK(&t->mutex); @@ -269,14 +336,14 @@ perl_destruct(pTHXx) /* Pass 2 on remaining threads: wait for the thread count to drop to one */ while (PL_nthreads > 1) { - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: final wait for %d threads\n", PL_nthreads - 1)); COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex); } /* At this point, we're the last thread */ MUTEX_UNLOCK(&PL_threads_mutex); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n")); + DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n")); MUTEX_DESTROY(&PL_threads_mutex); COND_DESTROY(&PL_nthreads_cond); #endif /* !defined(FAKE_THREADS) */ @@ -325,8 +392,6 @@ perl_destruct(pTHXx) PL_warnhook = Nullsv; SvREFCNT_dec(PL_diehook); PL_diehook = Nullsv; - SvREFCNT_dec(PL_parsehook); - PL_parsehook = Nullsv; /* call exit list functions */ while (PL_exitlistlen-- > 0) @@ -364,12 +429,11 @@ perl_destruct(pTHXx) PL_dowarn = G_WARN_OFF; PL_doextract = FALSE; PL_sawampersand = FALSE; /* must save all match strings */ - PL_sawstudy = FALSE; /* do fbm_instr on all strings */ - PL_sawvec = FALSE; PL_unsafe = FALSE; Safefree(PL_inplace); PL_inplace = Nullch; + SvREFCNT_dec(PL_patchlevel); if (PL_e_script) { SvREFCNT_dec(PL_e_script); @@ -406,34 +470,108 @@ perl_destruct(pTHXx) Safefree(PL_screamnext); PL_screamnext = 0; + /* float buffer */ + Safefree(PL_efloatbuf); + PL_efloatbuf = Nullch; + PL_efloatsize = 0; + /* startup and shutdown function lists */ SvREFCNT_dec(PL_beginav); SvREFCNT_dec(PL_endav); + SvREFCNT_dec(PL_checkav); SvREFCNT_dec(PL_initav); PL_beginav = Nullav; PL_endav = Nullav; + PL_checkav = Nullav; PL_initav = Nullav; /* shortcuts just get cleared */ PL_envgv = Nullgv; - PL_siggv = 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_debstash = Nullhv; /* reset so print() ends up where we expect */ setdefout(Nullgv); + SvREFCNT_dec(PL_argvout_stack); + PL_argvout_stack = Nullav; + + SvREFCNT_dec(PL_fdpid); + PL_fdpid = Nullav; + SvREFCNT_dec(PL_modglobal); + PL_modglobal = Nullhv; + SvREFCNT_dec(PL_preambleav); + PL_preambleav = Nullav; + SvREFCNT_dec(PL_subname); + PL_subname = Nullsv; + SvREFCNT_dec(PL_linestr); + PL_linestr = Nullsv; + SvREFCNT_dec(PL_pidstatus); + PL_pidstatus = Nullhv; + SvREFCNT_dec(PL_toptarget); + PL_toptarget = Nullsv; + SvREFCNT_dec(PL_bodytarget); + PL_bodytarget = Nullsv; + PL_formtarget = Nullsv; + + /* clear utf8 character classes */ + SvREFCNT_dec(PL_utf8_alnum); + SvREFCNT_dec(PL_utf8_alnumc); + SvREFCNT_dec(PL_utf8_ascii); + SvREFCNT_dec(PL_utf8_alpha); + SvREFCNT_dec(PL_utf8_space); + SvREFCNT_dec(PL_utf8_cntrl); + SvREFCNT_dec(PL_utf8_graph); + SvREFCNT_dec(PL_utf8_digit); + SvREFCNT_dec(PL_utf8_upper); + SvREFCNT_dec(PL_utf8_lower); + SvREFCNT_dec(PL_utf8_print); + SvREFCNT_dec(PL_utf8_punct); + SvREFCNT_dec(PL_utf8_xdigit); + SvREFCNT_dec(PL_utf8_mark); + SvREFCNT_dec(PL_utf8_toupper); + SvREFCNT_dec(PL_utf8_tolower); + 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; + + if (!specialWARN(PL_compiling.cop_warnings)) + SvREFCNT_dec(PL_compiling.cop_warnings); + PL_compiling.cop_warnings = Nullsv; + /* Prepare to destruct main symbol table. */ hv = PL_defstash; PL_defstash = 0; SvREFCNT_dec(hv); + SvREFCNT_dec(PL_curstname); + PL_curstname = Nullsv; + + /* clear queued errors */ + SvREFCNT_dec(PL_errors); + PL_errors = Nullsv; FREETMPS; if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) { @@ -500,10 +638,7 @@ perl_destruct(pTHXx) sv_free_arenas(); /* No SVs have survived, need to clean out */ - PL_linestr = NULL; - PL_pidstatus = Nullhv; Safefree(PL_origfilename); - Safefree(PL_archpat_auto); Safefree(PL_reg_start_tmp); if (PL_reg_curpm) Safefree(PL_reg_curpm); @@ -554,13 +689,21 @@ perl_destruct(pTHXx) } } +/* +=for apidoc perl_free + +Releases a Perl interpreter. See L. + +=cut +*/ + void perl_free(pTHXx) { #if defined(PERL_OBJECT) - Safefree(this); + PerlMem_free(this); #else - Safefree(aTHXx); + PerlMem_free(aTHXx); #endif } @@ -573,12 +716,21 @@ Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr) ++PL_exitlistlen; } +/* +=for apidoc perl_parse + +Tells a Perl interpreter to parse a Perl script. See L. + +=cut +*/ + int perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) { dTHR; I32 oldscope; int ret; + dJMPENV; #ifdef USE_THREADS dTHX; #endif @@ -627,9 +779,12 @@ setuid perl scripts securely.\n"); oldscope = PL_scopestack_ix; PL_dowarn = G_WARN_OFF; - CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_parse_body), env, xsinit); + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body), + env, xsinit); switch (ret) { case 0: + if (PL_checkav) + call_list(oldscope, PL_checkav); return 0; case 1: STATUS_ALL_FAILURE; @@ -640,11 +795,11 @@ setuid perl scripts securely.\n"); LEAVE; FREETMPS; PL_curstash = PL_defstash; - if (PL_endav) - call_list(oldscope, PL_endav); + if (PL_checkav) + call_list(oldscope, PL_checkav); return STATUS_NATIVE_EXPORT; case 3: - PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); + PerlIO_printf(Perl_error_log, "panic: top_env\n"); return 1; } return 0; @@ -664,6 +819,7 @@ S_parse_body(pTHX_ va_list args) AV* comppadlist; register SV *sv; register char *s; + char *cddir = Nullch; XSINIT_t xsinit = va_arg(args, XSINIT_t); @@ -740,18 +896,18 @@ S_parse_body(pTHX_ va_list args) if (!*++s && (s=argv[1]) != Nullch) { argc--,argv++; } - while (s && isSPACE(*s)) - ++s; if (s && *s) { - char *e, *p; - for (e = s; *e && !isSPACE(*e); e++) ; - p = savepvn(s, e-s); + char *p; + STRLEN len = strlen(s); + p = savepvn(s, len); incpush(p, TRUE); - sv_catpv(sv,"-I"); - sv_catpv(sv,p); - sv_catpv(sv," "); + sv_catpvn(sv, "-I", 2); + sv_catpvn(sv, p, len); + sv_catpvn(sv, " ", 1); Safefree(p); - } /* XXX else croak? */ + } + else + Perl_croak(aTHX_ "No directory specified for -I"); break; case 'P': forbid_setid("-P"); @@ -774,7 +930,6 @@ S_parse_body(pTHX_ va_list args) #else sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\","); #endif -#if defined(DEBUGGING) || defined(MULTIPLICITY) sv_catpv(PL_Sv,"\" Compile-time options:"); # ifdef DEBUGGING sv_catpv(PL_Sv," DEBUGGING"); @@ -782,8 +937,35 @@ S_parse_body(pTHX_ va_list args) # ifdef MULTIPLICITY sv_catpv(PL_Sv," MULTIPLICITY"); # endif +# ifdef USE_THREADS + sv_catpv(PL_Sv," USE_THREADS"); +# endif +# ifdef USE_ITHREADS + sv_catpv(PL_Sv," USE_ITHREADS"); +# endif +# ifdef USE_64_BITS + sv_catpv(PL_Sv," USE_64_BITS"); +# endif +# ifdef USE_LONG_DOUBLE + sv_catpv(PL_Sv," USE_LONG_DOUBLE"); +# endif +# ifdef USE_LARGE_FILES + sv_catpv(PL_Sv," USE_LARGE_FILES"); +# endif +# ifdef USE_SOCKS + sv_catpv(PL_Sv," USE_SOCKS"); +# endif +# ifdef PERL_OBJECT + sv_catpv(PL_Sv," PERL_OBJECT"); +# endif +# ifdef PERL_IMPLICIT_CONTEXT + sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT"); +# endif +# ifdef PERL_IMPLICIT_SYS + sv_catpv(PL_Sv," PERL_IMPLICIT_SYS"); +# endif sv_catpv(PL_Sv,"\\n\","); -#endif + #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) { int i; @@ -821,7 +1003,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_doextract = TRUE; s++; if (*s) - PL_cddir = savepv(s); + cddir = s; break; case 0: break; @@ -851,7 +1033,8 @@ print \" \\@INC:\\n @INC\\n\";"); #ifndef SECURE_INTERNAL_GETENV !PL_tainting && #endif - (s = PerlEnv_getenv("PERL5OPT"))) { + (s = PerlEnv_getenv("PERL5OPT"))) + { while (isSPACE(*s)) s++; if (*s == '-' && *(s+1) == 'T') @@ -894,8 +1077,27 @@ print \" \\@INC:\\n @INC\\n\";"); validate_suid(validarg, scriptname,fdscript); - if (PL_doextract) +#if defined(SIGCHLD) || defined(SIGCLD) + { +#ifndef SIGCHLD +# define SIGCHLD SIGCLD +#endif + Sighandler_t sigstate = rsignal_state(SIGCHLD); + if (sigstate == SIG_IGN) { + if (ckWARN(WARN_SIGNAL)) + Perl_warner(aTHX_ WARN_SIGNAL, + "Can't ignore signal CHLD, forcing to default"); + (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); + } + } +#endif + + if (PL_doextract) { find_beginning(); + if (cddir && PerlDir_chdir(cddir) < 0) + Perl_croak(aTHX_ "Can't chdir to %s",cddir); + + } PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)PL_compcv, SVt_PVCV); @@ -924,6 +1126,7 @@ print \" \\@INC:\\n @INC\\n\";"); CvPADLIST(PL_compcv) = comppadlist; boot_core_UNIVERSAL(); + boot_core_xsutils(); if (xsinit) (*xsinit)(aTHXo); /* in case linked C routines want magical variables */ @@ -956,7 +1159,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_origfilename); } } - PL_curcop->cop_line = 0; + CopLINE_set(PL_curcop, 0); PL_curstash = PL_defstash; PL_preprocess = FALSE; if (PL_e_script) { @@ -971,8 +1174,11 @@ print \" \\@INC:\\n @INC\\n\";"); if (PL_do_undump) my_unexec(); - if (isWARN_ONCE) + if (isWARN_ONCE) { + SAVECOPFILE(PL_curcop); + SAVECOPLINE(PL_curcop); gv_check(PL_defstash); + } LEAVE; FREETMPS; @@ -987,12 +1193,21 @@ print \" \\@INC:\\n @INC\\n\";"); return NULL; } +/* +=for apidoc perl_run + +Tells a Perl interpreter to run. See L. + +=cut +*/ + int perl_run(pTHXx) { dTHR; I32 oldscope; int ret; + dJMPENV; #ifdef USE_THREADS dTHX; #endif @@ -1000,7 +1215,7 @@ perl_run(pTHXx) oldscope = PL_scopestack_ix; redo_body: - CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_run_body), oldscope); + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope); switch (ret) { case 1: cxstack_ix = -1; /* start context stack again */ @@ -1011,7 +1226,7 @@ perl_run(pTHXx) LEAVE; FREETMPS; PL_curstash = PL_defstash; - if (PL_endav) + if (PL_endav && !PL_minus_c) call_list(oldscope, PL_endav); #ifdef MYMALLOC if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) @@ -1023,7 +1238,7 @@ perl_run(pTHXx) POPSTACK_TO(PL_mainstack); goto redo_body; } - PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); + PerlIO_printf(Perl_error_log, "panic: restartop\n"); FREETMPS; return 1; } @@ -1044,11 +1259,11 @@ S_run_body(pTHX_ va_list args) if (!PL_restartop) { DEBUG_x(dump_all()); DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); - DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n", - (unsigned long) thr)); + DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n", + PTR2UV(thr))); if (PL_minus_c) { - PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename); + PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); my_exit(0); } if (PERLDB_SINGLE && PL_DBsingle) @@ -1075,6 +1290,16 @@ S_run_body(pTHX_ va_list args) return NULL; } +/* +=for apidoc p||get_sv + +Returns the SV of the specified Perl scalar. If C is set and the +Perl variable does not exist then it will be created. If C is not +set and the variable does not exist then NULL is returned. + +=cut +*/ + SV* Perl_get_sv(pTHX_ const char *name, I32 create) { @@ -1094,6 +1319,16 @@ Perl_get_sv(pTHX_ const char *name, I32 create) return Nullsv; } +/* +=for apidoc p||get_av + +Returns the AV of the specified Perl array. If C is set and the +Perl variable does not exist then it will be created. If C is not +set and the variable does not exist then NULL is returned. + +=cut +*/ + AV* Perl_get_av(pTHX_ const char *name, I32 create) { @@ -1105,6 +1340,16 @@ Perl_get_av(pTHX_ const char *name, I32 create) return Nullav; } +/* +=for apidoc p||get_hv + +Returns the HV of the specified Perl hash. If C is set and the +Perl variable does not exist then it will be created. If C is not +set and the variable does not exist then NULL is returned. + +=cut +*/ + HV* Perl_get_hv(pTHX_ const char *name, I32 create) { @@ -1116,6 +1361,17 @@ Perl_get_hv(pTHX_ const char *name, I32 create) return Nullhv; } +/* +=for apidoc p||get_cv + +Returns the CV of the specified Perl subroutine. If C is set and +the Perl subroutine does not exist then it will be declared (which has the +same effect as saying C). If C is not set and the +subroutine does not exist then NULL is returned. + +=cut +*/ + CV* Perl_get_cv(pTHX_ const char *name, I32 create) { @@ -1136,6 +1392,14 @@ Perl_get_cv(pTHX_ const char *name, I32 create) /* Be sure to refetch the stack pointer after calling these routines. */ +/* +=for apidoc p||call_argv + +Performs a callback to the specified Perl sub. See L. + +=cut +*/ + I32 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) @@ -1155,6 +1419,14 @@ Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) return call_pv(sub_name, flags); } +/* +=for apidoc p||call_pv + +Performs a callback to the specified Perl sub. See L. + +=cut +*/ + I32 Perl_call_pv(pTHX_ const char *sub_name, I32 flags) /* name of the subroutine */ @@ -1163,6 +1435,15 @@ Perl_call_pv(pTHX_ const char *sub_name, I32 flags) return call_sv((SV*)get_cv(sub_name, TRUE), flags); } +/* +=for apidoc p||call_method + +Performs a callback to the specified Perl method. The blessed object must +be on the stack. See L. + +=cut +*/ + I32 Perl_call_method(pTHX_ const char *methname, I32 flags) /* name of the subroutine */ @@ -1181,6 +1462,15 @@ Perl_call_method(pTHX_ const char *methname, I32 flags) } /* May be called with any of a CV, a GV, or an SV containing the name. */ +/* +=for apidoc p||call_sv + +Performs a callback to the Perl sub whose name is in the SV. See +L. + +=cut +*/ + I32 Perl_call_sv(pTHX_ SV *sv, I32 flags) @@ -1194,6 +1484,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) bool oldcatch = CATCH_GET; int ret; OP* oldop = PL_op; + dJMPENV; if (flags & G_DISCARD) { ENTER; @@ -1228,7 +1519,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) CATCH_SET(TRUE); call_xbody((OP*)&myop, FALSE); retval = PL_stack_sp - (PL_stack_base + oldmark); - CATCH_SET(FALSE); + CATCH_SET(oldcatch); } else { cLOGOP->op_other = PL_op; @@ -1255,7 +1546,8 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) PL_markstack_ptr++; redo_body: - CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, FALSE); + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body), + (OP*)&myop, FALSE); switch (ret) { case 0: retval = PL_stack_sp - (PL_stack_base + oldmark); @@ -1269,7 +1561,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) /* my_exit() was called */ PL_curstash = PL_defstash; FREETMPS; - if (PL_statusvalue) + if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ @@ -1341,6 +1633,14 @@ S_call_xbody(pTHX_ OP *myop, int is_eval) /* Eval a string. The G_EVAL flag is always assumed. */ +/* +=for apidoc p||eval_sv + +Tells Perl to C the string in the SV. + +=cut +*/ + I32 Perl_eval_sv(pTHX_ SV *sv, I32 flags) @@ -1353,6 +1653,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) I32 oldscope; int ret; OP* oldop = PL_op; + dJMPENV; if (flags & G_DISCARD) { ENTER; @@ -1377,7 +1678,8 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) myop.op_flags |= OPf_SPECIAL; redo_body: - CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, TRUE); + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body), + (OP*)&myop, TRUE); switch (ret) { case 0: retval = PL_stack_sp - (PL_stack_base + oldmark); @@ -1391,7 +1693,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) /* my_exit() was called */ PL_curstash = PL_defstash; FREETMPS; - if (PL_statusvalue) + if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ @@ -1421,6 +1723,14 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) return retval; } +/* +=for apidoc p||eval_pv + +Tells Perl to C the given string and return an SV* result. + +=cut +*/ + SV* Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) { @@ -1445,6 +1755,14 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) /* Require a module. */ +/* +=for apidoc p||require_pv + +Tells Perl to C a module. + +=cut +*/ + void Perl_require_pv(pTHX_ const char *pv) { @@ -1522,7 +1840,7 @@ Perl_moreswitches(pTHX_ char *s) case '0': { dTHR; - rschar = scan_oct(s, 4, &numlen); + rschar = (U32)scan_oct(s, 4, &numlen); SvREFCNT_dec(PL_nrs); if (rschar & ~((U8)~0)) PL_nrs = &PL_sv_undef; @@ -1607,14 +1925,23 @@ Perl_moreswitches(pTHX_ char *s) ++s; if (*s) { char *e, *p; - for (e = s; *e && !isSPACE(*e); e++) ; - p = savepvn(s, e-s); - incpush(p, TRUE); - Safefree(p); - s = e; + p = s; + /* ignore trailing spaces (possibly followed by other switches) */ + do { + for (e = p; *e && !isSPACE(*e); e++) ; + p = e; + while (isSPACE(*p)) + p++; + } while (*p && *p != '-'); + e = savepvn(s, e-s); + incpush(e, TRUE); + Safefree(e); + s = p; + if (*s == '-') + s++; } else - Perl_croak(aTHX_ "No space allowed after -I"); + Perl_croak(aTHX_ "No directory specified for -I"); return s; case 'l': PL_minus_l = TRUE; @@ -1624,7 +1951,7 @@ Perl_moreswitches(pTHX_ char *s) if (isDIGIT(*s)) { PL_ors = savepv("\n"); PL_orslen = 1; - *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen); + *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen); s += numlen; } else { @@ -1667,7 +1994,7 @@ Perl_moreswitches(pTHX_ char *s) sv_catpv(sv, "})"); } s += strlen(s); - if (PL_preambleav == NULL) + if (!PL_preambleav) PL_preambleav = newAV(); av_push(PL_preambleav, sv); } @@ -1701,17 +2028,12 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'v': -#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0 - printf("\nThis is perl, version %d.%03d_%02d built for %s", - PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME); -#else - printf("\nThis is perl, version %s built for %s", - PL_patchlevel, ARCHNAME); -#endif + printf(Perl_form(aTHX_ "\nThis is perl, v%v built for %s", + PL_patchlevel, ARCHNAME)); #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) printf("\n(with %d registered patch%s, see perl -V for more detail)", - LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); + (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif printf("\n\nCopyright 1987-1999, Larry Wall\n"); @@ -1847,7 +2169,6 @@ S_init_interp(pTHX) PL_curcop = &PL_compiling;\ PL_curcopdb = NULL; \ PL_dbargs = 0; \ - PL_dlmax = 128; \ PL_dumpindent = 4; \ PL_laststatval = -1; \ PL_laststype = OP_STAT; \ @@ -1857,7 +2178,6 @@ S_init_interp(pTHX) PL_tmps_floor = -1; \ PL_tmps_ix = -1; \ PL_op_mask = NULL; \ - PL_dlmax = 128; \ PL_laststatval = -1; \ PL_laststype = OP_STAT; \ PL_mess_sv = Nullsv; \ @@ -1879,8 +2199,13 @@ S_init_interp(pTHX) # define PERLVAR(var,type) # define PERLVARA(var,n,type) # if defined(PERL_IMPLICIT_CONTEXT) -# define PERLVARI(var,type,init) my_perl->var = init; -# define PERLVARIC(var,type,init) my_perl->var = init; +# if defined(USE_THREADS) +# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; +# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; +# else /* !USE_THREADS */ +# define PERLVARI(var,type,init) aTHX->var = init; +# define PERLVARIC(var,type,init) aTHX->var = init; +# endif /* USE_THREADS */ # else # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; @@ -1947,7 +2272,7 @@ S_init_main_stash(pTHX) sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */ sv_setpvn(ERRSV, "", 0); PL_curstash = PL_defstash; - PL_compiling.cop_stash = 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)); /* We must init $/ before switches are processed. */ @@ -1982,7 +2307,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) } } - PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename); + CopFILE_set(PL_curcop, PL_origfilename); if (strEQ(PL_origfilename,"-")) scriptname = ""; if (*fdscript >= 0) { @@ -2001,7 +2326,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP); sv_catpv(cpp, cpp_cfg); - sv_catpv(sv,"-I"); + sv_catpvn(sv, "-I", 2); sv_catpv(sv,PRIVLIB_EXP); #ifdef MSDOS @@ -2017,7 +2342,7 @@ sed %s -e \"/^[^#]/b\" \ -e \"/^#[ ]*undef[ ]/b\" \ -e \"/^#[ ]*endif/b\" \ -e \"s/^#.*//\" \ - %s | %_ -C %_ %s", + %s | %"SVf" -C %"SVf" %s", (PL_doextract ? "-e \"1,/^#/d\n\"" : ""), #else # ifdef __OPEN_VM @@ -2033,7 +2358,7 @@ sed %s -e \"/^[^#]/b\" \ -e '/^#[ ]*undef[ ]/b' \ -e '/^#[ ]*endif/b' \ -e 's/^[ ]*#.*//' \ - %s | %_ %_ %s", + %s | %"SVf" %"SVf" %s", # else Perl_sv_setpvf(aTHX_ cmd, "\ %s %s -e '/^[^#]/b' \ @@ -2047,7 +2372,7 @@ sed %s -e \"/^[^#]/b\" \ -e '/^#[ ]*undef[ ]/b' \ -e '/^#[ ]*endif/b' \ -e 's/^[ ]*#.*//' \ - %s | %_ -C %_ %s", + %s | %"SVf" -C %"SVf" %s", # endif #ifdef LOC_SED LOC_SED, @@ -2096,17 +2421,19 @@ sed %s -e \"/^[^#]/b\" \ #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ if (PL_euid && - PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 && + PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) { /* try again */ - PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv); + PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP, + (int)PERL_REVISION, (int)PERL_VERSION, + (int)PERL_SUBVERSION), PL_origargv); Perl_croak(aTHX_ "Can't do setuid\n"); } #endif #endif Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", - SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno)); + CopFILE(PL_curcop), Strerror(errno)); } } @@ -2121,13 +2448,15 @@ sed %s -e \"/^[^#]/b\" \ STATIC int S_fd_on_nosuid_fs(pTHX_ int fd) { - int on_nosuid = 0; - int check_okay = 0; + int check_okay = 0; /* able to do all the required sys/libcalls */ + int on_nosuid = 0; /* the fd is on a nosuid fs */ /* - * Preferred order: fstatvfs(), fstatfs(), getmntent(). + * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent(). * fstatvfs() is UNIX98. - * fstatfs() is BSD. - * getmntent() is O(number-of-mounted-filesystems) and can hang. + * fstatfs() is 4.3 BSD. + * ustat()+getmnt() is pre-4.3 BSD. + * getmntent() is O(number-of-mounted-filesystems) and can hang on + * an irrelevant filesystem while trying to reach the right one. */ # ifdef HAS_FSTATVFS @@ -2135,24 +2464,45 @@ S_fd_on_nosuid_fs(pTHX_ int fd) check_okay = fstatvfs(fd, &stfs) == 0; on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID); # else -# if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS) +# ifdef PERL_MOUNT_NOSUID +# if defined(HAS_FSTATFS) && \ + defined(HAS_STRUCT_STATFS) && \ + defined(HAS_STRUCT_STATFS_F_FLAGS) struct statfs stfs; check_okay = fstatfs(fd, &stfs) == 0; -# undef PERL_MOUNT_NOSUID -# if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID) -# define PERL_MOUNT_NOSUID MNT_NOSUID -# endif -# if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID) -# define PERL_MOUNT_NOSUID MS_NOSUID -# endif -# if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID) -# define PERL_MOUNT_NOSUID M_NOSUID -# endif -# ifdef PERL_MOUNT_NOSUID on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID); -# endif +# else +# if defined(HAS_FSTAT) && \ + defined(HAS_USTAT) && \ + defined(HAS_GETMNT) && \ + defined(HAS_STRUCT_FS_DATA) && \ + defined(NOSTAT_ONE) + struct stat fdst; + if (fstat(fd, &fdst) == 0) { + struct ustat us; + if (ustat(fdst.st_dev, &us) == 0) { + struct fs_data fsd; + /* NOSTAT_ONE here because we're not examining fields which + * vary between that case and STAT_ONE. */ + if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) { + size_t cmplen = sizeof(us.f_fname); + if (sizeof(fsd.fd_req.path) < cmplen) + cmplen = sizeof(fsd.fd_req.path); + if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) && + fdst.st_dev == fsd.fd_req.dev) { + check_okay = 1; + on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID; + } + } + } + } + } +# endif /* fstat+ustat+getmnt */ +# endif /* fstatfs */ # else -# if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID) +# if defined(HAS_GETMNTENT) && \ + defined(HAS_HASMNTOPT) && \ + defined(MNTOPT_NOSUID) FILE *mtab = fopen("/etc/mtab", "r"); struct mntent *entry; struct stat stb, fsb; @@ -2172,11 +2522,12 @@ S_fd_on_nosuid_fs(pTHX_ int fd) } if (mtab) fclose(mtab); -# endif /* mntent */ -# endif /* statfs */ +# endif /* getmntent+hasmntopt */ +# endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */ # endif /* statvfs */ + if (!check_okay) - Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename); + Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename); return on_nosuid; } #endif /* IAMSUID */ @@ -2226,7 +2577,7 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) * But I don't think it's too important. The manual lies when * it says access() is useful in setuid programs. */ - if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/ + if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/ Perl_croak(aTHX_ "Permission denied"); #else /* If we can swap euid and uid, then we can determine access rights @@ -2247,7 +2598,7 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) #endif || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid) Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */ - if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0) + if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0) Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */ #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK) if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) @@ -2258,12 +2609,12 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) (void)PerlIO_close(PL_rsfp); if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */ PerlIO_printf(PL_rsfp, -"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\ -(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n", - (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino, +"User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\ +(Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n", + PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino, (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino, - SvPVX(GvSV(PL_curcop->cop_filegv)), - (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid); + CopFILE(PL_curcop), + PL_statbuf.st_uid, PL_statbuf.st_gid); (void)PerlProc_pclose(PL_rsfp); } Perl_croak(aTHX_ "Permission denied\n"); @@ -2289,7 +2640,7 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) if (PL_statbuf.st_mode & S_IWOTH) Perl_croak(aTHX_ "Setuid/gid script is writable by world"); PL_doswitches = FALSE; /* -s is insecure in suid */ - PL_curcop->cop_line++; + CopLINE_inc(PL_curcop); if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch || strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */ Perl_croak(aTHX_ "No #! line"); @@ -2323,7 +2674,9 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); (void)PerlIO_close(PL_rsfp); #ifndef IAMSUID /* try again */ - PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv); + PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP, + (int)PERL_REVISION, (int)PERL_VERSION, + (int)PERL_SUBVERSION), PL_origargv); #endif Perl_croak(aTHX_ "Can't do setuid\n"); } @@ -2405,7 +2758,9 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #if defined(HAS_FCNTL) && defined(F_SETFD) fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */ #endif - PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */ + PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP, + (int)PERL_REVISION, (int)PERL_VERSION, + (int)PERL_SUBVERSION), PL_origargv);/* try again */ Perl_croak(aTHX_ "Can't do setuid\n"); #endif /* IAMSUID */ #else /* !DOSUID */ @@ -2449,8 +2804,6 @@ S_find_beginning(pTHX) /*SUPPRESS 530*/ while (s = moreswitches(s)) ; } - if (PL_cddir && PerlDir_chdir(PL_cddir) < 0) - Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir); } } } @@ -2459,10 +2812,10 @@ S_find_beginning(pTHX) STATIC void S_init_ids(pTHX) { - PL_uid = (int)PerlProc_getuid(); - PL_euid = (int)PerlProc_geteuid(); - PL_gid = (int)PerlProc_getgid(); - PL_egid = (int)PerlProc_getegid(); + PL_uid = PerlProc_getuid(); + PL_euid = PerlProc_geteuid(); + PL_gid = PerlProc_getgid(); + PL_egid = PerlProc_getegid(); #ifdef VMS PL_uid |= PL_gid << 16; PL_euid |= PL_egid << 16; @@ -2530,7 +2883,7 @@ Perl_init_stacks(pTHX) PL_markstack_ptr = PL_markstack; PL_markstack_max = PL_markstack + REASONABLE(32); - SET_MARKBASE; + SET_MARK_OFFSET; New(54,PL_scopestack,REASONABLE(32),I32); PL_scopestack_ix = 0; @@ -2565,10 +2918,6 @@ S_nuke_stacks(pTHX) Safefree(PL_scopestack); Safefree(PL_savestack); Safefree(PL_retstack); - DEBUG( { - Safefree(PL_debname); - Safefree(PL_debdelim); - } ) } #ifndef PERL_OBJECT @@ -2614,9 +2963,9 @@ S_init_predump_symbols(pTHX) GvMULTI_on(tmpgv); GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); - othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); - GvMULTI_on(othergv); - io = GvIOp(othergv); + PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); + GvMULTI_on(PL_stderrgv); + io = GvIOp(PL_stderrgv); IoOFP(io) = IoIFP(io) = PerlIO_stderr(); tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV); GvMULTI_on(tmpgv); @@ -2641,7 +2990,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register for (; argc > 0 && **argv == '-'; argc--,argv++) { if (!argv[0][1]) break; - if (argv[0][1] == '-') { + if (argv[0][1] == '-' && !argv[0][2]) { argc--,argv++; break; } @@ -2667,7 +3016,11 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register magicname("0", "0", 1); } if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)) +#ifdef OS2 + sv_setpv(GvSV(tmpgv), os2_execname()); +#else sv_setpv(GvSV(tmpgv),PL_origargv[0]); +#endif if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) { GvMULTI_on(PL_argvgv); (void)gv_AVadd(PL_argvgv); @@ -2713,7 +3066,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register } TAINT_NOT; if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv), (IV)getpid()); + sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); } STATIC void @@ -2804,17 +3157,6 @@ S_incpush(pTHX_ char *p, int addsubdirs) if (addsubdirs) { subdir = sv_newmortal(); - if (!PL_archpat_auto) { - STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel) - + sizeof("//auto")); - New(55, PL_archpat_auto, len, char); - sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel); -#ifdef VMS - for (len = sizeof(ARCHNAME) + 2; - PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++) - if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_'; -#endif - } } /* Break at all separators */ @@ -2855,21 +3197,21 @@ S_incpush(pTHX_ char *p, int addsubdirs) sv_usepvn(libdir,unix,len); } else - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "Failed to unixify @INC element \"%s\"\n", SvPV(libdir,len)); #endif /* .../archname/version if -d .../archname/version/auto */ - sv_setsv(subdir, libdir); - sv_catpv(subdir, PL_archpat_auto); + Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s/"PERL_FS_VER_FMT"/auto", libdir, + ARCHNAME, (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), newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); /* .../archname if -d .../archname/auto */ - sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME), - strlen(PL_patchlevel) + 1, "", 0); + Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s/auto", libdir, ARCHNAME); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(PL_incgv), @@ -2897,7 +3239,6 @@ S_init_main_thread(pTHX) thr->threadsv = newAV(); /* thr->threadsvp is set when find_threadsv is called */ thr->specific = newAV(); - thr->errhv = newHV(); thr->flags = THRf_R_JOINABLE; MUTEX_INIT(&thr->mutex); /* Handcraft thrsv similarly to mess_sv */ @@ -2963,29 +3304,36 @@ void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { dTHR; - SV *atsv = ERRSV; - line_t oldline = PL_curcop->cop_line; + SV *atsv; + line_t oldline = CopLINE(PL_curcop); CV *cv; STRLEN len; int ret; + dJMPENV; while (AvFILL(paramList) >= 0) { cv = (CV*)av_shift(paramList); SAVEFREESV(cv); - CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_list_body), cv); + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv); switch (ret) { case 0: + atsv = ERRSV; (void)SvPV(atsv, len); if (len) { + STRLEN n_a; PL_curcop = &PL_compiling; - PL_curcop->cop_line = oldline; + CopLINE_set(PL_curcop, oldline); if (paramList == PL_beginav) sv_catpv(atsv, "BEGIN failed--compilation aborted"); else - sv_catpv(atsv, "END failed--cleanup aborted"); + Perl_sv_catpvf(aTHX_ atsv, + "%s failed--call queue aborted", + paramList == PL_checkav ? "CHECK" + : paramList == PL_initav ? "INIT" + : "END"); while (PL_scopestack_ix > oldscope) LEAVE; - Perl_croak(aTHX_ "%s", SvPVX(atsv)); + Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a)); } break; case 1: @@ -2997,25 +3345,26 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) LEAVE; FREETMPS; PL_curstash = PL_defstash; - if (PL_endav) - call_list(oldscope, PL_endav); PL_curcop = &PL_compiling; - PL_curcop->cop_line = oldline; - if (PL_statusvalue) { + CopLINE_set(PL_curcop, oldline); + if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) { if (paramList == PL_beginav) Perl_croak(aTHX_ "BEGIN failed--compilation aborted"); else - Perl_croak(aTHX_ "END failed--cleanup aborted"); + Perl_croak(aTHX_ "%s failed--call queue aborted", + paramList == PL_checkav ? "CHECK" + : paramList == PL_initav ? "INIT" + : "END"); } my_exit_jump(); /* NOTREACHED */ case 3: if (PL_restartop) { PL_curcop = &PL_compiling; - PL_curcop->cop_line = oldline; + CopLINE_set(PL_curcop, oldline); JMPENV_JUMP(3); } - PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); + PerlIO_printf(Perl_error_log, "panic: restartop\n"); FREETMPS; break; } @@ -3108,7 +3457,6 @@ S_my_exit_jump(pTHX) } #ifdef PERL_OBJECT -#define NO_XSLOCKS #include "XSUB.h" #endif @@ -3127,5 +3475,3 @@ read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen) sv_chop(PL_e_script, nl); return 1; } - -