/* pp.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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.
RETURN;
}
+/* Helper function for pp_rv2sv and pp_rv2av */
+GV *
+Perl_softref2xv(pTHX_ SV *const sv, const char *const what, const U32 type,
+ SV ***spp)
+{
+ dVAR;
+ GV *gv;
+
+ if (PL_op->op_private & HINT_STRICT_REFS) {
+ if (SvOK(sv))
+ Perl_die(aTHX_ PL_no_symref_sv, sv, what);
+ else
+ Perl_die(aTHX_ PL_no_usym, what);
+ }
+ if (!SvOK(sv)) {
+ if (PL_op->op_flags & OPf_REF)
+ Perl_die(aTHX_ PL_no_usym, what);
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
+ if (type != SVt_PV && GIMME_V == G_ARRAY) {
+ (*spp)--;
+ return NULL;
+ }
+ **spp = &PL_sv_undef;
+ return NULL;
+ }
+ if ((PL_op->op_flags & OPf_SPECIAL) &&
+ !(PL_op->op_flags & OPf_MOD))
+ {
+ gv = (GV*)gv_fetchsv(sv, 0, type);
+ if (!gv
+ && (!is_gv_magical_sv(sv,0)
+ || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, type))))
+ {
+ **spp = &PL_sv_undef;
+ return NULL;
+ }
+ }
+ else {
+ gv = (GV*)gv_fetchsv(sv, GV_ADD, type);
+ }
+ return gv;
+}
+
PP(pp_rv2sv)
{
dVAR; dSP; dTOPss;
if (SvROK(sv))
goto wasref;
}
- if (PL_op->op_private & HINT_STRICT_REFS) {
- if (SvOK(sv))
- DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
- else
- DIE(aTHX_ PL_no_usym, "a SCALAR");
- }
- if (!SvOK(sv)) {
- if (PL_op->op_flags & OPf_REF)
- DIE(aTHX_ PL_no_usym, "a SCALAR");
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- RETSETUNDEF;
- }
- if ((PL_op->op_flags & OPf_SPECIAL) &&
- !(PL_op->op_flags & OPf_MOD))
- {
- gv = (GV*)gv_fetchsv(sv, 0, SVt_PV);
- if (!gv
- && (!is_gv_magical_sv(sv, 0)
- || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV))))
- {
- RETSETUNDEF;
- }
- }
- else {
- gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV);
- }
+ gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
+ if (!gv)
+ RETURN;
}
sv = GvSVn(gv);
}
SV *ret = &PL_sv_undef;
if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
- const char * const s = SvPVX_const(TOPs);
+ const char * s = SvPVX_const(TOPs);
if (strnEQ(s, "CORE::", 6)) {
- const int code = keyword(s + 6, SvCUR(TOPs) - 6);
+ const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
if (code < 0) { /* Overridable. */
#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
- int i = 0, n = 0, seen_question = 0;
+ int i = 0, n = 0, seen_question = 0, defgv = 0;
I32 oa;
char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
if (code == -KEY_chop || code == -KEY_chomp
- || code == -KEY_exec || code == -KEY_system)
+ || code == -KEY_exec || code == -KEY_system || code == -KEY_err)
goto set;
+ if (code == -KEY_mkdir) {
+ ret = sv_2mortal(newSVpvs("_;$"));
+ goto set;
+ }
+ if (code == -KEY_readpipe) {
+ s = "CORE::backtick";
+ }
while (i < MAXO) { /* The slow way. */
if (strEQ(s + 6, PL_op_name[i])
|| strEQ(s + 6, PL_op_desc[i]))
}
goto nonesuch; /* Should not happen... */
found:
+ defgv = PL_opargs[i] & OA_DEFGV;
oa = PL_opargs[i] >> OASHIFT;
while (oa) {
- if (oa & OA_OPTIONAL && !seen_question) {
+ if (oa & OA_OPTIONAL && !seen_question && !defgv) {
seen_question = 1;
str[n++] = ';';
}
str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
oa = oa >> 4;
}
+ if (defgv && str[n - 1] == '$')
+ str[n - 1] = '_';
str[n++] = '\0';
ret = sv_2mortal(newSVpvn(str, n - 1));
}
if (len == 0 && ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Explicit blessing to '' (assuming package main)");
- stash = gv_stashpvn(ptr, len, TRUE);
+ stash = gv_stashpvn(ptr, len, GV_ADD);
}
(void)sv_bless(TOPs, stash);
}
s = (unsigned char*)(SvPV(sv, len));
pos = len;
- if (pos <= 0 || !SvPOK(sv)) {
+ if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
/* No point in studying a zero length string, and not safe to study
anything that doesn't appear to be a simple scalar (and hence might
change between now and when the regexp engine runs without our set
PP(pp_sprintf)
{
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ if (SvTAINTED(MARK[1]))
+ TAINT_PROPER("sprintf");
do_sprintf(TARG, SP-MARK, MARK+1);
TAINT_IF(SvTAINTED(TARG));
SP = ORIGMARK;
{
dVAR;
dSP;
- HV * const hash = (HV*)POPs;
+ HV * hash = (HV*)POPs;
HE *entry;
const I32 gimme = GIMME_V;
if (lval) {
if (!svp || *svp == &PL_sv_undef) {
- DIE(aTHX_ PL_no_helem_sv, keysv);
+ DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
}
if (localizing) {
if (HvNAME_get(hv) && isGV(*svp))
STRLEN keylen;
const char * const key = SvPV_const(keysv, keylen);
SAVEDELETE(hv, savepvn(key,keylen),
- SvUTF8(keysv) ? -(I32)keylen : keylen);
+ SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
}
}
}
*dst-- = *src--;
}
dst = AvARRAY(ary);
- SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
+ AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
AvMAX(ary) += diff;
}
else {
dst = src - diff;
Move(src, dst, offset, SV*);
}
- SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
+ AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
AvMAX(ary) += diff;
AvFILLp(ary) += diff;
}
base = SP - PL_stack_base;
orig = s;
if (pm->op_pmflags & PMf_SKIPWHITE) {
- if (pm->op_pmflags & PMf_LOCALE) {
+ if (do_utf8) {
+ while (*s == ' ' || is_utf8_space((U8*)s))
+ s += UTF8SKIP(s);
+ }
+ else if (pm->op_pmflags & PMf_LOCALE) {
while (isSPACE_LC(*s))
s++;
}
if (pm->op_pmflags & PMf_WHITE) {
while (--limit) {
m = s;
- while (m < strend &&
- !((pm->op_pmflags & PMf_LOCALE)
- ? isSPACE_LC(*m) : isSPACE(*m)))
- ++m;
+ /* this one uses 'm' and is a negative test */
+ if (do_utf8) {
+ while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
+ const int t = UTF8SKIP(m);
+ /* is_utf8_space returns FALSE for malform utf8 */
+ if (strend - m < t)
+ m = strend;
+ else
+ m += t;
+ }
+ } else if (pm->op_pmflags & PMf_LOCALE) {
+ while (m < strend && !isSPACE_LC(*m))
+ ++m;
+ } else {
+ while (m < strend && !isSPACE(*m))
+ ++m;
+ }
if (m >= strend)
break;
(void)SvUTF8_on(dstr);
XPUSHs(dstr);
- s = m + 1;
- while (s < strend &&
- ((pm->op_pmflags & PMf_LOCALE)
- ? isSPACE_LC(*s) : isSPACE(*s)))
- ++s;
+ /* skip the whitespace found last */
+ if (do_utf8)
+ s = m + UTF8SKIP(m);
+ else
+ s = m + 1;
+
+ /* this one uses 's' and is a positive test */
+ if (do_utf8) {
+ while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
+ s += UTF8SKIP(s);
+ } else if (pm->op_pmflags & PMf_LOCALE) {
+ while (s < strend && isSPACE_LC(*s))
+ ++s;
+ } else {
+ while (s < strend && isSPACE(*s))
+ ++s;
+ }
}
}
- else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
+ else if (rx->extflags & RXf_START_ONLY) {
while (--limit) {
for (m = s; m < strend && *m != '\n'; m++)
;
s = m;
}
}
- else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
- (rx->reganch & RE_USE_INTUIT) && !rx->nparens
- && (rx->reganch & ROPT_CHECK_ALL)
- && !(rx->reganch & ROPT_ANCH)) {
- const int tail = (rx->reganch & RE_INTUIT_TAIL);
- SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
+ else if (do_utf8 == ((rx->extflags & RXf_UTF8) != 0) &&
+ (rx->extflags & RXf_USE_INTUIT) && !rx->nparens
+ && (rx->extflags & RXf_CHECK_ALL)
+ && !(rx->extflags & RXf_ANCH)) {
+ const int tail = (rx->extflags & RXf_INTUIT_TAIL);
+ SV * const csv = CALLREG_INTUIT_STRING(rx);
- len = rx->minlen;
- if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
+ len = rx->minlenret;
+ if (len == 1 && !(rx->extflags & RXf_UTF8) && !tail) {
const char c = *SvPV_nolen_const(csv);
while (--limit) {
for (m = s; m < strend && *m != c; m++)
{
I32 rex_return;
PUTBACK;
- rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
+ rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
sv, NULL, 0);
SPAGAIN;
if (rex_return == 0)
https://perl5.git.perl.org / perl5.git / blobdiff