summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNicholas Clark <nick@ccl4.org>2004-12-23 21:38:59 +0000
committerNicholas Clark <nick@ccl4.org>2004-12-23 21:38:59 +0000
commit88fe16b231aae255ffd6ec9561af9af9f6edf830 (patch)
treeb6af595c0746525fa76d62e9c9f4d510ef2e5a4b
parent61f8421a3d7b1939452060412f2889c378aae8ed (diff)
downloadperl-88fe16b231aae255ffd6ec9561af9af9f6edf830.tar.gz
Relocatable @INC entries for Unix.
(With appropriate fixups in Config.pm to complete the illusion) Currently can only be enabled with hackery to config.sh TODO - proper Configure support, and support for otherlibdirs in Config.pm p4raw-id: //depot/perl@23674
-rw-r--r--Porting/Glossary7
-rw-r--r--config_h.SH6
-rwxr-xr-xconfigpm72
-rw-r--r--embed.fnc2
-rw-r--r--embed.h2
-rw-r--r--perl.c145
-rw-r--r--proto.h2
7 files changed, 209 insertions, 27 deletions
diff --git a/Porting/Glossary b/Porting/Glossary
index e70ce3e4af..41eec75fd9 100644
--- a/Porting/Glossary
+++ b/Porting/Glossary
@@ -4657,6 +4657,13 @@ usereentrant (usethreads.U):
meaningful if usethreads is set and is very experimental, it is
not even prompted for.
+userelocatableinc (XXX.U):
+ This variable is set to true to indicate that perl should relocate
+ @INC entries at runtime based on the path to the perl binary.
+ Any @INC paths starting ".../" are relocated relative to the directory
+ containing the perl binary, and a logical cleanup of the path is then
+ made around the join point (removing "dir/../" pairs)
+
usesfio (d_sfio.U):
This variable is set to true when the user agrees to use sfio.
It is set to false when sfio is not available or when the user
diff --git a/config_h.SH b/config_h.SH
index 472b5d4090..fa9f80de5a 100644
--- a/config_h.SH
+++ b/config_h.SH
@@ -982,6 +982,12 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
#define MEM_ALIGNBYTES $alignbytes
#endif
+/* PERL_RELOCATABLE_INC:
+ * This symbol, if defined, indicates that we'd like to relocate entries
+ * in @INC at run time based on the location of the perl binary.
+ */
+#$userelocatableinc PERL_RELOCATABLE_INC /**/
+
/* ARCHLIB:
* This variable, if defined, holds the name of the directory in
* which the user wants to put architecture-dependent public
diff --git a/configpm b/configpm
index d5623094a0..a6d6d0f14b 100755
--- a/configpm
+++ b/configpm
@@ -295,6 +295,67 @@ EOT
$byteorder_code = "our \$byteorder = '?'x$s;\n";
}
+my @need_relocation;
+
+if (fetch_string({},'userelocatableinc')) {
+ foreach my $what (qw(archlib archlibexp
+ privlib privlibexp
+ sitearch sitearchexp
+ sitelib sitelibexp
+ sitelib_stem
+ vendorarch vendorarchexp
+ vendorlib vendorlibexp
+ vendorlib_stem)) {
+ push @need_relocation, $what if fetch_string({}, $what) =~ m!^\.\.\./!;
+ }
+ # This can have .../ anywhere:
+ push @need_relocation, 'otherlibdirs'
+ if fetch_string({}, 'otherlibdirs') =~ m!\.\.\./!;
+}
+
+my %need_relocation;
+@need_relocation{@need_relocation} = @need_relocation;
+
+my $relocation_code = <<'EOT';
+
+sub relocate_inc {
+ my $libdir = shift;
+ return $libdir unless $libdir =~ s!^\.\.\./!!;
+ my $prefix = $^X;
+ if ($prefix =~ s!/[^/]*$!!) {
+ while ($libdir =~ m!^\.\./!) {
+ # Loop while $libdir starts "../" and $prefix still has a trailing
+ # directory
+ last unless $prefix =~ s!/([^/]+)$!!;
+ # but bail out if the directory we picked off the end of $prefix is .
+ # or ..
+ if ($1 eq '.' or $1 eq '..') {
+ # Undo! This should be rare, hence code it this way rather than a
+ # check each time before the s!!! above.
+ $prefix = "$prefix/$1";
+ last;
+ }
+ # Remove that leading ../ and loop again
+ substr ($libdir, 0, 3, '');
+ }
+ $libdir = "$prefix/$libdir";
+ }
+ $libdir;
+}
+EOT
+
+if (@need_relocation) {
+ my $relocations_in_common;
+ foreach (@need_relocation) {
+ $relocations_in_common++ if $Common{$_};
+ }
+ if ($relocations_in_common) {
+ print CONFIG $relocation_code;
+ } else {
+ print CONFIG_HEAVY $relocation_code;
+ }
+}
+
print CONFIG_HEAVY @non_v, "\n";
# copy config summary format from the myconfig.SH script
@@ -332,6 +393,14 @@ if ($Common{byteorder}) {
print CONFIG_HEAVY $byteorder_code;
}
+if (@need_relocation) {
+print CONFIG_HEAVY 'foreach my $what (qw(', join (' ', @need_relocation),
+ ")) {\n", <<'EOT';
+ s/^($what=)(['"])(.*?)\2/$1 . $2 . relocate_inc($3) . $2/me;
+}
+EOT
+}
+
print CONFIG_HEAVY <<'EOT';
s/(byteorder=)(['"]).*?\2/$1$2$Config::byteorder$2/m;
@@ -516,6 +585,9 @@ foreach my $key (keys %Common) {
$value =~ s!\\!\\\\!g;
$value =~ s!'!\\'!g;
$value = "'$value'";
+ if ($need_relocation{$key}) {
+ $value = "relocate_inc($value)";
+ }
} else {
$value = "undef";
}
diff --git a/embed.fnc b/embed.fnc
index 56fd52c711..4ca621f254 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1036,7 +1036,7 @@ Ap |void |Slab_Free |void *op
#if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
s |void |find_beginning
s |void |forbid_setid |char *
-s |void |incpush |char *|int|int|int
+s |void |incpush |char *|int|int|int|int
s |void |init_interp
s |void |init_ids
s |void |init_lexer
diff --git a/embed.h b/embed.h
index fb0e4f0700..f9113f89ea 100644
--- a/embed.h
+++ b/embed.h
@@ -4005,7 +4005,7 @@
#define forbid_setid(a) S_forbid_setid(aTHX_ a)
#endif
#ifdef PERL_CORE
-#define incpush(a,b,c,d) S_incpush(aTHX_ a,b,c,d)
+#define incpush(a,b,c,d,e) S_incpush(aTHX_ a,b,c,d,e)
#endif
#ifdef PERL_CORE
#define init_interp() S_init_interp(aTHX)
diff --git a/perl.c b/perl.c
index 54543256ce..7cd8e3b0c4 100644
--- a/perl.c
+++ b/perl.c
@@ -1343,7 +1343,7 @@ 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);
@@ -2654,7 +2654,7 @@ Perl_moreswitches(pTHX_ char *s)
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 == '-')
@@ -4177,9 +4177,9 @@ S_init_perllib(pTHX)
#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
@@ -4188,9 +4188,9 @@ S_init_perllib(pTHX)
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 */
}
@@ -4198,11 +4198,11 @@ S_init_perllib(pTHX)
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
{
@@ -4215,72 +4215,72 @@ S_init_perllib(pTHX)
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 */
}
@@ -4317,7 +4317,8 @@ S_incpush_if_exists(pTHX_ SV *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;
@@ -4361,6 +4362,102 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
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.
diff --git a/proto.h b/proto.h
index 066774c66e..9a3cf4df54 100644
--- a/proto.h
+++ b/proto.h
@@ -991,7 +991,7 @@ PERL_CALLCONV void Perl_Slab_Free(pTHX_ void *op);
#if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
STATIC void S_find_beginning(pTHX);
STATIC void S_forbid_setid(pTHX_ char *);
-STATIC void S_incpush(pTHX_ char *, int, int, int);
+STATIC void S_incpush(pTHX_ char *, int, int, int, int);
STATIC void S_init_interp(pTHX);
STATIC void S_init_ids(pTHX);
STATIC void S_init_lexer(pTHX);