/* 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);
}
}
PL_Dir = ipD;
PL_Sock = ipS;
PL_Proc = ipP;
+ INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
return my_perl;
}
my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
S_init_tls_and_interp(my_perl);
+#ifndef PERL_TRACK_MEMPOOL
return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
+#else
+ Zero(my_perl, 1, PerlInterpreter);
+ INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
+ return my_perl;
+#endif
}
#endif /* PERL_IMPLICIT_SYS */
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
if ((long) PL_mmap_page_size < 0) {
if (errno) {
SV * const error = ERRSV;
- (void) SvUPGRADE(error, SVt_PV);
+ SvUPGRADE(error, SVt_PV);
Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
}
else
PL_timesbase.tms_cstime = 0;
#endif
+#ifdef PERL_MAD
+ PL_curforce = -1;
+#endif
+
ENTER;
}
int
Perl_nothreadhook(pTHX)
{
+ PERL_UNUSED_CONTEXT;
return 0;
}
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;
if (CALL_FPTR(PL_threadhook)(aTHX)) {
/* Threads hook has vetoed further cleanup */
+ PL_veto_cleanup = TRUE;
return STATUS_EXIT;
}
PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
}
op_free(PL_main_root);
- PL_main_root = Nullop;
+ PL_main_root = NULL;
}
- PL_main_start = Nullop;
+ PL_main_start = NULL;
SvREFCNT_dec(PL_main_cv);
PL_main_cv = NULL;
PL_dirty = TRUE;
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);
if(PL_rsfp) {
(void)PerlIO_close(PL_rsfp);
- PL_rsfp = Nullfp;
+ PL_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;
PL_minus_n = FALSE;
SvREFCNT_dec(PL_rs); /* $/ */
PL_rs = NULL;
- PL_multiline = 0; /* $* */
Safefree(PL_osname); /* $^O */
PL_osname = NULL;
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_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_hash);
+ PL_compiling.cop_hints_hash = NULL;
CopFILE_free(&PL_compiling);
CopSTASH_free(&PL_compiling);
" 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",
sv_free_arenas();
+ while (PL_regmatch_slab) {
+ regmatch_slab *s = PL_regmatch_slab;
+ PL_regmatch_slab = PL_regmatch_slab->next;
+ Safefree(s);
+ }
+
/* As the absolutely last thing, free the non-arena SV for mess() */
if (PL_mess_sv) {
void
perl_free(pTHXx)
{
+ dVAR;
+
+ if (PL_veto_cleanup)
+ return;
+
+#ifdef PERL_TRACK_MEMPOOL
+ {
+ /*
+ * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
+ * value as we're probably hunting memory leaks then
+ */
+ const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
+ if (!s || atoi(s) == 0) {
+ /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
+ thread at thread exit. */
+ while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
+ safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
+ }
+ }
+#endif
+
#if defined(WIN32) || defined(NETWARE)
# if defined(PERL_IMPLICIT_SYS)
+ {
# ifdef NETWARE
- void *host = nw_internal_host;
+ void *host = nw_internal_host;
# else
- void *host = w32_internal_host;
+ void *host = w32_internal_host;
# endif
- PerlMem_free(aTHXx);
+ PerlMem_free(aTHXx);
# ifdef NETWARE
- nw_delete_internal_host(host);
+ nw_delete_internal_host(host);
# else
- win32_delete_internal_host(host);
+ win32_delete_internal_host(host);
# endif
+ }
# else
PerlMem_free(aTHXx);
# endif
#endif
}
-#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
+#if defined(USE_ITHREADS)
/* provide destructors to clean up the thread key when libperl is unloaded */
#ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
-#if defined(__hpux) && __ux_version > 1020 && !defined(__GNUC__)
+#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
}
/* 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 ((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
if (PL_main_root) {
op_free(PL_main_root);
- PL_main_root = Nullop;
+ PL_main_root = NULL;
}
- PL_main_start = Nullop;
+ PL_main_start = NULL;
SvREFCNT_dec(PL_main_cv);
PL_main_cv = NULL;
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;
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
- int fdscript;
- int suidscript = -1;
sv_setpvn(PL_linestr,"",0);
sv = newSVpvs(""); /* first used for -I flags */
#endif
s = argv[0]+1;
reswitch:
- switch (*s) {
+ switch ((c = *s)) {
case 'C':
#ifndef PERL_STRICT_CR
case '\r':
case 'X':
case 'w':
case 'A':
- if ((s = moreswitches(s, suidscript)))
+ if ((s = moreswitches(s)))
goto reswitch;
break;
if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
break;
#endif
- forbid_setid('e', suidscript);
+ forbid_setid('e', -1);
if (!PL_e_script) {
PL_e_script = newSVpvs("");
filter_add(read_e_script, NULL);
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;
goto reswitch;
case 'I': /* -I handled both here and in moreswitches() */
- forbid_setid('I', suidscript);
+ forbid_setid('I', -1);
if (!*++s && (s=argv[1]) != NULL) {
argc--,argv++;
}
Perl_croak(aTHX_ "No directory specified for -I");
break;
case 'P':
- forbid_setid('P', suidscript);
+ forbid_setid('P', -1);
PL_preprocess = TRUE;
s++;
goto reswitch;
case 'S':
- forbid_setid('S', suidscript);
+ forbid_setid('S', -1);
dosearch = TRUE;
s++;
goto reswitch;
{
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;
# ifdef PERL_IMPLICIT_SYS
" PERL_IMPLICIT_SYS"
# endif
+# ifdef PERL_MAD
+ " PERL_MAD"
+# endif
# ifdef PERL_MALLOC_WRAP
" PERL_MALLOC_WRAP"
# endif
# ifdef THREADS_HAVE_PIDS
" THREADS_HAVE_PIDS"
# endif
-# ifdef USE_5005THREADS
- " USE_5005THREADS"
-# endif
# ifdef USE_64_BIT_ALL
" USE_64_BIT_ALL"
# endif
PL_tainting = TRUE;
}
} else {
- moreswitches(d, suidscript);
+ moreswitches(d);
}
}
}
#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) {
else if (scriptname == NULL) {
#ifdef MSDOS
if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
- moreswitches("h", suidscript);
+ moreswitches("h");
#endif
scriptname = "-";
}
TAINT_NOT;
init_perllib();
- fdscript = open_script(scriptname, dosearch, sv, &suidscript);
+ {
+ int suidscript;
+ const int fdscript
+ = open_script(scriptname, dosearch, sv, &suidscript);
- validate_suid(validarg, scriptname, fdscript, suidscript);
+ validate_suid(validarg, scriptname, fdscript, suidscript);
#ifndef PERL_MICRO
-#if defined(SIGCHLD) || defined(SIGCLD)
- {
-#ifndef SIGCHLD
-# define SIGCHLD SIGCLD
-#endif
- Sighandler_t sigstate = rsignal_state(SIGCHLD);
- if (sigstate == (Sighandler_t) SIG_IGN) {
- if (ckWARN(WARN_SIGNAL))
- Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
- "Can't ignore signal CHLD, forcing to default");
- (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
+# if defined(SIGCHLD) || defined(SIGCLD)
+ {
+# ifndef SIGCHLD
+# define SIGCHLD SIGCLD
+# endif
+ Sighandler_t sigstate = rsignal_state(SIGCHLD);
+ if (sigstate == (Sighandler_t) SIG_IGN) {
+ if (ckWARN(WARN_SIGNAL))
+ Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
+ "Can't ignore signal CHLD, forcing to default");
+ (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
+ }
}
- }
-#endif
+# endif
#endif
+ if (PL_doextract
#ifdef MACOS_TRADITIONAL
- if (PL_doextract || gMacPerl_AlwaysExtract) {
-#else
- if (PL_doextract) {
+ || gMacPerl_AlwaysExtract
#endif
- find_beginning(suidscript);
- if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
- Perl_croak(aTHX_ "Can't chdir to %s",cddir);
+ ) {
+ /* This will croak if suidscript is >= 0, as -x cannot be used with
+ setuid scripts. */
+ forbid_setid('x', suidscript);
+ /* Hence you can't get here if suidscript >= 0 */
+
+ find_beginning();
+ if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
+ Perl_croak(aTHX_ "Can't chdir to %s",cddir);
+ }
}
PL_main_cv = PL_compcv = (CV*)newSV(0);
CvUNIQUE_on(PL_compcv);
CvPADLIST(PL_compcv) = pad_new(0);
-#ifdef USE_5005THREADS
- CvOWNER(PL_compcv) = 0;
- Newx(CvMUTEXP(PL_compcv), 1, perl_mutex);
- MUTEX_INIT(CvMUTEXP(PL_compcv));
-#endif /* USE_5005THREADS */
boot_core_PerlIO();
boot_core_UNIVERSAL();
Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
}
+#ifdef PERL_MAD
+ if ((s = PerlEnv_getenv("PERL_XMLDUMP"))) {
+ PL_madskills = 1;
+ PL_minus_c = 1;
+ if (!s || !s[0])
+ PL_xmlfp = PerlIO_stdout();
+ else {
+ PL_xmlfp = PerlIO_open(s, "w");
+ if (!PL_xmlfp)
+ Perl_croak(aTHX_ "Can't open %s", s);
+ }
+ my_setenv("PERL_XMLDUMP", Nullch); /* hide from subprocs */
+ }
+ if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
+ PL_madskills = atoi(s);
+ my_setenv("PERL_MADSKILLS", Nullch); /* hide from subprocs */
+ }
+#endif
+
init_lexer();
/* now parse the script */
PL_sawampersand ? "Enabling" : "Omitting"));
if (!PL_restartop) {
+#ifdef PERL_MAD
+ if (PL_xmlfp) {
+ xmldump_all();
+ exit(0); /* less likely to core dump than my_exit(0) */
+ }
+#endif
DEBUG_x(dump_all());
#ifdef DEBUGGING
if (!DEBUG_q_TEST)
Perl_get_sv(pTHX_ const char *name, I32 create)
{
GV *gv;
-#ifdef USE_5005THREADS
- if (name[1] == '\0' && !isALPHA(name[0])) {
- PADOFFSET tmp = find_threadsv(name);
- if (tmp != NOT_IN_PAD)
- return THREADSV(tmp);
- }
-#endif /* USE_5005THREADS */
gv = gv_fetchpv(name, create, SVt_PV);
if (gv)
return GvSV(gv);
/*
=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)),
- Nullop,
- Nullop);
+ 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;
}
Zero(&myop, 1, LOGOP);
- myop.op_next = Nullop;
+ myop.op_next = NULL;
if (!(flags & G_NOARGS))
myop.op_flags |= OPf_STACKED;
myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
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);
}
else {
myop.op_other = (OP*)&myop;
PL_markstack_ptr--;
- /* we're trying to emulate pp_entertry() here */
- {
- register PERL_CONTEXT *cx;
- const I32 gimme = GIMME_V;
-
- ENTER;
- SAVETMPS;
-
- PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
- PUSHEVAL(cx, 0, 0);
- PL_eval_root = PL_op; /* Only needed so that goto works right. */
-
- PL_in_eval = EVAL_INEVAL;
- if (flags & G_KEEPERR)
- PL_in_eval |= EVAL_KEEPERR;
- else
- sv_setpvn(ERRSV,"",0);
- }
+ create_eval_scope(flags|G_FAKINGEVAL);
PL_markstack_ptr++;
JMPENV_PUSH(ret);
+
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);
break;
}
- if (PL_scopestack_ix > oldscope) {
- SV **newsp;
- PMOP *newpm;
- I32 gimme;
- register PERL_CONTEXT *cx;
- I32 optype;
-
- POPBLOCK(cx,newpm);
- POPEVAL(cx);
- PL_curpm = newpm;
- LEAVE;
- PERL_UNUSED_VAR(newsp);
- PERL_UNUSED_VAR(gimme);
- PERL_UNUSED_VAR(optype);
- }
+ if (PL_scopestack_ix > oldscope)
+ delete_eval_scope();
JMPENV_POP;
}
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;
if (!(flags & G_NOARGS))
myop.op_flags = OPf_STACKED;
- myop.op_next = Nullop;
+ myop.op_next = NULL;
myop.op_type = OP_ENTEREVAL;
myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
(flags & G_ARRAY) ? OPf_WANT_LIST :
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);
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);
/* This routine handles any switches that can be given during run */
char *
-Perl_moreswitches(pTHX_ char *s, const int suidscript)
+Perl_moreswitches(pTHX_ char *s)
{
dVAR;
UV rschar;
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;
PL_splitstr = ++s;
while (*s && !isSPACE(*s)) ++s;
- *s = '\0';
- PL_splitstr = savepv(PL_splitstr);
+ PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
return s;
case 'a':
PL_minus_a = TRUE;
s++;
return s;
case 'd':
- forbid_setid('d', suidscript);
+ forbid_setid('d', -1);
s++;
/* -dt indicates to the debugger that threads will be used */
sv_catpv(sv, start);
else {
sv_catpvn(sv, start, s-start);
- Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0);
+ /* 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);
my_setenv("PERL5DB", SvPV_nolen_const(sv));
case 'D':
{
#ifdef DEBUGGING
- forbid_setid('D', suidscript);
+ forbid_setid('D', -1);
s++;
PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
#else /* !DEBUGGING */
return s+1;
}
#endif /* __CYGWIN__ */
- PL_inplace = savepv(s+1);
- for (s = PL_inplace; *s && !isSPACE(*s); s++)
- ;
+ {
+ const char * const start = ++s;
+ while (*s && !isSPACE(*s))
+ ++s;
+
+ PL_inplace = savepvn(start, s - start);
+ }
if (*s) {
- *s++ = '\0';
+ ++s;
if (*s == '-') /* Additional switches on #! line. */
- s++;
+ s++;
}
return s;
case 'I': /* -I handled both here and in parse_body() */
- forbid_setid('I', suidscript);
+ forbid_setid('I', -1);
++s;
while (*s && isSPACE(*s))
++s;
}
return s;
case 'A':
- forbid_setid('A', suidscript);
- if (!PL_preambleav)
- PL_preambleav = newAV();
+ forbid_setid('A', -1);
s++;
{
char * const start = 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);
+ Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
return s;
}
case 'M':
- forbid_setid('M', suidscript); /* XXX ? */
+ forbid_setid('M', -1); /* XXX ? */
/* FALL THROUGH */
case 'm':
- forbid_setid('m', suidscript); /* XXX ? */
+ forbid_setid('m', -1); /* XXX ? */
if (*++s) {
char *start;
SV *sv;
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));
s++;
return s;
case 's':
- forbid_setid('s', suidscript);
+ forbid_setid('s', -1);
PL_doswitches = TRUE;
s++;
return s;
" 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;
void
Perl_my_unexec(pTHX)
{
+ PERL_UNUSED_CONTEXT;
#ifdef UNEXEC
- SV* prog;
- SV* file;
+ SV * prog = newSVpv(BIN_EXP, 0);
+ SV * file = newSVpv(PL_origfilename, 0);
int status = 1;
extern int etext;
- prog = newSVpv(BIN_EXP, 0);
sv_catpvs(prog, "/perl");
- file = newSVpv(PL_origfilename, 0);
sv_catpvs(file, ".perldump");
unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
# define PERLVAR(var,type)
# define PERLVARA(var,n,type)
# if defined(PERL_IMPLICIT_CONTEXT)
-# if defined(USE_5005THREADS)
-# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
-# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
-# else /* !USE_5005THREADS */
-# define PERLVARI(var,type,init) aTHX->var = init;
-# define PERLVARIC(var,type,init) aTHX->var = init;
-# endif /* USE_5005THREADS */
+# define PERLVARI(var,type,init) aTHX->var = init;
+# define PERLVARIC(var,type,init) aTHX->var = init;
# else
# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
# endif
# include "intrpvar.h"
-# ifndef USE_5005THREADS
-# include "thrdvar.h"
-# endif
+# 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"
-# ifndef USE_5005THREADS
-# include "thrdvar.h"
-# endif
+# include "thrdvar.h"
# undef PERLVAR
# undef PERLVARA
# undef PERLVARI
# undef PERLVARIC
#endif
+ /* As these are inside a structure, PERLVARI isn't capable of initialising
+ them */
+ PL_reg_oldcurpm = PL_reg_curpm = NULL;
+ PL_reg_poscache = PL_reg_starttry = NULL;
}
STATIC void
of the SvREFCNT_dec, only to add it again with hv_name_set */
SvREFCNT_dec(GvHV(gv));
hv_name_set(PL_defstash, "main", 4, 0);
- GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
+ GvHV(gv) = (HV*)SvREFCNT_inc_simple(PL_defstash);
SvREADONLY_on(gv);
PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
SVt_PVAV)));
- SvREFCNT_inc(PL_incgv); /* Don't allow it to be freed */
+ SvREFCNT_inc_simple(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(PL_defgv);
+ SvREFCNT_inc_simple(PL_defgv);
PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
- SvREFCNT_inc(PL_errgv);
+ SvREFCNT_inc_simple(PL_errgv);
GvMULTI_on(PL_errgv);
PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
GvMULTI_on(PL_replgv);
sv_setpvn(get_sv("/", TRUE), "\n", 1);
}
-/* PSz 18 Nov 03 fdscript now global but do not change prototype */
STATIC int
S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
int *suidscript)
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;
Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
#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 */
/* not set-id, must be wrapped */
}
#endif /* DOSUID */
- (void)validarg;
- (void)scriptname;
+ PERL_UNUSED_ARG(validarg);
+ PERL_UNUSED_ARG(scriptname);
}
STATIC void
-S_find_beginning(pTHX_ const int suidscript)
+S_find_beginning(pTHX)
{
dVAR;
register char *s;
/* skip forward in input to the real script? */
- forbid_setid('x', suidscript);
#ifdef MACOS_TRADITIONAL
/* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
|| s2[-1] == '_') s2--;
if (strnEQ(s2-4,"perl",4))
- while ((s = moreswitches(s, suidscript)))
+ while ((s = moreswitches(s)))
;
}
#ifdef MACOS_TRADITIONAL
dVAR;
PerlIO *tmpfp;
tmpfp = PL_rsfp;
- PL_rsfp = Nullfp;
+ PL_rsfp = NULL;
lex_start(PL_linestr);
PL_rsfp = tmpfp;
PL_subname = newSVpvs("main");
IoIFP(io) = PerlIO_stdin();
tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
GvMULTI_on(tmpgv);
- GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
+ GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
GvMULTI_on(tmpgv);
setdefout(tmpgv);
tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
GvMULTI_on(tmpgv);
- GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
+ GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
GvMULTI_on(PL_stderrgv);
IoOFP(io) = IoIFP(io) = PerlIO_stderr();
tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
GvMULTI_on(tmpgv);
- GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
+ GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
PL_statname = newSV(0); /* last filename we did stat on */
}
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
#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 */
# endif
#endif
-#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
+#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
+ /* Search for version-specific dirs below here */
incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
#endif
#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);
}
}
}
}
-#ifdef USE_5005THREADS
-STATIC struct perl_thread *
-S_init_main_thread(pTHX)
-{
-#if !defined(PERL_IMPLICIT_CONTEXT)
- struct perl_thread *thr;
-#endif
- XPV *xpv;
-
- Newxz(thr, 1, struct perl_thread);
- PL_curcop = &PL_compiling;
- thr->interp = PERL_GET_INTERP;
- thr->cvcache = newHV();
- thr->threadsv = newAV();
- /* thr->threadsvp is set when find_threadsv is called */
- thr->specific = newAV();
- thr->flags = THRf_R_JOINABLE;
- MUTEX_INIT(&thr->mutex);
- /* Handcraft thrsv similarly to mess_sv */
- Newx(PL_thrsv, 1, SV);
- Newxz(xpv, 1, XPV);
- SvFLAGS(PL_thrsv) = SVt_PV;
- SvANY(PL_thrsv) = (void*)xpv;
- SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
- SvPV_set(PL_thrsvr, (char*)thr);
- SvCUR_set(PL_thrsv, sizeof(thr));
- SvLEN_set(PL_thrsv, sizeof(thr));
- *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
- thr->oursv = PL_thrsv;
- PL_chopset = " \n-";
- PL_dumpindent = 4;
-
- MUTEX_LOCK(&PL_threads_mutex);
- PL_nthreads++;
- thr->tid = 0;
- thr->next = thr;
- thr->prev = thr;
- thr->thr_done = 0;
- MUTEX_UNLOCK(&PL_threads_mutex);
-
-#ifdef HAVE_THREAD_INTERN
- Perl_init_thread_intern(thr);
-#endif
-
-#ifdef SET_THREAD_SELF
- SET_THREAD_SELF(thr);
-#else
- thr->self = pthread_self();
-#endif /* SET_THREAD_SELF */
- PERL_SET_THX(thr);
-
- /*
- * These must come after the thread self setting
- * because sv_setpvn does SvTAINT and the taint
- * fields thread selfness being set.
- */
- PL_toptarget = newSV(0);
- sv_upgrade(PL_toptarget, SVt_PVFM);
- sv_setpvn(PL_toptarget, "", 0);
- PL_bodytarget = newSV(0);
- sv_upgrade(PL_bodytarget, SVt_PVFM);
- sv_setpvn(PL_bodytarget, "", 0);
- PL_formtarget = PL_bodytarget;
- thr->errsv = newSVpvs("");
- (void) find_threadsv("@"); /* Ensure $@ is initialised early */
-
- PL_maxscream = -1;
- PL_peepp = MEMBER_TO_FPTR(Perl_peep);
- PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
- PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
- PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
- PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
- PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
- PL_regindent = 0;
- PL_reginterp_cnt = 0;
-
- return thr;
-}
-#endif /* USE_5005THREADS */
void
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
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 {
- SAVEFREESV(cv);
+ if (!PL_madskills)
+ SAVEFREESV(cv);
}
JMPENV_PUSH(ret);
switch (ret) {
case 0:
- call_list_body(cv);
+#ifdef PERL_MAD
+ if (PL_madskills)
+ PL_madskills |= 16384;
+#endif
+ 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;
S_my_exit_jump(pTHX)
{
dVAR;
- register PERL_CONTEXT *cx;
- I32 gimme;
- SV **newsp;
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
}
POPSTACK_TO(PL_mainstack);
- if (cxstack_ix >= 0) {
- if (cxstack_ix > 0)
- dounwind(0);
- POPBLOCK(cx,PL_curpm);
- LEAVE;
- }
+ dounwind(-1);
+ LEAVE_SCOPE(0);
JMPENV_JUMP(2);
- PERL_UNUSED_VAR(gimme);
- PERL_UNUSED_VAR(newsp);
}
static I32
https://perl5.git.perl.org / perl5.git / blobdiff