SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
sv_setpv(&PL_sv_no,PL_No);
+ /* value lookup in void context - happens to have the side effect
+ of caching the numeric forms. */
+ SvIV(&PL_sv_no);
SvNV(&PL_sv_no);
SvREADONLY_on(&PL_sv_no);
SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
sv_setpv(&PL_sv_yes,PL_Yes);
+ SvIV(&PL_sv_yes);
SvNV(&PL_sv_yes);
SvREADONLY_on(&PL_sv_yes);
SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
init_i18nl10n(1);
SET_NUMERIC_STANDARD();
- {
- U8 *s;
- PL_patchlevel = NEWSV(0,4);
- (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
- if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
- SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
- s = (U8*)SvPVX(PL_patchlevel);
- /* Build version strings using "native" characters */
- s = uvchr_to_utf8(s, (UV)PERL_REVISION);
- s = uvchr_to_utf8(s, (UV)PERL_VERSION);
- s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
- *s = '\0';
- SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
- SvPOK_on(PL_patchlevel);
- SvNVX(PL_patchlevel) = (NV)PERL_REVISION +
- ((NV)PERL_VERSION / (NV)1000) +
- ((NV)PERL_SUBVERSION / (NV)1000000);
- SvNOK_on(PL_patchlevel); /* dual valued */
- SvUTF8_on(PL_patchlevel);
- SvREADONLY_on(PL_patchlevel);
- }
-
#if defined(LOCAL_PATCH_COUNT)
PL_localpatches = local_patches; /* For possible -v */
#endif
#endif
/* Use sysconf(_SC_CLK_TCK) if available, if not
- * available or if the sysconf() fails, use the HZ. */
-#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
+ * available or if the sysconf() fails, use the HZ.
+ * BeOS has those, but returns the wrong value. */
+#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
PL_clocktick = sysconf(_SC_CLK_TCK);
if (PL_clocktick <= 0)
#endif
PL_stashcache = newHV();
+ PL_patchlevel = newSVpv(
+ Perl_form(aTHX_ "%d.%d.%d",
+ (int)PERL_REVISION,
+ (int)PERL_VERSION,
+ (int)PERL_SUBVERSION ), 0
+ );
+
ENTER;
}
*/
#ifndef PERL_MICRO
#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
- if (environ != PL_origenviron
+ if (environ != PL_origenviron && !PL_use_safe_putenv
#ifdef USE_ITHREADS
/* only main thread can free environ[0] contents */
&& PL_curinterp == aTHX
#endif
#endif /* !PERL_MICRO */
+ /* reset so print() ends up where we expect */
+ setdefout(Nullgv);
+
#ifdef USE_ITHREADS
/* the syntax tree is shared between clones
* so op_free(PL_main_root) only ReREFCNT_dec's
PL_dbargs = Nullav;
PL_debstash = Nullhv;
- /* reset so print() ends up where we expect */
- setdefout(Nullgv);
-
SvREFCNT_dec(PL_argvout_stack);
PL_argvout_stack = Nullav;
svend = &sva[SvREFCNT(sva)];
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) != SVTYPEMASK) {
- PerlIO_printf(Perl_debug_log, "leaked: 0x%p"
- pTHX__FORMAT "\n",
- sv pTHX__VALUE);
+ PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
+ " flags=0x08%"UVxf
+ " refcnt=%"UVuf pTHX__FORMAT "\n",
+ sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE);
}
}
}
}
}
/* we know that type >= SVt_PV */
- (void)SvOOK_off(PL_mess_sv);
+ SvOOK_off(PL_mess_sv);
Safefree(SvPVX(PL_mess_sv));
Safefree(SvANY(PL_mess_sv));
Safefree(PL_mess_sv);
CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
(OP*)&myop, TRUE);
#else
+ /* fail now; otherwise we could fail after the JMPENV_PUSH but
+ * before a PUSHEVAL, which corrupts the stack after a croak */
+ TAINT_PROPER("eval_sv()");
+
JMPENV_PUSH(ret);
#endif
switch (ret) {
#ifdef DEBUGGING
int
-Perl_get_debug_opts(pTHX_ char **s)
+Perl_get_debug_opts(pTHX_ char **s, bool givehelp)
{
static char *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",
+ " s Stack snapshots (with v, displays all stacks)",
" l Context (loop) stack processing",
" t Trace execution",
" o Method and overloading resolution",
" f Format processing",
" r Regular expression parsing and execution",
" x Syntax tree dump",
- " u Tainting checks (Obsolete, previously used for LEAKTEST)",
+ " u Tainting checks",
" H Hash dump -- usurps values()",
" X Scratchpad allocation",
" D Cleaning up",
" v Verbose: use in conjunction with other flags",
" C Copy On Write",
" A Consistency checks on internal structures",
- " q quiet - currently only suppressed the 'EXECUTING' message",
+ " q quiet - currently only suppresses the 'EXECUTING' message",
NULL
};
int i = 0;
i = atoi(*s);
for (; isALNUM(**s); (*s)++) ;
}
- else {
+ else if (givehelp) {
char **p = usage_msgd;
while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
}
case 'd':
forbid_setid("-d");
s++;
+
+ /* -dt indicates to the debugger that threads will be used */
+ if (*s == 't' && !isALNUM(s[1])) {
+ ++s;
+ my_setenv("PERL5DB_THREADED", "1");
+ }
+
/* The following permits -d:Mod to accepts arguments following an =
in the fashion that -MSome::Mod does. */
if (*s == ':' || *s == '=') {
#ifdef DEBUGGING
forbid_setid("-D");
s++;
- PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
+ PL_debug = get_debug_opts(&s, 1) | DEBUG_TOP_FLAG;
#else /* !DEBUGGING */
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
av_push(PL_preambleav, sv);
}
else
- Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
+ Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
return s;
case 'n':
PL_minus_n = TRUE;
s++;
return s;
case 'v':
+ if (!sv_derived_from(PL_patchlevel, "version"))
+ (void *)upg_version(PL_patchlevel);
#if !defined(DGUX)
PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
- PL_patchlevel, ARCHNAME));
+ Perl_form(aTHX_ "\nThis is perl, v%_ built for %s",
+ vstringify(PL_patchlevel),
+ ARCHNAME));
#else /* DGUX */
/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
+ Perl_form(aTHX_ "\nThis is perl, v%_\n",
+ vstringify(PL_patchlevel)));
PerlIO_printf(PerlIO_stdout(),
Perl_form(aTHX_ " built under %s at %s %s\n",
OSNAME, __DATE__, __TIME__));
GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
Complete documentation for Perl, including FAQ lists, should be found on\n\
this system using `man perl' or `perldoc perl'. If you have access to the\n\
-Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
+Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
my_exit(0);
case 'w':
if (! (PL_dowarn & G_WARN_ALL_MASK))
/* Sanity check on buffer end */
while ((*s) && !isSPACE(*s)) s++;
for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
- (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
+ (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
+ || s2[-1] == '-')); s2--) ;
/* Sanity check on buffer start */
if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) &&
(s-9 < SvPV(PL_linestr,n_a)+2 || strnNE(s-9,"perl",4)) )
s2 = s;
while (*s == ' ' || *s == '\t') s++;
if (*s++ == '-') {
- while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
+ while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
+ || s2[-1] == '_') s2--;
if (strnEQ(s2-4,"perl",4))
/*SUPPRESS 530*/
while ((s = moreswitches(s)))
#endif /* HAS_PROCSELFEXE */
STATIC void
+S_set_caret_X(pTHX) {
+ GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
+ if (tmpgv) {
+#ifdef HAS_PROCSELFEXE
+ S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
+#else
+#ifdef OS2
+ sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
+#else
+ sv_setpv(GvSV(tmpgv),PL_origargv[0]);
+#endif
+#endif
+ }
+}
+
+STATIC void
S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
{
char *s;
magicname("0", "0", 1);
#endif
}
- if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
-#ifdef HAS_PROCSELFEXE
- S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
-#else
-#ifdef OS2
- sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
-#else
- sv_setpv(GvSV(tmpgv),PL_origargv[0]);
-#endif
-#endif
- }
+ S_set_caret_X(aTHX);
if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
HV *hv;
GvMULTI_on(PL_envgv);
{
environ[0] = Nullch;
}
- if (env)
+ if (env) {
+ char** origenv = environ;
for (; *env; env++) {
- if (!(s = strchr(*env,'=')))
+ if (!(s = strchr(*env,'=')) || s == *env)
continue;
#if defined(MSDOS) && !defined(DJGPP)
*s = '\0';
(void)hv_store(hv, *env, s - *env, sv, 0);
if (env != environ)
mg_set(sv);
+ if (origenv != environ) {
+ /* realloc has shifted us */
+ env = (env - origenv) + environ;
+ origenv = environ;
+ }
}
+ }
#endif /* USE_ENVIRON_ARRAY */
#endif /* !PERL_MICRO */
}
# define PERLLIB_MANGLE(s,n) (s)
#endif
+/* Push a directory onto @INC if it exists.
+ 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)
+{
+ Stat_t tmpstatbuf;
+ if (PerlLIO_stat(SvPVX(dir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode)) {
+ av_push(GvAVn(PL_incgv), dir);
+ dir = NEWSV(0,0);
+ }
+ return dir;
+}
+
STATIC void
S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
{
return;
if (addsubdirs || addoldvers) {
- subdir = sv_newmortal();
+ subdir = NEWSV(0,0);
}
/* Break at all separators */
const char *incverlist[] = { PERL_INC_VERSION_LIST };
const char **incver;
#endif
- Stat_t tmpstatbuf;
#ifdef VMS
char *unix;
STRLEN len;
libdir,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION, ARCHNAME);
- if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
- S_ISDIR(tmpstatbuf.st_mode))
- av_push(GvAVn(PL_incgv), newSVsv(subdir));
+ subdir = S_incpush_if_exists(aTHX_ subdir);
/* .../version if -d .../version */
Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION);
- if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
- S_ISDIR(tmpstatbuf.st_mode))
- av_push(GvAVn(PL_incgv), newSVsv(subdir));
+ subdir = S_incpush_if_exists(aTHX_ subdir);
/* .../archname if -d .../archname */
Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
- if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
- S_ISDIR(tmpstatbuf.st_mode))
- av_push(GvAVn(PL_incgv), newSVsv(subdir));
+ subdir = S_incpush_if_exists(aTHX_ subdir);
+
}
#ifdef PERL_INC_VERSION_LIST
for (incver = incverlist; *incver; incver++) {
/* .../xxx if -d .../xxx */
Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
- if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
- S_ISDIR(tmpstatbuf.st_mode))
- av_push(GvAVn(PL_incgv), newSVsv(subdir));
+ subdir = S_incpush_if_exists(aTHX_ subdir);
}
}
#endif
/* finally push this lib directory on the end of @INC */
av_push(GvAVn(PL_incgv), libdir);
}
+ if (subdir) {
+ assert (SvREFCNT(subdir) == 1);
+ SvREFCNT_dec(subdir);
+ }
}
#ifdef USE_5005THREADS