#ifdef NETWARE
#include "nwutil.h"
-char *nw_get_sitelib(const char *pl);
#endif
/* XXX If this causes problems, set i_unistd=undef in the hint file. */
return ret;
}
-#define INCPUSH_ADD_SUB_DIRS 0x01
-#define INCPUSH_ADD_OLD_VERS 0x02
-#define INCPUSH_NOT_BASEDIR 0x04
-#define INCPUSH_CAN_RELOCATE 0x08
-#define INCPUSH_UNSHIFT 0x10
+#define INCPUSH_UNSHIFT 0x01
+#define INCPUSH_ADD_OLD_VERS 0x02
+#define INCPUSH_ADD_VERSIONED_SUB_DIRS 0x04
+#define INCPUSH_ADD_ARCHONLY_SUB_DIRS 0x08
+#define INCPUSH_NOT_BASEDIR 0x10
+#define INCPUSH_CAN_RELOCATE 0x20
+#define INCPUSH_ADD_SUB_DIRS \
+ (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
STATIC void *
S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
TAINT;
S_set_caret_X(aTHX);
TAINT_NOT;
- init_perllib(0);
- init_perllib(INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
+ init_perllib();
{
bool suidscript = FALSE;
}
STATIC void
-S_init_perllib(pTHX_ U32 old_vers)
+S_init_perllib(pTHX)
{
dVAR;
- char *s;
+#ifndef VMS
+ const char *perl5lib = NULL;
+#endif
+ const char *s;
+#ifdef WIN32
+ STRLEN len;
+#endif
+
if (!PL_tainting) {
#ifndef VMS
- s = PerlEnv_getenv("PERL5LIB");
+ perl5lib = PerlEnv_getenv("PERL5LIB");
/*
* It isn't possible to delete an environment variable with
* PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
* case we treat PERL5LIB as undefined if it has a zero-length value.
*/
#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
- if (s && *s != '\0')
+ if (perl5lib && *perl5lib != '\0')
#else
- if (s)
+ if (perl5lib)
#endif
- incpush_use_sep(s, old_vers ? old_vers : INCPUSH_ADD_SUB_DIRS);
- else if (!old_vers) {
+ incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
+ else {
s = PerlEnv_getenv("PERLLIB");
if (s)
- incpush_use_sep(s, 0);
+ incpush_use_sep(s, 0, 0);
}
#else /* VMS */
/* Treat PERL5?LIB as a possible search list logical name -- the
int idx = 0;
if (my_trnlnm("PERL5LIB",buf,0))
do {
- incpush_use_sep(buf, old_vers ? old_vers : INCPUSH_ADD_SUB_DIRS);
+ incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
} while (my_trnlnm("PERL5LIB",buf,++idx));
- else if (!old_vers)
+ else if
while (my_trnlnm("PERLLIB",buf,idx++))
- incpush_use_sep(buf, 0);
+ incpush_use_sep(buf, 0, 0);
#endif /* VMS */
}
ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
*/
#ifdef APPLLIB_EXP
- if (!old_vers) {
- incpush_use_sep(APPLLIB_EXP, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
- } else {
- incpush_use_sep(APPLLIB_EXP, old_vers|INCPUSH_CAN_RELOCATE);
- }
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
+ INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
#endif
- if (!old_vers) {
#ifdef MACOS_TRADITIONAL
+ {
Stat_t tmpstatbuf;
SV * privdir = newSV(0);
char * macperl = PerlEnv_getenv("MACPERL");
macperl = "";
# ifdef ARCHLIB_EXP
- if (!old_vers)
- incpush_use_sep(ARCHLIB_EXP, INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
# endif
Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
- incpush_use_sep(SvPVX(privdir), INCPUSH_ADD_SUB_DIRS);
+ incpush_use_sep(SvPVX(privdir), SvCUR(privdir),
+ INCPUSH_ADD_SUB_DIRS);
Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
- if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
- incpush_use_sep(SvPVX(privdir), INCPUSH_ADD_SUB_DIRS);
+ if (PerlLIO_stat(SvPVX(privdir), SvCUR(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
+ incpush_use_sep(SvPVX(privdir), SvCUR(privdir),
+ INCPUSH_ADD_SUB_DIRS);
SvREFCNT_dec(privdir);
if (!PL_tainting)
S_incpush(aTHX_ STR_WITH_LEN(":"), 0);
+ }
#else
-
#ifdef SITEARCH_EXP
/* sitearch is always relative to sitelib on Windows for
* DLL-based path intuition to work correctly */
# if !defined(WIN32)
- incpush_use_sep(SITEARCH_EXP, INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
+ INCPUSH_CAN_RELOCATE);
# endif
#endif
#ifdef SITELIB_EXP
# if defined(WIN32)
/* this picks up sitearch as well */
- s = win32_get_sitelib(PERL_FS_VERSION);
+ s = win32_get_sitelib(PERL_FS_VERSION, &len);
if (s)
- incpush_use_sep(s, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
+ incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
# else
- incpush_use_sep(SITELIB_EXP, INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
# endif
#endif
- }
-
-#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
- /* Search for version-specific dirs below here */
- incpush_use_sep(SITELIB_STEM, old_vers|INCPUSH_CAN_RELOCATE);
-#endif
- if (!old_vers) {
#ifdef PERL_VENDORARCH_EXP
/* vendorarch is always relative to vendorlib on Windows for
* DLL-based path intuition to work correctly */
# if !defined(WIN32)
- incpush_use_sep(PERL_VENDORARCH_EXP, INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
+ INCPUSH_CAN_RELOCATE);
# endif
#endif
#ifdef PERL_VENDORLIB_EXP
# if defined(WIN32)
/* this picks up vendorarch as well */
- s = win32_get_vendorlib(PERL_FS_VERSION);
+ s = win32_get_vendorlib(PERL_FS_VERSION, &len);
if (s)
- incpush_use_sep(s, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
+ incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
# else
- incpush_use_sep(PERL_VENDORLIB_EXP, INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
+ INCPUSH_CAN_RELOCATE);
# endif
#endif
- }
-
-#if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
- /* Search for version-specific dirs below here */
- incpush_use_sep(PERL_VENDORLIB_STEM, old_vers|INCPUSH_CAN_RELOCATE);
-#endif
- if (!old_vers) {
#ifdef ARCHLIB_EXP
- incpush_use_sep(ARCHLIB_EXP, INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
#endif
#ifndef PRIVLIB_EXP
#endif
#if defined(WIN32)
- s = win32_get_privlib(PERL_FS_VERSION);
- if (s)
- incpush_use_sep(s, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
+ s = win32_get_privlib(PERL_FS_VERSION, &len);
+ if (s)
+ incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
#else
- incpush_use_sep(PRIVLIB_EXP, INCPUSH_CAN_RELOCATE);
+# ifdef NETWARE
+ S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
+# else
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
+# endif
#endif
- }
#ifdef PERL_OTHERLIBDIRS
- if (!old_vers) {
- incpush_use_sep(PERL_OTHERLIBDIRS, INCPUSH_ADD_SUB_DIRS
- |INCPUSH_CAN_RELOCATE);
- } else {
- incpush_use_sep(PERL_OTHERLIBDIRS, old_vers|INCPUSH_CAN_RELOCATE);
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
+ INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
+ |INCPUSH_CAN_RELOCATE);
+#endif
+#endif /* MACOS_TRADITIONAL */
+
+ if (!PL_tainting) {
+#ifndef VMS
+/*
+ * It isn't possible to delete an environment variable with
+ * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
+ * case we treat PERL5LIB as undefined if it has a zero-length value.
+ */
+#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
+ if (perl5lib && *perl5lib != '\0')
+#else
+ if (perl5lib)
+#endif
+ incpush_use_sep(perl5lib, 0,
+ INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
+#else /* VMS */
+ /* Treat PERL5?LIB as a possible search list logical name -- the
+ * "natural" VMS idiom for a Unix path string. We allow each
+ * element to be a set of |-separated directories for compatibility.
+ */
+ char buf[256];
+ int idx = 0;
+ if (my_trnlnm("PERL5LIB",buf,0))
+ do {
+ incpush_use_sep(buf, 0,
+ INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
+ } while (my_trnlnm("PERL5LIB",buf,++idx));
+#endif /* VMS */
}
+
+/* Use the ~-expanded versions of APPLLIB (undocumented),
+ ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
+*/
+#ifdef APPLLIB_EXP
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
+ |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
+#endif
+
+#ifndef MACOS_TRADITIONAL
+#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
+ /* Search for version-specific dirs below here */
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
+ INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
#endif
- /* old_vers should be true, so that this last of all. */
- if (!PL_tainting && old_vers)
+
+#if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
+ /* Search for version-specific dirs below here */
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
+ INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
+#endif
+
+#ifdef PERL_OTHERLIBDIRS
+ S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
+ INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
+ |INCPUSH_CAN_RELOCATE);
+#endif
+
+ if (!PL_tainting)
S_incpush(aTHX_ STR_WITH_LEN("."), 0);
#endif /* MACOS_TRADITIONAL */
}
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_ AV *const av, SV *dir)
+S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
{
dVAR;
Stat_t tmpstatbuf;
if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode)) {
av_push(av, dir);
- dir = newSV(0);
+ dir = newSVsv(stem);
+ } else {
+ /* Truncate dir back to stem. */
+ SvCUR_set(dir, SvCUR(stem));
}
return dir;
}
S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
{
dVAR;
- const U8 addsubdirs = (U8)flags & INCPUSH_ADD_SUB_DIRS;
+ const U8 using_sub_dirs
+ = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
+ |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
+ const U8 add_versioned_sub_dirs
+ = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
+ const U8 add_archonly_sub_dirs
+ = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS;
const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
const U8 unshift = (U8)flags & INCPUSH_UNSHIFT;
const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
- SV *subdir = NULL;
- AV *inc;
-
- if (!dir || !*dir)
- return;
-
- inc = GvAVn(PL_incgv);
+ AV *const inc = GvAVn(PL_incgv);
- if (addsubdirs || addoldvers) {
- subdir = newSV(0);
- }
+ PERL_ARGS_ASSERT_INCPUSH;
+ assert(len > 0);
+ /* Could remove this vestigial extra block, if we don't mind a lot of
+ re-indenting diff noise. */
{
SV *libdir;
/* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
pushing. Hence to make it work, need to push the architecture
(etc) libraries onto a temporary array, then "unshift" that onto
the front of @INC. */
- AV *const av
- = (addsubdirs || addoldvers) ? (unshift ? newAV() : inc) : NULL;
+ AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
if (len) {
/* I am not convinced that this is valid when PERLLIB_MANGLE is
* BEFORE pushing libdir onto @INC we may first push version- and
* archname-specific sub-directories.
*/
- if (addsubdirs || addoldvers) {
+ if (using_sub_dirs) {
+ SV *subdir;
#ifdef PERL_INC_VERSION_LIST
/* Configure terminates PERL_INC_VERSION_LIST with a NULL */
const char * const incverlist[] = { PERL_INC_VERSION_LIST };
char *unix;
STRLEN len;
+
if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
len = strlen(unix);
while (unix[len-1] == '/') len--; /* Cosmetic */
"Failed to unixify @INC element \"%s\"\n",
SvPV(libdir,len));
#endif
- if (addsubdirs) {
+
+ subdir = newSVsv(libdir);
+
+ if (add_versioned_sub_dirs) {
#ifdef MACOS_TRADITIONAL
#define PERL_ARCH_FMT_PREFIX ""
#define PERL_ARCH_FMT_SUFFIX ":"
#define PERL_ARCH_FMT_PATH "/" PERL_FS_VERSION
#endif
/* .../version/archname if -d .../version/archname */
- sv_setsv(subdir, libdir);
sv_catpvs(subdir, PERL_ARCH_FMT_PATH \
PERL_ARCH_FMT_PREFIX ARCHNAME PERL_ARCH_FMT_SUFFIX);
- subdir = S_incpush_if_exists(aTHX_ av, subdir);
+ subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
/* .../version if -d .../version */
- sv_setsv(subdir, libdir);
sv_catpvs(subdir, PERL_ARCH_FMT_PATH);
- subdir = S_incpush_if_exists(aTHX_ av, subdir);
-
- /* .../archname if -d .../archname */
- sv_setsv(subdir, libdir);
- sv_catpvs(subdir,
- PERL_ARCH_FMT_PREFIX ARCHNAME PERL_ARCH_FMT_SUFFIX);
- subdir = S_incpush_if_exists(aTHX_ av, subdir);
-
+ subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
}
#ifdef PERL_INC_VERSION_LIST
if (addoldvers) {
for (incver = incverlist; *incver; incver++) {
/* .../xxx if -d .../xxx */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PREFIX \
- "%s" PERL_ARCH_FMT_SUFFIX,
- SVfARG(libdir), *incver);
- subdir = S_incpush_if_exists(aTHX_ av, subdir);
+ Perl_sv_catpvf(aTHX_ subdir, PERL_ARCH_FMT_PREFIX \
+ "%s" PERL_ARCH_FMT_SUFFIX, *incver);
+ subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
}
}
#endif
+
+ if (add_archonly_sub_dirs) {
+ /* .../archname if -d .../archname */
+ sv_catpvs(subdir,
+ PERL_ARCH_FMT_PREFIX ARCHNAME PERL_ARCH_FMT_SUFFIX);
+ subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
+
+ }
+
+ assert (SvREFCNT(subdir) == 1);
+ SvREFCNT_dec(subdir);
}
/* finally add this lib directory at the end of @INC */
SvREFCNT_dec(libdir);
}
}
- if (subdir) {
- assert (SvREFCNT(subdir) == 1);
- SvREFCNT_dec(subdir);
- }
}
STATIC void
-S_incpush_use_sep(pTHX_ const char *p, U32 flags)
+S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
{
+ const char *s;
+ const char *end;
/* This logic has been broken out from S_incpush(). It may be possible to
simplify it. */
PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
+ if (!len)
+ len = strlen(p);
+
+ end = p + len;
+
/* Break at all separators */
- while (*p) {
- const char *s;
+ while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
+ if (s == p) {
+ /* skip any consecutive separators */
- /* skip any consecutive separators */
- while ( *p == PERLLIB_SEP ) {
/* Uncomment the next line for PATH semantics */
+ /* But you'll need to write tests */
/* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
- p++;
- }
-
- if ((s = strchr(p, PERLLIB_SEP)) != NULL ) {
+ } else {
incpush(p, (STRLEN)(s - p), flags);
- p = s + 1;
- }
- else {
- incpush(p, 0, flags);
- return;
}
+ p = s + 1;
}
+ if (p != end)
+ incpush(p, (STRLEN)(end - p), flags);
+
}
void
projects / p5sagit/p5-mst-13.2.git / blobdiff