X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=8b73d25fad8dfd4d9840f6bb7f02599e18cddc88;hb=98b50af3d45dfb6f244ad0156bf5b77f62f20375;hp=54f68c762bec8f8ed41a40bbbd00dc4000e27420;hpb=d13ea15cf2b8e1eaa0f689391ed8162333a23e82;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 54f68c7..8b73d25 100644 --- a/perl.c +++ b/perl.c @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-2001 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,11 +16,28 @@ #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 +#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 @@ -39,17 +56,7 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); #endif #endif -#if defined(USE_5005THREADS) -# define INIT_TLS_AND_INTERP \ - STMT_START { \ - if (!PL_curinterp) { \ - PERL_SET_INTERP(my_perl); \ - INIT_THREADS; \ - ALLOC_THREAD_KEY; \ - } \ - } STMT_END -#else -# if defined(USE_ITHREADS) +#if defined(USE_ITHREADS) # define INIT_TLS_AND_INTERP \ STMT_START { \ if (!PL_curinterp) { \ @@ -63,7 +70,7 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); PERL_SET_THX(my_perl); \ } \ } STMT_END -# else +#else # define INIT_TLS_AND_INTERP \ STMT_START { \ if (!PL_curinterp) { \ @@ -72,7 +79,6 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); PERL_SET_THX(my_perl); \ } STMT_END # endif -#endif #ifdef PERL_IMPLICIT_SYS PerlInterpreter * @@ -102,6 +108,8 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, #else /* +=head1 Embedding Functions + =for apidoc perl_alloc Allocates a new Perl interpreter. See L. @@ -113,6 +121,9 @@ 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)); @@ -134,12 +145,6 @@ Initializes a new Perl interpreter. See L. void perl_construct(pTHXx) { -#ifdef USE_5005THREADS -#ifndef FAKE_THREADS - struct perl_thread *thr = NULL; -#endif /* FAKE_THREADS */ -#endif /* USE_5005THREADS */ - #ifdef MULTIPLICITY init_interp(); PL_perl_destruct_level = 1; @@ -150,27 +155,9 @@ perl_construct(pTHXx) /* Init the real globals (and main thread)? */ if (!PL_linestr) { -#ifdef USE_5005THREADS - 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); - MUTEX_INIT(&PL_sv_lock_mutex); - MUTEX_INIT(&PL_fdpid_mutex); - - thr = init_main_thread(); -#endif /* USE_5005THREADS */ - +#ifdef USE_ITHREADS + MUTEX_INIT(&PL_dollarzero_mutex); /* for $0 modifying */ +#endif #ifdef PERL_FLEXIBLE_EXCEPTIONS PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */ #endif @@ -200,16 +187,6 @@ perl_construct(pTHXx) PL_sighandlerp = Perl_sighandler; 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)PerlIO_close(PerlIO_importFILE(stdaux, 0)); - (void)PerlIO_close(PerlIO_importFILE(stdprn, 0)); -#endif } PL_rs = newSVpvn("\n", 1); @@ -263,14 +240,16 @@ perl_construct(pTHXx) PL_fdpid = newAV(); /* for remembering popen pids by fd */ PL_modglobal = newHV(); /* pointers to per-interpreter module globals */ PL_errors = newSVpvn("",0); + 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 - New(31337, PL_reentrant_buffer,1, REBUF); - New(31337, PL_reentrant_buffer->tmbuff,1, struct tm); + Perl_reentrant_init(aTHX); #endif /* Note that strtab is a rather special HV. Assumptions are made @@ -278,9 +257,6 @@ perl_construct(pTHXx) It is properly deallocated in perl_destruct() */ PL_strtab = newHV(); -#ifdef USE_5005THREADS - MUTEX_INIT(&PL_strtab_mutex); -#endif HvSHAREKEYS_off(PL_strtab); /* mandatory */ hv_ksplit(PL_strtab, 512); @@ -293,10 +269,33 @@ perl_construct(pTHXx) 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. @@ -310,84 +309,12 @@ perl_destruct(pTHXx) volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */ HV *hv; #ifdef USE_5005THREADS - Thread t; dTHX; #endif /* USE_5005THREADS */ /* wait for all pseudo-forked children to finish */ PERL_WAIT_FOR_CHILDREN; -#ifdef USE_5005THREADS -#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); - PL_nthreads--; -#endif /* !defined(FAKE_THREADS) */ -#endif /* USE_5005THREADS */ - destruct_level = PL_perl_destruct_level; #ifdef DEBUGGING { @@ -413,11 +340,18 @@ perl_destruct(pTHXx) 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; } @@ -465,7 +399,7 @@ perl_destruct(pTHXx) #endif /* The exit() function will do everything that needs doing. */ - return STATUS_NATIVE_EXPORT;; + return STATUS_NATIVE_EXPORT; } /* jettison our possibly duplicated environment */ @@ -473,7 +407,13 @@ perl_destruct(pTHXx) * so we certainly shouldn't free it here */ #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV) - if (environ != PL_origenviron) { + 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++) @@ -552,11 +492,6 @@ perl_destruct(pTHXx) PL_e_script = Nullsv; } - while (--PL_origargc >= 0) { - Safefree(PL_origargv[PL_origargc]); - } - Safefree(PL_origargv); - /* magical thingies */ SvREFCNT_dec(PL_ofs_sv); /* $, */ @@ -596,11 +531,13 @@ perl_destruct(pTHXx) 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 */ @@ -669,6 +606,8 @@ perl_destruct(pTHXx) 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; @@ -687,6 +626,8 @@ perl_destruct(pTHXx) 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); @@ -694,15 +635,8 @@ perl_destruct(pTHXx) if (!specialCopIO(PL_compiling.cop_io)) SvREFCNT_dec(PL_compiling.cop_io); PL_compiling.cop_io = Nullsv; -#ifdef USE_ITHREADS - Safefree(CopFILE(&PL_compiling)); - CopFILE(&PL_compiling) = Nullch; - Safefree(CopSTASHPV(&PL_compiling)); -#else - SvREFCNT_dec(CopFILEGV(&PL_compiling)); - CopFILEGV(&PL_compiling) = Nullgv; - /* cop_stash is not refcounted */ -#endif + CopFILE_free(&PL_compiling); + CopSTASH_free(&PL_compiling); /* Prepare to destruct main symbol table. */ @@ -719,18 +653,18 @@ 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); } @@ -771,7 +705,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; @@ -803,17 +737,49 @@ perl_destruct(pTHXx) SvANY(&PL_sv_no) = NULL; SvFLAGS(&PL_sv_no) = 0; - SvREFCNT(&PL_sv_undef) = 0; - SvREADONLY_off(&PL_sv_undef); + { + 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 + #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) @@ -829,27 +795,9 @@ perl_destruct(pTHXx) PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */ DEBUG_P(debprofdump()); -#ifdef USE_5005THREADS - MUTEX_DESTROY(&PL_strtab_mutex); - MUTEX_DESTROY(&PL_sv_mutex); - MUTEX_DESTROY(&PL_eval_mutex); - MUTEX_DESTROY(&PL_cred_mutex); - MUTEX_DESTROY(&PL_fdpid_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_5005THREADS */ #ifdef USE_REENTRANT_API - Safefree(PL_reentrant_buffer->tmbuff); - Safefree(PL_reentrant_buffer); + Perl_reentrant_free(aTHX); #endif sv_free_arenas(); @@ -899,7 +847,7 @@ perl_free(pTHXx) # endif PerlMem_free(aTHXx); # ifdef NETWARE - nw5_delete_internal_host(host); + nw_delete_internal_host(host); # else win32_delete_internal_host(host); # endif @@ -947,21 +895,7 @@ setuid perl scripts securely.\n"); #endif PL_origargc = argc; - { - /* we copy rather than point to argv - * since perl_clone will copy and perl_destruct - * has no way of knowing if we've made a copy or - * just point to argv - */ - int i = PL_origargc; - New(0, PL_origargv, i+1, char*); - PL_origargv[i] = '\0'; - while (i-- > 0) { - PL_origargv[i] = savepv(argv[i]); - } - } - - + PL_origargv = argv; if (PL_do_undump) { @@ -976,7 +910,6 @@ setuid perl scripts securely.\n"); } if (PL_main_root) { - PL_curpad = AvARRAY(PL_comppad); op_free(PL_main_root); PL_main_root = Nullop; } @@ -1044,7 +977,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) int fdscript = -1; VOL bool dosearch = FALSE; char *validarg = ""; - AV* comppadlist; register SV *sv; register char *s; char *cddir = Nullch; @@ -1099,8 +1031,16 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) 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; @@ -1108,7 +1048,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #ifdef MACOS_TRADITIONAL /* ignore -e for Dev:Pseudo argument */ if (argv[1] && !strcmp(argv[1], "Dev:Pseudo")) - break; + break; #endif if (PL_euid != PL_uid || PL_egid != PL_gid) Perl_croak(aTHX_ "No -e allowed in setuid scripts"); @@ -1136,7 +1076,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) char *p; STRLEN len = strlen(s); p = savepvn(s, len); - incpush(p, TRUE, TRUE); + incpush(p, TRUE, TRUE, FALSE); sv_catpvn(sv, "-I", 2); sv_catpvn(sv, p, len); sv_catpvn(sv, " ", 1); @@ -1269,6 +1209,7 @@ print \" \\@INC:\\n @INC\\n\";"); } } switch_end: + sv_setsv(get_sv("/", TRUE), PL_rs); if ( #ifndef SECURE_INTERNAL_GETENV @@ -1279,8 +1220,10 @@ print \" \\@INC:\\n @INC\\n\";"); 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) { @@ -1295,7 +1238,7 @@ print \" \\@INC:\\n @INC\\n\";"); d = s; if (!*s) break; - if (!strchr("DIMUdmw", *s)) + if (!strchr("DIMUdmtw", *s)) Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); while (++s && *s) { if (isSPACE(*s)) { @@ -1308,11 +1251,22 @@ print \" \\@INC:\\n @INC\\n\";"); break; } } - moreswitches(d); + 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) { @@ -1342,7 +1296,7 @@ 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); } @@ -1365,28 +1319,13 @@ 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; + CvPADLIST(PL_compcv) = pad_new(0); #ifdef USE_5005THREADS - av_store(PL_comppad_name, 0, newSVpvn("@_", 2)); - PL_curpad[0] = (SV*)newAV(); - SvPADMY_on(PL_curpad[0]); /* XXX Needed? */ CvOWNER(PL_compcv) = 0; New(666, CvMUTEXP(PL_compcv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(PL_compcv)); #endif /* USE_5005THREADS */ - comppadlist = newAV(); - AvREAL_off(comppadlist); - av_store(comppadlist, 0, (SV*)PL_comppad_name); - av_store(comppadlist, 1, (SV*)PL_comppad); - CvPADLIST(PL_compcv) = comppadlist; - boot_core_PerlIO(); boot_core_UNIVERSAL(); #ifndef PERL_MICRO @@ -1416,11 +1355,32 @@ print \" \\@INC:\\n @INC\\n\";"); if (!PL_do_undump) init_postdump_symbols(argc,argv,env); + /* PL_wantutf8 is conditionally turned on by + * locale.c:Perl_init_i18nl10n() if the environment + * look like the user wants to use UTF-8. */ + if (PL_wantutf8) { /* Requires init_predump_symbols(). */ + IO* io; + PerlIO* fp; + SV* sv; + /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR + * _and_ the default open discipline. */ + if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) { + sv_setpvn(sv, ":utf8\0:utf8", 11); + 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)) { @@ -1449,12 +1409,6 @@ print \" \\@INC:\\n @INC\\n\";"); PL_e_script = Nullsv; } -/* - Not sure that this is still the right place to do this now that we - no longer use PL_nrs. HVDS 2001/09/09 -*/ - sv_setsv(get_sv("/", TRUE), PL_rs); - if (PL_do_undump) my_unexec(); @@ -1570,7 +1524,9 @@ S_run_body(pTHX_ I32 oldscope) if (PL_minus_c) { #ifdef MACOS_TRADITIONAL - PerlIO_printf(Perl_error_log, "# %s syntax OK\n", MacPerl_MPWFileName(PL_origfilename)); + 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 @@ -1601,6 +1557,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 @@ -1628,6 +1586,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 @@ -1649,6 +1609,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 @@ -1670,6 +1632,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 @@ -1701,6 +1665,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. @@ -2082,6 +2049,8 @@ 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 the file named by the string argument. It is @@ -2140,6 +2109,7 @@ 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)", @@ -2180,7 +2150,7 @@ Perl_moreswitches(pTHX_ char *s) else if (!rschar && numlen >= 2) PL_rs = newSVpvn("", 0); else { - char ch = rschar; + char ch = (char)rschar; PL_rs = newSVpvn(&ch, 1); } return s + numlen; @@ -2238,7 +2208,7 @@ Perl_moreswitches(pTHX_ char *s) forbid_setid("-D"); if (isALPHA(s[1])) { /* if adding extra options, remember to update DEBUG_MASK */ - static char debopts[] = "psltocPmfrxuLHXDSTR"; + static char debopts[] = "psltocPmfrxu HXDSTRJvC"; char *d; for (s++; *s && (d = strchr(debopts,*s)); s++) @@ -2248,10 +2218,15 @@ Perl_moreswitches(pTHX_ char *s) PL_debug = atoi(s+1); for (s++; isDIGIT(*s); s++) ; } +#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 +#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 @@ -2260,10 +2235,16 @@ Perl_moreswitches(pTHX_ char *s) } case 'h': usage(PL_origargv[0]); - PerlProc_exit(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++) ; @@ -2289,7 +2270,7 @@ Perl_moreswitches(pTHX_ char *s) p++; } while (*p && *p != '-'); e = savepvn(s, e-s); - incpush(e, TRUE, TRUE); + incpush(e, TRUE, TRUE, FALSE); Safefree(e); s = p; if (*s == '-') @@ -2373,6 +2354,11 @@ 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"); @@ -2416,10 +2402,10 @@ Perl_moreswitches(pTHX_ char *s) #endif PerlIO_printf(PerlIO_stdout(), - "\n\nCopyright 1987-2001, Larry Wall\n"); + "\n\nCopyright 1987-2002, Larry Wall\n"); #ifdef MACOS_TRADITIONAL PerlIO_printf(PerlIO_stdout(), - "\nMac OS port Copyright 1991-2001, Matthias Neeracher;\n" + "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n" "maintained by Chris Nandor\n"); #endif #ifdef MSDOS @@ -2434,7 +2420,7 @@ Perl_moreswitches(pTHX_ char *s) #ifdef OS2 PerlIO_printf(PerlIO_stdout(), "\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"); + "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n"); #endif #ifdef atarist PerlIO_printf(PerlIO_stdout(), @@ -2446,7 +2432,7 @@ Perl_moreswitches(pTHX_ char *s) #endif #ifdef MPE PerlIO_printf(PerlIO_stdout(), - "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2001\n"); + "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n"); #endif #ifdef OEMVS PerlIO_printf(PerlIO_stdout(), @@ -2454,7 +2440,7 @@ Perl_moreswitches(pTHX_ char *s) #endif #ifdef __VOS__ PerlIO_printf(PerlIO_stdout(), - "Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n"); + "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n"); #endif #ifdef __OPEN_VM PerlIO_printf(PerlIO_stdout(), @@ -2470,10 +2456,10 @@ Perl_moreswitches(pTHX_ char *s) #endif #ifdef EPOC PerlIO_printf(PerlIO_stdout(), - "EPOC port by Olaf Flebbe, 1999-2000\n"); + "EPOC port by Olaf Flebbe, 1999-2002\n"); #endif #ifdef UNDER_CE - printf("WINCE port by Rainer Keuchel, 2001\n"); + printf("WINCE port by Rainer Keuchel, 2001-2002\n"); printf("Built on " __DATE__ " " __TIME__ "\n\n"); wce_hitreturn(); #endif @@ -2487,7 +2473,7 @@ 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; @@ -2495,11 +2481,15 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); return s; case 'W': 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; + if (!specialWARN(PL_compiling.cop_warnings)) + SvREFCNT_dec(PL_compiling.cop_warnings); PL_compiling.cop_warnings = pWARN_NONE ; s++; return s; @@ -2612,8 +2602,6 @@ S_init_main_stash(pTHX) { GV *gv; - - PL_curstash = PL_defstash = newHV(); PL_curstname = newSVpvn("main",4); gv = gv_fetchpv("main::",TRUE, SVt_PVHV); @@ -2637,7 +2625,6 @@ S_init_main_stash(pTHX) CopSTASH_set(&PL_compiling, PL_defstash); PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV)); - PL_nullstash = GvHV(gv_fetchpv("::", GV_ADDMULTI, SVt_PVHV)); /* We must init $/ before switches are processed. */ sv_setpvn(get_sv("/", TRUE), "\n", 1); } @@ -2645,6 +2632,11 @@ S_init_main_stash(pTHX) STATIC void S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) { + char *quote; + char *code; + char *cpp_discard_flag; + char *perl; + *fdscript = -1; if (PL_e_script) { @@ -2667,20 +2659,17 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) } } -#ifdef USE_ITHREADS - Safefree(CopFILE(PL_curcop)); -#else - SvREFCNT_dec(CopFILEGV(PL_curcop)); -#endif + 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; @@ -2691,85 +2680,70 @@ 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) - 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); + +# 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); + 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", @@ -2785,34 +2759,36 @@ 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 -#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 +# 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 } } @@ -2869,7 +2845,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd) defined(HAS_STRUCT_FS_DATA) && \ defined(NOSTAT_ONE) # define FD_ON_NOSUID_CHECK_OKAY - struct stat fdst; + Stat_t fdst; if (fstat(fd, &fdst) == 0) { struct ustat us; @@ -2899,7 +2875,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd) # define FD_ON_NOSUID_CHECK_OKAY FILE *mtab = fopen("/etc/mtab", "r"); struct mntent *entry; - struct stat stb, fsb; + Stat_t stb, fsb; if (mtab && (fstat(fd, &stb) == 0)) { while (entry = getmntent(mtab)) { @@ -2979,7 +2955,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 @@ -3167,6 +3143,9 @@ 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? */ @@ -3178,16 +3157,16 @@ S_find_beginning(pTHX) 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 @@ -3210,7 +3189,18 @@ S_find_beginning(pTHX) ; } #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 } } @@ -3415,14 +3405,31 @@ Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) #ifdef HAS_PROCSELFEXE /* This is a function so that we don't hold on to MAXPATHLEN - bytes of stack longer than necessary. + 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); - if (len > 0) { + + /* 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 { @@ -3431,57 +3438,12 @@ S_procself_val(pTHX_ SV *sv, char *arg0) } #endif /* HAS_PROCSELFEXE */ -#if defined(sun) && defined(__svr4__) /* solaris */ -#include -STATIC void -S_procselfauxv(pTHX_ SV *sv, char *arg0) { - auxv_t auxv; - int fh; - int n; - - fh = open("/proc/self/auxv", O_RDONLY); - if (fh < 0) { - sv_setpv(sv, arg0); - return; - } - - while (1) { - n = read(fh, &auxv, sizeof(auxv)); - if (n != sizeof(auxv)) - break; - if (auxv.a_type == AT_SUN_EXECNAME) { - close(fh); - sv_setpv(sv, auxv.a_un.a_ptr); - if (!strchr(SvPVX(sv), '/')) { - /* If no slash at all, probably started as "./perl" - * Do not compare against "perl", though, since the - * binary might be called something else. */ - STRLEN len; - char *s = SvPV(sv, len); - SvGROW(sv, len + 2); - memmove(s + 2, s, len); - SvPVX(sv)[0] = '.'; - SvPVX(sv)[1] = '/'; - SvCUR(sv) += 2; - } - return; - } - } - close(fh); - sv_setpv(sv, arg0); -} -#endif /* solaris */ - STATIC void S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env) { char *s; SV *sv; GV* tmpgv; -#ifdef NEED_ENVIRON_DUP_FOR_MODIFY - char **dup_env_base = 0; - int dup_env_count = 0; -#endif PL_toptarget = NEWSV(0,0); sv_upgrade(PL_toptarget, SVt_PVFM); @@ -3508,15 +3470,11 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register #ifdef HAS_PROCSELFEXE S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]); #else -# ifdef OS2 +#ifdef OS2 sv_setpv(GvSV(tmpgv), os2_execname(aTHX)); -# else -# if defined(sun) && defined(__svr4__) /* solaris */ - S_procselfauxv(aTHX_ GvSV(tmpgv), PL_origargv[0]); -# else - sv_setpv(GvSV(tmpgv), PL_origargv[0]); -# endif -# endif +#else + sv_setpv(GvSV(tmpgv),PL_origargv[0]); +#endif #endif } if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) { @@ -3532,48 +3490,28 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register */ if (!env) env = environ; - if (env != environ) - environ[0] = Nullch; -#ifdef NEED_ENVIRON_DUP_FOR_MODIFY + if (env != environ +# ifdef USE_ITHREADS + && PL_curinterp == aTHX +# endif + ) { - char **env_base; - for (env_base = env; *env; env++) - dup_env_count++; - if ((dup_env_base = (char **) - safesysmalloc( sizeof(char *) * (dup_env_count+1) ))) { - char **dup_env; - for (env = env_base, dup_env = dup_env_base; - *env; - env++, dup_env++) { - /* With environ one needs to use safesysmalloc(). */ - *dup_env = safesysmalloc(strlen(*env) + 1); - (void)strcpy(*dup_env, *env); - } - *dup_env = Nullch; - env = dup_env_base; - } /* else what? */ + environ[0] = Nullch; } -#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */ if (env) for (; *env; env++) { if (!(s = strchr(*env,'='))) continue; - *s++ = '\0'; #if defined(MSDOS) + *s = '\0'; (void)strupr(*env); + *s = '='; #endif - sv = newSVpv(s--,0); + sv = newSVpv(s+1, 0); (void)hv_store(hv, *env, s - *env, sv, 0); - *s = '='; + if (env != environ) + mg_set(sv); } -#ifdef NEED_ENVIRON_DUP_FOR_MODIFY - if (dup_env_base) { - char **dup_env; - for (dup_env = dup_env_base; *dup_env; dup_env++) - safesysfree(*dup_env); - safesysfree(dup_env_base); - } -#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */ #endif /* USE_ENVIRON_ARRAY */ } TAINT_NOT; @@ -3582,6 +3520,17 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register 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 @@ -3592,9 +3541,9 @@ S_init_perllib(pTHX) #ifndef VMS s = PerlEnv_getenv("PERL5LIB"); if (s) - incpush(s, TRUE, TRUE); + incpush(s, TRUE, TRUE, TRUE); else - incpush(PerlEnv_getenv("PERLLIB"), FALSE, 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 @@ -3603,9 +3552,9 @@ S_init_perllib(pTHX) char buf[256]; int idx = 0; if (my_trnlnm("PERL5LIB",buf,0)) - do { incpush(buf,TRUE,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,FALSE); + while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE); #endif /* VMS */ } @@ -3613,15 +3562,15 @@ S_init_perllib(pTHX) ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB */ #ifdef APPLLIB_EXP - incpush(APPLLIB_EXP, TRUE, TRUE); + incpush(APPLLIB_EXP, TRUE, TRUE, TRUE); #endif #ifdef ARCHLIB_EXP - incpush(ARCHLIB_EXP, FALSE, FALSE); + incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE); #endif #ifdef MACOS_TRADITIONAL { - struct stat tmpstatbuf; + Stat_t tmpstatbuf; SV * privdir = NEWSV(55, 0); char * macperl = PerlEnv_getenv("MACPERL"); @@ -3630,71 +3579,72 @@ S_init_perllib(pTHX) Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl); if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) - incpush(SvPVX(privdir), TRUE, FALSE); + 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); + incpush(SvPVX(privdir), TRUE, FALSE, TRUE); SvREFCNT_dec(privdir); } if (!PL_tainting) - incpush(":", FALSE, FALSE); + incpush(":", FALSE, FALSE, TRUE); #else #ifndef PRIVLIB_EXP # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" #endif #if defined(WIN32) - incpush(PRIVLIB_EXP, TRUE, FALSE); + incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE); #else - incpush(PRIVLIB_EXP, FALSE, 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); + incpush(SITEARCH_EXP, FALSE, FALSE, TRUE); # endif #endif #ifdef SITELIB_EXP # if defined(WIN32) - incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */ + /* this picks up sitearch as well */ + incpush(SITELIB_EXP, TRUE, FALSE, TRUE); # else - incpush(SITELIB_EXP, FALSE, FALSE); + incpush(SITELIB_EXP, FALSE, FALSE, TRUE); # endif #endif #ifdef SITELIB_STEM /* Search for version-specific dirs below here */ - incpush(SITELIB_STEM, FALSE, TRUE); + incpush(SITELIB_STEM, FALSE, TRUE, TRUE); #endif #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); + incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE); # endif #endif #ifdef PERL_VENDORLIB_EXP # if defined(WIN32) - incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */ + incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE); /* this picks up vendorarch as well */ # else - incpush(PERL_VENDORLIB_EXP, FALSE, FALSE); + 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); + incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE); #endif #ifdef PERL_OTHERLIBDIRS - incpush(PERL_OTHERLIBDIRS, TRUE, TRUE); + incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE); #endif if (!PL_tainting) - incpush(".", FALSE, FALSE); + incpush(".", FALSE, FALSE, TRUE); #endif /* MACOS_TRADITIONAL */ } @@ -3716,7 +3666,7 @@ S_init_perllib(pTHX) #endif STATIC void -S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) +S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep) { SV *subdir = Nullsv; @@ -3733,13 +3683,15 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) 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; @@ -3749,8 +3701,11 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) p = Nullch; /* break out */ } #ifdef MACOS_TRADITIONAL - if (!strchr(SvPVX(libdir), ':')) - sv_insert(libdir, 0, 0, ":", 1); + 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 @@ -3765,7 +3720,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) const char *incverlist[] = { PERL_INC_VERSION_LIST }; const char **incver; #endif - struct stat tmpstatbuf; + Stat_t tmpstatbuf; #ifdef VMS char *unix; STRLEN len; @@ -3924,11 +3879,19 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (AvFILL(paramList) >= 0) { cv = (CV*)av_shift(paramList); - if (PL_savebegin && (paramList == PL_beginav)) { + 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); + 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); } @@ -3945,7 +3908,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) @@ -3959,7 +3921,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: