#endif
/*
- * Types used in bitwise operations.
- *
- * Normally we'd just use IV and UV. However, some hardware and
- * software combinations (e.g. Alpha and current OSF/1) don't have a
- * floating-point type to use for NV that has adequate bits to fully
- * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
- *
- * It just so happens that "int" is the right size almost everywhere.
- */
-typedef int IBW;
-typedef unsigned UBW;
-
-/*
- * Mask used after bitwise operations.
- *
- * There is at least one realm (Cray word machines) that doesn't
- * have an integral type (except char) small enough to be represented
- * in a double without loss; that is, it has no 32-bit type.
- */
-#if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP)
-# define BW_BITS 32
-# define BW_MASK ((1 << BW_BITS) - 1)
-# define BW_SIGN (1 << (BW_BITS - 1))
-# define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
-# define BWu(u) ((u) & BW_MASK)
-#else
-# define BWi(i) (i)
-# define BWu(u) (u)
-#endif
-
-/*
* Offset for integer pack/unpack.
*
* On architectures where I16 and I32 aren't really 16 and 32 bits,
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;
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(lshift,opASSIGN);
{
- IBW shift = POPi;
- if (PL_op->op_private & HINT_INTEGER) {
- IBW i = TOPi;
- i = BWi(i) << shift;
- SETi(BWi(i));
- }
- else {
- UBW u = TOPu;
- u <<= shift;
- SETu(BWu(u));
- }
+ IV shift = POPi;
+ if (PL_op->op_private & HINT_INTEGER)
+ SETi(TOPi << shift);
+ else
+ SETu(TOPu << shift);
RETURN;
}
}
{
djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
{
- IBW shift = POPi;
- if (PL_op->op_private & HINT_INTEGER) {
- IBW i = TOPi;
- i = BWi(i) >> shift;
- SETi(BWi(i));
- }
- else {
- UBW u = TOPu;
- u >>= shift;
- SETu(BWu(u));
- }
+ IV shift = POPi;
+ if (PL_op->op_private & HINT_INTEGER)
+ SETi(TOPi >> shift);
+ else
+ SETu(TOPu >> shift);
RETURN;
}
}
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
- if (PL_op->op_private & HINT_INTEGER) {
- IBW value = SvIV(left) & SvIV(right);
- SETi(BWi(value));
- }
- else {
- UBW value = SvUV(left) & SvUV(right);
- SETu(BWu(value));
- }
+ if (PL_op->op_private & HINT_INTEGER)
+ SETi( SvIV(left) & SvIV(right) );
+ else
+ SETu( SvUV(left) & SvUV(right) );
}
else {
do_vop(PL_op->op_type, TARG, left, right);
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
- if (PL_op->op_private & HINT_INTEGER) {
- IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
- SETi(BWi(value));
- }
- else {
- UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
- SETu(BWu(value));
- }
+ if (PL_op->op_private & HINT_INTEGER)
+ SETi( (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right) );
+ else
+ SETu( (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right) );
}
else {
do_vop(PL_op->op_type, TARG, left, right);
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
- if (PL_op->op_private & HINT_INTEGER) {
- IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
- SETi(BWi(value));
- }
- else {
- UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
- SETu(BWu(value));
- }
+ if (PL_op->op_private & HINT_INTEGER)
+ SETi( (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right) );
+ else
+ SETu( (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right) );
}
else {
do_vop(PL_op->op_type, TARG, left, right);
{
dTOPss;
if (SvNIOKp(sv)) {
- if (PL_op->op_private & HINT_INTEGER) {
- IBW value = ~SvIV(sv);
- SETi(BWi(value));
- }
- else {
- UBW value = ~SvUV(sv);
- SETu(BWu(value));
- }
+ if (PL_op->op_private & HINT_INTEGER)
+ SETi( ~SvIV(sv) );
+ else
+ SETu( ~SvUV(sv) );
}
else {
register char *tmps;
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;
}
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) {
}
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':
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);
if (checksum) {
#if LONGSIZE != SIZE32
if (natint) {
+ long along;
while (len-- > 0) {
COPYNN(s, &along, sizeof(long));
s += sizeof(long);
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);
EXTEND_MORTAL(len);
#if LONGSIZE != SIZE32
if (unatint) {
+ unsigned long aulong;
while (len-- > 0) {
COPYNN(s, &aulong, sizeof(unsigned long));
s += sizeof(unsigned long);
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;
}
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 '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;
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