X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=866c9a88269c1512cbf79b67433af3771185bd32;hb=8aa8f774be44d46814d4ddbad03e302f1eb37338;hp=eba7e5cd652d6ea6aaa112b18804a33b1ccbecd4;hpb=14dd3ad8c9bf82cf09798a22cc89a9862dfd6d1a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index eba7e5c..866c9a8 100644 --- a/perl.c +++ b/perl.c @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-2000 Larry Wall + * Copyright (c) 1987-2002 Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -16,16 +16,33 @@ #include "perl.h" #include "patchlevel.h" /* for local_patches */ +#ifdef NETWARE +#include "nwutil.h" +char *nw_get_sitelib(const char *pl); +#endif + /* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD #include #endif -#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) +#ifdef __BEOS__ +# define HZ 1000000 +#endif + +#ifndef HZ +# ifdef CLK_TCK +# define HZ CLK_TCK +# else +# define HZ 60 +# endif +#endif + +#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO) char *getenv (char *); /* Usually in */ #endif -static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen); +static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); #ifdef IAMSUID #ifndef DOSUID @@ -39,13 +56,29 @@ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen); #endif #endif -#ifdef PERL_OBJECT -#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 +#if defined(USE_ITHREADS) +# define INIT_TLS_AND_INTERP \ + STMT_START { \ + if (!PL_curinterp) { \ + PERL_SET_INTERP(my_perl); \ + INIT_THREADS; \ + ALLOC_THREAD_KEY; \ + PERL_SET_THX(my_perl); \ + OP_REFCNT_INIT; \ + } \ + else { \ + PERL_SET_THX(my_perl); \ + } \ + } STMT_END +#else +# define INIT_TLS_AND_INTERP \ + STMT_START { \ + if (!PL_curinterp) { \ + PERL_SET_INTERP(my_perl); \ + } \ + PERL_SET_THX(my_perl); \ + } STMT_END +# endif #ifdef PERL_IMPLICIT_SYS PerlInterpreter * @@ -56,14 +89,9 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, struct IPerlProc* ipP) { 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); + INIT_TLS_AND_INTERP; Zero(my_perl, 1, PerlInterpreter); PL_Mem = ipM; PL_MemShared = ipMS; @@ -74,13 +102,14 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, PL_Dir = ipD; PL_Sock = ipS; PL_Proc = ipP; -#endif return my_perl; } #else /* +=head1 Embedding Functions + =for apidoc perl_alloc Allocates a new Perl interpreter. See L. @@ -92,10 +121,14 @@ PerlInterpreter * perl_alloc(void) { PerlInterpreter *my_perl; +#ifdef USE_5005THREADS + dTHX; +#endif /* New() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); - PERL_SET_INTERP(my_perl); + + INIT_TLS_AND_INTERP; Zero(my_perl, 1, PerlInterpreter); return my_perl; } @@ -112,16 +145,9 @@ Initializes a new Perl interpreter. See L. void perl_construct(pTHXx) { -#ifdef USE_THREADS - int i; -#ifndef FAKE_THREADS - struct perl_thread *thr = NULL; -#endif /* FAKE_THREADS */ -#endif /* USE_THREADS */ - #ifdef MULTIPLICITY init_interp(); - PL_perl_destruct_level = 1; + PL_perl_destruct_level = 1; #else if (PL_perl_destruct_level > 0) init_interp(); @@ -129,32 +155,9 @@ perl_construct(pTHXx) /* Init the real globals (and main thread)? */ if (!PL_linestr) { - INIT_THREADS; -#ifdef USE_THREADS -#ifdef ALLOC_THREAD_KEY - ALLOC_THREAD_KEY; -#else - if (pthread_key_create(&PL_thr_key, 0)) - Perl_croak(aTHX_ "panic: pthread_key_create"); +#ifdef USE_ITHREADS + MUTEX_INIT(&PL_dollarzero_mutex); /* for $0 modifying */ #endif - MUTEX_INIT(&PL_sv_mutex); - /* - * Safe to use basic SV functions from now on (though - * not things like mortals or tainting yet). - */ - MUTEX_INIT(&PL_eval_mutex); - COND_INIT(&PL_eval_cond); - MUTEX_INIT(&PL_threads_mutex); - COND_INIT(&PL_nthreads_cond); -#ifdef EMULATE_ATOMIC_REFCOUNTS - MUTEX_INIT(&PL_svref_mutex); -#endif /* EMULATE_ATOMIC_REFCOUNTS */ - - MUTEX_INIT(&PL_cred_mutex); - - thr = init_main_thread(); -#endif /* USE_THREADS */ - #ifdef PERL_FLEXIBLE_EXCEPTIONS PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */ #endif @@ -182,27 +185,11 @@ perl_construct(pTHXx) SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; } -#ifdef PERL_OBJECT - /* TODO: */ - /* PL_sighandlerp = sighandler; */ -#else PL_sighandlerp = Perl_sighandler; -#endif PL_pidstatus = newHV(); - -#ifdef MSDOS - /* - * There is no way we can refer to them from Perl so close them to save - * space. The other alternative would be to provide STDAUX and STDPRN - * filehandles. - */ - (void)fclose(stdaux); - (void)fclose(stdprn); -#endif } - PL_nrs = newSVpvn("\n", 1); - PL_rs = SvREFCNT_inc(PL_nrs); + PL_rs = newSVpvn("\n", 1); init_stacks(); @@ -218,22 +205,20 @@ perl_construct(pTHXx) { U8 *s; PL_patchlevel = NEWSV(0,4); - SvUPGRADE(PL_patchlevel, SVt_PVNV); + (void)SvUPGRADE(PL_patchlevel, SVt_PVNV); if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127) - SvGROW(PL_patchlevel,24); + SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1); 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); + /* 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) -#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0 - + ((NV)PERL_SUBVERSION / (NV)1000000) -#endif - ; + 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); @@ -243,15 +228,71 @@ perl_construct(pTHXx) PL_localpatches = local_patches; /* For possible -v */ #endif - PerlIO_init(); /* Hook to IO system */ +#ifdef HAVE_INTERP_INTERN + sys_intern_init(); +#endif + + PerlIO_init(aTHX); /* Hook to IO system */ PL_fdpid = newAV(); /* for remembering popen pids by fd */ PL_modglobal = newHV(); /* pointers to per-interpreter module globals */ + PL_errors = newSVpvn("",0); + 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. */ +#ifdef USE_ITHREADS + PL_regex_padav = newAV(); + av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */ + PL_regex_pad = AvARRAY(PL_regex_padav); +#endif +#ifdef USE_REENTRANT_API + Perl_reentrant_init(aTHX); +#endif + + /* Note that strtab is a rather special HV. Assumptions are made + about not iterating on it, and not adding tie magic to it. + It is properly deallocated in perl_destruct() */ + PL_strtab = newHV(); + + HvSHAREKEYS_off(PL_strtab); /* mandatory */ + hv_ksplit(PL_strtab, 512); + +#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__)) + _dyld_lookup_and_bind + ("__environ", (unsigned long *) &environ_pointer, NULL); +#endif /* environ */ + +#ifdef USE_ENVIRON_ARRAY + PL_origenviron = environ; +#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) + PL_clocktick = sysconf(_SC_CLK_TCK); + if (PL_clocktick <= 0) +#endif + PL_clocktick = HZ; ENTER; } /* +=for apidoc nothreadhook + +Stub that provides thread hook for perl_destruct when there are +no threads. + +=cut +*/ + +int +Perl_nothreadhook(pTHX) +{ + return 0; +} + +/* =for apidoc perl_destruct Shuts down a Perl interpreter. See L. @@ -259,96 +300,23 @@ Shuts down a Perl interpreter. See L. =cut */ -void +int perl_destruct(pTHXx) { - dTHR; - int destruct_level; /* 0=none, 1=full, 2=full with checks */ - I32 last_sv_count; + volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */ HV *hv; -#ifdef USE_THREADS - Thread t; +#ifdef USE_5005THREADS dTHX; -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ /* 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(Perl_debug_log, - "perl_destruct: waiting for %d threads...\n", - PL_nthreads - 1)); - for (t = thr->next; t != thr; t = t->next) { - MUTEX_LOCK(&t->mutex); - switch (ThrSTATE(t)) { - AV *av; - case THRf_ZOMBIE: - DEBUG_S(PerlIO_printf(Perl_debug_log, - "perl_destruct: joining zombie %p\n", t)); - ThrSETSTATE(t, THRf_DEAD); - MUTEX_UNLOCK(&t->mutex); - PL_nthreads--; - /* - * The SvREFCNT_dec below may take a long time (e.g. av - * may contain an object scalar whose destructor gets - * called) so we have to unlock threads_mutex and start - * all over again. - */ - MUTEX_UNLOCK(&PL_threads_mutex); - JOIN(t, &av); - SvREFCNT_dec((SV*)av); - 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(Perl_debug_log, - "perl_destruct: detaching thread %p\n", t)); - ThrSETSTATE(t, THRf_R_DETACHED); - /* - * We unlock threads_mutex and t->mutex in the opposite order - * from which we locked them just so that DETACH won't - * deadlock if it panics. It's only a breach of good style - * not a bug since they are unlocks not locks. - */ - MUTEX_UNLOCK(&PL_threads_mutex); - DETACH(t); - MUTEX_UNLOCK(&t->mutex); - goto retry_cleanup; - default: - DEBUG_S(PerlIO_printf(Perl_debug_log, - "perl_destruct: ignoring %p (state %u)\n", - t, ThrSTATE(t))); - MUTEX_UNLOCK(&t->mutex); - /* fall through and out */ - } - } - /* We leave the above "Pass 1" loop with threads_mutex still locked */ - - /* Pass 2 on remaining threads: wait for the thread count to drop to one */ - while (PL_nthreads > 1) - { - 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(Perl_debug_log, "perl_destruct: armageddon has arrived\n")); - MUTEX_DESTROY(&PL_threads_mutex); - COND_DESTROY(&PL_nthreads_cond); -#endif /* !defined(FAKE_THREADS) */ -#endif /* USE_THREADS */ - destruct_level = PL_perl_destruct_level; #ifdef DEBUGGING { char *s; - if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) { + if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) { int i = atoi(s); if (destruct_level < i) destruct_level = i; @@ -356,14 +324,31 @@ perl_destruct(pTHXx) } #endif + + if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) { + dJMPENV; + int x = 0; + + JMPENV_PUSH(x); + if (PL_endav && !PL_minus_c) + call_list(PL_scopestack_ix, PL_endav); + JMPENV_POP; + } LEAVE; FREETMPS; + /* Need to flush since END blocks can produce output */ + my_fflush_all(); + + if (CALL_FPTR(PL_threadhook)(aTHX)) { + /* Threads hook has vetoed further cleanup */ + return STATUS_NATIVE_EXPORT; + } + /* We must account for everything. */ /* Destroy the main CV and syntax tree */ if (PL_main_root) { - PL_curpad = AvARRAY(PL_comppad); op_free(PL_main_root); PL_main_root = Nullop; } @@ -373,6 +358,13 @@ perl_destruct(pTHXx) PL_main_cv = Nullcv; PL_dirty = TRUE; + /* Tell PerlIO we are about to tear things apart in case + we have layers which are using resources that should + be cleaned up now. + */ + + PerlIO_destruct(aTHX); + if (PL_sv_objcount) { /* * Try to destruct global references. We do this first so that the @@ -390,17 +382,79 @@ perl_destruct(pTHXx) /* call exit list functions */ while (PL_exitlistlen-- > 0) - PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr); + PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr); Safefree(PL_exitlist); if (destruct_level == 0){ DEBUG_P(debprofdump()); - + +#if defined(PERLIO_LAYERS) + /* No more IO - including error messages ! */ + PerlIO_cleanup(aTHX); +#endif + /* The exit() function will do everything that needs doing. */ - return; + return STATUS_NATIVE_EXPORT; + } + + /* jettison our possibly duplicated environment */ + /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied + * so we certainly shouldn't free it here + */ +#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV) + if (environ != PL_origenviron +#ifdef USE_ITHREADS + /* only main thread can free environ[0] contents */ + && PL_curinterp == aTHX +#endif + ) + { + I32 i; + + for (i = 0; environ[i]; i++) + safesysfree(environ[i]); + + /* Must use safesysfree() when working with environ. */ + safesysfree(environ); + + environ = PL_origenviron; + } +#endif + +#ifdef USE_ITHREADS + /* the syntax tree is shared between clones + * so op_free(PL_main_root) only ReREFCNT_dec's + * REGEXPs in the parent interpreter + * we need to manually ReREFCNT_dec for the clones + */ + { + I32 i = AvFILLp(PL_regex_padav) + 1; + SV **ary = AvARRAY(PL_regex_padav); + + while (i) { + SV *resv = ary[--i]; + REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv)); + + if (SvFLAGS(resv) & SVf_BREAK) { + /* this is PL_reg_curpm, already freed + * flag is set in regexec.c:S_regtry + */ + SvFLAGS(resv) &= ~SVf_BREAK; + } + else if(SvREPADTMP(resv)) { + SvREPADTMP_off(resv); + } + else { + ReREFCNT_dec(re); + } + } } + SvREFCNT_dec(PL_regex_padav); + PL_regex_padav = Nullav; + PL_regex_pad = NULL; +#endif /* loosen bonds of global variables */ @@ -437,18 +491,15 @@ perl_destruct(pTHXx) /* magical thingies */ - Safefree(PL_ofs); /* $, */ - PL_ofs = Nullch; + SvREFCNT_dec(PL_ofs_sv); /* $, */ + PL_ofs_sv = Nullsv; - Safefree(PL_ors); /* $\ */ - PL_ors = Nullch; + SvREFCNT_dec(PL_ors_sv); /* $\ */ + PL_ors_sv = Nullsv; SvREFCNT_dec(PL_rs); /* $/ */ PL_rs = Nullsv; - SvREFCNT_dec(PL_nrs); /* $/ helper */ - PL_nrs = Nullsv; - PL_multiline = 0; /* $* */ Safefree(PL_osname); /* $^O */ PL_osname = Nullch; @@ -474,12 +525,16 @@ perl_destruct(pTHXx) /* startup and shutdown function lists */ SvREFCNT_dec(PL_beginav); + SvREFCNT_dec(PL_beginav_save); SvREFCNT_dec(PL_endav); 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; /* shortcuts just get cleared */ @@ -526,6 +581,7 @@ perl_destruct(pTHXx) #ifdef USE_LOCALE_NUMERIC Safefree(PL_numeric_name); PL_numeric_name = Nullch; + SvREFCNT_dec(PL_numeric_radix_sv); #endif /* clear utf8 character classes */ @@ -544,7 +600,11 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_utf8_xdigit); SvREFCNT_dec(PL_utf8_mark); SvREFCNT_dec(PL_utf8_toupper); + SvREFCNT_dec(PL_utf8_totitle); SvREFCNT_dec(PL_utf8_tolower); + 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; @@ -562,10 +622,18 @@ perl_destruct(pTHXx) PL_utf8_toupper = Nullsv; PL_utf8_totitle = Nullsv; PL_utf8_tolower = Nullsv; + PL_utf8_tofold = Nullsv; + PL_utf8_idstart = Nullsv; + PL_utf8_idcont = Nullsv; if (!specialWARN(PL_compiling.cop_warnings)) SvREFCNT_dec(PL_compiling.cop_warnings); PL_compiling.cop_warnings = Nullsv; + if (!specialCopIO(PL_compiling.cop_io)) + SvREFCNT_dec(PL_compiling.cop_io); + PL_compiling.cop_io = Nullsv; + CopFILE_free(&PL_compiling); + CopSTASH_free(&PL_compiling); /* Prepare to destruct main symbol table. */ @@ -582,29 +650,29 @@ perl_destruct(pTHXx) FREETMPS; if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) { if (PL_scopestack_ix != 0) - Perl_warner(aTHX_ WARN_INTERNAL, + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", (long)PL_scopestack_ix); if (PL_savestack_ix != 0) - Perl_warner(aTHX_ WARN_INTERNAL, + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Unbalanced saves: %ld more saves than restores\n", (long)PL_savestack_ix); if (PL_tmps_floor != -1) - Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n", + Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n", (long)PL_tmps_floor + 1); if (cxstack_ix != -1) - Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n", + Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n", (long)cxstack_ix + 1); } /* Now absolutely destruct everything, somehow or other, loops or no. */ - last_sv_count = 0; SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */ SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */ - while (PL_sv_count != 0 && PL_sv_count != last_sv_count) { - last_sv_count = PL_sv_count; - sv_clean_all(); - } + + /* the 2 is for PL_fdpid and PL_strtab */ + while (PL_sv_count > 2 && sv_clean_all()) + ; + SvFLAGS(PL_fdpid) &= ~SVTYPEMASK; SvFLAGS(PL_fdpid) |= SVt_PVAV; SvFLAGS(PL_strtab) &= ~SVTYPEMASK; @@ -614,6 +682,10 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_fdpid); /* needed in io_close() */ PL_fdpid = Nullav; +#ifdef HAVE_INTERP_INTERN + sys_intern_clear(); +#endif + /* Destruct the global string table. */ { /* Yell and reset the HeVAL() slots that are still holding refcounts, @@ -630,7 +702,7 @@ perl_destruct(pTHXx) hent = array[0]; for (;;) { if (hent && ckWARN_d(WARN_INTERNAL)) { - Perl_warner(aTHX_ WARN_INTERNAL, + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Unbalanced string table refcount: (%d) for \"%s\"", HeVAL(hent) - Nullsv, HeKEY(hent)); HeVAL(hent) = Nullsv; @@ -645,22 +717,66 @@ perl_destruct(pTHXx) } SvREFCNT_dec(PL_strtab); +#ifdef USE_ITHREADS + /* free the pointer table used for cloning */ + ptr_table_free(PL_ptr_table); +#endif + /* free special SVs */ SvREFCNT(&PL_sv_yes) = 0; sv_clear(&PL_sv_yes); SvANY(&PL_sv_yes) = NULL; + SvFLAGS(&PL_sv_yes) = 0; SvREFCNT(&PL_sv_no) = 0; sv_clear(&PL_sv_no); SvANY(&PL_sv_no) = NULL; + SvFLAGS(&PL_sv_no) = 0; + + { + int i; + for (i=0; i<=2; i++) { + SvREFCNT(PERL_DEBUG_PAD(i)) = 0; + sv_clear(PERL_DEBUG_PAD(i)); + SvANY(PERL_DEBUG_PAD(i)) = NULL; + SvFLAGS(PERL_DEBUG_PAD(i)) = 0; + } + } if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count); + +#ifdef DEBUG_LEAKING_SCALARS + if (PL_sv_count != 0) { + SV* sva; + SV* sv; + register SV* svend; + + for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { + svend = &sva[SvREFCNT(sva)]; + for (sv = sva + 1; sv < svend; ++sv) { + if (SvTYPE(sv) != SVTYPEMASK) { + PerlIO_printf(Perl_debug_log, "leaked: 0x%p\n", sv); + } + } + } + } +#endif - sv_free_arenas(); - /* No SVs have survived, need to clean out */ +#if defined(PERLIO_LAYERS) + /* No more IO - including error messages ! */ + PerlIO_cleanup(aTHX); +#endif + + /* sv_undef needs to stay immortal until after PerlIO_cleanup + as currently layers use it rather than Nullsv 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); Safefree(PL_reg_start_tmp); if (PL_reg_curpm) @@ -668,26 +784,20 @@ perl_destruct(pTHXx) Safefree(PL_reg_poscache); Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh)); Safefree(PL_op_mask); + Safefree(PL_psig_ptr); + Safefree(PL_psig_name); + Safefree(PL_bitcount); + Safefree(PL_psig_pend); nuke_stacks(); PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */ - + DEBUG_P(debprofdump()); -#ifdef USE_THREADS - MUTEX_DESTROY(&PL_strtab_mutex); - MUTEX_DESTROY(&PL_sv_mutex); - MUTEX_DESTROY(&PL_eval_mutex); - MUTEX_DESTROY(&PL_cred_mutex); - COND_DESTROY(&PL_eval_cond); -#ifdef EMULATE_ATOMIC_REFCOUNTS - MUTEX_DESTROY(&PL_svref_mutex); -#endif /* EMULATE_ATOMIC_REFCOUNTS */ - - /* As the penultimate thing, free the non-arena SV for thrsv */ - Safefree(SvPVX(PL_thrsv)); - Safefree(SvANY(PL_thrsv)); - Safefree(PL_thrsv); - PL_thrsv = Nullsv; -#endif /* USE_THREADS */ + +#ifdef USE_REENTRANT_API + Perl_reentrant_free(aTHX); +#endif + + sv_free_arenas(); /* As the absolutely last thing, free the non-arena SV for mess() */ @@ -698,18 +808,20 @@ perl_destruct(pTHXx) MAGIC* moremagic; for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) { moremagic = mg->mg_moremagic; - if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0) + if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global + && mg->mg_len >= 0) Safefree(mg->mg_ptr); Safefree(mg); } } /* we know that type >= SVt_PV */ - SvOOK_off(PL_mess_sv); + (void)SvOOK_off(PL_mess_sv); Safefree(SvPVX(PL_mess_sv)); Safefree(SvANY(PL_mess_sv)); Safefree(PL_mess_sv); PL_mess_sv = Nullsv; } + return STATUS_NATIVE_EXPORT; } /* @@ -723,8 +835,22 @@ Releases a Perl interpreter. See L. void perl_free(pTHXx) { -#if defined(PERL_OBJECT) - PerlMem_free(this); +#if defined(WIN32) || defined(NETWARE) +# if defined(PERL_IMPLICIT_SYS) +# ifdef NETWARE + void *host = nw_internal_host; +# else + void *host = w32_internal_host; +# endif + PerlMem_free(aTHXx); +# ifdef NETWARE + nw_delete_internal_host(host); +# else + win32_delete_internal_host(host); +# endif +# else + PerlMem_free(aTHXx); +# endif #else PerlMem_free(aTHXx); #endif @@ -750,11 +876,10 @@ Tells a Perl interpreter to parse a Perl script. See L. int perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) { - dTHR; I32 oldscope; int ret; dJMPENV; -#ifdef USE_THREADS +#ifdef USE_5005THREADS dTHX; #endif @@ -766,16 +891,8 @@ setuid perl scripts securely.\n"); #endif #endif -#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__)) - _dyld_lookup_and_bind - ("__environ", (unsigned long *) &environ_pointer, NULL); -#endif /* environ */ - - PL_origargv = argv; PL_origargc = argc; -#ifndef VMS /* VMS doesn't have environ array */ - PL_origenviron = environ; -#endif + PL_origargv = argv; if (PL_do_undump) { @@ -790,7 +907,6 @@ setuid perl scripts securely.\n"); } if (PL_main_root) { - PL_curpad = AvARRAY(PL_comppad); op_free(PL_main_root); PL_main_root = Nullop; } @@ -852,14 +968,12 @@ S_vparse_body(pTHX_ va_list args) STATIC void * S_parse_body(pTHX_ char **env, XSINIT_t xsinit) { - dTHR; int argc = PL_origargc; char **argv = PL_origargv; char *scriptname = NULL; int fdscript = -1; VOL bool dosearch = FALSE; char *validarg = ""; - AV* comppadlist; register SV *sv; register char *s; char *cddir = Nullch; @@ -881,12 +995,16 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) s = argv[0]+1; reswitch: switch (*s) { + case 'C': +#ifdef WIN32 + win32_argv2utf8(argc-1, argv+1); + /* FALL THROUGH */ +#endif #ifndef PERL_STRICT_CR case '\r': #endif case ' ': case '0': - case 'C': case 'F': case 'a': case 'c': @@ -906,16 +1024,30 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) case 'W': case 'X': case 'w': - if (s = moreswitches(s)) + case 'A': + if ((s = moreswitches(s))) goto reswitch; break; + case 't': + if( !PL_tainting ) { + PL_taint_warn = TRUE; + PL_tainting = TRUE; + } + s++; + goto reswitch; case 'T': PL_tainting = TRUE; + PL_taint_warn = FALSE; s++; goto reswitch; case 'e': +#ifdef MACOS_TRADITIONAL + /* ignore -e for Dev:Pseudo argument */ + if (argv[1] && !strcmp(argv[1], "Dev:Pseudo")) + break; +#endif if (PL_euid != PL_uid || PL_egid != PL_gid) Perl_croak(aTHX_ "No -e allowed in setuid scripts"); if (!PL_e_script) { @@ -942,7 +1074,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) char *p; STRLEN len = strlen(s); p = savepvn(s, len); - incpush(p, TRUE); + incpush(p, TRUE, TRUE, FALSE); sv_catpvn(sv, "-I", 2); sv_catpvn(sv, p, len); sv_catpvn(sv, " ", 1); @@ -979,14 +1111,17 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef MULTIPLICITY sv_catpv(PL_Sv," MULTIPLICITY"); # endif -# ifdef USE_THREADS - sv_catpv(PL_Sv," USE_THREADS"); +# ifdef USE_5005THREADS + sv_catpv(PL_Sv," USE_5005THREADS"); # endif # ifdef USE_ITHREADS sv_catpv(PL_Sv," USE_ITHREADS"); # endif -# ifdef USE_64_BITS - sv_catpv(PL_Sv," USE_64_BITS"); +# ifdef USE_64_BIT_INT + sv_catpv(PL_Sv," USE_64_BIT_INT"); +# endif +# ifdef USE_64_BIT_ALL + sv_catpv(PL_Sv," USE_64_BIT_ALL"); # endif # ifdef USE_LONG_DOUBLE sv_catpv(PL_Sv," USE_LONG_DOUBLE"); @@ -997,9 +1132,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # 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 @@ -1028,7 +1160,12 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #endif sv_catpv(PL_Sv, "; \ $\"=\"\\n \"; \ -@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \ +@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; "); +#ifdef __CYGWIN__ + sv_catpv(PL_Sv,"\ +push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";"); +#endif + sv_catpv(PL_Sv, "\ print \" \\%ENV:\\n @env\\n\" if @env; \ print \" \\@INC:\\n @INC\\n\";"); } @@ -1070,6 +1207,7 @@ print \" \\@INC:\\n @INC\\n\";"); } } switch_end: + sv_setsv(get_sv("/", TRUE), PL_rs); if ( #ifndef SECURE_INTERNAL_GETENV @@ -1077,12 +1215,17 @@ print \" \\@INC:\\n @INC\\n\";"); #endif (s = PerlEnv_getenv("PERL5OPT"))) { + char *popt = s; while (isSPACE(*s)) s++; - if (*s == '-' && *(s+1) == 'T') + if (*s == '-' && *(s+1) == 'T') { PL_tainting = TRUE; + PL_taint_warn = FALSE; + } else { + char *popt_copy = Nullch; while (s && *s) { + char *d; while (isSPACE(*s)) s++; if (*s == '-') { @@ -1090,15 +1233,38 @@ print \" \\@INC:\\n @INC\\n\";"); if (isSPACE(*s)) continue; } + d = s; if (!*s) break; - if (!strchr("DIMUdmw", *s)) + if (!strchr("DIMUdmtwA", *s)) Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); - s = moreswitches(s); + while (++s && *s) { + if (isSPACE(*s)) { + if (!popt_copy) { + popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0))); + s = popt_copy + (s - popt); + d = popt_copy + (d - popt); + } + *s++ = '\0'; + break; + } + } + if (*d == 't') { + if( !PL_tainting ) { + PL_taint_warn = TRUE; + PL_tainting = TRUE; + } + } else { + moreswitches(d); + } } } } + if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) { + PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize); + } + if (!scriptname) scriptname = argv[0]; if (PL_e_script) { @@ -1119,6 +1285,7 @@ print \" \\@INC:\\n @INC\\n\";"); validate_suid(validarg, scriptname,fdscript); +#ifndef PERL_MICRO #if defined(SIGCHLD) || defined(SIGCLD) { #ifndef SIGCHLD @@ -1127,14 +1294,19 @@ print \" \\@INC:\\n @INC\\n\";"); Sighandler_t sigstate = rsignal_state(SIGCHLD); if (sigstate == SIG_IGN) { if (ckWARN(WARN_SIGNAL)) - Perl_warner(aTHX_ 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 +#ifdef MACOS_TRADITIONAL + if (PL_doextract || gMacPerl_AlwaysExtract) { +#else if (PL_doextract) { +#endif find_beginning(); if (cddir && PerlDir_chdir(cddir) < 0) Perl_croak(aTHX_ "Can't chdir to %s",cddir); @@ -1145,42 +1317,34 @@ print \" \\@INC:\\n @INC\\n\";"); sv_upgrade((SV *)PL_compcv, SVt_PVCV); CvUNIQUE_on(PL_compcv); - PL_comppad = newAV(); - av_push(PL_comppad, Nullsv); - PL_curpad = AvARRAY(PL_comppad); - PL_comppad_name = newAV(); - PL_comppad_name_fill = 0; - PL_min_intro_pending = 0; - PL_padix = 0; -#ifdef USE_THREADS - av_store(PL_comppad_name, 0, newSVpvn("@_", 2)); - PL_curpad[0] = (SV*)newAV(); - SvPADMY_on(PL_curpad[0]); /* XXX Needed? */ + CvPADLIST(PL_compcv) = pad_new(0); +#ifdef USE_5005THREADS CvOWNER(PL_compcv) = 0; New(666, CvMUTEXP(PL_compcv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(PL_compcv)); -#endif /* USE_THREADS */ - - comppadlist = newAV(); - AvREAL_off(comppadlist); - av_store(comppadlist, 0, (SV*)PL_comppad_name); - av_store(comppadlist, 1, (SV*)PL_comppad); - CvPADLIST(PL_compcv) = comppadlist; +#endif /* USE_5005THREADS */ + boot_core_PerlIO(); boot_core_UNIVERSAL(); #ifndef PERL_MICRO boot_core_xsutils(); #endif if (xsinit) - (*xsinit)(aTHXo); /* in case linked C routines want magical variables */ -#if defined(VMS) || defined(WIN32) || defined(DJGPP) + (*xsinit)(aTHX); /* in case linked C routines want magical variables */ +#ifndef PERL_MICRO +#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) init_os_extras(); #endif +#endif #ifdef USE_SOCKS +# ifdef HAS_SOCKS5_INIT + socks5_init(argv[0]); +# else SOCKSinit(argv[0]); -#endif +# endif +#endif init_predump_symbols(); /* init_postdump_symbols not currently designed to be called */ @@ -1189,12 +1353,63 @@ print \" \\@INC:\\n @INC\\n\";"); if (!PL_do_undump) init_postdump_symbols(argc,argv,env); + /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}. + * PL_utf8locale is conditionally turned on by + * locale.c:Perl_init_i18nl10n() if the environment + * look like the user wants to use UTF-8. */ + if (PL_unicode) { /* Requires init_predump_symbols(). */ + IO* io; + PerlIO* fp; + SV* sv; + + if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { + /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR + * and the default open discipline. */ + if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) && + PL_stdingv && (io = GvIO(PL_stdingv)) && + (fp = IoIFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) && + PL_defoutgv && (io = GvIO(PL_defoutgv)) && + (fp = IoOFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) && + PL_stderrgv && (io = GvIO(PL_stderrgv)) && + (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)))) { + U32 in = PL_unicode & PERL_UNICODE_IN_FLAG; + U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG; + if (in) { + if (out) + sv_setpvn(sv, ":utf8\0:utf8", 11); + else + sv_setpvn(sv, ":utf8\0", 6); + } + else if (out) + sv_setpvn(sv, "\0:utf8", 6); + SvSETMAGIC(sv); + } + } + } + init_lexer(); /* now parse the script */ - SETERRNO(0,SS$_NORMAL); + SETERRNO(0,SS_NORMAL); PL_error_count = 0; +#ifdef MACOS_TRADITIONAL + if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) { + if (PL_minus_c) + Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename)); + else { + Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n", + MacPerl_MPWFileName(PL_origfilename)); + } + } +#else if (yyparse() || PL_error_count) { if (PL_minus_c) Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename); @@ -1203,6 +1418,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_origfilename); } } +#endif CopLINE_set(PL_curcop, 0); PL_curstash = PL_defstash; PL_preprocess = FALSE; @@ -1211,10 +1427,6 @@ print \" \\@INC:\\n @INC\\n\";"); PL_e_script = Nullsv; } - /* now that script is parsed, we can modify record separator */ - SvREFCNT_dec(PL_rs); - PL_rs = SvREFCNT_inc(PL_nrs); - sv_setsv(get_sv("/", TRUE), PL_rs); if (PL_do_undump) my_unexec(); @@ -1248,15 +1460,17 @@ Tells a Perl interpreter to run. See L. int perl_run(pTHXx) { - dTHR; I32 oldscope; int ret = 0; dJMPENV; -#ifdef USE_THREADS +#ifdef USE_5005THREADS dTHX; #endif oldscope = PL_scopestack_ix; +#ifdef VMS + VMSISH_HUSHED = 0; +#endif #ifdef PERL_FLEXIBLE_EXCEPTIONS redo_body: @@ -1279,7 +1493,8 @@ perl_run(pTHXx) LEAVE; FREETMPS; PL_curstash = PL_defstash; - if (PL_endav && !PL_minus_c) + if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) && + PL_endav && !PL_minus_c) call_list(oldscope, PL_endav); #ifdef MYMALLOC if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) @@ -1316,8 +1531,6 @@ S_vrun_body(pTHX_ va_list args) STATIC void * S_run_body(pTHX_ I32 oldscope) { - dTHR; - DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n", PL_sawampersand ? "Enabling" : "Omitting")); @@ -1328,11 +1541,17 @@ S_run_body(pTHX_ I32 oldscope) PTR2UV(thr))); if (PL_minus_c) { +#ifdef MACOS_TRADITIONAL + PerlIO_printf(Perl_error_log, "%s%s syntax OK\n", + (gMacPerl_ErrorFormat ? "# " : ""), + MacPerl_MPWFileName(PL_origfilename)); +#else PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); +#endif my_exit(0); } if (PERLDB_SINGLE && PL_DBsingle) - sv_setiv(PL_DBsingle, 1); + sv_setiv(PL_DBsingle, 1); if (PL_initav) call_list(oldscope, PL_initav); } @@ -1356,6 +1575,8 @@ S_run_body(pTHX_ I32 oldscope) } /* +=head1 SV Manipulation Functions + =for apidoc p||get_sv Returns the SV of the specified Perl scalar. If C is set and the @@ -1369,15 +1590,13 @@ SV* Perl_get_sv(pTHX_ const char *name, I32 create) { GV *gv; -#ifdef USE_THREADS +#ifdef USE_5005THREADS if (name[1] == '\0' && !isALPHA(name[0])) { PADOFFSET tmp = find_threadsv(name); - if (tmp != NOT_IN_PAD) { - dTHR; + if (tmp != NOT_IN_PAD) return THREADSV(tmp); - } } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ gv = gv_fetchpv(name, create, SVt_PV); if (gv) return GvSV(gv); @@ -1385,6 +1604,8 @@ Perl_get_sv(pTHX_ const char *name, I32 create) } /* +=head1 Array Manipulation Functions + =for apidoc p||get_av Returns the AV of the specified Perl array. If C is set and the @@ -1406,6 +1627,8 @@ Perl_get_av(pTHX_ const char *name, I32 create) } /* +=head1 Hash Manipulation Functions + =for apidoc p||get_hv Returns the HV of the specified Perl hash. If C is set and the @@ -1427,6 +1650,8 @@ Perl_get_hv(pTHX_ const char *name, I32 create) } /* +=head1 CV Manipulation Functions + =for apidoc p||get_cv Returns the CV of the specified Perl subroutine. If C is set and @@ -1458,6 +1683,9 @@ Perl_get_cv(pTHX_ const char *name, I32 create) /* Be sure to refetch the stack pointer after calling these routines. */ /* + +=head1 Callback Functions + =for apidoc p||call_argv Performs a callback to the specified Perl sub. See L. @@ -1467,7 +1695,7 @@ Performs a callback to the specified Perl sub. See L. I32 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) - + /* See G_* flags in cop.h */ /* null terminated arg list */ { @@ -1514,18 +1742,7 @@ Perl_call_method(pTHX_ const char *methname, I32 flags) /* name of the subroutine */ /* See G_* flags in cop.h */ { - dSP; - OP myop; - if (!PL_op) { - Zero(&myop, 1, OP); - PL_op = &myop; - } - XPUSHs(sv_2mortal(newSVpv(methname,0))); - PUTBACK; - pp_method(); - if (PL_op == &myop) - PL_op = Nullop; - return call_sv(*PL_stack_sp--, flags); + return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD); } /* May be called with any of a CV, a GV, or an SV containing the name. */ @@ -1540,13 +1757,13 @@ L. I32 Perl_call_sv(pTHX_ SV *sv, I32 flags) - /* See G_* flags in cop.h */ { dSP; LOGOP myop; /* fake syntax tree node */ + UNOP method_op; I32 oldmark; - I32 retval; + volatile I32 retval = 0; I32 oldscope; bool oldcatch = CATCH_GET; int ret; @@ -1582,6 +1799,14 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) && !(flags & G_NODEBUG)) PL_op->op_private |= OPpENTERSUB_DB; + if (flags & G_METHOD) { + Zero(&method_op, 1, UNOP); + method_op.op_next = PL_op; + method_op.op_ppaddr = PL_ppaddr[OP_METHOD]; + myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; + PL_op = (OP*)&method_op; + } + if (!(flags & G_EVAL)) { CATCH_SET(TRUE); call_body((OP*)&myop, FALSE); @@ -1589,21 +1814,21 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) CATCH_SET(oldcatch); } else { - cLOGOP->op_other = PL_op; + myop.op_other = (OP*)&myop; PL_markstack_ptr--; /* we're trying to emulate pp_entertry() here */ { register PERL_CONTEXT *cx; I32 gimme = GIMME_V; - + ENTER; SAVETMPS; - - push_return(PL_op->op_next); - PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp); + + 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. */ - + PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR) PL_in_eval |= EVAL_KEEPERR; @@ -1698,13 +1923,11 @@ S_vcall_body(pTHX_ va_list args) STATIC void S_call_body(pTHX_ OP *myop, int is_eval) { - dTHR; - if (PL_op == myop) { if (is_eval) - PL_op = Perl_pp_entereval(aTHX); + PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */ else - PL_op = Perl_pp_entersub(aTHX); + PL_op = Perl_pp_entersub(aTHX); /* this does */ } if (PL_op) CALLRUNOPS(aTHX); @@ -1722,13 +1945,13 @@ Tells Perl to C the string in the SV. I32 Perl_eval_sv(pTHX_ SV *sv, I32 flags) - + /* See G_* flags in cop.h */ { dSP; UNOP myop; /* fake syntax tree node */ - I32 oldmark = SP - PL_stack_base; - I32 retval; + volatile I32 oldmark = SP - PL_stack_base; + volatile I32 retval = 0; I32 oldscope; int ret; OP* oldop = PL_op; @@ -1826,7 +2049,6 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) dSP; SV* sv = newSVpv(p, 0); - PUSHMARK(SP); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); @@ -1845,12 +2067,15 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) /* Require a module. */ /* +=head1 Embedding Functions + =for apidoc p||require_pv -Tells Perl to C a module. +Tells Perl to C the file named by the string argument. It is +analogous to the Perl code C. It's even +implemented that way; consider using Perl_load_module instead. -=cut -*/ +=cut */ void Perl_require_pv(pTHX_ const char *pv) @@ -1873,21 +2098,21 @@ Perl_magicname(pTHX_ char *sym, char *name, I32 namlen) { register GV *gv; - if (gv = gv_fetchpv(sym,TRUE, SVt_PV)) - sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen); + if ((gv = gv_fetchpv(sym,TRUE, SVt_PV))) + sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen); } STATIC void S_usage(pTHX_ char *name) /* XXX move this out into a module ? */ { /* This message really ought to be max 23 lines. - * Removed -h because the user already knows that opton. Others? */ + * Removed -h because the user already knows that option. Others? */ static char *usage_msg[] = { "-0[octal] specify record separator (\\0, if no argument)", "-a autosplit mode with -n or -p (splits $_ into @F)", "-C enable native wide character system interfaces", -"-c check syntax only (runs BEGIN and END blocks)", +"-c check syntax only (runs BEGIN and CHECK blocks)", "-d[:debugger] run program under debugger", "-D[number/list] set debugging flags (argument is a bit mask or alphabets)", "-e 'command' one line of program (several -e's allowed, omit programfile)", @@ -1902,20 +2127,25 @@ S_usage(pTHX_ char *name) /* XXX move this out into a module ? */ "-s enable rudimentary parsing for switches after programfile", "-S look for programfile using PATH environment variable", "-T enable tainting checks", +"-t enable tainting warnings", "-u dump core after parsing program", "-U allow unsafe operations", "-v print version, subversion (includes VERY IMPORTANT perl info)", "-V[:variable] print configuration summary (or a single Config.pm variable)", "-w enable many useful warnings (RECOMMENDED)", +"-W enable all warnings", +"-X disable all warnings", "-x[directory] strip off text before #!perl line and perhaps cd to directory", "\n", NULL }; char **p = usage_msg; - printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name); + PerlIO_printf(PerlIO_stdout(), + "\nUsage: %s [switches] [--] [programfile] [arguments]", + name); while (*p) - printf("\n %s", *p++); + PerlIO_printf(PerlIO_stdout(), "\n %s", *p++); } /* This routine handles any switches that can be given during run */ @@ -1923,33 +2153,36 @@ NULL char * Perl_moreswitches(pTHX_ char *s) { - I32 numlen; + STRLEN numlen; U32 rschar; switch (*s) { case '0': { - dTHR; - rschar = (U32)scan_oct(s, 4, &numlen); - SvREFCNT_dec(PL_nrs); + I32 flags = 0; + numlen = 4; + rschar = (U32)grok_oct(s, &numlen, &flags, NULL); + SvREFCNT_dec(PL_rs); if (rschar & ~((U8)~0)) - PL_nrs = &PL_sv_undef; + PL_rs = &PL_sv_undef; else if (!rschar && numlen >= 2) - PL_nrs = newSVpvn("", 0); + PL_rs = newSVpvn("", 0); else { - char ch = rschar; - PL_nrs = newSVpvn(&ch, 1); + char ch = (char)rschar; + PL_rs = newSVpvn(&ch, 1); } return s + numlen; } case 'C': - PL_widesyscalls = TRUE; - s++; + s++; + PL_unicode = parse_unicode_opts(&s); return s; case 'F': PL_minus_F = TRUE; - PL_splitstr = savepv(s + 1); - s += strlen(s); + PL_splitstr = ++s; + while (*s && !isSPACE(*s)) ++s; + *s = '\0'; + PL_splitstr = savepv(PL_splitstr); return s; case 'a': PL_minus_a = TRUE; @@ -1962,9 +2195,25 @@ Perl_moreswitches(pTHX_ char *s) case 'd': forbid_setid("-d"); s++; - if (*s == ':' || *s == '=') { - my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s)); + /* The following permits -d:Mod to accepts arguments following an = + in the fashion that -MSome::Mod does. */ + if (*s == ':' || *s == '=') { + char *start; + SV *sv; + sv = newSVpv("use Devel::", 0); + start = ++s; + /* We now allow -d:Module=Foo,Bar */ + while(isALNUM(*s) || *s==':') ++s; + if (*s != '=') + sv_catpv(sv, start); + else { + sv_catpvn(sv, start, s-start); + sv_catpv(sv, " split(/,/,q{"); + sv_catpv(sv, ++s); + sv_catpv(sv, "})"); + } s += strlen(s); + my_setenv("PERL5DB", SvPV(sv, PL_na)); } if (!PL_perldb) { PL_perldb = PERLDB_ALL; @@ -1976,7 +2225,8 @@ Perl_moreswitches(pTHX_ char *s) #ifdef DEBUGGING forbid_setid("-D"); if (isALPHA(s[1])) { - static char debopts[] = "psltocPmfrxuLHXDS"; + /* if adding extra options, remember to update DEBUG_MASK */ + static char debopts[] = "psltocPmfrxu HXDSTRJvC"; char *d; for (s++; *s && (d = strchr(debopts,*s)); s++) @@ -1986,11 +2236,15 @@ Perl_moreswitches(pTHX_ char *s) PL_debug = atoi(s+1); for (s++; isDIGIT(*s); s++) ; } - PL_debug |= 0x80000000; -#else - dTHR; +#ifdef EBCDIC + if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), + "-Dp not implemented on this platform\n"); +#endif + PL_debug |= DEBUG_TOP_FLAG; +#else /* !DEBUGGING */ if (ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ WARN_DEBUGGING, + Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Recompile perl with -DDEBUGGING to use -D switch\n"); for (s++; isALNUM(*s); s++) ; #endif @@ -1998,11 +2252,17 @@ Perl_moreswitches(pTHX_ char *s) return s; } case 'h': - usage(PL_origargv[0]); - PerlProc_exit(0); + usage(PL_origargv[0]); + my_exit(0); case 'i': if (PL_inplace) Safefree(PL_inplace); +#if defined(__CYGWIN__) /* do backup extension automagically */ + if (*(s+1) == '\0') { + PL_inplace = savepv(".bak"); + return s+1; + } +#endif /* __CYGWIN__ */ PL_inplace = savepv(s+1); /*SUPPRESS 530*/ for (s = PL_inplace; *s && !isSPACE(*s); s++) ; @@ -2012,7 +2272,7 @@ Perl_moreswitches(pTHX_ char *s) s++; } return s; - case 'I': /* -I handled both here and in parse_perl() */ + case 'I': /* -I handled both here and in parse_body() */ forbid_setid("-I"); ++s; while (*s && isSPACE(*s)) @@ -2028,7 +2288,7 @@ Perl_moreswitches(pTHX_ char *s) p++; } while (*p && *p != '-'); e = savepvn(s, e-s); - incpush(e, TRUE); + incpush(e, TRUE, TRUE, FALSE); Safefree(e); s = p; if (*s == '-') @@ -2040,25 +2300,40 @@ Perl_moreswitches(pTHX_ char *s) case 'l': PL_minus_l = TRUE; s++; - if (PL_ors) - Safefree(PL_ors); + if (PL_ors_sv) { + SvREFCNT_dec(PL_ors_sv); + PL_ors_sv = Nullsv; + } if (isDIGIT(*s)) { - PL_ors = savepv("\n"); - PL_orslen = 1; - *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen); + I32 flags = 0; + PL_ors_sv = newSVpvn("\n",1); + numlen = 3 + (*s == '0'); + *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL); s += numlen; } else { - dTHR; - if (RsPARA(PL_nrs)) { - PL_ors = "\n\n"; - PL_orslen = 2; + if (RsPARA(PL_rs)) { + PL_ors_sv = newSVpvn("\n\n",2); + } + else { + PL_ors_sv = newSVsv(PL_rs); } - else - PL_ors = SvPV(PL_nrs, PL_orslen); - PL_ors = savepvn(PL_ors, PL_orslen); } return s; + case 'A': + forbid_setid("-A"); + if (*++s) { + SV *sv=newSVpv("use assertions::activate split(/,/,q{",0); + sv_catpv(sv,s); + sv_catpv(sv,"})"); + s+=strlen(s); + if(!PL_preambleav) + PL_preambleav = newAV(); + av_push(PL_preambleav, sv); + } + else + Perl_croak(aTHX_ "No space allowed after -A"); + return s; case 'M': forbid_setid("-M"); /* XXX ? */ /* FALL THROUGH */ @@ -2082,6 +2357,9 @@ Perl_moreswitches(pTHX_ char *s) sv_catpv( 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_catpv(sv, ++s); @@ -2108,12 +2386,20 @@ Perl_moreswitches(pTHX_ char *s) PL_doswitches = TRUE; s++; return s; + case 't': + if (!PL_tainting) + Perl_croak(aTHX_ "Too late for \"-t\" option"); + s++; + return s; case 'T': if (!PL_tainting) Perl_croak(aTHX_ "Too late for \"-T\" option"); s++; return s; case 'u': +#ifdef MACOS_TRADITIONAL + Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh"); +#endif PL_do_undump = TRUE; s++; return s; @@ -2122,73 +2408,121 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'v': - printf(Perl_form(aTHX_ "\nThis is perl, v%v built for %s", - PL_patchlevel, ARCHNAME)); +#if !defined(DGUX) + PerlIO_printf(PerlIO_stdout(), + Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s", + 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)); + PerlIO_printf(PerlIO_stdout(), + Perl_form(aTHX_ " built under %s at %s %s\n", + OSNAME, __DATE__, __TIME__)); + PerlIO_printf(PerlIO_stdout(), + Perl_form(aTHX_ " OS Specific Release: %s\n", + OSVERS)); +#endif /* !DGUX */ + #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) - printf("\n(with %d registered patch%s, see perl -V for more detail)", - (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); + PerlIO_printf(PerlIO_stdout(), + "\n(with %d registered patch%s, " + "see perl -V for more detail)", + (int)LOCAL_PATCH_COUNT, + (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif - printf("\n\nCopyright 1987-2000, Larry Wall\n"); + PerlIO_printf(PerlIO_stdout(), + "\n\nCopyright 1987-2002, Larry Wall\n"); +#ifdef MACOS_TRADITIONAL + PerlIO_printf(PerlIO_stdout(), + "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n" + "maintained by Chris Nandor\n"); +#endif #ifdef MSDOS - printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); + PerlIO_printf(PerlIO_stdout(), + "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif #ifdef DJGPP - printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"); - printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n" + "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); #endif #ifdef OS2 - printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" - "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n"); + PerlIO_printf(PerlIO_stdout(), + "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" + "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n"); #endif #ifdef atarist - printf("atariST series port, ++jrb bammi@cadence.com\n"); + PerlIO_printf(PerlIO_stdout(), + "atariST series port, ++jrb bammi@cadence.com\n"); #endif #ifdef __BEOS__ - printf("BeOS port Copyright Tom Spindler, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "BeOS port Copyright Tom Spindler, 1997-1999\n"); #endif #ifdef MPE - printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n"); #endif #ifdef OEMVS - printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); #endif #ifdef __VOS__ - printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n"); #endif #ifdef __OPEN_VM - printf("VM/ESA port by Neale Ferguson, 1998-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "VM/ESA port by Neale Ferguson, 1998-1999\n"); #endif #ifdef POSIX_BC - printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); #endif #ifdef __MINT__ - printf("MiNT port by Guido Flohr, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "MiNT port by Guido Flohr, 1997-1999\n"); +#endif +#ifdef EPOC + PerlIO_printf(PerlIO_stdout(), + "EPOC port by Olaf Flebbe, 1999-2002\n"); +#endif +#ifdef UNDER_CE + printf("WINCE port by Rainer Keuchel, 2001-2002\n"); + printf("Built on " __DATE__ " " __TIME__ "\n\n"); + wce_hitreturn(); #endif #ifdef BINARY_BUILD_NOTICE BINARY_BUILD_NOTICE; #endif - printf("\n\ + PerlIO_printf(PerlIO_stdout(), + "\n\ 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.0 source kit.\n\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"); - PerlProc_exit(0); + my_exit(0); case 'w': if (! (PL_dowarn & G_WARN_ALL_MASK)) - PL_dowarn |= G_WARN_ON; + PL_dowarn |= G_WARN_ON; s++; return s; case 'W': - PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; - PL_compiling.cop_warnings = WARN_ALL ; + PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; + if (!specialWARN(PL_compiling.cop_warnings)) + SvREFCNT_dec(PL_compiling.cop_warnings); + PL_compiling.cop_warnings = pWARN_ALL ; s++; return s; case 'X': - PL_dowarn = G_WARN_ALL_OFF; - PL_compiling.cop_warnings = WARN_NONE ; + PL_dowarn = G_WARN_ALL_OFF; + if (!specialWARN(PL_compiling.cop_warnings)) + SvREFCNT_dec(PL_compiling.cop_warnings); + PL_compiling.cop_warnings = pWARN_NONE ; s++; return s; case '*': @@ -2255,77 +2589,42 @@ STATIC void S_init_interp(pTHX) { -#ifdef PERL_OBJECT /* XXX kludge */ -#define I_REINIT \ - STMT_START { \ - PL_chopset = " \n-"; \ - PL_copline = NOLINE; \ - PL_curcop = &PL_compiling;\ - PL_curcopdb = NULL; \ - PL_dbargs = 0; \ - PL_dumpindent = 4; \ - PL_laststatval = -1; \ - PL_laststype = OP_STAT; \ - PL_maxscream = -1; \ - PL_maxsysfd = MAXSYSFD; \ - PL_statname = Nullsv; \ - PL_tmps_floor = -1; \ - PL_tmps_ix = -1; \ - PL_op_mask = NULL; \ - PL_laststatval = -1; \ - PL_laststype = OP_STAT; \ - PL_mess_sv = Nullsv; \ - PL_splitstr = " "; \ - PL_generation = 100; \ - PL_exitlist = NULL; \ - PL_exitlistlen = 0; \ - PL_regindent = 0; \ - PL_in_clean_objs = FALSE; \ - PL_in_clean_all = FALSE; \ - PL_profiledata = NULL; \ - PL_rsfp = Nullfp; \ - PL_rsfp_filters = Nullav; \ - PL_dirty = FALSE; \ - } STMT_END - I_REINIT; -#else -# ifdef MULTIPLICITY -# define PERLVAR(var,type) -# define PERLVARA(var,n,type) -# if defined(PERL_IMPLICIT_CONTEXT) -# 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; +#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; -# endif -# include "intrpvar.h" -# ifndef USE_THREADS -# include "thrdvar.h" -# endif -# undef PERLVAR -# undef PERLVARA -# undef PERLVARI -# undef PERLVARIC +# else /* !USE_5005THREADS */ +# define PERLVARI(var,type,init) aTHX->var = init; +# define PERLVARIC(var,type,init) aTHX->var = init; +# endif /* USE_5005THREADS */ # else -# define PERLVAR(var,type) -# define PERLVARA(var,n,type) -# define PERLVARI(var,type,init) PL_##var = init; -# define PERLVARIC(var,type,init) PL_##var = init; -# include "intrpvar.h" -# ifndef USE_THREADS -# include "thrdvar.h" -# endif -# undef PERLVAR -# undef PERLVARA -# undef PERLVARI -# undef PERLVARIC +# 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 +# undef PERLVAR +# undef PERLVARA +# undef PERLVARI +# undef PERLVARIC +#else +# define PERLVAR(var,type) +# define PERLVARA(var,n,type) +# 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 +# undef PERLVAR +# undef PERLVARA +# undef PERLVARI +# undef PERLVARIC #endif } @@ -2333,19 +2632,8 @@ S_init_interp(pTHX) STATIC void S_init_main_stash(pTHX) { - dTHR; GV *gv; - /* Note that strtab is a rather special HV. Assumptions are made - about not iterating on it, and not adding tie magic to it. - It is properly deallocated in perl_destruct() */ - PL_strtab = newHV(); -#ifdef USE_THREADS - MUTEX_INIT(&PL_strtab_mutex); -#endif - HvSHAREKEYS_off(PL_strtab); /* mandatory */ - hv_ksplit(PL_strtab, 512); - PL_curstash = PL_defstash = newHV(); PL_curstname = newSVpvn("main",4); gv = gv_fetchpv("main::",TRUE, SVt_PVHV); @@ -2376,8 +2664,10 @@ S_init_main_stash(pTHX) STATIC void S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) { - dTHR; - register char *s; + char *quote; + char *code; + char *cpp_discard_flag; + char *perl; *fdscript = -1; @@ -2401,15 +2691,17 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) } } + CopFILE_free(PL_curcop); CopFILE_set(PL_curcop, PL_origfilename); if (strEQ(PL_origfilename,"-")) scriptname = ""; if (*fdscript >= 0) { PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE); -#if defined(HAS_FCNTL) && defined(F_SETFD) - if (PL_rsfp) - fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */ -#endif +# if defined(HAS_FCNTL) && defined(F_SETFD) + if (PL_rsfp) + /* ensure close-on-exec */ + fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); +# endif } else if (PL_preprocess) { char *cpp_cfg = CPPSTDIN; @@ -2420,82 +2712,75 @@ 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_catpvn(sv, "-I", 2); - sv_catpv(sv,PRIVLIB_EXP); +# ifndef VMS + sv_catpvn(sv, "-I", 2); + sv_catpv(sv,PRIVLIB_EXP); +# endif + + DEBUG_P(PerlIO_printf(Perl_debug_log, + "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n", + scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS)); + +# if defined(MSDOS) || defined(WIN32) || defined(VMS) + quote = "\""; +# else + quote = "'"; +# endif + +# ifdef VMS + cpp_discard_flag = ""; +# else + cpp_discard_flag = "-C"; +# endif + +# ifdef OS2 + perl = os2_execname(aTHX); +# else + perl = PL_origargv[0]; +# endif + + + /* This strips off Perl comments which might interfere with + the C pre-processor, including #!. #line directives are + deliberately stripped to avoid confusion with Perl's version + of #line. FWP played some golf with it so it will fit + into VMS's 255 character buffer. + */ + if( PL_doextract ) + code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print"; + else + code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print"; + + Perl_sv_setpvf(aTHX_ cmd, "\ +%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s", + perl, quote, code, quote, scriptname, cpp, + cpp_discard_flag, sv, CPPMINUS); -#ifdef MSDOS - Perl_sv_setpvf(aTHX_ cmd, "\ -sed %s -e \"/^[^#]/b\" \ - -e \"/^#[ ]*include[ ]/b\" \ - -e \"/^#[ ]*define[ ]/b\" \ - -e \"/^#[ ]*if[ ]/b\" \ - -e \"/^#[ ]*ifdef[ ]/b\" \ - -e \"/^#[ ]*ifndef[ ]/b\" \ - -e \"/^#[ ]*else/b\" \ - -e \"/^#[ ]*elif[ ]/b\" \ - -e \"/^#[ ]*undef[ ]/b\" \ - -e \"/^#[ ]*endif/b\" \ - -e \"s/^#.*//\" \ - %s | %"SVf" -C %"SVf" %s", - (PL_doextract ? "-e \"1,/^#/d\n\"" : ""), -#else -# ifdef __OPEN_VM - Perl_sv_setpvf(aTHX_ cmd, "\ -%s %s -e '/^[^#]/b' \ - -e '/^#[ ]*include[ ]/b' \ - -e '/^#[ ]*define[ ]/b' \ - -e '/^#[ ]*if[ ]/b' \ - -e '/^#[ ]*ifdef[ ]/b' \ - -e '/^#[ ]*ifndef[ ]/b' \ - -e '/^#[ ]*else/b' \ - -e '/^#[ ]*elif[ ]/b' \ - -e '/^#[ ]*undef[ ]/b' \ - -e '/^#[ ]*endif/b' \ - -e 's/^[ ]*#.*//' \ - %s | %"SVf" %"SVf" %s", -# else - Perl_sv_setpvf(aTHX_ cmd, "\ -%s %s -e '/^[^#]/b' \ - -e '/^#[ ]*include[ ]/b' \ - -e '/^#[ ]*define[ ]/b' \ - -e '/^#[ ]*if[ ]/b' \ - -e '/^#[ ]*ifdef[ ]/b' \ - -e '/^#[ ]*ifndef[ ]/b' \ - -e '/^#[ ]*else/b' \ - -e '/^#[ ]*elif[ ]/b' \ - -e '/^#[ ]*undef[ ]/b' \ - -e '/^#[ ]*endif/b' \ - -e 's/^[ ]*#.*//' \ - %s | %"SVf" -C %"SVf" %s", -# endif -#ifdef LOC_SED - LOC_SED, -#else - "sed", -#endif - (PL_doextract ? "-e '1,/^#/d\n'" : ""), -#endif - scriptname, cpp, sv, CPPMINUS); PL_doextract = FALSE; -#ifdef IAMSUID /* actually, this is caught earlier */ - if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */ -#ifdef HAS_SETEUID - (void)seteuid(PL_uid); /* musn't stay setuid root */ -#else -#ifdef HAS_SETREUID - (void)setreuid((Uid_t)-1, PL_uid); -#else -#ifdef HAS_SETRESUID - (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1); -#else - PerlProc_setuid(PL_uid); -#endif -#endif -#endif +# ifdef IAMSUID /* actually, this is caught earlier */ + if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */ +# ifdef HAS_SETEUID + (void)seteuid(PL_uid); /* musn't stay setuid root */ +# else +# ifdef HAS_SETREUID + (void)setreuid((Uid_t)-1, PL_uid); +# else +# ifdef HAS_SETRESUID + (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1); +# else + PerlProc_setuid(PL_uid); +# endif +# endif +# endif if (PerlProc_geteuid() != PL_uid) Perl_croak(aTHX_ "Can't do seteuid!\n"); } -#endif /* IAMSUID */ +# endif /* IAMSUID */ + + DEBUG_P(PerlIO_printf(Perl_debug_log, + "PL_preprocess: cmd=\"%s\"\n", + SvPVX(cmd))); + PL_rsfp = PerlProc_popen(SvPVX(cmd), "r"); SvREFCNT_dec(cmd); SvREFCNT_dec(cpp); @@ -2506,35 +2791,43 @@ sed %s -e \"/^[^#]/b\" \ } else { PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); -#if defined(HAS_FCNTL) && defined(F_SETFD) - if (PL_rsfp) - fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */ -#endif +# if defined(HAS_FCNTL) && defined(F_SETFD) + if (PL_rsfp) + /* ensure close-on-exec */ + fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); +# endif } if (!PL_rsfp) { -#ifdef DOSUID -#ifndef IAMSUID /* in case script is not readable before setuid */ - if (PL_euid && - 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"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", - CopFILE(PL_curcop), Strerror(errno)); +# ifdef DOSUID +# ifndef IAMSUID /* in case script is not readable before setuid */ + if (PL_euid && + 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"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 +# ifdef IAMSUID + errno = EPERM; + Perl_croak(aTHX_ "Can't open perl script: %s\n", + Strerror(errno)); +# else + Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", + CopFILE(PL_curcop), Strerror(errno)); +# endif } } /* Mention * I_SYSSTATVFS HAS_FSTATVFS * I_SYSMOUNT - * I_STATFS HAS_FSTATFS + * I_STATFS HAS_FSTATFS HAS_GETFSSTAT * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT * here so that metaconfig picks them up. */ @@ -2553,74 +2846,87 @@ S_fd_on_nosuid_fs(pTHX_ int fd) * an irrelevant filesystem while trying to reach the right one. */ -# ifdef HAS_FSTATVFS +#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(HAS_FSTATVFS) +# define FD_ON_NOSUID_CHECK_OKAY struct statvfs stfs; + check_okay = fstatvfs(fd, &stfs) == 0; on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID); -# else -# ifdef PERL_MOUNT_NOSUID -# if defined(HAS_FSTATFS) && \ - defined(HAS_STRUCT_STATFS) && \ - defined(HAS_STRUCT_STATFS_F_FLAGS) +# endif /* fstatvfs */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(PERL_MOUNT_NOSUID) && \ + defined(HAS_FSTATFS) && \ + defined(HAS_STRUCT_STATFS) && \ + defined(HAS_STRUCT_STATFS_F_FLAGS) +# define FD_ON_NOSUID_CHECK_OKAY struct statfs stfs; + check_okay = fstatfs(fd, &stfs) == 0; on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID); -# else -# if defined(HAS_FSTAT) && \ - defined(HAS_USTAT) && \ - defined(HAS_GETMNT) && \ - defined(HAS_STRUCT_FS_DATA) && \ - defined(NOSTAT_ONE) - struct stat fdst; +# endif /* fstatfs */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(PERL_MOUNT_NOSUID) && \ + defined(HAS_FSTAT) && \ + defined(HAS_USTAT) && \ + defined(HAS_GETMNT) && \ + defined(HAS_STRUCT_FS_DATA) && \ + defined(NOSTAT_ONE) +# define FD_ON_NOSUID_CHECK_OKAY + Stat_t 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. */ + 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; - } - } - } - } + 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) - FILE *mtab = fopen("/etc/mtab", "r"); - struct mntent *entry; - struct stat stb, fsb; +# endif /* fstat+ustat+getmnt */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(HAS_GETMNTENT) && \ + defined(HAS_HASMNTOPT) && \ + defined(MNTOPT_NOSUID) +# define FD_ON_NOSUID_CHECK_OKAY + FILE *mtab = fopen("/etc/mtab", "r"); + struct mntent *entry; + Stat_t stb, fsb; if (mtab && (fstat(fd, &stb) == 0)) { - while (entry = getmntent(mtab)) { - if (stat(entry->mnt_dir, &fsb) == 0 - && fsb.st_dev == stb.st_dev) - { - /* found the filesystem */ - check_okay = 1; - if (hasmntopt(entry, MNTOPT_NOSUID)) - on_nosuid = 1; - break; - } /* A single fs may well fail its stat(). */ - } + while (entry = getmntent(mtab)) { + if (stat(entry->mnt_dir, &fsb) == 0 + && fsb.st_dev == stb.st_dev) + { + /* found the filesystem */ + check_okay = 1; + if (hasmntopt(entry, MNTOPT_NOSUID)) + on_nosuid = 1; + break; + } /* A single fs may well fail its stat(). */ + } } if (mtab) - fclose(mtab); -# endif /* getmntent+hasmntopt */ -# endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */ -# endif /* statvfs */ + fclose(mtab); +# endif /* getmntent+hasmntopt */ - if (!check_okay) + if (!check_okay) Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename); return on_nosuid; } @@ -2629,7 +2935,9 @@ S_fd_on_nosuid_fs(pTHX_ int fd) STATIC void S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) { +#ifdef IAMSUID int which; +#endif /* do we need to emulate setuid on scripts? */ @@ -2652,7 +2960,6 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) */ #ifdef DOSUID - dTHR; char *s, *s2; if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */ @@ -2680,7 +2987,7 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) * Then we just have to make sure he or she can execute it. */ { - struct stat tmpstatbuf; + Stat_t tmpstatbuf; if ( #ifdef HAS_SETREUID @@ -2701,16 +3008,6 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) if (tmpstatbuf.st_dev != PL_statbuf.st_dev || tmpstatbuf.st_ino != PL_statbuf.st_ino) { (void)PerlIO_close(PL_rsfp); - if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */ - PerlIO_printf(PL_rsfp, -"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, - CopFILE(PL_curcop), - PL_statbuf.st_uid, PL_statbuf.st_gid); - (void)PerlProc_pclose(PL_rsfp); - } Perl_croak(aTHX_ "Permission denied\n"); } if ( @@ -2860,7 +3157,6 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #else /* !DOSUID */ if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW - dTHR; PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */ if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID) || @@ -2879,14 +3175,39 @@ STATIC void S_find_beginning(pTHX) { register char *s, *s2; +#ifdef MACOS_TRADITIONAL + int maclines = 0; +#endif /* 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 (!gMacPerl_AlwaysExtract) + Perl_croak(aTHX_ "No Perl script found in input\n"); + + if (PL_doextract) /* require explicit override ? */ + if (!OverrideExtract(PL_origfilename)) + Perl_croak(aTHX_ "User aborted script\n"); + else + PL_doextract = FALSE; + + /* Pater peccavi, file does not have #! */ + PerlIO_rewind(PL_rsfp); + + break; + } +#else while (PL_doextract) { if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) Perl_croak(aTHX_ "No Perl script found in input\n"); - if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) { +#endif + s2 = s; + if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) { PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */ PL_doextract = FALSE; while (*s && !(isSPACE (*s) || *s == '#')) s++; @@ -2896,8 +3217,23 @@ S_find_beginning(pTHX) while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--; if (strnEQ(s2-4,"perl",4)) /*SUPPRESS 530*/ - while (s = moreswitches(s)) ; + while ((s = moreswitches(s))) + ; } +#ifdef MACOS_TRADITIONAL + /* We are always searching for the #!perl line in MacPerl, + * so if we find it, still keep the line count correct + * by counting lines we already skipped over + */ + for (; maclines > 0 ; maclines--) + PerlIO_ungetc(PL_rsfp, '\n'); + + break; + + /* gMacPerl_AlwaysExtract is false in MPW tool */ + } else if (gMacPerl_AlwaysExtract) { + ++maclines; +#endif } } } @@ -2929,7 +3265,6 @@ S_forbid_setid(pTHX_ char *s) void Perl_init_debugger(pTHX) { - dTHR; HV *ostash = PL_curstash; PL_curstash = PL_debstash; @@ -2940,11 +3275,13 @@ Perl_init_debugger(pTHX) PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV)); sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */ PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV))); - sv_setiv(PL_DBsingle, 0); + sv_setiv(PL_DBsingle, 0); PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV))); - sv_setiv(PL_DBtrace, 0); + sv_setiv(PL_DBtrace, 0); PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV))); - sv_setiv(PL_DBsignal, 0); + sv_setiv(PL_DBsignal, 0); + PL_DBassertion = GvSV((gv_fetchpv("assertion", GV_ADDMULTI, SVt_PV))); + sv_setiv(PL_DBassertion, 0); PL_curstash = ostash; } @@ -2997,7 +3334,6 @@ Perl_init_stacks(pTHX) STATIC void S_nuke_stacks(pTHX) { - dTHR; while (PL_curstackinfo->si_next) PL_curstackinfo = PL_curstackinfo->si_next; while (PL_curstackinfo) { @@ -3014,16 +3350,10 @@ S_nuke_stacks(pTHX) Safefree(PL_retstack); } -#ifndef PERL_OBJECT -static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */ -#endif - STATIC void S_init_lexer(pTHX) { -#ifdef PERL_OBJECT - PerlIO *tmpfp; -#endif + PerlIO *tmpfp; tmpfp = PL_rsfp; PL_rsfp = Nullfp; lex_start(PL_linestr); @@ -3034,15 +3364,14 @@ S_init_lexer(pTHX) STATIC void S_init_predump_symbols(pTHX) { - dTHR; GV *tmpgv; - GV *othergv; IO *io; sv_setpvn(get_sv("\"", TRUE), " ", 1); PL_stdingv = gv_fetchpv("STDIN",TRUE, 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); GvMULTI_on(tmpgv); @@ -3051,6 +3380,7 @@ S_init_predump_symbols(pTHX) tmpgv = gv_fetchpv("STDOUT",TRUE, 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); @@ -3060,6 +3390,7 @@ S_init_predump_symbols(pTHX) PL_stderrgv = gv_fetchpv("STDERR",TRUE, 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); GvMULTI_on(tmpgv); @@ -3067,18 +3398,15 @@ S_init_predump_symbols(pTHX) PL_statname = NEWSV(66,0); /* last filename we did stat on */ - if (!PL_osname) - PL_osname = savepv(OSNAME); + if (PL_osname) + Safefree(PL_osname); + PL_osname = savepv(OSNAME); } -STATIC void -S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env) +void +Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) { - dTHR; char *s; - SV *sv; - GV* tmpgv; - argc--,argv++; /* skip name of script */ if (PL_doswitches) { for (; argc > 0 && **argv == '-'; argc--,argv++) { @@ -3088,7 +3416,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register argc--,argv++; break; } - if (s = strchr(argv[0], '=')) { + if ((s = strchr(argv[0], '='))) { *s++ = '\0'; sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s); } @@ -3096,6 +3424,65 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1); } } + if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) { + GvMULTI_on(PL_argvgv); + (void)gv_AVadd(PL_argvgv); + av_clear(GvAVn(PL_argvgv)); + for (; argc > 0; argc--,argv++) { + SV *sv = newSVpv(argv[0],0); + av_push(GvAVn(PL_argvgv),sv); + if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { + if (PL_unicode & PERL_UNICODE_ARGV_FLAG) + SvUTF8_on(sv); + } + if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */ + (void)sv_utf8_decode(sv); + } + } +} + +#ifdef HAS_PROCSELFEXE +/* This is a function so that we don't hold on to MAXPATHLEN + bytes of stack longer than necessary + */ +STATIC void +S_procself_val(pTHX_ SV *sv, char *arg0) +{ + char buf[MAXPATHLEN]; + int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1); + + /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe) + includes a spurious NUL which will cause $^X to fail in system + or backticks (this will prevent extensions from being built and + many tests from working). readlink is not meant to add a NUL. + Normal readlink works fine. + */ + if (len > 0 && buf[len-1] == '\0') { + len--; + } + + /* FreeBSD's implementation is acknowledged to be imperfect, sometimes + returning the text "unknown" from the readlink rather than the path + to the executable (or returning an error from the readlink). Any valid + path has a '/' in it somewhere, so use that to validate the result. + See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703 + */ + if (len > 0 && memchr(buf, '/', len)) { + sv_setpvn(sv,buf,len); + } + else { + sv_setpv(sv,arg0); + } +} +#endif /* HAS_PROCSELFEXE */ + +STATIC void +S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env) +{ + char *s; + SV *sv; + GV* tmpgv; + PL_toptarget = NEWSV(0,0); sv_upgrade(PL_toptarget, SVt_PVFM); sv_setpvn(PL_toptarget, "", 0); @@ -3105,30 +3492,35 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register PL_formtarget = PL_bodytarget; TAINT; - if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) { + + init_argv_symbols(argc,argv); + + if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) { +#ifdef MACOS_TRADITIONAL + /* $0 is not majick on a Mac */ + sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename)); +#else sv_setpv(GvSV(tmpgv),PL_origfilename); magicname("0", "0", 1); +#endif } - if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)) + 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()); + sv_setpv(GvSV(tmpgv), os2_execname(aTHX)); #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); - av_clear(GvAVn(PL_argvgv)); - for (; argc > 0; argc--,argv++) { - av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0)); - } +#endif } - if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) { + if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) { HV *hv; GvMULTI_on(PL_envgv); hv = GvHVn(PL_envgv); - hv_magic(hv, PL_envgv, 'E'); -#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */ + hv_magic(hv, Nullgv, PERL_MAGIC_env); +#ifdef USE_ENVIRON_ARRAY /* Note that if the supplied env parameter is actually a copy of the global environ then it may now point to free'd memory if the environment has been modified since. To avoid this @@ -3136,31 +3528,47 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register */ if (!env) env = environ; - if (env != environ) + if (env != environ +# ifdef USE_ITHREADS + && PL_curinterp == aTHX +# endif + ) + { environ[0] = Nullch; - for (; *env; env++) { + } + if (env) + for (; *env; env++) { if (!(s = strchr(*env,'='))) continue; - *s++ = '\0'; #if defined(MSDOS) + *s = '\0'; (void)strupr(*env); -#endif - sv = newSVpv(s--,0); - (void)hv_store(hv, *env, s - *env, sv, 0); *s = '='; -#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV) - /* Sins of the RTL. See note in my_setenv(). */ - (void)PerlEnv_putenv(savepv(*env)); -#endif - } -#endif -#ifdef DYNAMIC_ENV_FETCH - HvNAME(hv) = savepv(ENV_HV_NAME); #endif + sv = newSVpv(s+1, 0); + (void)hv_store(hv, *env, s - *env, sv, 0); + if (env != environ) + mg_set(sv); + } +#endif /* USE_ENVIRON_ARRAY */ } TAINT_NOT; - if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) + if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) { + SvREADONLY_off(GvSV(tmpgv)); sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); + SvREADONLY_on(GvSV(tmpgv)); + } +#ifdef THREADS_HAVE_PIDS + PL_ppid = (IV)getppid(); +#endif + + /* touch @F array to prevent spurious warnings 20020415 MJD */ + if (PL_minus_a) { + (void) get_av("main::F", TRUE | GV_ADDMULTI); + } + /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */ + (void) get_av("main::-", TRUE | GV_ADDMULTI); + (void) get_av("main::+", TRUE | GV_ADDMULTI); } STATIC void @@ -3171,9 +3579,9 @@ S_init_perllib(pTHX) #ifndef VMS s = PerlEnv_getenv("PERL5LIB"); if (s) - incpush(s, TRUE); + incpush(s, TRUE, TRUE, TRUE); else - incpush(PerlEnv_getenv("PERLLIB"), FALSE); + incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE); #else /* VMS */ /* Treat PERL5?LIB as a possible search list logical name -- the * "natural" VMS idiom for a Unix path string. We allow each @@ -3182,81 +3590,128 @@ S_init_perllib(pTHX) char buf[256]; int idx = 0; if (my_trnlnm("PERL5LIB",buf,0)) - do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx)); + do { incpush(buf,TRUE,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx)); else - while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE); + while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE); #endif /* VMS */ } /* Use the ~-expanded versions of APPLLIB (undocumented), - ARCHLIB PRIVLIB SITEARCH and SITELIB + ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB */ #ifdef APPLLIB_EXP - incpush(APPLLIB_EXP, TRUE); + incpush(APPLLIB_EXP, TRUE, TRUE, TRUE); #endif #ifdef ARCHLIB_EXP - incpush(ARCHLIB_EXP, FALSE); + incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE); #endif +#ifdef MACOS_TRADITIONAL + { + Stat_t tmpstatbuf; + SV * privdir = NEWSV(55, 0); + char * macperl = PerlEnv_getenv("MACPERL"); + + if (!macperl) + macperl = ""; + + Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl); + if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) + incpush(SvPVX(privdir), TRUE, FALSE, TRUE); + Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl); + if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) + incpush(SvPVX(privdir), TRUE, FALSE, TRUE); + + SvREFCNT_dec(privdir); + } + if (!PL_tainting) + incpush(":", FALSE, FALSE, TRUE); +#else #ifndef PRIVLIB_EXP -#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" +# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" #endif -#if defined(WIN32) - incpush(PRIVLIB_EXP, TRUE); +#if defined(WIN32) + incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE); #else - incpush(PRIVLIB_EXP, FALSE); + incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE); +#endif + +#ifdef SITEARCH_EXP + /* sitearch is always relative to sitelib on Windows for + * DLL-based path intuition to work correctly */ +# if !defined(WIN32) + incpush(SITEARCH_EXP, FALSE, FALSE, TRUE); +# endif #endif -#if defined(WIN32) - incpush(SITELIB_EXP, TRUE); /* XXX Win32 needs inc_version_list support */ -#else #ifdef SITELIB_EXP - { - char *path = SITELIB_EXP; - - if (path) { - char buf[1024]; - strcpy(buf,path); - if (strrchr(buf,'/')) /* XXX Hack, Configure var needed */ - *strrchr(buf,'/') = '\0'; - incpush(buf, TRUE); - } - } +# if defined(WIN32) + /* this picks up sitearch as well */ + incpush(SITELIB_EXP, TRUE, FALSE, TRUE); +# else + incpush(SITELIB_EXP, FALSE, FALSE, TRUE); +# endif #endif + +#ifdef SITELIB_STEM /* Search for version-specific dirs below here */ + incpush(SITELIB_STEM, FALSE, TRUE, TRUE); #endif -#if defined(PERL_VENDORLIB_EXP) -#if defined(WIN32) - incpush(PERL_VENDORLIB_EXP, TRUE); -#else - incpush(PERL_VENDORLIB_EXP, FALSE); + +#ifdef PERL_VENDORARCH_EXP + /* vendorarch is always relative to vendorlib on Windows for + * DLL-based path intuition to work correctly */ +# if !defined(WIN32) + incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE); +# endif #endif + +#ifdef PERL_VENDORLIB_EXP +# if defined(WIN32) + incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE); /* this picks up vendorarch as well */ +# else + incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE); +# endif +#endif + +#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */ + incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE); +#endif + +#ifdef PERL_OTHERLIBDIRS + incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE); #endif + if (!PL_tainting) - incpush(".", FALSE); + incpush(".", FALSE, FALSE, TRUE); +#endif /* MACOS_TRADITIONAL */ } -#if defined(DOSISH) +#if defined(DOSISH) || defined(EPOC) # define PERLLIB_SEP ';' #else # if defined(VMS) # define PERLLIB_SEP '|' # else -# define PERLLIB_SEP ':' +# if defined(MACOS_TRADITIONAL) +# define PERLLIB_SEP ',' +# else +# define PERLLIB_SEP ':' +# endif # endif #endif #ifndef PERLLIB_MANGLE # define PERLLIB_MANGLE(s,n) (s) -#endif +#endif STATIC void -S_incpush(pTHX_ char *p, int addsubdirs) +S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep) { SV *subdir = Nullsv; - if (!p) + if (!p || !*p) return; - if (addsubdirs) { + if (addsubdirs || addoldvers) { subdir = sv_newmortal(); } @@ -3266,13 +3721,15 @@ S_incpush(pTHX_ char *p, int addsubdirs) char *s; /* skip any consecutive separators */ - while ( *p == PERLLIB_SEP ) { - /* Uncomment the next line for PATH semantics */ - /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */ - p++; + if (usesep) { + while ( *p == PERLLIB_SEP ) { + /* Uncomment the next line for PATH semantics */ + /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */ + p++; + } } - if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) { + if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) { sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)), (STRLEN)(s - p)); p = s + 1; @@ -3281,18 +3738,27 @@ S_incpush(pTHX_ char *p, int addsubdirs) sv_setpv(libdir, PERLLIB_MANGLE(p, 0)); p = Nullch; /* break out */ } +#ifdef MACOS_TRADITIONAL + if (!strchr(SvPVX(libdir), ':')) { + char buf[256]; + + sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0)); + } + if (SvPVX(libdir)[SvCUR(libdir)-1] != ':') + sv_catpv(libdir, ":"); +#endif /* * BEFORE pushing libdir onto @INC we may first push version- and * archname-specific sub-directories. */ - if (addsubdirs) { + if (addsubdirs || addoldvers) { #ifdef PERL_INC_VERSION_LIST /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ const char *incverlist[] = { PERL_INC_VERSION_LIST }; const char **incver; #endif - struct stat tmpstatbuf; + Stat_t tmpstatbuf; #ifdef VMS char *unix; STRLEN len; @@ -3307,35 +3773,49 @@ S_incpush(pTHX_ char *p, int addsubdirs) "Failed to unixify @INC element \"%s\"\n", SvPV(libdir,len)); #endif - /* .../version/archname if -d .../version/archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", 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)); - - /* .../version if -d .../version */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, 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)); - - /* .../archname if -d .../archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME); - if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && - S_ISDIR(tmpstatbuf.st_mode)) - av_push(GvAVn(PL_incgv), newSVsv(subdir)); + if (addsubdirs) { +#ifdef MACOS_TRADITIONAL +#define PERL_AV_SUFFIX_FMT "" +#define PERL_ARCH_FMT "%s:" +#define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT +#else +#define PERL_AV_SUFFIX_FMT "/" +#define PERL_ARCH_FMT "/%s" +#define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT +#endif + /* .../version/archname if -d .../version/archname */ + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT, + 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)); -#ifdef PERL_INC_VERSION_LIST - for (incver = incverlist; *incver; incver++) { - /* .../xxx if -d .../xxx */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver); + /* .../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)); + + /* .../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)); + } + +#ifdef PERL_INC_VERSION_LIST + if (addoldvers) { + 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)); + } } #endif } @@ -3345,7 +3825,7 @@ S_incpush(pTHX_ char *p, int addsubdirs) } } -#ifdef USE_THREADS +#ifdef USE_5005THREADS STATIC struct perl_thread * S_init_main_thread(pTHX) { @@ -3382,6 +3862,7 @@ S_init_main_thread(pTHX) thr->tid = 0; thr->next = thr; thr->prev = thr; + thr->thr_done = 0; MUTEX_UNLOCK(&PL_threads_mutex); #ifdef HAVE_THREAD_INTERN @@ -3393,11 +3874,12 @@ S_init_main_thread(pTHX) #else thr->self = pthread_self(); #endif /* SET_THREAD_SELF */ - SET_THR(thr); + PERL_SET_THX(thr); /* - * These must come after the SET_THR because sv_setpvn does - * SvTAINT and the taint fields require dTHR. + * 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); @@ -3410,6 +3892,7 @@ S_init_main_thread(pTHX) (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); @@ -3420,12 +3903,11 @@ S_init_main_thread(pTHX) return thr; } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { - dTHR; SV *atsv; line_t oldline = CopLINE(PL_curcop); CV *cv; @@ -3435,7 +3917,22 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (AvFILL(paramList) >= 0) { cv = (CV*)av_shift(paramList); - SAVEFREESV(cv); + if (PL_savebegin) { + if (paramList == PL_beginav) { + /* save PL_beginav for compiler */ + if (! PL_beginav_save) + PL_beginav_save = newAV(); + av_push(PL_beginav_save, (SV*)cv); + } + else if (paramList == PL_checkav) { + /* save PL_checkav for compiler */ + if (! PL_checkav_save) + PL_checkav_save = newAV(); + av_push(PL_checkav_save, (SV*)cv); + } + } else { + SAVEFREESV(cv); + } #ifdef PERL_FLEXIBLE_EXCEPTIONS CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv); #else @@ -3449,7 +3946,6 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) atsv = ERRSV; (void)SvPV(atsv, len); if (len) { - STRLEN n_a; PL_curcop = &PL_compiling; CopLINE_set(PL_curcop, oldline); if (paramList == PL_beginav) @@ -3463,7 +3959,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (PL_scopestack_ix > oldscope) LEAVE; JMPENV_POP; - Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a)); + Perl_croak(aTHX_ "%"SVf"", atsv); } break; case 1: @@ -3523,8 +4019,6 @@ S_call_list_body(pTHX_ CV *cv) void Perl_my_exit(pTHX_ U32 status) { - dTHR; - DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n", thr, (unsigned long) status)); switch (status) { @@ -3560,7 +4054,7 @@ Perl_my_failure_exit(pTHX) if (errno & 255) STATUS_POSIX_SET(errno); else { - exitstatus = STATUS_POSIX >> 8; + exitstatus = STATUS_POSIX >> 8; if (exitstatus & 255) STATUS_POSIX_SET(exitstatus); else @@ -3573,7 +4067,6 @@ Perl_my_failure_exit(pTHX) STATIC void S_my_exit_jump(pTHX) { - dTHR; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; @@ -3594,12 +4087,8 @@ S_my_exit_jump(pTHX) JMPENV_JUMP(2); } -#ifdef PERL_OBJECT -#include "XSUB.h" -#endif - static I32 -read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen) +read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) { char *p, *nl; p = SvPVX(PL_e_script);