/* 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.
* 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)
+#if LONGSIZE > 4 && defined(_CRAY)
# define BW_BITS 32
# define BW_MASK ((1 << BW_BITS) - 1)
# define BW_SIGN (1 << (BW_BITS - 1))
# 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)
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;
SV *ssv = POPs;
STRLEN len;
char *ptr = SvPV(ssv,len);
- if (ckWARN(WARN_UNSAFE) && len == 0)
- Perl_warner(aTHX_ WARN_UNSAFE,
+ if (ckWARN(WARN_MISC) && len == 0)
+ Perl_warner(aTHX_ WARN_MISC,
"Explicit blessing to '' (assuming package main)");
stash = gv_stashpvn(ptr, len, TRUE);
}
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:
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);
}
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);
+ SvUTF8_on(TARG);
+ }
tmps += pos;
sv_setpvn(TARG, tmps, rem);
- if (lvalue) { /* it's an lvalue! */
+ 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;
LvTARGOFF(TARG) = pos;
LvTARGLEN(TARG) = rem;
}
- else if (repl)
- sv_insert(sv, pos, rem, repl, repl_len);
}
SPAGAIN;
PUSHs(TARG); /* avoid SvSETMAGIC here */
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) {
+ 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;
}
tmps = SvPVX(TARG);
*tmps++ = value;
*tmps = '\0';
+ SvUTF8_off(TARG); /* decontaminate */
(void)SvPOK_only(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 *tend;
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) || 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 *tend;
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) || 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) || 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) || 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--) {
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;
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) {
default:
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,
+ if (commas++ == 0 && ckWARN(WARN_UNPACK))
+ Perl_warner(aTHX_ WARN_UNPACK,
"Invalid type in unpack: '%c'", (int)datumtype);
break;
case '%':
default:
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 '%':
* of pack() (and all copies of the result) are
* gone.
*/
- if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr)
+ if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
|| (SvPADTMP(fromstr)
&& !SvREADONLY(fromstr))))
{
- Perl_warner(aTHX_ WARN_UNSAFE,
+ Perl_warner(aTHX_ WARN_PACK,
"Attempt to pack pointer to temporary value");
}
if (SvPOK(fromstr) || SvNIOK(fromstr))