X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=73f3273c0dbfded4d56568aed5906638b3532272;hb=43c32782ed6d18ddfca58337454582a388bfa6f8;hp=60a2f493267f2724276f7e8e8dfc6ceccb3ff448;hpb=3db8f154c4c6e098a5a0bdf7932e8f86fbd2c451;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 60a2f49..73f3273 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. @@ -65,6 +66,7 @@ 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); \ @@ -152,7 +154,6 @@ perl_construct(pTHXx) if (PL_perl_destruct_level > 0) init_interp(); #endif - /* Init the real globals (and main thread)? */ if (!PL_linestr) { #ifdef PERL_FLEXIBLE_EXCEPTIONS @@ -213,12 +214,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); @@ -274,6 +272,41 @@ perl_construct(pTHXx) #endif PL_clocktick = HZ; + PL_stashcache = newHV(); + +#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) + /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0 */ + { + char *s = NULL; + + if (!PL_earlytaint) + s = PerlEnv_getenv("PERL_HASH_SEED"); + if (s) + while (isSPACE(*s)) s++; + if (s && isDIGIT(*s)) + PL_hash_seed = (UV)Atoul(s); +#ifndef USE_HASH_SEED_EXPLICIT + else { + /* Compute a random seed */ + (void)seedDrand01((Rand_seed_t)seed()); + PL_srand_called = TRUE; + PL_hash_seed = (UV)(Drand01() * (NV)UV_MAX); +#if RANDBITS < (UVSIZE * 8) + { + int skip = (UVSIZE * 8) - RANDBITS; + PL_hash_seed >>= skip; + /* The low bits might need extra help. */ + PL_hash_seed += (UV)(Drand01() * ((1 << skip) - 1)); + } +#endif /* RANDBITS < (UVSIZE * 8) */ + } +#endif /* USE_HASH_SEED_EXPLICIT */ + if (!PL_earlytaint && (s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"))) + PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", + PL_hash_seed); + } +#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */ + ENTER; } @@ -349,7 +382,6 @@ perl_destruct(pTHXx) /* Destroy the main CV and syntax tree */ if (PL_main_root) { - PAD_UPDATE_CURPAD; op_free(PL_main_root); PL_main_root = Nullop; } @@ -387,6 +419,9 @@ perl_destruct(pTHXx) Safefree(PL_exitlist); + PL_exitlist = NULL; + PL_exitlistlen = 0; + if (destruct_level == 0){ DEBUG_P(debprofdump()); @@ -457,6 +492,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) { @@ -490,11 +528,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); /* $, */ @@ -753,6 +786,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); @@ -770,7 +821,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); @@ -880,22 +931,94 @@ setuid perl scripts securely.\n"); #endif PL_origargc = argc; + PL_origargv = argv; + { - /* 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]); - } + /* Set PL_origalen be the sum of the contiguous argv[] + * elements plus the size of the env in case that it is + * contiguous with the argv[]. This is used in mg.c:mg_set() + * as the maximum modifiable length of $0. In the worst case + * the area we are able to modify is limited to the size of + * the original argv[0]. (See below for 'contiguous', though.) + * --jhi */ + char *s; + int i; + UV mask = + ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0); + /* Do the mask check only if the args seem like aligned. */ + UV aligned = + (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0])); + + /* See if all the arguments are contiguous in memory. Note + * that 'contiguous' is a loose term because some platforms + * align the argv[] and the envp[]. If the arguments look + * like non-aligned, assume that they are 'strictly' or + * 'traditionally' contiguous. If the arguments look like + * aligned, we just check that they are within aligned + * PTRSIZE bytes. As long as no system has something bizarre + * like the argv[] interleaved with some other data, we are + * fine. (Did I just evoke Murphy's Law?) --jhi */ + s = PL_origargv[0]; + while (*s) s++; + for (i = 1; i < PL_origargc; i++) { + if ((PL_origargv[i] == s + 1 +#ifdef OS2 + || PL_origargv[i] == s + 2 +#endif + ) + || + (aligned && + (PL_origargv[i] > s && + PL_origargv[i] <= + INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) + ) + { + s = PL_origargv[i]; + while (*s) s++; + } + else + break; + } + /* Can we grab env area too to be used as the area for $0? */ + if (PL_origenviron) { + if ((PL_origenviron[0] == s + 1 +#ifdef OS2 + || (PL_origenviron[0] == s + 9 && (s += 8)) +#endif + ) + || + (aligned && + (PL_origenviron[0] > s && + PL_origenviron[0] <= + INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) + ) + { +#ifndef OS2 + s = PL_origenviron[0]; + while (*s) s++; +#endif + my_setenv("NoNe SuCh", Nullch); + /* Force copy of environment. */ + for (i = 1; PL_origenviron[i]; i++) { + if (PL_origenviron[i] == s + 1 + || + (aligned && + (PL_origenviron[i] > s && + PL_origenviron[i] <= + INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) + ) + { + s = PL_origenviron[i]; + while (*s) s++; + } + else + break; + } + } + } + PL_origalen = s - PL_origargv[0]; } - - if (PL_do_undump) { /* Come here if running an undumped a.out. */ @@ -909,7 +1032,6 @@ setuid perl scripts securely.\n"); } if (PL_main_root) { - PAD_UPDATE_CURPAD; op_free(PL_main_root); PL_main_root = Nullop; } @@ -999,10 +1121,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 @@ -1027,11 +1145,13 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) case 'W': case 'X': case 'w': + case 'A': if ((s = moreswitches(s))) goto reswitch; break; case 't': + CHECK_MALLOC_TOO_LATE_FOR('t'); if( !PL_tainting ) { PL_taint_warn = TRUE; PL_tainting = TRUE; @@ -1039,6 +1159,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) s++; goto reswitch; case 'T': + CHECK_MALLOC_TOO_LATE_FOR('T'); PL_tainting = TRUE; PL_taint_warn = FALSE; s++; @@ -1076,7 +1197,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); @@ -1221,6 +1342,7 @@ print \" \\@INC:\\n @INC\\n\";"); while (isSPACE(*s)) s++; if (*s == '-' && *(s+1) == 'T') { + CHECK_MALLOC_TOO_LATE_FOR('T'); PL_tainting = TRUE; PL_taint_warn = FALSE; } @@ -1238,7 +1360,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)) { @@ -1355,27 +1477,57 @@ 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 */ @@ -2055,7 +2207,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 */ @@ -2130,34 +2282,91 @@ NULL PerlIO_printf(PerlIO_stdout(), "\n %s", *p++); } +/* convert a string of -D options (or digits) into an int. + * sets *s to point to the char after the options */ + +#ifdef DEBUGGING +int +Perl_get_debug_opts(pTHX_ char **s) +{ + int i = 0; + if (isALPHA(**s)) { + /* if adding extra options, remember to update DEBUG_MASK */ + static char debopts[] = "psltocPmfrxu HXDSTRJvC"; + + for (; isALNUM(**s); (*s)++) { + char *d = strchr(debopts,**s); + if (d) + i |= 1 << (d - debopts); + else if (ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), + "invalid option -D%c\n", **s); + } + } + else { + i = atoi(*s); + for (; isALNUM(**s); (*s)++) ; + } +# ifdef EBCDIC + if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), + "-Dp not implemented on this platform\n"); +# endif + return i; +} +#endif + /* This routine handles any switches that can be given during run */ char * Perl_moreswitches(pTHX_ char *s) { STRLEN numlen; - U32 rschar; + UV rschar; 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, (STRLEN)(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; @@ -2206,24 +2415,8 @@ Perl_moreswitches(pTHX_ char *s) { #ifdef DEBUGGING forbid_setid("-D"); - if (isALPHA(s[1])) { - /* if adding extra options, remember to update DEBUG_MASK */ - static char debopts[] = "psltocPmfrxu HXDSTRJvC"; - char *d; - - for (s++; *s && (d = strchr(debopts,*s)); s++) - PL_debug |= 1 << (d - debopts); - } - else { - 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; + s++; + PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG; #else /* !DEBUGGING */ if (ckWARN_d(WARN_DEBUGGING)) Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), @@ -2270,7 +2463,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 == '-') @@ -2302,6 +2495,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 */ @@ -2356,12 +2563,12 @@ Perl_moreswitches(pTHX_ char *s) return s; case 't': if (!PL_tainting) - Perl_croak(aTHX_ "Too late for \"-t\" option"); + TOO_LATE_FOR('t'); s++; return s; case 'T': if (!PL_tainting) - Perl_croak(aTHX_ "Too late for \"-T\" option"); + TOO_LATE_FOR('T'); s++; return s; case 'u': @@ -2402,7 +2609,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" @@ -2459,8 +2666,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 @@ -3218,9 +3425,48 @@ S_init_ids(pTHX) PL_uid |= PL_gid << 16; PL_euid |= PL_egid << 16; #endif + /* Should not happen: */ + CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); } +/* This is used very early in the lifetime of the program, + * before even the options are parsed, so PL_tainting has + * not been initialized properly. The variable PL_earlytaint + * is set early in main() to the result of this function. */ +bool +Perl_doing_taint(int argc, char *argv[], char *envp[]) +{ +#ifndef PERL_IMPLICIT_SYS + /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia + * before we have an interpreter-- and the whole point of this + * function is to be called at such an early stage. If you are on + * a system with PERL_IMPLICIT_SYS but you do have a concept of + * "tainted because running with altered effective ids', you'll + * have to add your own checks somewhere in here. The two most + * known samples of 'implicitness' are Win32 and NetWare, neither + * of which has much of concept of 'uids'. */ + int uid = PerlProc_getuid(); + int euid = PerlProc_geteuid(); + int gid = PerlProc_getgid(); + int egid = PerlProc_getegid(); + +#ifdef VMS + uid |= gid << 16; + euid |= egid << 16; +#endif + if (uid && (euid != uid || egid != gid)) + return 1; +#endif /* !PERL_IMPLICIT_SYS */ + /* This is a really primitive check; environment gets ignored only + * if -T are the first chars together; otherwise one gets + * "Too late" message. */ + if ( argc > 1 && argv[1][0] == '-' + && (argv[1][1] == 't' || argv[1][1] == 'T') ) + return 1; + return 0; +} + STATIC void S_forbid_setid(pTHX_ char *s) { @@ -3248,6 +3494,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; } @@ -3397,8 +3645,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); } } } @@ -3541,9 +3793,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 @@ -3552,9 +3804,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 */ } @@ -3562,11 +3814,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 { @@ -3579,71 +3831,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 */ } @@ -3665,7 +3918,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; @@ -3682,13 +3935,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; @@ -3905,7 +4160,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) @@ -3919,7 +4173,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: