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;
#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
*/
#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
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);
}
}
}
#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;
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
https://perl5.git.perl.org / perl5.git / blobdiff