X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=77cd0c90872ee8008ea66c9831effbd343420b05;hb=96a925ab0077cdd24bd7d328f20be3d5373d4885;hp=3647708cbfc9bc179691dfc87b98459803d5ac7e;hpb=ed423f7afb5038546a92d00ca689992f3e08bc61;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 3647708..77cd0c9 100644 --- a/perl.c +++ b/perl.c @@ -1,6 +1,7 @@ /* perl.c * - * Copyright (c) 1987-2002 Larry Wall + * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -26,6 +27,18 @@ char *nw_get_sitelib(const char *pl); #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 @@ -44,17 +57,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,12 +66,13 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); ALLOC_THREAD_KEY; \ PERL_SET_THX(my_perl); \ OP_REFCNT_INIT; \ + MUTEX_INIT(&PL_dollarzero_mutex); \ } \ else { \ PERL_SET_THX(my_perl); \ } \ } STMT_END -# else +#else # define INIT_TLS_AND_INTERP \ STMT_START { \ if (!PL_curinterp) { \ @@ -77,7 +81,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 * @@ -144,12 +147,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; @@ -160,27 +157,6 @@ 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 PERL_FLEXIBLE_EXCEPTIONS PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */ #endif @@ -239,12 +215,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); @@ -280,9 +253,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); @@ -295,6 +265,16 @@ 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; + + PL_stashcache = newHV(); + ENTER; } @@ -327,84 +307,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 { @@ -442,8 +350,6 @@ perl_destruct(pTHXx) /* Destroy the main CV and syntax tree */ if (PL_main_root) { - /* If running under -d may not have PL_comppad. */ - PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; op_free(PL_main_root); PL_main_root = Nullop; } @@ -481,6 +387,9 @@ perl_destruct(pTHXx) Safefree(PL_exitlist); + PL_exitlist = NULL; + PL_exitlistlen = 0; + if (destruct_level == 0){ DEBUG_P(debprofdump()); @@ -551,6 +460,9 @@ perl_destruct(pTHXx) PL_regex_pad = NULL; #endif + SvREFCNT_dec((SV*) PL_stashcache); + PL_stashcache = NULL; + /* loosen bonds of global variables */ if(PL_rsfp) { @@ -584,11 +496,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); /* $, */ @@ -628,11 +535,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 */ @@ -845,6 +754,24 @@ perl_destruct(pTHXx) 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); @@ -862,7 +789,7 @@ perl_destruct(pTHXx) if (PL_reg_curpm) Safefree(PL_reg_curpm); Safefree(PL_reg_poscache); - Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh)); + free_tied_hv_pool(); Safefree(PL_op_mask); Safefree(PL_psig_ptr); Safefree(PL_psig_name); @@ -872,23 +799,6 @@ 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 Perl_reentrant_free(aTHX); @@ -989,21 +899,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) { @@ -1018,7 +914,6 @@ setuid perl scripts securely.\n"); } if (PL_main_root) { - PL_curpad = AvARRAY(PL_comppad); op_free(PL_main_root); PL_main_root = Nullop; } @@ -1086,7 +981,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; @@ -1109,10 +1003,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) reswitch: switch (*s) { case 'C': -#ifdef WIN32 - win32_argv2utf8(argc-1, argv+1); - /* FALL THROUGH */ -#endif #ifndef PERL_STRICT_CR case '\r': #endif @@ -1137,6 +1027,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; @@ -1186,7 +1077,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); @@ -1319,6 +1210,7 @@ print \" \\@INC:\\n @INC\\n\";"); } } switch_end: + sv_setsv(get_sv("/", TRUE), PL_rs); if ( #ifndef SECURE_INTERNAL_GETENV @@ -1347,7 +1239,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)) { @@ -1428,28 +1320,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 @@ -1479,32 +1356,62 @@ print \" \\@INC:\\n @INC\\n\";"); if (!PL_do_undump) init_postdump_symbols(argc,argv,env); - /* PL_wantutf8 is conditionally turned on by + /* 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_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); + if (PL_unicode) { + /* Requires init_predump_symbols(). */ + if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { + IO* io; + PerlIO* fp; + SV* sv; + + /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR + * and the default open disciplines. */ + 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); + } } } + if ((s = PerlEnv_getenv("PERL_SIGNALS"))) { + if (strEQ(s, "unsafe")) + PL_signals |= PERL_SIGNALS_UNSAFE_FLAG; + else if (strEQ(s, "safe")) + PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG; + else + Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s); + } + 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)) { @@ -1533,12 +1440,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(); @@ -2185,7 +2086,7 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) 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. +implemented that way; consider using load_module instead. =cut */ @@ -2271,23 +2172,46 @@ Perl_moreswitches(pTHX_ char *s) switch (*s) { case '0': { - I32 flags = 0; - numlen = 4; - rschar = (U32)grok_oct(s, &numlen, &flags, NULL); - SvREFCNT_dec(PL_rs); - if (rschar & ~((U8)~0)) - PL_rs = &PL_sv_undef; - else if (!rschar && numlen >= 2) - PL_rs = newSVpvn("", 0); - else { - char ch = (char)rschar; - PL_rs = newSVpvn(&ch, 1); - } - return s + numlen; + I32 flags = 0; + + SvREFCNT_dec(PL_rs); + if (s[1] == 'x' && s[2]) { + char *e; + U8 *tmps; + + for (s += 2, e = s; *e; e++); + numlen = e - s; + flags = PERL_SCAN_SILENT_ILLDIGIT; + rschar = (U32)grok_hex(s, &numlen, &flags, NULL); + if (s + numlen < e) { + rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */ + numlen = 0; + s--; + } + PL_rs = newSVpvn("", 0); + SvGROW(PL_rs, UNISKIP(rschar) + 1); + tmps = (U8*)SvPVX(PL_rs); + uvchr_to_utf8(tmps, rschar); + SvCUR_set(PL_rs, UNISKIP(rschar)); + SvUTF8_on(PL_rs); + } + else { + numlen = 4; + rschar = (U32)grok_oct(s, &numlen, &flags, NULL); + if (rschar & ~((U8)~0)) + PL_rs = &PL_sv_undef; + else if (!rschar && numlen >= 2) + PL_rs = newSVpvn("", 0); + else { + 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; @@ -2338,7 +2262,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++) @@ -2400,7 +2324,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 == '-') @@ -2432,6 +2356,20 @@ Perl_moreswitches(pTHX_ char *s) } } return s; + case 'A': + forbid_setid("-A"); + if (!PL_preambleav) + PL_preambleav = newAV(); + if (*++s) { + SV *sv = newSVpvn("use assertions::activate split(/,/,q{",37); + sv_catpv(sv,s); + sv_catpv(sv,"})"); + s+=strlen(s); + av_push(PL_preambleav, sv); + } + else + av_push(PL_preambleav, newSVpvn("use assertions::activate",24)); + return s; case 'M': forbid_setid("-M"); /* XXX ? */ /* FALL THROUGH */ @@ -2532,7 +2470,7 @@ Perl_moreswitches(pTHX_ char *s) #endif PerlIO_printf(PerlIO_stdout(), - "\n\nCopyright 1987-2002, Larry Wall\n"); + "\n\nCopyright 1987-2003, Larry Wall\n"); #ifdef MACOS_TRADITIONAL PerlIO_printf(PerlIO_stdout(), "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n" @@ -2589,8 +2527,8 @@ Perl_moreswitches(pTHX_ char *s) "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"); + PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n"); + PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n"); wce_hitreturn(); #endif #ifdef BINARY_BUILD_NOTICE @@ -2755,7 +2693,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); } @@ -3379,6 +3316,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; } @@ -3528,8 +3467,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); } } } @@ -3651,6 +3594,9 @@ 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) { @@ -3669,9 +3615,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 @@ -3680,9 +3626,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 */ } @@ -3690,11 +3636,11 @@ 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 { @@ -3707,71 +3653,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 */ } @@ -3793,7 +3740,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; @@ -3810,13 +3757,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; @@ -4004,11 +3953,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); } @@ -4025,7 +3982,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) @@ -4039,7 +3995,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: