diff options
| -rw-r--r-- | embed.fnc | 2 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | perl.c | 28 | ||||
| -rw-r--r-- | proto.h | 7 |
4 files changed, 21 insertions, 18 deletions
@@ -1493,7 +1493,7 @@ so |void |validate_suid |NN PerlIO *rsfp s |void* |parse_body |NULLOK char **env|XSINIT_t xsinit rs |void |run_body |I32 oldscope -s |SV * |incpush_if_exists|NN AV *const av|NN SV *dir +s |SV * |incpush_if_exists|NN AV *const av|NN SV *dir|NN SV *const stem #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) @@ -3646,7 +3646,7 @@ #ifdef PERL_CORE #define parse_body(a,b) S_parse_body(aTHX_ a,b) #define run_body(a) S_run_body(aTHX_ a) -#define incpush_if_exists(a,b) S_incpush_if_exists(aTHX_ a,b) +#define incpush_if_exists(a,b,c) S_incpush_if_exists(aTHX_ a,b,c) #endif #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) @@ -4325,7 +4325,7 @@ S_init_perllib(pTHX) Generate a new SV if we do this, to save needing to copy the SV we push onto @INC */ STATIC SV * -S_incpush_if_exists(pTHX_ AV *const av, SV *dir) +S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem) { dVAR; Stat_t tmpstatbuf; @@ -4335,7 +4335,10 @@ S_incpush_if_exists(pTHX_ AV *const av, SV *dir) if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) { av_push(av, dir); - dir = newSV(0); + dir = newSVsv(stem); + } else { + /* Truncate dir back to stem. */ + SvCUR_set(dir, SvCUR(stem)); } return dir; } @@ -4498,7 +4501,7 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) * archname-specific sub-directories. */ if (using_sub_dirs) { - SV *subdir = newSV(0); + SV *subdir; #ifdef PERL_INC_VERSION_LIST /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ const char * const incverlist[] = { PERL_INC_VERSION_LIST }; @@ -4519,6 +4522,9 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) "Failed to unixify @INC element \"%s\"\n", SvPV(libdir,len)); #endif + + subdir = newSVsv(libdir); + if (add_versioned_sub_dirs) { #ifdef MACOS_TRADITIONAL #define PERL_ARCH_FMT_PREFIX "" @@ -4530,35 +4536,31 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) #define PERL_ARCH_FMT_PATH "/" PERL_FS_VERSION #endif /* .../version/archname if -d .../version/archname */ - sv_setsv(subdir, libdir); sv_catpvs(subdir, PERL_ARCH_FMT_PATH \ PERL_ARCH_FMT_PREFIX ARCHNAME PERL_ARCH_FMT_SUFFIX); - subdir = S_incpush_if_exists(aTHX_ av, subdir); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); /* .../version if -d .../version */ - sv_setsv(subdir, libdir); sv_catpvs(subdir, PERL_ARCH_FMT_PATH); - subdir = S_incpush_if_exists(aTHX_ av, subdir); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); } #ifdef PERL_INC_VERSION_LIST if (addoldvers) { for (incver = incverlist; *incver; incver++) { /* .../xxx if -d .../xxx */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PREFIX \ - "%s" PERL_ARCH_FMT_SUFFIX, - SVfARG(libdir), *incver); - subdir = S_incpush_if_exists(aTHX_ av, subdir); + Perl_sv_catpvf(aTHX_ subdir, PERL_ARCH_FMT_PREFIX \ + "%s" PERL_ARCH_FMT_SUFFIX, *incver); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); } } #endif if (add_archonly_sub_dirs) { /* .../archname if -d .../archname */ - sv_setsv(subdir, libdir); sv_catpvs(subdir, PERL_ARCH_FMT_PREFIX ARCHNAME PERL_ARCH_FMT_SUFFIX); - subdir = S_incpush_if_exists(aTHX_ av, subdir); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); } @@ -4803,11 +4803,12 @@ STATIC void* S_parse_body(pTHX_ char **env, XSINIT_t xsinit); STATIC void S_run_body(pTHX_ I32 oldscope) __attribute__noreturn__; -STATIC SV * S_incpush_if_exists(pTHX_ AV *const av, SV *dir) +STATIC SV * S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem) __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2); + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); #define PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS \ - assert(av); assert(dir) + assert(av); assert(dir); assert(stem) #endif |