/* perl.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#endif
#endif
+#define CALL_BODY_EVAL(myop) \
+ if (PL_op == (myop)) \
+ PL_op = Perl_pp_entereval(aTHX); \
+ if (PL_op) \
+ CALLRUNOPS(aTHX);
+
+#define CALL_BODY_SUB(myop) \
+ if (PL_op == (myop)) \
+ PL_op = Perl_pp_entersub(aTHX); \
+ if (PL_op) \
+ CALLRUNOPS(aTHX);
+
+#define CALL_LIST_BODY(cv) \
+ PUSHMARK(PL_stack_sp); \
+ call_sv((SV*)(cv), G_EVAL|G_DISCARD);
+
static void
S_init_tls_and_interp(PerlInterpreter *my_perl)
{
ALLOC_THREAD_KEY;
PERL_SET_THX(my_perl);
OP_REFCNT_INIT;
+ HINTS_REFCNT_INIT;
MUTEX_INIT(&PL_dollarzero_mutex);
# endif
#ifdef PERL_IMPLICIT_CONTEXT
MUTEX_INIT(&PL_my_ctx_mutex);
# endif
}
- else {
+#if defined(USE_ITHREADS)
+ else
+#else
+ /* This always happens for non-ithreads */
+#endif
+ {
PERL_SET_THX(my_perl);
}
}
+
+/* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */
+
+void
+Perl_sys_init(int* argc, char*** argv)
+{
+ 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)
+{
+ 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(pTHX)
+{
+ if (!PL_veto_cleanup) {
+ PERL_SYS_TERM_BODY();
+ }
+}
+
+
#ifdef PERL_IMPLICIT_SYS
PerlInterpreter *
perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
perl_construct(pTHXx)
{
dVAR;
- PERL_UNUSED_CONTEXT;
+ PERL_UNUSED_ARG(my_perl);
#ifdef MULTIPLICITY
init_interp();
PL_perl_destruct_level = 1;
if (PL_perl_destruct_level > 0)
init_interp();
#endif
- /* Init the real globals (and main thread)? */
- if (!PL_linestr) {
- PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
-
- PL_linestr = newSV(79);
- sv_upgrade(PL_linestr,SVt_PVIV);
+ PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
- if (!SvREADONLY(&PL_sv_undef)) {
- /* set read-only and try to insure than we wont see REFCNT==0
- very often */
+ /* set read-only and try to insure than we wont see REFCNT==0
+ very often */
- SvREADONLY_on(&PL_sv_undef);
- SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
+ SvREADONLY_on(&PL_sv_undef);
+ SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
- 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);
- SvREADONLY_on(&PL_sv_no);
- SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
+ 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);
+ 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);
- SvREADONLY_on(&PL_sv_yes);
- SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
+ sv_setpv(&PL_sv_yes,PL_Yes);
+ SvIV(&PL_sv_yes);
+ SvNV(&PL_sv_yes);
+ SvREADONLY_on(&PL_sv_yes);
+ SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
- SvREADONLY_on(&PL_sv_placeholder);
- SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
- }
+ SvREADONLY_on(&PL_sv_placeholder);
+ SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
- PL_sighandlerp = (Sighandler_t) Perl_sighandler;
+ PL_sighandlerp = (Sighandler_t) Perl_sighandler;
#ifdef PERL_USES_PL_PIDSTATUS
- PL_pidstatus = newHV();
+ PL_pidstatus = newHV();
#endif
- }
PL_rs = newSVpvs("\n");
init_stacks();
init_ids();
- PL_lex_state = LEX_NOTPARSING;
JMPENV_BOOTSTRAP;
STATUS_ALL_SUCCESS;
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 */
+ /* First entry is an array of empty elements */
+ Perl_av_create_and_push(aTHX_ &PL_regex_padav,(SV*)newAV());
PL_regex_pad = AvARRAY(PL_regex_padav);
#endif
#ifdef USE_REENTRANT_API
PL_stashcache = newHV();
- PL_patchlevel = Perl_newSVpvf(aTHX_ "%d.%d.%d", (int)PERL_REVISION,
+ PL_patchlevel = Perl_newSVpvf(aTHX_ "v%d.%d.%d", (int)PERL_REVISION,
(int)PERL_VERSION, (int)PERL_SUBVERSION);
#ifdef HAS_MMAP
PL_timesbase.tms_cstime = 0;
#endif
-#ifdef PERL_MAD
- PL_curforce = -1;
-#endif
-
ENTER;
}
it to dump out to. We can't let it hold open the file descriptor when it
forks, as the file descriptor it will dump to can turn out to be one end
of pipe that some other process will wait on for EOF. (So as it would
- be open, the wait would be forever. */
+ be open, the wait would be forever.) */
msg.msg_control = control.control;
msg.msg_controllen = sizeof(control.control);
perl_destruct(pTHXx)
{
dVAR;
- volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
+ VOL int destruct_level; /* 0=none, 1=full, 2=full with checks */
HV *hv;
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
pid_t child;
#endif
- PERL_UNUSED_CONTEXT;
+ PERL_UNUSED_ARG(my_perl);
/* wait for all pseudo-forked children to finish */
PERL_WAIT_FOR_CHILDREN;
if (CALL_FPTR(PL_threadhook)(aTHX)) {
/* Threads hook has vetoed further cleanup */
+ PL_veto_cleanup = TRUE;
return STATUS_EXIT;
}
PL_exitlist = NULL;
PL_exitlistlen = 0;
- if (destruct_level == 0){
-
- DEBUG_P(debprofdump());
-
-#if defined(PERLIO_LAYERS)
- /* No more IO - including error messages ! */
- PerlIO_cleanup(aTHX);
-#endif
-
- /* The exit() function will do everything that needs doing. */
- return STATUS_EXIT;
- }
-
/* jettison our possibly duplicated environment */
/* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
* so we certainly shouldn't free it here
#endif
#endif /* !PERL_MICRO */
+ if (destruct_level == 0) {
+
+ DEBUG_P(debprofdump());
+
+#if defined(PERLIO_LAYERS)
+ /* No more IO - including error messages ! */
+ PerlIO_cleanup(aTHX);
+#endif
+
+ CopFILE_free(&PL_compiling);
+ CopSTASH_free(&PL_compiling);
+
+ /* The exit() function will do everything that needs doing. */
+ return STATUS_EXIT;
+ }
+
/* reset so print() ends up where we expect */
setdefout(NULL);
/* loosen bonds of global variables */
- if(PL_rsfp) {
- (void)PerlIO_close(PL_rsfp);
- PL_rsfp = NULL;
+ /* XXX can PL_parser still be non-null here? */
+ if(PL_parser && PL_parser->rsfp) {
+ (void)PerlIO_close(PL_parser->rsfp);
+ PL_parser->rsfp = NULL;
}
- /* Filters for program text */
- SvREFCNT_dec(PL_rsfp_filters);
- PL_rsfp_filters = NULL;
+ if (PL_minus_F) {
+ Safefree(PL_splitstr);
+ PL_splitstr = NULL;
+ }
/* switches */
PL_preprocess = FALSE;
SvREFCNT_dec(PL_endav);
SvREFCNT_dec(PL_checkav);
SvREFCNT_dec(PL_checkav_save);
+ SvREFCNT_dec(PL_unitcheckav);
+ SvREFCNT_dec(PL_unitcheckav_save);
SvREFCNT_dec(PL_initav);
PL_beginav = NULL;
PL_beginav_save = NULL;
PL_endav = NULL;
PL_checkav = NULL;
PL_checkav_save = NULL;
+ PL_unitcheckav = NULL;
+ PL_unitcheckav_save = NULL;
PL_initav = NULL;
/* shortcuts just get cleared */
PL_DBsingle = NULL;
PL_DBtrace = NULL;
PL_DBsignal = NULL;
- PL_DBassertion = NULL;
PL_DBcv = NULL;
PL_dbargs = NULL;
PL_debstash = NULL;
PL_preambleav = NULL;
SvREFCNT_dec(PL_subname);
PL_subname = NULL;
- SvREFCNT_dec(PL_linestr);
- PL_linestr = NULL;
#ifdef PERL_USES_PL_PIDSTATUS
SvREFCNT_dec(PL_pidstatus);
PL_pidstatus = NULL;
PL_utf8_idcont = NULL;
if (!specialWARN(PL_compiling.cop_warnings))
- SvREFCNT_dec(PL_compiling.cop_warnings);
+ PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = NULL;
- if (!specialCopIO(PL_compiling.cop_io))
- SvREFCNT_dec(PL_compiling.cop_io);
- PL_compiling.cop_io = NULL;
- Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints);
- PL_compiling.cop_hints = NULL;
+ Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
+ PL_compiling.cop_hints_hash = NULL;
CopFILE_free(&PL_compiling);
CopSTASH_free(&PL_compiling);
SvREFCNT_dec(PL_errors);
PL_errors = NULL;
+ SvREFCNT_dec(PL_isarev);
+
FREETMPS;
if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
if (PL_scopestack_ix != 0)
" flags=0x%"UVxf
" refcnt=%"UVuf pTHX__FORMAT "\n"
"\tallocated at %s:%d %s %s%s\n",
- sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE,
+ (void*)sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE,
sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
sv->sv_debug_line,
sv->sv_debug_inpad ? "for" : "by",
#endif
PL_sv_count = 0;
+#ifdef PERL_DEBUG_READONLY_OPS
+ free(PL_slabs);
+ PL_slabs = NULL;
+ PL_slab_count = 0;
+#endif
#if defined(PERLIO_LAYERS)
/* No more IO - including error messages ! */
void
perl_free(pTHXx)
{
+ dVAR;
+
+ if (PL_veto_cleanup)
+ return;
+
#ifdef PERL_TRACK_MEMPOOL
{
/*
#if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
#pragma fini "perl_fini"
+#elif defined(__sun) && !defined(__GNUC__)
+#pragma fini (perl_fini)
#endif
static void
perl_fini(void)
{
dVAR;
- if (PL_curinterp)
+ if (PL_curinterp && !PL_veto_cleanup)
FREE_THREAD_KEY;
}
int ret;
dJMPENV;
- PERL_UNUSED_VAR(my_perl);
+ PERL_UNUSED_ARG(my_perl);
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
break;
}
}
+
+#ifndef PERL_USE_SAFE_PUTENV
/* Can we grab env area too to be used as the area for $0? */
- if (s && PL_origenviron) {
- if ((PL_origenviron[0] == s + 1
-#ifdef OS2
- || (PL_origenviron[0] == s + 9 && (s += 8))
-#endif
- )
+ if (s && PL_origenviron && !PL_use_safe_putenv) {
+ if ((PL_origenviron[0] == s + 1)
||
(aligned &&
(PL_origenviron[0] > s &&
INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
)
{
-#ifndef OS2
+#ifndef OS2 /* ENVIRON is read by the kernel too. */
s = PL_origenviron[0];
while (*s) s++;
#endif
}
}
}
+#endif /* !defined(PERL_USE_SAFE_PUTENV) */
+
PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
}
switch (ret) {
case 0:
parse_body(env,xsinit);
+ if (PL_unitcheckav)
+ call_list(oldscope, PL_unitcheckav);
if (PL_checkav)
call_list(oldscope, PL_checkav);
ret = 0;
LEAVE;
FREETMPS;
PL_curstash = PL_defstash;
+ if (PL_unitcheckav)
+ call_list(oldscope, PL_unitcheckav);
if (PL_checkav)
call_list(oldscope, PL_checkav);
ret = STATUS_EXIT;
S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
{
dVAR;
+ PerlIO *rsfp;
int argc = PL_origargc;
char **argv = PL_origargv;
const char *scriptname = NULL;
VOL bool dosearch = FALSE;
const char *validarg = "";
register SV *sv;
- register char *s;
+ register char *s, c;
const char *cddir = NULL;
#ifdef USE_SITECUSTOMIZE
bool minus_f = FALSE;
#endif
+ SV *linestr_sv = newSV_type(SVt_PVIV);
+ bool add_read_e_script = FALSE;
+
+ SvGROW(linestr_sv, 80);
+ sv_setpvn(linestr_sv,"",0);
- sv_setpvn(PL_linestr,"",0);
sv = newSVpvs(""); /* first used for -I flags */
SAVEFREESV(sv);
init_main_stash();
#endif
s = argv[0]+1;
reswitch:
- switch (*s) {
+ switch ((c = *s)) {
case 'C':
#ifndef PERL_STRICT_CR
case '\r':
case 'W':
case 'X':
case 'w':
- case 'A':
if ((s = moreswitches(s)))
goto reswitch;
break;
forbid_setid('e', -1);
if (!PL_e_script) {
PL_e_script = newSVpvs("");
- filter_add(read_e_script, NULL);
+ add_read_e_script = TRUE;
}
if (*++s)
sv_catpv(PL_e_script, s);
argc--,argv++;
}
else
- Perl_croak(aTHX_ "No code specified for -%c", *s);
+ Perl_croak(aTHX_ "No code specified for -%c", c);
sv_catpvs(PL_e_script, "\n");
break;
forbid_setid('P', -1);
PL_preprocess = TRUE;
s++;
+ deprecate("-P");
goto reswitch;
case 'S':
forbid_setid('S', -1);
{
SV *opts_prog;
- if (!PL_preambleav)
- PL_preambleav = newAV();
- av_push(PL_preambleav,
- newSVpvs("use Config;"));
+ 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_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
-# ifdef PERL_NEED_APPCTX
- " PERL_NEED_APPCTX"
+# ifdef PERL_MEM_LOG
+ " PERL_MEM_LOG"
# endif
-# ifdef PERL_NEED_TIMESBASE
- " PERL_NEED_TIMESBASE"
+# ifdef PERL_MEM_LOG_ENV
+ " PERL_MEM_LOG_ENV"
# endif
-# ifdef PERL_OLD_COPY_ON_WRITE
- " PERL_OLD_COPY_ON_WRITE"
+# ifdef PERL_MEM_LOG_ENV_FD
+ " PERL_MEM_LOG_ENV_FD"
# endif
-# ifdef PERL_TRACK_MEMPOOL
- " PERL_TRACK_MEMPOOL"
+# ifdef PERL_MEM_LOG_STDERR
+ " PERL_MEM_LOG_STDERR"
+# endif
+# ifdef PERL_MEM_LOG_TIMESTAMP
+ " PERL_MEM_LOG_TIMESTAMP"
# 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
- */
+ , 0);
- 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 */
-
- 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) {
}
#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
#ifdef USE_SITECUSTOMIZE
if (!minus_f) {
- if (!PL_preambleav)
- PL_preambleav = newAV();
- av_unshift(PL_preambleav, 1);
- (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
+ (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
+ Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
}
#endif
- 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) {
{
int suidscript;
const int fdscript
- = open_script(scriptname, dosearch, sv, &suidscript);
+ = open_script(scriptname, dosearch, sv, &suidscript, &rsfp);
- validate_suid(validarg, scriptname, fdscript, suidscript);
+ validate_suid(validarg, scriptname, fdscript, suidscript,
+ linestr_sv, rsfp);
#ifndef PERL_MICRO
# if defined(SIGCHLD) || defined(SIGCLD)
forbid_setid('x', suidscript);
/* Hence you can't get here if suidscript >= 0 */
- find_beginning();
+ find_beginning(linestr_sv, rsfp);
if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
Perl_croak(aTHX_ "Can't chdir to %s",cddir);
}
}
- PL_main_cv = PL_compcv = (CV*)newSV(0);
- sv_upgrade((SV *)PL_compcv, SVt_PVCV);
+ PL_main_cv = PL_compcv = (CV*)newSV_type(SVt_PVCV);
CvUNIQUE_on(PL_compcv);
CvPADLIST(PL_compcv) = pad_new(0);
+ PL_isarev = newHV();
+
boot_core_PerlIO();
boot_core_UNIVERSAL();
boot_core_xsutils();
+ boot_core_mro();
if (xsinit)
(*xsinit)(aTHX); /* in case linked C routines want magical variables */
}
#endif
- init_lexer();
+ lex_start(linestr_sv, rsfp, TRUE);
+ PL_subname = newSVpvs("main");
+
+ if (add_read_e_script)
+ filter_add(read_e_script, NULL);
/* now parse the script */
SETERRNO(0,SS_NORMAL);
- PL_error_count = 0;
#ifdef MACOS_TRADITIONAL
- if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
+ if (gMacPerl_SyntaxError = (yyparse() || PL_parser->error_count)) {
if (PL_minus_c)
Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
else {
}
}
#else
- if (yyparse() || PL_error_count) {
+ if (yyparse() || PL_parser->error_count) {
if (PL_minus_c)
Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
else {
int ret = 0;
dJMPENV;
- PERL_UNUSED_CONTEXT;
+ PERL_UNUSED_ARG(my_perl);
oldscope = PL_scopestack_ix;
#ifdef VMS
return ret;
}
-
STATIC void
S_run_body(pTHX_ I32 oldscope)
{
sv_setiv(PL_DBsingle, 1);
if (PL_initav)
call_list(oldscope, PL_initav);
+#ifdef PERL_DEBUG_READONLY_OPS
+ Perl_pending_Slabs_to_ro(aTHX);
+#endif
}
/* do it */
/*
=head1 CV Manipulation Functions
+=for apidoc p||get_cvn_flags
+
+Returns the CV of the specified Perl subroutine. C<flags> are passed to
+C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
+exist then it will be declared (which has the same effect as saying
+C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist
+then NULL is returned.
+
=for apidoc p||get_cv
-Returns the CV of the specified Perl subroutine. If C<create> is set and
-the Perl subroutine does not exist then it will be declared (which has the
-same effect as saying C<sub name;>). If C<create> is not set and the
-subroutine does not exist then NULL is returned.
+Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
=cut
*/
CV*
-Perl_get_cv(pTHX_ const char *name, I32 create)
+Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
{
- GV* const gv = gv_fetchpv(name, create, SVt_PVCV);
- /* XXX unsafe for threads if eval_owner isn't held */
+ GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
/* XXX this is probably not what they think they're getting.
* It has the same effect as "sub name;", i.e. just a forward
* declaration! */
- if (create && !GvCVu(gv))
+ if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
+ SV *const sv = newSVpvn(name,len);
+ SvFLAGS(sv) |= flags & SVf_UTF8;
return newSUB(start_subparse(FALSE, 0),
- newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, sv),
NULL, NULL);
+ }
if (gv)
return GvCVu(gv);
return NULL;
}
+CV*
+Perl_get_cv(pTHX_ const char *name, I32 flags)
+{
+ return get_cvn_flags(name, strlen(name), flags);
+}
+
/* Be sure to refetch the stack pointer after calling these routines. */
/*
LOGOP myop; /* fake syntax tree node */
UNOP method_op;
I32 oldmark;
- volatile I32 retval = 0;
+ VOL I32 retval = 0;
I32 oldscope;
bool oldcatch = CATCH_GET;
int ret;
if (!(flags & G_EVAL)) {
CATCH_SET(TRUE);
- call_body((OP*)&myop, FALSE);
+ CALL_BODY_SUB((OP*)&myop);
retval = PL_stack_sp - (PL_stack_base + oldmark);
CATCH_SET(oldcatch);
}
switch (ret) {
case 0:
redo_body:
- call_body((OP*)&myop, FALSE);
+ CALL_BODY_SUB((OP*)&myop);
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR))
sv_setpvn(ERRSV,"",0);
return retval;
}
-STATIC void
-S_call_body(pTHX_ const OP *myop, bool is_eval)
-{
- dVAR;
- if (PL_op == myop) {
- if (is_eval)
- PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
- else
- PL_op = Perl_pp_entersub(aTHX); /* this does */
- }
- if (PL_op)
- CALLRUNOPS(aTHX);
-}
-
/* Eval a string. The G_EVAL flag is always assumed. */
/*
dVAR;
dSP;
UNOP myop; /* fake syntax tree node */
- volatile I32 oldmark = SP - PL_stack_base;
- volatile I32 retval = 0;
+ VOL I32 oldmark = SP - PL_stack_base;
+ VOL I32 retval = 0;
int ret;
OP* const oldop = PL_op;
dJMPENV;
switch (ret) {
case 0:
redo_body:
- call_body((OP*)&myop,TRUE);
+ CALL_BODY_EVAL((OP*)&myop);
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR))
sv_setpvn(ERRSV,"",0);
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)",
int i = 0;
if (isALPHA(**s)) {
/* if adding extra options, remember to update DEBUG_MASK */
- static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
+ static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAq";
for (; isALNUM(**s); (*s)++) {
const char * const d = strchr(debopts,**s);
case 'C':
s++;
PL_unicode = parse_unicode_opts( (const char **)&s );
+ if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
+ PL_utf8cache = -1;
return s;
case 'F':
PL_minus_F = TRUE;
}
s += strlen(s);
my_setenv("PERL5DB", SvPV_nolen_const(sv));
+ SvREFCNT_dec(sv);
}
if (!PL_perldb) {
PL_perldb = PERLDB_ALL;
}
}
return s;
- case 'A':
- forbid_setid('A', -1);
- if (!PL_preambleav)
- PL_preambleav = newAV();
- 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);
- }
- av_push(PL_preambleav, sv);
- return s;
- }
case 'M':
forbid_setid('M', -1); /* XXX ? */
/* FALL THROUGH */
sv_catpvs(sv, "\0)");
}
s += strlen(s);
- if (!PL_preambleav)
- PL_preambleav = newAV();
- av_push(PL_preambleav, sv);
+ Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
}
else
Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
return s;
case 'v':
if (!sv_derived_from(PL_patchlevel, "version"))
- upg_version(PL_patchlevel);
+ upg_version(PL_patchlevel, TRUE);
#if !defined(DGUX)
PerlIO_printf(PerlIO_stdout(),
Perl_form(aTHX_ "\nThis is perl, %"SVf
" DEVEL" STRINGIFY(PERL_PATCHNUM)
#endif
" built for %s",
- vstringify(PL_patchlevel),
- ARCHNAME));
+ SVfARG(vstringify(PL_patchlevel)),
+ ARCHNAME));
#else /* DGUX */
/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
PerlIO_printf(PerlIO_stdout(),
Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
- vstringify(PL_patchlevel)));
+ SVfARG(vstringify(PL_patchlevel))));
PerlIO_printf(PerlIO_stdout(),
Perl_form(aTHX_ " built under %s at %s %s\n",
OSNAME, __DATE__, __TIME__));
PerlIO_printf(PerlIO_stdout(),
"\n(with %d registered patch%s, "
"see perl -V for more detail)",
- (int)LOCAL_PATCH_COUNT,
+ LOCAL_PATCH_COUNT,
(LOCAL_PATCH_COUNT!=1) ? "es" : "");
#endif
PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2006, Larry Wall\n");
+ "\n\nCopyright 1987-2007, Larry Wall\n");
#ifdef MACOS_TRADITIONAL
PerlIO_printf(PerlIO_stdout(),
"\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
my_exit(0);
case 'w':
- if (! (PL_dowarn & G_WARN_ALL_MASK))
+ if (! (PL_dowarn & G_WARN_ALL_MASK)) {
PL_dowarn |= G_WARN_ON;
+ }
s++;
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);
+ PerlMemShared_free(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);
+ PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_NONE ;
s++;
return s;
# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
# endif
# include "intrpvar.h"
-# include "thrdvar.h"
# undef PERLVAR
# undef PERLVARA
# undef PERLVARI
# define PERLVARI(var,type,init) PL_##var = init;
# define PERLVARIC(var,type,init) PL_##var = init;
# include "intrpvar.h"
-# include "thrdvar.h"
# undef PERLVAR
# undef PERLVARA
# undef PERLVARI
/* As these are inside a structure, PERLVARI isn't capable of initialising
them */
- PL_regindent = 0;
PL_reg_oldcurpm = PL_reg_curpm = NULL;
PL_reg_poscache = PL_reg_starttry = NULL;
}
SvREADONLY_on(gv);
PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
SVt_PVAV)));
- SvREFCNT_inc_simple(PL_incgv); /* Don't allow it to be freed */
+ SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
GvMULTI_on(PL_incgv);
PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
GvMULTI_on(PL_hintgv);
PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
- SvREFCNT_inc_simple(PL_defgv);
+ SvREFCNT_inc_simple_void(PL_defgv);
PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
- SvREFCNT_inc_simple(PL_errgv);
+ SvREFCNT_inc_simple_void(PL_errgv);
GvMULTI_on(PL_errgv);
PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
GvMULTI_on(PL_replgv);
STATIC int
S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
- int *suidscript)
+ int *suidscript, PerlIO **rsfpp)
{
#ifndef IAMSUID
const char *quote;
if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
scriptname = (char *)"";
if (fdscript >= 0) {
- PL_rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
+ *rsfpp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
# if defined(HAS_FCNTL) && defined(F_SETFD)
- if (PL_rsfp)
+ if (*rsfpp)
/* ensure close-on-exec */
- fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
+ fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
# endif
}
#ifdef IAMSUID
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);
+ perl, quote, code, quote, scriptname, SVfARG(cpp),
+ cpp_discard_flag, SVfARG(sv), CPPMINUS);
PL_doextract = FALSE;
"PL_preprocess: cmd=\"%s\"\n",
SvPVX_const(cmd)));
- PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
+ *rsfpp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
SvREFCNT_dec(cmd);
SvREFCNT_dec(cpp);
}
else if (!*scriptname) {
forbid_setid(0, *suidscript);
- PL_rsfp = PerlIO_stdin();
+ *rsfpp = PerlIO_stdin();
}
else {
- PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
+#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 (PL_rsfp)
+ if (*rsfpp)
/* ensure close-on-exec */
- fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
+ fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
# endif
}
#endif /* IAMSUID */
- if (!PL_rsfp) {
+ if (!*rsfpp) {
/* PSz 16 Sep 03 Keep neat error message */
if (PL_e_script)
Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
STATIC void
S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
- int fdscript, int suidscript)
+ int fdscript, int suidscript, SV *linestr_sv, PerlIO *rsfp)
{
dVAR;
#ifdef IAMSUID
#ifdef DOSUID
const char *s, *s2;
- if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
+ if (PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
I32 len;
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
/* 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,
* operating systems do not have such mount options anyway...)
* Seems safe enough to do as root.
*/
-#if !defined(NO_NOSUID_CHECK)
- if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
+# 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");
PL_doswitches = FALSE; /* -s is insecure in suid */
/* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
CopLINE_inc(PL_curcop);
- if (sv_gets(PL_linestr, PL_rsfp, 0) == NULL)
+ if (sv_gets(linestr_sv, rsfp, 0) == NULL)
Perl_croak(aTHX_ "No #! line");
- linestr = SvPV_nolen_const(PL_linestr);
+ linestr = SvPV_nolen_const(linestr_sv);
/* required even on Sys V */
if (!*linestr || !linestr[1] || strnNE(linestr,"#!",2))
Perl_croak(aTHX_ "No #! line");
|| ((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 */
* 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.
* in fact will use that to distinguish this from "normal"
* usage, see comments above.
*/
- PerlIO_rewind(PL_rsfp);
- PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
+ PerlIO_rewind(rsfp);
+ PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
/* PSz 27 Feb 04 Sanity checks on scriptname */
if ((!scriptname) || (!*scriptname) ) {
Perl_croak(aTHX_ "No setuid script name\n");
Perl_croak(aTHX_ "Can't change argv to have fd script\n");
}
PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
- PerlIO_fileno(PL_rsfp), PL_origargv[which]));
-#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
-#endif
+ PerlIO_fileno(rsfp), PL_origargv[which]));
+# if defined(HAS_FCNTL) && defined(F_SETFD)
+ fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
+# 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");
}
* 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");
}
if (!cando(S_IXUSR,TRUE,&PL_statbuf))
Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */
}
-#ifdef IAMSUID
+# 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");
else if (fdscript < 0 || suidscript != 1)
* #endif
* into the perly bits.
*/
- PerlIO_rewind(PL_rsfp);
- PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
+ PerlIO_rewind(rsfp);
+ PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
/* PSz 11 Nov 03
* Keep original arguments: suidperl already has fd script.
*/
/* Perl_croak(aTHX_ "Permission denied\n"); */
/* } */
/* PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s", */
-/* PerlIO_fileno(PL_rsfp), PL_origargv[which])); */
-#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
-#endif
+/* PerlIO_fileno(rsfp), PL_origargv[which])); */
+# if defined(HAS_FCNTL) && defined(F_SETFD)
+ fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
+# 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
- PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
+# 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)
||
(PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
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 */
PERL_UNUSED_ARG(validarg);
PERL_UNUSED_ARG(scriptname);
+ PERL_UNUSED_ARG(linestr_sv);
}
STATIC void
-S_find_beginning(pTHX)
+S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
{
dVAR;
register char *s;
/* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
while (PL_doextract || gMacPerl_AlwaysExtract) {
- if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
+ if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) {
if (!gMacPerl_AlwaysExtract)
Perl_croak(aTHX_ "No Perl script found in input\n");
PL_doextract = FALSE;
/* Pater peccavi, file does not have #! */
- PerlIO_rewind(PL_rsfp);
+ PerlIO_rewind(rsfp);
break;
}
#else
while (PL_doextract) {
- if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == NULL)
+ if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
Perl_croak(aTHX_ "No Perl script found in input\n");
#endif
s2 = s;
if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
- PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
+ PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
PL_doextract = FALSE;
while (*s && !(isSPACE (*s) || *s == '#')) s++;
s2 = s;
* by counting lines we already skipped over
*/
for (; maclines > 0 ; maclines--)
- PerlIO_ungetc(PL_rsfp, '\n');
+ PerlIO_ungetc(rsfp, '\n');
break;
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;
}
Safefree(PL_savestack);
}
-STATIC void
-S_init_lexer(pTHX)
-{
- dVAR;
- PerlIO *tmpfp;
- tmpfp = PL_rsfp;
- PL_rsfp = NULL;
- lex_start(PL_linestr);
- PL_rsfp = tmpfp;
- PL_subname = newSVpvs("main");
-}
STATIC void
S_init_predump_symbols(pTHX)
dVAR;
GV* tmpgv;
- PL_toptarget = newSV(0);
- sv_upgrade(PL_toptarget, SVt_PVFM);
+ PL_toptarget = newSV_type(SVt_PVFM);
sv_setpvn(PL_toptarget, "", 0);
- PL_bodytarget = newSV(0);
- sv_upgrade(PL_bodytarget, SVt_PVFM);
+ PL_bodytarget = newSV_type(SVt_PVFM);
sv_setpvn(PL_bodytarget, "", 0);
PL_formtarget = PL_bodytarget;
}
if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
HV *hv;
+ bool env_is_not_environ;
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
hv_magic(hv, NULL, PERL_MAGIC_env);
*/
if (!env)
env = environ;
- if (env != environ
+ env_is_not_environ = env != environ;
+ if (env_is_not_environ
# ifdef USE_ITHREADS
&& PL_curinterp == aTHX
# endif
environ[0] = NULL;
}
if (env) {
- char** origenv = environ;
char *s;
SV *sv;
for (; *env; env++) {
#endif
sv = newSVpv(s+1, 0);
(void)hv_store(hv, *env, s - *env, sv, 0);
- if (env != environ)
+ if (env_is_not_environ)
mg_set(sv);
- if (origenv != environ) {
- /* realloc has shifted us */
- env = (env - origenv) + environ;
- origenv = environ;
- }
}
}
#endif /* USE_ENVIRON_ARRAY */
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
#endif
/* .../version/archname if -d .../version/archname */
Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
- libdir,
+ SVfARG(libdir),
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION, ARCHNAME);
subdir = S_incpush_if_exists(aTHX_ subdir);
/* .../version if -d .../version */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH,
+ SVfARG(libdir),
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION);
subdir = S_incpush_if_exists(aTHX_ subdir);
/* .../archname if -d .../archname */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT,
+ SVfARG(libdir), ARCHNAME);
subdir = S_incpush_if_exists(aTHX_ subdir);
}
if (addoldvers) {
for (incver = incverlist; *incver; incver++) {
/* .../xxx if -d .../xxx */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT,
+ SVfARG(libdir), *incver);
subdir = S_incpush_if_exists(aTHX_ subdir);
}
}
{
dVAR;
SV *atsv;
- const line_t oldline = CopLINE(PL_curcop);
+ volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
CV *cv;
STRLEN len;
int ret;
if (PL_savebegin) {
if (paramList == PL_beginav) {
/* save PL_beginav for compiler */
- if (! PL_beginav_save)
- PL_beginav_save = newAV();
- av_push(PL_beginav_save, (SV*)cv);
+ Perl_av_create_and_push(aTHX_ &PL_beginav_save, (SV*)cv);
}
else if (paramList == PL_checkav) {
/* save PL_checkav for compiler */
- if (! PL_checkav_save)
- PL_checkav_save = newAV();
- av_push(PL_checkav_save, (SV*)cv);
+ Perl_av_create_and_push(aTHX_ &PL_checkav_save, (SV*)cv);
+ }
+ else if (paramList == PL_unitcheckav) {
+ /* save PL_unitcheckav for compiler */
+ Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, (SV*)cv);
}
} else {
if (!PL_madskills)
if (PL_madskills)
PL_madskills |= 16384;
#endif
- call_list_body(cv);
+ CALL_LIST_BODY(cv);
#ifdef PERL_MAD
if (PL_madskills)
PL_madskills &= ~16384;
#endif
atsv = ERRSV;
(void)SvPV_const(atsv, len);
- if (PL_madskills && PL_minus_c && paramList == PL_beginav)
- break; /* not really trying to run, so just wing it */
if (len) {
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
"%s failed--call queue aborted",
paramList == PL_checkav ? "CHECK"
: paramList == PL_initav ? "INIT"
+ : paramList == PL_unitcheckav ? "UNITCHECK"
: "END");
while (PL_scopestack_ix > oldscope)
LEAVE;
JMPENV_POP;
- Perl_croak(aTHX_ "%"SVf"", atsv);
+ Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
}
break;
case 1:
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
JMPENV_POP;
- if (PL_madskills && PL_minus_c && paramList == PL_beginav)
- return; /* not really trying to run, so just wing it */
if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
if (paramList == PL_beginav)
Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
Perl_croak(aTHX_ "%s failed--call queue aborted",
paramList == PL_checkav ? "CHECK"
: paramList == PL_initav ? "INIT"
+ : paramList == PL_unitcheckav ? "UNITCHECK"
: "END");
}
my_exit_jump();
}
}
-STATIC void *
-S_call_list_body(pTHX_ CV *cv)
-{
- dVAR;
- PUSHMARK(PL_stack_sp);
- call_sv((SV*)cv, G_EVAL|G_DISCARD);
- return NULL;
-}
-
void
Perl_my_exit(pTHX_ U32 status)
{
dVAR;
DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
- thr, (unsigned long) status));
+ (void*)thr, (unsigned long) status));
switch (status) {
case 0:
STATUS_ALL_SUCCESS;
https://perl5.git.perl.org / perl5.git / blobdiff