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);
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
int returned_errno;
unsigned char buffer[256];
+ PERL_ARGS_ASSERT_DUMP_SV_CHILD;
+
if(sock == -1 || debug_fd == -1)
return;
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;
}
/* 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;
{
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_AND_IAMSUID
Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now "
#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;
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_flags(name, len, flags & SVf_UTF8);
return newSUB(start_subparse(FALSE, 0),
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) {
/* name of the subroutine */
/* See G_* flags in cop.h */
{
+ PERL_ARGS_ASSERT_CALL_PV;
+
return call_sv((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;
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;
OP* const oldop = PL_op;
dJMPENV;
+ PERL_ARGS_ASSERT_EVAL_SV;
+
if (flags & G_DISCARD) {
ENTER;
SAVETMPS;
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;
dSP;
SV* sv = newSVpv(p, 0);
+ PERL_ARGS_ASSERT_EVAL_PV;
+
eval_sv(sv, G_SCALAR);
SvREFCNT_dec(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);
{
register GV * const gv = gv_fetchpv(sym, GV_ADD, SVt_PV);
+ PERL_ARGS_ASSERT_MAGICNAME;
+
if (gv)
sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
}
};
const char * const *p = usage_msg;
+ PERL_ARGS_ASSERT_USAGE;
+
PerlIO_printf(PerlIO_stdout(),
"\nUsage: %s [switches] [--] [programfile] [arguments]",
name);
" 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':
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;
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));
int fdscript = -1;
dVAR;
+ PERL_ARGS_ASSERT_OPEN_SCRIPT;
+
if (PL_e_script) {
PL_origfilename = savepvs("-e");
}
dVAR;
const char *s, *s2;
+ PERL_ARGS_ASSERT_VALIDATE_SUID;
+
/* do we need to emulate setuid on scripts? */
/* This code is for those BSD systems that have setuid #! scripts disabled
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)
||
int maclines = 0;
#endif
+ PERL_ARGS_ASSERT_FIND_BEGINNING;
+
/* skip forward in input to the real script? */
#ifdef MACOS_TRADITIONAL
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);
PL_bodytarget = newSV_type(SVt_PVFM);
{
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);
int ret;
dJMPENV;
+ PERL_ARGS_ASSERT_CALL_LIST;
+
while (av_len(paramList) >= 0) {
cv = (CV*)av_shift(paramList);
if (PL_savebegin) {
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;