#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)
{
perl_construct(pTHXx)
{
dVAR;
- PERL_UNUSED_CONTEXT;
+ PERL_UNUSED_ARG(my_perl);
#ifdef MULTIPLICITY
init_interp();
PL_perl_destruct_level = 1;
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;
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_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 */
if (!specialWARN(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);
int ret;
dJMPENV;
- PERL_UNUSED_VAR(my_perl);
+ PERL_UNUSED_ARG(my_perl);
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
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
s = argv[0]+1;
reswitch:
- switch (*s) {
+ switch ((c = *s)) {
case 'C':
#ifndef PERL_STRICT_CR
case '\r':
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;
int ret = 0;
dJMPENV;
- PERL_UNUSED_CONTEXT;
+ PERL_UNUSED_ARG(my_perl);
oldscope = PL_scopestack_ix;
#ifdef VMS
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);
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;
" DEVEL" STRINGIFY(PERL_PATCHNUM)
#endif
" built for %s",
- vstringify(PL_patchlevel),
- ARCHNAME));
+ (void*)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(),
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
/* 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;
}
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, (void*)cpp,
+ cpp_discard_flag, (void*)sv, CPPMINUS);
PL_doextract = FALSE;
#endif
/* .../version/archname if -d .../version/archname */
Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
- libdir,
+ (void*)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,
+ (void*)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,
+ (void*)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, (void *)libdir, *incver);
subdir = S_incpush_if_exists(aTHX_ subdir);
}
}
PL_checkav_save = newAV();
av_push(PL_checkav_save, (SV*)cv);
}
+ else if (paramList == PL_unitcheckav) {
+ /* save PL_unitcheckav for compiler */
+ if (! PL_unitcheckav_save)
+ PL_unitcheckav_save = newAV();
+ av_push(PL_unitcheckav_save, (SV*)cv);
+ }
} else {
if (!PL_madskills)
SAVEFREESV(cv);
if (PL_madskills)
PL_madskills |= 16384;
#endif
- call_list_body(cv);
+ CALL_LIST_BODY(cv);
#ifdef PERL_MAD
if (PL_madskills)
PL_madskills &= ~16384;
"%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"", (void*)atsv);
}
break;
case 1:
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)
{
projects / p5sagit/p5-mst-13.2.git / blobdiff