diff options
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | lib/version.pm | 24 | ||||
| -rw-r--r-- | lib/version.t | 49 | ||||
| -rw-r--r-- | pod/perlapi.pod | 14 | ||||
| -rw-r--r-- | proto.h | 3 | ||||
| -rwxr-xr-x | t/comp/use.t | 4 | ||||
| -rw-r--r-- | util.c | 109 |
9 files changed, 175 insertions, 32 deletions
@@ -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 @@ -570,6 +570,7 @@ #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 @@ -2562,6 +2563,7 @@ #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) diff --git a/global.sym b/global.sym index f17db24143..27535f788a 100644 --- a/global.sym +++ b/global.sym @@ -329,6 +329,7 @@ Perl_scan_vstring Perl_scan_version Perl_new_version Perl_upg_version +Perl_vverify Perl_vnumify Perl_vnormal Perl_vstringify diff --git a/lib/version.pm b/lib/version.pm index e6e4f3ee1f..1e3cabbb0d 100644 --- a/lib/version.pm +++ b/lib/version.pm @@ -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 diff --git a/lib/version.t b/lib/version.t index bfb9c463a7..e387095ec2 100644 --- a/lib/version.t +++ b/lib/version.t @@ -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"); + } diff --git a/pod/perlapi.pod b/pod/perlapi.pod index e45481e340..b26011e4ba 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -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 @@ -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); diff --git a/t/comp/use.t b/t/comp/use.t index a8be2d39c9..fb378b2979 100755 --- a/t/comp/use.t +++ b/t/comp/use.t @@ -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"; @@ -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 ) ) |