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"
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
#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
#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)
Perl_upg_version
Perl_vnumify
Perl_vstringify
+Perl_vcmp
Perl_ninstr
Perl_op_free
Perl_pad_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
=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)
as C<ourstash>
C<is_our> indicates that the name to check is an 'our' declaration
-
void pad_check_dup(char* name, bool is_our, HV* ourstash)
=for hackers
=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)
=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:
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);
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";
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";
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);
"%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<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 v%"VDf" required--"
- "this is only v%"VDf,
- 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 */
- (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<use Foo v1.2.3> */
- 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);
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;
Perl_croak(aTHX_ "lobj is not of type version");
{
- SV *vs = NEWSV(92,5);
- vnumify(vs,lobj);
- PUSHs(vs);
+ PUSHs(vnumify(lobj));
}
PUTBACK;
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);
{
SV *rs;
- rs = newSViv(sv_cmp(lobj,Nullsv));
+ rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
PUSHs(rs);
}
return s;
}
-
/*
=for apidoc scan_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;
}
/*
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;
}
*/
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
projects / p5sagit/p5-mst-13.2.git / commitdiff