X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d2aaa77e10d841339f3651b4c6cfc980b9f58b7a..18729d3e27f8d8545469c3e23a69b10dc409a88f:/perl.c diff --git a/perl.c b/perl.c index d19ae96..989d1e3 100644 --- a/perl.c +++ b/perl.c @@ -1,6 +1,7 @@ /* perl.c * - * Copyright (c) 1987-2003 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. @@ -75,6 +76,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); \ @@ -193,10 +195,6 @@ perl_construct(pTHXx) thr = init_main_thread(); #endif /* USE_5005THREADS */ -#if defined(USE_5005THREADS) || defined(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 @@ -316,6 +314,8 @@ perl_construct(pTHXx) #endif PL_clocktick = HZ; + PL_stashcache = newHV(); + ENTER; } @@ -500,6 +500,9 @@ perl_destruct(pTHXx) Safefree(PL_exitlist); + PL_exitlist = NULL; + PL_exitlistlen = 0; + if (destruct_level == 0){ DEBUG_P(debprofdump()); @@ -570,6 +573,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) { @@ -896,7 +902,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); @@ -1127,10 +1133,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 @@ -2213,7 +2215,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 */ @@ -2294,24 +2296,47 @@ 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': s++; @@ -2617,8 +2642,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 @@ -3607,6 +3632,10 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register 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); @@ -3661,6 +3690,26 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register { environ[0] = Nullch; } +#ifdef NEED_ENVIRON_DUP_FOR_MODIFY + { + 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? */ + } +#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */ if (env) for (; *env; env++) { if (!(s = strchr(*env,'='))) @@ -3675,6 +3724,14 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register 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; @@ -4071,7 +4128,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) @@ -4085,7 +4141,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: