X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=5aae0c88c74f9201e9ae8003ab3b62aad5e32b57;hb=4d76a3443f3312704ec3416fd425698e92a208cd;hp=ee55c911e28fbf8e0de0243fbf53be6b75433de2;hpb=7114a2d26db82c459c722352adf0625e3ae9f42d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index ee55c91..5aae0c8 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. @@ -16,6 +16,11 @@ #include "perl.h" #include "patchlevel.h" /* for local_patches */ +#ifdef NETWARE +#include "nwutil.h" +char *nw_get_sitelib(const char *pl); +#endif + /* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD #include @@ -102,6 +107,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 +120,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 +210,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 +263,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 @@ -297,6 +299,21 @@ perl_construct(pTHXx) } /* +=for apidoc nothreadhook + +Stub that provides thread hook for perl_destruct when there are +no threads. + +=cut +*/ + +int +Perl_nothreadhook(pTHX) +{ + return 0; +} + +/* =for apidoc perl_destruct Shuts down a Perl interpreter. See L. @@ -413,11 +430,20 @@ perl_destruct(pTHXx) LEAVE; FREETMPS; + /* Need to flush since END blocks can produce output */ + my_fflush_all(); + + if (CALL_FPTR(PL_threadhook)(aTHX)) { + /* Threads hook has vetoed further cleanup */ + return STATUS_NATIVE_EXPORT; + } + /* We must account for everything. */ /* Destroy the main CV and syntax tree */ if (PL_main_root) { - PL_curpad = AvARRAY(PL_comppad); + /* 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; } @@ -465,13 +491,21 @@ perl_destruct(pTHXx) #endif /* The exit() function will do everything that needs doing. */ - return STATUS_NATIVE_EXPORT;; + return STATUS_NATIVE_EXPORT; } /* jettison our possibly duplicated environment */ - -#ifdef USE_ENVIRON_ARRAY - if (environ != PL_origenviron) { + /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied + * so we certainly shouldn't free it here + */ +#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV) + if (environ != PL_origenviron +#ifdef USE_ITHREADS + /* only main thread can free environ[0] contents */ + && PL_curinterp == aTHX +#endif + ) + { I32 i; for (i = 0; environ[i]; i++) @@ -667,6 +701,8 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_utf8_totitle); SvREFCNT_dec(PL_utf8_tolower); SvREFCNT_dec(PL_utf8_tofold); + SvREFCNT_dec(PL_utf8_idstart); + SvREFCNT_dec(PL_utf8_idcont); PL_utf8_alnum = Nullsv; PL_utf8_alnumc = Nullsv; PL_utf8_ascii = Nullsv; @@ -685,6 +721,8 @@ perl_destruct(pTHXx) PL_utf8_totitle = Nullsv; PL_utf8_tolower = Nullsv; PL_utf8_tofold = Nullsv; + PL_utf8_idstart = Nullsv; + PL_utf8_idcont = Nullsv; if (!specialWARN(PL_compiling.cop_warnings)) SvREFCNT_dec(PL_compiling.cop_warnings); @@ -692,15 +730,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. */ @@ -717,18 +748,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); } @@ -769,7 +800,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; @@ -801,17 +832,31 @@ perl_destruct(pTHXx) SvANY(&PL_sv_no) = NULL; SvFLAGS(&PL_sv_no) = 0; - SvREFCNT(&PL_sv_undef) = 0; - SvREADONLY_off(&PL_sv_undef); + { + int i; + for (i=0; i<=2; i++) { + SvREFCNT(PERL_DEBUG_PAD(i)) = 0; + sv_clear(PERL_DEBUG_PAD(i)); + SvANY(PERL_DEBUG_PAD(i)) = NULL; + SvFLAGS(PERL_DEBUG_PAD(i)) = 0; + } + } 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 ! */ PerlIO_cleanup(aTHX); #endif + /* sv_undef needs to stay immortal until after PerlIO_cleanup + as currently layers use it rather than Nullsv as a marker + for no arg - and will try and SvREFCNT_dec it. + */ + SvREFCNT(&PL_sv_undef) = 0; + SvREADONLY_off(&PL_sv_undef); + Safefree(PL_origfilename); Safefree(PL_reg_start_tmp); if (PL_reg_curpm) @@ -846,8 +891,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(); @@ -897,7 +941,7 @@ perl_free(pTHXx) # endif PerlMem_free(aTHXx); # ifdef NETWARE - nw5_delete_internal_host(host); + nw_delete_internal_host(host); # else win32_delete_internal_host(host); # endif @@ -1097,8 +1141,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; @@ -1106,7 +1158,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #ifdef MACOS_TRADITIONAL /* ignore -e for Dev:Pseudo argument */ if (argv[1] && !strcmp(argv[1], "Dev:Pseudo")) - break; + break; #endif if (PL_euid != PL_uid || PL_egid != PL_gid) Perl_croak(aTHX_ "No -e allowed in setuid scripts"); @@ -1277,8 +1329,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) { @@ -1293,7 +1347,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)) { @@ -1306,11 +1360,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) { @@ -1340,7 +1405,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); } @@ -1414,6 +1479,27 @@ print \" \\@INC:\\n @INC\\n\";"); if (!PL_do_undump) init_postdump_symbols(argc,argv,env); + /* PL_wantutf8 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); + } + } + init_lexer(); /* now parse the script */ @@ -1568,7 +1654,9 @@ S_run_body(pTHX_ I32 oldscope) if (PL_minus_c) { #ifdef MACOS_TRADITIONAL - PerlIO_printf(Perl_error_log, "# %s syntax OK\n", MacPerl_MPWFileName(PL_origfilename)); + PerlIO_printf(Perl_error_log, "%s%s syntax OK\n", + (gMacPerl_ErrorFormat ? "# " : ""), + MacPerl_MPWFileName(PL_origfilename)); #else PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); #endif @@ -1599,6 +1687,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 @@ -1626,6 +1716,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 @@ -1647,6 +1739,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 @@ -1668,6 +1762,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 @@ -1699,6 +1795,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. @@ -2080,6 +2179,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 @@ -2138,6 +2239,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)", @@ -2178,7 +2280,7 @@ Perl_moreswitches(pTHX_ char *s) else if (!rschar && numlen >= 2) PL_rs = newSVpvn("", 0); else { - char ch = rschar; + char ch = (char)rschar; PL_rs = newSVpvn(&ch, 1); } return s + numlen; @@ -2189,8 +2291,10 @@ Perl_moreswitches(pTHX_ char *s) return s; case 'F': PL_minus_F = TRUE; - PL_splitstr = savepv(s + 1); - s += strlen(s); + PL_splitstr = ++s; + while (*s && !isSPACE(*s)) ++s; + *s = '\0'; + PL_splitstr = savepv(PL_splitstr); return s; case 'a': PL_minus_a = TRUE; @@ -2234,7 +2338,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[] = "psltocPmfrxuLHXDSTRJvC"; char *d; for (s++; *s && (d = strchr(debopts,*s)); s++) @@ -2244,10 +2348,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 @@ -2256,10 +2365,16 @@ Perl_moreswitches(pTHX_ char *s) } case 'h': usage(PL_origargv[0]); - PerlProc_exit(0); + my_exit(0); case 'i': if (PL_inplace) Safefree(PL_inplace); +#if defined(__CYGWIN__) /* do backup extension automagically */ + if (*(s+1) == '\0') { + PL_inplace = savepv(".bak"); + return s+1; + } +#endif /* __CYGWIN__ */ PL_inplace = savepv(s+1); /*SUPPRESS 530*/ for (s = PL_inplace; *s && !isSPACE(*s); s++) ; @@ -2269,7 +2384,7 @@ Perl_moreswitches(pTHX_ char *s) s++; } return s; - case 'I': /* -I handled both here and in parse_perl() */ + case 'I': /* -I handled both here and in parse_body() */ forbid_setid("-I"); ++s; while (*s && isSPACE(*s)) @@ -2369,6 +2484,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"); @@ -2412,10 +2532,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 @@ -2430,7 +2550,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(), @@ -2442,7 +2562,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(), @@ -2450,7 +2570,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(), @@ -2466,10 +2586,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 @@ -2483,7 +2603,7 @@ GNU General Public License, which may be found in the Perl 5 source kit.\n\n\ Complete documentation for Perl, including FAQ lists, should be found on\n\ this system using `man perl' or `perldoc perl'. If you have access to the\n\ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); - PerlProc_exit(0); + my_exit(0); case 'w': if (! (PL_dowarn & G_WARN_ALL_MASK)) PL_dowarn |= G_WARN_ON; @@ -2491,11 +2611,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; @@ -2608,8 +2732,6 @@ S_init_main_stash(pTHX) { GV *gv; - - PL_curstash = PL_defstash = newHV(); PL_curstname = newSVpvn("main",4); gv = gv_fetchpv("main::",TRUE, SVt_PVHV); @@ -2641,6 +2763,11 @@ S_init_main_stash(pTHX) STATIC void S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) { + char *quote; + char *code; + char *cpp_discard_flag; + char *perl; + *fdscript = -1; if (PL_e_script) { @@ -2663,20 +2790,17 @@ 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 = ""; if (*fdscript >= 0) { PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE); -#if defined(HAS_FCNTL) && defined(F_SETFD) - if (PL_rsfp) - fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */ -#endif +# if defined(HAS_FCNTL) && defined(F_SETFD) + if (PL_rsfp) + /* ensure close-on-exec */ + fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); +# endif } else if (PL_preprocess) { char *cpp_cfg = CPPSTDIN; @@ -2687,85 +2811,75 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP); sv_catpv(cpp, cpp_cfg); - sv_catpvn(sv, "-I", 2); - sv_catpv(sv,PRIVLIB_EXP); +# ifndef VMS + sv_catpvn(sv, "-I", 2); + sv_catpv(sv,PRIVLIB_EXP); +# endif DEBUG_P(PerlIO_printf(Perl_debug_log, "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n", scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS)); -#if defined(MSDOS) || defined(WIN32) - Perl_sv_setpvf(aTHX_ cmd, "\ -sed %s -e \"/^[^#]/b\" \ - -e \"/^#[ ]*include[ ]/b\" \ - -e \"/^#[ ]*define[ ]/b\" \ - -e \"/^#[ ]*if[ ]/b\" \ - -e \"/^#[ ]*ifdef[ ]/b\" \ - -e \"/^#[ ]*ifndef[ ]/b\" \ - -e \"/^#[ ]*else/b\" \ - -e \"/^#[ ]*elif[ ]/b\" \ - -e \"/^#[ ]*undef[ ]/b\" \ - -e \"/^#[ ]*endif/b\" \ - -e \"s/^#.*//\" \ - %s | %"SVf" -C %"SVf" %s", - (PL_doextract ? "-e \"1,/^#/d\n\"" : ""), -#else -# ifdef __OPEN_VM - Perl_sv_setpvf(aTHX_ cmd, "\ -%s %s -e '/^[^#]/b' \ - -e '/^#[ ]*include[ ]/b' \ - -e '/^#[ ]*define[ ]/b' \ - -e '/^#[ ]*if[ ]/b' \ - -e '/^#[ ]*ifdef[ ]/b' \ - -e '/^#[ ]*ifndef[ ]/b' \ - -e '/^#[ ]*else/b' \ - -e '/^#[ ]*elif[ ]/b' \ - -e '/^#[ ]*undef[ ]/b' \ - -e '/^#[ ]*endif/b' \ - -e 's/^[ ]*#.*//' \ - %s | %"SVf" %"SVf" %s", -# else - Perl_sv_setpvf(aTHX_ cmd, "\ -%s %s -e '/^[^#]/b' \ - -e '/^#[ ]*include[ ]/b' \ - -e '/^#[ ]*define[ ]/b' \ - -e '/^#[ ]*if[ ]/b' \ - -e '/^#[ ]*ifdef[ ]/b' \ - -e '/^#[ ]*ifndef[ ]/b' \ - -e '/^#[ ]*else/b' \ - -e '/^#[ ]*elif[ ]/b' \ - -e '/^#[ ]*undef[ ]/b' \ - -e '/^#[ ]*endif/b' \ - -e 's/^[ ]*#.*//' \ - %s | %"SVf" -C %"SVf" %s", -# endif -#ifdef LOC_SED - LOC_SED, -#else - "sed", -#endif - (PL_doextract ? "-e '1,/^#/d\n'" : ""), -#endif - scriptname, cpp, sv, CPPMINUS); + +# if defined(MSDOS) || defined(WIN32) || defined(VMS) + quote = "\""; +# else + quote = "'"; +# endif + +# ifdef VMS + cpp_discard_flag = ""; +# else + cpp_discard_flag = "-C"; +# endif + +# ifdef OS2 + perl = os2_execname(aTHX); +# else + perl = PL_origargv[0]; +# endif + + + /* This strips off Perl comments which might interfere with + the C pre-processor, including #!. #line directives are + deliberately stripped to avoid confusion with Perl's version + of #line. FWP played some golf with it so it will fit + into VMS's 255 character buffer. + */ + if( PL_doextract ) + code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print"; + else + code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print"; + + Perl_sv_setpvf(aTHX_ cmd, "\ +%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s", + perl, quote, code, quote, scriptname, cpp, + cpp_discard_flag, sv, CPPMINUS); + PL_doextract = FALSE; -#ifdef IAMSUID /* actually, this is caught earlier */ - if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */ -#ifdef HAS_SETEUID - (void)seteuid(PL_uid); /* musn't stay setuid root */ -#else -#ifdef HAS_SETREUID - (void)setreuid((Uid_t)-1, PL_uid); -#else -#ifdef HAS_SETRESUID - (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1); -#else - PerlProc_setuid(PL_uid); -#endif -#endif -#endif +# ifdef IAMSUID /* actually, this is caught earlier */ + if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */ +# ifdef HAS_SETEUID + (void)seteuid(PL_uid); /* musn't stay setuid root */ +# else +# ifdef HAS_SETREUID + (void)setreuid((Uid_t)-1, PL_uid); +# else +# ifdef HAS_SETRESUID + (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1); +# else + PerlProc_setuid(PL_uid); +# endif +# endif +# endif if (PerlProc_geteuid() != PL_uid) Perl_croak(aTHX_ "Can't do seteuid!\n"); } -#endif /* IAMSUID */ +# endif /* IAMSUID */ + + DEBUG_P(PerlIO_printf(Perl_debug_log, + "PL_preprocess: cmd=\"%s\"\n", + SvPVX(cmd))); + PL_rsfp = PerlProc_popen(SvPVX(cmd), "r"); SvREFCNT_dec(cmd); SvREFCNT_dec(cpp); @@ -2776,34 +2890,36 @@ sed %s -e \"/^[^#]/b\" \ } else { PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); -#if defined(HAS_FCNTL) && defined(F_SETFD) - if (PL_rsfp) - fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */ -#endif +# if defined(HAS_FCNTL) && defined(F_SETFD) + if (PL_rsfp) + /* ensure close-on-exec */ + fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); +# endif } if (!PL_rsfp) { -#ifdef DOSUID -#ifndef IAMSUID /* in case script is not readable before setuid */ - if (PL_euid && - PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 && - PL_statbuf.st_mode & (S_ISUID|S_ISGID)) - { - /* try again */ - PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP, - (int)PERL_REVISION, (int)PERL_VERSION, - (int)PERL_SUBVERSION), PL_origargv); - Perl_croak(aTHX_ "Can't do setuid\n"); - } -#endif -#endif -#ifdef IAMSUID - errno = EPERM; - Perl_croak(aTHX_ "Can't open perl script: %s\n", - Strerror(errno)); -#else - Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", - CopFILE(PL_curcop), Strerror(errno)); -#endif +# ifdef DOSUID +# ifndef IAMSUID /* in case script is not readable before setuid */ + if (PL_euid && + PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 && + PL_statbuf.st_mode & (S_ISUID|S_ISGID)) + { + /* try again */ + PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, + BIN_EXP, (int)PERL_REVISION, + (int)PERL_VERSION, + (int)PERL_SUBVERSION), PL_origargv); + Perl_croak(aTHX_ "Can't do setuid\n"); + } +# endif +# endif +# ifdef IAMSUID + errno = EPERM; + Perl_croak(aTHX_ "Can't open perl script: %s\n", + Strerror(errno)); +# else + Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", + CopFILE(PL_curcop), Strerror(errno)); +# endif } } @@ -2860,7 +2976,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd) defined(HAS_STRUCT_FS_DATA) && \ defined(NOSTAT_ONE) # define FD_ON_NOSUID_CHECK_OKAY - struct stat fdst; + Stat_t fdst; if (fstat(fd, &fdst) == 0) { struct ustat us; @@ -2890,7 +3006,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd) # define FD_ON_NOSUID_CHECK_OKAY FILE *mtab = fopen("/etc/mtab", "r"); struct mntent *entry; - struct stat stb, fsb; + Stat_t stb, fsb; if (mtab && (fstat(fd, &stb) == 0)) { while (entry = getmntent(mtab)) { @@ -2970,7 +3086,7 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) * Then we just have to make sure he or she can execute it. */ { - struct stat tmpstatbuf; + Stat_t tmpstatbuf; if ( #ifdef HAS_SETREUID @@ -3158,6 +3274,9 @@ STATIC void S_find_beginning(pTHX) { register char *s, *s2; +#ifdef MACOS_TRADITIONAL + int maclines = 0; +#endif /* skip forward in input to the real script? */ @@ -3169,16 +3288,16 @@ S_find_beginning(pTHX) if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { if (!gMacPerl_AlwaysExtract) Perl_croak(aTHX_ "No Perl script found in input\n"); - + if (PL_doextract) /* require explicit override ? */ if (!OverrideExtract(PL_origfilename)) Perl_croak(aTHX_ "User aborted script\n"); else PL_doextract = FALSE; - + /* Pater peccavi, file does not have #! */ PerlIO_rewind(PL_rsfp); - + break; } #else @@ -3201,7 +3320,18 @@ S_find_beginning(pTHX) ; } #ifdef MACOS_TRADITIONAL + /* We are always searching for the #!perl line in MacPerl, + * so if we find it, still keep the line count correct + * by counting lines we already skipped over + */ + for (; maclines > 0 ; maclines--) + PerlIO_ungetc(PL_rsfp, '\n'); + break; + + /* gMacPerl_AlwaysExtract is false in MPW tool */ + } else if (gMacPerl_AlwaysExtract) { + ++maclines; #endif } } @@ -3370,17 +3500,10 @@ S_init_predump_symbols(pTHX) PL_osname = savepv(OSNAME); } -STATIC void -S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env) +void +Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) { char *s; - SV *sv; - GV* tmpgv; -#ifdef NEED_ENVIRON_DUP_FOR_MODIFY - char **dup_env_base = 0; - int dup_env_count = 0; -#endif - argc--,argv++; /* skip name of script */ if (PL_doswitches) { for (; argc > 0 && **argv == '-'; argc--,argv++) { @@ -3398,6 +3521,61 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1); } } + if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) { + GvMULTI_on(PL_argvgv); + (void)gv_AVadd(PL_argvgv); + av_clear(GvAVn(PL_argvgv)); + 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); + } + } +} + +#ifdef HAS_PROCSELFEXE +/* This is a function so that we don't hold on to MAXPATHLEN + bytes of stack longer than necessary + */ +STATIC void +S_procself_val(pTHX_ SV *sv, char *arg0) +{ + char buf[MAXPATHLEN]; + int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1); + + /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe) + includes a spurious NUL which will cause $^X to fail in system + or backticks (this will prevent extensions from being built and + many tests from working). readlink is not meant to add a NUL. + Normal readlink works fine. + */ + if (len > 0 && buf[len-1] == '\0') { + len--; + } + + /* 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 { + sv_setpv(sv,arg0); + } +} +#endif /* HAS_PROCSELFEXE */ + +STATIC void +S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env) +{ + char *s; + SV *sv; + GV* tmpgv; + PL_toptarget = NEWSV(0,0); sv_upgrade(PL_toptarget, SVt_PVFM); sv_setpvn(PL_toptarget, "", 0); @@ -3407,6 +3585,9 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register PL_formtarget = PL_bodytarget; TAINT; + + init_argv_symbols(argc,argv); + if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) { #ifdef MACOS_TRADITIONAL /* $0 is not majick on a Mac */ @@ -3416,22 +3597,16 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register magicname("0", "0", 1); #endif } - if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) + if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */ +#ifdef HAS_PROCSELFEXE + S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]); +#else #ifdef OS2 sv_setpv(GvSV(tmpgv), os2_execname(aTHX)); #else sv_setpv(GvSV(tmpgv),PL_origargv[0]); #endif - if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) { - GvMULTI_on(PL_argvgv); - (void)gv_AVadd(PL_argvgv); - av_clear(GvAVn(PL_argvgv)); - 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); - } +#endif } if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) { HV *hv; @@ -3446,53 +3621,47 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register */ if (!env) env = environ; - if (env != environ) - environ[0] = Nullch; -#ifdef NEED_ENVIRON_DUP_FOR_MODIFY + if (env != environ +# ifdef USE_ITHREADS + && PL_curinterp == aTHX +# endif + ) { - 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? */ + environ[0] = Nullch; } -#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; - if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) + if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) { + SvREADONLY_off(GvSV(tmpgv)); 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) { + (void) get_av("main::F", TRUE | GV_ADDMULTI); + } + /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */ + (void) get_av("main::-", TRUE | GV_ADDMULTI); + (void) get_av("main::+", TRUE | GV_ADDMULTI); } STATIC void @@ -3532,7 +3701,7 @@ S_init_perllib(pTHX) #endif #ifdef MACOS_TRADITIONAL { - struct stat tmpstatbuf; + Stat_t tmpstatbuf; SV * privdir = NEWSV(55, 0); char * macperl = PerlEnv_getenv("MACPERL"); @@ -3660,8 +3829,11 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) p = Nullch; /* break out */ } #ifdef MACOS_TRADITIONAL - if (!strchr(SvPVX(libdir), ':')) - sv_insert(libdir, 0, 0, ":", 1); + if (!strchr(SvPVX(libdir), ':')) { + char buf[256]; + + sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0)); + } if (SvPVX(libdir)[SvCUR(libdir)-1] != ':') sv_catpv(libdir, ":"); #endif @@ -3676,7 +3848,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) const char *incverlist[] = { PERL_INC_VERSION_LIST }; const char **incver; #endif - struct stat tmpstatbuf; + Stat_t tmpstatbuf; #ifdef VMS char *unix; STRLEN len;