/* variations on pp_null */
-#ifdef I_UNISTD
-#include <unistd.h>
-#endif
-
/* XXX I can't imagine anyone who doesn't have this actually _needs_
it, since pid_t is an integral type.
--AD 2/20/1998
PP(pp_rv2gv)
{
- djSP; dTOPss;
+ djSP; dTOPss;
if (SvROK(sv)) {
wasref:
goto wasref;
}
if (!SvOK(sv) && sv != &PL_sv_undef) {
- /* If this is a 'my' scalar and flag is set then vivify
+ /* If this is a 'my' scalar and flag is set then vivify
* NI-S 1999/05/07
- */
+ */
if (PL_op->op_private & OPpDEREF) {
char *name;
GV *gv;
name = CopSTASHPV(PL_curcop);
gv = newGVgen(name);
}
- sv_upgrade(sv, SVt_RV);
+ if (SvTYPE(sv) < SVt_RV)
+ sv_upgrade(sv, SVt_RV);
SvRV(sv) = (SV*)gv;
SvROK_on(sv);
SvSETMAGIC(sv);
char *s = SvPVX(TOPs);
if (strnEQ(s, "CORE::", 6)) {
int code;
-
+
code = keyword(s + 6, SvCUR(TOPs) - 6);
if (code < 0) { /* Overridable. */
#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
seen_question = 1;
str[n++] = ';';
}
- else if (n && str[0] == ';' && seen_question)
+ else if (n && str[0] == ';' && seen_question)
goto set; /* XXXX system, exec */
- if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
+ if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
&& (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
str[n++] = '\\';
}
else {
SV *ssv = POPs;
STRLEN len;
- char *ptr = SvPV(ssv,len);
+ 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,
+ Perl_warner(aTHX_ WARN_MISC,
"Explicit blessing to '' (assuming package main)");
stash = gv_stashpvn(ptr, len, TRUE);
}
char *elem;
djSP;
STRLEN n_a;
-
+
sv = POPs;
elem = SvPV(sv, n_a);
gv = (GV*)POPs;
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"))
{
djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
{
- register I32 count = POPi;
+ register IV count = POPi;
if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
dMARK;
I32 items = SP - MARK;
}
}
else {
- register char *tmps;
- register long *tmpl;
+ register U8 *tmps;
register I32 anum;
STRLEN len;
SvSetSV(TARG, sv);
- tmps = SvPV_force(TARG, len);
+ tmps = (U8*)SvPV_force(TARG, len);
anum = len;
+ if (SvUTF8(TARG)) {
+ /* Calculate exact length, let's not estimate. */
+ STRLEN targlen = 0;
+ U8 *result;
+ U8 *send;
+ STRLEN l;
+ UV nchar = 0;
+ UV nwide = 0;
+
+ send = tmps + len;
+ while (tmps < send) {
+ UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
+ tmps += UTF8SKIP(tmps);
+ targlen += UNISKIP(~c);
+ nchar++;
+ if (c > 0xff)
+ nwide++;
+ }
+
+ /* Now rewind strings and write them. */
+ tmps -= len;
+
+ if (nwide) {
+ Newz(0, result, targlen + 1, U8);
+ while (tmps < send) {
+ UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
+ tmps += UTF8SKIP(tmps);
+ result = uv_to_utf8(result, ~c);
+ }
+ *result = '\0';
+ result -= targlen;
+ sv_setpvn(TARG, (char*)result, targlen);
+ SvUTF8_on(TARG);
+ }
+ else {
+ Newz(0, result, nchar + 1, U8);
+ while (tmps < send) {
+ U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
+ tmps += UTF8SKIP(tmps);
+ *result++ = ~c;
+ }
+ *result = '\0';
+ result -= nchar;
+ sv_setpvn(TARG, (char*)result, nchar);
+ }
+ Safefree(result);
+ SETs(TARG);
+ RETURN;
+ }
#ifdef LIBERAL
- for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
- *tmps = ~*tmps;
- tmpl = (long*)tmps;
- for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
- *tmpl = ~*tmpl;
- tmps = (char*)tmpl;
+ {
+ register long *tmpl;
+ for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
+ *tmps = ~*tmps;
+ tmpl = (long*)tmps;
+ for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
+ *tmpl = ~*tmpl;
+ tmps = (U8*)tmpl;
+ }
#endif
for ( ; anum > 0; anum--, tmps++)
*tmps = ~*tmps;
PP(pp_i_modulo)
{
- djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
{
dPOPTOPiirl;
if (!right)
{
djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
{
- dPOPTOPiirl;
+ dPOPTOPiirl_ul;
SETi( left + right );
RETURN;
}
{
djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
{
- dPOPTOPiirl;
+ dPOPTOPiirl_ul;
SETi( left - right );
RETURN;
}
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);
SETi(iv);
}
else {
- if (value >= 0.0)
- (void)Perl_modf(value, &value);
+ if (value >= 0.0) {
+#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
+ (void)Perl_modf(value, &value);
+#else
+ double tmp = (double)value;
+ (void)Perl_modf(tmp, &tmp);
+ value = (NV)tmp;
+#endif
+ }
else {
- (void)Perl_modf(-value, &value);
- value = -value;
+#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
+ (void)Perl_modf(-value, &value);
+ value = -value;
+#else
+ double tmp = (double)value;
+ (void)Perl_modf(-tmp, &tmp);
+ value = -(NV)tmp;
+#endif
}
iv = I_V(value);
if (iv == value)
{
djSP; dTARGET;
char *tmps;
- I32 argtype;
+ STRLEN argtype;
STRLEN n_a;
tmps = POPpx;
{
djSP; dTARGET;
NV value;
- I32 argtype;
+ STRLEN argtype;
char *tmps;
STRLEN n_a;
PP(pp_vec)
{
djSP; dTARGET;
- register I32 size = POPi;
- register I32 offset = POPi;
+ register IV size = POPi;
+ register IV offset = POPi;
register SV *src = POPs;
I32 lvalue = PL_op->op_flags & OPf_MOD;
{
djSP; dTARGET;
UV value;
- STRLEN n_a;
SV *tmpsv = POPs;
- U8 *tmps = (U8*)SvPVx(tmpsv,n_a);
- I32 retlen;
+ STRLEN len;
+ U8 *tmps = (U8*)SvPVx(tmpsv, len);
+ STRLEN retlen;
if ((*tmps & 0x80) && DO_UTF8(tmpsv))
- value = utf8_to_uv(tmps, &retlen);
+ value = utf8_to_uv(tmps, len, &retlen, 0);
else
value = (UV)(*tmps & 255);
XPUSHu(value);
{
djSP; dTARGET;
char *tmps;
- U32 value = POPu;
+ UV value = POPu;
(void)SvUPGRADE(TARG,SVt_PV);
- if (value > 255 && !IN_BYTE) {
+ 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);
sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
#endif
#else
- DIE(aTHX_
+ DIE(aTHX_
"The crypt() function is unimplemented due to excessive paranoia.");
#endif
SETs(TARG);
STRLEN slen;
if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
- I32 ulen;
+ STRLEN ulen;
U8 tmpbuf[UTF8_MAXLEN];
U8 *tend;
- UV uv = utf8_to_uv(s, &ulen);
+ UV uv = utf8_to_uv(s, slen, &ulen, 0);
if (PL_op->op_private & OPpLOCALE) {
TAINT;
STRLEN slen;
if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
- I32 ulen;
+ STRLEN ulen;
U8 tmpbuf[UTF8_MAXLEN];
U8 *tend;
- UV uv = utf8_to_uv(s, &ulen);
+ UV uv = utf8_to_uv(s, slen, &ulen, 0);
if (PL_op->op_private & OPpLOCALE) {
TAINT;
if (DO_UTF8(sv)) {
dTARGET;
- I32 ulen;
+ STRLEN ulen;
register U8 *d;
U8 *send;
TAINT;
SvTAINTED_on(TARG);
while (s < send) {
- d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
+ d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
s += ulen;
}
}
if (DO_UTF8(sv)) {
dTARGET;
- I32 ulen;
+ STRLEN ulen;
register U8 *d;
U8 *send;
TAINT;
SvTAINTED_on(TARG);
while (s < send) {
- d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
+ d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
s += ulen;
}
}
ix = SvIVx(*lelem);
if (ix < 0)
ix += max;
- else
+ else
ix -= arybase;
if (ix < 0 || ix >= max)
*lelem = &PL_sv_undef;
register char *str;
/* These must not be in registers: */
- I16 ashort;
+ short ashort;
int aint;
- I32 along;
+ long along;
#ifdef HAS_QUAD
Quad_t aquad;
#endif
len = strend - s;
if (checksum) {
while (len-- > 0 && s < strend) {
- auint = utf8_to_uv((U8*)s, &along);
+ STRLEN alen;
+ auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
+ along = alen;
s += along;
if (checksum > 32)
cdouble += (NV)auint;
EXTEND(SP, len);
EXTEND_MORTAL(len);
while (len-- > 0 && s < strend) {
- auint = utf8_to_uv((U8*)s, &along);
+ STRLEN alen;
+ auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
+ along = alen;
s += along;
sv = NEWSV(37, 0);
sv_setuv(sv, (UV)auint);
if (checksum) {
#if LONGSIZE != SIZE32
if (natint) {
- long along;
while (len-- > 0) {
COPYNN(s, &along, sizeof(long));
s += sizeof(long);
#endif
{
while (len-- > 0) {
+#if LONGSIZE > SIZE32 && INTSIZE == SIZE32
+ I32 along;
+#endif
COPY32(s, &along);
#if LONGSIZE > SIZE32
if (along > 2147483647)
EXTEND_MORTAL(len);
#if LONGSIZE != SIZE32
if (natint) {
- long along;
while (len-- > 0) {
COPYNN(s, &along, sizeof(long));
s += sizeof(long);
#endif
{
while (len-- > 0) {
+#if LONGSIZE > SIZE32 && INTSIZE == SIZE32
+ I32 along;
+#endif
COPY32(s, &along);
#if LONGSIZE > SIZE32
if (along > 2147483647)
char *t;
STRLEN n_a;
- sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
+ sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
while (s < strend) {
sv = mul128(sv, *s & 0x7f);
if (!(*s++ & 0x80)) {
*/
if (PL_uudmap['M'] == 0) {
int i;
-
+
for (i = 0; i < sizeof(PL_uuemap); i += 1)
PL_uudmap[(U8)PL_uuemap[i]] = i;
/*
patcopy++;
continue;
}
- if (datumtype == 'U' && pat==patcopy+1)
+ if (datumtype == 'U' && pat == patcopy+1)
SvUTF8_on(cat);
if (datumtype == '#') {
while (pat < patend && *pat != '\n')
do {
double next = floor(adouble / 128);
*--in = (unsigned char)(adouble - (next * 128)) | 0x80;
- if (--in < buf) /* this cannot happen ;-) */
+ if (in <= buf) /* this cannot happen ;-) */
DIE(aTHX_ "Cannot compress integer");
+ in--;
adouble = next;
} while (adouble > 0);
buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
{
djSP; dTARG;
AV *ary;
- register I32 limit = POPi; /* note, negative is forever */
+ register IV limit = POPi; /* note, negative is forever */
SV *sv = POPs;
+ bool doutf8 = DO_UTF8(sv);
STRLEN len;
register char *s = SvPV(sv, len);
char *strend = s + len;
sv_setpvn(dstr, s, m-s);
if (make_mortal)
sv_2mortal(dstr);
+ if (doutf8)
+ (void)SvUTF8_on(dstr);
XPUSHs(dstr);
s = m + 1;
sv_setpvn(dstr, s, m-s);
if (make_mortal)
sv_2mortal(dstr);
+ if (doutf8)
+ (void)SvUTF8_on(dstr);
XPUSHs(dstr);
s = m;
}
&& !(rx->reganch & ROPT_ANCH)) {
int tail = (rx->reganch & RE_INTUIT_TAIL);
SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
- char c;
len = rx->minlen;
if (len == 1 && !tail) {
- c = *SvPV(csv,len);
+ STRLEN n_a;
+ char c = *SvPV(csv, n_a);
while (--limit) {
/*SUPPRESS 530*/
for (m = s; m < strend && *m != c; m++) ;
sv_setpvn(dstr, s, m-s);
if (make_mortal)
sv_2mortal(dstr);
+ if (doutf8)
+ (void)SvUTF8_on(dstr);
XPUSHs(dstr);
- s = m + 1;
+ /* The rx->minlen is in characters but we want to step
+ * s ahead by bytes. */
+ s = m + (doutf8 ? SvCUR(csv) : len);
}
}
else {
sv_setpvn(dstr, s, m-s);
if (make_mortal)
sv_2mortal(dstr);
+ if (doutf8)
+ (void)SvUTF8_on(dstr);
XPUSHs(dstr);
- s = m + len; /* Fake \n at the end */
+ /* The rx->minlen is in characters but we want to step
+ * s ahead by bytes. */
+ s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
}
}
}
else {
maxiters += (strend - s) * rx->nparens;
while (s < strend && --limit
-/* && (!rx->check_substr
+/* && (!rx->check_substr
|| ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
0, NULL))))
*/ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
sv_setpvn(dstr, s, m-s);
if (make_mortal)
sv_2mortal(dstr);
+ if (doutf8)
+ (void)SvUTF8_on(dstr);
XPUSHs(dstr);
if (rx->nparens) {
for (i = 1; i <= rx->nparens; i++) {
dstr = NEWSV(33, 0);
if (make_mortal)
sv_2mortal(dstr);
+ if (doutf8)
+ (void)SvUTF8_on(dstr);
XPUSHs(dstr);
}
}
/* keep field after final delim? */
if (s < strend || (iters && origlimit)) {
- dstr = NEWSV(34, strend-s);
- sv_setpvn(dstr, s, strend-s);
+ STRLEN l = strend - s;
+ dstr = NEWSV(34, l);
+ sv_setpvn(dstr, s, l);
if (make_mortal)
sv_2mortal(dstr);
+ if (doutf8)
+ (void)SvUTF8_on(dstr);
XPUSHs(dstr);
iters++;
}