X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=130a83c6ec16edb2a7c0098d51d596eb5cd99de3;hb=f21000970ab9d31d61aef8d0ffdfbc9fdad80291;hp=0aa8dfd04bb91b2b199d20949aca277f3602610d;hpb=e6a0bbf8b4e00dca6da011b9cb1d8c949b3bfa1e;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 0aa8dfd..130a83c 100644 --- a/perl.c +++ b/perl.c @@ -1624,11 +1624,14 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) return ret; } -#define INCPUSH_ADD_SUB_DIRS 0x01 -#define INCPUSH_ADD_OLD_VERS 0x02 -#define INCPUSH_NOT_BASEDIR 0x04 -#define INCPUSH_CAN_RELOCATE 0x08 -#define INCPUSH_UNSHIFT 0x10 +#define INCPUSH_UNSHIFT 0x01 +#define INCPUSH_ADD_OLD_VERS 0x02 +#define INCPUSH_ADD_VERSIONED_SUB_DIRS 0x04 +#define INCPUSH_ADD_ARCHONLY_SUB_DIRS 0x08 +#define INCPUSH_NOT_BASEDIR 0x10 +#define INCPUSH_CAN_RELOCATE 0x20 +#define INCPUSH_ADD_SUB_DIRS \ + (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS) STATIC void * S_parse_body(pTHX_ char **env, XSINIT_t xsinit) @@ -1639,7 +1642,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) char **argv = PL_origargv; const char *scriptname = NULL; VOL bool dosearch = FALSE; - register SV *sv; register char c; const char *cddir = NULL; #ifdef USE_SITECUSTOMIZE @@ -1651,8 +1653,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) SvGROW(linestr_sv, 80); sv_setpvs(linestr_sv,""); - sv = newSVpvs(""); /* first used for -I flags */ - SAVEFREESV(sv); init_main_stash(); { @@ -1747,9 +1747,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) if (s && *s) { STRLEN len = strlen(s); incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS); - sv_catpvs(sv, "-I"); - sv_catpvn(sv, s, len); - sv_catpvs(sv, " "); } else Perl_croak(aTHX_ "No directory specified for -I"); @@ -1926,7 +1923,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) d = s; if (!*s) break; - if (!strchr("CDIMUdmtw", *s)) + if (!strchr("CDIMUdmtwW", *s)) Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); while (++s && *s) { if (isSPACE(*s)) { @@ -1978,8 +1975,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) TAINT; S_set_caret_X(aTHX); TAINT_NOT; - init_perllib(0); - init_perllib(INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); + init_perllib(); { bool suidscript = FALSE; @@ -2032,7 +2028,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) boot_core_PerlIO(); boot_core_UNIVERSAL(); - boot_core_xsutils(); boot_core_mro(); if (xsinit) @@ -4090,29 +4085,32 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register } STATIC void -S_init_perllib(pTHX_ U32 old_vers) +S_init_perllib(pTHX) { dVAR; - char *s; +#ifndef VMS + const char *perl5lib = NULL; +#endif + const char *s; #ifdef WIN32 STRLEN len; #endif if (!PL_tainting) { #ifndef VMS - s = PerlEnv_getenv("PERL5LIB"); + perl5lib = PerlEnv_getenv("PERL5LIB"); /* * It isn't possible to delete an environment variable with * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that * case we treat PERL5LIB as undefined if it has a zero-length value. */ #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV) - if (s && *s != '\0') + if (perl5lib && *perl5lib != '\0') #else - if (s) + if (perl5lib) #endif - incpush_use_sep(s, 0, old_vers ? old_vers : INCPUSH_ADD_SUB_DIRS); - else if (!old_vers) { + incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS); + else { s = PerlEnv_getenv("PERLLIB"); if (s) incpush_use_sep(s, 0, 0); @@ -4126,11 +4124,12 @@ S_init_perllib(pTHX_ U32 old_vers) int idx = 0; if (my_trnlnm("PERL5LIB",buf,0)) do { - incpush_use_sep(buf, 0, old_vers ? old_vers : INCPUSH_ADD_SUB_DIRS); + incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS); } while (my_trnlnm("PERL5LIB",buf,++idx)); - else if (!old_vers) + else { while (my_trnlnm("PERLLIB",buf,idx++)) incpush_use_sep(buf, 0, 0); + } #endif /* VMS */ } @@ -4138,15 +4137,12 @@ S_init_perllib(pTHX_ U32 old_vers) ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB */ #ifdef APPLLIB_EXP - if (!old_vers) { - S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); - } else { - S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), old_vers|INCPUSH_CAN_RELOCATE); - } + S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), + INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); #endif - if (!old_vers) { #ifdef MACOS_TRADITIONAL + { Stat_t tmpstatbuf; SV * privdir = newSV(0); char * macperl = PerlEnv_getenv("MACPERL"); @@ -4155,27 +4151,29 @@ S_init_perllib(pTHX_ U32 old_vers) macperl = ""; # ifdef ARCHLIB_EXP - if (!old_vers) S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE); # endif Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl); if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) - incpush_use_sep(SvPVX(privdir), SvCUR(privdir), INCPUSH_ADD_SUB_DIRS); + incpush_use_sep(SvPVX(privdir), SvCUR(privdir), + INCPUSH_ADD_SUB_DIRS); Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl); if (PerlLIO_stat(SvPVX(privdir), SvCUR(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) - incpush_use_sep(SvPVX(privdir), INCPUSH_ADD_SUB_DIRS); + incpush_use_sep(SvPVX(privdir), SvCUR(privdir), + INCPUSH_ADD_SUB_DIRS); SvREFCNT_dec(privdir); if (!PL_tainting) S_incpush(aTHX_ STR_WITH_LEN(":"), 0); + } #else - #ifdef SITEARCH_EXP /* sitearch is always relative to sitelib on Windows for * DLL-based path intuition to work correctly */ # if !defined(WIN32) - S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP), INCPUSH_CAN_RELOCATE); + S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP), + INCPUSH_CAN_RELOCATE); # endif #endif @@ -4189,19 +4187,13 @@ S_init_perllib(pTHX_ U32 old_vers) S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE); # endif #endif - } - -#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST) - /* Search for version-specific dirs below here */ - S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM), old_vers|INCPUSH_CAN_RELOCATE); -#endif - if (!old_vers) { #ifdef PERL_VENDORARCH_EXP /* vendorarch is always relative to vendorlib on Windows for * DLL-based path intuition to work correctly */ # if !defined(WIN32) - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP), INCPUSH_CAN_RELOCATE); + S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP), + INCPUSH_CAN_RELOCATE); # endif #endif @@ -4212,19 +4204,13 @@ S_init_perllib(pTHX_ U32 old_vers) if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); # else - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP), INCPUSH_CAN_RELOCATE); + S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP), + INCPUSH_CAN_RELOCATE); # endif #endif - } - -#if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST) - /* Search for version-specific dirs below here */ - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM), old_vers|INCPUSH_CAN_RELOCATE); -#endif - if (!old_vers) { #ifdef ARCHLIB_EXP - S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE); + S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE); #endif #ifndef PRIVLIB_EXP @@ -4232,25 +4218,82 @@ S_init_perllib(pTHX_ U32 old_vers) #endif #if defined(WIN32) - s = win32_get_privlib(PERL_FS_VERSION, &len); - if (s) - incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); + s = win32_get_privlib(PERL_FS_VERSION, &len); + if (s) + incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); #else - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE); +# ifdef NETWARE + S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE); +# else + S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE); +# endif #endif - } #ifdef PERL_OTHERLIBDIRS - if (!old_vers) { - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), INCPUSH_ADD_SUB_DIRS - |INCPUSH_CAN_RELOCATE); - } else { - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), old_vers|INCPUSH_CAN_RELOCATE); + S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), + INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR + |INCPUSH_CAN_RELOCATE); +#endif +#endif /* MACOS_TRADITIONAL */ + + if (!PL_tainting) { +#ifndef VMS +/* + * It isn't possible to delete an environment variable with + * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that + * case we treat PERL5LIB as undefined if it has a zero-length value. + */ +#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV) + if (perl5lib && *perl5lib != '\0') +#else + if (perl5lib) +#endif + incpush_use_sep(perl5lib, 0, + INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); +#else /* VMS */ + /* Treat PERL5?LIB as a possible search list logical name -- the + * "natural" VMS idiom for a Unix path string. We allow each + * element to be a set of |-separated directories for compatibility. + */ + char buf[256]; + int idx = 0; + if (my_trnlnm("PERL5LIB",buf,0)) + do { + incpush_use_sep(buf, 0, + INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); + } while (my_trnlnm("PERL5LIB",buf,++idx)); +#endif /* VMS */ } + +/* Use the ~-expanded versions of APPLLIB (undocumented), + ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB +*/ +#ifdef APPLLIB_EXP + S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS + |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE); +#endif + +#ifndef MACOS_TRADITIONAL +#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST) + /* Search for version-specific dirs below here */ + S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM), + INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); +#endif + + +#if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST) + /* Search for version-specific dirs below here */ + S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM), + INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); +#endif + +#ifdef PERL_OTHERLIBDIRS + S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), + INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS + |INCPUSH_CAN_RELOCATE); #endif - /* old_vers should be true, so that this last of all. */ - if (!PL_tainting && old_vers) + if (!PL_tainting) S_incpush(aTHX_ STR_WITH_LEN("."), 0); #endif /* MACOS_TRADITIONAL */ } @@ -4276,7 +4319,7 @@ S_init_perllib(pTHX_ U32 old_vers) 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; @@ -4286,7 +4329,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; } @@ -4295,23 +4341,26 @@ STATIC void S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) { dVAR; - const U8 addsubdirs = (U8)flags & INCPUSH_ADD_SUB_DIRS; + 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 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; - SV *subdir = NULL; - AV *inc; - - if (!dir || !*dir) - return; - - inc = GvAVn(PL_incgv); + AV *const inc = GvAVn(PL_incgv); - if (addsubdirs || addoldvers) { - subdir = newSV(0); - } + 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, @@ -4321,8 +4370,7 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) 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. */ - AV *const av - = (addsubdirs || addoldvers) ? (unshift ? newAV() : inc) : NULL; + AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL; if (len) { /* I am not convinced that this is valid when PERLLIB_MANGLE is @@ -4448,7 +4496,8 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) * BEFORE pushing libdir onto @INC we may first push version- and * archname-specific sub-directories. */ - if (addsubdirs || addoldvers) { + if (using_sub_dirs) { + SV *subdir; #ifdef PERL_INC_VERSION_LIST /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ const char * const incverlist[] = { PERL_INC_VERSION_LIST }; @@ -4458,6 +4507,7 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) char *unix; STRLEN len; + if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) { len = strlen(unix); while (unix[len-1] == '/') len--; /* Cosmetic */ @@ -4468,7 +4518,10 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) "Failed to unixify @INC element \"%s\"\n", SvPV(libdir,len)); #endif - if (addsubdirs) { + + subdir = newSVsv(libdir); + + if (add_versioned_sub_dirs) { #ifdef MACOS_TRADITIONAL #define PERL_ARCH_FMT_PREFIX "" #define PERL_ARCH_FMT_SUFFIX ":" @@ -4479,35 +4532,36 @@ 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); - - /* .../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); } #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_catpvs(subdir, + PERL_ARCH_FMT_PREFIX ARCHNAME PERL_ARCH_FMT_SUFFIX); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); + + } + + assert (SvREFCNT(subdir) == 1); + SvREFCNT_dec(subdir); } /* finally add this lib directory at the end of @INC */ @@ -4540,10 +4594,6 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) SvREFCNT_dec(libdir); } } - if (subdir) { - assert (SvREFCNT(subdir) == 1); - SvREFCNT_dec(subdir); - } } STATIC void