From ad63d80fcd28c3b5fdbb5328f0f8ea29cbce94d8 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Fri, 4 Oct 2002 19:15:10 -0400 Subject: [PATCH] Version object combined patch Message-ID: <3D9E593E.1060605@rowman.com> p4raw-id: //depot/perl@17990 --- MANIFEST | 2 + embed.fnc | 5 +- embed.h | 6 +- global.sym | 1 + pod/perlapi.pod | 34 +++++--- pod/perlintern.pod | 10 +-- proto.h | 5 +- t/comp/use.t | 4 +- universal.c | 69 +++------------ util.c | 246 +++++++++++++++++++++++++++++++++++------------------ 10 files changed, 220 insertions(+), 162 deletions(-) diff --git a/MANIFEST b/MANIFEST index 38e5616..0039df0 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1955,6 +1955,8 @@ lib/utf8_heavy.pl Support routines for utf8 pragma lib/validate.pl Perl library supporting wholesale file mode validation lib/vars.pm Declare pseudo-imported global variables lib/vars.t See if "use vars" work +lib/version.pm Support for version objects +lib/version.t Tests for version objects lib/vmsish.pm Control VMS-specific behavior of Perl core lib/vmsish.t Tests for vmsish.pm lib/warnings.pm For "use warnings" diff --git a/embed.fnc b/embed.fnc index f96728c..c7c03b8 100644 --- a/embed.fnc +++ b/embed.fnc @@ -538,8 +538,9 @@ Apd |char* |scan_vstring |char *vstr|SV *sv Apd |char* |scan_version |char *vstr|SV *sv Apd |SV* |new_version |SV *ver Apd |SV* |upg_version |SV *ver -Apd |SV* |vnumify |SV *sv|SV *vs -Apd |SV* |vstringify |SV *sv|SV *vs +Apd |SV* |vnumify |SV *vs +Apd |SV* |vstringify |SV *vs +Apd |int |vcmp |SV *lvs|SV *rvs p |PerlIO*|nextargv |GV* gv Ap |char* |ninstr |const char* big|const char* bigend \ |const char* little|const char* lend diff --git a/embed.h b/embed.h index fe6c4bb..0376317 100644 --- a/embed.h +++ b/embed.h @@ -484,6 +484,7 @@ #define upg_version Perl_upg_version #define vnumify Perl_vnumify #define vstringify Perl_vstringify +#define vcmp Perl_vcmp #define nextargv Perl_nextargv #define ninstr Perl_ninstr #define oopsCV Perl_oopsCV @@ -2060,8 +2061,9 @@ #define scan_version(a,b) Perl_scan_version(aTHX_ a,b) #define new_version(a) Perl_new_version(aTHX_ a) #define upg_version(a) Perl_upg_version(aTHX_ a) -#define vnumify(a,b) Perl_vnumify(aTHX_ a,b) -#define vstringify(a,b) Perl_vstringify(aTHX_ a,b) +#define vnumify(a) Perl_vnumify(aTHX_ a) +#define vstringify(a) Perl_vstringify(aTHX_ a) +#define vcmp(a,b) Perl_vcmp(aTHX_ a,b) #define nextargv(a) Perl_nextargv(aTHX_ a) #define ninstr(a,b,c,d) Perl_ninstr(aTHX_ a,b,c,d) #define oopsCV(a) Perl_oopsCV(aTHX_ a) diff --git a/global.sym b/global.sym index 5651534..b4bdf25 100644 --- a/global.sym +++ b/global.sym @@ -321,6 +321,7 @@ Perl_new_version Perl_upg_version Perl_vnumify Perl_vstringify +Perl_vcmp Perl_ninstr Perl_op_free Perl_pad_sv diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 78e1044..772be5f 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -4579,32 +4579,42 @@ Returns a pointer to the upgraded SV. =for hackers Found in file util.c +=item vcmp + +Version object aware cmp. Both operands must already have been +converted into version objects. + + int vcmp(SV *lvs, SV *rvs) + +=for hackers +Found in file util.c + =item vnumify -Accepts a version (or vstring) object and returns the -normalized floating point representation. Call like: +Accepts a version object and returns the normalized floating +point representation. Call like: - sv = vnumify(sv,SvRV(rv)); + sv = vnumify(rv); -NOTE: no checking is done to see if the object is of the -correct type (for speed). +NOTE: you can pass either the object directly or the SV +contained within the RV. - SV* vnumify(SV *sv, SV *vs) + SV* vnumify(SV *vs) =for hackers Found in file util.c =item vstringify -Accepts a version (or vstring) object and returns the -normalized representation. Call like: +Accepts a version object and returns the normalized string +representation. Call like: - sv = vstringify(sv,SvRV(rv)); + sv = vstringify(rv); -NOTE: no checking is done to see if the object is of the -correct type (for speed). +NOTE: you can pass either the object directly or the SV +contained within the RV. - SV* vstringify(SV *sv, SV *vs) + SV* vstringify(SV *vs) =for hackers Found in file util.c diff --git a/pod/perlintern.pod b/pod/perlintern.pod index d256e7e..a9915d2 100644 --- a/pod/perlintern.pod +++ b/pod/perlintern.pod @@ -402,7 +402,7 @@ Found in file pad.c =item cv_clone Clone a CV: make a new CV which points to the same code etc, but which -has a newly-created pad done by copying the prototype pad and capturing +has a newly-created pad built by copying the prototype pad and capturing any outer lexicals. CV* cv_clone(CV* proto) @@ -491,7 +491,6 @@ Check for duplicate declarations: report any of: as C C indicates that the name to check is an 'our' declaration - void pad_check_dup(char* name, bool is_our, HV* ourstash) =for hackers @@ -511,9 +510,10 @@ Found in file pad.c =item pad_findmy -Given a lexical name, try to find it's offset, first in the current pad, +Given a lexical name, try to find its offset, first in the current pad, or failing that, in the pads of any lexically enclosing subs (including -the complications introduced by eval). If the name is found in an outer pad, then a fake entry is added to the current pad. +the complications introduced by eval). If the name is found in an outer pad, +then a fake entry is added to the current pad. Returns the offset in the current pad, or NOT_IN_PAD on failure. PADOFFSET pad_findmy(char* name) @@ -552,7 +552,7 @@ Found in file pad.c =item pad_new -Create a new comnpiling padlist, saving and updating the various global +Create a new compiling padlist, saving and updating the various global vars at the same time as creating the pad itself. The following flags can be OR'ed together: diff --git a/proto.h b/proto.h index 6dc54a4..e19d606 100644 --- a/proto.h +++ b/proto.h @@ -579,8 +579,9 @@ PERL_CALLCONV char* Perl_scan_vstring(pTHX_ char *vstr, SV *sv); PERL_CALLCONV char* Perl_scan_version(pTHX_ char *vstr, SV *sv); PERL_CALLCONV SV* Perl_new_version(pTHX_ SV *ver); PERL_CALLCONV SV* Perl_upg_version(pTHX_ SV *ver); -PERL_CALLCONV SV* Perl_vnumify(pTHX_ SV *sv, SV *vs); -PERL_CALLCONV SV* Perl_vstringify(pTHX_ SV *sv, SV *vs); +PERL_CALLCONV SV* Perl_vnumify(pTHX_ SV *vs); +PERL_CALLCONV SV* Perl_vstringify(pTHX_ SV *vs); +PERL_CALLCONV int Perl_vcmp(pTHX_ SV *lvs, SV *rvs); PERL_CALLCONV PerlIO* Perl_nextargv(pTHX_ GV* gv); PERL_CALLCONV char* Perl_ninstr(pTHX_ const char* big, const char* bigend, const char* little, const char* lend); PERL_CALLCONV OP* Perl_oopsCV(pTHX_ OP* o); diff --git a/t/comp/use.t b/t/comp/use.t index 8e9eb8b..fa4dc18 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 v100\.105 required--this is only v35\.36/) { + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) { 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 required--this is only version 35\.036/) { + unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) { print "not "; } print "ok ",$i++,"\n"; diff --git a/universal.c b/universal.c index 7e80da2..533d843 100644 --- a/universal.c +++ b/universal.c @@ -186,11 +186,8 @@ Perl_boot_core_UNIVERSAL(pTHX) newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); { - /* create the package stash for version objects */ - HV *hv = get_hv("version::OVERLOAD",TRUE); - SV *sv = *hv_fetch(hv,"register",8,1); - sv_inc(sv); - SvSETMAGIC(sv); + /* register the overloading (type 'A') magic */ + PL_amagic_generation++; /* Make it findable via fetchmethod */ newXS("version::()", XS_version_noop, file); newXS("version::new", XS_version_new, file); @@ -334,48 +331,17 @@ XS(XS_UNIVERSAL_VERSION) "%s defines neither package nor VERSION--version check failed", str); } } - 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 (SvNOK(req) && SvPOK(req)) { - /* they said C and $Foo::VERSION - * doesn't look like a float: do string compare */ - if (sv_cmp(req,sv) == 1) { - Perl_croak(aTHX_ "%s v%"VDf" required--" - "this is only v%"VDf, - HvNAME(pkg), req, sv); - } - goto finish; - } - /* they said C and $Foo::VERSION - * doesn't look like a float: force numeric compare */ - (void)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 */ - if (SvNOK(req) && SvPOK(req)) { - NV n = SvNV(req); - req = sv_newmortal(); - sv_setnv(req, n); - } + if ( !sv_derived_from(sv, "version")) + sv = new_version(sv); + + if ( !sv_derived_from(req, "version")) + req = new_version(req); - if (SvNV(req) > SvNV(sv)) + if ( vcmp( SvRV(req), SvRV(sv) ) > 0 ) Perl_croak(aTHX_ "%s version %s required--this is only version %s", - HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv)); + HvNAME(pkg), SvPV(req,PL_na), SvPV(sv,PL_na)); } -finish: ST(0) = sv; XSRETURN(1); @@ -417,12 +383,7 @@ XS(XS_version_stringify) Perl_croak(aTHX_ "lobj is not of type version"); { - SV *vs = NEWSV(92,5); - if ( lobj == SvRV(PL_patchlevel) ) - sv_catsv(vs,lobj); - else - vstringify(vs,lobj); - PUSHs(vs); + PUSHs(vstringify(lobj)); } PUTBACK; @@ -447,9 +408,7 @@ XS(XS_version_numify) Perl_croak(aTHX_ "lobj is not of type version"); { - SV *vs = NEWSV(92,5); - vnumify(vs,lobj); - PUSHs(vs); + PUSHs(vnumify(lobj)); } PUTBACK; @@ -487,11 +446,11 @@ XS(XS_version_vcmp) if ( swap ) { - rs = newSViv(sv_cmp(rvs,lobj)); + rs = newSViv(vcmp(rvs,lobj)); } else { - rs = newSViv(sv_cmp(lobj,rvs)); + rs = newSViv(vcmp(lobj,rvs)); } PUSHs(rs); @@ -520,7 +479,7 @@ XS(XS_version_boolean) { SV *rs; - rs = newSViv(sv_cmp(lobj,Nullsv)); + rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) ); PUSHs(rs); } diff --git a/util.c b/util.c index e7a6655..80b17b7 100644 --- a/util.c +++ b/util.c @@ -3967,7 +3967,6 @@ Perl_scan_vstring(pTHX_ char *s, SV *sv) return s; } - /* =for apidoc scan_version @@ -3989,38 +3988,82 @@ is a beta version). */ char * -Perl_scan_version(pTHX_ char *version, SV *rv) +Perl_scan_version(pTHX_ char *s, SV *rv) { - char* d; - int beta = 0; + char *pos = s; + I32 saw_period = 0; + bool saw_under = 0; 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 == '.' || *d == '\0') - d++; - if (*d == '_') { - *d = '.'; - 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"); + (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */ + + /* pre-scan the imput string to check for decimals */ + while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) + { + if ( *pos == '.' ) + { + if ( saw_under ) + croak(aTHX_ "Invalid version format (underscores before decimal)"); + saw_period++ ; + } + else if ( *pos == '_' ) + { + if ( saw_under ) + croak(aTHX_ "Invalid version format (multiple underscores)"); + saw_under = 1; + } + pos++; + } + pos = s; + + if (*pos == 'v') pos++; /* get past 'v' */ + while (isDIGIT(*pos)) + pos++; + if (!isALPHA(*pos)) { + I32 rev; + + if (*s == 'v') s++; /* get past 'v' */ + + for (;;) { + rev = 0; + { + /* this is atoi() that delimits on underscores */ + char *end = pos; + I32 mult = 1; + if ( s < pos && *(s-1) == '_' ) { + if ( *s == '0' && *(s+1) != '0') + mult = 10; /* perl-style */ + else + mult = -1; /* beta version */ + } + while (--end >= s) { + + I32 orev; + orev = rev; + rev += (*end - '0') * mult; + mult *= 10; + if ( abs(orev) > abs(rev) ) + croak(aTHX_ "Integer overflow in version"); + } } + + /* Append revision */ + av_push((AV *)sv, newSViv(rev)); + if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1])) + s = ++pos; + else if ( isDIGIT(*pos) ) + s = pos; else { - beta = -1; + s = pos; + break; + } + while ( isDIGIT(*pos) ) { + if ( saw_period == 1 && pos-s == 3 ) + break; + pos++; } } - 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 */ - SvIVX(sv) = beta; - return version; + return s; } /* @@ -4040,15 +4083,14 @@ SV * Perl_new_version(pTHX_ SV *ver) { SV *rv = NEWSV(92,5); - char *version; + char *version = (char *)SvPV(ver,PL_na); - if ( SvMAGICAL(ver) ) { /* already a v-string */ +#ifdef SvVOK + if ( SvVOK(ver) ) { /* already a v-string */ MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring); version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); } - else { - version = (char *)SvPV_nolen(ver); - } +#endif version = scan_version(version,rv); return rv; } @@ -4066,93 +4108,133 @@ Returns a pointer to the upgraded SV. */ SV * -Perl_upg_version(pTHX_ SV *sv) +Perl_upg_version(pTHX_ SV *ver) { - char *version = (char *)SvPV_nolen(sv_mortalcopy(sv)); - bool utf8 = SvUTF8(sv); - if ( SvVOK(sv) ) { /* already a v-string */ - SV * ver = newSVrv(sv, "version"); - sv_setpv(ver,version); - if ( utf8 ) - SvUTF8_on(ver); - } - else { - version = scan_version(version,sv); + char *version = savepvn(SvPVX(ver),SvCUR(ver)); +#ifdef SvVOK + if ( SvVOK(ver) ) { /* already a v-string */ + MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring); + version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); } - return sv; +#endif + version = scan_version(version,ver); + return ver; } /* =for apidoc vnumify -Accepts a version (or vstring) object and returns the -normalized floating point representation. Call like: +Accepts a version object and returns the normalized floating +point representation. Call like: - sv = vnumify(sv,SvRV(rv)); + sv = vnumify(rv); -NOTE: no checking is done to see if the object is of the -correct type (for speed). +NOTE: you can pass either the object directly or the SV +contained within the RV. =cut */ SV * -Perl_vnumify(pTHX_ SV *sv, SV *vs) +Perl_vnumify(pTHX_ SV *vs) { - U8* pv = (U8*)SvPVX(vs); - STRLEN len = SvCUR(vs); - STRLEN retlen; - UV digit = utf8_to_uvchr(pv,&retlen); - Perl_sv_setpvf(aTHX_ sv,"%"UVf".",digit); - for (pv += retlen, len -= retlen; - len > 0; - pv += retlen, len -= retlen) + I32 i, len, digit; + SV *sv = NEWSV(92,0); + if ( SvROK(vs) ) + vs = SvRV(vs); + len = av_len((AV *)vs); + digit = SvIVX(*av_fetch((AV *)vs, 0, 0)); + Perl_sv_setpvf(aTHX_ sv,"%d.",abs(digit)); + for ( i = 1 ; i <= len ; i++ ) { - digit = utf8_to_uvchr(pv,&retlen); - Perl_sv_catpvf(aTHX_ sv,"%03"UVf,digit); + digit = SvIVX(*av_fetch((AV *)vs, i, 0)); + Perl_sv_catpvf(aTHX_ sv,"%03d",abs(digit)); } + if ( len == 0 ) + Perl_sv_catpv(aTHX_ sv,"000"); return sv; } /* =for apidoc vstringify -Accepts a version (or vstring) object and returns the -normalized representation. Call like: +Accepts a version object and returns the normalized string +representation. Call like: - sv = vstringify(sv,SvRV(rv)); + sv = vstringify(rv); -NOTE: no checking is done to see if the object is of the -correct type (for speed). +NOTE: you can pass either the object directly or the SV +contained within the RV. =cut */ SV * -Perl_vstringify(pTHX_ SV *sv, SV *vs) +Perl_vstringify(pTHX_ SV *vs) { - U8* pv = (U8*)SvPVX(vs); - STRLEN len = SvCUR(vs); - STRLEN retlen; - UV digit = utf8_to_uvchr(pv,&retlen); - Perl_sv_setpvf(aTHX_ sv,"%"UVf,digit); - for (pv += retlen, len -= retlen; - len > 0; - pv += retlen, len -= retlen) - { - digit = utf8_to_uvchr(pv,&retlen); - Perl_sv_catpvf(aTHX_ sv,".%"UVf,digit); - } - if (SvIVX(vs) < 0) { - char* pv = SvPVX(sv); - for (pv += SvCUR(sv); *pv != '.'; pv--) - ; - *pv = '_'; + I32 i, len, digit; + SV *sv = NEWSV(92,0); + if ( SvROK(vs) ) + vs = SvRV(vs); + len = av_len((AV *)vs); + digit = SvIVX(*av_fetch((AV *)vs, 0, 0)); + Perl_sv_setpvf(aTHX_ sv,"%d",digit); + for ( i = 1 ; i <= len ; i++ ) +{ + digit = SvIVX(*av_fetch((AV *)vs, i, 0)); + if ( digit < 0 ) + Perl_sv_catpvf(aTHX_ sv,"_%d",-digit); + else + Perl_sv_catpvf(aTHX_ sv,".%d",digit); } + if ( len == 0 ) + Perl_sv_catpv(aTHX_ sv,".0"); return sv; } +/* +=for apidoc vcmp + +Version object aware cmp. Both operands must already have been +converted into version objects. + +=cut +*/ + +int +Perl_vcmp(pTHX_ SV *lsv, SV *rsv) +{ + I32 i,l,m,r,retval; + if ( SvROK(lsv) ) + lsv = SvRV(lsv); + if ( SvROK(rsv) ) + rsv = SvRV(rsv); + l = av_len((AV *)lsv); + r = av_len((AV *)rsv); + m = l < r ? l : r; + retval = 0; + i = 0; + while ( i <= m && retval == 0 ) + { + I32 left = SvIV(*av_fetch((AV *)lsv,i,0)); + I32 right = SvIV(*av_fetch((AV *)rsv,i,0)); + bool lbeta = left < 0 ? 1 : 0; + bool rbeta = right < 0 ? 1 : 0; + left = abs(left); + right = abs(right); + if ( left < right || (left == right && lbeta && !rbeta) ) + retval = -1; + if ( left > right || (left == right && rbeta && !lbeta) ) + retval = +1; + i++; + } + + if ( l != r && retval == 0 ) + retval = l < r ? -1 : +1; + return retval; +} + #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT) # define EMULATE_SOCKETPAIR_UDP #endif -- 2.7.4