Upgrade to Pod-Simple-3.04

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

diff --git a/util.c b/util.c
index 881287b..abbf4ed 100644 (file)
--- a/util.c
+++ b/util.c
@@ -929,7 +929,7 @@ S_mess_alloc(pTHX)
     Newxz(any, 1, XPVMG);
     SvFLAGS(sv) = SVt_PVMG;
     SvANY(sv) = (void*)any;
-    SvPV_set(sv, 0);
+    SvPV_set(sv, NULL);
     SvREFCNT(sv) = 1 << 30; /* practically infinite */
     PL_mess_sv = sv;
     return sv;
@@ -1130,23 +1130,25 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
     }
 }
 
-/* Common code used by vcroak, vdie and vwarner  */
+/* Common code used by vcroak, vdie, vwarn and vwarner  */
 
-STATIC void
-S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
+STATIC bool
+S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
 {
     dVAR;
     HV *stash;
     GV *gv;
     CV *cv;
-    /* sv_2cv might call Perl_croak() */
-    SV * const olddiehook = PL_diehook;
+    SV **const hook = warn ? &PL_warnhook : &PL_diehook;
+    /* sv_2cv might call Perl_croak() or Perl_warner() */
+    SV * const oldhook = *hook;
+
+    assert(oldhook);
 
-    assert(PL_diehook);
     ENTER;
-    SAVESPTR(PL_diehook);
-    PL_diehook = Nullsv;
-    cv = sv_2cv(olddiehook, &stash, &gv, 0);
+    SAVESPTR(*hook);
+    *hook = NULL;
+    cv = sv_2cv(oldhook, &stash, &gv, 0);
     LEAVE;
     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
        dSP;
@@ -1154,7 +1156,11 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
 
        ENTER;
        save_re_context();
-       if (message) {
+       if (warn) {
+           SAVESPTR(*hook);
+           *hook = NULL;
+       }
+       if (warn || message) {
            msg = newSVpvn(message, msglen);
            SvFLAGS(msg) |= utf8;
            SvREADONLY_on(msg);
@@ -1164,14 +1170,16 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
            msg = ERRSV;
        }
 
-       PUSHSTACKi(PERLSI_DIEHOOK);
+       PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
        PUSHMARK(SP);
        XPUSHs(msg);
        PUTBACK;
        call_sv((SV*)cv, G_DISCARD);
        POPSTACK;
        LEAVE;
+       return TRUE;
     }
+    return FALSE;
 }
 
 STATIC const char *
@@ -1200,7 +1208,7 @@ S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
                          "%p: die/croak: message = %s\ndiehook = %p\n",
                          thr, message, PL_diehook));
     if (PL_diehook) {
-       S_vdie_common(aTHX_ message, *msglen, *utf8);
+       S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
     }
     return message;
 }
@@ -1330,39 +1338,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
     const char * const message = SvPV_const(msv, msglen);
 
     if (PL_warnhook) {
-       /* sv_2cv might call Perl_warn() */
-       SV * const oldwarnhook = PL_warnhook;
-       CV * cv;
-       HV * stash;
-       GV * gv;
-
-       ENTER;
-       SAVESPTR(PL_warnhook);
-       PL_warnhook = Nullsv;
-       cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
-       LEAVE;
-       if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
-           dSP;
-           SV *msg;
-
-           ENTER;
-           SAVESPTR(PL_warnhook);
-           PL_warnhook = Nullsv;
-           save_re_context();
-           msg = newSVpvn(message, msglen);
-           SvFLAGS(msg) |= utf8;
-           SvREADONLY_on(msg);
-           SAVEFREESV(msg);
-
-           PUSHSTACKi(PERLSI_WARNHOOK);
-           PUSHMARK(SP);
-           XPUSHs(msg);
-           PUTBACK;
-           call_sv((SV*)cv, G_DISCARD);
-           POPSTACK;
-           LEAVE;
+       if (vdie_common(message, msglen, utf8, TRUE))
            return;
-       }
     }
 
     write_to_stderr(message, msglen);
@@ -1431,7 +1408,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 
        if (PL_diehook) {
            assert(message);
-           S_vdie_common(aTHX_ message, msglen, utf8);
+           S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
        }
        if (PL_in_eval) {
            PL_restartop = die_where(message, msglen);
@@ -4031,6 +4008,9 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
        pos++;
     }
 
+    if ( alpha && !saw_period )
+       Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
+
     if ( saw_period > 1 )
        qv = 1; /* force quoted version processing */
 
@@ -4174,11 +4154,11 @@ Perl_new_version(pTHX_ SV *ver)
        
        if ( hv_exists((HV*)ver, "width", 5 ) )
        {
-           const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE));
+           const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
            hv_store((HV *)hv, "width", 5, newSViv(width), 0);
        }
 
-       sav = (AV *)SvRV(*hv_fetch((HV*)ver, "version", 7, FALSE));
+       sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
        /* This will get reblessed later if a derived class*/
        for ( key = 0; key <= av_len(sav); key++ )
        {
@@ -4203,8 +4183,7 @@ Perl_new_version(pTHX_ SV *ver)
 #ifdef SvVOK
     }
 #endif
-    upg_version(rv);
-    return rv;
+    return upg_version(rv);
 }
 
 /*
@@ -4222,7 +4201,7 @@ Returns a pointer to the upgraded SV.
 SV *
 Perl_upg_version(pTHX_ SV *ver)
 {
-    char *version;
+    const char *version, *s;
     bool qv = 0;
 
     if ( SvNOK(ver) ) /* may get too much accuracy */ 
@@ -4242,7 +4221,12 @@ Perl_upg_version(pTHX_ SV *ver)
     {
        version = savepv(SvPV_nolen(ver));
     }
-    (void)scan_version(version, ver, 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);
     Safefree(version);
     return ver;
 }
@@ -4280,7 +4264,7 @@ Perl_vverify(pTHX_ SV *vs)
     /* see if the appropriate elements exist */
     if ( SvTYPE(vs) == SVt_PVHV
         && hv_exists((HV*)vs, "version", 7)
-        && (sv = SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)))
+        && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
         && SvTYPE(sv) == SVt_PVAV )
        return TRUE;
     else
@@ -4319,13 +4303,13 @@ Perl_vnumify(pTHX_ SV *vs)
     if ( hv_exists((HV*)vs, "alpha", 5 ) )
        alpha = TRUE;
     if ( hv_exists((HV*)vs, "width", 5 ) )
-       width = SvIV(*hv_fetch((HV*)vs, "width", 5, FALSE));
+       width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
     else
        width = 3;
 
 
     /* attempt to retrieve the version array */
-    if ( !(av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)) ) ) {
+    if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
        sv_catpvs(sv,"0");
        return sv;
     }
@@ -4395,7 +4379,7 @@ Perl_vnormal(pTHX_ SV *vs)
 
     if ( hv_exists((HV*)vs, "alpha", 5 ) )
        alpha = TRUE;
-    av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE));
+    av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
 
     len = av_len(av);
     if ( len == -1 )
@@ -4483,12 +4467,12 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
        Perl_croak(aTHX_ "Invalid version object");
 
     /* get the left hand term */
-    lav = (AV *)SvRV(*hv_fetch((HV*)lhv, "version", 7, FALSE));
+    lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
     if ( hv_exists((HV*)lhv, "alpha", 5 ) )
        lalpha = TRUE;
 
     /* and the right hand term */
-    rav = (AV *)SvRV(*hv_fetch((HV*)rhv, "version", 7, FALSE));
+    rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
     if ( hv_exists((HV*)rhv, "alpha", 5 ) )
        ralpha = TRUE;