This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[Fwd: CPAN Upload: J/JP/JPEACOCK/version-0.47.tar.gz]
authorJohn Peacock <jpeacock@rowman.com>
Tue, 23 Aug 2005 20:41:11 +0000 (23:41 +0300)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Wed, 24 Aug 2005 15:53:01 +0000 (15:53 +0000)
From: "John Peacock" <jpeacock@rowman.com>
Message-ID: <2444.85.65.24.143.1124818871.squirrel@webmail.rowman.com>

p4raw-id: //depot/perl@25325

embed.fnc
embed.h
global.sym
lib/version.pm
lib/version.t
pod/perlapi.pod
proto.h
t/comp/use.t
util.c

index 3f00817..690977b 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -554,6 +554,7 @@ Ap  |char*  |scan_vstring   |NN const char *vstr|NN SV *sv
 Apd    |const char*    |scan_version   |NN const char *vstr|NN SV *sv|bool qv
 Apd    |SV*    |new_version    |NN SV *ver
 Apd    |SV*    |upg_version    |NN SV *ver
+Apd    |bool   |vverify        |NN SV *vs
 Apd    |SV*    |vnumify        |NN SV *vs
 Apd    |SV*    |vnormal        |NN SV *vs
 Apd    |SV*    |vstringify     |NN SV *vs
diff --git a/embed.h b/embed.h
index c3d0231..5faec5a 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define scan_version           Perl_scan_version
 #define new_version            Perl_new_version
 #define upg_version            Perl_upg_version
+#define vverify                        Perl_vverify
 #define vnumify                        Perl_vnumify
 #define vnormal                        Perl_vnormal
 #define vstringify             Perl_vstringify
 #define scan_version(a,b,c)    Perl_scan_version(aTHX_ a,b,c)
 #define new_version(a)         Perl_new_version(aTHX_ a)
 #define upg_version(a)         Perl_upg_version(aTHX_ a)
+#define vverify(a)             Perl_vverify(aTHX_ a)
 #define vnumify(a)             Perl_vnumify(aTHX_ a)
 #define vnormal(a)             Perl_vnormal(aTHX_ a)
 #define vstringify(a)          Perl_vstringify(aTHX_ a)
index f17db24..27535f7 100644 (file)
@@ -329,6 +329,7 @@ Perl_scan_vstring
 Perl_scan_version
 Perl_new_version
 Perl_upg_version
+Perl_vverify
 Perl_vnumify
 Perl_vnormal
 Perl_vstringify
index e6e4f3e..1e3cabb 100644 (file)
@@ -12,7 +12,7 @@ use vars qw(@ISA $VERSION $CLASS @EXPORT);
 
 @EXPORT = qw(qv);
 
-$VERSION = "0.44"; 
+$VERSION = "0.47"; 
 
 $CLASS = 'version';
 
@@ -538,6 +538,28 @@ will also exclusively return the numified form.  Technically, the
 $module->VERSION function returns a string (PV) that can be converted to a 
 number following the normal Perl rules, when used in a numeric context.
 
+=head1 SUBCLASSING
+
+This module is specifically designed and tested to be easily subclassed.
+In practice, you only need to override the methods you want to change, but
+you have to take some care when overriding new() (since that is where all
+of the parsing takes place).  For example, this is a perfect acceptable
+derived class:
+
+  package myversion;
+  use base version;
+  sub new { 
+      my($self,$n)=@_;
+      my $obj;
+      # perform any special input handling here
+      $obj = $self->SUPER::new($n);
+      # and/or add additional hash elements here
+      return $obj;
+  }
+
+See also L<version::AlphaBeta> on CPAN for an alternate representation of
+version strings.
+
 =head1 EXPORT
 
 qv - quoted version initialization operator
index bfb9c46..e387095 100644 (file)
@@ -4,12 +4,12 @@
 
 #########################
 
-use Test::More tests => 183;
+use Test::More tests => 200;
 
 diag "Tests with base class" unless $ENV{PERL_CORE};
 
 BEGIN {
-    use_ok("version", 0.30); # If we made it this far, we are ok.
+    use_ok("version", 0.47); # If we made it this far, we are ok.
 }
 
 BaseTests("version");
@@ -22,18 +22,38 @@ use version 0.30;
 @ISA = qw(version);
 $VERSION = 0.01;
 
+package version::Bad;
+use base version;
+sub new { my($self,$n)=@_;  bless \$n, $self }
+
 package main;
-my $testobj = new version::Empty 1.002_003;
+my $testobj = version::Empty->new(1.002_003);
 isa_ok( $testobj, "version::Empty" );
 ok( $testobj->numify == 1.002003, "Numified correctly" );
 ok( $testobj->stringify eq "1.002003", "Stringified correctly" );
 ok( $testobj->normal eq "v1.2.3", "Normalified correctly" );
 
-my $verobj = new version "1.2.4";
+my $verobj = version->new("1.2.4");
 ok( $verobj > $testobj, "Comparison vs parent class" );
 ok( $verobj gt $testobj, "Comparison vs parent class" );
 BaseTests("version::Empty");
 
+diag "tests with bad subclass" unless $ENV{PERL_CORE};
+$testobj = version::Bad->new(1.002_003);
+isa_ok( $testobj, "version::Bad" );
+eval { my $string = $testobj->numify };
+like($@, qr/Invalid version object/,
+    "Bad subclass numify");
+eval { my $string = $testobj->normal };
+like($@, qr/Invalid version object/,
+    "Bad subclass normal");
+eval { my $string = $testobj->stringify };
+like($@, qr/Invalid version object/,
+    "Bad subclass stringify");
+eval { my $test = $testobj > 1.0 };
+like($@, qr/Invalid version object/,
+    "Bad subclass vcmp");
+
 sub BaseTests {
 
        my $CLASS = shift;
@@ -278,4 +298,25 @@ SKIP:      {
            $version = qv(1.2.3);
            ok("$version" eq "v1.2.3", 'v-string initialized qv()');
        }
+
+       diag "Tests with real-world (malformed) data" unless $ENV{PERL_CORE};
+
+       # trailing zero testing (reported by Andreas Koenig).
+       $version = $CLASS->new("1");
+       ok($version->numify eq "1.000", "trailing zeros preserved");
+       $version = $CLASS->new("1.0");
+       ok($version->numify eq "1.000", "trailing zeros preserved");
+       $version = $CLASS->new("1.0.0");
+       ok($version->numify eq "1.000000", "trailing zeros preserved");
+       $version = $CLASS->new("1.0.0.0");
+       ok($version->numify eq "1.000000000", "trailing zeros preserved");
+       
+       # leading zero testing (reported by Andreas Koenig).
+       $version = $CLASS->new(".7");
+       ok($version->numify eq "0.700", "leading zero inferred");
+
+       # leading space testing (reported by Andreas Koenig).
+       $version = $CLASS->new(" 1.7");
+       ok($version->numify eq "1.700", "leading space ignored");
+
 }
index e45481e..b26011e 100644 (file)
@@ -2019,6 +2019,20 @@ the original version contained 1 or more dots, respectively
 =for hackers
 Found in file util.c
 
+=item vverify
+
+Validates that the SV contains a valid version object.
+
+    bool vverify(SV *vobj);
+
+Note that it only confirms the bare minimum structure (so as not to get
+confused by derived classes which may contain additional hash entries):
+
+       bool    vverify(SV *vs)
+
+=for hackers
+Found in file util.c
+
 
 =back
 
diff --git a/proto.h b/proto.h
index 65a7bb4..dc9fc21 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1357,6 +1357,9 @@ PERL_CALLCONV SV* Perl_new_version(pTHX_ SV *ver)
 PERL_CALLCONV SV*      Perl_upg_version(pTHX_ SV *ver)
                        __attribute__nonnull__(pTHX_1);
 
+PERL_CALLCONV bool     Perl_vverify(pTHX_ SV *vs)
+                       __attribute__nonnull__(pTHX_1);
+
 PERL_CALLCONV SV*      Perl_vnumify(pTHX_ SV *vs)
                        __attribute__nonnull__(pTHX_1);
 
index a8be2d3..fb378b2 100755 (executable)
@@ -153,7 +153,7 @@ print "ok ",$i++,"\n";
     print "ok ",$i++,"\n";
 
     eval "use lib v100.105";
-    unless ($@ =~ /lib version 100.105 \(v100\.105\.0\) required--this is only version 35.036 \(v35\.36\.0\)/) {
+    unless ($@ =~ /lib version 100.105 \(v100\.105\.0\) required--this is only version 35.036000 \(v35\.36\.0\)/) {
        print "not ";
     }
     print "ok ",$i++,"\n";
@@ -163,7 +163,7 @@ print "ok ",$i++,"\n";
     print "ok ",$i++,"\n";
 
     eval "use lib 100.105";
-    unless ($@ =~ /lib version 100.105 \(v100\.105\.0\) required--this is only version 35.036 \(v35\.36\.0\)/) {
+    unless ($@ =~ /lib version 100.105 \(v100\.105\.0\) required--this is only version 35.036000 \(v35\.36\.0\)/) {
        print "not ";
     }
     print "ok ",$i++,"\n";
diff --git a/util.c b/util.c
index 5824d87..f23e9cb 100644 (file)
--- a/util.c
+++ b/util.c
@@ -3878,7 +3878,7 @@ it doesn't.
 const char *
 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 {
-    const char *start = s;
+    const char *start;
     const char *pos;
     const char *last;
     int saw_period = 0;
@@ -3891,12 +3891,15 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
 #endif
 
+    while (isSPACE(*s)) /* leading whitespace is OK */
+       s++;
+
     if (*s == 'v') {
        s++;  /* get past 'v' */
        qv = 1; /* force quoted version processing */
     }
 
-    last = pos = s;
+    start = last = pos = s;
 
     /* pre-scan the input string to check for decimals/underbars */
     while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
@@ -3918,17 +3921,15 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
        pos++;
     }
 
-    if ( saw_period > 1 ) {
+    if ( saw_period > 1 )
        qv = 1; /* force quoted version processing */
-    }
 
     pos = s;
 
     if ( qv )
        hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
-    if ( saw_under ) {
+    if ( saw_under )
        hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
-    }
     if ( !qv && width < 3 )
        hv_store((HV *)hv, "width", 5, newSViv(width), 0);
     
@@ -3949,7 +3950,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                 * point of a version originally created with a bare
                 * floating point number, i.e. not quoted in any way
                 */
-               if ( !qv && s > start+1 && saw_period == 1 ) {
+               if ( !qv && s > start && saw_period == 1 ) {
                    mult *= 100;
                    while ( s < end ) {
                        orev = rev;
@@ -4044,7 +4045,7 @@ Perl_new_version(pTHX_ SV *ver)
        AV * const av = newAV();
        AV *sav;
        /* This will get reblessed later if a derived class*/
-       SV const hv = newSVrv(rv, "version"); 
+       SV * const hv = newSVrv(rv, "version"); 
        (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
 #ifndef NODEFAULT_SHAREKEYS
        HvSHAREKEYS_on(hv);         /* key-sharing on by default */
@@ -4079,7 +4080,7 @@ Perl_new_version(pTHX_ SV *ver)
     }
 #ifdef SvVOK
     if ( SvVOK(ver) ) { /* already a v-string */
-       MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
+       const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
        const STRLEN len = mg->mg_len;
        char * const version = savepvn( (const char*)mg->mg_ptr, len);
        sv_setpvn(rv,version,len);
@@ -4135,6 +4136,45 @@ Perl_upg_version(pTHX_ SV *ver)
     return ver;
 }
 
+/*
+=for apidoc vverify
+
+Validates that the SV contains a valid version object.
+
+    bool vverify(SV *vobj);
+
+Note that it only confirms the bare minimum structure (so as not to get
+confused by derived classes which may contain additional hash entries):
+
+=over 4
+
+=item * The SV contains a hash (or a reference to one)
+
+=item * The hash contains a "version" key
+
+=item * The "version" key has an AV as its value
+
+=back
+
+=cut
+*/
+
+bool
+Perl_vverify(pTHX_ SV *vs)
+{
+    SV *sv;
+    if ( SvROK(vs) )
+       vs = SvRV(vs);
+
+    /* see if the appropriate elements exist */
+    if ( SvTYPE(vs) == SVt_PVHV
+        && hv_exists((HV*)vs, "version", 7)
+        && (sv = *hv_fetch((HV*)vs, "version", 7, FALSE))
+        && SvTYPE(sv) == SVt_PVAV )
+       return TRUE;
+    else
+       return FALSE;
+}
 
 /*
 =for apidoc vnumify
@@ -4161,6 +4201,9 @@ Perl_vnumify(pTHX_ SV *vs)
     if ( SvROK(vs) )
        vs = SvRV(vs);
 
+    if ( !vverify(vs) )
+       Perl_croak(aTHX_ "Invalid version object");
+
     /* see if various flags exist */
     if ( hv_exists((HV*)vs, "alpha", 5 ) )
        alpha = TRUE;
@@ -4184,17 +4227,17 @@ Perl_vnumify(pTHX_ SV *vs)
     }
 
     digit = SvIV(*av_fetch(av, 0, 0));
-    Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
+    sv_setpvf(sv, "%d.", (int)PERL_ABS(digit));
     for ( i = 1 ; i < len ; i++ )
     {
        digit = SvIV(*av_fetch(av, i, 0));
        if ( width < 3 ) {
            const int denom = (int)pow(10,(3-width));
            const div_t term = div((int)PERL_ABS(digit),denom);
-           Perl_sv_catpvf(aTHX_ sv,"%0*d_%d", width, term.quot, term.rem);
+           sv_catpvf(sv, "%0*d_%d", width, term.quot, term.rem);
        }
        else {
-           Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit);
+           sv_catpvf(sv, "%0*d", width, (int)digit);
        }
     }
 
@@ -4202,14 +4245,12 @@ Perl_vnumify(pTHX_ SV *vs)
     {
        digit = SvIV(*av_fetch(av, len, 0));
        if ( alpha && width == 3 ) /* alpha version */
-           Perl_sv_catpv(aTHX_ sv,"_");
-       /* Don't display additional trailing zeros */
-       if ( digit > 0 )
-           Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit);
+           sv_catpvn(sv,"_",1);
+       sv_catpvf(sv, "%0*d", width, (int)digit);
     }
-    else /* len == 1 */
+    else /* len == 0 */
     {
-        sv_catpvn(sv,"000",3);
+       sv_catpvn(sv,"000",3);
     }
     return sv;
 }
@@ -4238,36 +4279,40 @@ Perl_vnormal(pTHX_ SV *vs)
     if ( SvROK(vs) )
        vs = SvRV(vs);
 
+    if ( !vverify(vs) )
+       Perl_croak(aTHX_ "Invalid version object");
+
     if ( hv_exists((HV*)vs, "alpha", 5 ) )
        alpha = TRUE;
     av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE);
 
     len = av_len(av);
-    if ( len == -1 ) {
+    if ( len == -1 )
+    {
        sv_catpvn(sv,"",0);
        return sv;
     }
     digit = SvIV(*av_fetch(av, 0, 0));
-    Perl_sv_setpvf(aTHX_ sv,"v%"IVdf,(IV)digit);
+    sv_setpvf(sv, "v%"IVdf, (IV)digit);
     for ( i = 1 ; i <= len-1 ; i++ ) {
        digit = SvIV(*av_fetch(av, i, 0));
-       Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
+       sv_catpvf(sv, ".%"IVdf, (IV)digit);
     }
 
-    if ( len > 0 ) {
+    if ( len > 0 )
+    {
        /* handle last digit specially */
        digit = SvIV(*av_fetch(av, len, 0));
        if ( alpha )
-           Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
+           sv_catpvf(sv, "_%"IVdf, (IV)digit);
        else
-           Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
+           sv_catpvf(sv, ".%"IVdf, (IV)digit);
     }
 
     if ( len <= 2 ) { /* short version, must be at least three */
        for ( len = 2 - len; len != 0; len-- )
            sv_catpvn(sv,".0",2);
     }
-
     return sv;
 }
 
@@ -4285,9 +4330,17 @@ the original version contained 1 or more dots, respectively
 SV *
 Perl_vstringify(pTHX_ SV *vs)
 {
+    I32 qv = 0;
     if ( SvROK(vs) )
        vs = SvRV(vs);
+    
+    if ( !vverify(vs) )
+       Perl_croak(aTHX_ "Invalid version object");
+
     if ( hv_exists((HV *)vs, "qv", 2) )
+       qv = 1;
+    
+    if ( qv )
        return vnormal(vs);
     else
        return vnumify(vs);
@@ -4316,6 +4369,12 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
     if ( SvROK(rhv) )
        rhv = SvRV(rhv);
 
+    if ( !vverify(lhv) )
+       Perl_croak(aTHX_ "Invalid version object");
+
+    if ( !vverify(rhv) )
+       Perl_croak(aTHX_ "Invalid version object");
+
     /* get the left hand term */
     lav = (AV *)*hv_fetch((HV*)lhv, "version", 7, FALSE);
     if ( hv_exists((HV*)lhv, "alpha", 5 ) )