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 )
+ Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
+ saw_period++ ;
+ }
+ else if ( *pos == '_' )
+ {
+ if ( saw_under )
+ Perl_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) )
+ Perl_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 / blobdiff