X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=67c99ebcc3d88b913d391d70e08f87a7510feb3a;hb=4c84d7f2a03f1d29578b3894e1b6863673b307fb;hp=c62722a178cbd56bf9f2349bc149e7a517c9b361;hpb=13765c85de4dc05031cfb5d6273ea7e178b9807b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index c62722a..67c99eb 100644 --- a/perl.c +++ b/perl.c @@ -181,6 +181,38 @@ S_init_tls_and_interp(PerlInterpreter *my_perl) } } + +/* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */ + +void +Perl_sys_init(int* argc, char*** argv) +{ + dVAR; + PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */ + PERL_UNUSED_ARG(argv); + PERL_SYS_INIT_BODY(argc, argv); +} + +void +Perl_sys_init3(int* argc, char*** argv, char*** env) +{ + dVAR; + PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */ + PERL_UNUSED_ARG(argv); + PERL_UNUSED_ARG(env); + PERL_SYS_INIT3_BODY(argc, argv, env); +} + +void +Perl_sys_term() +{ + dVAR; + if (!PL_veto_cleanup) { + PERL_SYS_TERM_BODY(); + } +} + + #ifdef PERL_IMPLICIT_SYS PerlInterpreter * perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, @@ -268,15 +300,19 @@ perl_construct(pTHXx) sv_setpv(&PL_sv_no,PL_No); /* value lookup in void context - happens to have the side effect - of caching the numeric forms. */ - SvIV(&PL_sv_no); + of caching the numeric forms. However, as &PL_sv_no doesn't contain + a string that is a valid numer, we have to turn the public flags by + hand: */ SvNV(&PL_sv_no); + SvIV(&PL_sv_no); + SvIOK_on(&PL_sv_no); + SvNOK_on(&PL_sv_no); SvREADONLY_on(&PL_sv_no); SvREFCNT(&PL_sv_no) = (~(U32)0)/2; sv_setpv(&PL_sv_yes,PL_Yes); - SvIV(&PL_sv_yes); SvNV(&PL_sv_yes); + SvIV(&PL_sv_yes); SvREADONLY_on(&PL_sv_yes); SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; @@ -531,7 +567,7 @@ int perl_destruct(pTHXx) { dVAR; - VOL int destruct_level; /* 0=none, 1=full, 2=full with checks */ + VOL signed char destruct_level; /* see possible values in intrpvar.h */ HV *hv; #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP pid_t child; @@ -836,28 +872,6 @@ perl_destruct(pTHXx) * REGEXPs in the parent interpreter * we need to manually ReREFCNT_dec for the clones */ - { - I32 i = AvFILLp(PL_regex_padav) + 1; - SV * const * const ary = AvARRAY(PL_regex_padav); - - while (i) { - SV * const resv = ary[--i]; - - if (SvFLAGS(resv) & SVf_BREAK) { - /* this is PL_reg_curpm, already freed - * flag is set in regexec.c:S_regtry - */ - SvFLAGS(resv) &= ~SVf_BREAK; - } - else if(SvREPADTMP(resv)) { - SvREPADTMP_off(resv); - } - else if(SvIOKp(resv)) { - REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv)); - ReREFCNT_dec(re); - } - } - } SvREFCNT_dec(PL_regex_padav); PL_regex_padav = NULL; PL_regex_pad = NULL; @@ -880,7 +894,6 @@ perl_destruct(pTHXx) } /* switches */ - PL_preprocess = FALSE; PL_minus_n = FALSE; PL_minus_p = FALSE; PL_minus_l = FALSE; @@ -971,7 +984,6 @@ perl_destruct(pTHXx) PL_DBsingle = NULL; PL_DBtrace = NULL; PL_DBsignal = NULL; - PL_DBassertion = NULL; PL_DBcv = NULL; PL_dbargs = NULL; PL_debstash = NULL; @@ -1192,7 +1204,8 @@ perl_destruct(pTHXx) " flags=0x%"UVxf " refcnt=%"UVuf pTHX__FORMAT "\n" "\tallocated at %s:%d %s %s%s\n", - (void*)sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE, + (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt + pTHX__VALUE, sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", sv->sv_debug_line, sv->sv_debug_inpad ? "for" : "by", @@ -1226,6 +1239,10 @@ perl_destruct(pTHXx) } #endif #endif +#ifdef DEBUG_LEAKING_SCALARS_ABORT + if (PL_sv_count) + abort(); +#endif PL_sv_count = 0; #ifdef PERL_DEBUG_READONLY_OPS @@ -1658,7 +1675,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) VOL bool dosearch = FALSE; const char *validarg = ""; register SV *sv; - register char *s, c; + register char c; const char *cddir = NULL; #ifdef USE_SITECUSTOMIZE bool minus_f = FALSE; @@ -1673,6 +1690,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) SAVEFREESV(sv); init_main_stash(); + { + const char *s; for (argc--,argv++; argc > 0; argc--,argv++) { if (argv[0][0] != '-' || !argv[0][1]) break; @@ -1716,7 +1735,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) case 'W': case 'X': case 'w': - case 'A': if ((s = moreswitches(s))) goto reswitch; break; @@ -1785,11 +1803,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) else Perl_croak(aTHX_ "No directory specified for -I"); break; - case 'P': - forbid_setid('P', -1); - PL_preprocess = TRUE; - s++; - goto reswitch; case 'S': forbid_setid('S', -1); dosearch = TRUE; @@ -1801,56 +1814,18 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) Perl_av_create_and_push(aTHX_ &PL_preambleav, newSVpvs("use Config;")); if (*++s != ':') { - STRLEN opts; - - opts_prog = newSVpvs("print Config::myconfig(),"); -#ifdef VMS - sv_catpvs(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n\","); -#else - sv_catpvs(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n\","); -#endif - opts = SvCUR(opts_prog); - - Perl_sv_catpv(aTHX_ opts_prog,"\" Compile-time options:" + /* Can't do newSVpvs() as that would involve pre-processor + condititionals inside a macro expansion. */ + opts_prog = Perl_newSVpv(aTHX_ "$_ = join ' ', sort qw(" # ifdef DEBUGGING " DEBUGGING" # endif -# ifdef DEBUG_LEAKING_SCALARS - " DEBUG_LEAKING_SCALARS" -# endif -# ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP - " DEBUG_LEAKING_SCALARS_FORK_DUMP" -# endif -# ifdef FAKE_THREADS - " FAKE_THREADS" -# endif -# ifdef MULTIPLICITY - " MULTIPLICITY" -# endif -# ifdef MYMALLOC - " MYMALLOC" -# endif # ifdef NO_MATHOMS " NO_MATHOMS" # endif -# ifdef PERL_DEBUG_READONLY_OPS - " PERL_DEBUG_READONLY_OPS" -# endif # ifdef PERL_DONT_CREATE_GVSV " PERL_DONT_CREATE_GVSV" # endif -# ifdef PERL_GLOBAL_STRUCT - " PERL_GLOBAL_STRUCT" -# endif -# ifdef PERL_IMPLICIT_CONTEXT - " PERL_IMPLICIT_CONTEXT" -# endif -# ifdef PERL_IMPLICIT_SYS - " PERL_IMPLICIT_SYS" -# endif -# ifdef PERL_MAD - " PERL_MAD" -# endif # ifdef PERL_MALLOC_WRAP " PERL_MALLOC_WRAP" # endif @@ -1869,85 +1844,24 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef PERL_MEM_LOG_TIMESTAMP " PERL_MEM_LOG_TIMESTAMP" # endif -# ifdef PERL_NEED_APPCTX - " PERL_NEED_APPCTX" -# endif -# ifdef PERL_NEED_TIMESBASE - " PERL_NEED_TIMESBASE" -# endif -# ifdef PERL_OLD_COPY_ON_WRITE - " PERL_OLD_COPY_ON_WRITE" -# endif -# ifdef PERL_POISON - " PERL_POISON" -# endif -# ifdef PERL_TRACK_MEMPOOL - " PERL_TRACK_MEMPOOL" -# endif # ifdef PERL_USE_SAFE_PUTENV " PERL_USE_SAFE_PUTENV" # endif -# ifdef PERL_USES_PL_PIDSTATUS - " PERL_USES_PL_PIDSTATUS" -# endif -# ifdef PL_OP_SLAB_ALLOC - " PL_OP_SLAB_ALLOC" -# endif -# ifdef THREADS_HAVE_PIDS - " THREADS_HAVE_PIDS" -# endif -# ifdef USE_64_BIT_ALL - " USE_64_BIT_ALL" -# endif -# ifdef USE_64_BIT_INT - " USE_64_BIT_INT" -# endif -# ifdef USE_ITHREADS - " USE_ITHREADS" -# endif -# ifdef USE_LARGE_FILES - " USE_LARGE_FILES" -# endif -# ifdef USE_LONG_DOUBLE - " USE_LONG_DOUBLE" -# endif -# ifdef USE_PERLIO - " USE_PERLIO" -# endif -# ifdef USE_REENTRANT_API - " USE_REENTRANT_API" -# endif -# ifdef USE_SFIO - " USE_SFIO" -# endif # ifdef USE_SITECUSTOMIZE " USE_SITECUSTOMIZE" # endif -# ifdef USE_SOCKS - " USE_SOCKS" -# endif - ); - - while (SvCUR(opts_prog) > opts+76) { - /* find last space after "options: " and before col 76 - */ - - const char *space; - char * const pv = SvPV_nolen(opts_prog); - const char c = pv[opts+76]; - pv[opts+76] = '\0'; - space = strrchr(pv+opts+26, ' '); - pv[opts+76] = c; - if (!space) break; /* "Can't happen" */ - - /* break the line before that space */ + , 0); - opts = space - pv; - Perl_sv_insert(aTHX_ opts_prog, opts, 0, - STR_WITH_LEN("\\n ")); - } + sv_catpv(opts_prog, PL_bincompat_options); + /* Terminate the qw(, and then wrap at 76 columns. */ + sv_catpvs(opts_prog, "); s/(?=.{53})(.{1,53}) /$1\\n /mg;print Config::myconfig(),"); +#ifdef VMS + sv_catpvs(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n"); +#else + sv_catpvs(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n"); +#endif - sv_catpvs(opts_prog,"\\n\","); + sv_catpvs(opts_prog," Compile-time options: $_\\n\","); #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) { @@ -1962,14 +1876,14 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } #endif Perl_sv_catpvf(aTHX_ opts_prog, - "\" Built under %s\\n\"",OSNAME); + "\" Built under %s\\n",OSNAME); #ifdef __DATE__ # ifdef __TIME__ Perl_sv_catpvf(aTHX_ opts_prog, - ",\" Compiled at %s %s\\n\"",__DATE__, + " Compiled at %s %s\\n\"",__DATE__, __TIME__); # else - Perl_sv_catpvf(aTHX_ opts_prog,",\" Compiled on %s\\n\"", + Perl_sv_catpvf(aTHX_ opts_prog," Compiled on %s\\n\"", __DATE__); # endif #endif @@ -2024,8 +1938,13 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s); } } + } + switch_end: + { + char *s; + if ( #ifndef SECURE_INTERNAL_GETENV !PL_tainting && @@ -2054,7 +1973,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) d = s; if (!*s) break; - if (!strchr("CDIMUdmtwA", *s)) + if (!strchr("CDIMUdmtw", *s)) Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); while (++s && *s) { if (isSPACE(*s)) { @@ -2078,6 +1997,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } } + } #ifdef USE_SITECUSTOMIZE if (!minus_f) { @@ -2230,6 +2150,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } + { + const char *s; if ((s = PerlEnv_getenv("PERL_SIGNALS"))) { if (strEQ(s, "unsafe")) PL_signals |= PERL_SIGNALS_UNSAFE_FLAG; @@ -2238,8 +2160,11 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) else Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s); } + } #ifdef PERL_MAD + { + const char *s; if ((s = PerlEnv_getenv("PERL_XMLDUMP"))) { PL_madskills = 1; PL_minus_c = 1; @@ -2250,11 +2175,16 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) if (!PL_xmlfp) Perl_croak(aTHX_ "Can't open %s", s); } - my_setenv("PERL_XMLDUMP", Nullch); /* hide from subprocs */ + my_setenv("PERL_XMLDUMP", NULL); /* hide from subprocs */ + } } + + { + const char *s; if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) { PL_madskills = atoi(s); - my_setenv("PERL_MADSKILLS", Nullch); /* hide from subprocs */ + my_setenv("PERL_MADSKILLS", NULL); /* hide from subprocs */ + } } #endif @@ -2288,7 +2218,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #endif CopLINE_set(PL_curcop, 0); PL_curstash = PL_defstash; - PL_preprocess = FALSE; if (PL_e_script) { SvREFCNT_dec(PL_e_script); PL_e_script = NULL; @@ -2307,8 +2236,11 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) FREETMPS; #ifdef MYMALLOC + { + const char *s; if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2) dump_mstats("after compilation:"); + } #endif ENTER; @@ -2528,8 +2460,7 @@ Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags) * It has the same effect as "sub name;", i.e. just a forward * declaration! */ if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) { - SV *const sv = newSVpvn(name,len); - SvFLAGS(sv) |= flags & SVf_UTF8; + SV *const sv = newSVpvn_flags(name, len, flags & SVf_UTF8); return newSUB(start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, sv), NULL, NULL); @@ -2570,7 +2501,7 @@ Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) PUSHMARK(SP); if (argv) { while (*argv) { - XPUSHs(sv_2mortal(newSVpv(*argv,0))); + mXPUSHs(newSVpv(*argv,0)); argv++; } PUTBACK; @@ -2908,7 +2839,6 @@ S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */ static const char * const usage_msg[] = { "-0[octal] specify record separator (\\0, if no argument)", -"-A[mod][=pattern] activate all/given assertions", "-a autosplit mode with -n or -p (splits $_ into @F)", "-C[number/list] enables the listed Unicode features", "-c check syntax only (runs BEGIN and CHECK blocks)", @@ -2924,7 +2854,6 @@ S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */ "-[mM][-]module execute \"use/no module...\" before executing program", "-n assume \"while (<>) { ... }\" loop around program", "-p assume loop like -n but print line also, like sed", -"-P run program through C preprocessor before compilation", "-s enable rudimentary parsing for switches after programfile", "-S look for programfile using PATH environment variable", "-t enable tainting warnings", @@ -2964,7 +2893,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) " t Trace execution", " o Method and overloading resolution", " c String/numeric conversions", - " P Print profiling info, preprocessor command for -P, source file input state", + " P Print profiling info, source file input state", " m Memory allocation", " f Format processing", " r Regular expression parsing and execution", @@ -3016,8 +2945,8 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) /* This routine handles any switches that can be given during run */ -char * -Perl_moreswitches(pTHX_ char *s) +const char * +Perl_moreswitches(pTHX_ const char *s) { dVAR; UV rschar; @@ -3098,21 +3027,23 @@ Perl_moreswitches(pTHX_ char *s) /* The following permits -d:Mod to accepts arguments following an = in the fashion that -MSome::Mod does. */ if (*s == ':' || *s == '=') { - const char *start; + const char *start = ++s; + const char *const end = s + strlen(s); SV * const sv = newSVpvs("use Devel::"); - start = ++s; + /* We now allow -d:Module=Foo,Bar */ while(isALNUM(*s) || *s==':') ++s; if (*s != '=') - sv_catpv(sv, start); + sv_catpvn(sv, start, end - start); else { sv_catpvn(sv, start, s-start); /* Don't use NUL as q// delimiter here, this string goes in the * environment. */ Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s); } - s += strlen(s); + s = end; my_setenv("PERL5DB", SvPV_nolen_const(sv)); + SvREFCNT_dec(sv); } if (!PL_perldb) { PL_perldb = PERLDB_ALL; @@ -3163,7 +3094,7 @@ Perl_moreswitches(pTHX_ char *s) while (*s && isSPACE(*s)) ++s; if (*s) { - char *e, *p; + const char *e, *p; p = s; /* ignore trailing spaces (possibly followed by other switches) */ do { @@ -3206,34 +3137,14 @@ Perl_moreswitches(pTHX_ char *s) } } return s; - case 'A': - forbid_setid('A', -1); - s++; - { - char * const start = s; - SV * const sv = newSVpvs("use assertions::activate"); - while(isALNUM(*s) || *s == ':') ++s; - if (s != start) { - sv_catpvs(sv, "::"); - sv_catpvn(sv, start, s-start); - } - if (*s == '=') { - Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0); - s+=strlen(s); - } - else if (*s != '\0') { - Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, (int)(s-start), start); - } - Perl_av_create_and_push(aTHX_ &PL_preambleav, sv); - return s; - } case 'M': forbid_setid('M', -1); /* XXX ? */ /* FALL THROUGH */ case 'm': forbid_setid('m', -1); /* XXX ? */ if (*++s) { - char *start; + const char *start; + const char *end; SV *sv; const char *use = "use "; /* -M-foo == 'no foo' */ @@ -3244,8 +3155,9 @@ Perl_moreswitches(pTHX_ char *s) start = s; /* We allow -M'Module qw(Foo Bar)' */ while(isALNUM(*s) || *s==':') ++s; + end = s + strlen(s); if (*s != '=') { - sv_catpv(sv, start); + sv_catpvn(sv, start, end - start); if (*(start-1) == 'm') { if (*s != '\0') Perl_croak(aTHX_ "Can't use '%c' after -mname", *s); @@ -3256,12 +3168,13 @@ Perl_moreswitches(pTHX_ char *s) Perl_croak(aTHX_ "Module name required with -%c option", s[-1]); sv_catpvn(sv, start, s-start); - sv_catpvs(sv, " split(/,/,q"); - sv_catpvs(sv, "\0"); /* Use NUL as q//-delimiter. */ - sv_catpv(sv, ++s); + /* Use NUL as q''-delimiter. */ + sv_catpvs(sv, " split(/,/,q\0"); + ++s; + sv_catpvn(sv, s, end - s); sv_catpvs(sv, "\0)"); } - s += strlen(s); + s = end; Perl_av_create_and_push(aTHX_ &PL_preambleav, sv); } else @@ -3449,10 +3362,6 @@ Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n"); case 'S': /* OS/2 needs -S on "extproc" line. */ break; #endif - case 'P': - if (PL_preprocess) - return s+1; - /* FALL THROUGH */ default: Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s); } @@ -3662,78 +3571,52 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv, Perl_croak(aTHX_ "suidperl needs (suid) fd script\n"); } #else /* IAMSUID */ - else if (PL_preprocess) { - const char * const cpp_cfg = CPPSTDIN; - SV * const cpp = newSVpvs(""); - SV * const cmd = newSV(0); - - if (cpp_cfg[0] == 0) /* PERL_MICRO? */ - Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined"); - if (strEQ(cpp_cfg, "cppstdin")) - Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP); - sv_catpv(cpp, cpp_cfg); - -# ifndef VMS - sv_catpvs(sv, "-I"); - 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_const (cpp), SvPVX_const (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, SVfARG(cpp), - cpp_discard_flag, SVfARG(sv), CPPMINUS); - - PL_doextract = FALSE; - - DEBUG_P(PerlIO_printf(Perl_debug_log, - "PL_preprocess: cmd=\"%s\"\n", - SvPVX_const(cmd))); - - *rsfpp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r"); - SvREFCNT_dec(cmd); - SvREFCNT_dec(cpp); - } else if (!*scriptname) { forbid_setid(0, *suidscript); *rsfpp = PerlIO_stdin(); } else { +#ifdef FAKE_BIT_BUCKET + /* This hack allows one not to have /dev/null (or BIT_BUCKET as it + * is called) and still have the "-e" work. (Believe it or not, + * a /dev/null is required for the "-e" to work because source + * filter magic is used to implement it. ) This is *not* a general + * replacement for a /dev/null. What we do here is create a temp + * file (an empty file), open up that as the script, and then + * immediately close and unlink it. Close enough for jazz. */ +#define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-" +#define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX" +#define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX + char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = { + FAKE_BIT_BUCKET_TEMPLATE + }; + const char * const err = "Failed to create a fake bit bucket"; + if (strEQ(scriptname, BIT_BUCKET)) { +#ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */ + int tmpfd = mkstemp(tmpname); + if (tmpfd > -1) { + scriptname = tmpname; + close(tmpfd); + } else + Perl_croak(aTHX_ err); +#else +# ifdef HAS_MKTEMP + scriptname = mktemp(tmpname); + if (!scriptname) + Perl_croak(aTHX_ err); +# endif +#endif + } +#endif *rsfpp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); +#ifdef FAKE_BIT_BUCKET + if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX, + sizeof(FAKE_BIT_BUCKET_PREFIX) - 1) + && strlen(scriptname) == sizeof(tmpname) - 1) { + unlink(scriptname); + } + scriptname = BIT_BUCKET; +#endif # if defined(HAS_FCNTL) && defined(F_SETFD) if (*rsfpp) /* ensure close-on-exec */ @@ -3932,7 +3815,7 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname, const char *linestr; const char *s_end; -#ifdef IAMSUID +# ifdef IAMSUID if (fdscript < 0 || suidscript != 1) Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */ /* PSz 11 Nov 03 @@ -3943,16 +3826,16 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname, /* PSz 27 Feb 04 * Do checks even for systems with no HAS_SETREUID. * We used to swap, then re-swap UIDs with -#ifdef HAS_SETREUID +# ifdef HAS_SETREUID if (setreuid(PL_euid,PL_uid) < 0 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid) Perl_croak(aTHX_ "Can't swap uid and euid"); -#endif -#ifdef HAS_SETREUID +# endif +# ifdef HAS_SETREUID if (setreuid(PL_uid,PL_euid) < 0 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid) Perl_croak(aTHX_ "Can't reswap uid and euid"); -#endif +# endif */ /* On this access check to make sure the directories are readable, @@ -4013,12 +3896,12 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname, * operating systems do not have such mount options anyway...) * Seems safe enough to do as root. */ -#if !defined(NO_NOSUID_CHECK) +# if !defined(NO_NOSUID_CHECK) if (fd_on_nosuid_fs(PerlIO_fileno(rsfp))) { Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n"); } -#endif -#endif /* IAMSUID */ +# endif +# endif /* IAMSUID */ if (!S_ISREG(PL_statbuf.st_mode)) { Perl_croak(aTHX_ "Setuid script not plain file\n"); @@ -4082,14 +3965,14 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname, || ((s_end - s) == len+2 && isSPACE(s[len+1])))) Perl_croak(aTHX_ "Args must match #! line"); -#ifndef IAMSUID +# ifndef IAMSUID if (fdscript < 0 && PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) && PL_euid == PL_statbuf.st_uid) if (!PL_do_undump) Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); -#endif /* IAMSUID */ +# endif /* IAMSUID */ if (fdscript < 0 && PL_euid) { /* oops, we're not the setuid root perl */ @@ -4107,7 +3990,7 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); * fdscript to avoid loops), and do the execs * even for root. */ -#ifndef IAMSUID +# ifndef IAMSUID int which; /* PSz 11 Nov 03 * Pass fd script to suidperl. @@ -4135,15 +4018,15 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); } PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s", PerlIO_fileno(rsfp), PL_origargv[which])); -#if defined(HAS_FCNTL) && defined(F_SETFD) +# if defined(HAS_FCNTL) && defined(F_SETFD) fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */ -#endif +# endif PERL_FPU_PRE_EXEC 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_FPU_POST_EXEC -#endif /* IAMSUID */ +# endif /* IAMSUID */ Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n"); } @@ -4154,54 +4037,54 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); * in the sense that we only want to set EGID; but are there any machines * with either of the latter, but not the former? Same with UID, later. */ -#ifdef HAS_SETEGID +# ifdef HAS_SETEGID (void)setegid(PL_statbuf.st_gid); -#else -#ifdef HAS_SETREGID +# else +# ifdef HAS_SETREGID (void)setregid((Gid_t)-1,PL_statbuf.st_gid); -#else -#ifdef HAS_SETRESGID +# else +# ifdef HAS_SETRESGID (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1); -#else +# else PerlProc_setgid(PL_statbuf.st_gid); -#endif -#endif -#endif +# endif +# endif +# endif if (PerlProc_getegid() != PL_statbuf.st_gid) Perl_croak(aTHX_ "Can't do setegid!\n"); } if (PL_statbuf.st_mode & S_ISUID) { if (PL_statbuf.st_uid != PL_euid) -#ifdef HAS_SETEUID +# ifdef HAS_SETEUID (void)seteuid(PL_statbuf.st_uid); /* all that for this */ -#else -#ifdef HAS_SETREUID +# else +# ifdef HAS_SETREUID (void)setreuid((Uid_t)-1,PL_statbuf.st_uid); -#else -#ifdef HAS_SETRESUID +# else +# ifdef HAS_SETRESUID (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1); -#else +# else PerlProc_setuid(PL_statbuf.st_uid); -#endif -#endif -#endif +# endif +# endif +# endif if (PerlProc_geteuid() != PL_statbuf.st_uid) Perl_croak(aTHX_ "Can't do seteuid!\n"); } else if (PL_uid) { /* oops, mustn't run as root */ -#ifdef HAS_SETEUID +# ifdef HAS_SETEUID (void)seteuid((Uid_t)PL_uid); -#else -#ifdef HAS_SETREUID +# else +# ifdef HAS_SETREUID (void)setreuid((Uid_t)-1,(Uid_t)PL_uid); -#else -#ifdef HAS_SETRESUID +# else +# ifdef HAS_SETRESUID (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1); -#else +# else PerlProc_setuid((Uid_t)PL_uid); -#endif -#endif -#endif +# endif +# endif +# endif if (PerlProc_geteuid() != PL_uid) Perl_croak(aTHX_ "Can't do seteuid!\n"); } @@ -4209,9 +4092,7 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); if (!cando(S_IXUSR,TRUE,&PL_statbuf)) Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */ } -#ifdef IAMSUID - else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */ - Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n"); +# ifdef IAMSUID else if (fdscript < 0 || suidscript != 1) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */ Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n"); @@ -4265,21 +4146,23 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); /* } */ /* PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s", */ /* PerlIO_fileno(rsfp), PL_origargv[which])); */ -#if defined(HAS_FCNTL) && defined(F_SETFD) +# if defined(HAS_FCNTL) && defined(F_SETFD) fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */ -#endif +# endif PERL_FPU_PRE_EXEC PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION), PL_origargv);/* try again */ PERL_FPU_POST_EXEC Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n"); -#endif /* IAMSUID */ +# endif /* IAMSUID */ #else /* !DOSUID */ PERL_UNUSED_ARG(fdscript); PERL_UNUSED_ARG(suidscript); if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */ -#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW +# ifdef SETUID_SCRIPTS_ARE_SECURE_NOW + PERL_UNUSED_ARG(rsfp); +# else PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */ if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID) || @@ -4288,7 +4171,7 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); if (!PL_do_undump) Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); -#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ +# endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ /* not set-id, must be wrapped */ } #endif /* DOSUID */ @@ -4301,7 +4184,7 @@ STATIC void S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) { dVAR; - register char *s; + const char *s; register const char *s2; #ifdef MACOS_TRADITIONAL int maclines = 0; @@ -4500,8 +4383,6 @@ Perl_init_debugger(pTHX) sv_setiv(PL_DBtrace, 0); PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBsignal, 0); - PL_DBassertion = GvSV((gv_fetchpvs("DB::assertion", GV_ADDMULTI, SVt_PV))); - sv_setiv(PL_DBassertion, 0); PL_curstash = ostash; } @@ -4977,7 +4858,8 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, SvPOK() won't be true. */ assert(caret_X); assert(SvPOKp(caret_X)); - prefix_sv = newSVpvn(SvPVX(caret_X), SvCUR(caret_X)); + prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X), + SvUTF8(caret_X)); /* Firstly take off the leading .../ If all else fail we'll do the paths relative to the current directory. */