Change 23674 by [EMAIL PROTECTED] on 2004/12/23 21:38:59
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
Affected files ...
... //depot/perl/Porting/Glossary#152 edit
... //depot/perl/config_h.SH#291 edit
... //depot/perl/configpm#66 edit
... //depot/perl/embed.fnc#140 edit
... //depot/perl/embed.h#448 edit
... //depot/perl/perl.c#574 edit
... //depot/perl/proto.h#487 edit
Differences ...
==== //depot/perl/Porting/Glossary#152 (text) ====
Index: perl/Porting/Glossary
--- perl/Porting/Glossary#151~23457~ Mon Nov 1 05:26:43 2004
+++ perl/Porting/Glossary Thu Dec 23 13:38:59 2004
@@ -4657,6 +4657,13 @@
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
==== //depot/perl/config_h.SH#291 (text) ====
Index: perl/config_h.SH
--- perl/config_h.SH#290~23673~ Thu Dec 23 13:04:37 2004
+++ perl/config_h.SH Thu Dec 23 13:38:59 2004
@@ -982,6 +982,12 @@
#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
==== //depot/perl/configpm#66 (xtext) ====
Index: perl/configpm
--- perl/configpm#65~23564~ Sun Nov 28 08:13:56 2004
+++ perl/configpm Thu Dec 23 13:38:59 2004
@@ -295,6 +295,67 @@
$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;
[EMAIL PROTECTED]@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 @@
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 @@
$value =~ s!\\!\\\\!g;
$value =~ s!'!\\'!g;
$value = "'$value'";
+ if ($need_relocation{$key}) {
+ $value = "relocate_inc($value)";
+ }
} else {
$value = "undef";
}
==== //depot/perl/embed.fnc#140 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#139~23644~ Mon Dec 13 09:26:46 2004
+++ perl/embed.fnc Thu Dec 23 13:38:59 2004
@@ -1036,7 +1036,7 @@
#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
==== //depot/perl/embed.h#448 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#447~23612~ Mon Dec 6 05:01:36 2004
+++ perl/embed.h Thu Dec 23 13:38:59 2004
@@ -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)
==== //depot/perl/perl.c#574 (text) ====
Index: perl/perl.c
--- perl/perl.c#573~23668~ Wed Dec 22 00:46:21 2004
+++ perl/perl.c Thu Dec 23 13:38:59 2004
@@ -1343,7 +1343,7 @@
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 @@
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 @@
#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 @@
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 @@
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 @@
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 @@
}
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 @@
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.
==== //depot/perl/proto.h#487 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#486~23612~ Mon Dec 6 05:01:36 2004
+++ perl/proto.h Thu Dec 23 13:38:59 2004
@@ -991,7 +991,7 @@
#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);
End of Patch.
