+#line 2 "perl.c"
/* perl.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
#define PERL_IN_PERL_C
#include "perl.h"
#include "patchlevel.h" /* for local_patches */
+#include "XSUB.h"
#ifdef NETWARE
#include "nwutil.h"
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;
PERL_UNUSED_ARG(my_perl);
#endif
+ assert(PL_scopestack_ix == 1);
+
/* wait for all pseudo-forked children to finish */
PERL_WAIT_FOR_CHILDREN;
}
LEAVE;
FREETMPS;
+ assert(PL_scopestack_ix == 0);
/* Need to flush since END blocks can produce output */
my_fflush_all();
/* 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);
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;
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. */
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;
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
+/* 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_SITECUSTOMIZE
+ " USE_SITECUSTOMIZE"
+# endif
+# ifdef USE_FAST_STDIO
+ " USE_FAST_STDIO"
+# 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)
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
SvGROW(linestr_sv, 80);
sv_setpvs(linestr_sv,"");
- sv = newSVpvs(""); /* first used for -I flags */
- SAVEFREESV(sv);
init_main_stash();
{
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("");
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");
{
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;
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)) {
}
}
-#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
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;
# 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. */
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 */
#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) {
}
}
}
+#endif
{
const char *s;
/* 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);
PL_origfilename);
}
}
-#endif
CopLINE_set(PL_curcop, 0);
PL_curstash = PL_defstash;
if (PL_e_script) {
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)
/* 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. */
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:
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:
" 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;
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);
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;
#endif
PerlIO_printf(PerlIO_stdout(),
"\nThis is perl, %"SVf
- " built for %s",
- level,
- ARCHNAME);
+ " built for " ARCHNAME,
+ level);
SvREFCNT_dec(level);
}
#else /* DGUX */
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");
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");
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 */
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
}
}
}
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);
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
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;
}
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);
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 */
}
+#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
*/
#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
-#ifdef MACOS_TRADITIONAL
- if (!old_vers) {
- Stat_t tmpstatbuf;
- SV * privdir = newSV(0);
- char * macperl = PerlEnv_getenv("MACPERL");
-
- if (!macperl)
- 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);
- 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), SvCUR(privdir), INCPUSH_ADD_SUB_DIRS);
-
- SvREFCNT_dec(privdir);
- if (!PL_tainting)
- S_incpush(aTHX_ STR_WITH_LEN(":"), 0);
- }
-#else
- if (!old_vers) {
-
#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
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
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
#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
# ifdef NETWARE
- S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
+ 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);
+ 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
+
+ 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
+#endif /* !PERL_IS_MINIPERL */
- /* 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__)
# 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
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;
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;
}
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;
+ AV *const inc = GvAVn(PL_incgv);
- 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,
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
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) {
* 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 };
char *unix;
STRLEN len;
+
if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
len = strlen(unix);
while (unix[len-1] == '/') len--; /* Cosmetic */
"Failed to unixify @INC element \"%s\"\n",
SvPV(libdir,len));
#endif
- if (addsubdirs) {
-#ifdef MACOS_TRADITIONAL
-#define PERL_ARCH_FMT_PREFIX ""
-#define PERL_ARCH_FMT_SUFFIX ":"
-#define PERL_ARCH_FMT_PATH PERL_FS_VERSION ""
-#else
-#define PERL_ARCH_FMT_PREFIX "/"
-#define PERL_ARCH_FMT_SUFFIX ""
-#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);
- /* .../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 */
- sv_setsv(subdir, libdir);
- sv_catpvs(subdir,
- PERL_ARCH_FMT_PREFIX ARCHNAME PERL_ARCH_FMT_SUFFIX);
- 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_PREFIX \
- "%s" PERL_ARCH_FMT_SUFFIX,
- 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 */
SvREFCNT_dec(libdir);
}
}
- if (subdir) {
- assert (SvREFCNT(subdir) == 1);
- SvREFCNT_dec(subdir);
- }
}
STATIC void
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:
https://perl5.git.perl.org / perl5.git / blobdiff