Tweaks to Bleadperl Version Object Support

Message-ID: <3D6D835C.50809@rowman.com>

p4raw-id: //depot/perl@17819

diff --git a/universal.c b/universal.c
index 4a879e9..7e80da2 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -192,6 +192,7 @@ Perl_boot_core_UNIVERSAL(pTHX)
        sv_inc(sv);
        SvSETMAGIC(sv);
        /* Make it findable via fetchmethod */
+       newXS("version::()", XS_version_noop, file);
        newXS("version::new", XS_version_new, file);
        newXS("version::(\"\"", XS_version_stringify, file);
        newXS("version::stringify", XS_version_stringify, file);

diff --git a/util.c b/util.c
index 35fb8a8..cf793bd 100644 (file)
--- a/util.c
+++ b/util.c
@@ -4155,27 +4155,34 @@ is a beta version).
 char *
 Perl_scan_version(pTHX_ char *version, SV *rv)
 {
-    char *d;
+    char* d;
     int beta = 0;
-    SV * sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+    SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
     d = version;
     if (*d == 'v')
        d++;
     if (isDIGIT(*d)) {
-       while (isDIGIT(*d) || *d == '.')
+       while (isDIGIT(*d) || *d == '.' || *d == '\0')
            d++;
-       if ( *d == '_' ) {
+       if (*d == '_') {
            *d = '.';
-           if ( *(d+1) == '0' && *(d+2) != '0' ) { /* perl-style version */
+           if (*(d+1) == '0' && *(d+2) != '0') { /* perl-style version */
                *(d+1) = *(d+2);
                *(d+2) = '0';
+               if (ckWARN(WARN_PORTABLE))
+                   Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
+                               "perl-style version not portable");
            }
            else {
                beta = -1;
            }
        }
+       while (isDIGIT(*d) || *d == '.' || *d == '\0')
+           d++;
+       if (*d == '_')
+           Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
     }
-    version = scan_vstring(version,sv);        /* store the v-string in the object */
+    version = scan_vstring(version, sv); /* store the v-string in the object */
     SvIVX(sv) = beta;
     return version;
 }
@@ -4299,10 +4306,14 @@ Perl_vstringify(pTHX_ SV *sv, SV *vs)
        pv += retlen, len -= retlen)
     {
        digit = utf8_to_uvchr(pv,&retlen);
-       Perl_sv_catpvf(aTHX_ sv,".%03"UVf,digit);
+       Perl_sv_catpvf(aTHX_ sv,".%"UVf,digit);
+    }
+    if (SvIVX(vs) < 0) {
+       char* pv = SvPVX(sv); 
+       for (pv += SvCUR(sv); *pv != '.'; pv--)
+           ;
+       *pv = '_';
     }
-    if ( SvIVX(vs) < 0 )
-       sv_catpv(sv,"beta");
     return sv;
 }