X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/60eaec425bbc5e93d5dab2c98aa44af5d0baeb52..9426e1a55981168c83a030df9bce5e0b46586581:/perl.c diff --git a/perl.c b/perl.c index 0edad78..d2571a8 100644 --- a/perl.c +++ b/perl.c @@ -80,12 +80,6 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); # 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); \ @@ -348,6 +342,7 @@ perl_construct(pTHXx) PL_stashcache = newHV(); PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING); + PL_apiversion = newSVpvs("v" PERL_API_VERSION_STRING); #ifdef HAS_MMAP if (!PL_mmap_page_size) { @@ -562,8 +557,10 @@ perl_destruct(pTHXx) 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; @@ -573,7 +570,7 @@ perl_destruct(pTHXx) /* 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; @@ -750,9 +747,13 @@ perl_destruct(pTHXx) 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 @@ -769,8 +770,6 @@ perl_destruct(pTHXx) */ 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 */ @@ -832,9 +831,6 @@ perl_destruct(pTHXx) 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 @@ -870,13 +866,13 @@ perl_destruct(pTHXx) 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; Safefree(PL_inplace); PL_inplace = NULL; SvREFCNT_dec(PL_patchlevel); + SvREFCNT_dec(PL_apiversion); if (PL_e_script) { SvREFCNT_dec(PL_e_script); @@ -1009,6 +1005,7 @@ perl_destruct(pTHXx) 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; @@ -1028,18 +1025,21 @@ perl_destruct(pTHXx) 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); @@ -1069,6 +1069,12 @@ perl_destruct(pTHXx) (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 */ @@ -1162,7 +1168,8 @@ perl_destruct(pTHXx) PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p" " flags=0x%"UVxf " refcnt=%"UVuf pTHX__FORMAT "\n" - "\tallocated at %s:%d %s %s%s; serial %"UVuf"\n", + "\tallocated at %s:%d %s %s (parent 0x%"UVxf");" + "serial %"UVuf"\n", (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt pTHX__VALUE, sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", @@ -1170,7 +1177,7 @@ perl_destruct(pTHXx) sv->sv_debug_inpad ? "for" : "by", sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)", - sv->sv_debug_cloned ? " (cloned)" : "", + PTR2UV(sv->sv_debug_parent), sv->sv_debug_serial ); #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP @@ -1235,8 +1242,6 @@ perl_destruct(pTHXx) 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 */ @@ -1602,10 +1607,13 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) 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: @@ -1617,10 +1625,13 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) 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: @@ -1661,6 +1672,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef PERL_DONT_CREATE_GVSV " PERL_DONT_CREATE_GVSV" # endif +# ifdef PERL_EXTERNAL_GLOB + " PERL_EXTERNAL_GLOB" +# endif # ifdef PERL_IS_MINIPERL " PERL_IS_MINIPERL" # endif @@ -1741,6 +1755,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) 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; @@ -1748,6 +1763,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) 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,""); @@ -1869,7 +1886,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) goto reswitch; } case 'x': - PL_doextract = TRUE; + doextract = TRUE; s++; if (*s) cddir = s; @@ -2013,7 +2030,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # endif #endif - if (PL_doextract) { + if (doextract) { /* This will croak if suidscript is true, as -x cannot be used with setuid scripts. */ @@ -2147,7 +2164,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } #endif - lex_start(linestr_sv, rsfp, TRUE); + lex_start(linestr_sv, rsfp, 0); PL_subname = newSVpvs("main"); if (add_read_e_script) @@ -2156,7 +2173,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) /* 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 { @@ -2238,8 +2255,10 @@ perl_run(pTHXx) 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: "); @@ -2288,8 +2307,10 @@ S_run_body(pTHX_ I32 oldscope) } 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 @@ -2297,6 +2318,8 @@ S_run_body(pTHX_ I32 oldscope) /* do it */ + PL_phase = PERL_PHASE_RUN; + if (PL_restartop) { PL_restartjmpenv = NULL; PL_op = PL_restartop; @@ -2656,7 +2679,8 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) /* =for apidoc p||eval_sv -Tells Perl to C the string in the SV. +Tells Perl to C the string in the SV. It supports the same flags +as C, with the obvious exception of G_EVAL. See L. =cut */ @@ -2704,7 +2728,12 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) 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(); @@ -2727,6 +2756,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) PL_restartop = 0; goto redo_body; } + fail: PL_stack_sp = PL_stack_base + oldmark; if ((flags & G_WANT) == G_ARRAY) retval = 0; @@ -3018,11 +3048,21 @@ Perl_moreswitches(pTHX_ const char *s) /* 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); @@ -3662,24 +3702,21 @@ S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) /* 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))) + ; } } @@ -3774,15 +3811,30 @@ S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */ } void +Perl_init_dbargs(pTHX) +{ + AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", + GV_ADDMULTI, + SVt_PVAV)))); + + if (AvREAL(args)) { + /* Someone has already created it. + It might have entries, and if we just turn off AvREAL(), they will + "leak" until global destruction. */ + av_clear(args); + } + AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ +} + +void Perl_init_debugger(pTHX) { dVAR; HV * const ostash = PL_curstash; PL_curstash = PL_debstash; - PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", GV_ADDMULTI, - SVt_PVAV)))); - AvREAL_off(PL_dbargs); + + Perl_init_dbargs(aTHX); PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV); PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV); PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV)); @@ -3866,6 +3918,39 @@ S_nuke_stacks(pTHX) 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) @@ -3873,7 +3958,6 @@ 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)); @@ -3892,14 +3976,11 @@ S_init_predump_symbols(pTHX) so that code that does C; 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);