PL_stashcache = newHV();
-#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
- /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0 */
- {
- char *s = NULL;
-
- if (!PL_earlytaint)
- s = PerlEnv_getenv("PERL_HASH_SEED");
- if (s)
- while (isSPACE(*s)) s++;
- if (s && isDIGIT(*s))
- PL_hash_seed = (UV)Atoul(s);
-#ifndef USE_HASH_SEED_EXPLICIT
- else {
- /* Compute a random seed */
- (void)seedDrand01((Rand_seed_t)seed());
- PL_srand_called = TRUE;
- PL_hash_seed = (UV)(Drand01() * (NV)UV_MAX);
-#if RANDBITS < (UVSIZE * 8)
- {
- int skip = (UVSIZE * 8) - RANDBITS;
- PL_hash_seed >>= skip;
- /* The low bits might need extra help. */
- PL_hash_seed += (UV)(Drand01() * ((1 << skip) - 1));
- }
-#endif /* RANDBITS < (UVSIZE * 8) */
- }
-#endif /* USE_HASH_SEED_EXPLICIT */
- if (!PL_earlytaint && (s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG")))
- PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
- PL_hash_seed);
- }
-#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
-
ENTER;
}
#endif
#endif
+#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
+ /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
+ * This MUST be done before any hash stores or fetches take place. */
+ {
+ bool earlytaint = doing_taint(argc, argv, env);
+ char *s = NULL;
+
+ if (!earlytaint)
+ s = PerlEnv_getenv("PERL_HASH_SEED");
+ if (s)
+ while (isSPACE(*s)) s++;
+ if (s && isDIGIT(*s))
+ PL_hash_seed = (UV)Atoul(s);
+#ifndef USE_HASH_SEED_EXPLICIT
+ else {
+ /* Compute a random seed */
+ (void)seedDrand01((Rand_seed_t)seed());
+ PL_srand_called = TRUE;
+ PL_hash_seed = (UV)(Drand01() * (NV)UV_MAX);
+#if RANDBITS < (UVSIZE * 8)
+ /* Since there are not enough randbits to to reach all
+ * the bits of a UV, the low bits might need extra
+ * help. Sum in another random number that will
+ * fill in the low bits. */
+ PL_hash_seed +=
+ (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
+#endif /* RANDBITS < (UVSIZE * 8) */
+ }
+#endif /* USE_HASH_SEED_EXPLICIT */
+ if ((s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG")))
+ PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
+ PL_hash_seed);
+ }
+#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
+
PL_origargc = argc;
PL_origargv = argv;
* contiguous with the argv[]. This is used in mg.c:mg_set()
* as the maximum modifiable length of $0. In the worst case
* the area we are able to modify is limited to the size of
- * the original argv[0].
+ * the original argv[0]. (See below for 'contiguous', though.)
* --jhi */
char *s;
int i;
UV mask =
~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
-
- /* See if all the arguments are contiguous in memory.
- * Note that 'contiguous' is a loose term because some
- * platforms align the argv[] and the envp[]. We just check
- * that they are within aligned PTRSIZE bytes. As long as no
- * system has something bizarre like the argv[] interleaved
- * with some other data, we are fine. (Did I just evoke
- * Murphy's Law?) --jhi */
+ /* Do the mask check only if the args seem like aligned. */
+ UV aligned =
+ (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
+
+ /* See if all the arguments are contiguous in memory. Note
+ * that 'contiguous' is a loose term because some platforms
+ * align the argv[] and the envp[]. If the arguments look
+ * like non-aligned, assume that they are 'strictly' or
+ * 'traditionally' contiguous. If the arguments look like
+ * aligned, we just check that they are within aligned
+ * PTRSIZE bytes. As long as no system has something bizarre
+ * like the argv[] interleaved with some other data, we are
+ * fine. (Did I just evoke Murphy's Law?) --jhi */
s = PL_origargv[0];
while (*s) s++;
for (i = 1; i < PL_origargc; i++) {
- if (PL_origargv[i] > s &&
- PL_origargv[i] <=
- INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)) {
+ if ((PL_origargv[i] == s + 1
+#ifdef OS2
+ || PL_origargv[i] == s + 2
+#endif
+ )
+ ||
+ (aligned &&
+ (PL_origargv[i] > s &&
+ PL_origargv[i] <=
+ INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
+ )
+ {
s = PL_origargv[i];
while (*s) s++;
}
break;
}
/* Can we grab env area too to be used as the area for $0? */
- if (PL_origenviron &&
- PL_origenviron[0] > s &&
- PL_origenviron[0] <=
- INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)) {
- s = PL_origenviron[0];
- while (*s) s++;
- my_setenv("NoNe SuCh", Nullch);
- /* Force copy of environment. */
- for (i = 1; PL_origenviron[i]; i++)
- if (PL_origenviron[i] > s &&
- PL_origenviron[i] <=
- INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)) {
- s = PL_origenviron[i];
- while (*s) s++;
+ if (PL_origenviron) {
+ if ((PL_origenviron[0] == s + 1
+#ifdef OS2
+ || (PL_origenviron[0] == s + 9 && (s += 8))
+#endif
+ )
+ ||
+ (aligned &&
+ (PL_origenviron[0] > s &&
+ PL_origenviron[0] <=
+ INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
+ )
+ {
+#ifndef OS2
+ s = PL_origenviron[0];
+ while (*s) s++;
+#endif
+ my_setenv("NoNe SuCh", Nullch);
+ /* Force copy of environment. */
+ for (i = 1; PL_origenviron[i]; i++) {
+ if (PL_origenviron[i] == s + 1
+ ||
+ (aligned &&
+ (PL_origenviron[i] > s &&
+ PL_origenviron[i] <=
+ INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
+ )
+ {
+ s = PL_origenviron[i];
+ while (*s) s++;
+ }
+ else
+ break;
}
- else
- break;
+ }
}
PL_origalen = s - PL_origargv[0];
}
/* This is used very early in the lifetime of the program,
* before even the options are parsed, so PL_tainting has
- * not been initialized properly. The variable PL_earlytaint
- * is set early in main() to the result of this function. */
+ * not been initialized properly. */
bool
Perl_doing_taint(int argc, char *argv[], char *envp[])
{
- dTHX;
+#ifndef PERL_IMPLICIT_SYS
+ /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
+ * before we have an interpreter-- and the whole point of this
+ * function is to be called at such an early stage. If you are on
+ * a system with PERL_IMPLICIT_SYS but you do have a concept of
+ * "tainted because running with altered effective ids', you'll
+ * have to add your own checks somewhere in here. The two most
+ * known samples of 'implicitness' are Win32 and NetWare, neither
+ * of which has much of concept of 'uids'. */
int uid = PerlProc_getuid();
int euid = PerlProc_geteuid();
int gid = PerlProc_getgid();
#endif
if (uid && (euid != uid || egid != gid))
return 1;
+#endif /* !PERL_IMPLICIT_SYS */
/* This is a really primitive check; environment gets ignored only
* if -T are the first chars together; otherwise one gets
* "Too late" message. */
HV *ostash = PL_curstash;
PL_curstash = PL_debstash;
- PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
+ PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
AvREAL_off(PL_dbargs);
- PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
- PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
- PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
+ PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
+ PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
+ PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
- PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
+ PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsingle, 0);
- PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
+ PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBtrace, 0);
- PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
+ PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsignal, 0);
PL_DBassertion = GvSV((gv_fetchpv("assertion", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBassertion, 0);
projects / p5sagit/p5-mst-13.2.git / blobdiff