More Perl malloc debugging magic from Ilya. Seems to work in

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

diff --git a/perl.c b/perl.c
index 9914935..f85b010 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1033,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;
@@ -1040,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++;
@@ -1222,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;
        }
@@ -2424,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':
@@ -3286,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)
 {