[PATCH] perlcommunity.pod: add information about OSDC.fr

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

diff --git a/util.c b/util.c
index 6ee5ddf..f60f3d0 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1361,7 +1361,6 @@ S_vdie(pTHX_ const char* pat, va_list *args)
 {
     dVAR;
     const char *message;
-    const int was_in_eval = PL_in_eval;
     STRLEN msglen;
     I32 utf8 = 0;
 
@@ -1369,9 +1368,9 @@ S_vdie(pTHX_ const char* pat, va_list *args)
 
     PL_restartop = die_where(message, msglen);
     SvFLAGS(ERRSV) |= utf8;
-    if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
-       JMPENV_JUMP(3);
-    return PL_restartop;
+    JMPENV_JUMP(3);
+    /* NOTREACHED */
+    return NULL;
 }
 
 #if defined(PERL_IMPLICIT_CONTEXT)
@@ -1529,6 +1528,32 @@ Perl_warner_nocontext(U32 err, const char *pat, ...)
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 void
+Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
+{
+    PERL_ARGS_ASSERT_CK_WARNER_D;
+
+    if (Perl_ckwarn_d(aTHX_ err)) {
+       va_list args;
+       va_start(args, pat);
+       vwarner(err, pat, &args);
+       va_end(args);
+    }
+}
+
+void
+Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
+{
+    PERL_ARGS_ASSERT_CK_WARNER;
+
+    if (Perl_ckwarn(aTHX_ err)) {
+       va_list args;
+       va_start(args, pat);
+       vwarner(err, pat, &args);
+       va_end(args);
+    }
+}
+
+void
 Perl_warner(pTHX_ U32  err, const char* pat,...)
 {
     va_list args;
@@ -1572,20 +1597,11 @@ bool
 Perl_ckwarn(pTHX_ U32 w)
 {
     dVAR;
-    return isLEXWARN_on
-       ? (PL_curcop->cop_warnings != pWARN_NONE
-          && (
-                  PL_curcop->cop_warnings == pWARN_ALL
-               || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
-               || (unpackWARN2(w) &&
-                    isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
-               || (unpackWARN3(w) &&
-                    isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
-               || (unpackWARN4(w) &&
-                    isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
-               )
-          )
-       : (PL_dowarn & G_WARN_ON);
+    /* If lexical warnings have not been set, use $^W.  */
+    if (isLEXWARN_off)
+       return PL_dowarn & G_WARN_ON;
+
+    return ckwarn_common(w);
 }
 
 /* implements the ckWARN?_d macro */
@@ -1594,22 +1610,42 @@ bool
 Perl_ckwarn_d(pTHX_ U32 w)
 {
     dVAR;
-    return
-          isLEXWARN_off
-       || PL_curcop->cop_warnings == pWARN_ALL
-       || (
-             PL_curcop->cop_warnings != pWARN_NONE 
-          && (
-                  isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
-             || (unpackWARN2(w) &&
-                  isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
-             || (unpackWARN3(w) &&
-                  isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
-             || (unpackWARN4(w) &&
-                  isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
-             )
-          )
-       ;
+    /* If lexical warnings have not been set then default classes warn.  */
+    if (isLEXWARN_off)
+       return TRUE;
+
+    return ckwarn_common(w);
+}
+
+static bool
+S_ckwarn_common(pTHX_ U32 w)
+{
+    if (PL_curcop->cop_warnings == pWARN_ALL)
+       return TRUE;
+
+    if (PL_curcop->cop_warnings == pWARN_NONE)
+       return FALSE;
+
+    /* Check the assumption that at least the first slot is non-zero.  */
+    assert(unpackWARN1(w));
+
+    /* Check the assumption that it is valid to stop as soon as a zero slot is
+       seen.  */
+    if (!unpackWARN2(w)) {
+       assert(!unpackWARN3(w));
+       assert(!unpackWARN4(w));
+    } else if (!unpackWARN3(w)) {
+       assert(!unpackWARN4(w));
+    }
+       
+    /* Right, dealt with all the special cases, which are implemented as non-
+       pointers, so there is a pointer to a real warnings mask.  */
+    do {
+       if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
+           return TRUE;
+    } while (w >>= WARNshift);
+
+    return FALSE;
 }
 
 /* Set buffer=NULL to get a new one.  */
@@ -2275,8 +2311,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
            }
            return NULL;
        }
-       if (ckWARN(WARN_PIPE))
-           Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
+       Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
        sleep(5);
     }
     if (pid == 0) {
@@ -2423,8 +2458,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
                Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
            return NULL;
        }
-       if (ckWARN(WARN_PIPE))
-           Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
+       Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
        sleep(5);
     }
     if (pid == 0) {
@@ -4295,9 +4329,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                        mult /= 10;
                        if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
                            || (PERL_ABS(rev) > VERSION_MAX )) {
-                           if(ckWARN(WARN_OVERFLOW))
-                               Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), 
-                               "Integer overflow in version %d",VERSION_MAX);
+                           Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
+                                          "Integer overflow in version %d",VERSION_MAX);
                            s = end - 1;
                            rev = VERSION_MAX;
                            vinf = 1;
@@ -4314,9 +4347,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                        mult *= 10;
                        if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
                            || (PERL_ABS(rev) > VERSION_MAX )) {
-                           if(ckWARN(WARN_OVERFLOW))
-                               Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), 
-                               "Integer overflow in version");
+                           Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
+                                          "Integer overflow in version");
                            end = s - 1;
                            rev = VERSION_MAX;
                            vinf = 1;
@@ -4564,10 +4596,9 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 
     s = scan_version(version, ver, qv);
     if ( *s != '\0' ) 
-       if(ckWARN(WARN_MISC))
-           Perl_warner(aTHX_ packWARN(WARN_MISC), 
-               "Version string '%s' contains invalid data; "
-               "ignoring: '%s'", version, s);
+       Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 
+                      "Version string '%s' contains invalid data; "
+                      "ignoring: '%s'", version, s);
     Safefree(version);
     return ver;
 }
@@ -6022,17 +6053,14 @@ Perl_my_dirfd(pTHX_ DIR * dir) {
 
 REGEXP *
 Perl_get_re_arg(pTHX_ SV *sv) {
-    SV    *tmpsv;
 
     if (sv) {
         if (SvMAGICAL(sv))
             mg_get(sv);
-        if (SvROK(sv) &&
-            (tmpsv = MUTABLE_SV(SvRV(sv))) &&            /* assign deliberate */
-            SvTYPE(tmpsv) == SVt_REGEXP)
-        {
-            return (REGEXP*) tmpsv;
-        }
+        if (SvROK(sv))
+           sv = MUTABLE_SV(SvRV(sv));
+        if (SvTYPE(sv) == SVt_REGEXP)
+            return (REGEXP*) sv;
     }
  
     return NULL;