X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=866c9a88269c1512cbf79b67433af3771185bd32;hb=8aa8f774be44d46814d4ddbad03e302f1eb37338;hp=70ace15efc77cdfdeae12c11a9756fc6b1c875aa;hpb=9014280dc8264580f076d4325a59f22a11592058;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 70ace15..866c9a8 100644 --- a/perl.c +++ b/perl.c @@ -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 * @@ -139,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; @@ -155,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 @@ -234,12 +216,9 @@ perl_construct(pTHXx) *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); @@ -258,6 +237,9 @@ 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 */ @@ -272,9 +254,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); @@ -287,10 +266,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. @@ -304,84 +306,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 { @@ -407,11 +337,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; } @@ -459,7 +396,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 */ @@ -467,7 +404,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++) @@ -546,11 +489,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); /* $, */ @@ -590,11 +528,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 */ @@ -663,6 +603,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; @@ -681,6 +623,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); @@ -790,17 +734,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_ 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) @@ -816,27 +792,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->tmbuf); - Safefree(PL_reentrant_buffer); + Perl_reentrant_free(aTHX); #endif sv_free_arenas(); @@ -886,7 +844,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 @@ -934,21 +892,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) { @@ -963,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; } @@ -1031,7 +974,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; @@ -1082,6 +1024,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) case 'W': case 'X': case 'w': + case 'A': if ((s = moreswitches(s))) goto reswitch; break; @@ -1103,7 +1046,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"); @@ -1131,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, TRUE); + incpush(p, TRUE, TRUE, FALSE); sv_catpvn(sv, "-I", 2); sv_catpvn(sv, p, len); sv_catpvn(sv, " ", 1); @@ -1264,6 +1207,7 @@ print \" \\@INC:\\n @INC\\n\";"); } } switch_end: + sv_setsv(get_sv("/", TRUE), PL_rs); if ( #ifndef SECURE_INTERNAL_GETENV @@ -1292,7 +1236,7 @@ print \" \\@INC:\\n @INC\\n\";"); d = s; if (!*s) break; - if (!strchr("DIMUdmtw", *s)) + if (!strchr("DIMUdmtwA", *s)) Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); while (++s && *s) { if (isSPACE(*s)) { @@ -1373,28 +1317,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 @@ -1424,11 +1353,52 @@ 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)) { @@ -1457,12 +1427,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(); @@ -1578,7 +1542,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 @@ -2161,6 +2127,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)", @@ -2201,14 +2168,14 @@ 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; } case 'C': - PL_widesyscalls = TRUE; - s++; + s++; + PL_unicode = parse_unicode_opts(&s); return s; case 'F': PL_minus_F = TRUE; @@ -2259,7 +2226,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[] = "psltocPmfrxuLHXDSTRJ"; + static char debopts[] = "psltocPmfrxu HXDSTRJvC"; char *d; for (s++; *s && (d = strchr(debopts,*s)); s++) @@ -2269,8 +2236,13 @@ 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_ packWARN(WARN_DEBUGGING), "Recompile perl with -DDEBUGGING to use -D switch\n"); @@ -2281,10 +2253,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++) ; @@ -2310,7 +2288,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 == '-') @@ -2342,6 +2320,20 @@ Perl_moreswitches(pTHX_ char *s) } } 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 */ @@ -2480,7 +2472,7 @@ Perl_moreswitches(pTHX_ char *s) #endif #ifdef __VOS__ PerlIO_printf(PerlIO_stdout(), - "Stratus VOS port by Paul_Green@stratus.com, 1997-2002\n"); + "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n"); #endif #ifdef __OPEN_VM PerlIO_printf(PerlIO_stdout(), @@ -2513,7 +2505,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; @@ -2642,8 +2634,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); @@ -2667,7 +2657,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); } @@ -2752,8 +2741,8 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) /* 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 + 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. */ @@ -2764,7 +2753,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) Perl_sv_setpvf(aTHX_ cmd, "\ %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s", - perl, quote, code, quote, scriptname, cpp, + perl, quote, code, quote, scriptname, cpp, cpp_discard_flag, sv, CPPMINUS); PL_doextract = FALSE; @@ -2788,8 +2777,8 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) } # endif /* IAMSUID */ - DEBUG_P(PerlIO_printf(Perl_debug_log, - "PL_preprocess: cmd=\"%s\"\n", + DEBUG_P(PerlIO_printf(Perl_debug_log, + "PL_preprocess: cmd=\"%s\"\n", SvPVX(cmd))); PL_rsfp = PerlProc_popen(SvPVX(cmd), "r"); @@ -2816,8 +2805,8 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) 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, + 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"); @@ -2888,7 +2877,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; @@ -2918,7 +2907,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)) { @@ -2998,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 @@ -3186,6 +3175,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? */ @@ -3197,16 +3189,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 @@ -3229,7 +3221,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 } } @@ -3277,6 +3280,8 @@ Perl_init_debugger(pTHX) sv_setiv(PL_DBtrace, 0); PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBsignal, 0); + PL_DBassertion = GvSV((gv_fetchpv("assertion", GV_ADDMULTI, SVt_PV))); + sv_setiv(PL_DBassertion, 0); PL_curstash = ostash; } @@ -3426,8 +3431,12 @@ Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) for (; argc > 0; argc--,argv++) { SV *sv = newSVpv(argv[0],0); av_push(GvAVn(PL_argvgv),sv); - if (PL_widesyscalls) - (void)sv_utf8_decode(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); } } } @@ -3441,7 +3450,24 @@ 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 { @@ -3502,8 +3528,14 @@ 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; + } if (env) for (; *env; env++) { if (!(s = strchr(*env,'='))) @@ -3526,6 +3558,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 @@ -3536,9 +3579,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 @@ -3547,9 +3590,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 */ } @@ -3557,15 +3600,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"); @@ -3574,71 +3617,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 */ } @@ -3660,7 +3704,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; @@ -3677,13 +3721,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; @@ -3693,8 +3739,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 @@ -3709,7 +3758,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; @@ -3868,11 +3917,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); } @@ -3889,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) @@ -3903,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: