X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=84ef3afd6c58cd326b901a4f2f40d4904d6919e9;hb=f224927c1e379a33cd6d5e0a5d25d0ecb9c9d964;hp=e1d3d18e1cc2967aa69dc08644db7f867570161d;hpb=1b24ed4b35a915c6e59d3fc62a8dd13d3947354a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index e1d3d18..84ef3af 100644 --- a/perl.c +++ b/perl.c @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-2001 Larry Wall + * Copyright (c) 1987-2002 Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -102,6 +102,8 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, #else /* +=head1 Embedding Functions + =for apidoc perl_alloc Allocates a new Perl interpreter. See L. @@ -113,6 +115,9 @@ PerlInterpreter * perl_alloc(void) { PerlInterpreter *my_perl; +#ifdef USE_5005THREADS + dTHX; +#endif /* New() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); @@ -200,16 +205,6 @@ perl_construct(pTHXx) PL_sighandlerp = Perl_sighandler; PL_pidstatus = newHV(); - -#ifdef MSDOS - /* - * There is no way we can refer to them from Perl so close them to save - * space. The other alternative would be to provide STDAUX and STDPRN - * filehandles. - */ - (void)PerlIO_close(PerlIO_importFILE(stdaux, 0)); - (void)PerlIO_close(PerlIO_importFILE(stdprn, 0)); -#endif } PL_rs = newSVpvn("\n", 1); @@ -263,14 +258,16 @@ 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 */ PL_regex_pad = AvARRAY(PL_regex_padav); #endif #ifdef USE_REENTRANT_API - New(31337, PL_reentrant_buffer,1, REBUF); - New(31337, PL_reentrant_buffer->tmbuff,1, struct tm); + Perl_reentrant_init(aTHX); #endif /* Note that strtab is a rather special HV. Assumptions are made @@ -694,15 +691,8 @@ perl_destruct(pTHXx) if (!specialCopIO(PL_compiling.cop_io)) SvREFCNT_dec(PL_compiling.cop_io); PL_compiling.cop_io = Nullsv; -#ifdef USE_ITHREADS - Safefree(CopFILE(&PL_compiling)); - CopFILE(&PL_compiling) = Nullch; - Safefree(CopSTASHPV(&PL_compiling)); -#else - SvREFCNT_dec(CopFILEGV(&PL_compiling)); - CopFILEGV(&PL_compiling) = Nullgv; - /* cop_stash is not refcounted */ -#endif + CopFILE_free(&PL_compiling); + CopSTASH_free(&PL_compiling); /* Prepare to destruct main symbol table. */ @@ -719,18 +709,18 @@ perl_destruct(pTHXx) FREETMPS; if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) { if (PL_scopestack_ix != 0) - Perl_warner(aTHX_ WARN_INTERNAL, + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", (long)PL_scopestack_ix); if (PL_savestack_ix != 0) - Perl_warner(aTHX_ WARN_INTERNAL, + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Unbalanced saves: %ld more saves than restores\n", (long)PL_savestack_ix); if (PL_tmps_floor != -1) - Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n", + Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n", (long)PL_tmps_floor + 1); if (cxstack_ix != -1) - Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n", + Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n", (long)cxstack_ix + 1); } @@ -771,7 +761,7 @@ perl_destruct(pTHXx) hent = array[0]; for (;;) { if (hent && ckWARN_d(WARN_INTERNAL)) { - Perl_warner(aTHX_ WARN_INTERNAL, + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Unbalanced string table refcount: (%d) for \"%s\"", HeVAL(hent) - Nullsv, HeKEY(hent)); HeVAL(hent) = Nullsv; @@ -807,7 +797,7 @@ perl_destruct(pTHXx) SvREADONLY_off(&PL_sv_undef); if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count); #if defined(PERLIO_LAYERS) /* No more IO - including error messages ! */ @@ -848,8 +838,7 @@ perl_destruct(pTHXx) #endif /* USE_5005THREADS */ #ifdef USE_REENTRANT_API - Safefree(PL_reentrant_buffer->tmbuff); - Safefree(PL_reentrant_buffer); + Perl_reentrant_free(aTHX); #endif sv_free_arenas(); @@ -1099,8 +1088,16 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) goto reswitch; break; + case 't': + if( !PL_tainting ) { + PL_taint_warn = TRUE; + PL_tainting = TRUE; + } + s++; + goto reswitch; case 'T': PL_tainting = TRUE; + PL_taint_warn = FALSE; s++; goto reswitch; @@ -1279,8 +1276,10 @@ print \" \\@INC:\\n @INC\\n\";"); char *popt = s; while (isSPACE(*s)) s++; - if (*s == '-' && *(s+1) == 'T') + if (*s == '-' && *(s+1) == 'T') { PL_tainting = TRUE; + PL_taint_warn = FALSE; + } else { char *popt_copy = Nullch; while (s && *s) { @@ -1295,7 +1294,7 @@ print \" \\@INC:\\n @INC\\n\";"); d = s; if (!*s) break; - if (!strchr("DIMUdmw", *s)) + if (!strchr("DIMUdmtw", *s)) Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); while (++s && *s) { if (isSPACE(*s)) { @@ -1308,11 +1307,22 @@ print \" \\@INC:\\n @INC\\n\";"); break; } } - moreswitches(d); + if (*d == 't') { + if( !PL_tainting ) { + PL_taint_warn = TRUE; + PL_tainting = TRUE; + } + } else { + moreswitches(d); + } } } } + if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) { + PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize); + } + if (!scriptname) scriptname = argv[0]; if (PL_e_script) { @@ -1342,7 +1352,7 @@ print \" \\@INC:\\n @INC\\n\";"); Sighandler_t sigstate = rsignal_state(SIGCHLD); if (sigstate == SIG_IGN) { if (ckWARN(WARN_SIGNAL)) - Perl_warner(aTHX_ WARN_SIGNAL, + Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "Can't ignore signal CHLD, forcing to default"); (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); } @@ -1416,6 +1426,22 @@ print \" \\@INC:\\n @INC\\n\";"); if (!PL_do_undump) init_postdump_symbols(argc,argv,env); + if (PL_wantutf8) { /* Requires init_predump_symbols(). */ + IO* io; + PerlIO* fp; + SV* sv; + 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); + } + } + init_lexer(); /* now parse the script */ @@ -1601,6 +1627,8 @@ S_run_body(pTHX_ I32 oldscope) } /* +=head1 SV Manipulation Functions + =for apidoc p||get_sv Returns the SV of the specified Perl scalar. If C is set and the @@ -1628,6 +1656,8 @@ Perl_get_sv(pTHX_ const char *name, I32 create) } /* +=head1 Array Manipulation Functions + =for apidoc p||get_av Returns the AV of the specified Perl array. If C is set and the @@ -1649,6 +1679,8 @@ Perl_get_av(pTHX_ const char *name, I32 create) } /* +=head1 Hash Manipulation Functions + =for apidoc p||get_hv Returns the HV of the specified Perl hash. If C is set and the @@ -1670,6 +1702,8 @@ Perl_get_hv(pTHX_ const char *name, I32 create) } /* +=head1 CV Manipulation Functions + =for apidoc p||get_cv Returns the CV of the specified Perl subroutine. If C is set and @@ -1701,6 +1735,9 @@ Perl_get_cv(pTHX_ const char *name, I32 create) /* Be sure to refetch the stack pointer after calling these routines. */ /* + +=head1 Callback Functions + =for apidoc p||call_argv Performs a callback to the specified Perl sub. See L. @@ -2082,6 +2119,8 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) /* Require a module. */ /* +=head1 Embedding Functions + =for apidoc p||require_pv Tells Perl to C the file named by the string argument. It is @@ -2140,6 +2179,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)", @@ -2238,7 +2278,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[] = "psltocPmfrxuLHXDSTR"; + static char debopts[] = "psltocPmfrxuLHXDSTRJ"; char *d; for (s++; *s && (d = strchr(debopts,*s)); s++) @@ -2248,10 +2288,15 @@ 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_ WARN_DEBUGGING, + Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Recompile perl with -DDEBUGGING to use -D switch\n"); for (s++; isALNUM(*s); s++) ; #endif @@ -2373,6 +2418,11 @@ Perl_moreswitches(pTHX_ char *s) PL_doswitches = TRUE; s++; return s; + case 't': + if (!PL_tainting) + Perl_croak(aTHX_ "Too late for \"-t\" option"); + s++; + return s; case 'T': if (!PL_tainting) Perl_croak(aTHX_ "Too late for \"-T\" option"); @@ -2416,10 +2466,10 @@ Perl_moreswitches(pTHX_ char *s) #endif PerlIO_printf(PerlIO_stdout(), - "\n\nCopyright 1987-2001, Larry Wall\n"); + "\n\nCopyright 1987-2002, Larry Wall\n"); #ifdef MACOS_TRADITIONAL PerlIO_printf(PerlIO_stdout(), - "\nMac OS port Copyright 1991-2001, Matthias Neeracher;\n" + "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n" "maintained by Chris Nandor\n"); #endif #ifdef MSDOS @@ -2434,7 +2484,7 @@ Perl_moreswitches(pTHX_ char *s) #ifdef OS2 PerlIO_printf(PerlIO_stdout(), "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" - "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n"); + "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n"); #endif #ifdef atarist PerlIO_printf(PerlIO_stdout(), @@ -2446,7 +2496,7 @@ Perl_moreswitches(pTHX_ char *s) #endif #ifdef MPE PerlIO_printf(PerlIO_stdout(), - "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2001\n"); + "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n"); #endif #ifdef OEMVS PerlIO_printf(PerlIO_stdout(), @@ -2454,7 +2504,7 @@ Perl_moreswitches(pTHX_ char *s) #endif #ifdef __VOS__ PerlIO_printf(PerlIO_stdout(), - "Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n"); + "Stratus VOS port by Paul_Green@stratus.com, 1997-2002\n"); #endif #ifdef __OPEN_VM PerlIO_printf(PerlIO_stdout(), @@ -2470,10 +2520,10 @@ Perl_moreswitches(pTHX_ char *s) #endif #ifdef EPOC PerlIO_printf(PerlIO_stdout(), - "EPOC port by Olaf Flebbe, 1999-2000\n"); + "EPOC port by Olaf Flebbe, 1999-2002\n"); #endif #ifdef UNDER_CE - printf("WINCE port by Rainer Keuchel, 2001\n"); + printf("WINCE port by Rainer Keuchel, 2001-2002\n"); printf("Built on " __DATE__ " " __TIME__ "\n\n"); wce_hitreturn(); #endif @@ -2495,11 +2545,15 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); return s; case 'W': PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; + if (!specialWARN(PL_compiling.cop_warnings)) + SvREFCNT_dec(PL_compiling.cop_warnings); PL_compiling.cop_warnings = pWARN_ALL ; s++; return s; case 'X': PL_dowarn = G_WARN_ALL_OFF; + if (!specialWARN(PL_compiling.cop_warnings)) + SvREFCNT_dec(PL_compiling.cop_warnings); PL_compiling.cop_warnings = pWARN_NONE ; s++; return s; @@ -2672,11 +2726,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) } } -# ifdef USE_ITHREADS - Safefree(CopFILE(PL_curcop)); -# else - SvREFCNT_dec(CopFILEGV(PL_curcop)); -# endif + CopFILE_free(PL_curcop); CopFILE_set(PL_curcop, PL_origfilename); if (strEQ(PL_origfilename,"-")) scriptname = ""; @@ -3415,7 +3465,13 @@ S_procself_val(pTHX_ SV *sv, char *arg0) { char buf[MAXPATHLEN]; int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1); - if (len > 0) { + /* 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 { @@ -3430,10 +3486,6 @@ 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); @@ -3482,46 +3534,20 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register env = environ; if (env != environ) 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,'='))) continue; - *s++ = '\0'; #if defined(MSDOS) + *s = '\0'; (void)strupr(*env); + *s = '='; #endif - sv = newSVpv(s--,0); + sv = newSVpv(s+1, 0); (void)hv_store(hv, *env, s - *env, sv, 0); - *s = '='; + 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;