X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/dcd079400e6b410586048355b9496c6b06ca4f1b..c1939273d48daaa779bfff86aacdcd7106ed3497:/perl.c?ds=sidebyside diff --git a/perl.c b/perl.c index 6b02712..c7e9a90 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, @@ -269,14 +301,14 @@ 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); SvNV(&PL_sv_no); + SvIV(&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 +563,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; @@ -1657,7 +1689,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; @@ -1672,6 +1704,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; @@ -1787,6 +1821,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) forbid_setid('P', -1); PL_preprocess = TRUE; s++; + deprecate("-P"); goto reswitch; case 'S': forbid_setid('S', -1); @@ -1799,56 +1834,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 @@ -1867,85 +1864,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" */ + , 0); - /* break the line before that space */ - - 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) { @@ -1960,14 +1896,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 @@ -2022,8 +1958,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 && @@ -2052,7 +1993,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)) { @@ -2076,6 +2017,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } } + } #ifdef USE_SITECUSTOMIZE if (!minus_f) { @@ -2228,6 +2170,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; @@ -2236,8 +2180,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; @@ -2248,11 +2195,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 @@ -2305,8 +2257,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; @@ -2526,8 +2481,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); @@ -2568,7 +2522,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; @@ -3013,8 +2967,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; @@ -3095,21 +3049,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; @@ -3160,7 +3116,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 { @@ -3209,7 +3165,8 @@ Perl_moreswitches(pTHX_ char *s) 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' */ @@ -3220,8 +3177,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); @@ -3232,12 +3190,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 @@ -4319,7 +4278,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; @@ -4993,7 +4952,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. */