/* pp.c
*
- * Copyright (c) 1991-1999, Larry Wall
+ * Copyright (c) 1991-2000, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#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,
# define PERL_NATINT_PACK
#endif
-#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
+#if LONGSIZE > 4 && defined(_CRAY)
# if BYTEORDER == 0x12345678
# define OFF16(p) (char*)(p)
# define OFF32(p) (char*)(p)
else {
if (SvTYPE(sv) != SVt_PVGV) {
char *sym;
- STRLEN n_a;
+ STRLEN len;
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
goto wasref;
}
- if (!SvOK(sv)) {
+ if (!SvOK(sv) && sv != &PL_sv_undef) {
/* If this is a 'my' scalar and flag is set then vivify
* NI-S 1999/05/07
*/
if (PL_op->op_private & OPpDEREF) {
- GV *gv = (GV *) newSV(0);
- STRLEN len = 0;
- char *name = "";
- if (cUNOP->op_first->op_type == OP_PADSV) {
- SV *padname = *av_fetch(PL_comppad_name, cUNOP->op_first->op_targ, 4);
- name = SvPV(padname,len);
+ char *name;
+ GV *gv;
+ if (cUNOP->op_targ) {
+ STRLEN len;
+ SV *namesv = PL_curpad[cUNOP->op_targ];
+ name = SvPV(namesv, len);
+ gv = (GV*)NEWSV(0,0);
+ gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
+ }
+ else {
+ name = CopSTASHPV(PL_curcop);
+ gv = newGVgen(name);
}
- gv_init(gv, PL_curcop->cop_stash, name, len, 0);
sv_upgrade(sv, SVt_RV);
- SvRV(sv) = (SV *) gv;
+ SvRV(sv) = (SV*)gv;
SvROK_on(sv);
SvSETMAGIC(sv);
goto wasref;
- }
+ }
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ PL_no_usym, "a symbol");
if (ckWARN(WARN_UNINITIALIZED))
- Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
+ report_uninit();
RETSETUNDEF;
}
- sym = SvPV(sv, n_a);
+ sym = SvPV(sv,len);
if ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
- if (!sv)
+ if (!sv
+ && (!is_gv_magical(sym,len,0)
+ || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
+ {
RETSETUNDEF;
+ }
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
else {
GV *gv = (GV*)sv;
char *sym;
- STRLEN n_a;
+ STRLEN len;
if (SvTYPE(gv) != SVt_PVGV) {
if (SvGMAGICAL(sv)) {
PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ PL_no_usym, "a SCALAR");
if (ckWARN(WARN_UNINITIALIZED))
- Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
+ report_uninit();
RETSETUNDEF;
}
- sym = SvPV(sv, n_a);
+ sym = SvPV(sv, len);
if ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
- if (!gv)
+ if (!gv
+ && (!is_gv_magical(sym,len,0)
+ || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
+ {
RETSETUNDEF;
+ }
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
mg = mg_find(sv, 'g');
if (mg && mg->mg_len >= 0) {
I32 i = mg->mg_len;
- if (IN_UTF8)
+ if (DO_UTF8(sv))
sv_pos_b2u(sv, &i);
PUSHi(i + PL_curcop->cop_arybase);
RETURN;
if (cv) {
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+ if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
+ DIE(aTHX_ "Can't modify non-lvalue subroutine call");
}
else
cv = (CV*)&PL_sv_undef;
seen_question = 1;
str[n++] = ';';
}
- else if (seen_question)
+ else if (n && str[0] == ';' && seen_question)
goto set; /* XXXX system, exec */
if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
&& (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
goto set;
else { /* None such */
nonesuch:
- Perl_croak(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
+ DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
}
}
}
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 {
HV *stash;
if (MAXARG == 1)
- stash = PL_curcop->cop_stash;
+ stash = CopSTASH(PL_curcop);
else {
SV *ssv = POPs;
STRLEN len;
- char *ptr = SvPV(ssv,len);
- if (ckWARN(WARN_UNSAFE) && len == 0)
- Perl_warner(aTHX_ WARN_UNSAFE,
+ char *ptr;
+
+ if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
+ Perl_croak(aTHX_ "Attempt to bless into a reference");
+ ptr = SvPV(ssv,len);
+ if (ckWARN(WARN_MISC) && len == 0)
+ Perl_warner(aTHX_ WARN_MISC,
"Explicit blessing to '' (assuming package main)");
stash = gv_stashpvn(ptr, len, TRUE);
}
case 'F':
if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
tmpRef = (SV*)GvIOp(gv);
+ else
+ if (strEQ(elem, "FORMAT"))
+ tmpRef = (SV*)GvFORM(gv);
break;
case 'G':
if (strEQ(elem, "GLOB"))
hv_undef((HV*)sv);
break;
case SVt_PVCV:
- if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
- Perl_warner(aTHX_ WARN_UNSAFE, "Constant subroutine %s undefined",
+ if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
+ Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
/* FALL THROUGH */
case SVt_PVFM:
Newz(602, gp, 1, GP);
GvGP(sv) = gp_ref(gp);
GvSV(sv) = NEWSV(72,0);
- GvLINE(sv) = PL_curcop->cop_line;
+ GvLINE(sv) = CopLINE(PL_curcop);
GvEGV(sv) = (GV*)sv;
GvMULTI_on(sv);
}
{
djSP;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- Perl_croak(aTHX_ PL_no_modify);
+ DIE(aTHX_ PL_no_modify);
if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MIN)
{
{
djSP; dTARGET;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- Perl_croak(aTHX_ PL_no_modify);
+ DIE(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MAX)
{
djSP; dTARGET;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- Perl_croak(aTHX_ PL_no_modify);
+ DIE(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MIN)
djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
{
dPOPTOPnnrl;
- SETn( pow( left, right) );
+ SETn( Perl_pow( left, right) );
RETURN;
}
}
NV dright;
NV dleft;
- if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
+ if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
IV i = SvIVX(POPs);
right = (right_neg = (i < 0)) ? -i : i;
}
dright = -dright;
}
- if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
+ if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
IV i = SvIVX(POPs);
left = (left_neg = (i < 0)) ? -i : i;
}
#endif
/* Backward-compatibility clause: */
- dright = floor(dright + 0.5);
- dleft = floor(dleft + 0.5);
+ dright = Perl_floor(dright + 0.5);
+ dleft = Perl_floor(dleft + 0.5);
if (!dright)
DIE(aTHX_ "Illegal modulus zero");
SP -= items;
}
else { /* Note: mark already snarfed by pp_list */
- SV *tmpstr;
+ SV *tmpstr = POPs;
STRLEN len;
+ bool isutf = DO_UTF8(tmpstr);
- tmpstr = POPs;
SvSetSV(TARG, tmpstr);
SvPV_force(TARG, len);
if (count != 1) {
}
*SvEND(TARG) = '\0';
}
- (void)SvPOK_only(TARG);
+ if (isutf)
+ (void)SvPOK_only_UTF8(TARG);
+ else
+ (void)SvPOK_only(TARG);
PUSHTARG;
}
RETURN;
{
djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
{
- IBW shift = POPi;
+ IV shift = POPi;
if (PL_op->op_private & HINT_INTEGER) {
- IBW i = TOPi;
- i = BWi(i) << shift;
- SETi(BWi(i));
+ IV i = TOPi;
+ SETi(i << shift);
}
else {
- UBW u = TOPu;
- u <<= shift;
- SETu(BWu(u));
+ UV u = TOPu;
+ SETu(u << shift);
}
RETURN;
}
{
djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
{
- IBW shift = POPi;
+ IV shift = POPi;
if (PL_op->op_private & HINT_INTEGER) {
- IBW i = TOPi;
- i = BWi(i) >> shift;
- SETi(BWi(i));
+ IV i = TOPi;
+ SETi(i >> shift);
}
else {
- UBW u = TOPu;
- u >>= shift;
- SETu(BWu(u));
+ UV u = TOPu;
+ SETu(u >> shift);
}
RETURN;
}
dPOPTOPnnrl;
I32 value;
+#ifdef Perl_isnan
+ if (Perl_isnan(left) || Perl_isnan(right)) {
+ SETs(&PL_sv_undef);
+ RETURN;
+ }
+ value = (left > right) - (left < right);
+#else
if (left == right)
value = 0;
else if (left < right)
SETs(&PL_sv_undef);
RETURN;
}
+#endif
SETi(value);
RETURN;
}
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
if (PL_op->op_private & HINT_INTEGER) {
- IBW value = SvIV(left) & SvIV(right);
- SETi(BWi(value));
+ IV i = SvIV(left) & SvIV(right);
+ SETi(i);
}
else {
- UBW value = SvUV(left) & SvUV(right);
- SETu(BWu(value));
+ UV u = SvUV(left) & SvUV(right);
+ SETu(u);
}
}
else {
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));
+ IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
+ SETi(i);
}
else {
- UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
- SETu(BWu(value));
+ UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
+ SETu(u);
}
}
else {
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));
+ IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
+ SETi(i);
}
else {
- UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
- SETu(BWu(value));
+ UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
+ SETu(u);
}
}
else {
dTOPss;
if (SvGMAGICAL(sv))
mg_get(sv);
- if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
- SETi(-SvIVX(sv));
- else if (SvNIOKp(sv))
+ if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
+ if (SvIsUV(sv)) {
+ if (SvIVX(sv) == IV_MIN) {
+ SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
+ RETURN;
+ }
+ else if (SvUVX(sv) <= IV_MAX) {
+ SETi(-SvIVX(sv));
+ RETURN;
+ }
+ }
+ else if (SvIVX(sv) != IV_MIN) {
+ SETi(-SvIVX(sv));
+ RETURN;
+ }
+ }
+ if (SvNIOKp(sv))
SETn(-SvNV(sv));
else if (SvPOKp(sv)) {
STRLEN len;
sv_setsv(TARG, sv);
*SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
}
- else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
+ else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
sv_setpvn(TARG, "-", 1);
sv_catsv(TARG, sv);
}
dTOPss;
if (SvNIOKp(sv)) {
if (PL_op->op_private & HINT_INTEGER) {
- IBW value = ~SvIV(sv);
- SETi(BWi(value));
+ IV i = ~SvIV(sv);
+ SETi(i);
}
else {
- UBW value = ~SvUV(sv);
- SETu(BWu(value));
+ UV u = ~SvUV(sv);
+ SETu(u);
}
}
else {
u = (U32)SEED_C1 * when;
# endif
#endif
- u += SEED_C3 * (U32)getpid();
- u += SEED_C4 * (U32)(UV)PL_stack_sp;
+ u += SEED_C3 * (U32)PerlProc_getpid();
+ 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;
}
NV value;
value = POPn;
if (value <= 0.0) {
- RESTORE_NUMERIC_STANDARD();
+ SET_NUMERIC_STANDARD();
DIE(aTHX_ "Can't take log of %g", value);
}
value = Perl_log(value);
NV value;
value = POPn;
if (value < 0.0) {
- RESTORE_NUMERIC_STANDARD();
+ SET_NUMERIC_STANDARD();
DIE(aTHX_ "Can't take sqrt of %g", value);
}
value = Perl_sqrt(value);
STRLEN n_a;
tmps = POPpx;
+ argtype = 1; /* allow underscores */
XPUSHn(scan_hex(tmps, 99, &argtype));
RETURN;
}
tmps++;
if (*tmps == '0')
tmps++;
+ argtype = 1; /* allow underscores */
if (*tmps == 'x')
value = scan_hex(++tmps, 99, &argtype);
else if (*tmps == 'b')
PP(pp_length)
{
djSP; dTARGET;
+ SV *sv = TOPs;
- if (IN_UTF8) {
- SETi( sv_len_utf8(TOPs) );
- RETURN;
- }
-
- SETi( sv_len(TOPs) );
+ if (DO_UTF8(sv))
+ SETi(sv_len_utf8(sv));
+ else
+ SETi(sv_len(sv));
RETURN;
}
STRLEN repl_len;
SvTAINTED_off(TARG); /* decontaminate */
+ SvUTF8_off(TARG); /* decontaminate */
if (MAXARG > 2) {
if (MAXARG > 3) {
sv = POPs;
sv = POPs;
PUTBACK;
tmps = SvPV(sv, curlen);
- if (IN_UTF8) {
+ if (DO_UTF8(sv)) {
utfcurlen = sv_len_utf8(sv);
if (utfcurlen == curlen)
utfcurlen = 0;
rem -= pos;
}
if (fail < 0) {
- if (ckWARN(WARN_SUBSTR) || lvalue || repl)
+ if (lvalue || repl)
+ Perl_croak(aTHX_ "substr outside of string");
+ if (ckWARN(WARN_SUBSTR))
Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
RETPUSHUNDEF;
}
else {
- if (utfcurlen)
+ if (utfcurlen)
sv_pos_u2b(sv, &pos, &rem);
tmps += pos;
sv_setpvn(TARG, tmps, rem);
- if (lvalue) { /* it's an lvalue! */
+ if (utfcurlen)
+ SvUTF8_on(TARG);
+ if (repl)
+ sv_insert(sv, pos, rem, repl, repl_len);
+ else if (lvalue) { /* it's an lvalue! */
if (!SvGMAGICAL(sv)) {
if (SvROK(sv)) {
STRLEN n_a;
"Attempt to use reference as lvalue in substr");
}
if (SvOK(sv)) /* is it defined ? */
- (void)SvPOK_only(sv);
+ (void)SvPOK_only_UTF8(sv);
else
sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
}
LvTARGOFF(TARG) = pos;
LvTARGLEN(TARG) = rem;
}
- else if (repl)
- sv_insert(sv, pos, rem, repl, repl_len);
}
SPAGAIN;
PUSHs(TARG); /* avoid SvSETMAGIC here */
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;
}
little = POPs;
big = POPs;
tmps = SvPV(big, biglen);
- if (IN_UTF8 && offset > 0)
+ if (offset > 0 && DO_UTF8(big))
sv_pos_u2b(big, &offset, 0);
if (offset < 0)
offset = 0;
retval = -1;
else
retval = tmps2 - tmps;
- if (IN_UTF8 && retval > 0)
+ if (retval > 0 && DO_UTF8(big))
sv_pos_b2u(big, &retval);
PUSHi(retval + arybase);
RETURN;
if (MAXARG < 3)
offset = blen;
else {
- if (IN_UTF8 && offset > 0)
+ if (offset > 0 && DO_UTF8(big))
sv_pos_u2b(big, &offset, 0);
offset = offset - arybase + llen;
}
retval = -1;
else
retval = tmps2 - tmps;
- if (IN_UTF8 && retval > 0)
+ if (retval > 0 && DO_UTF8(big))
sv_pos_b2u(big, &retval);
PUSHi(retval + arybase);
RETURN;
djSP; dTARGET;
UV value;
STRLEN n_a;
- U8 *tmps = (U8*)POPpx;
+ SV *tmpsv = POPs;
+ U8 *tmps = (U8*)SvPVx(tmpsv,n_a);
I32 retlen;
- if (IN_UTF8 && (*tmps & 0x80))
+ if ((*tmps & 0x80) && DO_UTF8(tmpsv))
value = utf8_to_uv(tmps, &retlen);
else
value = (UV)(*tmps & 255);
(void)SvUPGRADE(TARG,SVt_PV);
- if (IN_UTF8 && value >= 128) {
- SvGROW(TARG,8);
+ if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) {
+ SvGROW(TARG, UTF8_MAXLEN+1);
tmps = SvPVX(TARG);
tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
SvCUR_set(TARG, tmps - SvPVX(TARG));
*tmps = '\0';
(void)SvPOK_only(TARG);
+ SvUTF8_on(TARG);
XPUSHs(TARG);
RETURN;
}
register U8 *s;
STRLEN slen;
- if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
+ if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
I32 ulen;
- U8 tmpbuf[10];
+ U8 tmpbuf[UTF8_MAXLEN];
U8 *tend;
UV uv = utf8_to_uv(s, &ulen);
tend = uv_to_utf8(tmpbuf, uv);
- if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
+ if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
dTARGET;
sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
+ SvUTF8_on(TARG);
SETs(TARG);
}
else {
}
}
else {
- if (!SvPADTMP(sv)) {
+ if (!SvPADTMP(sv) || SvREADONLY(sv)) {
dTARGET;
+ SvUTF8_off(TARG); /* decontaminate */
sv_setsv(TARG, sv);
sv = TARG;
SETs(sv);
register U8 *s;
STRLEN slen;
- if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
+ if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
I32 ulen;
- U8 tmpbuf[10];
+ U8 tmpbuf[UTF8_MAXLEN];
U8 *tend;
UV uv = utf8_to_uv(s, &ulen);
tend = uv_to_utf8(tmpbuf, uv);
- if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
+ if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
dTARGET;
sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
+ SvUTF8_on(TARG);
SETs(TARG);
}
else {
}
}
else {
- if (!SvPADTMP(sv)) {
+ if (!SvPADTMP(sv) || SvREADONLY(sv)) {
dTARGET;
+ SvUTF8_off(TARG); /* decontaminate */
sv_setsv(TARG, sv);
sv = TARG;
SETs(sv);
else
*s = toLOWER(*s);
}
- SETs(sv);
}
if (SvSMAGICAL(sv))
mg_set(sv);
register U8 *s;
STRLEN len;
- if (IN_UTF8) {
+ if (DO_UTF8(sv)) {
dTARGET;
I32 ulen;
register U8 *d;
s = (U8*)SvPV(sv,len);
if (!len) {
+ SvUTF8_off(TARG); /* decontaminate */
sv_setpvn(TARG, "", 0);
SETs(TARG);
}
}
}
*d = '\0';
+ SvUTF8_on(TARG);
SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
SETs(TARG);
}
}
else {
- if (!SvPADTMP(sv)) {
+ if (!SvPADTMP(sv) || SvREADONLY(sv)) {
dTARGET;
+ SvUTF8_off(TARG); /* decontaminate */
sv_setsv(TARG, sv);
sv = TARG;
SETs(sv);
register U8 *s;
STRLEN len;
- if (IN_UTF8) {
+ if (DO_UTF8(sv)) {
dTARGET;
I32 ulen;
register U8 *d;
s = (U8*)SvPV(sv,len);
if (!len) {
+ SvUTF8_off(TARG); /* decontaminate */
sv_setpvn(TARG, "", 0);
SETs(TARG);
}
}
}
*d = '\0';
+ SvUTF8_on(TARG);
SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
SETs(TARG);
}
}
else {
- if (!SvPADTMP(sv)) {
+ if (!SvPADTMP(sv) || SvREADONLY(sv)) {
dTARGET;
+ SvUTF8_off(TARG); /* decontaminate */
sv_setsv(TARG, sv);
sv = TARG;
SETs(sv);
register char *s = SvPV(sv,len);
register char *d;
+ SvUTF8_off(TARG); /* decontaminate */
if (len) {
(void)SvUPGRADE(TARG, SVt_PV);
SvGROW(TARG, (len * 2) + 1);
d = SvPVX(TARG);
- if (IN_UTF8) {
+ if (DO_UTF8(sv)) {
while (len) {
if (*s & 0x80) {
STRLEN ulen = UTF8SKIP(s);
len--;
}
}
+ SvUTF8_on(TARG);
}
else {
while (len--) {
}
*d = '\0';
SvCUR_set(TARG, d - SvPVX(TARG));
- (void)SvPOK_only(TARG);
+ (void)SvPOK_only_UTF8(TARG);
}
else
sv_setpvn(TARG, s, len);
U32 hvtype;
hv = (HV*)POPs;
hvtype = SvTYPE(hv);
- while (++MARK <= SP) {
- if (hvtype == SVt_PVHV)
+ if (hvtype == SVt_PVHV) { /* hash element */
+ while (++MARK <= SP) {
sv = hv_delete_ent(hv, *MARK, discard, 0);
- else
- DIE(aTHX_ "Not a HASH reference");
- *MARK = sv ? sv : &PL_sv_undef;
+ *MARK = sv ? sv : &PL_sv_undef;
+ }
+ }
+ else if (hvtype == SVt_PVAV) {
+ if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
+ while (++MARK <= SP) {
+ sv = av_delete((AV*)hv, SvIV(*MARK), discard);
+ *MARK = sv ? sv : &PL_sv_undef;
+ }
+ }
+ else { /* pseudo-hash element */
+ while (++MARK <= SP) {
+ sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
+ *MARK = sv ? sv : &PL_sv_undef;
+ }
+ }
}
+ else
+ DIE(aTHX_ "Not a HASH reference");
if (discard)
SP = ORIGMARK;
else if (gimme == G_SCALAR) {
hv = (HV*)POPs;
if (SvTYPE(hv) == SVt_PVHV)
sv = hv_delete_ent(hv, keysv, discard, 0);
+ else if (SvTYPE(hv) == SVt_PVAV) {
+ if (PL_op->op_flags & OPf_SPECIAL)
+ sv = av_delete((AV*)hv, SvIV(keysv), discard);
+ else
+ sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
+ }
else
DIE(aTHX_ "Not a HASH reference");
if (!sv)
PP(pp_exists)
{
djSP;
- SV *tmpsv = POPs;
- HV *hv = (HV*)POPs;
+ SV *tmpsv;
+ HV *hv;
+
+ if (PL_op->op_private & OPpEXISTS_SUB) {
+ GV *gv;
+ CV *cv;
+ SV *sv = POPs;
+ cv = sv_2cv(sv, &hv, &gv, FALSE);
+ if (cv)
+ RETPUSHYES;
+ if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
+ RETPUSHYES;
+ RETPUSHNO;
+ }
+ tmpsv = POPs;
+ hv = (HV*)POPs;
if (SvTYPE(hv) == SVt_PVHV) {
if (hv_exists_ent(hv, tmpsv, 0))
RETPUSHYES;
}
else if (SvTYPE(hv) == SVt_PVAV) {
- if (avhv_exists_ent((AV*)hv, tmpsv, 0))
+ if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
+ if (av_exists((AV*)hv, SvIV(tmpsv)))
+ RETPUSHYES;
+ }
+ else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
RETPUSHYES;
}
else {
SV *val = NEWSV(46, 0);
if (MARK < SP)
sv_setsv(val, *++MARK);
- else if (ckWARN(WARN_UNSAFE))
- Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
+ else if (ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
SV **tmparyval = 0;
MAGIC *mg;
- if (mg = SvTIED_mg((SV*)ary, 'P')) {
+ if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
*MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
register SV *sv = &PL_sv_undef;
MAGIC *mg;
- if (mg = SvTIED_mg((SV*)ary, 'P')) {
+ if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
*MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
register I32 i = 0;
MAGIC *mg;
- if (mg = SvTIED_mg((SV*)ary, 'P')) {
+ if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
*MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
*MARK++ = *SP;
*SP-- = tmp;
}
+ /* safe as long as stack cannot get extended in the above */
SP = oldsp;
}
else {
dTARGET;
STRLEN len;
+ SvUTF8_off(TARG); /* decontaminate */
if (SP - MARK > 1)
do_join(TARG, &PL_sv_no, MARK, SP);
else
sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
up = SvPV_force(TARG, len);
if (len > 1) {
- if (IN_UTF8) { /* first reverse each character */
+ if (DO_UTF8(TARG)) { /* first reverse each character */
U8* s = (U8*)SvPVX(TARG);
U8* send = (U8*)(s + len);
while (s < send) {
*up++ = *down;
*down-- = tmp;
}
- (void)SvPOK_only(TARG);
+ (void)SvPOK_only_UTF8(TARG);
}
SP = MARK + 1;
SETTARG;
{
djSP;
dPOPPOPssrl;
- SV **oldsp = SP;
+ I32 start_sp_offset = SP - PL_stack_base;
I32 gimme = GIMME_V;
SV *sv;
STRLEN llen;
I32 datumtype;
register I32 len;
register I32 bits;
+ register char *str;
/* These must not be in registers: */
I16 ashort;
register U32 culong;
NV cdouble;
int commas = 0;
+ int star;
#ifdef PERL_NATINT_PACK
int natint; /* native integer */
int unatint; /* unsigned native integer */
#endif
if (isSPACE(datumtype))
continue;
+ if (datumtype == '#') {
+ while (pat < patend && *pat != '\n')
+ pat++;
+ continue;
+ }
if (*pat == '!') {
char *natstr = "sSiIlL";
pat++;
}
else
- Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
+ DIE(aTHX_ "'!' allowed only after types %s", natstr);
}
+ star = 0;
if (pat >= patend)
len = 1;
else if (*pat == '*') {
len = strend - strbeg; /* long enough */
pat++;
+ star = 1;
}
else if (isDIGIT(*pat)) {
len = *pat++ - '0';
- while (isDIGIT(*pat))
+ while (isDIGIT(*pat)) {
len = (len * 10) + (*pat++ - '0');
+ if (len < 0)
+ DIE(aTHX_ "Repeat count in unpack overflows");
+ }
}
else
len = (datumtype != '@');
+ redo_switch:
switch(datumtype) {
default:
- Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
+ DIE(aTHX_ "Invalid type in unpack: '%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 unpack: '%c'", (int)datumtype);
+ if (commas++ == 0 && ckWARN(WARN_UNPACK))
+ Perl_warner(aTHX_ WARN_UNPACK,
+ "Invalid type in unpack: '%c'", (int)datumtype);
break;
case '%':
if (len == 1 && pat[-1] != '1')
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");
+ case '/':
+ if (start_sp_offset >= SP - PL_stack_base)
+ DIE(aTHX_ "/ must follow a numeric type");
datumtype = *pat++;
if (*pat == '*')
pat++; /* ignore '*' for compatibility with pack */
if (isDIGIT(*pat))
- DIE(aTHX_ "# cannot take a count" );
+ DIE(aTHX_ "/ cannot take a count" );
len = POPi;
- /* drop through */
+ star = 0;
+ goto redo_switch;
case 'A':
case 'Z':
case 'a':
break;
case 'B':
case 'b':
- if (pat[-1] == '*' || len > (strend - s) * 8)
+ if (star || len > (strend - s) * 8)
len = (strend - s) * 8;
if (checksum) {
if (!PL_bitcount) {
sv = NEWSV(35, len + 1);
SvCUR_set(sv, len);
SvPOK_on(sv);
- aptr = pat; /* borrow register */
- pat = SvPVX(sv);
+ str = SvPVX(sv);
if (datumtype == 'b') {
aint = len;
for (len = 0; len < aint; len++) {
bits >>= 1;
else
bits = *s++;
- *pat++ = '0' + (bits & 1);
+ *str++ = '0' + (bits & 1);
}
}
else {
bits <<= 1;
else
bits = *s++;
- *pat++ = '0' + ((bits & 128) != 0);
+ *str++ = '0' + ((bits & 128) != 0);
}
}
- *pat = '\0';
- pat = aptr; /* unborrow register */
+ *str = '\0';
XPUSHs(sv_2mortal(sv));
break;
case 'H':
case 'h':
- if (pat[-1] == '*' || len > (strend - s) * 2)
+ if (star || len > (strend - s) * 2)
len = (strend - s) * 2;
sv = NEWSV(35, len + 1);
SvCUR_set(sv, len);
SvPOK_on(sv);
- aptr = pat; /* borrow register */
- pat = SvPVX(sv);
+ str = SvPVX(sv);
if (datumtype == 'h') {
aint = len;
for (len = 0; len < aint; len++) {
bits >>= 4;
else
bits = *s++;
- *pat++ = PL_hexdigit[bits & 15];
+ *str++ = PL_hexdigit[bits & 15];
}
}
else {
bits <<= 4;
else
bits = *s++;
- *pat++ = PL_hexdigit[(bits >> 4) & 15];
+ *str++ = PL_hexdigit[(bits >> 4) & 15];
}
}
- *pat = '\0';
- pat = aptr; /* unborrow register */
+ *str = '\0';
XPUSHs(sv_2mortal(sv));
break;
case 'c':
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);
}
}
if ((s >= strend) && bytes)
- Perl_croak(aTHX_ "Unterminated compressed integer");
+ DIE(aTHX_ "Unterminated compressed integer");
}
break;
case 'P':
int i;
for (i = 0; i < sizeof(PL_uuemap); i += 1)
- PL_uudmap[PL_uuemap[i]] = i;
+ PL_uudmap[(U8)PL_uuemap[i]] = i;
/*
* Because ' ' and '`' map to the same value,
* we need to decode them both the same.
char hunk[4];
hunk[3] = '\0';
- len = PL_uudmap[*s++] & 077;
+ len = PL_uudmap[*(U8*)s++] & 077;
while (len > 0) {
if (s < strend && ISUUCHAR(*s))
- a = PL_uudmap[*s++] & 077;
+ a = PL_uudmap[*(U8*)s++] & 077;
else
a = 0;
if (s < strend && ISUUCHAR(*s))
- b = PL_uudmap[*s++] & 077;
+ b = PL_uudmap[*(U8*)s++] & 077;
else
b = 0;
if (s < strend && ISUUCHAR(*s))
- c = PL_uudmap[*s++] & 077;
+ c = PL_uudmap[*(U8*)s++] & 077;
else
c = 0;
if (s < strend && ISUUCHAR(*s))
- d = PL_uudmap[*s++] & 077;
+ d = PL_uudmap[*(U8*)s++] & 077;
else
d = 0;
hunk[0] = (a << 2) | (b >> 4);
checksum = 0;
}
}
- if (SP == oldsp && gimme == G_SCALAR)
+ if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
PUSHs(&PL_sv_undef);
RETURN;
}
register I32 items;
STRLEN fromlen;
register char *pat = SvPVx(*++MARK, fromlen);
+ char *patcopy;
register char *patend = pat + fromlen;
register I32 len;
I32 datumtype;
items = SP - MARK;
MARK++;
sv_setpvn(cat, "", 0);
+ patcopy = pat;
while (pat < patend) {
SV *lengthcode = Nullsv;
#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
#ifdef PERL_NATINT_PACK
natint = 0;
#endif
- if (isSPACE(datumtype))
+ if (isSPACE(datumtype)) {
+ patcopy++;
+ continue;
+ }
+ if (datumtype == 'U' && pat == patcopy+1)
+ SvUTF8_on(cat);
+ if (datumtype == '#') {
+ while (pat < patend && *pat != '\n')
+ pat++;
continue;
+ }
if (*pat == '!') {
char *natstr = "sSiIlL";
pat++;
}
else
- Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
+ DIE(aTHX_ "'!' allowed only after types %s", natstr);
}
if (*pat == '*') {
len = strchr("@Xxu", datumtype) ? 0 : items;
}
else if (isDIGIT(*pat)) {
len = *pat++ - '0';
- while (isDIGIT(*pat))
+ while (isDIGIT(*pat)) {
len = (len * 10) + (*pat++ - '0');
+ if (len < 0)
+ DIE(aTHX_ "Repeat count in pack overflows");
+ }
}
else
len = 1;
- if (*pat == '#') {
+ if (*pat == '/') {
++pat;
- if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
- DIE(aTHX_ "# must be followed by a*, A* or Z*");
+ 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)));
+ ? *MARK : &PL_sv_no)
+ + (*pat == 'Z' ? 1 : 0)));
}
switch(datumtype) {
default:
- Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
+ DIE(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,
+ if (commas++ == 0 && ckWARN(WARN_PACK))
+ Perl_warner(aTHX_ WARN_PACK,
"Invalid type in pack: '%c'", (int)datumtype);
break;
case '%':
case 'a':
fromstr = NEXTFROM;
aptr = SvPV(fromstr, fromlen);
- if (pat[-1] == '*')
+ if (pat[-1] == '*') {
len = fromlen;
- if (fromlen > len)
+ if (datumtype == 'Z')
+ ++len;
+ }
+ if (fromlen >= len) {
sv_catpvn(cat, aptr, len);
+ if (datumtype == 'Z')
+ *(SvEND(cat)-1) = '\0';
+ }
else {
sv_catpvn(cat, aptr, fromlen);
len -= fromlen;
case 'B':
case 'b':
{
- char *savepat = pat;
+ register char *str;
I32 saveitems;
fromstr = NEXTFROM;
saveitems = items;
- aptr = SvPV(fromstr, fromlen);
+ str = SvPV(fromstr, fromlen);
if (pat[-1] == '*')
len = fromlen;
- pat = aptr;
aint = SvCUR(cat);
SvCUR(cat) += (len+7)/8;
SvGROW(cat, SvCUR(cat) + 1);
items = 0;
if (datumtype == 'B') {
for (len = 0; len++ < aint;) {
- items |= *pat++ & 1;
+ items |= *str++ & 1;
if (len & 7)
items <<= 1;
else {
}
else {
for (len = 0; len++ < aint;) {
- if (*pat++ & 1)
+ if (*str++ & 1)
items |= 128;
if (len & 7)
items >>= 1;
items >>= 7 - (aint & 7);
*aptr++ = items & 0xff;
}
- pat = SvPVX(cat) + SvCUR(cat);
- while (aptr <= pat)
+ str = SvPVX(cat) + SvCUR(cat);
+ while (aptr <= str)
*aptr++ = '\0';
- pat = savepat;
items = saveitems;
}
break;
case 'H':
case 'h':
{
- char *savepat = pat;
+ register char *str;
I32 saveitems;
fromstr = NEXTFROM;
saveitems = items;
- aptr = SvPV(fromstr, fromlen);
+ str = SvPV(fromstr, fromlen);
if (pat[-1] == '*')
len = fromlen;
- pat = aptr;
aint = SvCUR(cat);
SvCUR(cat) += (len+1)/2;
SvGROW(cat, SvCUR(cat) + 1);
items = 0;
if (datumtype == 'H') {
for (len = 0; len++ < aint;) {
- if (isALPHA(*pat))
- items |= ((*pat++ & 15) + 9) & 15;
+ if (isALPHA(*str))
+ items |= ((*str++ & 15) + 9) & 15;
else
- items |= *pat++ & 15;
+ items |= *str++ & 15;
if (len & 1)
items <<= 4;
else {
}
else {
for (len = 0; len++ < aint;) {
- if (isALPHA(*pat))
- items |= (((*pat++ & 15) + 9) & 15) << 4;
+ if (isALPHA(*str))
+ items |= (((*str++ & 15) + 9) & 15) << 4;
else
- items |= (*pat++ & 15) << 4;
+ items |= (*str++ & 15) << 4;
if (len & 1)
items >>= 4;
else {
}
if (aint & 1)
*aptr++ = items & 0xff;
- pat = SvPVX(cat) + SvCUR(cat);
- while (aptr <= pat)
+ str = SvPVX(cat) + SvCUR(cat);
+ while (aptr <= str)
*aptr++ = '\0';
- pat = savepat;
items = saveitems;
}
break;
while (len-- > 0) {
fromstr = NEXTFROM;
auint = SvUV(fromstr);
- SvGROW(cat, SvCUR(cat) + 10);
+ SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
- SvPVX(cat));
}
case 's':
#if SHORTSIZE != SIZE16
if (natint) {
+ short ashort;
+
while (len-- > 0) {
fromstr = NEXTFROM;
ashort = SvIV(fromstr);
adouble = Perl_floor(SvNV(fromstr));
if (adouble < 0)
- Perl_croak(aTHX_ "Cannot compress negative numbers");
+ DIE(aTHX_ "Cannot compress negative numbers");
if (
-#ifdef BW_BITS
- adouble <= BW_MASK
+#if UVSIZE > 4 && UVSIZE >= NVSIZE
+ adouble <= 0xffffffff
#else
-#ifdef CXUX_BROKEN_CONSTANT_CONVERT
+# ifdef CXUX_BROKEN_CONSTANT_CONVERT
adouble <= UV_MAX_cxux
-#else
+# else
adouble <= UV_MAX
-#endif
+# endif
#endif
)
{
/* Copy string and check for compliance */
from = SvPV(fromstr, len);
if ((norm = is_an_int(from, len)) == NULL)
- Perl_croak(aTHX_ "can compress only unsigned integer");
+ DIE(aTHX_ "can compress only unsigned integer");
New('w', result, len, char);
in = result + len;
double next = floor(adouble / 128);
*--in = (unsigned char)(adouble - (next * 128)) | 0x80;
if (--in < buf) /* this cannot happen ;-) */
- Perl_croak(aTHX_ "Cannot compress integer");
+ DIE(aTHX_ "Cannot compress integer");
adouble = next;
} while (adouble > 0);
buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
}
else
- Perl_croak(aTHX_ "Cannot compress non integer");
+ DIE(aTHX_ "Cannot compress non integer");
}
break;
case 'i':
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;
sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
}
break;
-#endif /* HAS_QUAD */
+#endif
case 'P':
len = 1; /* assume SV is correct length */
/* FALL THROUGH */
* of pack() (and all copies of the result) are
* gone.
*/
- if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
- Perl_warner(aTHX_ WARN_UNSAFE,
+ if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
+ || (SvPADTMP(fromstr)
+ && !SvREADONLY(fromstr))))
+ {
+ Perl_warner(aTHX_ WARN_PACK,
"Attempt to pack pointer to temporary value");
+ }
if (SvPOK(fromstr) || SvNIOK(fromstr))
aptr = SvPV(fromstr,n_a);
else
TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
(pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
- if (pm->op_pmreplroot)
+ if (pm->op_pmreplroot) {
+#ifdef USE_ITHREADS
+ ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
+#else
ary = GvAVn((GV*)pm->op_pmreplroot);
+#endif
+ }
else if (gimme != G_ARRAY)
#ifdef USE_THREADS
ary = (AV*)PL_curpad[0];
av_extend(ary,0);
av_clear(ary);
SPAGAIN;
- if (mg = SvTIED_mg((SV*)ary, 'P')) {
+ if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)ary, mg));
}
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;
}
}
- else if (rx->prelen == 1 && *rx->precomp == '^') {
- if (!(pm->op_pmflags & PMf_MULTILINE)
- && !(pm->op_pmregexp->reganch & ROPT_WARNED)) {
- if (ckWARN(WARN_DEPRECATED))
- Perl_warner(aTHX_ WARN_DEPRECATED,
- "split /^/ better written as split /^/m");
- pm->op_pmregexp->reganch |= ROPT_WARNED;
- }
+ else if (strEQ("^", rx->precomp)) {
while (--limit) {
/*SUPPRESS 530*/
for (m = s; m < strend && *m != '\n'; m++) ;
Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
MgOWNER(mg) = 0;
COND_SIGNAL(MgOWNERCONDP(mg));
- DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
- (unsigned long)thr, (unsigned long)svv);)
+ DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
+ PTR2UV(thr), PTR2UV(svv));)
MUTEX_UNLOCK(MgMUTEXP(mg));
}
#endif /* USE_THREADS */
dTOPss;
SV *retsv = sv;
#ifdef USE_THREADS
- MAGIC *mg;
-
- if (SvROK(sv))
- sv = SvRV(sv);
-
- mg = condpair_magic(sv);
- MUTEX_LOCK(MgMUTEXP(mg));
- if (MgOWNER(mg) == thr)
- MUTEX_UNLOCK(MgMUTEXP(mg));
- else {
- while (MgOWNER(mg))
- COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
- MgOWNER(mg) = thr;
- DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
- (unsigned long)thr, (unsigned long)sv);)
- MUTEX_UNLOCK(MgMUTEXP(mg));
- SAVEDESTRUCTOR(Perl_unlock_condpair, sv);
- }
+ sv_lock(sv);
#endif /* USE_THREADS */
if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
|| SvTYPE(retsv) == SVt_PVCV) {
PP(pp_threadsv)
{
- djSP;
#ifdef USE_THREADS
+ djSP;
EXTEND(SP, 1);
if (PL_op->op_private & OPpLVAL_INTRO)
PUSHs(*save_threadsv(PL_op->op_targ));
https://perl5.git.perl.org / perl5.git / blobdiff