/* util.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
else if (PL_nomemok)
return Nullch;
else {
- PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
+ /* Can't use PerlIO to write as it allocates memory */
+ PerlLIO_write(PerlIO_fileno(Perl_error_log),
+ PL_no_mem, strlen(PL_no_mem));
my_exit(1);
return Nullch;
}
else if (PL_nomemok)
return Nullch;
else {
- PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
+ /* Can't use PerlIO to write as it allocates memory */
+ PerlLIO_write(PerlIO_fileno(Perl_error_log),
+ PL_no_mem, strlen(PL_no_mem));
my_exit(1);
return Nullch;
}
else if (PL_nomemok)
return Nullch;
else {
- PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
+ /* Can't use PerlIO to write as it allocates memory */
+ PerlLIO_write(PerlIO_fileno(Perl_error_log),
+ PL_no_mem, strlen(PL_no_mem));
my_exit(1);
return Nullch;
}
=for apidoc croak
This is the XSUB-writer's interface to Perl's C<die> function.
-Normally use this function the same way you use the C C<printf>
-function. See C<warn>.
+Normally call this function the same way you call the C C<printf>
+function. Calling C<croak> returns control directly to Perl,
+sidestepping the normal C order of execution. See C<warn>.
If you want to throw an exception object, assign the object to
C<$@> and then pass C<Nullch> to croak():
/*
=for apidoc warn
-This is the XSUB-writer's interface to Perl's C<warn> function. Use this
-function the same way you use the C C<printf> function. See
-C<croak>.
+This is the XSUB-writer's interface to Perl's C<warn> function. Call this
+function the same way you call the C C<printf> function. See C<croak>.
=cut
*/
Function must be called with an already existing SV like
- sv = NEWSV(92,0);
- s = scan_version(s,sv);
+ sv = newSV(0);
+ s = scan_version(s,SV *sv, bool qv);
Performs some preprocessing to the string to ensure that
it has the correct characteristics of a version. Flags the
object if it contains an underscore (which denotes this
-is a beta version).
+is a alpha version). The boolean qv denotes that the version
+should be interpreted as if it had multiple decimals, even if
+it doesn't.
=cut
*/
char *
-Perl_scan_version(pTHX_ char *s, SV *rv)
+Perl_scan_version(pTHX_ char *s, SV *rv, bool qv)
{
const char *start = s;
char *pos = s;
}
pos = s;
- if (*pos == 'v') pos++; /* get past 'v' */
+ if (*pos == 'v') {
+ pos++; /* get past 'v' */
+ qv = 1; /* force quoted version processing */
+ }
while (isDIGIT(*pos))
pos++;
if (!isALPHA(*pos)) {
I32 mult = 1;
I32 orev;
if ( s < pos && s > start && *(s-1) == '_' ) {
- mult *= -1; /* beta version */
+ mult *= -1; /* alpha version */
}
/* the following if() will only be true after the decimal
* point of a version originally created with a bare
* floating point number, i.e. not quoted in any way
*/
- if ( s > start+1 && saw_period == 1 && !saw_under ) {
+ if ( !qv && s > start+1 && saw_period == 1 && !saw_under ) {
mult = 100;
while ( s < end ) {
orev = rev;
}
}
}
+ if ( qv ) { /* quoted versions always become full version objects */
+ I32 len = av_len((AV *)sv);
+ for ( len = 2 - len; len != 0; len-- )
+ av_push((AV *)sv, newSViv(0));
+ }
return s;
}
Perl_new_version(pTHX_ SV *ver)
{
SV *rv = newSV(0);
- char *version;
- if ( SvNOK(ver) ) /* may get too much accuracy */
- {
- char tbuf[64];
- sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
- version = savepv(tbuf);
- }
#ifdef SvVOK
- else if ( SvVOK(ver) ) { /* already a v-string */
+ if ( SvVOK(ver) ) { /* already a v-string */
+ char *version;
MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
+ sv_setpv(rv,version);
+ Safefree(version);
}
+ else {
#endif
- else /* must be a string or something like a string */
- {
- version = (char *)SvPV(ver,PL_na);
+ sv_setsv(rv,ver); /* make a duplicate */
+#ifdef SvVOK
}
- version = scan_version(version,rv);
+#endif
+ upg_version(rv);
return rv;
}
SV *
Perl_upg_version(pTHX_ SV *ver)
{
- char *version = savepvn(SvPVX(ver),SvCUR(ver));
+ char *version;
+ bool qv = 0;
+
+ if ( SvNOK(ver) ) /* may get too much accuracy */
+ {
+ char tbuf[64];
+ sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
+ version = savepv(tbuf);
+ }
#ifdef SvVOK
- if ( SvVOK(ver) ) { /* already a v-string */
+ else 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 );
+ qv = 1;
}
#endif
- version = scan_version(version,ver);
+ else /* must be a string or something like a string */
+ {
+ STRLEN n_a;
+ version = savepv(SvPV(ver,n_a));
+ }
+ (void)scan_version(version, ver, qv);
+ Safefree(version);
return ver;
}
Perl_vnumify(pTHX_ SV *vs)
{
I32 i, len, digit;
- SV *sv = NEWSV(92,0);
+ SV *sv = newSV(0);
if ( SvROK(vs) )
vs = SvRV(vs);
len = av_len((AV *)vs);
return sv;
}
digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
- Perl_sv_setpvf(aTHX_ sv,"%d.", PERL_ABS(digit));
+ Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
for ( i = 1 ; i <= len ; i++ )
{
digit = SvIVX(*av_fetch((AV *)vs, i, 0));
- Perl_sv_catpvf(aTHX_ sv,"%03d", PERL_ABS(digit));
+ Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
}
if ( len == 0 )
Perl_sv_catpv(aTHX_ sv,"000");
}
/*
-=for apidoc vstringify
+=for apidoc vnormal
Accepts a version object and returns the normalized string
representation. Call like:
- sv = vstringify(rv);
+ sv = vnormal(rv);
NOTE: you can pass either the object directly or the SV
contained within the RV.
*/
SV *
-Perl_vstringify(pTHX_ SV *vs)
+Perl_vnormal(pTHX_ SV *vs)
{
I32 i, len, digit;
- SV *sv = NEWSV(92,0);
+ SV *sv = newSV(0);
if ( SvROK(vs) )
vs = SvRV(vs);
len = av_len((AV *)vs);
else
Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
}
- if ( len == 0 )
- Perl_sv_catpv(aTHX_ sv,".0");
+
+ if ( len <= 2 ) { /* short version, must be at least three */
+ for ( len = 2 - len; len != 0; len-- )
+ Perl_sv_catpv(aTHX_ sv,".0");
+ }
+
return sv;
}
/*
+=for apidoc vstringify
+
+In order to maintain maximum compatibility with earlier versions
+of Perl, this function will return either the floating point
+notation or the multiple dotted notation, depending on whether
+the original version contained 1 or more dots, respectively
+
+=cut
+*/
+
+SV *
+Perl_vstringify(pTHX_ SV *vs)
+{
+ I32 i, len, digit;
+ if ( SvROK(vs) )
+ vs = SvRV(vs);
+ len = av_len((AV *)vs);
+
+ if ( len < 2 )
+ return vnumify(vs);
+ else
+ return vnormal(vs);
+}
+
+/*
=for apidoc vcmp
Version object aware cmp. Both operands must already have been
{
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 = PERL_ABS(left);
- right = PERL_ABS(right);
- if ( left < right || (left == right && lbeta && !rbeta) )
+ bool lalpha = left < 0 ? 1 : 0;
+ bool ralpha = right < 0 ? 1 : 0;
+ left = abs(left);
+ right = abs(right);
+ if ( left < right || (left == right && lalpha && !ralpha) )
retval = -1;
- if ( left > right || (left == right && rbeta && !lbeta) )
+ if ( left > right || (left == right && ralpha && !lalpha) )
retval = +1;
i++;
}
- if ( l != r && retval == 0 ) /* possible match except for trailing 0 */
+ if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
{
- if ( !( l < r && r-l == 1 && SvIV(*av_fetch((AV *)rsv,r,0)) == 0 ) &&
- !( l-r == 1 && SvIV(*av_fetch((AV *)lsv,l,0)) == 0 ) )
+ if ( l < r )
{
- retval = l < r ? -1 : +1; /* not a match after all */
+ while ( i <= r && retval == 0 )
+ {
+ if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 )
+ retval = -1; /* not a match after all */
+ i++;
+ }
+ }
+ else
+ {
+ while ( i <= l && retval == 0 )
+ {
+ if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 )
+ retval = +1; /* not a match after all */
+ i++;
+ }
}
}
return retval;
projects / p5sagit/p5-mst-13.2.git / blobdiff