diff options
| -rw-r--r-- | embed.h | 4 | ||||
| -rwxr-xr-x | embed.pl | 1 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | objXSUB.h | 4 | ||||
| -rw-r--r-- | perlapi.c | 7 | ||||
| -rw-r--r-- | proto.h | 1 | ||||
| -rwxr-xr-x | t/comp/use.t | 67 | ||||
| -rw-r--r-- | toke.c | 31 | ||||
| -rw-r--r-- | universal.c | 57 |
9 files changed, 162 insertions, 11 deletions
@@ -686,6 +686,7 @@ #define sv_usepvn Perl_sv_usepvn #define sv_vcatpvfn Perl_sv_vcatpvfn #define sv_vsetpvfn Perl_sv_vsetpvfn +#define str_to_version Perl_str_to_version #define swash_init Perl_swash_init #define swash_fetch Perl_swash_fetch #define taint_env Perl_taint_env @@ -2113,6 +2114,7 @@ #define sv_usepvn(a,b,c) Perl_sv_usepvn(aTHX_ a,b,c) #define sv_vcatpvfn(a,b,c,d,e,f,g) Perl_sv_vcatpvfn(aTHX_ a,b,c,d,e,f,g) #define sv_vsetpvfn(a,b,c,d,e,f,g) Perl_sv_vsetpvfn(aTHX_ a,b,c,d,e,f,g) +#define str_to_version(a) Perl_str_to_version(aTHX_ a) #define swash_init(a,b,c,d,e) Perl_swash_init(aTHX_ a,b,c,d,e) #define swash_fetch(a,b) Perl_swash_fetch(aTHX_ a,b) #define taint_env() Perl_taint_env(aTHX) @@ -4145,6 +4147,8 @@ #define sv_vcatpvfn Perl_sv_vcatpvfn #define Perl_sv_vsetpvfn CPerlObj::Perl_sv_vsetpvfn #define sv_vsetpvfn Perl_sv_vsetpvfn +#define Perl_str_to_version CPerlObj::Perl_str_to_version +#define str_to_version Perl_str_to_version #define Perl_swash_init CPerlObj::Perl_swash_init #define swash_init Perl_swash_init #define Perl_swash_fetch CPerlObj::Perl_swash_fetch @@ -2004,6 +2004,7 @@ Apd |void |sv_vcatpvfn |SV* sv|const char* pat|STRLEN patlen \ Apd |void |sv_vsetpvfn |SV* sv|const char* pat|STRLEN patlen \ |va_list* args|SV** svargs|I32 svmax \ |bool *maybe_tainted +Ap |NV |str_to_version |SV *sv Ap |SV* |swash_init |char* pkg|char* name|SV* listsv \ |I32 minbits|I32 none Ap |UV |swash_fetch |SV *sv|U8 *ptr diff --git a/global.sym b/global.sym index fee76148b9..b38fc6f519 100644 --- a/global.sym +++ b/global.sym @@ -431,6 +431,7 @@ Perl_sv_upgrade Perl_sv_usepvn Perl_sv_vcatpvfn Perl_sv_vsetpvfn +Perl_str_to_version Perl_swash_init Perl_swash_fetch Perl_taint_env @@ -1737,6 +1737,10 @@ #define Perl_sv_vsetpvfn pPerl->Perl_sv_vsetpvfn #undef sv_vsetpvfn #define sv_vsetpvfn Perl_sv_vsetpvfn +#undef Perl_str_to_version +#define Perl_str_to_version pPerl->Perl_str_to_version +#undef str_to_version +#define str_to_version Perl_str_to_version #undef Perl_swash_init #define Perl_swash_init pPerl->Perl_swash_init #undef swash_init @@ -3140,6 +3140,13 @@ Perl_sv_vsetpvfn(pTHXo_ SV* sv, const char* pat, STRLEN patlen, va_list* args, S ((CPerlObj*)pPerl)->Perl_sv_vsetpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted); } +#undef Perl_str_to_version +NV +Perl_str_to_version(pTHXo_ SV *sv) +{ + return ((CPerlObj*)pPerl)->Perl_str_to_version(sv); +} + #undef Perl_swash_init SV* Perl_swash_init(pTHXo_ char* pkg, char* name, SV* listsv, I32 minbits, I32 none) @@ -768,6 +768,7 @@ PERL_CALLCONV bool Perl_sv_upgrade(pTHX_ SV* sv, U32 mt); PERL_CALLCONV void Perl_sv_usepvn(pTHX_ SV* sv, char* ptr, STRLEN len); PERL_CALLCONV void Perl_sv_vcatpvfn(pTHX_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted); PERL_CALLCONV void Perl_sv_vsetpvfn(pTHX_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted); +PERL_CALLCONV NV Perl_str_to_version(pTHX_ SV *sv); PERL_CALLCONV SV* Perl_swash_init(pTHX_ char* pkg, char* name, SV* listsv, I32 minbits, I32 none); PERL_CALLCONV UV Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr); PERL_CALLCONV void Perl_taint_env(pTHX); diff --git a/t/comp/use.t b/t/comp/use.t index dbbda5c038..c3cdb70709 100755 --- a/t/comp/use.t +++ b/t/comp/use.t @@ -5,7 +5,7 @@ BEGIN { unshift @INC, '../lib'; } -print "1..15\n"; +print "1..27\n"; my $i = 1; eval "use 5.000"; # implicit semicolon @@ -103,3 +103,68 @@ print "ok ",$i++,"\n"; print "not " if $INC[0] eq "freda"; print "ok ",$i++,"\n"; + +{ + local $lib::VERSION = 35.36; + eval "use lib v33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib v100.105"; + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) { + print "not "; + } + print "ok ",$i++,"\n"; + + eval "use lib 33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib 100.105"; + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) { + print "not "; + } + print "ok ",$i++,"\n"; + + local $lib::VERSION = '35.36'; + eval "use lib v33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib v100.105"; + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) { + print "not "; + } + print "ok ",$i++,"\n"; + + eval "use lib 33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib 100.105"; + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) { + print "not "; + } + print "ok ",$i++,"\n"; + + local $lib::VERSION = v35.36; + eval "use lib v33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib v100.105"; + unless ($@ =~ /lib version v100\.105 required--this is only version v35\.36/) { + print "not "; + } + print "ok ",$i++,"\n"; + + eval "use lib 33.55"; + print "not " if $@; + print "ok ",$i++,"\n"; + + eval "use lib 100.105"; + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.036/) { + print "not "; + } + print "ok ",$i++,"\n"; +} @@ -812,6 +812,31 @@ S_force_ident(pTHX_ register char *s, int kind) } } +NV +Perl_str_to_version(pTHX_ SV *sv) +{ + NV retval = 0.0; + NV nshift = 1.0; + STRLEN len; + char *start = SvPVx(sv,len); + bool utf = SvUTF8(sv); + char *end = start + len; + while (start < end) { + I32 skip; + UV n; + if (utf) + n = utf8_to_uv((U8*)start, &skip); + else { + n = *(U8*)start; + skip = 1; + } + retval += ((NV)n)/nshift; + start += skip; + nshift *= 1000; + } + return retval; +} + /* * S_force_version * Forces the next token to be a version number. @@ -833,12 +858,12 @@ S_force_version(pTHX_ char *s) if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) { SV *ver; s = scan_num(s); - /* real VERSION number -- GBARR */ version = yylval.opval; ver = cSVOPx(version)->op_sv; if (SvPOK(ver) && !SvNIOK(ver)) { - SvUPGRADE(ver, SVt_PVIV); - SvIOKp_on(ver); /* hint that it is a version */ + SvUPGRADE(ver, SVt_PVNV); + SvNVX(ver) = str_to_version(ver); + SvNOK_on(ver); /* hint that it is a version */ } } } diff --git a/universal.c b/universal.c index 6ccff2f003..0e5a89b2c0 100644 --- a/universal.c +++ b/universal.c @@ -197,11 +197,10 @@ XS(XS_UNIVERSAL_VERSION) GV *gv; SV *sv; char *undef; - NV req; - if(SvROK(ST(0))) { + if (SvROK(ST(0))) { sv = (SV*)SvRV(ST(0)); - if(!SvOBJECT(sv)) + if (!SvOBJECT(sv)) Perl_croak(aTHX_ "Cannot find version of an unblessed reference"); pkg = SvSTASH(sv); } @@ -222,12 +221,56 @@ XS(XS_UNIVERSAL_VERSION) undef = "(undef)"; } - if (items > 1 && (undef || (req = SvNV(ST(1)), req > SvNV(sv)))) { - STRLEN n_a; - Perl_croak(aTHX_ "%s version %s required--this is only version %s", - HvNAME(pkg), SvPV(ST(1),n_a), undef ? undef : SvPV(sv,n_a)); + if (items > 1) { + STRLEN len; + SV *req = ST(1); + + if (undef) + Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed", + HvNAME(pkg), HvNAME(pkg)); + + if (!SvNIOK(sv) && SvPOK(sv)) { + char *str = SvPVx(sv,len); + while (len) { + --len; + /* XXX could DWIM "1.2.3" here */ + if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_') + break; + } + if (len) { + if (SvNIOKp(req) && SvPOK(req)) { + /* they said C<use Foo v1.2.3> and $Foo::VERSION + * doesn't look like a float: do string compare */ + if (sv_cmp(req,sv) == 1) { + Perl_croak(aTHX_ "%s version v%vd required--" + "this is only version v%vd", + HvNAME(pkg), req, sv); + } + goto finish; + } + /* they said C<use Foo 1.002_003> and $Foo::VERSION + * doesn't look like a float: force numeric compare */ + SvUPGRADE(sv, SVt_PVNV); + SvNVX(sv) = str_to_version(sv); + SvPOK_off(sv); + SvNOK_on(sv); + } + } + /* if we get here, we're looking for a numeric comparison, + * so force the required version into a float, even if they + * said C<use Foo v1.2.3> */ + if (SvNIOKp(req) && SvPOK(req)) { + NV n = SvNV(req); + req = sv_newmortal(); + sv_setnv(req, n); + } + + if (SvNV(req) > SvNV(sv)) + Perl_croak(aTHX_ "%s version %s required--this is only version %s", + HvNAME(pkg), SvPV(req,len), SvPV(sv,len)); } +finish: ST(0) = sv; XSRETURN(1); |