/* 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);
#endif
/* Use sysconf(_SC_CLK_TCK) if available, if not
- * available or if the sysconf() fails, use the HZ. */
-#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
+ * available or if the sysconf() fails, use the HZ.
+ * BeOS has those, but returns the wrong value. */
+#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
PL_clocktick = sysconf(_SC_CLK_TCK);
if (PL_clocktick <= 0)
#endif
{
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;
*/
#ifndef PERL_MICRO
#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
- if (environ != PL_origenviron
+ if (environ != PL_origenviron && !PL_use_safe_putenv
#ifdef USE_ITHREADS
/* only main thread can free environ[0] contents */
&& PL_curinterp == aTHX
#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)
{
++PL_exitlistlen;
}
+#ifdef HAS_PROCSELFEXE
+/* This is a function so that we don't hold on to MAXPATHLEN
+ bytes of stack longer than necessary
+ */
+STATIC void
+S_procself_val(pTHX_ SV *sv, char *arg0)
+{
+ char buf[MAXPATHLEN];
+ int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
+
+ /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
+ includes a spurious NUL which will cause $^X to fail in system
+ or backticks (this will prevent extensions from being built and
+ many tests from working). readlink is not meant to add a NUL.
+ Normal readlink works fine.
+ */
+ if (len > 0 && buf[len-1] == '\0') {
+ len--;
+ }
+
+ /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
+ returning the text "unknown" from the readlink rather than the path
+ to the executable (or returning an error from the readlink). Any valid
+ path has a '/' in it somewhere, so use that to validate the result.
+ See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
+ */
+ if (len > 0 && memchr(buf, '/', len)) {
+ sv_setpvn(sv,buf,len);
+ }
+ else {
+ sv_setpv(sv,arg0);
+ }
+}
+#endif /* HAS_PROCSELFEXE */
+
+STATIC void
+S_set_caret_X(pTHX) {
+ GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
+ if (tmpgv) {
+#ifdef HAS_PROCSELFEXE
+ S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
+#else
+#ifdef OS2
+ sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
+#else
+ sv_setpv(GvSV(tmpgv),PL_origargv[0]);
+#endif
+#endif
+ }
+}
+
/*
=for apidoc perl_parse
I32 oldscope;
int ret;
dJMPENV;
-#ifdef USE_5005THREADS
- dTHX;
-#endif
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
PL_do_undump = FALSE;
cxstack_ix = -1; /* start label stack again */
init_ids();
+ assert (!PL_tainted);
+ TAINT;
+ S_set_caret_X(aTHX);
+ TAINT_NOT;
init_postdump_symbols(argc,argv,env);
return 0;
}
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)
{
char *p;
STRLEN len = strlen(s);
p = savepvn(s, len);
- incpush(p, TRUE, TRUE, FALSE);
+ incpush(p, TRUE, TRUE, FALSE, FALSE);
sv_catpvn(sv, "-I", 2);
sv_catpvn(sv, p, len);
sv_catpvn(sv, " ", 1);
scriptname = "-";
}
+ /* Set $^X early so that it can be used for relocatable paths in @INC */
+ assert (!PL_tainted);
+ TAINT;
+ S_set_caret_X(aTHX);
+ TAINT_NOT;
init_perllib();
open_script(scriptname,dosearch,sv);
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,"");
p++;
} while (*p && *p != '-');
e = savepvn(s, e-s);
- incpush(e, TRUE, TRUE, FALSE);
+ incpush(e, TRUE, TRUE, FALSE, FALSE);
Safefree(e);
s = p;
if (*s == '-')
av_push(PL_preambleav, sv);
}
else
- Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
+ Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
return s;
case 'n':
PL_minus_n = TRUE;
(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);
/* Sanity check on buffer end */
while ((*s) && !isSPACE(*s)) s++;
for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
- (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
+ (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
+ || s2[-1] == '-')); s2--) ;
/* Sanity check on buffer start */
if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) &&
(s-9 < SvPV(PL_linestr,n_a)+2 || strnNE(s-9,"perl",4)) )
s2 = s;
while (*s == ' ' || *s == '\t') s++;
if (*s++ == '-') {
- while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
+ while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
+ || s2[-1] == '_') s2--;
if (strnEQ(s2-4,"perl",4))
/*SUPPRESS 530*/
while ((s = moreswitches(s)))
}
}
-#ifdef HAS_PROCSELFEXE
-/* This is a function so that we don't hold on to MAXPATHLEN
- bytes of stack longer than necessary
- */
-STATIC void
-S_procself_val(pTHX_ SV *sv, char *arg0)
-{
- char buf[MAXPATHLEN];
- int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
-
- /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
- includes a spurious NUL which will cause $^X to fail in system
- or backticks (this will prevent extensions from being built and
- many tests from working). readlink is not meant to add a NUL.
- Normal readlink works fine.
- */
- if (len > 0 && buf[len-1] == '\0') {
- len--;
- }
-
- /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
- returning the text "unknown" from the readlink rather than the path
- to the executable (or returning an error from the readlink). Any valid
- path has a '/' in it somewhere, so use that to validate the result.
- See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
- */
- if (len > 0 && memchr(buf, '/', len)) {
- sv_setpvn(sv,buf,len);
- }
- else {
- sv_setpv(sv,arg0);
- }
-}
-#endif /* HAS_PROCSELFEXE */
-
STATIC void
S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
{
magicname("0", "0", 1);
#endif
}
- if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
-#ifdef HAS_PROCSELFEXE
- S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
-#else
-#ifdef OS2
- sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
-#else
- sv_setpv(GvSV(tmpgv),PL_origargv[0]);
-#endif
-#endif
- }
if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
HV *hv;
GvMULTI_on(PL_envgv);
#ifndef VMS
s = PerlEnv_getenv("PERL5LIB");
if (s)
- incpush(s, TRUE, TRUE, TRUE);
+ incpush(s, TRUE, TRUE, TRUE, FALSE);
else
- incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
+ incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
#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,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
+ do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
else
- while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE);
+ while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
#endif /* VMS */
}
ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
*/
#ifdef APPLLIB_EXP
- incpush(APPLLIB_EXP, TRUE, TRUE, TRUE);
+ incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
#endif
#ifdef ARCHLIB_EXP
- incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE);
+ incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, 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, TRUE);
+ incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
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, TRUE);
+ incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
SvREFCNT_dec(privdir);
}
if (!PL_tainting)
- incpush(":", FALSE, FALSE, TRUE);
+ incpush(":", FALSE, FALSE, TRUE, FALSE);
#else
#ifndef PRIVLIB_EXP
# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
#endif
#if defined(WIN32)
- incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE);
+ incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
#else
- incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE);
+ incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, 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, TRUE);
+ incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
# endif
#endif
#ifdef SITELIB_EXP
# if defined(WIN32)
/* this picks up sitearch as well */
- incpush(SITELIB_EXP, TRUE, FALSE, TRUE);
+ incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
# else
- incpush(SITELIB_EXP, FALSE, FALSE, TRUE);
+ incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
# endif
#endif
#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
- incpush(SITELIB_STEM, FALSE, TRUE, TRUE);
+ incpush(SITELIB_STEM, FALSE, TRUE, 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, TRUE);
+ incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
# endif
#endif
#ifdef PERL_VENDORLIB_EXP
# if defined(WIN32)
- incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE); /* this picks up vendorarch as well */
+ incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE); /* this picks up vendorarch as well */
# else
- incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE);
+ incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
# endif
#endif
#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
- incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE);
+ incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
#endif
#ifdef PERL_OTHERLIBDIRS
- incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE);
+ incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
#endif
if (!PL_tainting)
- incpush(".", FALSE, FALSE, TRUE);
+ incpush(".", FALSE, FALSE, TRUE, FALSE);
#endif /* MACOS_TRADITIONAL */
}
# define PERLLIB_MANGLE(s,n) (s)
#endif
+/* Push a directory onto @INC if it exists.
+ Generate a new SV if we do this, to save needing to copy the SV we push
+ onto @INC */
+STATIC SV *
+S_incpush_if_exists(pTHX_ SV *dir)
+{
+ Stat_t tmpstatbuf;
+ if (PerlLIO_stat(SvPVX(dir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode)) {
+ av_push(GvAVn(PL_incgv), dir);
+ dir = NEWSV(0,0);
+ }
+ return dir;
+}
+
STATIC void
-S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
+S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep,
+ int canrelocate)
{
SV *subdir = Nullsv;
return;
if (addsubdirs || addoldvers) {
- subdir = sv_newmortal();
+ subdir = NEWSV(0,0);
}
/* Break at all separators */
sv_catpv(libdir, ":");
#endif
+#ifdef PERL_RELOCATABLE_INC
+ /*
+ * Relocatable include entries are marked with a leading .../
+ *
+ * The algorithm is
+ * 0: Remove that leading ".../"
+ * 1: Remove trailing executable name (anything after the last '/')
+ * from the perl path to give a perl prefix
+ * Then
+ * While the @INC element starts "../" and the prefix ends with a real
+ * directory (ie not . or ..) chop that real directory off the prefix
+ * and the leading "../" from the @INC element. ie a logical "../"
+ * cleanup
+ * Finally concatenate the prefix and the remainder of the @INC element
+ * The intent is that /usr/local/bin/perl and .../../lib/perl5
+ * generates /usr/local/lib/perl5
+ */
+ {
+ char *libpath = SvPVX(libdir);
+ STRLEN libpath_len = SvCUR(libdir);
+ if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
+ /* Game on! */
+ SV *caret_X = get_sv("\030", 0);
+ /* Going to use the SV just as a scratch buffer holding a C
+ string: */
+ SV *prefix_sv;
+ char *prefix;
+ char *lastslash;
+
+ /* $^X is *the* source of taint if tainting is on, hence
+ SvPOK() won't be true. */
+ assert(caret_X);
+ assert(SvPOKp(caret_X));
+ prefix_sv = newSVpvn(SvPVX(caret_X), SvCUR(caret_X));
+ /* Firstly take off the leading .../
+ If all else fail we'll do the paths relative to the current
+ directory. */
+ sv_chop(libdir, libpath + 4);
+ /* Don't use SvPV as we're intentionally bypassing taining,
+ mortal copies that the mg_get of tainting creates, and
+ corruption that seems to come via the save stack.
+ I guess that the save stack isn't correctly set up yet. */
+ libpath = SvPVX(libdir);
+ libpath_len = SvCUR(libdir);
+
+ /* This would work more efficiently with memrchr, but as it's
+ only a GNU extension we'd need to probe for it and
+ implement our own. Not hard, but maybe not worth it? */
+
+ prefix = SvPVX(prefix_sv);
+ lastslash = strrchr(prefix, '/');
+
+ /* First time in with the *lastslash = '\0' we just wipe off
+ the trailing /perl from (say) /usr/foo/bin/perl
+ */
+ if (lastslash) {
+ SV *tempsv;
+ while ((*lastslash = '\0'), /* Do that, come what may. */
+ (libpath_len >= 3 && memEQ(libpath, "../", 3)
+ && (lastslash = strrchr(prefix, '/')))) {
+ if (lastslash[1] == '\0'
+ || (lastslash[1] == '.'
+ && (lastslash[2] == '/' /* ends "/." */
+ || (lastslash[2] == '/'
+ && lastslash[3] == '/' /* or "/.." */
+ )))) {
+ /* Prefix ends "/" or "/." or "/..", any of which
+ are fishy, so don't do any more logical cleanup.
+ */
+ break;
+ }
+ /* Remove leading "../" from path */
+ libpath += 3;
+ libpath_len -= 3;
+ /* Next iteration round the loop removes the last
+ directory name from prefix by writing a '\0' in
+ the while clause. */
+ }
+ /* prefix has been terminated with a '\0' to the correct
+ length. libpath points somewhere into the libdir SV.
+ We need to join the 2 with '/' and drop the result into
+ libdir. */
+ tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
+ SvREFCNT_dec(libdir);
+ /* And this is the new libdir. */
+ libdir = tempsv;
+ if (PL_tainting &&
+ (PL_uid != PL_euid || PL_gid != PL_egid)) {
+ /* Need to taint reloccated paths if running set ID */
+ SvTAINTED_on(libdir);
+ }
+ }
+ SvREFCNT_dec(prefix_sv);
+ }
+ }
+#endif
/*
* BEFORE pushing libdir onto @INC we may first push version- and
* archname-specific sub-directories.
const char *incverlist[] = { PERL_INC_VERSION_LIST };
const char **incver;
#endif
- Stat_t tmpstatbuf;
#ifdef VMS
char *unix;
STRLEN len;
libdir,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION, ARCHNAME);
- if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
- S_ISDIR(tmpstatbuf.st_mode))
- av_push(GvAVn(PL_incgv), newSVsv(subdir));
+ subdir = S_incpush_if_exists(aTHX_ subdir);
/* .../version if -d .../version */
Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION);
- if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
- S_ISDIR(tmpstatbuf.st_mode))
- av_push(GvAVn(PL_incgv), newSVsv(subdir));
+ subdir = S_incpush_if_exists(aTHX_ subdir);
/* .../archname if -d .../archname */
Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
- if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
- S_ISDIR(tmpstatbuf.st_mode))
- av_push(GvAVn(PL_incgv), newSVsv(subdir));
+ subdir = S_incpush_if_exists(aTHX_ subdir);
+
}
#ifdef PERL_INC_VERSION_LIST
for (incver = incverlist; *incver; incver++) {
/* .../xxx if -d .../xxx */
Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
- if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
- S_ISDIR(tmpstatbuf.st_mode))
- av_push(GvAVn(PL_incgv), newSVsv(subdir));
+ subdir = S_incpush_if_exists(aTHX_ subdir);
}
}
#endif
/* finally push this lib directory on the end of @INC */
av_push(GvAVn(PL_incgv), libdir);
}
+ if (subdir) {
+ assert (SvREFCNT(subdir) == 1);
+ SvREFCNT_dec(subdir);
+ }
}
#ifdef USE_5005THREADS
} 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)
{
projects / p5sagit/p5-mst-13.2.git / blobdiff