if (cv) {
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+ if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
+ Perl_croak(aTHX_ "Can't modify non-lvalue subroutine call");
}
else
cv = (CV*)&PL_sv_undef;
else
(void)SvREFCNT_inc(sv);
}
+ else if (SvTYPE(sv) == SVt_PVAV) {
+ if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
+ av_reify((AV*)sv);
+ SvTEMP_off(sv);
+ (void)SvREFCNT_inc(sv);
+ }
else if (SvPADTMP(sv))
sv = newSVsv(sv);
else {
PP(pp_postdec)
{
djSP; dTARGET;
- if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+ if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
Perl_croak(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
{
dPOPPOPnnrl;
- double value;
+ NV value;
if (right == 0.0)
DIE(aTHX_ "Illegal division by zero");
#ifdef SLOPPYDIVIDE
/* insure that 20./5. == 4. */
{
IV k;
- if ((double)I_V(left) == left &&
- (double)I_V(right) == right &&
+ if ((NV)I_V(left) == left &&
+ (NV)I_V(right) == right &&
(k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
value = k;
}
bool left_neg;
bool right_neg;
bool use_double = 0;
- double dright;
- double dleft;
+ NV dright;
+ NV dleft;
if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
IV i = SvIVX(POPs);
}
if (use_double) {
- double dans;
+ NV dans;
#if 1
/* Somehow U_V is pessimized even if CASTFLAGS is 0 */
if (!dright)
DIE(aTHX_ "Illegal modulus zero");
- dans = fmod(dleft, dright);
+ dans = Perl_fmod(dleft, dright);
if ((left_neg != right_neg) && dans)
dans = dright - dans;
if (right_neg)
if (ans <= ~((UV)IV_MAX)+1)
sv_setiv(TARG, ~ans+1);
else
- sv_setnv(TARG, -(double)ans);
+ sv_setnv(TARG, -(NV)ans);
}
else
sv_setuv(TARG, ans);
djSP; dTARGET; tryAMAGICbin(atan2,0);
{
dPOPTOPnnrl;
- SETn(atan2(left, right));
+ SETn(Perl_atan2(left, right));
RETURN;
}
}
{
djSP; dTARGET; tryAMAGICun(sin);
{
- double value;
+ NV value;
value = POPn;
- value = sin(value);
+ value = Perl_sin(value);
XPUSHn(value);
RETURN;
}
{
djSP; dTARGET; tryAMAGICun(cos);
{
- double value;
+ NV value;
value = POPn;
- value = cos(value);
+ value = Perl_cos(value);
XPUSHn(value);
RETURN;
}
PP(pp_rand)
{
djSP; dTARGET;
- double value;
+ NV value;
if (MAXARG < 1)
value = 1.0;
else
# endif
#endif
u += SEED_C3 * (U32)getpid();
- u += SEED_C4 * (U32)(UV)PL_stack_sp;
+ u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
- u += SEED_C5 * (U32)(UV)&when;
+ u += SEED_C5 * (U32)PTR2UV(&when);
#endif
return u;
}
{
djSP; dTARGET; tryAMAGICun(exp);
{
- double value;
+ NV value;
value = POPn;
- value = exp(value);
+ value = Perl_exp(value);
XPUSHn(value);
RETURN;
}
{
djSP; dTARGET; tryAMAGICun(log);
{
- double value;
+ NV value;
value = POPn;
if (value <= 0.0) {
RESTORE_NUMERIC_STANDARD();
DIE(aTHX_ "Can't take log of %g", value);
}
- value = log(value);
+ value = Perl_log(value);
XPUSHn(value);
RETURN;
}
{
djSP; dTARGET; tryAMAGICun(sqrt);
{
- double value;
+ NV value;
value = POPn;
if (value < 0.0) {
RESTORE_NUMERIC_STANDARD();
DIE(aTHX_ "Can't take sqrt of %g", value);
}
- value = sqrt(value);
+ value = Perl_sqrt(value);
XPUSHn(value);
RETURN;
}
{
djSP; dTARGET;
{
- double value = TOPn;
+ NV value = TOPn;
IV iv;
if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
}
else {
if (value >= 0.0)
- (void)modf(value, &value);
+ (void)Perl_modf(value, &value);
else {
- (void)modf(-value, &value);
+ (void)Perl_modf(-value, &value);
value = -value;
}
iv = I_V(value);
{
djSP; dTARGET; tryAMAGICun(abs);
{
- double value = TOPn;
+ NV value = TOPn;
IV iv;
if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
STRLEN n_a;
tmps = POPpx;
- XPUSHu(scan_hex(tmps, 99, &argtype));
+ XPUSHn(scan_hex(tmps, 99, &argtype));
RETURN;
}
PP(pp_oct)
{
djSP; dTARGET;
- UV value;
+ NV value;
I32 argtype;
char *tmps;
STRLEN n_a;
value = scan_bin(++tmps, 99, &argtype);
else
value = scan_oct(tmps, 99, &argtype);
- XPUSHu(value);
+ XPUSHn(value);
RETURN;
}
register I32 offset = POPi;
register SV *src = POPs;
I32 lvalue = PL_op->op_flags & OPf_MOD;
- STRLEN srclen;
- unsigned char *s = (unsigned char*)SvPV(src, srclen);
- unsigned long retnum;
- I32 len;
-
- SvTAINTED_off(TARG); /* decontaminate */
- offset *= size; /* turn into bit offset */
- len = (offset + size + 7) / 8;
- if (offset < 0 || size < 1)
- retnum = 0;
- else {
- if (lvalue) { /* it's an lvalue! */
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, Nullsv, 'v', Nullch, 0);
- }
- LvTYPE(TARG) = 'v';
- if (LvTARG(TARG) != src) {
- if (LvTARG(TARG))
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc(src);
- }
- LvTARGOFF(TARG) = offset;
- LvTARGLEN(TARG) = size;
- }
- if (len > srclen) {
- if (size <= 8)
- retnum = 0;
- else {
- offset >>= 3;
- if (size == 16) {
- if (offset >= srclen)
- retnum = 0;
- else
- retnum = (unsigned long) s[offset] << 8;
- }
- else if (size == 32) {
- if (offset >= srclen)
- retnum = 0;
- else if (offset + 1 >= srclen)
- retnum = (unsigned long) s[offset] << 24;
- else if (offset + 2 >= srclen)
- retnum = ((unsigned long) s[offset] << 24) +
- ((unsigned long) s[offset + 1] << 16);
- else
- retnum = ((unsigned long) s[offset] << 24) +
- ((unsigned long) s[offset + 1] << 16) +
- (s[offset + 2] << 8);
- }
- }
+ SvTAINTED_off(TARG); /* decontaminate */
+ if (lvalue) { /* it's an lvalue! */
+ if (SvTYPE(TARG) < SVt_PVLV) {
+ sv_upgrade(TARG, SVt_PVLV);
+ sv_magic(TARG, Nullsv, 'v', Nullch, 0);
}
- else if (size < 8)
- retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
- else {
- offset >>= 3;
- if (size == 8)
- retnum = s[offset];
- else if (size == 16)
- retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
- else if (size == 32)
- retnum = ((unsigned long) s[offset] << 24) +
- ((unsigned long) s[offset + 1] << 16) +
- (s[offset + 2] << 8) + s[offset+3];
+ LvTYPE(TARG) = 'v';
+ if (LvTARG(TARG) != src) {
+ if (LvTARG(TARG))
+ SvREFCNT_dec(LvTARG(TARG));
+ LvTARG(TARG) = SvREFCNT_inc(src);
}
+ LvTARGOFF(TARG) = offset;
+ LvTARGLEN(TARG) = size;
}
- sv_setuv(TARG, (UV)retnum);
+ sv_setuv(TARG, do_vecget(src, offset, size));
PUSHs(TARG);
RETURN;
}
s = (U8*)SvPV_force(sv, slen);
Copy(tmpbuf, s, ulen, U8);
}
- } else {
+ }
+ else {
if (!SvPADTMP(sv)) {
dTARGET;
sv_setsv(TARG, sv);
s = (U8*)SvPV_force(sv, slen);
Copy(tmpbuf, s, ulen, U8);
}
- } else {
+ }
+ else {
if (!SvPADTMP(sv)) {
dTARGET;
sv_setsv(TARG, sv);
if (!len) {
sv_setpvn(TARG, "", 0);
SETs(TARG);
- } else {
+ }
+ else {
(void)SvUPGRADE(TARG, SVt_PV);
SvGROW(TARG, (len * 2) + 1);
(void)SvPOK_only(TARG);
SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
SETs(TARG);
}
- } else {
+ }
+ else {
if (!SvPADTMP(sv)) {
dTARGET;
sv_setsv(TARG, sv);
if (!len) {
sv_setpvn(TARG, "", 0);
SETs(TARG);
- } else {
+ }
+ else {
(void)SvUPGRADE(TARG, SVt_PV);
SvGROW(TARG, (len * 2) + 1);
(void)SvPOK_only(TARG);
SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
SETs(TARG);
}
- } else {
+ }
+ else {
if (!SvPADTMP(sv)) {
dTARGET;
sv_setsv(TARG, sv);
PP(pp_each)
{
- djSP; dTARGET;
+ djSP;
HV *hash = (HV*)POPs;
HE *entry;
I32 gimme = GIMME_V;
if (entry) {
PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
if (gimme == G_ARRAY) {
+ SV *val;
PUTBACK;
/* might clobber stack_sp */
- sv_setsv(TARG, realhv ?
- hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
+ val = realhv ?
+ hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
SPAGAIN;
- PUSHs(TARG);
+ PUSHs(val);
}
}
else if (gimme == G_SCALAR)
s += UTF8SKIP(s);
down = (char*)(s - 1);
if (s > send || !((*down & 0xc0) == 0x80)) {
- Perl_warn(aTHX_ "Malformed UTF-8 character");
+ if (ckWARN_d(WARN_UTF8))
+ Perl_warner(aTHX_ WARN_UTF8,
+ "Malformed UTF-8 character");
break;
}
while (down > up) {
double adouble;
I32 checksum = 0;
register U32 culong;
- double cdouble;
+ NV cdouble;
int commas = 0;
#ifdef PERL_NATINT_PACK
int natint; /* native integer */
#endif
if (isSPACE(datumtype))
continue;
+ if (datumtype == '#') {
+ while (pat < patend && *pat != '\n')
+ pat++;
+ continue;
+ }
if (*pat == '!') {
char *natstr = "sSiIlL";
}
else if (isDIGIT(*pat)) {
len = *pat++ - '0';
- while (isDIGIT(*pat))
+ while (isDIGIT(*pat)) {
len = (len * 10) + (*pat++ - '0');
+ if (len < 0)
+ Perl_croak(aTHX_ "Repeat count in unpack overflows");
+ }
}
else
len = (datumtype != '@');
DIE(aTHX_ "x outside of string");
s += len;
break;
+ case '/':
+ if (oldsp >= SP)
+ DIE(aTHX_ "/ must follow a numeric type");
+ if (*pat != 'a' && *pat != 'A' && *pat != 'Z')
+ DIE(aTHX_ "/ must be followed by a, A or Z");
+ datumtype = *pat++;
+ if (*pat == '*')
+ pat++; /* ignore '*' for compatibility with pack */
+ if (isDIGIT(*pat))
+ DIE(aTHX_ "/ cannot take a count" );
+ len = POPi;
+ /* drop through */
case 'A':
case 'Z':
case 'a':
auint = utf8_to_uv((U8*)s, &along);
s += along;
if (checksum > 32)
- cdouble += (double)auint;
+ cdouble += (NV)auint;
else
culong += auint;
}
if (checksum) {
#if SHORTSIZE != SIZE16
if (natint) {
+ short ashort;
while (len-- > 0) {
COPYNN(s, &ashort, sizeof(short));
s += sizeof(short);
EXTEND_MORTAL(len);
#if SHORTSIZE != SIZE16
if (natint) {
+ short ashort;
while (len-- > 0) {
COPYNN(s, &ashort, sizeof(short));
s += sizeof(short);
if (checksum) {
#if SHORTSIZE != SIZE16
if (unatint) {
+ unsigned short aushort;
while (len-- > 0) {
COPYNN(s, &aushort, sizeof(unsigned short));
s += sizeof(unsigned short);
EXTEND_MORTAL(len);
#if SHORTSIZE != SIZE16
if (unatint) {
+ unsigned short aushort;
while (len-- > 0) {
COPYNN(s, &aushort, sizeof(unsigned short));
s += sizeof(unsigned short);
Copy(s, &aint, 1, int);
s += sizeof(int);
if (checksum > 32)
- cdouble += (double)aint;
+ cdouble += (NV)aint;
else
culong += aint;
}
Copy(s, &auint, 1, unsigned int);
s += sizeof(unsigned int);
if (checksum > 32)
- cdouble += (double)auint;
+ cdouble += (NV)auint;
else
culong += auint;
}
if (checksum) {
#if LONGSIZE != SIZE32
if (natint) {
+ long along;
while (len-- > 0) {
COPYNN(s, &along, sizeof(long));
s += sizeof(long);
if (checksum > 32)
- cdouble += (double)along;
+ cdouble += (NV)along;
else
culong += along;
}
#endif
s += SIZE32;
if (checksum > 32)
- cdouble += (double)along;
+ cdouble += (NV)along;
else
culong += along;
}
EXTEND_MORTAL(len);
#if LONGSIZE != SIZE32
if (natint) {
+ long along;
while (len-- > 0) {
COPYNN(s, &along, sizeof(long));
s += sizeof(long);
if (checksum) {
#if LONGSIZE != SIZE32
if (unatint) {
+ unsigned long aulong;
while (len-- > 0) {
COPYNN(s, &aulong, sizeof(unsigned long));
s += sizeof(unsigned long);
if (checksum > 32)
- cdouble += (double)aulong;
+ cdouble += (NV)aulong;
else
culong += aulong;
}
aulong = vtohl(aulong);
#endif
if (checksum > 32)
- cdouble += (double)aulong;
+ cdouble += (NV)aulong;
else
culong += aulong;
}
EXTEND_MORTAL(len);
#if LONGSIZE != SIZE32
if (unatint) {
+ unsigned long aulong;
while (len-- > 0) {
COPYNN(s, &aulong, sizeof(unsigned long));
s += sizeof(unsigned long);
if (aquad >= IV_MIN && aquad <= IV_MAX)
sv_setiv(sv, (IV)aquad);
else
- sv_setnv(sv, (double)aquad);
+ sv_setnv(sv, (NV)aquad);
PUSHs(sv_2mortal(sv));
}
break;
if (auquad <= UV_MAX)
sv_setuv(sv, (UV)auquad);
else
- sv_setnv(sv, (double)auquad);
+ sv_setnv(sv, (NV)auquad);
PUSHs(sv_2mortal(sv));
}
break;
Copy(s, &afloat, 1, float);
s += sizeof(float);
sv = NEWSV(47, 0);
- sv_setnv(sv, (double)afloat);
+ sv_setnv(sv, (NV)afloat);
PUSHs(sv_2mortal(sv));
}
}
Copy(s, &adouble, 1, double);
s += sizeof(double);
sv = NEWSV(48, 0);
- sv_setnv(sv, (double)adouble);
+ sv_setnv(sv, (NV)adouble);
PUSHs(sv_2mortal(sv));
}
}
sv = NEWSV(42, 0);
if (strchr("fFdD", datumtype) ||
(checksum > 32 && strchr("iIlLNU", datumtype)) ) {
- double trouble;
+ NV trouble;
adouble = 1.0;
while (checksum >= 16) {
along = (1 << checksum) - 1;
while (cdouble < 0.0)
cdouble += adouble;
- cdouble = modf(cdouble / adouble, &trouble) * adouble;
+ cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
sv_setnv(sv, cdouble);
}
else {
MARK++;
sv_setpvn(cat, "", 0);
while (pat < patend) {
-#define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
+ SV *lengthcode = Nullsv;
+#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
datumtype = *pat++ & 0xFF;
#ifdef PERL_NATINT_PACK
natint = 0;
#endif
if (isSPACE(datumtype))
continue;
+ if (datumtype == '#') {
+ while (pat < patend && *pat != '\n')
+ pat++;
+ continue;
+ }
if (*pat == '!') {
char *natstr = "sSiIlL";
}
else if (isDIGIT(*pat)) {
len = *pat++ - '0';
- while (isDIGIT(*pat))
+ while (isDIGIT(*pat)) {
len = (len * 10) + (*pat++ - '0');
+ if (len < 0)
+ Perl_croak(aTHX_ "Repeat count in pack overflows");
+ }
}
else
len = 1;
+ if (*pat == '/') {
+ ++pat;
+ if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
+ DIE(aTHX_ "/ must be followed by a*, A* or Z*");
+ lengthcode = sv_2mortal(newSViv(sv_len(items > 0
+ ? *MARK : &PL_sv_no)));
+ }
switch(datumtype) {
default:
Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
if (commas++ == 0 && ckWARN(WARN_UNSAFE))
- Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
+ Perl_warner(aTHX_ WARN_UNSAFE,
+ "Invalid type in pack: '%c'", (int)datumtype);
break;
case '%':
DIE(aTHX_ "%% may only be used in unpack");
case 's':
#if SHORTSIZE != SIZE16
if (natint) {
+ short ashort;
+
while (len-- > 0) {
fromstr = NEXTFROM;
ashort = SvIV(fromstr);
case 'w':
while (len-- > 0) {
fromstr = NEXTFROM;
- adouble = floor(SvNV(fromstr));
+ adouble = Perl_floor(SvNV(fromstr));
if (adouble < 0)
Perl_croak(aTHX_ "Cannot compress negative numbers");
case 'L':
#if LONGSIZE != SIZE32
if (natint) {
+ unsigned long aulong;
+
while (len-- > 0) {
fromstr = NEXTFROM;
aulong = SvUV(fromstr);
case 'l':
#if LONGSIZE != SIZE32
if (natint) {
+ long along;
+
while (len-- > 0) {
fromstr = NEXTFROM;
along = SvIV(fromstr);
case 'Q':
while (len-- > 0) {
fromstr = NEXTFROM;
- auquad = (Uquad_t)SvIV(fromstr);
+ auquad = (Uquad_t)SvUV(fromstr);
sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
}
break;
else {
if (!AvREAL(ary)) {
AvREAL_on(ary);
+ AvREIFY_off(ary);
for (i = AvFILLp(ary); i >= 0; i--)
AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
}
s = m;
}
}
- else if (rx->check_substr && !rx->nparens
+ else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
&& (rx->reganch & ROPT_CHECK_ALL)
&& !(rx->reganch & ROPT_ANCH)) {
- int tail = SvTAIL(rx->check_substr) != 0;
+ int tail = (rx->reganch & RE_INTUIT_TAIL);
+ SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
+ char c;
- i = SvCUR(rx->check_substr);
- if (i == 1 && !tail) {
- i = *SvPVX(rx->check_substr);
+ len = rx->minlen;
+ if (len == 1 && !tail) {
+ c = *SvPV(csv,len);
while (--limit) {
/*SUPPRESS 530*/
- for (m = s; m < strend && *m != i; m++) ;
+ for (m = s; m < strend && *m != c; m++) ;
if (m >= strend)
break;
dstr = NEWSV(30, m-s);
else {
#ifndef lint
while (s < strend && --limit &&
- (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
- rx->check_substr, PL_multiline ? FBMrf_MULTILINE : 0)) )
+ (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
+ csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
#endif
{
dstr = NEWSV(31, m-s);
if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
- s = m + i - tail; /* Fake \n at the end */
+ s = m + len; /* Fake \n at the end */
}
}
}
else {
maxiters += (strend - s) * rx->nparens;
- while (s < strend && --limit &&
- CALLREGEXEC(aTHX_ rx, s, strend, orig, 1, sv, NULL, 0))
+ while (s < strend && --limit
+/* && (!rx->check_substr
+ || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
+ 0, NULL))))
+*/ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
+ 1 /* minend */, sv, NULL, 0))
{
TAINT_IF(RX_MATCH_TAINTED(rx));
if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
(unsigned long)thr, (unsigned long)sv);)
MUTEX_UNLOCK(MgMUTEXP(mg));
- save_destructor(Perl_unlock_condpair, sv);
+ SAVEDESTRUCTOR(Perl_unlock_condpair, sv);
}
#endif /* USE_THREADS */
if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
projects / p5sagit/p5-mst-13.2.git / blobdiff