From: Nicholas Clark Date: Thu, 23 Dec 2004 21:38:59 +0000 (+0000) Subject: Relocatable @INC entries for Unix. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=88fe16b231aae255ffd6ec9561af9af9f6edf830;p=p5sagit%2Fp5-mst-13.2.git 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 --- diff --git a/Porting/Glossary b/Porting/Glossary index e70ce3e..41eec75 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 472b5d4..fa9f80d 100644 --- a/config_h.SH +++ b/config_h.SH @@ -982,6 +982,12 @@ sed <$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 d562309..a6d6d0f 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 56fd52c..4ca621f 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 fb0e4f0..f9113f8 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 5454325..7cd8e3b 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 066774c..9a3cf4d 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);