#define FLUSH
-#ifdef LEAKTEST
-
-long xcount[MAXXCOUNT];
-long lastxcount[MAXXCOUNT];
-long xycount[MAXXCOUNT][MAXYCOUNT];
-long lastxycount[MAXXCOUNT][MAXYCOUNT];
-
-#endif
-
#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
# define FD_CLOEXEC 1 /* NeXT needs this */
#endif
/*NOTREACHED*/
}
-#ifdef LEAKTEST
-
-struct mem_test_strut {
- union {
- long type;
- char c[2];
- } u;
- long size;
-};
-
-# define ALIGN sizeof(struct mem_test_strut)
-
-# define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size)
-# define typeof_chunk(ch) \
- (((struct mem_test_strut*) (ch))->u.c[0] + ((struct mem_test_strut*) (ch))->u.c[1]*100)
-# define set_typeof_chunk(ch,t) \
- (((struct mem_test_strut*) (ch))->u.c[0] = t % 100, ((struct mem_test_strut*) (ch))->u.c[1] = t / 100)
-#define SIZE_TO_Y(size) ( (size) > MAXY_SIZE \
- ? MAXYCOUNT - 1 \
- : ( (size) > 40 \
- ? ((size) - 1)/8 + 5 \
- : ((size) - 1)/4))
-
-Malloc_t
-Perl_safexmalloc(I32 x, MEM_SIZE size)
-{
- register char* where = (char*)safemalloc(size + ALIGN);
-
- xcount[x] += size;
- xycount[x][SIZE_TO_Y(size)]++;
- set_typeof_chunk(where, x);
- sizeof_chunk(where) = size;
- return (Malloc_t)(where + ALIGN);
-}
-
-Malloc_t
-Perl_safexrealloc(Malloc_t wh, MEM_SIZE size)
-{
- char *where = (char*)wh;
-
- if (!wh)
- return safexmalloc(0,size);
-
- {
- MEM_SIZE old = sizeof_chunk(where - ALIGN);
- int t = typeof_chunk(where - ALIGN);
- register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN);
-
- xycount[t][SIZE_TO_Y(old)]--;
- xycount[t][SIZE_TO_Y(size)]++;
- xcount[t] += size - old;
- sizeof_chunk(new) = size;
- return (Malloc_t)(new + ALIGN);
- }
-}
-
-void
-Perl_safexfree(Malloc_t wh)
-{
- I32 x;
- char *where = (char*)wh;
- MEM_SIZE size;
-
- if (!where)
- return;
- where -= ALIGN;
- size = sizeof_chunk(where);
- x = where[0] + 100 * where[1];
- xcount[x] -= size;
- xycount[x][SIZE_TO_Y(size)]--;
- safefree(where);
-}
-
-Malloc_t
-Perl_safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size)
-{
- register char * where = (char*)safexmalloc(x, size * count + ALIGN);
- xcount[x] += size;
- xycount[x][SIZE_TO_Y(size)]++;
- memset((void*)(where + ALIGN), 0, size * count);
- set_typeof_chunk(where, x);
- sizeof_chunk(where) = size;
- return (Malloc_t)(where + ALIGN);
-}
-
-STATIC void
-S_xstat(pTHX_ int flag)
-{
- register I32 i, j, total = 0;
- I32 subtot[MAXYCOUNT];
-
- for (j = 0; j < MAXYCOUNT; j++) {
- subtot[j] = 0;
- }
-
- PerlIO_printf(Perl_debug_log, " Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+\n", total);
- for (i = 0; i < MAXXCOUNT; i++) {
- total += xcount[i];
- for (j = 0; j < MAXYCOUNT; j++) {
- subtot[j] += xycount[i][j];
- }
- if (flag == 0
- ? xcount[i] /* Have something */
- : (flag == 2
- ? xcount[i] != lastxcount[i] /* Changed */
- : xcount[i] > lastxcount[i])) { /* Growed */
- PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100,
- flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]);
- lastxcount[i] = xcount[i];
- for (j = 0; j < MAXYCOUNT; j++) {
- if ( flag == 0
- ? xycount[i][j] /* Have something */
- : (flag == 2
- ? xycount[i][j] != lastxycount[i][j] /* Changed */
- : xycount[i][j] > lastxycount[i][j])) { /* Growed */
- PerlIO_printf(Perl_debug_log,"%3ld ",
- flag == 2
- ? xycount[i][j] - lastxycount[i][j]
- : xycount[i][j]);
- lastxycount[i][j] = xycount[i][j];
- } else {
- PerlIO_printf(Perl_debug_log, " . ", xycount[i][j]);
- }
- }
- PerlIO_printf(Perl_debug_log, "\n");
- }
- }
- if (flag != 2) {
- PerlIO_printf(Perl_debug_log, "Total %7ld ", total);
- for (j = 0; j < MAXYCOUNT; j++) {
- if (subtot[j]) {
- PerlIO_printf(Perl_debug_log, "%3ld ", subtot[j]);
- } else {
- PerlIO_printf(Perl_debug_log, " . ");
- }
- }
- PerlIO_printf(Perl_debug_log, "\n");
- }
-}
-
-#endif /* LEAKTEST */
-
/* These must be defined when not using Perl's malloc for binary
* compatibility */
PerlIO *serr = Perl_error_log;
PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
-#ifdef LEAKTEST
- DEBUG_L(*message == '!'
- ? (xstat(message[1]=='!'
- ? (message[2]=='!' ? 2 : 1)
- : 0)
- , 0)
- : 0);
-#endif
(void)PerlIO_flush(serr);
}
}
{
PerlIO *serr = Perl_error_log;
PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
-#ifdef LEAKTEST
- DEBUG_L(*message == '!'
- ? (xstat(message[1]=='!'
- ? (message[2]=='!' ? 2 : 1)
- : 0)
- , 0)
- : 0);
-#endif
(void)PerlIO_flush(serr);
}
}
return 0;
}
# endif
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,RMS_IFI);
return EOF;
# endif
#endif
pos++;
}
SvPOK_on(sv);
- sv_magicext(sv,NULL,PERL_MAGIC_vstring,NULL,(const char*)start, pos-start);
+ sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
SvRMAGICAL_on(sv);
}
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