X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=a27620a41d6ff2dae2fe38eae0338db5ef408ad8;hb=758f564b3fb5c63b84ce2ab3dd6edc68d23923b7;hp=73212c021481f52cfdbf1047cb0dc19f40dc18f7;hpb=b4e400f9f0f3998e635cdce0c2d2e790cbe42caa;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 73212c0..a27620a 100644 --- a/perl.c +++ b/perl.c @@ -21,7 +21,7 @@ #include #endif -#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) +#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO) char *getenv (char *); /* Usually in */ #endif @@ -469,8 +469,10 @@ perl_destruct(pTHXx) } /* jettison our possibly duplicated environment */ - -#ifdef USE_ENVIRON_ARRAY + /* 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) { I32 i; @@ -1097,6 +1099,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) goto reswitch; break; + case 't': + PL_taint_warn = TRUE; case 'T': PL_tainting = TRUE; s++; @@ -2189,8 +2193,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; @@ -2269,7 +2275,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 +2375,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"); @@ -2641,6 +2652,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 +2679,21 @@ 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 +# ifdef USE_ITHREADS + Safefree(CopFILE(PL_curcop)); +# else + SvREFCNT_dec(CopFILEGV(PL_curcop)); +# endif 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 +2704,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 +2783,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 } } @@ -3370,17 +3379,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 +3400,44 @@ 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); + if (len > 0) { + 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 +3447,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 +3459,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; @@ -3448,51 +3485,28 @@ 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; - 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)); + } } STATIC void