X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=7cb8530b245ca5786d9378f1cad227d9494593d4;hb=18869dc676cf135549b1be0ce06b9a400bb0f137;hp=eb31f9ea45786b6430690e7de8be3e6a686e14ba;hpb=bdb1cbf7b53e27466d3d9ba865b3b0e74998bf89;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index eb31f9e..7cb8530 100644 --- a/perl.c +++ b/perl.c @@ -29,7 +29,6 @@ #ifdef NETWARE #include "nwutil.h" -char *nw_get_sitelib(const char *pl); #endif /* XXX If this causes problems, set i_unistd=undef in the hint file. */ @@ -1229,14 +1228,18 @@ perl_destruct(pTHXx) Safefree(PL_reg_poscache); free_tied_hv_pool(); Safefree(PL_op_mask); - Safefree(PL_psig_ptr); - PL_psig_ptr = (SV**)NULL; Safefree(PL_psig_name); PL_psig_name = (SV**)NULL; - Safefree(PL_bitcount); - PL_bitcount = NULL; + PL_psig_ptr = (SV**)NULL; Safefree(PL_psig_pend); PL_psig_pend = (int*)NULL; + { + /* We need to NULL PL_psig_pend first, so that + signal handlers know not to use it */ + int *psig_save = PL_psig_pend; + PL_psig_pend = (int*)NULL; + Safefree(psig_save); + } PL_formfeed = NULL; nuke_stacks(); PL_tainting = FALSE; @@ -1625,11 +1628,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) @@ -1640,7 +1646,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 @@ -1652,8 +1657,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(); { @@ -1712,11 +1715,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) PL_minus_E = TRUE; /* FALL THROUGH */ case 'e': -#ifdef MACOS_TRADITIONAL - /* ignore -e for Dev:Pseudo argument */ - if (argv[1] && !strcmp(argv[1], "Dev:Pseudo")) - break; -#endif forbid_setid('e', FALSE); if (!PL_e_script) { PL_e_script = newSVpvs(""); @@ -1748,9 +1746,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"); @@ -1775,6 +1770,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef NO_MATHOMS " NO_MATHOMS" # endif +# ifdef PERL_DISABLE_PMC + " PERL_DISABLE_PMC" +# endif # ifdef PERL_DONT_CREATE_GVSV " PERL_DONT_CREATE_GVSV" # endif @@ -1784,17 +1782,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef PERL_MEM_LOG " PERL_MEM_LOG" # endif -# ifdef PERL_MEM_LOG_ENV - " PERL_MEM_LOG_ENV" -# endif -# ifdef PERL_MEM_LOG_ENV_FD - " PERL_MEM_LOG_ENV_FD" -# endif -# ifdef PERL_MEM_LOG_STDERR - " PERL_MEM_LOG_STDERR" -# endif -# ifdef PERL_MEM_LOG_TIMESTAMP - " PERL_MEM_LOG_TIMESTAMP" +# ifdef PERL_MEM_LOG_NOIMPL + " PERL_MEM_LOG_NOIMPL" # endif # ifdef PERL_USE_DEVEL " PERL_USE_DEVEL" @@ -1927,7 +1916,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)) { @@ -1979,8 +1968,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; @@ -2007,11 +1995,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # endif #endif - if (PL_doextract -#ifdef MACOS_TRADITIONAL - || gMacPerl_AlwaysExtract -#endif - ) { + if (PL_doextract) { /* This will croak if suidscript is true, as -x cannot be used with setuid scripts. */ @@ -2033,7 +2017,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) boot_core_PerlIO(); boot_core_UNIVERSAL(); - boot_core_xsutils(); boot_core_mro(); if (xsinit) @@ -2152,16 +2135,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) /* now parse the script */ SETERRNO(0,SS_NORMAL); -#ifdef MACOS_TRADITIONAL - if (gMacPerl_SyntaxError = (yyparse() || PL_parser->error_count)) { - if (PL_minus_c) - Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename)); - else { - Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n", - MacPerl_MPWFileName(PL_origfilename)); - } - } -#else if (yyparse() || PL_parser->error_count) { if (PL_minus_c) Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename); @@ -2170,7 +2143,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) PL_origfilename); } } -#endif CopLINE_set(PL_curcop, 0); PL_curstash = PL_defstash; if (PL_e_script) { @@ -2288,13 +2260,7 @@ S_run_body(pTHX_ I32 oldscope) #endif if (PL_minus_c) { -#ifdef MACOS_TRADITIONAL - PerlIO_printf(Perl_error_log, "%s%s syntax OK\n", - (gMacPerl_ErrorFormat ? "# " : ""), - MacPerl_MPWFileName(PL_origfilename)); -#else PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); -#endif my_exit(0); } if (PERLDB_SINGLE && PL_DBsingle) @@ -2897,6 +2863,8 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) " C Copy On Write", " A Consistency checks on internal structures", " q quiet - currently only suppresses the 'EXECUTING' message", + " M trace smart match resolution", + " B dump suBroutine definitions, including special Blocks like BEGIN", NULL }; int i = 0; @@ -2905,7 +2873,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) if (isALPHA(**s)) { /* if adding extra options, remember to update DEBUG_MASK */ - static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAq"; + static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB"; for (; isALNUM(**s); (*s)++) { const char * const d = strchr(debopts,**s); @@ -3208,9 +3176,6 @@ Perl_moreswitches(pTHX_ const char *s) s++; return s; case 'u': -#ifdef MACOS_TRADITIONAL - Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh"); -#endif PL_do_undump = TRUE; s++; return s; @@ -3269,11 +3234,6 @@ Perl_moreswitches(pTHX_ const char *s) PerlIO_printf(PerlIO_stdout(), "\n\nCopyright 1987-2009, Larry Wall\n"); -#ifdef MACOS_TRADITIONAL - PerlIO_printf(PerlIO_stdout(), - "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n" - "maintained by Chris Nandor\n"); -#endif #ifdef MSDOS PerlIO_printf(PerlIO_stdout(), "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); @@ -3316,10 +3276,6 @@ Perl_moreswitches(pTHX_ const char *s) PerlIO_printf(PerlIO_stdout(), "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); #endif -#ifdef __MINT__ - PerlIO_printf(PerlIO_stdout(), - "MiNT port by Guido Flohr, 1997-1999\n"); -#endif #ifdef EPOC PerlIO_printf(PerlIO_stdout(), "EPOC port by Olaf Flebbe, 1999-2002\n"); @@ -3670,38 +3626,14 @@ S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) dVAR; const char *s; register const char *s2; -#ifdef MACOS_TRADITIONAL - int maclines = 0; -#endif PERL_ARGS_ASSERT_FIND_BEGINNING; /* skip forward in input to the real script? */ -#ifdef MACOS_TRADITIONAL - /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */ - - while (PL_doextract || gMacPerl_AlwaysExtract) { - if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) { - if (!gMacPerl_AlwaysExtract) - Perl_croak(aTHX_ "No Perl script found in input\n"); - - if (PL_doextract) /* require explicit override ? */ - if (!OverrideExtract(PL_origfilename)) - Perl_croak(aTHX_ "User aborted script\n"); - else - PL_doextract = FALSE; - - /* Pater peccavi, file does not have #! */ - PerlIO_rewind(rsfp); - - break; - } -#else while (PL_doextract) { if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) Perl_croak(aTHX_ "No Perl script found in input\n"); -#endif s2 = s; if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) { PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */ @@ -3716,20 +3648,6 @@ S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) while ((s = moreswitches(s))) ; } -#ifdef MACOS_TRADITIONAL - /* We are always searching for the #!perl line in MacPerl, - * so if we find it, still keep the line count correct - * by counting lines we already skipped over - */ - for (; maclines > 0 ; maclines--) - PerlIO_ungetc(rsfp, '\n'); - - break; - - /* gMacPerl_AlwaysExtract is false in MPW tool */ - } else if (gMacPerl_AlwaysExtract) { - ++maclines; -#endif } } } @@ -4015,17 +3933,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register init_argv_symbols(argc,argv); if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) { -#ifdef MACOS_TRADITIONAL - /* $0 is not majick on a Mac */ - sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename)); -#else sv_setpv(GvSV(tmpgv),PL_origfilename); - { - GV * const gv = gv_fetchpv("0", GV_ADD, SVt_PV); - if (gv) - sv_magic(GvSV(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, "0", 1); - } -#endif } if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) { HV *hv; @@ -4091,28 +3999,35 @@ 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, 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); + incpush_use_sep(s, 0, 0); } #else /* VMS */ /* Treat PERL5?LIB as a possible search list logical name -- the @@ -4123,11 +4038,12 @@ S_init_perllib(pTHX_ U32 old_vers) int idx = 0; if (my_trnlnm("PERL5LIB",buf,0)) do { - incpush_use_sep(buf, 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); + incpush_use_sep(buf, 0, 0); + } #endif /* VMS */ } @@ -4135,90 +4051,53 @@ S_init_perllib(pTHX_ U32 old_vers) ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB */ #ifdef APPLLIB_EXP - if (!old_vers) { - incpush_use_sep(APPLLIB_EXP, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); - } else { - incpush_use_sep(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"); - - if (!macperl) - macperl = ""; - -# ifdef ARCHLIB_EXP - if (!old_vers) - incpush_use_sep(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), INCPUSH_ADD_SUB_DIRS); - Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl); - if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) - incpush_use_sep(SvPVX(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) - incpush_use_sep(SITEARCH_EXP, INCPUSH_CAN_RELOCATE); + S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP), + INCPUSH_CAN_RELOCATE); # endif #endif #ifdef SITELIB_EXP # if defined(WIN32) /* this picks up sitearch as well */ - incpush_use_sep(SITELIB_EXP, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); + s = win32_get_sitelib(PERL_FS_VERSION, &len); + if (s) + incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); # else - incpush_use_sep(SITELIB_EXP, INCPUSH_CAN_RELOCATE); + 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 */ - incpush_use_sep(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) - incpush_use_sep(PERL_VENDORARCH_EXP, INCPUSH_CAN_RELOCATE); + S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP), + INCPUSH_CAN_RELOCATE); # endif #endif #ifdef PERL_VENDORLIB_EXP # if defined(WIN32) /* this picks up vendorarch as well */ - incpush_use_sep(PERL_VENDORLIB_EXP, - INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); + s = win32_get_vendorlib(PERL_FS_VERSION, &len); + if (s) + incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); # else - incpush_use_sep(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 */ - incpush_use_sep(PERL_VENDORLIB_STEM, old_vers|INCPUSH_CAN_RELOCATE); -#endif - if (!old_vers) { #ifdef ARCHLIB_EXP - incpush_use_sep(ARCHLIB_EXP, INCPUSH_CAN_RELOCATE); + S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE); #endif #ifndef PRIVLIB_EXP @@ -4226,25 +4105,81 @@ S_init_perllib(pTHX_ U32 old_vers) #endif #if defined(WIN32) - incpush_use_sep(PRIVLIB_EXP, 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 - incpush_use_sep(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) { - incpush_use_sep(PERL_OTHERLIBDIRS, INCPUSH_ADD_SUB_DIRS - |INCPUSH_CAN_RELOCATE); - } else { - incpush_use_sep(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 + + 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 + +#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 */ } #if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__) @@ -4253,11 +4188,7 @@ S_init_perllib(pTHX_ U32 old_vers) # if defined(VMS) # define PERLLIB_SEP '|' # else -# if defined(MACOS_TRADITIONAL) -# define PERLLIB_SEP ',' -# else -# define PERLLIB_SEP ':' -# endif +# define PERLLIB_SEP ':' # endif #endif #ifndef PERLLIB_MANGLE @@ -4268,7 +4199,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; @@ -4278,7 +4209,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; } @@ -4287,23 +4221,26 @@ STATIC void S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) { dVAR; - const U8 addsubdirs = flags & INCPUSH_ADD_SUB_DIRS; - const U8 addoldvers = flags & INCPUSH_ADD_OLD_VERS; - const U8 canrelocate = flags & INCPUSH_CAN_RELOCATE; - const U8 unshift = flags & INCPUSH_UNSHIFT; + 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; + AV *const inc = GvAVn(PL_incgv); - if (!dir || !*dir) - return; - - 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, @@ -4313,8 +4250,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 @@ -4327,16 +4263,6 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) libdir = newSVpv(PERLLIB_MANGLE(dir, 0), 0); } -#ifdef MACOS_TRADITIONAL - if (!strchr(SvPVX(libdir), ':')) { - char buf[256]; - - sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0)); - } - if (SvPVX(libdir)[SvCUR(libdir)-1] != ':') - sv_catpvs(libdir, ":"); -#endif - /* Do the if() outside the #ifdef to avoid warnings about an unused parameter. */ if (canrelocate) { @@ -4440,7 +4366,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 }; @@ -4450,6 +4377,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 */ @@ -4460,41 +4388,38 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) "Failed to unixify @INC element \"%s\"\n", SvPV(libdir,len)); #endif - if (addsubdirs) { -#ifdef MACOS_TRADITIONAL -#define PERL_ARCH_FMT "%s:" -#define PERL_ARCH_FMT_PATH PERL_FS_VERSION "" -#else -#define PERL_ARCH_FMT "/%s" -#define PERL_ARCH_FMT_PATH "/" PERL_FS_VERSION -#endif - /* .../version/archname if -d .../version/archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT, - SVfARG(libdir), ARCHNAME); - subdir = S_incpush_if_exists(aTHX_ av, subdir); - /* .../version if -d .../version */ - sv_setsv(subdir, libdir); - sv_catpvs(subdir, PERL_ARCH_FMT_PATH); - subdir = S_incpush_if_exists(aTHX_ av, subdir); + subdir = newSVsv(libdir); - /* .../archname if -d .../archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, - SVfARG(libdir), ARCHNAME); - subdir = S_incpush_if_exists(aTHX_ av, subdir); + if (add_versioned_sub_dirs) { + /* .../version/archname if -d .../version/archname */ + sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); + /* .../version if -d .../version */ + sv_catpvs(subdir, "/" PERL_FS_VERSION); + 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, - SVfARG(libdir), *incver); - subdir = S_incpush_if_exists(aTHX_ av, subdir); + Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); } } #endif + + if (add_archonly_sub_dirs) { + /* .../archname if -d .../archname */ + sv_catpvs(subdir, "/" ARCHNAME); + 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 */ @@ -4527,40 +4452,39 @@ 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 -S_incpush_use_sep(pTHX_ const char *p, U32 flags) +S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags) { + const char *s; + const char *end; /* This logic has been broken out from S_incpush(). It may be possible to simplify it. */ PERL_ARGS_ASSERT_INCPUSH_USE_SEP; + if (!len) + len = strlen(p); + + end = p + len; + /* Break at all separators */ - while (*p) { - const char *s; + while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) { + if (s == p) { + /* skip any consecutive separators */ - /* skip any consecutive separators */ - while ( *p == PERLLIB_SEP ) { /* Uncomment the next line for PATH semantics */ + /* But you'll need to write tests */ /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */ - p++; - } - - if ((s = strchr(p, PERLLIB_SEP)) != NULL ) { + } else { incpush(p, (STRLEN)(s - p), flags); - p = s + 1; - } - else { - incpush(p, 0, flags); - return; } + p = s + 1; } + if (p != end) + incpush(p, (STRLEN)(end - p), flags); + } void