#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)
{
ALLOC_THREAD_KEY;
PERL_SET_THX(my_perl);
OP_REFCNT_INIT;
+ HINTS_REFCNT_INIT;
MUTEX_INIT(&PL_dollarzero_mutex);
# endif
#ifdef PERL_IMPLICIT_CONTEXT
PL_Dir = ipD;
PL_Sock = ipS;
PL_Proc = ipP;
+ INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
return my_perl;
}
my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
S_init_tls_and_interp(my_perl);
+#ifndef PERL_TRACK_MEMPOOL
return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
+#else
+ Zero(my_perl, 1, PerlInterpreter);
+ INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
+ return my_perl;
+#endif
}
#endif /* PERL_IMPLICIT_SYS */
if ((long) PL_mmap_page_size < 0) {
if (errno) {
SV * const error = ERRSV;
- (void) SvUPGRADE(error, SVt_PV);
+ SvUPGRADE(error, SVt_PV);
Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
}
else
PL_timesbase.tms_cstime = 0;
#endif
+#ifdef PERL_MAD
+ PL_curforce = -1;
+#endif
+
ENTER;
}
int
Perl_nothreadhook(pTHX)
{
+ PERL_UNUSED_CONTEXT;
return 0;
}
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;
PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
}
op_free(PL_main_root);
- PL_main_root = Nullop;
+ PL_main_root = NULL;
}
- PL_main_start = Nullop;
+ PL_main_start = NULL;
SvREFCNT_dec(PL_main_cv);
- PL_main_cv = Nullcv;
+ PL_main_cv = NULL;
PL_dirty = TRUE;
/* Tell PerlIO we are about to tear things apart in case
sv_clean_objs();
PL_sv_objcount = 0;
if (PL_defoutgv && !SvREFCNT(PL_defoutgv))
- PL_defoutgv = Nullgv; /* may have been freed */
+ PL_defoutgv = NULL; /* may have been freed */
}
/* unhook hooks which will soon be, or use, destroyed data */
SvREFCNT_dec(PL_warnhook);
- PL_warnhook = Nullsv;
+ PL_warnhook = NULL;
SvREFCNT_dec(PL_diehook);
- PL_diehook = Nullsv;
+ PL_diehook = NULL;
/* call exit list functions */
while (PL_exitlistlen-- > 0)
PL_exitlist = NULL;
PL_exitlistlen = 0;
- if (destruct_level == 0){
-
- DEBUG_P(debprofdump());
-
-#if defined(PERLIO_LAYERS)
- /* No more IO - including error messages ! */
- PerlIO_cleanup(aTHX);
-#endif
-
- /* The exit() function will do everything that needs doing. */
- return STATUS_EXIT;
- }
-
/* jettison our possibly duplicated environment */
/* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
* so we certainly shouldn't free it here
#endif
#endif /* !PERL_MICRO */
+ if (destruct_level == 0) {
+
+ DEBUG_P(debprofdump());
+
+#if defined(PERLIO_LAYERS)
+ /* No more IO - including error messages ! */
+ PerlIO_cleanup(aTHX);
+#endif
+
+ CopFILE_free(&PL_compiling);
+ CopSTASH_free(&PL_compiling);
+
+ /* The exit() function will do everything that needs doing. */
+ return STATUS_EXIT;
+ }
+
/* reset so print() ends up where we expect */
- setdefout(Nullgv);
+ setdefout(NULL);
#ifdef USE_ITHREADS
/* the syntax tree is shared between clones
if(PL_rsfp) {
(void)PerlIO_close(PL_rsfp);
- PL_rsfp = Nullfp;
+ PL_rsfp = NULL;
}
/* Filters for program text */
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;
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
- PL_e_script = Nullsv;
+ PL_e_script = NULL;
}
PL_perldb = 0;
/* magical thingies */
SvREFCNT_dec(PL_ofs_sv); /* $, */
- PL_ofs_sv = Nullsv;
+ PL_ofs_sv = NULL;
SvREFCNT_dec(PL_ors_sv); /* $\ */
- PL_ors_sv = Nullsv;
+ PL_ors_sv = NULL;
SvREFCNT_dec(PL_rs); /* $/ */
- PL_rs = Nullsv;
+ PL_rs = NULL;
- PL_multiline = 0; /* $* */
Safefree(PL_osname); /* $^O */
PL_osname = NULL;
SvREFCNT_dec(PL_statname);
- PL_statname = Nullsv;
- PL_statgv = Nullgv;
+ PL_statname = NULL;
+ PL_statgv = NULL;
/* defgv, aka *_ should be taken care of elsewhere */
/* clean up after study() */
SvREFCNT_dec(PL_lastscream);
- PL_lastscream = Nullsv;
+ PL_lastscream = NULL;
Safefree(PL_screamfirst);
PL_screamfirst = 0;
Safefree(PL_screamnext);
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 */
- PL_envgv = Nullgv;
- PL_incgv = Nullgv;
- PL_hintgv = Nullgv;
- PL_errgv = Nullgv;
- PL_argvgv = Nullgv;
- PL_argvoutgv = Nullgv;
- PL_stdingv = Nullgv;
- PL_stderrgv = Nullgv;
- PL_last_in_gv = Nullgv;
- PL_replgv = Nullgv;
- PL_DBgv = Nullgv;
- PL_DBline = Nullgv;
- PL_DBsub = Nullgv;
- PL_DBsingle = Nullsv;
- PL_DBtrace = Nullsv;
- PL_DBsignal = Nullsv;
- PL_DBassertion = Nullsv;
- PL_DBcv = Nullcv;
+ PL_envgv = NULL;
+ PL_incgv = NULL;
+ PL_hintgv = NULL;
+ PL_errgv = NULL;
+ PL_argvgv = NULL;
+ PL_argvoutgv = NULL;
+ PL_stdingv = NULL;
+ PL_stderrgv = NULL;
+ PL_last_in_gv = NULL;
+ PL_replgv = NULL;
+ PL_DBgv = NULL;
+ PL_DBline = NULL;
+ PL_DBsub = NULL;
+ PL_DBsingle = NULL;
+ PL_DBtrace = NULL;
+ PL_DBsignal = NULL;
+ PL_DBassertion = NULL;
+ PL_DBcv = NULL;
PL_dbargs = NULL;
PL_debstash = NULL;
SvREFCNT_dec(PL_preambleav);
PL_preambleav = NULL;
SvREFCNT_dec(PL_subname);
- PL_subname = Nullsv;
+ PL_subname = NULL;
SvREFCNT_dec(PL_linestr);
- PL_linestr = Nullsv;
+ PL_linestr = NULL;
#ifdef PERL_USES_PL_PIDSTATUS
SvREFCNT_dec(PL_pidstatus);
PL_pidstatus = NULL;
#endif
SvREFCNT_dec(PL_toptarget);
- PL_toptarget = Nullsv;
+ PL_toptarget = NULL;
SvREFCNT_dec(PL_bodytarget);
- PL_bodytarget = Nullsv;
- PL_formtarget = Nullsv;
+ PL_bodytarget = NULL;
+ PL_formtarget = NULL;
/* free locale stuff */
#ifdef USE_LOCALE_COLLATE
Safefree(PL_numeric_name);
PL_numeric_name = NULL;
SvREFCNT_dec(PL_numeric_radix_sv);
- PL_numeric_radix_sv = Nullsv;
+ PL_numeric_radix_sv = NULL;
#endif
/* clear utf8 character classes */
SvREFCNT_dec(PL_utf8_tofold);
SvREFCNT_dec(PL_utf8_idstart);
SvREFCNT_dec(PL_utf8_idcont);
- PL_utf8_alnum = Nullsv;
- PL_utf8_alnumc = Nullsv;
- PL_utf8_ascii = Nullsv;
- PL_utf8_alpha = Nullsv;
- PL_utf8_space = Nullsv;
- PL_utf8_cntrl = Nullsv;
- PL_utf8_graph = Nullsv;
- PL_utf8_digit = Nullsv;
- PL_utf8_upper = Nullsv;
- PL_utf8_lower = Nullsv;
- PL_utf8_print = Nullsv;
- PL_utf8_punct = Nullsv;
- PL_utf8_xdigit = Nullsv;
- PL_utf8_mark = Nullsv;
- PL_utf8_toupper = Nullsv;
- PL_utf8_totitle = Nullsv;
- PL_utf8_tolower = Nullsv;
- PL_utf8_tofold = Nullsv;
- PL_utf8_idstart = Nullsv;
- PL_utf8_idcont = Nullsv;
+ PL_utf8_alnum = NULL;
+ PL_utf8_alnumc = NULL;
+ PL_utf8_ascii = NULL;
+ PL_utf8_alpha = NULL;
+ PL_utf8_space = NULL;
+ PL_utf8_cntrl = NULL;
+ PL_utf8_graph = NULL;
+ PL_utf8_digit = NULL;
+ PL_utf8_upper = NULL;
+ PL_utf8_lower = NULL;
+ PL_utf8_print = NULL;
+ PL_utf8_punct = NULL;
+ PL_utf8_xdigit = NULL;
+ PL_utf8_mark = NULL;
+ PL_utf8_toupper = NULL;
+ PL_utf8_totitle = NULL;
+ PL_utf8_tolower = NULL;
+ PL_utf8_tofold = NULL;
+ PL_utf8_idstart = NULL;
+ PL_utf8_idcont = NULL;
if (!specialWARN(PL_compiling.cop_warnings))
- SvREFCNT_dec(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = Nullsv;
- if (!specialCopIO(PL_compiling.cop_io))
- SvREFCNT_dec(PL_compiling.cop_io);
- PL_compiling.cop_io = Nullsv;
+ 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;
CopFILE_free(&PL_compiling);
CopSTASH_free(&PL_compiling);
PL_defstash = 0;
SvREFCNT_dec(hv);
SvREFCNT_dec(PL_curstname);
- PL_curstname = Nullsv;
+ PL_curstname = NULL;
/* clear queued errors */
SvREFCNT_dec(PL_errors);
- PL_errors = Nullsv;
+ PL_errors = NULL;
FREETMPS;
if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
#endif
/* sv_undef needs to stay immortal until after PerlIO_cleanup
- as currently layers use it rather than Nullsv as a marker
+ as currently layers use it rather than NULL as a marker
for no arg - and will try and SvREFCNT_dec it.
*/
SvREFCNT(&PL_sv_undef) = 0;
PL_bitcount = NULL;
Safefree(PL_psig_pend);
PL_psig_pend = (int*)NULL;
- PL_formfeed = Nullsv;
+ PL_formfeed = NULL;
nuke_stacks();
PL_tainting = FALSE;
PL_taint_warn = FALSE;
sv_free_arenas();
+ while (PL_regmatch_slab) {
+ regmatch_slab *s = PL_regmatch_slab;
+ PL_regmatch_slab = PL_regmatch_slab->next;
+ Safefree(s);
+ }
+
/* As the absolutely last thing, free the non-arena SV for mess() */
if (PL_mess_sv) {
SvPV_free(PL_mess_sv);
Safefree(SvANY(PL_mess_sv));
Safefree(PL_mess_sv);
- PL_mess_sv = Nullsv;
+ PL_mess_sv = NULL;
}
return STATUS_EXIT;
}
void
perl_free(pTHXx)
{
+#ifdef PERL_TRACK_MEMPOOL
+ {
+ /*
+ * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
+ * value as we're probably hunting memory leaks then
+ */
+ const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
+ if (!s || atoi(s) == 0) {
+ /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
+ thread at thread exit. */
+ while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
+ safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
+ }
+ }
+#endif
+
#if defined(WIN32) || defined(NETWARE)
# if defined(PERL_IMPLICIT_SYS)
+ {
# ifdef NETWARE
- void *host = nw_internal_host;
+ void *host = nw_internal_host;
# else
- void *host = w32_internal_host;
+ void *host = w32_internal_host;
# endif
- PerlMem_free(aTHXx);
+ PerlMem_free(aTHXx);
# ifdef NETWARE
- nw_delete_internal_host(host);
+ nw_delete_internal_host(host);
# else
- win32_delete_internal_host(host);
+ win32_delete_internal_host(host);
# endif
+ }
# else
PerlMem_free(aTHXx);
# endif
#endif
}
-#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
+#if defined(USE_ITHREADS)
/* provide destructors to clean up the thread key when libperl is unloaded */
#ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
-#if defined(__hpux) && __ux_version > 1020 && !defined(__GNUC__)
+#if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
#pragma fini "perl_fini"
+#elif defined(__sun) && !defined(__GNUC__)
+#pragma fini (perl_fini)
#endif
static void
int ret;
dJMPENV;
- PERL_UNUSED_VAR(my_perl);
+ PERL_UNUSED_ARG(my_perl);
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
if (PL_main_root) {
op_free(PL_main_root);
- PL_main_root = Nullop;
+ PL_main_root = NULL;
}
- PL_main_start = Nullop;
+ PL_main_start = NULL;
SvREFCNT_dec(PL_main_cv);
- PL_main_cv = Nullcv;
+ PL_main_cv = NULL;
time(&PL_basetime);
oldscope = PL_scopestack_ix;
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
- PL_fdscript = -1;
- PL_suidscript = -1;
sv_setpvn(PL_linestr,"",0);
sv = newSVpvs(""); /* first used for -I flags */
SAVEFREESV(sv);
#endif
s = argv[0]+1;
reswitch:
- switch (*s) {
+ switch ((c = *s)) {
case 'C':
#ifndef PERL_STRICT_CR
case '\r':
if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
break;
#endif
- forbid_setid("-e");
+ forbid_setid('e', -1);
if (!PL_e_script) {
PL_e_script = newSVpvs("");
filter_add(read_e_script, NULL);
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;
goto reswitch;
case 'I': /* -I handled both here and in moreswitches() */
- forbid_setid("-I");
+ forbid_setid('I', -1);
if (!*++s && (s=argv[1]) != NULL) {
argc--,argv++;
}
Perl_croak(aTHX_ "No directory specified for -I");
break;
case 'P':
- forbid_setid("-P");
+ forbid_setid('P', -1);
PL_preprocess = TRUE;
s++;
goto reswitch;
case 'S':
- forbid_setid("-S");
+ forbid_setid('S', -1);
dosearch = TRUE;
s++;
goto reswitch;
# ifdef PERL_IMPLICIT_SYS
" PERL_IMPLICIT_SYS"
# endif
+# ifdef PERL_MAD
+ " PERL_MAD"
+# endif
# ifdef PERL_MALLOC_WRAP
" PERL_MALLOC_WRAP"
# endif
# ifdef THREADS_HAVE_PIDS
" THREADS_HAVE_PIDS"
# endif
-# ifdef USE_5005THREADS
- " USE_5005THREADS"
-# endif
# ifdef USE_64_BIT_ALL
" USE_64_BIT_ALL"
# endif
#endif
if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
- PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
+ PL_compiling.cop_warnings
+ = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize);
}
if (!scriptname)
TAINT_NOT;
init_perllib();
- open_script(scriptname,dosearch,sv);
+ {
+ int suidscript;
+ const int fdscript
+ = open_script(scriptname, dosearch, sv, &suidscript);
- validate_suid(validarg, scriptname);
+ validate_suid(validarg, scriptname, fdscript, suidscript);
#ifndef PERL_MICRO
-#if defined(SIGCHLD) || defined(SIGCLD)
- {
-#ifndef SIGCHLD
-# define SIGCHLD SIGCLD
-#endif
- Sighandler_t sigstate = rsignal_state(SIGCHLD);
- if (sigstate == (Sighandler_t) SIG_IGN) {
- if (ckWARN(WARN_SIGNAL))
- Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
- "Can't ignore signal CHLD, forcing to default");
- (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
+# if defined(SIGCHLD) || defined(SIGCLD)
+ {
+# ifndef SIGCHLD
+# define SIGCHLD SIGCLD
+# endif
+ Sighandler_t sigstate = rsignal_state(SIGCHLD);
+ if (sigstate == (Sighandler_t) SIG_IGN) {
+ if (ckWARN(WARN_SIGNAL))
+ Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
+ "Can't ignore signal CHLD, forcing to default");
+ (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
+ }
}
- }
-#endif
+# endif
#endif
+ if (PL_doextract
#ifdef MACOS_TRADITIONAL
- if (PL_doextract || gMacPerl_AlwaysExtract) {
-#else
- if (PL_doextract) {
+ || gMacPerl_AlwaysExtract
#endif
- find_beginning();
- if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
- Perl_croak(aTHX_ "Can't chdir to %s",cddir);
+ ) {
+ /* This will croak if suidscript is >= 0, as -x cannot be used with
+ setuid scripts. */
+ forbid_setid('x', suidscript);
+ /* Hence you can't get here if suidscript >= 0 */
+
+ find_beginning();
+ if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
+ Perl_croak(aTHX_ "Can't chdir to %s",cddir);
+ }
}
PL_main_cv = PL_compcv = (CV*)newSV(0);
CvUNIQUE_on(PL_compcv);
CvPADLIST(PL_compcv) = pad_new(0);
-#ifdef USE_5005THREADS
- CvOWNER(PL_compcv) = 0;
- Newx(CvMUTEXP(PL_compcv), 1, perl_mutex);
- MUTEX_INIT(CvMUTEXP(PL_compcv));
-#endif /* USE_5005THREADS */
boot_core_PerlIO();
boot_core_UNIVERSAL();
Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
}
+#ifdef PERL_MAD
+ if ((s = PerlEnv_getenv("PERL_XMLDUMP"))) {
+ PL_madskills = 1;
+ PL_minus_c = 1;
+ if (!s || !s[0])
+ PL_xmlfp = PerlIO_stdout();
+ else {
+ PL_xmlfp = PerlIO_open(s, "w");
+ if (!PL_xmlfp)
+ Perl_croak(aTHX_ "Can't open %s", s);
+ }
+ my_setenv("PERL_XMLDUMP", Nullch); /* hide from subprocs */
+ }
+ if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
+ PL_madskills = atoi(s);
+ my_setenv("PERL_MADSKILLS", Nullch); /* hide from subprocs */
+ }
+#endif
+
init_lexer();
/* now parse the script */
PL_preprocess = FALSE;
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
- PL_e_script = Nullsv;
+ PL_e_script = NULL;
}
if (PL_do_undump)
PL_sawampersand ? "Enabling" : "Omitting"));
if (!PL_restartop) {
+#ifdef PERL_MAD
+ if (PL_xmlfp) {
+ xmldump_all();
+ exit(0); /* less likely to core dump than my_exit(0) */
+ }
+#endif
DEBUG_x(dump_all());
#ifdef DEBUGGING
if (!DEBUG_q_TEST)
Perl_get_sv(pTHX_ const char *name, I32 create)
{
GV *gv;
-#ifdef USE_5005THREADS
- if (name[1] == '\0' && !isALPHA(name[0])) {
- PADOFFSET tmp = find_threadsv(name);
- if (tmp != NOT_IN_PAD)
- return THREADSV(tmp);
- }
-#endif /* USE_5005THREADS */
gv = gv_fetchpv(name, create, SVt_PV);
if (gv)
return GvSV(gv);
- return Nullsv;
+ return NULL;
}
/*
if (create && !GvCVu(gv))
return newSUB(start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, newSVpv(name,0)),
- Nullop,
- Nullop);
+ NULL, NULL);
if (gv)
return GvCVu(gv);
- return Nullcv;
+ return NULL;
}
/* Be sure to refetch the stack pointer after calling these routines. */
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;
}
Zero(&myop, 1, LOGOP);
- myop.op_next = Nullop;
+ myop.op_next = NULL;
if (!(flags & G_NOARGS))
myop.op_flags |= OPf_STACKED;
myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
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);
}
else {
myop.op_other = (OP*)&myop;
PL_markstack_ptr--;
- /* we're trying to emulate pp_entertry() here */
- {
- register PERL_CONTEXT *cx;
- const I32 gimme = GIMME_V;
-
- ENTER;
- SAVETMPS;
-
- PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
- PUSHEVAL(cx, 0, 0);
- PL_eval_root = PL_op; /* Only needed so that goto works right. */
-
- PL_in_eval = EVAL_INEVAL;
- if (flags & G_KEEPERR)
- PL_in_eval |= EVAL_KEEPERR;
- else
- sv_setpvn(ERRSV,"",0);
- }
+ create_eval_scope(flags|G_FAKINGEVAL);
PL_markstack_ptr++;
JMPENV_PUSH(ret);
+
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);
break;
}
- if (PL_scopestack_ix > oldscope) {
- SV **newsp;
- PMOP *newpm;
- I32 gimme;
- register PERL_CONTEXT *cx;
- I32 optype;
-
- POPBLOCK(cx,newpm);
- POPEVAL(cx);
- PL_curpm = newpm;
- LEAVE;
- PERL_UNUSED_VAR(newsp);
- PERL_UNUSED_VAR(gimme);
- PERL_UNUSED_VAR(optype);
- }
+ if (PL_scopestack_ix > oldscope)
+ delete_eval_scope();
JMPENV_POP;
}
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;
if (!(flags & G_NOARGS))
myop.op_flags = OPf_STACKED;
- myop.op_next = Nullop;
+ myop.op_next = NULL;
myop.op_type = OP_ENTEREVAL;
myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
(flags & G_ARRAY) ? OPf_WANT_LIST :
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;
PL_splitstr = ++s;
while (*s && !isSPACE(*s)) ++s;
- *s = '\0';
- PL_splitstr = savepv(PL_splitstr);
+ PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
return s;
case 'a':
PL_minus_a = TRUE;
s++;
return s;
case 'd':
- forbid_setid("-d");
+ forbid_setid('d', -1);
s++;
/* -dt indicates to the debugger that threads will be used */
sv_catpv(sv, start);
else {
sv_catpvn(sv, start, s-start);
- Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0);
+ /* Don't use NUL as q// delimiter here, this string goes in the
+ * environment. */
+ Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
}
s += strlen(s);
my_setenv("PERL5DB", SvPV_nolen_const(sv));
case 'D':
{
#ifdef DEBUGGING
- forbid_setid("-D");
+ forbid_setid('D', -1);
s++;
PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
#else /* !DEBUGGING */
return s+1;
}
#endif /* __CYGWIN__ */
- PL_inplace = savepv(s+1);
- for (s = PL_inplace; *s && !isSPACE(*s); s++)
- ;
+ {
+ const char * const start = ++s;
+ while (*s && !isSPACE(*s))
+ ++s;
+
+ PL_inplace = savepvn(start, s - start);
+ }
if (*s) {
- *s++ = '\0';
+ ++s;
if (*s == '-') /* Additional switches on #! line. */
- s++;
+ s++;
}
return s;
case 'I': /* -I handled both here and in parse_body() */
- forbid_setid("-I");
+ forbid_setid('I', -1);
++s;
while (*s && isSPACE(*s))
++s;
s++;
if (PL_ors_sv) {
SvREFCNT_dec(PL_ors_sv);
- PL_ors_sv = Nullsv;
+ PL_ors_sv = NULL;
}
if (isDIGIT(*s)) {
I32 flags = 0;
}
return s;
case 'A':
- forbid_setid("-A");
+ forbid_setid('A', -1);
if (!PL_preambleav)
PL_preambleav = newAV();
s++;
return s;
}
case 'M':
- forbid_setid("-M"); /* XXX ? */
+ forbid_setid('M', -1); /* XXX ? */
/* FALL THROUGH */
case 'm':
- forbid_setid("-m"); /* XXX ? */
+ forbid_setid('m', -1); /* XXX ? */
if (*++s) {
char *start;
SV *sv;
s++;
return s;
case 's':
- forbid_setid("-s");
+ forbid_setid('s', -1);
PL_doswitches = TRUE;
s++;
return s;
" 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
case 'W':
PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
if (!specialWARN(PL_compiling.cop_warnings))
- SvREFCNT_dec(PL_compiling.cop_warnings);
+ PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_ALL ;
s++;
return s;
case 'X':
PL_dowarn = G_WARN_ALL_OFF;
if (!specialWARN(PL_compiling.cop_warnings))
- SvREFCNT_dec(PL_compiling.cop_warnings);
+ PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_NONE ;
s++;
return s;
void
Perl_my_unexec(pTHX)
{
+ PERL_UNUSED_CONTEXT;
#ifdef UNEXEC
- SV* prog;
- SV* file;
+ SV * prog = newSVpv(BIN_EXP, 0);
+ SV * file = newSVpv(PL_origfilename, 0);
int status = 1;
extern int etext;
- prog = newSVpv(BIN_EXP, 0);
sv_catpvs(prog, "/perl");
- file = newSVpv(PL_origfilename, 0);
sv_catpvs(file, ".perldump");
unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
# define PERLVAR(var,type)
# define PERLVARA(var,n,type)
# if defined(PERL_IMPLICIT_CONTEXT)
-# if defined(USE_5005THREADS)
-# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
-# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
-# else /* !USE_5005THREADS */
-# define PERLVARI(var,type,init) aTHX->var = init;
-# define PERLVARIC(var,type,init) aTHX->var = init;
-# endif /* USE_5005THREADS */
+# define PERLVARI(var,type,init) aTHX->var = init;
+# define PERLVARIC(var,type,init) aTHX->var = init;
# else
# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
# endif
# include "intrpvar.h"
-# ifndef USE_5005THREADS
-# include "thrdvar.h"
-# endif
+# include "thrdvar.h"
# undef PERLVAR
# undef PERLVARA
# undef PERLVARI
# define PERLVARI(var,type,init) PL_##var = init;
# define PERLVARIC(var,type,init) PL_##var = init;
# include "intrpvar.h"
-# ifndef USE_5005THREADS
-# include "thrdvar.h"
-# endif
+# include "thrdvar.h"
# undef PERLVAR
# undef PERLVARA
# undef PERLVARI
# undef PERLVARIC
#endif
+ /* As these are inside a structure, PERLVARI isn't capable of initialising
+ them */
+ PL_reg_oldcurpm = PL_reg_curpm = NULL;
+ PL_reg_poscache = PL_reg_starttry = NULL;
}
STATIC void
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(PL_defstash);
+ GvHV(gv) = (HV*)SvREFCNT_inc_simple(PL_defstash);
SvREADONLY_on(gv);
PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
SVt_PVAV)));
- SvREFCNT_inc(PL_incgv); /* Don't allow it to be freed */
+ SvREFCNT_inc_simple(PL_incgv); /* Don't allow it to be freed */
GvMULTI_on(PL_incgv);
PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
GvMULTI_on(PL_hintgv);
PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
- SvREFCNT_inc(PL_defgv);
+ SvREFCNT_inc_simple(PL_defgv);
PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
- SvREFCNT_inc(PL_errgv);
+ SvREFCNT_inc_simple(PL_errgv);
GvMULTI_on(PL_errgv);
PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
GvMULTI_on(PL_replgv);
sv_setpvn(get_sv("/", TRUE), "\n", 1);
}
-/* PSz 18 Nov 03 fdscript now global but do not change prototype */
-STATIC void
-S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
+STATIC int
+S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
+ int *suidscript)
{
#ifndef IAMSUID
const char *quote;
const char *cpp_discard_flag;
const char *perl;
#endif
+ int fdscript = -1;
dVAR;
- PL_fdscript = -1;
- PL_suidscript = -1;
+ *suidscript = -1;
if (PL_e_script) {
PL_origfilename = savepvs("-e");
if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
const char *s = scriptname + 8;
- PL_fdscript = atoi(s);
+ fdscript = atoi(s);
while (isDIGIT(*s))
s++;
if (*s) {
* Is it a mistake to use a similar /dev/fd/ construct for
* suidperl?
*/
- PL_suidscript = 1;
+ *suidscript = 1;
/* PSz 20 Feb 04
* Be supersafe and do some sanity-checks.
* Still, can we be sure we got the right thing?
CopFILE_set(PL_curcop, PL_origfilename);
if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
scriptname = (char *)"";
- if (PL_fdscript >= 0) {
- PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
+ if (fdscript >= 0) {
+ PL_rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
# if defined(HAS_FCNTL) && defined(F_SETFD)
if (PL_rsfp)
/* ensure close-on-exec */
* perl with that fd as it has always done.
*/
}
- if (PL_suidscript != 1) {
+ if (*suidscript != 1) {
Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
}
#else /* IAMSUID */
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;
SvREFCNT_dec(cpp);
}
else if (!*scriptname) {
- forbid_setid("program input from stdin");
+ forbid_setid(0, *suidscript);
PL_rsfp = PerlIO_stdin();
}
else {
Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
CopFILE(PL_curcop), Strerror(errno));
}
+ return fdscript;
}
/* Mention
#endif /* IAMSUID */
STATIC void
-S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
+S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
+ int fdscript, int suidscript)
{
dVAR;
#ifdef IAMSUID
const char *s_end;
#ifdef IAMSUID
- if (PL_fdscript < 0 || PL_suidscript != 1)
+ if (fdscript < 0 || suidscript != 1)
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_ "Args must match #! line");
#ifndef IAMSUID
- if (PL_fdscript < 0 &&
+ if (fdscript < 0 &&
PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
PL_euid == PL_statbuf.st_uid)
if (!PL_do_undump)
FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
#endif /* IAMSUID */
- if (PL_fdscript < 0 &&
+ if (fdscript < 0 &&
PL_euid) { /* oops, we're not the setuid root perl */
/* PSz 18 Feb 04
* When root runs a setuid script, we do not go through the same
* might run also non-setuid ones, and deserves what he gets.
*
* Or, we might drop the PL_euid check above (and rely just on
- * PL_fdscript to avoid loops), and do the execs
+ * fdscript to avoid loops), and do the execs
* even for root.
*/
#ifndef IAMSUID
#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 (PL_fdscript < 0 || PL_suidscript != 1)
+ else if (fdscript < 0 || suidscript != 1)
/* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
else {
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) */
#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
/* not set-id, must be wrapped */
}
#endif /* DOSUID */
- (void)validarg;
- (void)scriptname;
+ PERL_UNUSED_ARG(validarg);
+ PERL_UNUSED_ARG(scriptname);
}
STATIC void
/* skip forward in input to the real script? */
- forbid_setid("-x");
#ifdef MACOS_TRADITIONAL
/* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
return 0;
}
+/* Passing the flag as a single char rather than a string is a slight space
+ optimisation. The only message that isn't /^-.$/ is
+ "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 *s)
+S_forbid_setid(pTHX_ const char flag, const int suidscript)
{
dVAR;
+ char string[3] = "-x";
+ const char *message = "program input from stdin";
+
+ if (flag) {
+ string[1] = flag;
+ message = string;
+ }
+
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
if (PL_euid != PL_uid)
- Perl_croak(aTHX_ "No %s allowed while running setuid", s);
+ Perl_croak(aTHX_ "No %s allowed while running setuid", message);
if (PL_egid != PL_gid)
- Perl_croak(aTHX_ "No %s allowed while running setgid", s);
+ Perl_croak(aTHX_ "No %s allowed while running setgid", message);
#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
/* PSz 29 Feb 04
* Checks for UID/GID above "wrong": why disallow
*
* Also see comments about root running a setuid script, elsewhere.
*/
- if (PL_suidscript >= 0)
- Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
+ if (suidscript >= 0)
+ Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
#ifdef IAMSUID
/* PSz 11 Nov 03 Catch it in suidperl, always! */
- Perl_croak(aTHX_ "No %s allowed in suidperl", s);
+ Perl_croak(aTHX_ "No %s allowed in suidperl", message);
#endif /* IAMSUID */
}
dVAR;
PerlIO *tmpfp;
tmpfp = PL_rsfp;
- PL_rsfp = Nullfp;
+ PL_rsfp = NULL;
lex_start(PL_linestr);
PL_rsfp = tmpfp;
PL_subname = newSVpvs("main");
IoIFP(io) = PerlIO_stdin();
tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
GvMULTI_on(tmpgv);
- GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
+ GvIOp(tmpgv) = (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(io);
+ GvIOp(tmpgv) = (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(io);
+ GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
PL_statname = newSV(0); /* last filename we did stat on */
HV *hv;
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
- hv_magic(hv, Nullgv, PERL_MAGIC_env);
+ hv_magic(hv, NULL, PERL_MAGIC_env);
#ifndef PERL_MICRO
#ifdef USE_ENVIRON_ARRAY
/* Note that if the supplied env parameter is actually a copy
# endif
#endif
-#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
+#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
+ /* Search for version-specific dirs below here */
incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
#endif
bool canrelocate)
{
dVAR;
- SV *subdir = Nullsv;
+ SV *subdir = NULL;
const char *p = dir;
if (!p || !*p)
#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);
}
}
}
}
-#ifdef USE_5005THREADS
-STATIC struct perl_thread *
-S_init_main_thread(pTHX)
-{
-#if !defined(PERL_IMPLICIT_CONTEXT)
- struct perl_thread *thr;
-#endif
- XPV *xpv;
-
- Newxz(thr, 1, struct perl_thread);
- PL_curcop = &PL_compiling;
- thr->interp = PERL_GET_INTERP;
- thr->cvcache = newHV();
- thr->threadsv = newAV();
- /* thr->threadsvp is set when find_threadsv is called */
- thr->specific = newAV();
- thr->flags = THRf_R_JOINABLE;
- MUTEX_INIT(&thr->mutex);
- /* Handcraft thrsv similarly to mess_sv */
- Newx(PL_thrsv, 1, SV);
- Newxz(xpv, 1, XPV);
- SvFLAGS(PL_thrsv) = SVt_PV;
- SvANY(PL_thrsv) = (void*)xpv;
- SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
- SvPV_set(PL_thrsvr, (char*)thr);
- SvCUR_set(PL_thrsv, sizeof(thr));
- SvLEN_set(PL_thrsv, sizeof(thr));
- *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
- thr->oursv = PL_thrsv;
- PL_chopset = " \n-";
- PL_dumpindent = 4;
-
- MUTEX_LOCK(&PL_threads_mutex);
- PL_nthreads++;
- thr->tid = 0;
- thr->next = thr;
- thr->prev = thr;
- thr->thr_done = 0;
- MUTEX_UNLOCK(&PL_threads_mutex);
-
-#ifdef HAVE_THREAD_INTERN
- Perl_init_thread_intern(thr);
-#endif
-
-#ifdef SET_THREAD_SELF
- SET_THREAD_SELF(thr);
-#else
- thr->self = pthread_self();
-#endif /* SET_THREAD_SELF */
- PERL_SET_THX(thr);
-
- /*
- * These must come after the thread self setting
- * because sv_setpvn does SvTAINT and the taint
- * fields thread selfness being set.
- */
- PL_toptarget = newSV(0);
- sv_upgrade(PL_toptarget, SVt_PVFM);
- sv_setpvn(PL_toptarget, "", 0);
- PL_bodytarget = newSV(0);
- sv_upgrade(PL_bodytarget, SVt_PVFM);
- sv_setpvn(PL_bodytarget, "", 0);
- PL_formtarget = PL_bodytarget;
- thr->errsv = newSVpvs("");
- (void) find_threadsv("@"); /* Ensure $@ is initialised early */
-
- PL_maxscream = -1;
- PL_peepp = MEMBER_TO_FPTR(Perl_peep);
- PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
- PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
- PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
- PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
- PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
- PL_regindent = 0;
- PL_reginterp_cnt = 0;
-
- return thr;
-}
-#endif /* USE_5005THREADS */
void
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
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 {
- SAVEFREESV(cv);
+ if (!PL_madskills)
+ SAVEFREESV(cv);
}
JMPENV_PUSH(ret);
switch (ret) {
case 0:
- call_list_body(cv);
+#ifdef PERL_MAD
+ if (PL_madskills)
+ PL_madskills |= 16384;
+#endif
+ CALL_LIST_BODY(cv);
+#ifdef PERL_MAD
+ if (PL_madskills)
+ PL_madskills &= ~16384;
+#endif
atsv = ERRSV;
(void)SvPV_const(atsv, len);
+ if (PL_madskills && PL_minus_c && paramList == PL_beginav)
+ break; /* not really trying to run, so just wing it */
if (len) {
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
"%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:
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
JMPENV_POP;
+ if (PL_madskills && PL_minus_c && paramList == PL_beginav)
+ return; /* not really trying to run, so just wing it */
if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
if (paramList == PL_beginav)
Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
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)
{
S_my_exit_jump(pTHX)
{
dVAR;
- register PERL_CONTEXT *cx;
- I32 gimme;
- SV **newsp;
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
- PL_e_script = Nullsv;
+ PL_e_script = NULL;
}
POPSTACK_TO(PL_mainstack);
- if (cxstack_ix >= 0) {
- if (cxstack_ix > 0)
- dounwind(0);
- POPBLOCK(cx,PL_curpm);
- LEAVE;
- }
+ dounwind(-1);
+ LEAVE_SCOPE(0);
JMPENV_JUMP(2);
- PERL_UNUSED_VAR(gimme);
- PERL_UNUSED_VAR(newsp);
}
static I32
https://perl5.git.perl.org / perl5.git / blobdiff