/* perl.c
*
- * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
+ * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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.
*/
/*
- * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
+ * A ship then new they built for him
+ * of mithril and of elven-glass
+ * --from Bilbo's song of EƤrendil
+ *
+ * [p.236 of _The Lord of the Rings_, II/i: "Many Meetings"]
*/
/* This file contains the top-level functions that are used to create, use
static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
-#ifdef IAMSUID
-#ifndef DOSUID
-#define DOSUID
-#endif
-#endif /* IAMSUID */
-
-#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef DOSUID
-#undef DOSUID
-#endif
+# ifdef IAMSUID
+/* Drop scriptname */
+# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ validarg, fdscript, suidscript, linestr_sv, rsfp)
+# else
+/* Drop suidscript */
+# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ validarg, scriptname, fdscript, linestr_sv, rsfp)
+# endif
+#else
+# ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
+/* Drop everything. Heck, don't even try to call it */
+# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) NOOP
+# else
+/* Drop almost everything */
+# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ rsfp)
+# endif
#endif
#define CALL_BODY_EVAL(myop) \
if (PL_op == (myop)) \
- PL_op = Perl_pp_entereval(aTHX); \
+ PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX); \
if (PL_op) \
CALLRUNOPS(aTHX);
#define CALL_BODY_SUB(myop) \
if (PL_op == (myop)) \
- PL_op = Perl_pp_entersub(aTHX); \
+ PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
if (PL_op) \
CALLRUNOPS(aTHX);
#define CALL_LIST_BODY(cv) \
PUSHMARK(PL_stack_sp); \
- call_sv((SV*)(cv), G_EVAL|G_DISCARD);
+ call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD);
static void
S_init_tls_and_interp(PerlInterpreter *my_perl)
Perl_sys_init(int* argc, char*** argv)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SYS_INIT;
+
PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
PERL_UNUSED_ARG(argv);
PERL_SYS_INIT_BODY(argc, argv);
Perl_sys_init3(int* argc, char*** argv, char*** env)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SYS_INIT3;
+
PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
PERL_UNUSED_ARG(argv);
PERL_UNUSED_ARG(env);
}
void
-Perl_sys_term(pTHX)
+Perl_sys_term()
{
dVAR;
if (!PL_veto_cleanup) {
struct IPerlProc* ipP)
{
PerlInterpreter *my_perl;
+
+ PERL_ARGS_ASSERT_PERL_ALLOC_USING;
+
/* Newx() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
S_init_tls_and_interp(my_perl);
perl_construct(pTHXx)
{
dVAR;
- PERL_UNUSED_ARG(my_perl);
+
+ PERL_ARGS_ASSERT_PERL_CONSTRUCT;
+
#ifdef MULTIPLICITY
init_interp();
PL_perl_destruct_level = 1;
#else
+ PERL_UNUSED_ARG(my_perl);
if (PL_perl_destruct_level > 0)
init_interp();
#endif
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;
PL_fdpid = newAV(); /* for remembering popen pids by fd */
PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
PL_errors = newSVpvs("");
- sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
- sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
- sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
+ sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
+ sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
+ sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
#ifdef USE_ITHREADS
- /* First entry is an array of empty elements */
- Perl_av_create_and_push(aTHX_ &PL_regex_padav,(SV*)newAV());
+ /* First entry is a list of empty elements. It needs to be initialised
+ else all hell breaks loose in S_find_uninit_var(). */
+ Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
PL_regex_pad = AvARRAY(PL_regex_padav);
#endif
#ifdef USE_REENTRANT_API
int returned_errno;
unsigned char buffer[256];
+ PERL_ARGS_ASSERT_DUMP_SV_CHILD;
+
if(sock == -1 || debug_fd == -1)
return;
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;
#endif
+ PERL_ARGS_ASSERT_PERL_DESTRUCT;
+#ifndef MULTIPLICITY
PERL_UNUSED_ARG(my_perl);
+#endif
/* wait for all pseudo-forked children to finish */
PERL_WAIT_FOR_CHILDREN;
int f;
const char *where;
/* Our success message is an integer 0, and a char 0 */
- static const char success[sizeof(int) + 1];
+ static const char success[sizeof(int) + 1] = {0};
close(fd[0]);
* 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;
#endif
- SvREFCNT_dec((SV*) PL_stashcache);
+ SvREFCNT_dec(MUTABLE_SV(PL_stashcache));
PL_stashcache = NULL;
/* loosen bonds of global variables */
}
/* switches */
- PL_preprocess = FALSE;
PL_minus_n = FALSE;
PL_minus_p = FALSE;
PL_minus_l = FALSE;
/* magical thingies */
- SvREFCNT_dec(PL_ofs_sv); /* $, */
- PL_ofs_sv = NULL;
+ SvREFCNT_dec(PL_ofsgv); /* *, */
+ PL_ofsgv = NULL;
SvREFCNT_dec(PL_ors_sv); /* $\ */
PL_ors_sv = NULL;
}
/* Now absolutely destruct everything, somehow or other, loops or no. */
- SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
- SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
/* the 2 is for PL_fdpid and PL_strtab */
- while (PL_sv_count > 2 && sv_clean_all())
+ while (sv_clean_all() > 2)
;
- SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
- SvFLAGS(PL_fdpid) |= SVt_PVAV;
- SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
- SvFLAGS(PL_strtab) |= SVt_PVHV;
-
AvREAL_off(PL_fdpid); /* no surviving entries */
SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
PL_fdpid = NULL;
SV* sv;
register SV* svend;
- for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
+ for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
svend = &sva[SvREFCNT(sva)];
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) != SVTYPEMASK) {
" 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",
}
#endif
#endif
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+ if (PL_sv_count)
+ abort();
+#endif
PL_sv_count = 0;
#ifdef PERL_DEBUG_READONLY_OPS
{
dVAR;
+ PERL_ARGS_ASSERT_PERL_FREE;
+
if (PL_veto_cleanup)
return;
*/
const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
if (!s || atoi(s) == 0) {
+ const U32 old_debug = PL_debug;
/* Emulate the PerlHost behaviour of free()ing all memory allocated in this
thread at thread exit. */
+ if (DEBUG_m_TEST) {
+ PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
+ "free this thread's memory\n");
+ PL_debug &= ~ DEBUG_m_FLAG;
+ }
while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
+ PL_debug = old_debug;
}
}
#endif
int ret;
dJMPENV;
+ PERL_ARGS_ASSERT_PERL_PARSE;
+#ifndef MULTIPLICITY
PERL_UNUSED_ARG(my_perl);
+#endif
-#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
-#ifdef IAMSUID
-#undef IAMSUID
- Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
-setuid perl scripts securely.\n");
-#endif /* IAMSUID */
+#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW_AND_IAMSUID
+ Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now "
+ "execute\nsetuid perl scripts securely.\n");
#endif
#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
char **argv = PL_origargv;
const char *scriptname = NULL;
VOL bool dosearch = FALSE;
+#ifdef DOSUID
const char *validarg = "";
+#endif
register SV *sv;
register char c;
const char *cddir = NULL;
bool add_read_e_script = FALSE;
SvGROW(linestr_sv, 80);
- sv_setpvn(linestr_sv,"",0);
+ sv_setpvs(linestr_sv,"");
sv = newSVpvs(""); /* first used for -I flags */
SAVEFREESV(sv);
if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
break;
#endif
- forbid_setid('e', -1);
+ forbid_setid('e', FALSE);
if (!PL_e_script) {
PL_e_script = newSVpvs("");
add_read_e_script = TRUE;
goto reswitch;
case 'I': /* -I handled both here and in moreswitches() */
- forbid_setid('I', -1);
+ forbid_setid('I', FALSE);
if (!*++s && (s=argv[1]) != NULL) {
argc--,argv++;
}
else
Perl_croak(aTHX_ "No directory specified for -I");
break;
- case 'P':
- forbid_setid('P', -1);
- PL_preprocess = TRUE;
- s++;
- deprecate("-P");
- goto reswitch;
case 'S':
- forbid_setid('S', -1);
+ forbid_setid('S', FALSE);
dosearch = TRUE;
s++;
goto reswitch;
# ifdef PERL_MEM_LOG_TIMESTAMP
" PERL_MEM_LOG_TIMESTAMP"
# endif
+# ifdef PERL_USE_DEVEL
+ " PERL_USE_DEVEL"
+# endif
# ifdef PERL_USE_SAFE_PUTENV
" PERL_USE_SAFE_PUTENV"
# endif
# ifdef USE_SITECUSTOMIZE
" USE_SITECUSTOMIZE"
# endif
+# ifdef USE_FAST_STDIO
+ " USE_FAST_STDIO"
+# endif
, 0);
sv_catpv(opts_prog, PL_bincompat_options);
"\" Built under %s\\n",OSNAME);
#ifdef __DATE__
# ifdef __TIME__
- Perl_sv_catpvf(aTHX_ opts_prog,
- " Compiled at %s %s\\n\"",__DATE__,
- __TIME__);
+ sv_catpvs(opts_prog,
+ " Compiled at " __DATE__ " " __TIME__ "\\n\"");
# else
- Perl_sv_catpvf(aTHX_ opts_prog," Compiled on %s\\n\"",
- __DATE__);
+ sv_catpvs(opts_prog, " Compiled on " __DATE__ "\\n\"");
# endif
#endif
sv_catpvs(opts_prog, "; $\"=\"\\n \"; "
#endif
(s = PerlEnv_getenv("PERL5OPT")))
{
- const char *popt = s;
while (isSPACE(*s))
s++;
if (*s == '-' && *(s+1) == 'T') {
else {
char *popt_copy = NULL;
while (s && *s) {
- char *d;
+ const char *d;
while (isSPACE(*s))
s++;
if (*s == '-') {
while (++s && *s) {
if (isSPACE(*s)) {
if (!popt_copy) {
- popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
- s = popt_copy + (s - popt);
- d = popt_copy + (d - popt);
+ popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
+ s = popt_copy + (s - d);
+ d = popt_copy;
}
*s++ = '\0';
break;
init_perllib();
{
- int suidscript;
- const int fdscript
- = open_script(scriptname, dosearch, sv, &suidscript, &rsfp);
+ bool suidscript = FALSE;
+
+#ifdef DOSUID
+ const int fdscript =
+#endif
+ open_script(scriptname, dosearch, &suidscript, &rsfp);
validate_suid(validarg, scriptname, fdscript, suidscript,
linestr_sv, rsfp);
#endif
) {
- /* This will croak if suidscript is >= 0, as -x cannot be used with
+ /* This will croak if suidscript is true, as -x cannot be used with
setuid scripts. */
forbid_setid('x', suidscript);
- /* Hence you can't get here if suidscript >= 0 */
+ /* Hence you can't get here if suidscript is true */
find_beginning(linestr_sv, rsfp);
if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
}
}
- PL_main_cv = PL_compcv = (CV*)newSV_type(SVt_PVCV);
+ PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
CvUNIQUE_on(PL_compcv);
CvPADLIST(PL_compcv) = pad_new(0);
U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
if (in) {
if (out)
- sv_setpvn(sv, ":utf8\0:utf8", 11);
+ sv_setpvs(sv, ":utf8\0:utf8");
else
- sv_setpvn(sv, ":utf8\0", 6);
+ sv_setpvs(sv, ":utf8\0");
}
else if (out)
- sv_setpvn(sv, "\0:utf8", 6);
+ sv_setpvs(sv, "\0:utf8");
SvSETMAGIC(sv);
}
}
#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;
int ret = 0;
dJMPENV;
+ PERL_ARGS_ASSERT_PERL_RUN;
+#ifndef MULTIPLICITY
PERL_UNUSED_ARG(my_perl);
+#endif
oldscope = PL_scopestack_ix;
#ifdef VMS
if (!DEBUG_q_TEST)
PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
#endif
- DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
- PTR2UV(thr)));
if (PL_minus_c) {
#ifdef MACOS_TRADITIONAL
Perl_get_sv(pTHX_ const char *name, I32 create)
{
GV *gv;
+
+ PERL_ARGS_ASSERT_GET_SV;
+
gv = gv_fetchpv(name, create, SVt_PV);
if (gv)
return GvSV(gv);
Perl_get_av(pTHX_ const char *name, I32 create)
{
GV* const gv = gv_fetchpv(name, create, SVt_PVAV);
+
+ PERL_ARGS_ASSERT_GET_AV;
+
if (create)
return GvAVn(gv);
if (gv)
Perl_get_hv(pTHX_ const char *name, I32 create)
{
GV* const gv = gv_fetchpv(name, create, SVt_PVHV);
+
+ PERL_ARGS_ASSERT_GET_HV;
+
if (create)
return GvHVn(gv);
if (gv)
/* 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! */
+
+ PERL_ARGS_ASSERT_GET_CVN_FLAGS;
+
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);
CV*
Perl_get_cv(pTHX_ const char *name, I32 flags)
{
+ PERL_ARGS_ASSERT_GET_CV;
+
return get_cvn_flags(name, strlen(name), flags);
}
dVAR;
dSP;
+ PERL_ARGS_ASSERT_CALL_ARGV;
+
PUSHMARK(SP);
if (argv) {
while (*argv) {
- XPUSHs(sv_2mortal(newSVpv(*argv,0)));
+ mXPUSHs(newSVpv(*argv,0));
argv++;
}
PUTBACK;
/* name of the subroutine */
/* See G_* flags in cop.h */
{
- return call_sv((SV*)get_cv(sub_name, TRUE), flags);
+ PERL_ARGS_ASSERT_CALL_PV;
+
+ return call_sv(MUTABLE_SV(get_cv(sub_name, TRUE)), flags);
}
/*
/* name of the subroutine */
/* See G_* flags in cop.h */
{
+ PERL_ARGS_ASSERT_CALL_METHOD;
+
return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
}
*/
I32
-Perl_call_sv(pTHX_ SV *sv, I32 flags)
+Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
/* See G_* flags in cop.h */
{
dVAR; dSP;
OP* const oldop = PL_op;
dJMPENV;
+ PERL_ARGS_ASSERT_CALL_SV;
+
if (flags & G_DISCARD) {
ENTER;
SAVETMPS;
}
+ if (!(flags & G_WANT)) {
+ /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
+ */
+ flags |= G_SCALAR;
+ }
Zero(&myop, 1, LOGOP);
myop.op_next = NULL;
if (!(flags & G_NOARGS))
myop.op_flags |= OPf_STACKED;
- myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
- (flags & G_ARRAY) ? OPf_WANT_LIST :
- OPf_WANT_SCALAR);
+ myop.op_flags |= OP_GIMME_REVERSE(flags);
SAVEOP();
PL_op = (OP*)&myop;
&& (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
/* Try harder, since this may have been a sighandler, thus
* curstash may be meaningless. */
- && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
+ && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
&& !(flags & G_NODEBUG))
PL_op->op_private |= OPpENTERSUB_DB;
Zero(&method_op, 1, UNOP);
method_op.op_next = PL_op;
method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
+ method_op.op_type = OP_METHOD;
myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
+ myop.op_type = OP_ENTERSUB;
PL_op = (OP*)&method_op;
}
redo_body:
CALL_BODY_SUB((OP*)&myop);
retval = PL_stack_sp - (PL_stack_base + oldmark);
- if (!(flags & G_KEEPERR))
- sv_setpvn(ERRSV,"",0);
+ if (!(flags & G_KEEPERR)) {
+ CLEAR_ERRSV();
+ }
break;
case 1:
STATUS_ALL_FAILURE;
goto redo_body;
}
PL_stack_sp = PL_stack_base + oldmark;
- if (flags & G_ARRAY)
+ if ((flags & G_WANT) == G_ARRAY)
retval = 0;
else {
retval = 1;
OP* const oldop = PL_op;
dJMPENV;
+ PERL_ARGS_ASSERT_EVAL_SV;
+
if (flags & G_DISCARD) {
ENTER;
SAVETMPS;
myop.op_flags = OPf_STACKED;
myop.op_next = NULL;
myop.op_type = OP_ENTEREVAL;
- myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
- (flags & G_ARRAY) ? OPf_WANT_LIST :
- OPf_WANT_SCALAR);
+ myop.op_flags |= OP_GIMME_REVERSE(flags);
if (flags & G_KEEPERR)
myop.op_flags |= OPf_SPECIAL;
redo_body:
CALL_BODY_EVAL((OP*)&myop);
retval = PL_stack_sp - (PL_stack_base + oldmark);
- if (!(flags & G_KEEPERR))
- sv_setpvn(ERRSV,"",0);
+ if (!(flags & G_KEEPERR)) {
+ CLEAR_ERRSV();
+ }
break;
case 1:
STATUS_ALL_FAILURE;
goto redo_body;
}
PL_stack_sp = PL_stack_base + oldmark;
- if (flags & G_ARRAY)
+ if ((flags & G_WANT) == G_ARRAY)
retval = 0;
else {
retval = 1;
dSP;
SV* sv = newSVpv(p, 0);
+ PERL_ARGS_ASSERT_EVAL_PV;
+
eval_sv(sv, G_SCALAR);
SvREFCNT_dec(sv);
PUTBACK;
if (croak_on_error && SvTRUE(ERRSV)) {
- Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV));
+ Perl_croak(aTHX_ "%s", SvPVx_nolen_const(ERRSV));
}
return sv;
dVAR;
dSP;
SV* sv;
+
+ PERL_ARGS_ASSERT_REQUIRE_PV;
+
PUSHSTACKi(PERLSI_REQUIRE);
PUTBACK;
sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
POPSTACK;
}
-void
-Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
-{
- register GV * const gv = gv_fetchpv(sym, GV_ADD, SVt_PV);
-
- if (gv)
- sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
-}
-
STATIC void
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",
};
const char * const *p = usage_msg;
+ PERL_ARGS_ASSERT_USAGE;
+
PerlIO_printf(PerlIO_stdout(),
"\nUsage: %s [switches] [--] [programfile] [arguments]",
name);
" t Trace execution",
" o Method and overloading resolution",
" c String/numeric conversions",
- " P Print profiling info, preprocessor command for -P, source file input state",
- " m Memory allocation",
+ " P Print profiling info, source file input state",
+ " m Memory and SV allocation",
" f Format processing",
" r Regular expression parsing and execution",
" x Syntax tree dump",
" H Hash dump -- usurps values()",
" X Scratchpad allocation",
" D Cleaning up",
- " S Thread synchronization",
" T Tokenising",
" R Include reference counts of dumped variables (eg when using -Ds)",
" J Do not s,t,P-debug (Jump over) opcodes within package DB",
NULL
};
int i = 0;
+
+ PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
+
if (isALPHA(**s)) {
/* if adding extra options, remember to update DEBUG_MASK */
static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAq";
{
dVAR;
UV rschar;
+ const char option = *s; /* used to remember option in -m/-M code */
+
+ PERL_ARGS_ASSERT_MORESWITCHES;
switch (*s) {
case '0':
s++;
return s;
case 'd':
- forbid_setid('d', -1);
+ forbid_setid('d', FALSE);
s++;
/* -dt indicates to the debugger that threads will be used */
case 'D':
{
#ifdef DEBUGGING
- forbid_setid('D', -1);
+ forbid_setid('D', FALSE);
s++;
PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
#else /* !DEBUGGING */
}
return s;
case 'I': /* -I handled both here and in parse_body() */
- forbid_setid('I', -1);
+ forbid_setid('I', FALSE);
++s;
while (*s && isSPACE(*s))
++s;
}
return s;
case 'M':
- forbid_setid('M', -1); /* XXX ? */
+ forbid_setid('M', FALSE); /* XXX ? */
/* FALL THROUGH */
case 'm':
- forbid_setid('m', -1); /* XXX ? */
+ forbid_setid('m', FALSE); /* XXX ? */
if (*++s) {
const char *start;
const char *end;
SV *sv;
const char *use = "use ";
+ bool colon = FALSE;
/* -M-foo == 'no foo' */
/* Leading space on " no " is deliberate, to make both
possibilities the same length. */
sv = newSVpvn(use,4);
start = s;
/* We allow -M'Module qw(Foo Bar)' */
- while(isALNUM(*s) || *s==':') ++s;
+ while(isALNUM(*s) || *s==':') {
+ if( *s++ == ':' ) {
+ if( *s == ':' )
+ s++;
+ else
+ colon = TRUE;
+ }
+ }
+ if (s == start)
+ Perl_croak(aTHX_ "Module name required with -%c option",
+ option);
+ if (colon)
+ Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
+ "contains single ':'",
+ (int)(s - start), start, option);
end = s + strlen(s);
if (*s != '=') {
sv_catpvn(sv, start, end - start);
- if (*(start-1) == 'm') {
+ if (option == 'm') {
if (*s != '\0')
Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
sv_catpvs( sv, " ()");
}
} else {
- if (s == start)
- Perl_croak(aTHX_ "Module name required with -%c option",
- s[-1]);
sv_catpvn(sv, start, s-start);
/* Use NUL as q''-delimiter. */
sv_catpvs(sv, " split(/,/,q\0");
Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
}
else
- Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
+ Perl_croak(aTHX_ "Missing argument to -%c", option);
return s;
case 'n':
PL_minus_n = TRUE;
s++;
return s;
case 's':
- forbid_setid('s', -1);
+ forbid_setid('s', FALSE);
PL_doswitches = TRUE;
s++;
return s;
upg_version(PL_patchlevel, TRUE);
#if !defined(DGUX)
PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ "\nThis is perl, %"SVf
+ "\nThis is perl, %"SVf
#ifdef PERL_PATCHNUM
- " DEVEL" STRINGIFY(PERL_PATCHNUM)
+ " DEVEL" STRINGIFY(PERL_PATCHNUM)
#endif
- " built for %s",
- SVfARG(vstringify(PL_patchlevel)),
- ARCHNAME));
+ " built for %s",
+ 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(),
#endif
PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2007, Larry Wall\n");
+ "\n\nCopyright 1987-2008, Larry Wall\n");
#ifdef MACOS_TRADITIONAL
PerlIO_printf(PerlIO_stdout(),
"\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
return s;
case '*':
case ' ':
- if (s[1] == '-') /* Additional switches on #! line. */
- return s+2;
+ while( *s == ' ' )
+ ++s;
+ if (s[0] == '-') /* Additional switches on #! line. */
+ return s+1;
break;
case '-':
case 0:
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);
}
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_simple(PL_defstash);
+ GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
SvREADONLY_on(gv);
PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
SVt_PVAV)));
gv_SVadd(PL_errgv);
#endif
sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
- sv_setpvn(ERRSV, "", 0);
+ CLEAR_ERRSV();
PL_curstash = PL_defstash;
CopSTASH_set(&PL_compiling, PL_defstash);
PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
SVt_PVHV));
/* We must init $/ before switches are processed. */
- sv_setpvn(get_sv("/", TRUE), "\n", 1);
+ sv_setpvs(get_sv("/", TRUE), "\n");
}
STATIC int
-S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
- int *suidscript, PerlIO **rsfpp)
+S_open_script(pTHX_ const char *scriptname, bool dosearch,
+ bool *suidscript, PerlIO **rsfpp)
{
-#ifndef IAMSUID
- const char *quote;
- const char *code;
- const char *cpp_discard_flag;
- const char *perl;
-#endif
int fdscript = -1;
dVAR;
- *suidscript = -1;
+ PERL_ARGS_ASSERT_OPEN_SCRIPT;
if (PL_e_script) {
PL_origfilename = savepvs("-e");
* Is it a mistake to use a similar /dev/fd/ construct for
* suidperl?
*/
- *suidscript = 1;
+ *suidscript = TRUE;
/* PSz 20 Feb 04
* Be supersafe and do some sanity-checks.
* Still, can we be sure we got the right thing?
* perl with that fd as it has always done.
*/
}
- if (*suidscript != 1) {
+ if (*suidscript) {
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();
}
#endif /* IAMSUID */
+#ifdef DOSUID
STATIC void
-S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
- int fdscript, int suidscript, SV *linestr_sv, PerlIO *rsfp)
+S_validate_suid(pTHX_ const char *validarg,
+# ifndef IAMSUID
+ const char *scriptname,
+# endif
+ int fdscript,
+# ifdef IAMSUID
+ bool suidscript,
+# endif
+ SV *linestr_sv, PerlIO *rsfp)
{
dVAR;
-#ifdef IAMSUID
- /* int which; */
-#endif /* IAMSUID */
+ const char *s, *s2;
+
+ PERL_ARGS_ASSERT_VALIDATE_SUID;
/* do we need to emulate setuid on scripts? */
* Configure script will set this up for you if you want it.
*/
-#ifdef DOSUID
- const char *s, *s2;
-
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)) {
const char *s_end;
# ifdef IAMSUID
- if (fdscript < 0 || suidscript != 1)
+ if (fdscript < 0 || !suidscript)
Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
/* PSz 11 Nov 03
* Since the script is opened by perl, not suidperl, some of these
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");
- else if (fdscript < 0 || suidscript != 1)
+ else if (fdscript < 0 || !suidscript)
/* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
else {
/* PSz 11 Nov 03
* Keep original arguments: suidperl already has fd script.
*/
-/* for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ; */
-/* if (!PL_origargv[which]) { */
-/* errno = EPERM; */
-/* Perl_croak(aTHX_ "Permission denied\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)
fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
# endif
PERL_FPU_POST_EXEC
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) */
+
# ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
- PERL_UNUSED_ARG(rsfp);
+/* Don't even need this function. */
# else
+STATIC void
+S_validate_suid(pTHX_ PerlIO *rsfp)
+{
+ PERL_ARGS_ASSERT_VALIDATE_SUID;
+
+ if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
+# ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
+ dVAR;
+
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)
||
# 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);
}
+# endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
+#endif /* DOSUID */
STATIC void
S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
int maclines = 0;
#endif
+ PERL_ARGS_ASSERT_FIND_BEGINNING;
+
/* skip forward in input to the real script? */
#ifdef MACOS_TRADITIONAL
"program input from stdin", which is substituted in place of '\0', which
could never be a command line flag. */
STATIC void
-S_forbid_setid(pTHX_ const char flag, const int suidscript)
+S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
{
dVAR;
char string[3] = "-x";
*
* Also see comments about root running a setuid script, elsewhere.
*/
- if (suidscript >= 0)
+ if (suidscript)
Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
#ifdef IAMSUID
/* PSz 11 Nov 03 Catch it in suidperl, always! */
GV *tmpgv;
IO *io;
- sv_setpvn(get_sv("\"", TRUE), " ", 1);
+ sv_setpvs(get_sv("\"", TRUE), " ");
+ PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
+
PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
GvMULTI_on(PL_stdingv);
io = GvIOp(PL_stdingv);
IoIFP(io) = PerlIO_stdin();
tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
GvMULTI_on(tmpgv);
- GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
+ GvIOp(tmpgv) = MUTABLE_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_simple(io);
+ GvIOp(tmpgv) = MUTABLE_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_simple(io);
+ GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
PL_statname = newSV(0); /* last filename we did stat on */
Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
{
dVAR;
+
+ PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
+
argc--,argv++; /* skip name of script */
if (PL_doswitches) {
for (; argc > 0 && **argv == '-'; argc--,argv++) {
dVAR;
GV* tmpgv;
+ PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
+
PL_toptarget = newSV_type(SVt_PVFM);
- sv_setpvn(PL_toptarget, "", 0);
+ sv_setpvs(PL_toptarget, "");
PL_bodytarget = newSV_type(SVt_PVFM);
- sv_setpvn(PL_bodytarget, "", 0);
+ sv_setpvs(PL_bodytarget, "");
PL_formtarget = PL_bodytarget;
TAINT;
sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
#else
sv_setpv(GvSV(tmpgv),PL_origfilename);
- magicname("0", "0", 1);
+ {
+ GV * const gv = gv_fetchpv("0", GV_ADD, SVt_PV);
+ if (gv)
+ sv_magic(GvSV(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, "0", 1);
+ }
#endif
}
if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
environ[0] = NULL;
}
if (env) {
- char *s;
+ char *s, *old_var;
SV *sv;
for (; *env; env++) {
- if (!(s = strchr(*env,'=')) || s == *env)
+ old_var = *env;
+
+ if (!(s = strchr(old_var,'=')) || s == old_var)
continue;
+
#if defined(MSDOS) && !defined(DJGPP)
*s = '\0';
- (void)strupr(*env);
+ (void)strupr(old_var);
*s = '=';
#endif
sv = newSVpv(s+1, 0);
- (void)hv_store(hv, *env, s - *env, sv, 0);
+ (void)hv_store(hv, old_var, s - old_var, sv, 0);
if (env_is_not_environ)
mg_set(sv);
}
# endif
#endif
-#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
+#if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
+ /* Search for version-specific dirs below here */
incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
#endif
{
dVAR;
Stat_t tmpstatbuf;
+
+ PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
+
if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode)) {
av_push(GvAVn(PL_incgv), dir);
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. */
int ret;
dJMPENV;
+ PERL_ARGS_ASSERT_CALL_LIST;
+
while (av_len(paramList) >= 0) {
- cv = (CV*)av_shift(paramList);
+ cv = MUTABLE_CV(av_shift(paramList));
if (PL_savebegin) {
if (paramList == PL_beginav) {
/* save PL_beginav for compiler */
- Perl_av_create_and_push(aTHX_ &PL_beginav_save, (SV*)cv);
+ Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
}
else if (paramList == PL_checkav) {
/* save PL_checkav for compiler */
- Perl_av_create_and_push(aTHX_ &PL_checkav_save, (SV*)cv);
+ Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
}
else if (paramList == PL_unitcheckav) {
/* save PL_unitcheckav for compiler */
- Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, (SV*)cv);
+ Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
}
} else {
if (!PL_madskills)
Perl_my_exit(pTHX_ U32 status)
{
dVAR;
- DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
- (void*)thr, (unsigned long) status));
switch (status) {
case 0:
STATUS_ALL_SUCCESS;