/* pp.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
*/
+/* This file contains general pp ("push/pop") functions that execute the
+ * opcodes that make up a perl program. A typical pp function expects to
+ * find its arguments on the stack, and usually pushes its results onto
+ * the stack, hence the 'pp' terminology. Each OP structure contains
+ * a pointer to the relevant pp_foo() function.
+ */
+
#include "EXTERN.h"
#define PERL_IN_PP_C
#include "perl.h"
}
else {
if (SvTYPE(sv) != SVt_PVGV) {
- char *sym;
- STRLEN len;
-
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
/* If this is a 'my' scalar and flag is set then vivify
* NI-S 1999/05/07
*/
+ if (SvREADONLY(sv))
+ Perl_croak(aTHX_ PL_no_modify);
if (PL_op->op_private & OPpDEREF) {
- char *name;
+ const char *name;
GV *gv;
if (cUNOP->op_targ) {
STRLEN len;
if (SvTYPE(sv) < SVt_RV)
sv_upgrade(sv, SVt_RV);
if (SvPVX(sv)) {
- (void)SvOOK_off(sv); /* backoff */
+ SvOOK_off(sv); /* backoff */
if (SvLEN(sv))
Safefree(SvPVX(sv));
SvLEN(sv)=SvCUR(sv)=0;
report_uninit(sv);
RETSETUNDEF;
}
- 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
- && (!is_gv_magical(sym,len,0)
- || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
- {
+ SV * temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV);
+ if (!temp
+ && (!is_gv_magical_sv(sv,0)
+ || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) {
RETSETUNDEF;
}
+ sv = temp;
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref, sym, "a symbol");
- sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
+ DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
+ sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV);
}
}
}
}
}
else {
- char *sym;
- STRLEN len;
gv = (GV*)sv;
if (SvTYPE(gv) != SVt_PVGV) {
report_uninit(sv);
RETSETUNDEF;
}
- 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);
+ gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV);
if (!gv
- && (!is_gv_magical(sym,len,0)
- || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
+ && (!is_gv_magical_sv(sv, 0)
+ || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV))))
{
RETSETUNDEF;
}
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
- gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
+ DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
+ gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV);
}
}
sv = GvSV(gv);
{
dSP; dTARGET;
SV *sv;
- char *pv;
+ const char *pv;
sv = POPs;
else {
SV *ssv = POPs;
STRLEN len;
- char *ptr;
+ const char *ptr;
if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
Perl_croak(aTHX_ "Attempt to bless into a reference");
GV *gv;
SV *sv;
SV *tmpRef;
- char *elem;
+ const char *elem;
dSP;
STRLEN n_a;
gv = (GV*)POPs;
tmpRef = Nullsv;
sv = Nullsv;
- switch (elem ? *elem : '\0')
- {
- case 'A':
- if (strEQ(elem, "ARRAY"))
- tmpRef = (SV*)GvAV(gv);
- break;
- case 'C':
- if (strEQ(elem, "CODE"))
- tmpRef = (SV*)GvCVu(gv);
- break;
- case 'F':
- if (strEQ(elem, "FILEHANDLE")) {
- /* finally deprecated in 5.8.0 */
- deprecate("*glob{FILEHANDLE}");
- tmpRef = (SV*)GvIOp(gv);
+ if (elem) {
+ /* elem will always be NUL terminated. */
+ const char *elem2 = elem + 1;
+ switch (*elem) {
+ case 'A':
+ if (strEQ(elem2, "RRAY"))
+ tmpRef = (SV*)GvAV(gv);
+ break;
+ case 'C':
+ if (strEQ(elem2, "ODE"))
+ tmpRef = (SV*)GvCVu(gv);
+ break;
+ case 'F':
+ if (strEQ(elem2, "ILEHANDLE")) {
+ /* finally deprecated in 5.8.0 */
+ deprecate("*glob{FILEHANDLE}");
+ tmpRef = (SV*)GvIOp(gv);
+ }
+ else
+ if (strEQ(elem2, "ORMAT"))
+ tmpRef = (SV*)GvFORM(gv);
+ break;
+ case 'G':
+ if (strEQ(elem2, "LOB"))
+ tmpRef = (SV*)gv;
+ break;
+ case 'H':
+ if (strEQ(elem2, "ASH"))
+ tmpRef = (SV*)GvHV(gv);
+ break;
+ case 'I':
+ if (*elem2 == 'O' && !elem[2])
+ tmpRef = (SV*)GvIOp(gv);
+ break;
+ case 'N':
+ if (strEQ(elem2, "AME"))
+ sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
+ break;
+ case 'P':
+ if (strEQ(elem2, "ACKAGE")) {
+ const char *name = HvNAME(GvSTASH(gv));
+ sv = newSVpv(name ? name : "__ANON__", 0);
+ }
+ break;
+ case 'S':
+ if (strEQ(elem2, "CALAR"))
+ tmpRef = GvSV(gv);
+ break;
}
- else
- if (strEQ(elem, "FORMAT"))
- tmpRef = (SV*)GvFORM(gv);
- break;
- case 'G':
- if (strEQ(elem, "GLOB"))
- tmpRef = (SV*)gv;
- break;
- case 'H':
- if (strEQ(elem, "HASH"))
- tmpRef = (SV*)GvHV(gv);
- break;
- case 'I':
- if (strEQ(elem, "IO"))
- tmpRef = (SV*)GvIOp(gv);
- break;
- case 'N':
- if (strEQ(elem, "NAME"))
- sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
- break;
- case 'P':
- if (strEQ(elem, "PACKAGE")) {
- if (HvNAME(GvSTASH(gv)))
- sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
- else
- sv = newSVpv("__ANON__",0);
- }
- break;
- case 'S':
- if (strEQ(elem, "SCALAR"))
- tmpRef = GvSV(gv);
- break;
}
if (tmpRef)
sv = newRV(tmpRef);
break;
default:
if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
- (void)SvOOK_off(sv);
+ SvOOK_off(sv);
Safefree(SvPVX(sv));
SvPV_set(sv, Nullch);
SvLEN_set(sv, 0);
}
- (void)SvOK_off(sv);
+ SvOK_off(sv);
SvSETMAGIC(sv);
}
I32 pos;
I32 rem;
I32 fail;
- I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
- char *tmps;
- I32 arybase = PL_curcop->cop_arybase;
+ const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
+ const char *tmps;
+ const I32 arybase = PL_curcop->cop_arybase;
SV *repl_sv = NULL;
- char *repl = 0;
+ const char *repl = 0;
STRLEN repl_len;
int num_args = PL_op->op_private & 7;
bool repl_need_utf8_upgrade = FALSE;
sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
}
else
- (void)SvOK_off(TARG);
+ SvOK_off(TARG);
LvTYPE(TARG) = 'x';
if (LvTARG(TARG) != sv) {
dSP; dTARGET;
SV *big;
SV *little;
+ SV *temp = Nullsv;
I32 offset;
I32 retval;
char *tmps;
char *tmps2;
STRLEN biglen;
I32 arybase = PL_curcop->cop_arybase;
+ int big_utf8;
+ int little_utf8;
if (MAXARG < 3)
offset = 0;
offset = POPi - arybase;
little = POPs;
big = POPs;
- tmps = SvPV(big, biglen);
- if (offset > 0 && DO_UTF8(big))
+ big_utf8 = DO_UTF8(big);
+ little_utf8 = DO_UTF8(little);
+ if (big_utf8 ^ little_utf8) {
+ /* One needs to be upgraded. */
+ SV *bytes = little_utf8 ? big : little;
+ STRLEN len;
+ char *p = SvPV(bytes, len);
+
+ temp = newSVpvn(p, len);
+
+ if (PL_encoding) {
+ sv_recode_to_utf8(temp, PL_encoding);
+ } else {
+ sv_utf8_upgrade(temp);
+ }
+ if (little_utf8) {
+ big = temp;
+ big_utf8 = TRUE;
+ } else {
+ little = temp;
+ }
+ }
+ if (big_utf8 && offset > 0)
sv_pos_u2b(big, &offset, 0);
+ tmps = SvPV(big, biglen);
if (offset < 0)
offset = 0;
else if (offset > (I32)biglen)
retval = -1;
else
retval = tmps2 - tmps;
- if (retval > 0 && DO_UTF8(big))
+ if (retval > 0 && big_utf8)
sv_pos_b2u(big, &retval);
+ if (temp)
+ SvREFCNT_dec(temp);
PUSHi(retval + arybase);
RETURN;
}
dSP; dTARGET;
SV *big;
SV *little;
+ SV *temp = Nullsv;
STRLEN blen;
STRLEN llen;
I32 offset;
char *tmps;
char *tmps2;
I32 arybase = PL_curcop->cop_arybase;
+ int big_utf8;
+ int little_utf8;
if (MAXARG >= 3)
offset = POPi;
little = POPs;
big = POPs;
+ big_utf8 = DO_UTF8(big);
+ little_utf8 = DO_UTF8(little);
+ if (big_utf8 ^ little_utf8) {
+ /* One needs to be upgraded. */
+ SV *bytes = little_utf8 ? big : little;
+ STRLEN len;
+ char *p = SvPV(bytes, len);
+
+ temp = newSVpvn(p, len);
+
+ if (PL_encoding) {
+ sv_recode_to_utf8(temp, PL_encoding);
+ } else {
+ sv_utf8_upgrade(temp);
+ }
+ if (little_utf8) {
+ big = temp;
+ big_utf8 = TRUE;
+ } else {
+ little = temp;
+ }
+ }
tmps2 = SvPV(little, llen);
tmps = SvPV(big, blen);
+
if (MAXARG < 3)
offset = blen;
else {
- if (offset > 0 && DO_UTF8(big))
+ if (offset > 0 && big_utf8)
sv_pos_u2b(big, &offset, 0);
offset = offset - arybase + llen;
}
retval = -1;
else
retval = tmps2 - tmps;
- if (retval > 0 && DO_UTF8(big))
+ if (retval > 0 && big_utf8)
sv_pos_b2u(big, &retval);
+ if (temp)
+ SvREFCNT_dec(temp);
PUSHi(retval + arybase);
RETURN;
}
}
XPUSHu(DO_UTF8(argsv) ?
- utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
+ utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
(*s & 0xff));
RETURN;
if (DO_UTF8(sv) &&
(s = (U8*)SvPV_nomg(sv, slen)) && slen &&
UTF8_IS_START(*s)) {
- U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
+ U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
STRLEN ulen;
STRLEN tculen;
(s = (U8*)SvPV_nomg(sv, slen)) && slen &&
UTF8_IS_START(*s)) {
STRLEN ulen;
- U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
+ U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
U8 *tend;
UV uv;
STRLEN ulen;
register U8 *d;
U8 *send;
- U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
+ U8 tmpbuf[UTF8_MAXBYTES+1];
s = (U8*)SvPV_nomg(sv,len);
if (!len) {
SETs(TARG);
}
else {
- STRLEN nchar = utf8_length(s, s + len);
+ STRLEN min = len + 1;
(void)SvUPGRADE(TARG, SVt_PV);
- SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
+ SvGROW(TARG, min);
(void)SvPOK_only(TARG);
d = (U8*)SvPVX(TARG);
send = s + len;
while (s < send) {
+ STRLEN u = UTF8SKIP(s);
+
toUPPER_utf8(s, tmpbuf, &ulen);
+ if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
+ /* If the eventually required minimum size outgrows
+ * the available space, we need to grow. */
+ UV o = d - (U8*)SvPVX(TARG);
+
+ /* If someone uppercases one million U+03B0s we
+ * SvGROW() one million times. Or we could try
+ * guessing how much to allocate without allocating
+ * too much. Such is life. */
+ SvGROW(TARG, min);
+ d = (U8*)SvPVX(TARG) + o;
+ }
Copy(tmpbuf, d, ulen, U8);
d += ulen;
- s += UTF8SKIP(s);
+ s += u;
}
*d = '\0';
SvUTF8_on(TARG);
STRLEN ulen;
register U8 *d;
U8 *send;
- U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
+ U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
s = (U8*)SvPV_nomg(sv,len);
if (!len) {
SETs(TARG);
}
else {
- STRLEN nchar = utf8_length(s, s + len);
+ STRLEN min = len + 1;
(void)SvUPGRADE(TARG, SVt_PV);
- SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
+ SvGROW(TARG, min);
(void)SvPOK_only(TARG);
d = (U8*)SvPVX(TARG);
send = s + len;
while (s < send) {
+ STRLEN u = UTF8SKIP(s);
UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
-#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
+
+#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
/*
* Now if the sigma is NOT followed by
* then it should be mapped to 0x03C2,
* (GREEK SMALL LETTER FINAL SIGMA),
* instead of staying 0x03A3.
- * See lib/unicore/SpecCase.txt.
+ * "should be": in other words,
+ * this is not implemented yet.
+ * See lib/unicore/SpecialCasing.txt.
*/
}
+ if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
+ /* If the eventually required minimum size outgrows
+ * the available space, we need to grow. */
+ UV o = d - (U8*)SvPVX(TARG);
+
+ /* If someone lowercases one million U+0130s we
+ * SvGROW() one million times. Or we could try
+ * guessing how much to allocate without allocating.
+ * too much. Such is life. */
+ SvGROW(TARG, min);
+ d = (U8*)SvPVX(TARG) + o;
+ }
Copy(tmpbuf, d, ulen, U8);
d += ulen;
- s += UTF8SKIP(s);
+ s += u;
}
*d = '\0';
SvUTF8_on(TARG);
/* make new elements SVs now: avoid problems if they're from the array */
for (dst = MARK, i = newlen; i; i--) {
SV *h = *dst;
- *dst = NEWSV(46, 0);
- sv_setsv(*dst++, h);
+ *dst++ = newSVsv(h);
}
if (diff < 0) { /* shrinking the area */
else {
av_unshift(ary, SP - MARK);
while (MARK < SP) {
- sv = NEWSV(27, 0);
- sv_setsv(sv, *++MARK);
+ sv = newSVsv(*++MARK);
(void)av_store(ary, i++, sv);
}
}
I32 gimme = GIMME_V;
I32 oldsave = PL_savestack_ix;
I32 make_mortal = 1;
+ bool multiline = 0;
MAGIC *mg = (MAGIC *) NULL;
#ifdef DEBUGGING
s++;
}
}
- if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
- SAVEINT(PL_multiline);
- PL_multiline = pm->op_pmflags & PMf_MULTILINE;
+ if (pm->op_pmflags & PMf_MULTILINE) {
+ multiline = 1;
}
if (!limit)
if (m >= strend)
break;
- dstr = NEWSV(30, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
++s;
}
}
- else if (strEQ("^", rx->precomp)) {
+ else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
while (--limit) {
/*SUPPRESS 530*/
for (m = s; m < strend && *m != '\n'; m++) ;
m++;
if (m >= strend)
break;
- dstr = NEWSV(30, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
for (m = s; m < strend && *m != c; m++) ;
if (m >= strend)
break;
- dstr = NEWSV(30, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
#ifndef lint
while (s < strend && --limit &&
(m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
- csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
+ csv, multiline ? FBMrf_MULTILINE : 0)) )
#endif
{
- dstr = NEWSV(31, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
strend = s + (strend - m);
}
m = rx->startp[0] + orig;
- dstr = NEWSV(32, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
parens that didn't match -- they should be set to
undef, not the empty string */
if (m >= orig && s >= orig) {
- dstr = NEWSV(33, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
}
else
dstr = &PL_sv_undef; /* undef, not "" */
/* keep field after final delim? */
if (s < strend || (iters && origlimit)) {
STRLEN l = strend - s;
- dstr = NEWSV(34, l);
- sv_setpvn(dstr, s, l);
+ dstr = newSVpvn(s, l);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
{
DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * vim: shiftwidth=4:
+*/
projects / p5sagit/p5-mst-13.2.git / blobdiff