SV* sva = (SV*)ptr;
register SV* sv;
register SV* svend;
- Zero(sva, size, char);
+ Zero(ptr, size, char);
/* The first SV in an arena isn't an SV. */
SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
while (c < SvEND(sv)) {
if (*c & 0x80) {
I32 len;
- UV uv = utf8_to_uv(c, &len);
+ UV uv = utf8_to_uv((U8*)c, &len);
if (uv >= 256) {
if (fail_ok)
return FALSE;
while (src < SvEND(sv)) {
if (*src & 0x80) {
I32 len;
- U8 u = (U8)utf8_to_uv(src, &len);
+ U8 u = (U8)utf8_to_uv((U8*)src, &len);
*dst++ = u;
src += len;
}
Perl_croak(aTHX_
"Can't redefine active sort subroutine %s",
GvENAME((GV*)dstr));
- if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
- if (!(CvGV(cv) && GvSTASH(CvGV(cv))
- && HvNAME(GvSTASH(CvGV(cv)))
- && strEQ(HvNAME(GvSTASH(CvGV(cv))),
- "autouse")))
- Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
+ if ((const_changed || const_sv) && ckWARN(WARN_REDEFINE))
+ Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
"Constant subroutine %s redefined"
: "Subroutine %s redefined",
GvENAME((GV*)dstr));
- }
}
cv_ckproto(cv, (GV*)dstr,
SvPOK(sref) ? SvPVX(sref) : Nullch);
SvPV_set(dstr, SvPVX(sstr));
SvLEN_set(dstr, SvLEN(sstr));
SvCUR_set(dstr, SvCUR(sstr));
+ if (SvUTF8(sstr))
+ SvUTF8_on(dstr);
+ else
+ SvUTF8_off(dstr);
+
SvTEMP_off(dstr);
(void)SvOK_off(sstr);
SvPV_set(sstr, Nullch);
}
else {
if (dtype == SVt_PVGV) {
- if (ckWARN(WARN_UNSAFE))
- Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
+ if (ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
}
else
(void)SvOK_off(dstr);
for (p = (char*)pat; p < patend; p = q) {
bool alt = FALSE;
bool left = FALSE;
+ bool vectorize = FALSE;
+ bool utf = FALSE;
char fill = ' ';
char plus = 0;
char intsize = 0;
bool is_utf = FALSE;
char esignbuf[4];
- U8 utf8buf[10];
+ U8 utf8buf[UTF8_MAXLEN];
STRLEN esignlen = 0;
char *eptr = Nullch;
char ebuf[IV_DIG * 4 + NV_DIG + 32];
/* large enough for "%#.#f" --chip */
/* what about long double NVs? --jhi */
+
+ SV *vecsv;
+ U8 *vecstr = Null(U8*);
+ STRLEN veclen = 0;
char c;
int i;
unsigned base;
STRLEN have;
STRLEN need;
STRLEN gap;
+ char *dotstr = ".";
+ STRLEN dotstrlen = 1;
for (q = p; q < patend && *q != '%'; ++q) ;
if (q > p) {
q++;
continue;
+ case '*': /* printf("%*vX",":",$ipv6addr) */
+ if (q[1] != 'v')
+ break;
+ q++;
+ if (args)
+ vecsv = va_arg(*args, SV*);
+ else if (svix < svmax)
+ vecsv = svargs[svix++];
+ dotstr = SvPVx(vecsv,dotstrlen);
+ if (DO_UTF8(vecsv))
+ is_utf = TRUE;
+ /* FALL THROUGH */
+
+ case 'v':
+ vectorize = TRUE;
+ q++;
+ if (args)
+ vecsv = va_arg(*args, SV*);
+ else if (svix < svmax)
+ vecsv = svargs[svix++];
+ vecstr = (U8*)SvPVx(vecsv,veclen);
+ utf = DO_UTF8(vecsv);
+ continue;
+
default:
break;
}
}
goto string;
- case 'v':
- if (args)
- argsv = va_arg(*args, SV*);
- else if (svix < svmax)
- argsv = svargs[svix++];
- {
- STRLEN len;
- U8 *str = (U8*)SvPVx(argsv,len);
- I32 vlen = len*3+1;
- SV *vsv = NEWSV(73,vlen);
- I32 ulen;
- I32 vfree = vlen;
- U8 *vptr = (U8*)SvPVX(vsv);
- STRLEN vcur = 0;
- bool utf = DO_UTF8(argsv);
-
- if (utf)
- is_utf = TRUE;
- while (len) {
- UV uv;
-
- if (utf)
- uv = utf8_to_uv(str, &ulen);
- else {
- uv = *str;
- ulen = 1;
- }
- str += ulen;
- len -= ulen;
- eptr = ebuf + sizeof ebuf;
- do {
- *--eptr = '0' + uv % 10;
- } while (uv /= 10);
- elen = (ebuf + sizeof ebuf) - eptr;
- while (elen >= vfree-1) {
- STRLEN off = vptr - (U8*)SvPVX(vsv);
- vfree += vlen;
- vlen *= 2;
- SvGROW(vsv, vlen);
- vptr = (U8*)SvPVX(vsv) + off;
- }
- memcpy(vptr, eptr, elen);
- vptr += elen;
- *vptr++ = '.';
- vfree -= elen + 1;
- vcur += elen + 1;
- }
- if (vcur) {
- vcur--;
- vptr[-1] = '\0';
- }
- SvCUR_set(vsv,vcur);
- eptr = SvPVX(vsv);
- elen = vcur;
- }
- goto string;
-
case '_':
/*
* The "%_" hack might have to be changed someday,
is_utf = TRUE;
string:
+ vectorize = FALSE;
if (has_precis && elen > precis)
elen = precis;
break;
/* FALL THROUGH */
case 'd':
case 'i':
- if (args) {
+ if (vectorize) {
+ I32 ulen;
+ if (!veclen) {
+ vectorize = FALSE;
+ break;
+ }
+ if (utf)
+ iv = (IV)utf8_to_uv(vecstr, &ulen);
+ else {
+ iv = *vecstr;
+ ulen = 1;
+ }
+ vecstr += ulen;
+ veclen -= ulen;
+ }
+ else if (args) {
switch (intsize) {
case 'h': iv = (short)va_arg(*args, int); break;
default: iv = va_arg(*args, int); break;
base = 16;
uns_integer:
- if (args) {
+ if (vectorize) {
+ I32 ulen;
+ vector:
+ if (!veclen) {
+ vectorize = FALSE;
+ break;
+ }
+ if (utf)
+ uv = utf8_to_uv(vecstr, &ulen);
+ else {
+ uv = *vecstr;
+ ulen = 1;
+ }
+ vecstr += ulen;
+ veclen -= ulen;
+ }
+ else if (args) {
switch (intsize) {
case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
default: uv = va_arg(*args, unsigned); break;
break;
default: /* it had better be ten or less */
#if defined(PERL_Y2KWARN)
- if (ckWARN(WARN_MISC)) {
+ if (ckWARN(WARN_Y2K)) {
STRLEN n;
char *s = SvPV(sv,n);
if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
&& (n == 2 || !isDIGIT(s[n-3])))
{
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ WARN_Y2K,
"Possible Y2K bug: %%%c %s",
c, "format string following '19'");
}
/* This is evil, but floating point is even more evil */
+ vectorize = FALSE;
if (args)
nv = va_arg(*args, NV);
else
need = 0;
if (c != 'e' && c != 'E') {
i = PERL_INT_MIN;
- (void)frexp(nv, &i);
+ (void)Perl_frexp(nv, &i);
if (i == PERL_INT_MIN)
Perl_die(aTHX_ "panic: frexp");
if (i > 0)
/* SPECIAL */
case 'n':
+ vectorize = FALSE;
i = SvCUR(sv) - origlen;
if (args) {
switch (intsize) {
default:
unknown:
+ vectorize = FALSE;
if (!args && ckWARN(WARN_PRINTF) &&
(PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
SV *msg = sv_newmortal();
need = (have > width ? have : width);
gap = need - have;
- SvGROW(sv, SvCUR(sv) + need + 1);
+ SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
p = SvEND(sv);
if (esignlen && fill == '0') {
for (i = 0; i < esignlen; i++)
memset(p, ' ', gap);
p += gap;
}
+ if (vectorize) {
+ if (veclen) {
+ memcpy(p, dotstr, dotstrlen);
+ p += dotstrlen;
+ }
+ else
+ vectorize = FALSE; /* done iterating over vecstr */
+ }
if (is_utf)
SvUTF8_on(sv);
*p = '\0';
SvCUR(sv) = p - SvPVX(sv);
+ if (vectorize) {
+ esignlen = 0;
+ goto vector;
+ }
}
}
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
dptr = POPDPTR(ss,ix);
- TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl);
+ TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
break;
case SAVEt_DESTRUCTOR_X:
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
dxptr = POPDXPTR(ss,ix);
- TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl);
+ TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
break;
case SAVEt_REGCONTEXT:
case SAVEt_ALLOC:
# ifdef PERL_OBJECT
CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
ipD, ipS, ipP);
- PERL_SET_INTERP(pPerl);
+ PERL_SET_THX(pPerl);
# else /* !PERL_OBJECT */
PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
- PERL_SET_INTERP(my_perl);
+ PERL_SET_THX(my_perl);
# ifdef DEBUGGING
memset(my_perl, 0xab, sizeof(PerlInterpreter));
SV *sv;
SV **svp;
PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
- PERL_SET_INTERP(my_perl);
+ PERL_SET_THX(my_perl);
# ifdef DEBUGGING
memset(my_perl, 0xab, sizeof(PerlInterpreter));
PL_dirty = proto_perl->Tdirty;
PL_localizing = proto_perl->Tlocalizing;
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
PL_protect = proto_perl->Tprotect;
+#endif
PL_errors = sv_dup_inc(proto_perl->Terrors);
PL_av_fetch_sv = Nullsv;
PL_hv_fetch_sv = Nullsv;
projects / p5sagit/p5-mst-13.2.git / blobdiff