Make sitecustomize relocatableinc aware
authorCarl Hayter <hayter@usc.edu>
Thu, 24 Nov 2011 16:49:50 +0000 (17:49 +0100)
committerRicardo Signes <rjbs@cpan.org>
Wed, 21 Mar 2012 01:01:28 +0000 (21:01 -0400)
When -Dusesitecustomize is used with -Duserelocatableinc,
SITELIB_EXP/sitecustomize.pl is not found due to SITELIB_EXP having a
'.../..' relocation path.

This patch refactors the path relocation code from S_incpush() into
S_mayberelocate() so that it can be used in both S_incpush() and in
usesitecustomize's use of SITELIB_EXP.

AUTHORS
embed.fnc
embed.h
perl.c
proto.h

index 42ff149..229bda2 100644 (file)
--- a/AUTHORS
+++ b/AUTHORS
@@ -170,6 +170,7 @@ Calle Dybedahl                      <calle@lysator.liu.se>
 Campo Weijerman                        <rfc822@nl.ibm.com>
 Carl Eklof                     <CEklof@endeca.com>
 Carl M. Fongheiser             <cmf@ins.infonet.net>
+Carl Hayter                <hayter@usc.edu>
 Carl Witty                     <cwitty@newtonlabs.com>
 Cary D. Renzema                        <caryr@mxim.com>
 Casey R. Tweten                        <crt@kiski.net>
index bce167e..c23c020 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1665,6 +1665,8 @@ s |void   |find_beginning |NN SV* linestr_sv|NN PerlIO *rsfp
 s      |void   |forbid_setid   |const char flag|const bool suidscript
 s      |void   |incpush        |NN const char *const dir|STRLEN len \
                                |U32 flags
+s      |SV*    |mayberelocate  |NN const char *const dir|STRLEN len \
+                               |U32 flags
 s      |void   |incpush_use_sep|NN const char *p|STRLEN len|U32 flags
 s      |void   |init_interp
 s      |void   |init_ids
diff --git a/embed.h b/embed.h
index 04b32d1..675ab74 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define init_perllib()         S_init_perllib(aTHX)
 #define init_postdump_symbols(a,b,c)   S_init_postdump_symbols(aTHX_ a,b,c)
 #define init_predump_symbols() S_init_predump_symbols(aTHX)
+#define mayberelocate(a,b,c)   S_mayberelocate(aTHX_ a,b,c)
 #define my_exit_jump()         S_my_exit_jump(aTHX)
 #define nuke_stacks()          S_nuke_stacks(aTHX)
 #define open_script(a,b,c,d)   S_open_script(aTHX_ a,b,c,d)
diff --git a/perl.c b/perl.c
index f756e02..7cb101b 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1980,6 +1980,13 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     }
     }
 
+    /* Set $^X early so that it can be used for relocatable paths in @INC  */
+    /* and for SITELIB_EXP in USE_SITECUSTOMIZE                            */
+    assert (!PL_tainted);
+    TAINT;
+    S_set_caret_X(aTHX);
+    TAINT_NOT;
+
 #if defined(USE_SITECUSTOMIZE)
     if (!minus_f) {
        /* The games with local $! are to avoid setting errno if there is no
@@ -1995,10 +2002,16 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
        }
 #  else
        /* SITELIB_EXP is a function call on Win32.  */
-       const char *const sitelib = SITELIB_EXP;
+       const char *const raw_sitelib = SITELIB_EXP;
+       /* process .../.. if PERL_RELOCATABLE_INC is defined */
+       SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
+                                      INCPUSH_CAN_RELOCATE);
+       const char *const sitelib = SvPVX(sitelib_sv);
        (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
                                             Perl_newSVpvf(aTHX_
                                                           "BEGIN { do {local $!; -f '%s/sitecustomize.pl'} && do '%s/sitecustomize.pl' }", sitelib, sitelib));
+       assert (SvREFCNT(sitelib_sv) == 1);
+       SvREFCNT_dec(sitelib_sv);
 #  endif
     }
 #endif
@@ -2017,11 +2030,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
        scriptname = "-";
     }
 
-    /* Set $^X early so that it can be used for relocatable paths in @INC  */
     assert (!PL_tainted);
-    TAINT;
-    S_set_caret_X(aTHX);
-    TAINT_NOT;
     init_perllib();
 
     {
@@ -4384,45 +4393,15 @@ S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
 }
 #endif
 
-STATIC void
-S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
+STATIC SV *
+S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
 {
-    dVAR;
-#ifndef PERL_IS_MINIPERL
-    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;
-#ifdef PERL_INC_VERSION_LIST
-    const U8 addoldvers  = (U8)flags & INCPUSH_ADD_OLD_VERS;
-#endif
-#endif
     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;
-    AV *const inc = GvAVn(PL_incgv);
+    SV *libdir;
 
-    PERL_ARGS_ASSERT_INCPUSH;
+    PERL_ARGS_ASSERT_MAYBERELOCATE;
     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,
-          arranged to unshift #! line -I onto the front of @INC. However,
-          -I can add version and architecture specific libraries, and they
-          need to go first. The old code assumed that it was always
-          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.  */
-#ifndef PERL_IS_MINIPERL
-       AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
-#endif
-
        if (len) {
            /* I am not convinced that this is valid when PERLLIB_MANGLE is
               defined to so something (in os2/os2.c), but the code has been
@@ -4548,6 +4527,50 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
            }
 #endif
        }
+    return libdir;
+
+}
+
+STATIC void
+S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
+{
+    dVAR;
+#ifndef PERL_IS_MINIPERL
+    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;
+#ifdef PERL_INC_VERSION_LIST
+    const U8 addoldvers  = (U8)flags & INCPUSH_ADD_OLD_VERS;
+#endif
+#endif
+    const U8 unshift     = (U8)flags & INCPUSH_UNSHIFT;
+    const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
+    AV *const inc = GvAVn(PL_incgv);
+
+    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,
+          arranged to unshift #! line -I onto the front of @INC. However,
+          -I can add version and architecture specific libraries, and they
+          need to go first. The old code assumed that it was always
+          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.  */
+#ifndef PERL_IS_MINIPERL
+       AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
+#endif
+
+       libdir = mayberelocate(dir, len, flags);
+
 #ifndef PERL_IS_MINIPERL
        /*
         * BEFORE pushing libdir onto @INC we may first push version- and
diff --git a/proto.h b/proto.h
index 0b46a79..cc001e6 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5638,6 +5638,11 @@ STATIC void      S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
        assert(argv)
 
 STATIC void    S_init_predump_symbols(pTHX);
+STATIC SV*     S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MAYBERELOCATE \
+       assert(dir)
+
 STATIC void    S_my_exit_jump(pTHX)
                        __attribute__noreturn__;