X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/cc69b689ee7c274593c3c386a61a06ecb909431c..5afa72af5aa99c40932771ad390abf5ba229611b:/perl.c diff --git a/perl.c b/perl.c index 4eb5148..7a87120 100644 --- a/perl.c +++ b/perl.c @@ -1,7 +1,9 @@ +#line 2 "perl.c" /* perl.c * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 - * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others + * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 by Larry Wall + * and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -26,10 +28,10 @@ #define PERL_IN_PERL_C #include "perl.h" #include "patchlevel.h" /* for local_patches */ +#include "XSUB.h" #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. */ @@ -107,8 +109,6 @@ S_init_tls_and_interp(PerlInterpreter *my_perl) OP_REFCNT_INIT; HINTS_REFCNT_INIT; MUTEX_INIT(&PL_dollarzero_mutex); -# endif -#ifdef PERL_IMPLICIT_CONTEXT MUTEX_INIT(&PL_my_ctx_mutex); # endif } @@ -347,8 +347,7 @@ perl_construct(pTHXx) PL_stashcache = newHV(); - PL_patchlevel = Perl_newSVpvf(aTHX_ "v%d.%d.%d", (int)PERL_REVISION, - (int)PERL_VERSION, (int)PERL_SUBVERSION); + PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING); #ifdef HAS_MMAP if (!PL_mmap_page_size) { @@ -392,6 +391,8 @@ perl_construct(pTHXx) PL_timesbase.tms_cstime = 0; #endif + PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME)); + PL_registered_mros = newHV(); /* Start with 1 bucket, for DFS. It's unlikely we'll need more. */ HvMAX(PL_registered_mros) = 0; @@ -538,6 +539,8 @@ perl_destruct(pTHXx) PERL_UNUSED_ARG(my_perl); #endif + assert(PL_scopestack_ix == 1); + /* wait for all pseudo-forked children to finish */ PERL_WAIT_FOR_CHILDREN; @@ -565,6 +568,7 @@ perl_destruct(pTHXx) } LEAVE; FREETMPS; + assert(PL_scopestack_ix == 0); /* Need to flush since END blocks can produce output */ my_fflush_all(); @@ -987,7 +991,6 @@ perl_destruct(pTHXx) /* clear utf8 character classes */ SvREFCNT_dec(PL_utf8_alnum); - SvREFCNT_dec(PL_utf8_alnumc); SvREFCNT_dec(PL_utf8_ascii); SvREFCNT_dec(PL_utf8_alpha); SvREFCNT_dec(PL_utf8_space); @@ -1007,7 +1010,6 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_utf8_idstart); SvREFCNT_dec(PL_utf8_idcont); PL_utf8_alnum = NULL; - PL_utf8_alnumc = NULL; PL_utf8_ascii = NULL; PL_utf8_alpha = NULL; PL_utf8_space = NULL; @@ -1050,21 +1052,21 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_isarev); FREETMPS; - if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) { + if (destruct_level >= 2) { if (PL_scopestack_ix != 0) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", - (long)PL_scopestack_ix); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", + (long)PL_scopestack_ix); if (PL_savestack_ix != 0) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Unbalanced saves: %ld more saves than restores\n", - (long)PL_savestack_ix); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Unbalanced saves: %ld more saves than restores\n", + (long)PL_savestack_ix); if (PL_tmps_floor != -1) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n", - (long)PL_tmps_floor + 1); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n", + (long)PL_tmps_floor + 1); if (cxstack_ix != -1) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n", - (long)cxstack_ix + 1); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n", + (long)cxstack_ix + 1); } /* Now absolutely destruct everything, somehow or other, loops or no. */ @@ -1161,7 +1163,7 @@ perl_destruct(pTHXx) PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p" " flags=0x%"UVxf " refcnt=%"UVuf pTHX__FORMAT "\n" - "\tallocated at %s:%d %s %s%s\n", + "\tallocated at %s:%d %s %s%s; serial %"UVuf"\n", (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt pTHX__VALUE, sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", @@ -1169,7 +1171,8 @@ perl_destruct(pTHXx) sv->sv_debug_inpad ? "for" : "by", sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)", - sv->sv_debug_cloned ? " (cloned)" : "" + sv->sv_debug_cloned ? " (cloned)" : "", + sv->sv_debug_serial ); #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP Perl_dump_sv_child(aTHX_ sv); @@ -1230,14 +1233,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; @@ -1626,6 +1633,105 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) return ret; } +/* This needs to stay in perl.c, as perl.c is compiled with different flags for + miniperl, and we need to see those flags reflected in the values here. */ + +/* What this returns is subject to change. Use the public interface in Config. + */ +static void +S_Internals_V(pTHX_ CV *cv) +{ + dXSARGS; +#ifdef LOCAL_PATCH_COUNT + const int local_patch_count = LOCAL_PATCH_COUNT; +#else + const int local_patch_count = 0; +#endif + const int entries = 3 + local_patch_count; + int i; + static char non_bincompat_options[] = +# ifdef DEBUGGING + " DEBUGGING" +# endif +# ifdef NO_MATHOMS + " NO_MATHOMS" +# endif +# ifdef PERL_DISABLE_PMC + " PERL_DISABLE_PMC" +# endif +# ifdef PERL_DONT_CREATE_GVSV + " PERL_DONT_CREATE_GVSV" +# endif +# ifdef PERL_IS_MINIPERL + " PERL_IS_MINIPERL" +# endif +# ifdef PERL_MALLOC_WRAP + " PERL_MALLOC_WRAP" +# endif +# ifdef PERL_MEM_LOG + " PERL_MEM_LOG" +# endif +# ifdef PERL_MEM_LOG_NOIMPL + " PERL_MEM_LOG_NOIMPL" +# endif +# ifdef PERL_USE_DEVEL + " PERL_USE_DEVEL" +# endif +# ifdef PERL_USE_SAFE_PUTENV + " PERL_USE_SAFE_PUTENV" +# endif +# ifdef USE_ATTRIBUTES_FOR_PERLIO + " USE_ATTRIBUTES_FOR_PERLIO" +# endif +# ifdef USE_FAST_STDIO + " USE_FAST_STDIO" +# endif +# ifdef USE_PERL_ATOF + " USE_PERL_ATOF" +# endif +# ifdef USE_SITECUSTOMIZE + " USE_SITECUSTOMIZE" +# endif + ; + PERL_UNUSED_ARG(cv); + PERL_UNUSED_ARG(items); + + EXTEND(SP, entries); + + PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0))); + PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options, + sizeof(non_bincompat_options) - 1, SVs_TEMP)); + +#ifdef __DATE__ +# ifdef __TIME__ + PUSHs(Perl_newSVpvn_flags(aTHX_ + STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__), + SVs_TEMP)); +# else + PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__), + SVs_TEMP)); +# endif +#else + PUSHs(&PL_sv_undef); +#endif + + for (i = 1; i <= local_patch_count; i++) { + /* This will be an undef, if PL_localpatches[i] is NULL. */ + PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0))); + } + + XSRETURN(entries); +} + +#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) { @@ -1635,7 +1741,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 @@ -1647,8 +1752,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(); { @@ -1707,11 +1810,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(""); @@ -1742,12 +1840,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } if (s && *s) { STRLEN len = strlen(s); - const char * const p = savepvn(s, len); - incpush(p, TRUE, TRUE, FALSE, FALSE, FALSE); - sv_catpvs(sv, "-I"); - sv_catpvn(sv, p, len); - sv_catpvs(sv, " "); - Safefree(p); + incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS); } else Perl_croak(aTHX_ "No directory specified for -I"); @@ -1761,103 +1854,17 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) { SV *opts_prog; - Perl_av_create_and_push(aTHX_ &PL_preambleav, newSVpvs("use Config;")); if (*++s != ':') { - /* Can't do newSVpvs() as that would involve pre-processor - condititionals inside a macro expansion. */ - opts_prog = Perl_newSVpv(aTHX_ "$_ = join ' ', sort qw(" -# ifdef DEBUGGING - " DEBUGGING" -# endif -# ifdef NO_MATHOMS - " NO_MATHOMS" -# endif -# ifdef PERL_DONT_CREATE_GVSV - " PERL_DONT_CREATE_GVSV" -# endif -# ifdef PERL_MALLOC_WRAP - " PERL_MALLOC_WRAP" -# endif -# 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" -# endif -# ifdef PERL_USE_DEVEL - " PERL_USE_DEVEL" -# endif -# ifdef PERL_USE_SAFE_PUTENV - " PERL_USE_SAFE_PUTENV" -# endif -# ifdef USE_SITECUSTOMIZE - " USE_SITECUSTOMIZE" -# endif -# ifdef USE_FAST_STDIO - " USE_FAST_STDIO" -# endif - , 0); - - sv_catpv(opts_prog, PL_bincompat_options); - /* Terminate the qw(, and then wrap at 76 columns. */ - sv_catpvs(opts_prog, "); s/(?=.{53})(.{1,53}) /$1\\n /mg;print Config::myconfig(),"); -#ifdef VMS - sv_catpvs(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n"); -#else - sv_catpvs(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n"); -#endif - sv_catpvs(opts_prog," Compile-time options: $_\\n\","); - -#if defined(LOCAL_PATCH_COUNT) - if (LOCAL_PATCH_COUNT > 0) { - int i; - sv_catpvs(opts_prog, - "\" Locally applied patches:\\n\","); - for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { - if (PL_localpatches[i]) - Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,", - 0, PL_localpatches[i], 0); - } - } -#endif - Perl_sv_catpvf(aTHX_ opts_prog, - "\" Built under %s\\n",OSNAME); -#ifdef __DATE__ -# ifdef __TIME__ - sv_catpvs(opts_prog, - " Compiled at " __DATE__ " " __TIME__ "\\n\""); -# else - sv_catpvs(opts_prog, " Compiled on " __DATE__ "\\n\""); -# endif -#endif - sv_catpvs(opts_prog, "; $\"=\"\\n \"; " - "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } " - "sort grep {/^PERL/} keys %ENV; "); -#ifdef __CYGWIN__ - sv_catpvs(opts_prog, - "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";"); -#endif - sv_catpvs(opts_prog, - "print \" \\%ENV:\\n @env\\n\" if @env;" - "print \" \\@INC:\\n @INC\\n\";"); + opts_prog = newSVpvs("use Config; Config::_V()"); } else { ++s; opts_prog = Perl_newSVpvf(aTHX_ - "Config::config_vars(qw%c%s%c)", + "use Config; Config::config_vars(qw%c%s%c)", 0, s, 0); s += strlen(s); } - av_push(PL_preambleav, opts_prog); + Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog); /* don't look for script or read stdin */ scriptname = BIT_BUCKET; goto reswitch; @@ -1924,7 +1931,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)) { @@ -1950,10 +1957,15 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } -#ifdef USE_SITECUSTOMIZE +#if defined(USE_SITECUSTOMIZE) && !defined(PERL_IS_MINIPERL) if (!minus_f) { + /* SITELIB_EXP is a function call on Win32. + The games with local $! are to avoid setting errno if there is no + sitecustomize script. */ + const char *const sitelib = SITELIB_EXP; (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, - Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP)); + Perl_newSVpvf(aTHX_ + "BEGIN { do {local $!; -f '%s/sitecustomize.pl'} && do '%s/sitecustomize.pl' }", sitelib, sitelib)); } #endif @@ -1994,20 +2006,15 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # endif Sighandler_t sigstate = rsignal_state(SIGCHLD); if (sigstate == (Sighandler_t) SIG_IGN) { - if (ckWARN(WARN_SIGNAL)) - Perl_warner(aTHX_ packWARN(WARN_SIGNAL), - "Can't ignore signal CHLD, forcing to default"); + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), + "Can't ignore signal CHLD, forcing to default"); (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); } } # 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. */ @@ -2029,8 +2036,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) boot_core_PerlIO(); boot_core_UNIVERSAL(); - boot_core_xsutils(); boot_core_mro(); + newXS("Internals::V", S_Internals_V, __FILE__); if (xsinit) (*xsinit)(aTHX); /* in case linked C routines want magical variables */ @@ -2062,6 +2069,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #if defined(__SYMBIAN32__) PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */ #endif +# ifndef PERL_IS_MINIPERL if (PL_unicode) { /* Requires init_predump_symbols(). */ if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { @@ -2100,6 +2108,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } } +#endif { const char *s; @@ -2148,16 +2157,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); @@ -2166,7 +2165,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) { @@ -2195,6 +2193,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #endif ENTER; + PL_restartjmpenv = NULL; PL_restartop = 0; return NULL; } @@ -2277,20 +2276,15 @@ S_run_body(pTHX_ I32 oldscope) exit(0); /* less likely to core dump than my_exit(0) */ } #endif - DEBUG_x(dump_all()); #ifdef DEBUGGING + if (DEBUG_x_TEST || DEBUG_B_TEST) + dump_all_perl(!DEBUG_B_TEST); if (!DEBUG_q_TEST) PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); #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) @@ -2305,6 +2299,7 @@ S_run_body(pTHX_ I32 oldscope) /* do it */ if (PL_restartop) { + PL_restartjmpenv = NULL; PL_op = PL_restartop; PL_restartop = 0; CALLRUNOPS(aTHX); @@ -2514,9 +2509,13 @@ Perl_call_method(pTHX_ const char *methname, I32 flags) /* name of the subroutine */ /* See G_* flags in cop.h */ { + STRLEN len; PERL_ARGS_ASSERT_CALL_METHOD; - return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD); + len = strlen(methname); + + /* XXX: sv_2mortal(newSVpvn_share(methname, len)) can be faster */ + return call_sv(newSVpvn_flags(methname, len, SVs_TEMP), flags | G_METHOD); } /* May be called with any of a CV, a GV, or an SV containing the name. */ @@ -2619,12 +2618,11 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) PL_curstash = PL_defstash; FREETMPS; JMPENV_POP; - if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) - Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ case 3: if (PL_restartop) { + PL_restartjmpenv = NULL; PL_op = PL_restartop; PL_restartop = 0; goto redo_body; @@ -2721,12 +2719,11 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) PL_curstash = PL_defstash; FREETMPS; JMPENV_POP; - if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) - Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ case 3: if (PL_restartop) { + PL_restartjmpenv = NULL; PL_op = PL_restartop; PL_restartop = 0; goto redo_body; @@ -2819,47 +2816,51 @@ S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */ /* This message really ought to be max 23 lines. * Removed -h because the user already knows that option. Others? */ + /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89 + minimum of 509 character string literals. */ static const char * const usage_msg[] = { -"-0[octal] specify record separator (\\0, if no argument)", -"-a autosplit mode with -n or -p (splits $_ into @F)", -"-C[number/list] enables the listed Unicode features", -"-c check syntax only (runs BEGIN and CHECK blocks)", -"-d[:debugger] run program under debugger", -"-D[number/list] set debugging flags (argument is a bit mask or alphabets)", -"-e program one line of program (several -e's allowed, omit programfile)", -"-E program like -e, but enables all optional features", -"-f don't do $sitelib/sitecustomize.pl at startup", -"-F/pattern/ split() pattern for -a switch (//'s are optional)", -"-i[extension] edit <> files in place (makes backup if extension supplied)", -"-Idirectory specify @INC/#include directory (several -I's allowed)", -"-l[octal] enable line ending processing, specifies line terminator", -"-[mM][-]module execute \"use/no module...\" before executing program", -"-n assume \"while (<>) { ... }\" loop around program", -"-p assume loop like -n but print line also, like sed", -"-s enable rudimentary parsing for switches after programfile", -"-S look for programfile using PATH environment variable", -"-t enable tainting warnings", -"-T enable tainting checks", -"-u dump core after parsing program", -"-U allow unsafe operations", -"-v print version, subversion (includes VERY IMPORTANT perl info)", -"-V[:variable] print configuration summary (or a single Config.pm variable)", -"-w enable many useful warnings (RECOMMENDED)", -"-W enable all warnings", -"-x[directory] strip off text before #!perl line and perhaps cd to directory", -"-X disable all warnings", -"\n", +" -0[octal] specify record separator (\\0, if no argument)\n" +" -a autosplit mode with -n or -p (splits $_ into @F)\n" +" -C[number/list] enables the listed Unicode features\n" +" -c check syntax only (runs BEGIN and CHECK blocks)\n" +" -d[:debugger] run program under debugger\n" +" -D[number/list] set debugging flags (argument is a bit mask or alphabets)\n", +" -e program one line of program (several -e's allowed, omit programfile)\n" +" -E program like -e, but enables all optional features\n" +" -f don't do $sitelib/sitecustomize.pl at startup\n" +" -F/pattern/ split() pattern for -a switch (//'s are optional)\n" +" -i[extension] edit <> files in place (makes backup if extension supplied)\n" +" -Idirectory specify @INC/#include directory (several -I's allowed)\n", +" -l[octal] enable line ending processing, specifies line terminator\n" +" -[mM][-]module execute \"use/no module...\" before executing program\n" +" -n assume \"while (<>) { ... }\" loop around program\n" +" -p assume loop like -n but print line also, like sed\n" +" -s enable rudimentary parsing for switches after programfile\n" +" -S look for programfile using PATH environment variable\n", +" -t enable tainting warnings\n" +" -T enable tainting checks\n" +" -u dump core after parsing program\n" +" -U allow unsafe operations\n" +" -v print version, patchlevel and license\n" +" -V[:variable] print configuration summary (or a single Config.pm variable)\n", +" -w enable many useful warnings (RECOMMENDED)\n" +" -W enable all warnings\n" +" -x[directory] ignore text before #!perl line (optionally cd to directory)\n" +" -X disable all warnings\n" +" \n" +"Run 'perldoc perl' for more help with Perl.\n\n", NULL }; const char * const *p = usage_msg; + PerlIO *out = PerlIO_stdout(); PERL_ARGS_ASSERT_USAGE; - PerlIO_printf(PerlIO_stdout(), - "\nUsage: %s [switches] [--] [programfile] [arguments]", + PerlIO_printf(out, + "\nUsage: %s [switches] [--] [programfile] [arguments]\n", name); while (*p) - PerlIO_printf(PerlIO_stdout(), "\n %s", *p++); + PerlIO_puts(out, *p++); } /* convert a string of -D options (or digits) into an int. @@ -2870,29 +2871,31 @@ int Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) { static const char * const usage_msgd[] = { - " Debugging flag values: (see also -d)", - " p Tokenizing and parsing (with v, displays parse stack)", - " s Stack snapshots (with v, displays all stacks)", - " l Context (loop) stack processing", - " t Trace execution", - " o Method and overloading resolution", - " c String/numeric conversions", - " P Print profiling info, source file input state", - " m Memory and SV allocation", - " f Format processing", - " r Regular expression parsing and execution", - " x Syntax tree dump", - " u Tainting checks", - " H Hash dump -- usurps values()", - " X Scratchpad allocation", - " D Cleaning up", - " T Tokenising", - " R Include reference counts of dumped variables (eg when using -Ds)", - " J Do not s,t,P-debug (Jump over) opcodes within package DB", - " v Verbose: use in conjunction with other flags", - " C Copy On Write", - " A Consistency checks on internal structures", - " q quiet - currently only suppresses the 'EXECUTING' message", + " Debugging flag values: (see also -d)\n" + " p Tokenizing and parsing (with v, displays parse stack)\n" + " s Stack snapshots (with v, displays all stacks)\n" + " l Context (loop) stack processing\n" + " t Trace execution\n" + " o Method and overloading resolution\n", + " c String/numeric conversions\n" + " P Print profiling info, source file input state\n" + " m Memory and SV allocation\n" + " f Format processing\n" + " r Regular expression parsing and execution\n" + " x Syntax tree dump\n", + " u Tainting checks\n" + " H Hash dump -- usurps values()\n" + " X Scratchpad allocation\n" + " D Cleaning up\n" + " T Tokenising\n" + " R Include reference counts of dumped variables (eg when using -Ds)\n", + " J Do not s,t,P-debug (Jump over) opcodes within package DB\n" + " v Verbose: use in conjunction with other flags\n" + " C Copy On Write\n" + " A Consistency checks on internal structures\n" + " q quiet - currently only suppresses the 'EXECUTING' message\n" + " M trace smart match resolution\n" + " B dump suBroutine definitions, including special Blocks like BEGIN\n", NULL }; int i = 0; @@ -2901,7 +2904,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); @@ -2918,7 +2921,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) } else if (givehelp) { const char *const *p = usage_msgd; - while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++); + while (*p) PerlIO_puts(PerlIO_stdout(), *p++); } # ifdef EBCDIC if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING)) @@ -3092,9 +3095,8 @@ Perl_moreswitches(pTHX_ const char *s) while (isSPACE(*p)) p++; } while (*p && *p != '-'); - e = savepvn(s, e-s); - incpush(e, TRUE, TRUE, FALSE, FALSE, TRUE); - Safefree(e); + incpush(s, e-s, + INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT); s = p; if (*s == '-') s++; @@ -3205,9 +3207,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; @@ -3222,10 +3221,11 @@ Perl_moreswitches(pTHX_ const char *s) { SV* level= vstringify(PL_patchlevel); #ifdef PERL_PATCHNUM - SV* num= newSVpvn(PERL_PATCHNUM,sizeof(PERL_PATCHNUM)-1); -#ifdef PERL_GIT_UNCOMMITTED_CHANGES - sv_catpvs(num, "*"); -#endif +# ifdef PERL_GIT_UNCOMMITTED_CHANGES + SV *num = newSVpvs(PERL_PATCHNUM "*"); +# else + SV *num = newSVpvs(PERL_PATCHNUM); +# endif if (sv_len(num)>=sv_len(level) && strnEQ(SvPV_nolen(num),SvPV_nolen(level),sv_len(level))) { SvREFCNT_dec(level); @@ -3236,10 +3236,11 @@ Perl_moreswitches(pTHX_ const char *s) } #endif PerlIO_printf(PerlIO_stdout(), - "\nThis is perl, %"SVf - " built for %s", - level, - ARCHNAME); + "\nThis is perl " STRINGIFY(PERL_REVISION) + ", version " STRINGIFY(PERL_VERSION) + ", subversion " STRINGIFY(PERL_SUBVERSION) + " (%"SVf") built for " ARCHNAME, level + ); SvREFCNT_dec(level); } #else /* DGUX */ @@ -3264,12 +3265,7 @@ Perl_moreswitches(pTHX_ const char *s) #endif 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 + "\n\nCopyright 1987-2010, Larry Wall\n"); #ifdef MSDOS PerlIO_printf(PerlIO_stdout(), "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); @@ -3312,10 +3308,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"); @@ -3514,7 +3506,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, PERL_ARGS_ASSERT_OPEN_SCRIPT; if (PL_e_script) { - PL_origfilename = (PL_minus_E ? savepvs("-E") : savepvs( "-e" )); + PL_origfilename = savepvs("-e"); } else { /* if find_script() returns, it returns a malloc()-ed value */ @@ -3666,38 +3658,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 */ @@ -3712,20 +3680,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 } } } @@ -3875,6 +3829,9 @@ Perl_init_stacks(pTHX) SET_MARK_OFFSET; Newx(PL_scopestack,REASONABLE(32),I32); +#ifdef DEBUGGING + Newx(PL_scopestack_name,REASONABLE(32),const char*); +#endif PL_scopestack_ix = 0; PL_scopestack_max = REASONABLE(32); @@ -3901,6 +3858,9 @@ S_nuke_stacks(pTHX) Safefree(PL_tmps_stack); Safefree(PL_markstack); Safefree(PL_scopestack); +#ifdef DEBUGGING + Safefree(PL_scopestack_name); +#endif Safefree(PL_savestack); } @@ -3911,10 +3871,34 @@ S_init_predump_symbols(pTHX) dVAR; GV *tmpgv; IO *io; + AV *isa; sv_setpvs(get_sv("\"", GV_ADD), " "); PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV)); + + /* Historically, PVIOs were blessed into IO::Handle, unless + FileHandle was loaded, in which case they were blessed into + that. Action at a distance. + However, if we simply bless into IO::Handle, we break code + that assumes that PVIOs will have (among others) a seek + method. IO::File inherits from IO::Handle and IO::Seekable, + and provides the needed methods. But if we simply bless into + it, then we break code that assumed that by loading + IO::Handle, *it* would work. + So a compromise is to set up the correct @IO::File::ISA, + so that code that does C; will still work. + */ + + isa = get_av("IO::File::ISA", GV_ADD | GV_ADDMULTI); + av_push(isa, newSVpvs("IO::Handle")); + av_push(isa, newSVpvs("IO::Seekable")); + av_push(isa, newSVpvs("Exporter")); + (void) gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVGV); + (void) gv_fetchpvs("IO::Seekable::", GV_ADD, SVt_PVGV); + (void) gv_fetchpvs("Exporter::", GV_ADD, SVt_PVGV); + + PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO); GvMULTI_on(PL_stdingv); io = GvIOp(PL_stdingv); @@ -3944,9 +3928,6 @@ S_init_predump_symbols(pTHX) GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io)); PL_statname = newSV(0); /* last filename we did stat on */ - - Safefree(PL_osname); - PL_osname = savepv(OSNAME); } void @@ -4011,17 +3992,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; @@ -4090,23 +4061,33 @@ STATIC void S_init_perllib(pTHX) { dVAR; - char *s; +#ifndef VMS + const char *perl5lib = NULL; +#endif + const char *s; +#if defined(WIN32) && !defined(PERL_IS_MINIPERL) + 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(s, TRUE, TRUE, TRUE, FALSE, FALSE); - else - incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE, FALSE); + incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS); + else { + s = PerlEnv_getenv("PERLLIB"); + if (s) + incpush_use_sep(s, 0, 0); + } #else /* VMS */ /* Treat PERL5?LIB as a possible search list logical name -- the * "natural" VMS idiom for a Unix path string. We allow each @@ -4115,102 +4096,154 @@ S_init_perllib(pTHX) char buf[256]; int idx = 0; if (my_trnlnm("PERL5LIB",buf,0)) - do { incpush(buf,TRUE,TRUE,TRUE,FALSE, FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx)); - else - while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE, FALSE); + do { + incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS); + } while (my_trnlnm("PERL5LIB",buf,++idx)); + else { + while (my_trnlnm("PERLLIB",buf,idx++)) + incpush_use_sep(buf, 0, 0); + } #endif /* VMS */ } +#ifndef PERL_IS_MINIPERL + /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC + (and not the architecture specific directories from $ENV{PERL5LIB}) */ + /* Use the ~-expanded versions of APPLLIB (undocumented), - ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB + SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB */ #ifdef APPLLIB_EXP - incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE, FALSE); -#endif - -#ifdef ARCHLIB_EXP - incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE, FALSE); -#endif -#ifdef MACOS_TRADITIONAL - { - Stat_t tmpstatbuf; - SV * privdir = newSV(0); - char * macperl = PerlEnv_getenv("MACPERL"); - - if (!macperl) - macperl = ""; - - 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, FALSE, 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, FALSE, FALSE); - - SvREFCNT_dec(privdir); - } - if (!PL_tainting) - incpush(":", FALSE, FALSE, FALSE, FALSE, 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, TRUE, FALSE); -#else - incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE, FALSE); + S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), + INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); #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, TRUE, FALSE); + 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(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE, FALSE); + s = win32_get_sitelib(PERL_FS_VERSION, &len); + if (s) + incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); # else - incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE, FALSE); + 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(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE, FALSE); -#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, TRUE, FALSE); + S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP), + INCPUSH_CAN_RELOCATE); # endif #endif #ifdef PERL_VENDORLIB_EXP # if defined(WIN32) - incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE, FALSE); /* this picks up vendorarch as well */ + /* this picks up vendorarch as well */ + s = win32_get_vendorlib(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(PERL_VENDORLIB_EXP), + INCPUSH_CAN_RELOCATE); +# endif +#endif + +#ifdef ARCHLIB_EXP + S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE); +#endif + +#ifndef PRIVLIB_EXP +# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" +#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); +#else +# ifdef NETWARE + S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE); # else - incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE, FALSE); + S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE); # endif #endif +#ifdef PERL_OTHERLIBDIRS + 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), + SITELIB and VENDORLIB for older versions +*/ +#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 */ - incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE, FALSE); + S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM), + INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); #endif #ifdef PERL_OTHERLIBDIRS - incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE, FALSE); + S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), + INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS + |INCPUSH_CAN_RELOCATE); #endif +#endif /* !PERL_IS_MINIPERL */ if (!PL_tainting) - incpush(".", FALSE, FALSE, FALSE, FALSE, FALSE); -#endif /* MACOS_TRADITIONAL */ + S_incpush(aTHX_ STR_WITH_LEN("."), 0); } #if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__) @@ -4219,11 +4252,7 @@ S_init_perllib(pTHX) # 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 @@ -4234,7 +4263,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_ SV *dir) +S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem) { dVAR; Stat_t tmpstatbuf; @@ -4243,59 +4272,60 @@ S_incpush_if_exists(pTHX_ SV *dir) if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) { - av_push(GvAVn(PL_incgv), dir); - dir = newSV(0); + av_push(av, dir); + dir = newSVsv(stem); + } else { + /* Truncate dir back to stem. */ + SvCUR_set(dir, SvCUR(stem)); } return dir; } STATIC void -S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, - bool canrelocate, bool unshift) +S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) { dVAR; - SV *subdir = NULL; - const char *p = dir; - - if (!p || !*p) - return; - - if (addsubdirs || addoldvers) { - subdir = newSV(0); - } - - /* Break at all separators */ - while (p && *p) { - SV *libdir = newSV(0); - const char *s; - - /* skip any consecutive separators */ - if (usesep) { - while ( *p == PERLLIB_SEP ) { - /* Uncomment the next line for PATH semantics */ - /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */ - p++; - } - } + 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; + AV *const inc = GvAVn(PL_incgv); - if ( usesep && (s = strchr(p, PERLLIB_SEP)) != NULL ) { - sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)), - (STRLEN)(s - p)); - p = s + 1; - } - else { - sv_setpv(libdir, PERLLIB_MANGLE(p, 0)); - p = NULL; /* break out */ - } -#ifdef MACOS_TRADITIONAL - if (!strchr(SvPVX(libdir), ':')) { - char buf[256]; + PERL_ARGS_ASSERT_INCPUSH; + assert(len > 0); - sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 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. */ + AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL; + + 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 + this way, ignoring any possible changed of length, since + 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave + it be. */ + libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len); + } else { + libdir = newSVpv(PERLLIB_MANGLE(dir, 0), 0); } - if (SvPVX(libdir)[SvCUR(libdir)-1] != ':') - sv_catpvs(libdir, ":"); -#endif /* Do the if() outside the #ifdef to avoid warnings about an unused parameter. */ @@ -4400,7 +4430,8 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, * 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 }; @@ -4410,6 +4441,7 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, char *unix; STRLEN len; + if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) { len = strlen(unix); while (unix[len-1] == '/') len--; /* Cosmetic */ @@ -4420,64 +4452,104 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, "Failed to unixify @INC element \"%s\"\n", SvPV(libdir,len)); #endif - if (addsubdirs) { -#ifdef MACOS_TRADITIONAL -#define PERL_AV_SUFFIX_FMT "" -#define PERL_ARCH_FMT "%s:" -#define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT -#else -#define PERL_AV_SUFFIX_FMT "/" -#define PERL_ARCH_FMT "/%s" -#define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT -#endif - /* .../version/archname if -d .../version/archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT, - SVfARG(libdir), - (int)PERL_REVISION, (int)PERL_VERSION, - (int)PERL_SUBVERSION, ARCHNAME); - subdir = S_incpush_if_exists(aTHX_ subdir); - /* .../version if -d .../version */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, - SVfARG(libdir), - (int)PERL_REVISION, (int)PERL_VERSION, - (int)PERL_SUBVERSION); - subdir = S_incpush_if_exists(aTHX_ 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_ 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_ 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 */ if (unshift) { - av_unshift( GvAVn( PL_incgv ), 1 ); - av_store( GvAVn( PL_incgv ), 0, libdir ); + U32 extra = av_len(av) + 1; + av_unshift(inc, extra + push_basedir); + if (push_basedir) + av_store(inc, extra, libdir); + while (extra--) { + /* av owns a reference, av_store() expects to be donated a + reference, and av expects to be sane when it's cleared. + If I wanted to be naughty and wrong, I could peek inside the + implementation of av_clear(), realise that it uses + SvREFCNT_dec() too, so av's array could be a run of NULLs, + and so directly steal from it (with a memcpy() to inc, and + then memset() to NULL them out. But people copy code from the + core expecting it to be best practise, so let's use the API. + Although studious readers will note that I'm not checking any + return codes. */ + av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE))); + } + SvREFCNT_dec(av); } - else { - av_push(GvAVn(PL_incgv), libdir); + else if (push_basedir) { + av_push(inc, libdir); + } + + if (!push_basedir) { + assert (SvREFCNT(libdir) == 1); + SvREFCNT_dec(libdir); } - } - if (subdir) { - assert (SvREFCNT(subdir) == 1); - SvREFCNT_dec(subdir); } } +STATIC void +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 ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) { + if (s == p) { + /* skip any consecutive separators */ + + /* Uncomment the next line for PATH semantics */ + /* But you'll need to write tests */ + /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */ + } else { + incpush(p, (STRLEN)(s - p), flags); + } + p = s + 1; + } + if (p != end) + incpush(p, (STRLEN)(end - p), flags); + +} void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) @@ -4555,16 +4627,6 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) PL_curcop = &PL_compiling; CopLINE_set(PL_curcop, oldline); JMPENV_POP; - if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) { - if (paramList == PL_beginav) - Perl_croak(aTHX_ "BEGIN failed--compilation aborted"); - else - Perl_croak(aTHX_ "%s failed--call queue aborted", - paramList == PL_checkav ? "CHECK" - : paramList == PL_initav ? "INIT" - : paramList == PL_unitcheckav ? "UNITCHECK" - : "END"); - } my_exit_jump(); /* NOTREACHED */ case 3: