perl_construct(pTHXx)
{
dVAR;
- PERL_UNUSED_ARG(my_perl);
+ PERL_UNUSED_CONTEXT;
#ifdef MULTIPLICITY
init_interp();
PL_perl_destruct_level = 1;
int
Perl_nothreadhook(pTHX)
{
+ PERL_UNUSED_CONTEXT;
return 0;
}
pid_t child;
#endif
- PERL_UNUSED_ARG(my_perl);
+ PERL_UNUSED_CONTEXT;
/* wait for all pseudo-forked children to finish */
PERL_WAIT_FOR_CHILDREN;
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 = NULL;
PL_dirty = TRUE;
if(PL_rsfp) {
(void)PerlIO_close(PL_rsfp);
- PL_rsfp = Nullfp;
+ PL_rsfp = NULL;
}
/* Filters for program text */
perl_free(pTHXx)
{
#ifdef PERL_TRACK_MEMPOOL
- /* 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));
+ {
+ /*
+ * 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;
# else
#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"
#endif
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 = NULL;
# 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
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 */
int ret = 0;
dJMPENV;
- PERL_UNUSED_ARG(my_perl);
+ PERL_UNUSED_CONTEXT;
oldscope = PL_scopestack_ix;
#ifdef VMS
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);
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 NULL;
}
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_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 :
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;
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));
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
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);
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
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 */
}
}
-#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)
av_push(PL_checkav_save, (SV*)cv);
}
} else {
- SAVEFREESV(cv);
+ if (!PL_madskills)
+ SAVEFREESV(cv);
}
JMPENV_PUSH(ret);
switch (ret) {
case 0:
+#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);
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");
S_my_exit_jump(pTHX)
{
dVAR;
- register PERL_CONTEXT *cx;
- I32 gimme;
- SV **newsp;
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
}
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
projects / p5sagit/p5-mst-13.2.git / blobdiff