Re: [perl #22719] ISA cache problem with blessed stash objects

[p5sagit/p5-mst-13.2.git] / perl.c

diff --git a/perl.c b/perl.c
index 3f5de94..f85b010 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1,6 +1,7 @@
 /*    perl.c
  *
- *    Copyright (c) 1987-2003 Larry Wall
+ *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ *    2000, 2001, 2002, 2003, 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.
@@ -788,7 +789,7 @@ perl_destruct(pTHXx)
     if (PL_reg_curpm)
        Safefree(PL_reg_curpm);
     Safefree(PL_reg_poscache);
-    Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
+    free_tied_hv_pool();
     Safefree(PL_op_mask);
     Safefree(PL_psig_ptr);
     Safefree(PL_psig_name);
@@ -1032,6 +1033,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
            break;
 
        case 't':
+           CHECK_MALLOC_TOO_LATE_FOR('t');
            if( !PL_tainting ) {
                 PL_taint_warn = TRUE;
                 PL_tainting = TRUE;
@@ -1039,6 +1041,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
            s++;
            goto reswitch;
        case 'T':
+           CHECK_MALLOC_TOO_LATE_FOR('T');
            PL_tainting = TRUE;
            PL_taint_warn = FALSE;
            s++;
@@ -1221,6 +1224,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
        while (isSPACE(*s))
            s++;
        if (*s == '-' && *(s+1) == 'T') {
+           CHECK_MALLOC_TOO_LATE_FOR('T');
            PL_tainting = TRUE;
             PL_taint_warn = FALSE;
        }
@@ -2166,7 +2170,7 @@ char *
 Perl_moreswitches(pTHX_ char *s)
 {
     STRLEN numlen;
-    U32 rschar;
+    UV rschar;
 
     switch (*s) {
     case '0':
@@ -2188,7 +2192,7 @@ Perl_moreswitches(pTHX_ char *s)
                   s--;
              }
              PL_rs = newSVpvn("", 0);
-             SvGROW(PL_rs, UNISKIP(rschar) + 1);
+             SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
              tmps = (U8*)SvPVX(PL_rs);
              uvchr_to_utf8(tmps, rschar);
              SvCUR_set(PL_rs, UNISKIP(rschar));
@@ -2423,12 +2427,12 @@ Perl_moreswitches(pTHX_ char *s)
        return s;
     case 't':
         if (!PL_tainting)
-            Perl_croak(aTHX_ "Too late for \"-t\" option");
+           TOO_LATE_FOR('t');
         s++;
         return s;
     case 'T':
        if (!PL_tainting)
-           Perl_croak(aTHX_ "Too late for \"-T\" option");
+           TOO_LATE_FOR('T');
        s++;
        return s;
     case 'u':
@@ -3285,9 +3289,37 @@ S_init_ids(pTHX)
     PL_uid |= PL_gid << 16;
     PL_euid |= PL_egid << 16;
 #endif
+    /* Should not happen: */
+    CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
 }
 
+#ifdef MYMALLOC
+/* This is used very early in the lifetime of the program. */
+int
+Perl_doing_taint(int argc, char *argv[], char *envp[])
+{
+    int uid = PerlProc_getuid();
+    int euid = PerlProc_geteuid();
+    int gid = PerlProc_getgid();
+    int egid = PerlProc_getegid();
+
+#ifdef VMS
+    uid |= gid << 16;
+    euid |= egid << 16;
+#endif
+    if (uid && (euid != uid || egid != gid))
+       return 1;
+    /* This is a really primitive check; $ENV{PERL_MALLOC_OPT} is
+       ignored only if -T are the first chars together; otherwise one
+       gets "Too late" message. */
+    if ( argc > 1 && argv[1][0] == '-'
+         && (argv[1][1] == 't' || argv[1][1] == 'T') )
+       return 1;
+    return 0;
+}
+#endif
+
 STATIC void
 S_forbid_setid(pTHX_ char *s)
 {