#include "EXTERN.h"
#define PERL_IN_PERL_C
#include "perl.h"
+#include "patchlevel.h" /* for local_patches */
/* XXX If this causes problems, set i_unistd=undef in the hint file. */
#ifdef I_UNISTD
{
PerlInterpreter *my_perl;
-#if !defined(PERL_IMPLICIT_CONTEXT)
- PL_curinterp = 0;
-#endif
- New(53, my_perl, 1, PerlInterpreter);
+ /* New() needs interpreter, so call malloc() instead */
+ my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+ PERL_SET_INTERP(my_perl);
return my_perl;
}
#endif /* PERL_OBJECT */
#ifdef USE_THREADS
int i;
#ifndef FAKE_THREADS
- struct perl_thread *thr;
+ struct perl_thread *thr = NULL;
#endif /* FAKE_THREADS */
#endif /* USE_THREADS */
-#ifndef PERL_OBJECT
- if (!(PL_curinterp = my_perl))
- return;
+#ifdef MULTIPLICITY
+ Zero(my_perl, 1, PerlInterpreter);
#endif
#ifdef MULTIPLICITY
- Zero(my_perl, 1, PerlInterpreter);
+ init_interp();
+ PL_perl_destruct_level = 1;
+#else
+ if (PL_perl_destruct_level > 0)
+ init_interp();
#endif
/* Init the real globals (and main thread)? */
thr = init_main_thread();
#endif /* USE_THREADS */
- PL_protect = FUNC_NAME_TO_PTR(Perl_default_protect); /* for exceptions */
+ PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
PL_rs = SvREFCNT_inc(PL_nrs);
init_stacks();
-#ifdef MULTIPLICITY
- init_interp();
- PL_perl_destruct_level = 1;
-#else
- if (PL_perl_destruct_level > 0)
- init_interp();
-#endif
init_ids();
PL_lex_state = LEX_NOTPARSING;
dTHX;
#endif /* USE_THREADS */
-#if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
- if (!(PL_curinterp = my_perl))
- return;
-#endif
-
#ifdef USE_THREADS
#ifndef FAKE_THREADS
/* Pass 1 on any remaining threads: detach joinables, join zombies */
retry_cleanup:
MUTEX_LOCK(&PL_threads_mutex);
- DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
"perl_destruct: waiting for %d threads...\n",
PL_nthreads - 1));
for (t = thr->next; t != thr; t = t->next) {
switch (ThrSTATE(t)) {
AV *av;
case THRf_ZOMBIE:
- DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
"perl_destruct: joining zombie %p\n", t));
ThrSETSTATE(t, THRf_DEAD);
MUTEX_UNLOCK(&t->mutex);
MUTEX_UNLOCK(&PL_threads_mutex);
JOIN(t, &av);
SvREFCNT_dec((SV*)av);
- DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
"perl_destruct: joined zombie %p OK\n", t));
goto retry_cleanup;
case THRf_R_JOINABLE:
- DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
"perl_destruct: detaching thread %p\n", t));
ThrSETSTATE(t, THRf_R_DETACHED);
/*
MUTEX_UNLOCK(&t->mutex);
goto retry_cleanup;
default:
- DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
"perl_destruct: ignoring %p (state %u)\n",
t, ThrSTATE(t)));
MUTEX_UNLOCK(&t->mutex);
/* Pass 2 on remaining threads: wait for the thread count to drop to one */
while (PL_nthreads > 1)
{
- DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
"perl_destruct: final wait for %d threads\n",
PL_nthreads - 1));
COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
}
/* At this point, we're the last thread */
MUTEX_UNLOCK(&PL_threads_mutex);
- DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
+ DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
MUTEX_DESTROY(&PL_threads_mutex);
COND_DESTROY(&PL_nthreads_cond);
#endif /* !defined(FAKE_THREADS) */
PL_warnhook = Nullsv;
SvREFCNT_dec(PL_diehook);
PL_diehook = Nullsv;
- SvREFCNT_dec(PL_parsehook);
- PL_parsehook = Nullsv;
/* call exit list functions */
while (PL_exitlistlen-- > 0)
Safefree(PL_screamnext);
PL_screamnext = 0;
+ /* float buffer */
+ Safefree(PL_efloatbuf);
+ PL_efloatbuf = Nullch;
+ PL_efloatsize = 0;
+
/* startup and shutdown function lists */
SvREFCNT_dec(PL_beginav);
SvREFCNT_dec(PL_endav);
PL_argvgv = Nullgv;
PL_argvoutgv = Nullgv;
PL_stdingv = Nullgv;
+ PL_stderrgv = Nullgv;
PL_last_in_gv = Nullgv;
PL_replgv = Nullgv;
PL_defstash = 0;
SvREFCNT_dec(hv);
+ /* clear queued errors */
+ SvREFCNT_dec(PL_errors);
+ PL_errors = Nullsv;
+
FREETMPS;
- if (destruct_level >= 2) {
+ if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
if (PL_scopestack_ix != 0)
- Perl_warn(aTHX_ "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
+ Perl_warner(aTHX_ WARN_INTERNAL,
+ "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
(long)PL_scopestack_ix);
if (PL_savestack_ix != 0)
- Perl_warn(aTHX_ "Unbalanced saves: %ld more saves than restores\n",
+ Perl_warner(aTHX_ WARN_INTERNAL,
+ "Unbalanced saves: %ld more saves than restores\n",
(long)PL_savestack_ix);
if (PL_tmps_floor != -1)
- Perl_warn(aTHX_ "Unbalanced tmps: %ld more allocs than frees\n",
+ Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
(long)PL_tmps_floor + 1);
if (cxstack_ix != -1)
- Perl_warn(aTHX_ "Unbalanced context: %ld more PUSHes than POPs\n",
+ Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
(long)cxstack_ix + 1);
}
array = HvARRAY(PL_strtab);
hent = array[0];
for (;;) {
- if (hent) {
- Perl_warn(aTHX_ "Unbalanced string table refcount: (%d) for \"%s\"",
+ if (hent && ckWARN_d(WARN_INTERNAL)) {
+ Perl_warner(aTHX_ WARN_INTERNAL,
+ "Unbalanced string table refcount: (%d) for \"%s\"",
HeVAL(hent) - Nullsv, HeKEY(hent));
HeVAL(hent) = Nullsv;
hent = HeNEXT(hent);
}
SvREFCNT_dec(PL_strtab);
- if (PL_sv_count != 0)
- Perl_warn(aTHX_ "Scalars leaked: %ld\n", (long)PL_sv_count);
+ if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
sv_free_arenas();
Safefree(PL_reg_start_tmp);
if (PL_reg_curpm)
Safefree(PL_reg_curpm);
+ Safefree(PL_reg_poscache);
Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
Safefree(PL_op_mask);
nuke_stacks();
void
perl_free(pTHXx)
{
-#ifdef PERL_OBJECT
- Safefree(this);
+#if defined(PERL_OBJECT)
+ PerlMem_free(this);
#else
-# if !defined(PERL_IMPLICIT_CONTEXT)
- if (!(PL_curinterp = my_perl))
- return;
-# endif
- Safefree(my_perl);
+ PerlMem_free(aTHXx);
#endif
}
#endif
#endif
-#if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
- if (!(PL_curinterp = my_perl))
- return 255;
-#endif
-
#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
_dyld_lookup_and_bind
("__environ", (unsigned long *) &environ_pointer, NULL);
oldscope = PL_scopestack_ix;
PL_dowarn = G_WARN_OFF;
- CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_parse_body), env, xsinit);
+ CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_parse_body), env, xsinit);
switch (ret) {
case 0:
return 0;
LEAVE;
FREETMPS;
PL_curstash = PL_defstash;
- if (PL_endav)
+ if (PL_endav && !PL_minus_c)
call_list(oldscope, PL_endav);
return STATUS_NATIVE_EXPORT;
case 3:
- PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
+ PerlIO_printf(Perl_error_log, "panic: top_env\n");
return 1;
}
return 0;
CvPADLIST(PL_compcv) = comppadlist;
boot_core_UNIVERSAL();
+ boot_core_xsutils();
if (xsinit)
(*xsinit)(aTHXo); /* in case linked C routines want magical variables */
#if defined(VMS) || defined(WIN32) || defined(DJGPP)
- init_os_extras(aTHX);
+ init_os_extras();
#endif
+#ifdef USE_SOCKS
+ SOCKSinit(argv[0]);
+#endif
+
init_predump_symbols();
/* init_postdump_symbols not currently designed to be called */
/* more than once (ENV isn't cleared first, for example) */
if (PL_do_undump)
my_unexec();
- if (ckWARN(WARN_ONCE))
+ if (isWARN_ONCE)
gv_check(PL_defstash);
LEAVE;
dTHX;
#endif
-#if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
- if (!(PL_curinterp = my_perl))
- return 255;
-#endif
-
oldscope = PL_scopestack_ix;
redo_body:
- CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_run_body), oldscope);
+ CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
switch (ret) {
case 1:
cxstack_ix = -1; /* start context stack again */
LEAVE;
FREETMPS;
PL_curstash = PL_defstash;
- if (PL_endav)
+ if (PL_endav && !PL_minus_c)
call_list(oldscope, PL_endav);
#ifdef MYMALLOC
if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
POPSTACK_TO(PL_mainstack);
goto redo_body;
}
- PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+ PerlIO_printf(Perl_error_log, "panic: restartop\n");
FREETMPS;
return 1;
}
(unsigned long) thr));
if (PL_minus_c) {
- PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
+ PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
my_exit(0);
}
if (PERLDB_SINGLE && PL_DBsingle)
CALLRUNOPS(aTHX);
}
+ my_exit(0);
+ /* NOTREACHED */
return NULL;
}
PL_op->op_private |= OPpENTERSUB_DB;
if (!(flags & G_EVAL)) {
- CATCH_SET(TRUE);
+ /* G_NOCATCH is a hack for perl_vdie using this path to call
+ a __DIE__ handler */
+ if (!(flags & G_NOCATCH)) {
+ CATCH_SET(TRUE);
+ }
call_xbody((OP*)&myop, FALSE);
retval = PL_stack_sp - (PL_stack_base + oldmark);
- CATCH_SET(FALSE);
+ if (!(flags & G_NOCATCH)) {
+ CATCH_SET(FALSE);
+ }
}
else {
cLOGOP->op_other = PL_op;
PL_markstack_ptr++;
redo_body:
- CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, FALSE);
+ CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, FALSE);
switch (ret) {
case 0:
retval = PL_stack_sp - (PL_stack_base + oldmark);
myop.op_flags |= OPf_SPECIAL;
redo_body:
- CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, TRUE);
+ CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, TRUE);
switch (ret) {
case 0:
retval = PL_stack_sp - (PL_stack_base + oldmark);
}
return s;
case 'D':
+ {
#ifdef DEBUGGING
forbid_setid("-D");
if (isALPHA(s[1])) {
}
PL_debug |= 0x80000000;
#else
- Perl_warn(aTHX_ "Recompile perl with -DDEBUGGING to use -D switch\n");
+ dTHR;
+ if (ckWARN_d(WARN_DEBUGGING))
+ Perl_warner(aTHX_ WARN_DEBUGGING,
+ "Recompile perl with -DDEBUGGING to use -D switch\n");
for (s++; isALNUM(*s); s++) ;
#endif
/*SUPPRESS 530*/
return s;
+ }
case 'h':
usage(PL_origargv[0]);
PerlProc_exit(0);
#else
# ifdef MULTIPLICITY
# define PERLVAR(var,type)
+# define PERLVARA(var,n,type)
# if defined(PERL_IMPLICIT_CONTEXT)
-# define PERLVARI(var,type,init) my_perl->var = init;
-# define PERLVARIC(var,type,init) my_perl->var = init;
+# if defined(USE_THREADS)
+# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
+# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
+# else /* !USE_THREADS */
+# define PERLVARI(var,type,init) aTHX->var = init;
+# define PERLVARIC(var,type,init) aTHX->var = init;
+# endif /* USE_THREADS */
# else
-# define PERLVARI(var,type,init) PL_curinterp->var = init;
-# define PERLVARIC(var,type,init) PL_curinterp->var = init;
+# 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_THREADS
# include "thrdvar.h"
# endif
# undef PERLVAR
+# undef PERLVARA
# undef PERLVARI
# undef PERLVARIC
# else
# define PERLVAR(var,type)
+# define PERLVARA(var,n,type)
# define PERLVARI(var,type,init) PL_##var = init;
# define PERLVARIC(var,type,init) PL_##var = init;
# include "intrpvar.h"
# include "thrdvar.h"
# endif
# undef PERLVAR
+# undef PERLVARA
# undef PERLVARI
# undef PERLVARIC
# endif
STATIC void
S_init_ids(pTHX)
{
- PL_uid = (int)PerlProc_getuid();
- PL_euid = (int)PerlProc_geteuid();
- PL_gid = (int)PerlProc_getgid();
- PL_egid = (int)PerlProc_getegid();
+ PL_uid = PerlProc_getuid();
+ PL_euid = PerlProc_geteuid();
+ PL_gid = PerlProc_getgid();
+ PL_egid = PerlProc_getegid();
#ifdef VMS
PL_uid |= PL_gid << 16;
PL_euid |= PL_egid << 16;
Perl_croak(aTHX_ "No %s allowed while running setgid", s);
}
-STATIC void
-S_init_debugger(pTHX)
+void
+Perl_init_debugger(pTHX)
{
dTHR;
+ HV *ostash = PL_curstash;
+
PL_curstash = PL_debstash;
PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
AvREAL_off(PL_dbargs);
PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
+ sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsingle, 0);
PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBtrace, 0);
PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsignal, 0);
- PL_curstash = PL_defstash;
+ PL_curstash = ostash;
}
#ifndef STRESS_REALLOC
dTHR;
GV *tmpgv;
GV *othergv;
+ IO *io;
sv_setpvn(get_sv("\"", TRUE), " ", 1);
PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
GvMULTI_on(PL_stdingv);
- IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
+ io = GvIOp(PL_stdingv);
+ IoIFP(io) = PerlIO_stdin();
tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
GvMULTI_on(tmpgv);
- GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
+ GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
GvMULTI_on(tmpgv);
- IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
+ io = GvIOp(tmpgv);
+ IoOFP(io) = IoIFP(io) = PerlIO_stdout();
setdefout(tmpgv);
tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
GvMULTI_on(tmpgv);
- GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
+ GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
- othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
- GvMULTI_on(othergv);
- IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
+ PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
+ GvMULTI_on(PL_stderrgv);
+ io = GvIOp(PL_stderrgv);
+ IoOFP(io) = IoIFP(io) = PerlIO_stderr();
tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
GvMULTI_on(tmpgv);
- GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
+ GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
PL_statname = NEWSV(66,0); /* last filename we did stat on */
incpush(SITELIB_EXP, FALSE);
#endif
#endif
+#if defined(PERL_VENDORLIB_EXP)
+#if defined(WIN32)
+ incpush(PERL_VENDORLIB_EXP, TRUE);
+#else
+ incpush(PERL_VENDORLIB_EXP, FALSE);
+#endif
+#endif
if (!PL_tainting)
incpush(".", FALSE);
}
sv_usepvn(libdir,unix,len);
}
else
- PerlIO_printf(PerlIO_stderr(),
+ PerlIO_printf(Perl_error_log,
"Failed to unixify @INC element \"%s\"\n",
SvPV(libdir,len));
#endif
STATIC struct perl_thread *
S_init_main_thread(pTHX)
{
-#ifndef PERL_IMPLICIT_CONTEXT
+#if !defined(PERL_IMPLICIT_CONTEXT)
struct perl_thread *thr;
#endif
XPV *xpv;
Newz(53, 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->errhv = newHV();
thr->flags = THRf_R_JOINABLE;
MUTEX_INIT(&thr->mutex);
/* Handcraft thrsv similarly to mess_sv */
(void) find_threadsv("@"); /* Ensure $@ is initialised early */
PL_maxscream = -1;
- PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp);
- PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags);
+ 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;
while (AvFILL(paramList) >= 0) {
cv = (CV*)av_shift(paramList);
SAVEFREESV(cv);
- CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_list_body), cv);
+ CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
switch (ret) {
case 0:
(void)SvPV(atsv, len);
LEAVE;
FREETMPS;
PL_curstash = PL_defstash;
- if (PL_endav)
+ if (PL_endav && !PL_minus_c)
call_list(oldscope, PL_endav);
PL_curcop = &PL_compiling;
PL_curcop->cop_line = oldline;
PL_curcop->cop_line = oldline;
JMPENV_JUMP(3);
}
- PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+ PerlIO_printf(Perl_error_log, "panic: restartop\n");
FREETMPS;
break;
}
#ifdef PERL_OBJECT
#define NO_XSLOCKS
-#endif /* PERL_OBJECT */
-
#include "XSUB.h"
+#endif
static I32
read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)