/* perl.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#endif
#endif
+static void
+S_init_tls_and_interp(PerlInterpreter *my_perl)
+{
+ if (!PL_curinterp) {
+ PERL_SET_INTERP(my_perl);
#if defined(USE_ITHREADS)
-# define INIT_TLS_AND_INTERP \
- STMT_START { \
- if (!PL_curinterp) { \
- PERL_SET_INTERP(my_perl); \
- INIT_THREADS; \
- ALLOC_THREAD_KEY; \
- PERL_SET_THX(my_perl); \
- OP_REFCNT_INIT; \
- MUTEX_INIT(&PL_dollarzero_mutex); \
- } \
- else { \
- PERL_SET_THX(my_perl); \
- } \
- } STMT_END
-#else
-# define INIT_TLS_AND_INTERP \
- STMT_START { \
- if (!PL_curinterp) { \
- PERL_SET_INTERP(my_perl); \
- } \
- PERL_SET_THX(my_perl); \
- } STMT_END
+ INIT_THREADS;
+ ALLOC_THREAD_KEY;
+ PERL_SET_THX(my_perl);
+ OP_REFCNT_INIT;
+ MUTEX_INIT(&PL_dollarzero_mutex);
# endif
+ }
+ else {
+ PERL_SET_THX(my_perl);
+ }
+}
#ifdef PERL_IMPLICIT_SYS
PerlInterpreter *
PerlInterpreter *my_perl;
/* New() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
- INIT_TLS_AND_INTERP;
+ S_init_tls_and_interp(my_perl);
Zero(my_perl, 1, PerlInterpreter);
PL_Mem = ipM;
PL_MemShared = ipMS;
perl_alloc(void)
{
PerlInterpreter *my_perl;
-#ifdef USE_5005THREADS
- dTHX;
-#endif
/* New() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
- INIT_TLS_AND_INTERP;
+ S_init_tls_and_interp(my_perl);
return ZeroD(my_perl, 1, PerlInterpreter);
}
#endif /* PERL_IMPLICIT_SYS */
#endif
/* Init the real globals (and main thread)? */
if (!PL_linestr) {
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
- PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
-#endif
-
PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
PL_linestr = NEWSV(65,79);
{
volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
HV *hv;
-#ifdef USE_5005THREADS
- dTHX;
-#endif /* USE_5005THREADS */
/* wait for all pseudo-forked children to finish */
PERL_WAIT_FOR_CHILDREN;
#endif
}
+#if defined(USE_5005THREADS) || 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) && !defined(__GNUC__)
+#pragma fini "perl_fini"
+#endif
+
+#if defined(__GNUC__) && defined(__attribute__)
+/* want to make sure __attribute__ works here even
+ * for -Dd_attribut=undef builds.
+ */
+#undef __attribute__
+#endif
+
+static void __attribute__((destructor))
+perl_fini()
+{
+ if (PL_curinterp)
+ FREE_THREAD_KEY;
+}
+
+#endif /* WIN32 */
+#endif /* THREADS */
+
void
Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
{
I32 oldscope;
int ret;
dJMPENV;
-#ifdef USE_5005THREADS
- dTHX;
-#endif
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
oldscope = PL_scopestack_ix;
PL_dowarn = G_WARN_OFF;
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
-#else
JMPENV_PUSH(ret);
-#endif
switch (ret) {
case 0:
-#ifndef PERL_FLEXIBLE_EXCEPTIONS
parse_body(env,xsinit);
-#endif
if (PL_checkav)
call_list(oldscope, PL_checkav);
ret = 0;
return ret;
}
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-STATIC void *
-S_vparse_body(pTHX_ va_list args)
-{
- char **env = va_arg(args, char**);
- XSINIT_t xsinit = va_arg(args, XSINIT_t);
-
- return parse_body(env, xsinit);
-}
-#endif
-
STATIC void *
S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
{
I32 oldscope;
int ret = 0;
dJMPENV;
-#ifdef USE_5005THREADS
- dTHX;
-#endif
oldscope = PL_scopestack_ix;
#ifdef VMS
VMSISH_HUSHED = 0;
#endif
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
- redo_body:
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
-#else
JMPENV_PUSH(ret);
-#endif
switch (ret) {
case 1:
cxstack_ix = -1; /* start context stack again */
goto redo_body;
case 0: /* normal completion */
-#ifndef PERL_FLEXIBLE_EXCEPTIONS
redo_body:
run_body(oldscope);
-#endif
/* FALL THROUGH */
case 2: /* my_exit() */
while (PL_scopestack_ix > oldscope)
return ret;
}
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-STATIC void *
-S_vrun_body(pTHX_ va_list args)
-{
- I32 oldscope = va_arg(args, I32);
-
- return run_body(oldscope);
-}
-#endif
-
STATIC void *
S_run_body(pTHX_ I32 oldscope)
}
PL_markstack_ptr++;
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
- redo_body:
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
- (OP*)&myop, FALSE);
-#else
JMPENV_PUSH(ret);
-#endif
switch (ret) {
case 0:
-#ifndef PERL_FLEXIBLE_EXCEPTIONS
redo_body:
call_body((OP*)&myop, FALSE);
-#endif
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR))
sv_setpv(ERRSV,"");
return retval;
}
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-STATIC void *
-S_vcall_body(pTHX_ va_list args)
-{
- OP *myop = va_arg(args, OP*);
- int is_eval = va_arg(args, int);
-
- call_body(myop, is_eval);
- return NULL;
-}
-#endif
-
STATIC void
S_call_body(pTHX_ OP *myop, int is_eval)
{
if (flags & G_KEEPERR)
myop.op_flags |= OPf_SPECIAL;
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
- redo_body:
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
- (OP*)&myop, TRUE);
-#else
/* fail now; otherwise we could fail after the JMPENV_PUSH but
* before a PUSHEVAL, which corrupts the stack after a croak */
TAINT_PROPER("eval_sv()");
JMPENV_PUSH(ret);
-#endif
switch (ret) {
case 0:
-#ifndef PERL_FLEXIBLE_EXCEPTIONS
redo_body:
call_body((OP*)&myop,TRUE);
-#endif
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR))
sv_setpv(ERRSV,"");
(void *)upg_version(PL_patchlevel);
#if !defined(DGUX)
PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ "\nThis is perl, v%_ built for %s",
+ Perl_form(aTHX_ "\nThis is perl, v%"SVf" built for %s",
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(),
- Perl_form(aTHX_ "\nThis is perl, v%_\n",
+ Perl_form(aTHX_ "\nThis is perl, v%"SVf"\n",
vstringify(PL_patchlevel)));
PerlIO_printf(PerlIO_stdout(),
Perl_form(aTHX_ " built under %s at %s %s\n",
SvREFCNT_dec(GvHV(gv));
GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
SvREADONLY_on(gv);
- HvNAME(PL_defstash) = savepv("main");
+ HvNAME(PL_defstash) = savepvn("main", 4);
PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
GvMULTI_on(PL_incgv);
PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
PL_suidscript = -1;
if (PL_e_script) {
- PL_origfilename = savepv("-e");
+ PL_origfilename = savepvn("-e", 2);
}
else {
/* if find_script() returns, it returns a malloc()-ed value */
CopFILE_free(PL_curcop);
CopFILE_set(PL_curcop, PL_origfilename);
- if (strEQ(PL_origfilename,"-"))
+ if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
scriptname = "";
if (PL_fdscript >= 0) {
PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
} else {
SAVEFREESV(cv);
}
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
-#else
JMPENV_PUSH(ret);
-#endif
switch (ret) {
case 0:
-#ifndef PERL_FLEXIBLE_EXCEPTIONS
call_list_body(cv);
-#endif
atsv = ERRSV;
(void)SvPV(atsv, len);
if (len) {
}
}
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-STATIC void *
-S_vcall_list_body(pTHX_ va_list args)
-{
- CV *cv = va_arg(args, CV*);
- return call_list_body(cv);
-}
-#endif
-
STATIC void *
S_call_list_body(pTHX_ CV *cv)
{