X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=9914935203ed8638132c5f3ac126392ac621e80f;hb=18aba96f40a877297fb70961dbd4be7bc6f1c199;hp=a2aa4d2b9229b171fe3d6ec124b703407adce0d6;hpb=574c798aa09309489c549b50dff81b705c3afde8;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index a2aa4d2..9914935 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); \ @@ -213,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); @@ -274,6 +273,8 @@ perl_construct(pTHXx) #endif PL_clocktick = HZ; + PL_stashcache = newHV(); + ENTER; } @@ -386,6 +387,9 @@ perl_destruct(pTHXx) Safefree(PL_exitlist); + PL_exitlist = NULL; + PL_exitlistlen = 0; + if (destruct_level == 0){ DEBUG_P(debprofdump()); @@ -456,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) { @@ -489,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); /* $, */ @@ -752,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); @@ -769,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); @@ -879,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) { @@ -997,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 @@ -1025,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; @@ -1236,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)) { @@ -1353,27 +1356,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 */ @@ -2053,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 */ @@ -2134,28 +2167,51 @@ 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; @@ -2300,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 */ @@ -2400,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" @@ -2457,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 @@ -3246,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; } @@ -3395,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); } } } @@ -3906,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) @@ -3920,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: