This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Relocatable @INC entries for Unix.
authorNicholas Clark <nick@ccl4.org>
Thu, 23 Dec 2004 21:38:59 +0000 (21:38 +0000)
committerNicholas Clark <nick@ccl4.org>
Thu, 23 Dec 2004 21:38:59 +0000 (21:38 +0000)
(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

Porting/Glossary
config_h.SH
configpm
embed.fnc
embed.h
perl.c
proto.h

index e70ce3e..41eec75 100644 (file)
@@ -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
index 472b5d4..fa9f80d 100644 (file)
@@ -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
index d562309..a6d6d0f 100755 (executable)
--- 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";
     }
index 56fd52c..4ca621f 100644 (file)
--- 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 (file)
--- a/embed.h
+++ b/embed.h
 #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 (file)
--- 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 (file)
--- 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);