#endif
#endif
-#if defined(USE_5005THREADS)
-# define INIT_TLS_AND_INTERP \
- STMT_START { \
- if (!PL_curinterp) { \
- PERL_SET_INTERP(my_perl); \
- INIT_THREADS; \
- ALLOC_THREAD_KEY; \
- } \
- } STMT_END
-#else
-# if defined(USE_ITHREADS)
+#if defined(USE_ITHREADS)
# define INIT_TLS_AND_INTERP \
STMT_START { \
if (!PL_curinterp) { \
PERL_SET_THX(my_perl); \
} \
} STMT_END
-# else
+#else
# define INIT_TLS_AND_INTERP \
STMT_START { \
if (!PL_curinterp) { \
PERL_SET_THX(my_perl); \
} STMT_END
# endif
-#endif
#ifdef PERL_IMPLICIT_SYS
PerlInterpreter *
void
perl_construct(pTHXx)
{
-#ifdef USE_5005THREADS
-#ifndef FAKE_THREADS
- struct perl_thread *thr = NULL;
-#endif /* FAKE_THREADS */
-#endif /* USE_5005THREADS */
-
#ifdef MULTIPLICITY
init_interp();
PL_perl_destruct_level = 1;
/* Init the real globals (and main thread)? */
if (!PL_linestr) {
-#ifdef USE_5005THREADS
- MUTEX_INIT(&PL_sv_mutex);
- /*
- * Safe to use basic SV functions from now on (though
- * not things like mortals or tainting yet).
- */
- MUTEX_INIT(&PL_eval_mutex);
- COND_INIT(&PL_eval_cond);
- MUTEX_INIT(&PL_threads_mutex);
- COND_INIT(&PL_nthreads_cond);
-# ifdef EMULATE_ATOMIC_REFCOUNTS
- MUTEX_INIT(&PL_svref_mutex);
-# endif /* EMULATE_ATOMIC_REFCOUNTS */
-
- MUTEX_INIT(&PL_cred_mutex);
- MUTEX_INIT(&PL_sv_lock_mutex);
- MUTEX_INIT(&PL_fdpid_mutex);
-
- thr = init_main_thread();
-#endif /* USE_5005THREADS */
-
#ifdef PERL_FLEXIBLE_EXCEPTIONS
PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
#endif
It is properly deallocated in perl_destruct() */
PL_strtab = newHV();
-#ifdef USE_5005THREADS
- MUTEX_INIT(&PL_strtab_mutex);
-#endif
HvSHAREKEYS_off(PL_strtab); /* mandatory */
hv_ksplit(PL_strtab, 512);
volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
HV *hv;
#ifdef USE_5005THREADS
- Thread t;
dTHX;
#endif /* USE_5005THREADS */
/* wait for all pseudo-forked children to finish */
PERL_WAIT_FOR_CHILDREN;
-#ifdef USE_5005THREADS
-#ifndef FAKE_THREADS
- /* Pass 1 on any remaining threads: detach joinables, join zombies */
- retry_cleanup:
- MUTEX_LOCK(&PL_threads_mutex);
- 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) {
- MUTEX_LOCK(&t->mutex);
- switch (ThrSTATE(t)) {
- AV *av;
- case THRf_ZOMBIE:
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "perl_destruct: joining zombie %p\n", t));
- ThrSETSTATE(t, THRf_DEAD);
- MUTEX_UNLOCK(&t->mutex);
- PL_nthreads--;
- /*
- * The SvREFCNT_dec below may take a long time (e.g. av
- * may contain an object scalar whose destructor gets
- * called) so we have to unlock threads_mutex and start
- * all over again.
- */
- MUTEX_UNLOCK(&PL_threads_mutex);
- JOIN(t, &av);
- SvREFCNT_dec((SV*)av);
- 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(Perl_debug_log,
- "perl_destruct: detaching thread %p\n", t));
- ThrSETSTATE(t, THRf_R_DETACHED);
- /*
- * We unlock threads_mutex and t->mutex in the opposite order
- * from which we locked them just so that DETACH won't
- * deadlock if it panics. It's only a breach of good style
- * not a bug since they are unlocks not locks.
- */
- MUTEX_UNLOCK(&PL_threads_mutex);
- DETACH(t);
- MUTEX_UNLOCK(&t->mutex);
- goto retry_cleanup;
- default:
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "perl_destruct: ignoring %p (state %u)\n",
- t, ThrSTATE(t)));
- MUTEX_UNLOCK(&t->mutex);
- /* fall through and out */
- }
- }
- /* We leave the above "Pass 1" loop with threads_mutex still locked */
-
- /* Pass 2 on remaining threads: wait for the thread count to drop to one */
- while (PL_nthreads > 1)
- {
- 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(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
- MUTEX_DESTROY(&PL_threads_mutex);
- COND_DESTROY(&PL_nthreads_cond);
- PL_nthreads--;
-#endif /* !defined(FAKE_THREADS) */
-#endif /* USE_5005THREADS */
-
destruct_level = PL_perl_destruct_level;
#ifdef DEBUGGING
{
/* Destroy the main CV and syntax tree */
if (PL_main_root) {
- PAD_UPDATE_CURPAD;
op_free(PL_main_root);
PL_main_root = Nullop;
}
if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
+#ifdef DEBUG_LEAKING_SCALARS
+ if (PL_sv_count != 0) {
+ SV* sva;
+ SV* sv;
+ register SV* svend;
+
+ for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
+ svend = &sva[SvREFCNT(sva)];
+ for (sv = sva + 1; sv < svend; ++sv) {
+ if (SvTYPE(sv) != SVTYPEMASK) {
+ PerlIO_printf(Perl_debug_log, "leaked: 0x%p\n", sv);
+ }
+ }
+ }
+ }
+#endif
+
+
#if defined(PERLIO_LAYERS)
/* No more IO - including error messages ! */
PerlIO_cleanup(aTHX);
PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
DEBUG_P(debprofdump());
-#ifdef USE_5005THREADS
- MUTEX_DESTROY(&PL_strtab_mutex);
- MUTEX_DESTROY(&PL_sv_mutex);
- MUTEX_DESTROY(&PL_eval_mutex);
- MUTEX_DESTROY(&PL_cred_mutex);
- MUTEX_DESTROY(&PL_fdpid_mutex);
- COND_DESTROY(&PL_eval_cond);
-#ifdef EMULATE_ATOMIC_REFCOUNTS
- MUTEX_DESTROY(&PL_svref_mutex);
-#endif /* EMULATE_ATOMIC_REFCOUNTS */
-
- /* As the penultimate thing, free the non-arena SV for thrsv */
- Safefree(SvPVX(PL_thrsv));
- Safefree(SvANY(PL_thrsv));
- Safefree(PL_thrsv);
- PL_thrsv = Nullsv;
-#endif /* USE_5005THREADS */
#ifdef USE_REENTRANT_API
Perl_reentrant_free(aTHX);
}
if (PL_main_root) {
- PAD_UPDATE_CURPAD;
op_free(PL_main_root);
PL_main_root = Nullop;
}
char *p;
STRLEN len = strlen(s);
p = savepvn(s, len);
- incpush(p, TRUE, TRUE);
+ incpush(p, TRUE, TRUE, FALSE);
sv_catpvn(sv, "-I", 2);
sv_catpvn(sv, p, len);
sv_catpvn(sv, " ", 1);
}
}
switch_end:
+ sv_setsv(get_sv("/", TRUE), PL_rs);
if (
#ifndef SECURE_INTERNAL_GETENV
PL_e_script = Nullsv;
}
-/*
- Not sure that this is still the right place to do this now that we
- no longer use PL_nrs. HVDS 2001/09/09
-*/
- sv_setsv(get_sv("/", TRUE), PL_rs);
-
if (PL_do_undump)
my_unexec();
p++;
} while (*p && *p != '-');
e = savepvn(s, e-s);
- incpush(e, TRUE, TRUE);
+ incpush(e, TRUE, TRUE, FALSE);
Safefree(e);
s = p;
if (*s == '-')
#ifndef VMS
s = PerlEnv_getenv("PERL5LIB");
if (s)
- incpush(s, TRUE, TRUE);
+ incpush(s, TRUE, TRUE, TRUE);
else
- incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
+ incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
#else /* VMS */
/* Treat PERL5?LIB as a possible search list logical name -- the
* "natural" VMS idiom for a Unix path string. We allow each
char buf[256];
int idx = 0;
if (my_trnlnm("PERL5LIB",buf,0))
- do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
+ do { incpush(buf,TRUE,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
else
- while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
+ while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE);
#endif /* VMS */
}
ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
*/
#ifdef APPLLIB_EXP
- incpush(APPLLIB_EXP, TRUE, TRUE);
+ incpush(APPLLIB_EXP, TRUE, TRUE, TRUE);
#endif
#ifdef ARCHLIB_EXP
- incpush(ARCHLIB_EXP, FALSE, FALSE);
+ incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE);
#endif
#ifdef MACOS_TRADITIONAL
{
Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
- incpush(SvPVX(privdir), TRUE, FALSE);
+ incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
- incpush(SvPVX(privdir), TRUE, FALSE);
+ incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
SvREFCNT_dec(privdir);
}
if (!PL_tainting)
- incpush(":", FALSE, FALSE);
+ incpush(":", FALSE, FALSE, TRUE);
#else
#ifndef PRIVLIB_EXP
# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
#endif
#if defined(WIN32)
- incpush(PRIVLIB_EXP, TRUE, FALSE);
+ incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE);
#else
- incpush(PRIVLIB_EXP, FALSE, FALSE);
+ incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE);
#endif
#ifdef SITEARCH_EXP
/* sitearch is always relative to sitelib on Windows for
* DLL-based path intuition to work correctly */
# if !defined(WIN32)
- incpush(SITEARCH_EXP, FALSE, FALSE);
+ incpush(SITEARCH_EXP, FALSE, FALSE, TRUE);
# endif
#endif
#ifdef SITELIB_EXP
# if defined(WIN32)
- incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
+ /* this picks up sitearch as well */
+ incpush(SITELIB_EXP, TRUE, FALSE, TRUE);
# else
- incpush(SITELIB_EXP, FALSE, FALSE);
+ incpush(SITELIB_EXP, FALSE, FALSE, TRUE);
# endif
#endif
#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
- incpush(SITELIB_STEM, FALSE, TRUE);
+ incpush(SITELIB_STEM, FALSE, TRUE, TRUE);
#endif
#ifdef PERL_VENDORARCH_EXP
/* vendorarch is always relative to vendorlib on Windows for
* DLL-based path intuition to work correctly */
# if !defined(WIN32)
- incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
+ incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE);
# endif
#endif
#ifdef PERL_VENDORLIB_EXP
# if defined(WIN32)
- incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
+ incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE); /* this picks up vendorarch as well */
# else
- incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
+ incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE);
# endif
#endif
#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
- incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
+ incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE);
#endif
#ifdef PERL_OTHERLIBDIRS
- incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
+ incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE);
#endif
if (!PL_tainting)
- incpush(".", FALSE, FALSE);
+ incpush(".", FALSE, FALSE, TRUE);
#endif /* MACOS_TRADITIONAL */
}
#endif
STATIC void
-S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
+S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
{
SV *subdir = Nullsv;
char *s;
/* skip any consecutive separators */
- while ( *p == PERLLIB_SEP ) {
- /* Uncomment the next line for PATH semantics */
- /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
- p++;
+ if (usesep) {
+ while ( *p == PERLLIB_SEP ) {
+ /* Uncomment the next line for PATH semantics */
+ /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
+ p++;
+ }
}
- if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
+ if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
(STRLEN)(s - p));
p = s + 1;
projects / p5sagit/p5-mst-13.2.git / blobdiff