# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ rsfp)
#endif
-#define CALL_BODY_EVAL(myop) \
- if (PL_op == (myop)) \
- PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX); \
- if (PL_op) \
- CALLRUNOPS(aTHX);
-
#define CALL_BODY_SUB(myop) \
if (PL_op == (myop)) \
PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
JMPENV_PUSH(x);
PERL_UNUSED_VAR(x);
- if (PL_endav && !PL_minus_c)
+ if (PL_endav && !PL_minus_c) {
+ PL_phase = PERL_PHASE_END;
call_list(PL_scopestack_ix, PL_endav);
+ }
JMPENV_POP;
}
LEAVE;
/* Need to flush since END blocks can produce output */
my_fflush_all();
- if (CALL_FPTR(PL_threadhook)(aTHX)) {
+ if (PL_threadhook(aTHX)) {
/* Threads hook has vetoed further cleanup */
PL_veto_cleanup = TRUE;
return STATUS_EXIT;
PL_main_root = NULL;
}
PL_main_start = NULL;
+ /* note that PL_main_cv isn't usually actually freed at this point,
+ * due to the CvOUTSIDE refs from subs compiled within it. It will
+ * get freed once all the subs are freed in sv_clean_all(), for
+ * destruct_level > 0 */
SvREFCNT_dec(PL_main_cv);
PL_main_cv = NULL;
- PL_dirty = TRUE;
+ PL_phase = PERL_PHASE_DESTRUCT;
/* Tell PerlIO we are about to tear things apart in case
we have layers which are using resources that should
*/
sv_clean_objs();
PL_sv_objcount = 0;
- if (PL_defoutgv && !SvREFCNT(PL_defoutgv))
- PL_defoutgv = NULL; /* may have been freed */
}
/* unhook hooks which will soon be, or use, destroyed data */
return STATUS_EXIT;
}
- /* reset so print() ends up where we expect */
- setdefout(NULL);
-
#ifdef USE_ITHREADS
/* the syntax tree is shared between clones
* so op_free(PL_main_root) only ReREFCNT_dec's
PL_minus_F = FALSE;
PL_doswitches = FALSE;
PL_dowarn = G_WARN_OFF;
- PL_doextract = FALSE;
PL_sawampersand = FALSE; /* must save all match strings */
PL_unsafe = FALSE;
SvREFCNT_dec(PL_utf8_tofold);
SvREFCNT_dec(PL_utf8_idstart);
SvREFCNT_dec(PL_utf8_idcont);
+ SvREFCNT_dec(PL_utf8_foldclosures);
PL_utf8_alnum = NULL;
PL_utf8_ascii = NULL;
PL_utf8_alpha = NULL;
PL_utf8_tofold = NULL;
PL_utf8_idstart = NULL;
PL_utf8_idcont = NULL;
+ PL_utf8_foldclosures = NULL;
if (!specialWARN(PL_compiling.cop_warnings))
PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = NULL;
- Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
- PL_compiling.cop_hints_hash = NULL;
+ cophh_free(CopHINTHASH_get(&PL_compiling));
+ CopHINTHASH_set(&PL_compiling, cophh_new_empty());
CopFILE_free(&PL_compiling);
CopSTASH_free(&PL_compiling);
/* Prepare to destruct main symbol table. */
hv = PL_defstash;
+ /* break ref loop *:: <=> %:: */
+ (void)hv_delete(hv, "main::", 6, G_DISCARD);
PL_defstash = 0;
SvREFCNT_dec(hv);
SvREFCNT_dec(PL_curstname);
(long)cxstack_ix + 1);
}
+#ifdef PERL_IMPLICIT_CONTEXT
+ /* the entries in this list are allocated via SV PVX's, so get freed
+ * in sv_clean_all */
+ Safefree(PL_my_cxt_list);
+#endif
+
/* Now absolutely destruct everything, somehow or other, loops or no. */
/* the 2 is for PL_fdpid and PL_strtab */
Safefree(PL_psig_name);
PL_psig_name = (SV**)NULL;
PL_psig_ptr = (SV**)NULL;
- Safefree(PL_psig_pend);
- PL_psig_pend = (int*)NULL;
{
/* We need to NULL PL_psig_pend first, so that
signal handlers know not to use it */
switch (ret) {
case 0:
parse_body(env,xsinit);
- if (PL_unitcheckav)
+ if (PL_unitcheckav) {
call_list(oldscope, PL_unitcheckav);
- if (PL_checkav)
+ }
+ if (PL_checkav) {
+ PL_phase = PERL_PHASE_CHECK;
call_list(oldscope, PL_checkav);
+ }
ret = 0;
break;
case 1:
LEAVE;
FREETMPS;
PL_curstash = PL_defstash;
- if (PL_unitcheckav)
+ if (PL_unitcheckav) {
call_list(oldscope, PL_unitcheckav);
- if (PL_checkav)
+ }
+ if (PL_checkav) {
+ PL_phase = PERL_PHASE_CHECK;
call_list(oldscope, PL_checkav);
+ }
ret = STATUS_EXIT;
break;
case 3:
const char *scriptname = NULL;
VOL bool dosearch = FALSE;
register char c;
+ bool doextract = FALSE;
const char *cddir = NULL;
#ifdef USE_SITECUSTOMIZE
bool minus_f = FALSE;
SV *linestr_sv = newSV_type(SVt_PVIV);
bool add_read_e_script = FALSE;
+ PL_phase = PERL_PHASE_START;
+
SvGROW(linestr_sv, 80);
sv_setpvs(linestr_sv,"");
goto reswitch;
}
case 'x':
- PL_doextract = TRUE;
+ doextract = TRUE;
s++;
if (*s)
cddir = s;
# endif
#endif
- if (PL_doextract) {
+ if (doextract) {
/* This will croak if suidscript is true, as -x cannot be used with
setuid scripts. */
}
#endif
- lex_start(linestr_sv, rsfp, TRUE);
+ lex_start(linestr_sv, rsfp, 0);
PL_subname = newSVpvs("main");
if (add_read_e_script)
/* now parse the script */
SETERRNO(0,SS_NORMAL);
- if (yyparse() || PL_parser->error_count) {
+ if (yyparse(GRAMPROG) || PL_parser->error_count) {
if (PL_minus_c)
Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
else {
FREETMPS;
PL_curstash = PL_defstash;
if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
- PL_endav && !PL_minus_c)
+ PL_endav && !PL_minus_c) {
+ PL_phase = PERL_PHASE_END;
call_list(oldscope, PL_endav);
+ }
#ifdef MYMALLOC
if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
}
if (PERLDB_SINGLE && PL_DBsingle)
sv_setiv(PL_DBsingle, 1);
- if (PL_initav)
+ if (PL_initav) {
+ PL_phase = PERL_PHASE_INIT;
call_list(oldscope, PL_initav);
+ }
#ifdef PERL_DEBUG_READONLY_OPS
Perl_pending_Slabs_to_ro(aTHX);
#endif
/* do it */
+ PL_phase = PERL_PHASE_RUN;
+
if (PL_restartop) {
PL_restartjmpenv = NULL;
PL_op = PL_restartop;
/*
=for apidoc p||eval_sv
-Tells Perl to C<eval> the string in the SV.
+Tells Perl to C<eval> the string in the SV. It supports the same flags
+as C<call_sv>, with the obvious exception of G_EVAL. See L<perlcall>.
=cut
*/
switch (ret) {
case 0:
redo_body:
- CALL_BODY_EVAL((OP*)&myop);
+ if (PL_op == (OP*)(&myop)) {
+ PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
+ if (!PL_op)
+ goto fail; /* failed in compilation */
+ }
+ CALLRUNOPS(aTHX);
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR)) {
CLEAR_ERRSV();
PL_restartop = 0;
goto redo_body;
}
+ fail:
PL_stack_sp = PL_stack_base + oldmark;
if ((flags & G_WANT) == G_ARRAY)
retval = 0;
/* The following permits -d:Mod to accepts arguments following an =
in the fashion that -MSome::Mod does. */
if (*s == ':' || *s == '=') {
- const char *start = ++s;
- const char *const end = s + strlen(s);
- SV * const sv = newSVpvs("use Devel::");
+ const char *start;
+ const char *end;
+ SV *sv;
- /* We now allow -d:Module=Foo,Bar */
+ if (*++s == '-') {
+ ++s;
+ sv = newSVpvs("no Devel::");
+ } else {
+ sv = newSVpvs("use Devel::");
+ }
+
+ start = s;
+ end = s + strlen(s);
+
+ /* We now allow -d:Module=Foo,Bar and -d:-Module */
while(isALNUM(*s) || *s==':') ++s;
if (*s != '=')
sv_catpvn(sv, start, end - start);
/* skip forward in input to the real script? */
- while (PL_doextract) {
+ do {
if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
Perl_croak(aTHX_ "No Perl script found in input\n");
s2 = s;
- if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
- PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
- PL_doextract = FALSE;
- while (*s && !(isSPACE (*s) || *s == '#')) s++;
- s2 = s;
- while (*s == ' ' || *s == '\t') s++;
- if (*s++ == '-') {
- while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
- || s2[-1] == '_') s2--;
- if (strnEQ(s2-4,"perl",4))
- while ((s = moreswitches(s)))
- ;
- }
- }
+ } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
+ PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
+ while (*s && !(isSPACE (*s) || *s == '#')) s++;
+ s2 = s;
+ while (*s == ' ' || *s == '\t') s++;
+ if (*s++ == '-') {
+ while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
+ || s2[-1] == '_') s2--;
+ if (strnEQ(s2-4,"perl",4))
+ while ((s = moreswitches(s)))
+ ;
}
}
Safefree(PL_savestack);
}
+void
+Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
+{
+ GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
+ AV *const isa = GvAVn(gv);
+ va_list args;
+
+ PERL_ARGS_ASSERT_POPULATE_ISA;
+
+ if(AvFILLp(isa) != -1)
+ return;
+
+ /* NOTE: No support for tied ISA */
+
+ va_start(args, len);
+ do {
+ const char *const parent = va_arg(args, const char*);
+ size_t parent_len;
+
+ if (!parent)
+ break;
+ parent_len = va_arg(args, size_t);
+
+ /* Arguments are supplied with a trailing :: */
+ assert(parent_len > 2);
+ assert(parent[parent_len - 1] == ':');
+ assert(parent[parent_len - 2] == ':');
+ av_push(isa, newSVpvn(parent, parent_len - 2));
+ (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
+ } while (1);
+ va_end(args);
+}
+
STATIC void
S_init_predump_symbols(pTHX)
dVAR;
GV *tmpgv;
IO *io;
- AV *isa;
sv_setpvs(get_sv("\"", GV_ADD), " ");
PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
so that code that does C<use IO::Handle>; will still work.
*/
- isa = get_av("IO::File::ISA", GV_ADD | GV_ADDMULTI);
- av_push(isa, newSVpvs("IO::Handle"));
- av_push(isa, newSVpvs("IO::Seekable"));
- av_push(isa, newSVpvs("Exporter"));
- (void) gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVGV);
- (void) gv_fetchpvs("IO::Seekable::", GV_ADD, SVt_PVGV);
- (void) gv_fetchpvs("Exporter::", GV_ADD, SVt_PVGV);
-
+ Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
+ STR_WITH_LEN("IO::Handle::"),
+ STR_WITH_LEN("IO::Seekable::"),
+ STR_WITH_LEN("Exporter::"),
+ NULL);
PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
GvMULTI_on(PL_stdingv);