/* pp_hot.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.
PP(pp_rv2av)
{
dVAR; dSP; dTOPss;
- AV *av;
+ const I32 gimme = GIMME_V;
+ static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
+ static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
+ static const char an_array[] = "an ARRAY";
+ static const char a_hash[] = "a HASH";
+ const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
+ const U32 type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
if (SvROK(sv)) {
wasref:
- tryAMAGICunDEREF(to_av);
+ tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
- av = (AV*)SvRV(sv);
- if (SvTYPE(av) != SVt_PVAV)
- DIE(aTHX_ "Not an ARRAY reference");
+ sv = SvRV(sv);
+ if (SvTYPE(sv) != type)
+ DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
if (PL_op->op_flags & OPf_REF) {
- SETs((SV*)av);
+ SETs(sv);
RETURN;
}
else if (LVRET) {
- if (GIMME == G_SCALAR)
- Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
- SETs((SV*)av);
+ if (gimme != G_ARRAY)
+ Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
+ : return_hash_to_lvalue_scalar);
+ SETs(sv);
RETURN;
}
else if (PL_op->op_flags & OPf_MOD
Perl_croak(aTHX_ PL_no_localize_ref);
}
else {
- if (SvTYPE(sv) == SVt_PVAV) {
- av = (AV*)sv;
+ if (SvTYPE(sv) == type) {
if (PL_op->op_flags & OPf_REF) {
- SETs((SV*)av);
+ SETs(sv);
RETURN;
}
else if (LVRET) {
- if (GIMME == G_SCALAR)
- Perl_croak(aTHX_ "Can't return array to lvalue"
- " scalar context");
- SETs((SV*)av);
+ if (gimme != G_ARRAY)
+ Perl_croak(aTHX_
+ is_pp_rv2av ? return_array_to_lvalue_scalar
+ : return_hash_to_lvalue_scalar);
+ SETs(sv);
RETURN;
}
}
if (SvROK(sv))
goto wasref;
}
- if (!SvOK(sv)) {
- if (PL_op->op_flags & OPf_REF ||
- PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_usym, "an ARRAY");
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- if (GIMME == G_ARRAY) {
- (void)POPs;
- RETURN;
- }
- RETSETUNDEF;
- }
- if ((PL_op->op_flags & OPf_SPECIAL) &&
- !(PL_op->op_flags & OPf_MOD))
- {
- gv = (GV*)gv_fetchsv(sv, 0, SVt_PVAV);
- if (!gv
- && (!is_gv_magical_sv(sv,0)
- || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV))))
- {
- RETSETUNDEF;
- }
- }
- else {
- if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
- gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV);
- }
+ gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
+ type, &sp);
+ if (!gv)
+ RETURN;
}
else {
gv = (GV*)sv;
}
- av = GvAVn(gv);
+ sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
if (PL_op->op_private & OPpLVAL_INTRO)
- av = save_ary(gv);
+ sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
if (PL_op->op_flags & OPf_REF) {
- SETs((SV*)av);
+ SETs(sv);
RETURN;
}
else if (LVRET) {
- if (GIMME == G_SCALAR)
- Perl_croak(aTHX_ "Can't return array to lvalue"
- " scalar context");
- SETs((SV*)av);
+ if (gimme != G_ARRAY)
+ Perl_croak(aTHX_
+ is_pp_rv2av ? return_array_to_lvalue_scalar
+ : return_hash_to_lvalue_scalar);
+ SETs(sv);
RETURN;
}
}
}
- if (GIMME == G_ARRAY) {
+ if (is_pp_rv2av) {
+ AV *const av = (AV*)sv;
+ /* The guts of pp_rv2av, with no intenting change to preserve history
+ (until such time as we get tools that can do blame annotation across
+ whitespace changes. */
+ if (gimme == G_ARRAY) {
const I32 maxarg = AvFILL(av) + 1;
(void)POPs; /* XXXX May be optimized away? */
EXTEND(SP, maxarg);
}
SP += maxarg;
}
- else if (GIMME_V == G_SCALAR) {
+ else if (gimme == G_SCALAR) {
dTARGET;
const I32 maxarg = AvFILL(av) + 1;
SETi(maxarg);
}
- RETURN;
-}
-
-PP(pp_rv2hv)
-{
- dVAR; dSP; dTOPss;
- HV *hv;
- const I32 gimme = GIMME_V;
- static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
-
- if (SvROK(sv)) {
- wasref:
- tryAMAGICunDEREF(to_hv);
-
- hv = (HV*)SvRV(sv);
- if (SvTYPE(hv) != SVt_PVHV)
- DIE(aTHX_ "Not a HASH reference");
- if (PL_op->op_flags & OPf_REF) {
- SETs((SV*)hv);
- RETURN;
- }
- else if (LVRET) {
- if (gimme != G_ARRAY)
- Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
- SETs((SV*)hv);
- RETURN;
- }
- else if (PL_op->op_flags & OPf_MOD
- && PL_op->op_private & OPpLVAL_INTRO)
- Perl_croak(aTHX_ PL_no_localize_ref);
- }
- else {
- if (SvTYPE(sv) == SVt_PVHV) {
- hv = (HV*)sv;
- if (PL_op->op_flags & OPf_REF) {
- SETs((SV*)hv);
- RETURN;
- }
- else if (LVRET) {
- if (gimme != G_ARRAY)
- Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
- SETs((SV*)hv);
- RETURN;
- }
- }
- else {
- GV *gv;
-
- if (SvTYPE(sv) != SVt_PVGV) {
- if (SvGMAGICAL(sv)) {
- mg_get(sv);
- if (SvROK(sv))
- goto wasref;
- }
- if (!SvOK(sv)) {
- if (PL_op->op_flags & OPf_REF ||
- PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_usym, "a HASH");
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- if (gimme == G_ARRAY) {
- SP--;
- RETURN;
- }
- RETSETUNDEF;
- }
- if ((PL_op->op_flags & OPf_SPECIAL) &&
- !(PL_op->op_flags & OPf_MOD))
- {
- gv = (GV*)gv_fetchsv(sv, 0, SVt_PVHV);
- if (!gv
- && (!is_gv_magical_sv(sv,0)
- || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV))))
- {
- RETSETUNDEF;
- }
- }
- else {
- if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
- gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV);
- }
- }
- else {
- gv = (GV*)sv;
- }
- hv = GvHVn(gv);
- if (PL_op->op_private & OPpLVAL_INTRO)
- hv = save_hash(gv);
- if (PL_op->op_flags & OPf_REF) {
- SETs((SV*)hv);
- RETURN;
- }
- else if (LVRET) {
- if (gimme != G_ARRAY)
- Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
- SETs((SV*)hv);
- RETURN;
- }
- }
- }
-
+ } else {
+ /* The guts of pp_rv2hv */
if (gimme == G_ARRAY) { /* array wanted */
- *PL_stack_sp = (SV*)hv;
+ *PL_stack_sp = sv;
return do_kv();
}
else if (gimme == G_SCALAR) {
dTARGET;
- TARG = Perl_hv_scalar(aTHX_ hv);
+ TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
SETTARG;
}
+ }
RETURN;
}
if (pm->op_pmdynflags & PMdf_TAINTED)
SvTAINTED_on(rv);
sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
- RETURNX(PUSHs(rv));
+ XPUSHs(rv);
+ RETURN;
}
PP(pp_match)
/* remove comment to get faster /g but possibly unsafe $1 vars after a
match. Test for the unsafe vars will fail as well*/
if (( /* !global && */ rx->nparens)
- || SvTEMP(TARG) || PL_sawampersand || (pm->op_pmflags & PMf_EVAL))
+ || SvTEMP(TARG) || PL_sawampersand ||
+ (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)))
r_flags |= REXEC_COPY_STR;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
goto nope;
if ( (rx->extflags & RXf_CHECK_ALL)
&& !PL_sawampersand
+ && !(pm->op_pmflags & PMf_KEEPCOPY)
&& ((rx->extflags & RXf_NOSCAN)
|| !((rx->extflags & RXf_INTUIT_TAIL)
&& (r_flags & REXEC_SCREAM)))
rx->sublen = strend - truebase;
goto gotcha;
}
- if (PL_sawampersand) {
+ if (PL_sawampersand || pm->op_pmflags & PMf_KEEPCOPY) {
I32 off;
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
rx->startp[0] = s - truebase;
rx->endp[0] = s - truebase + rx->minlenret;
}
+ /* including rx->nparens in the below code seems highly suspicious.
+ -dmq */
rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
LEAVE_SCOPE(oldsave);
RETPUSHYES;
if (lv)
SvREFCNT_dec(LvTARG(lv));
else {
- lv = cx->blk_loop.iterlval = newSV(0);
- sv_upgrade(lv, SVt_PVLV);
+ lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
LvTYPE(lv) = 'y';
sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
}
rx = PM_GETRE(pm);
}
r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
- || (pm->op_pmflags & PMf_EVAL))
+ || (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)) )
? REXEC_COPY_STR : 0;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
/* How to do it in subst? */
/* if ( (rx->extflags & RXf_CHECK_ALL)
&& !PL_sawampersand
+ && !(pm->op_pmflags & PMf_KEEPCOPY)
&& ((rx->extflags & RXf_NOSCAN)
|| !((rx->extflags & RXf_INTUIT_TAIL)
&& (r_flags & REXEC_SCREAM))))
default:
if (!SvROK(sv)) {
const char *sym;
+ STRLEN len;
if (sv == &PL_sv_yes) { /* unfound import, ignore */
if (hasargs)
SP = PL_stack_base + POPMARK;
mg_get(sv);
if (SvROK(sv))
goto got_rv;
- sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
+ if (SvPOKp(sv)) {
+ sym = SvPVX_const(sv);
+ len = SvCUR(sv);
+ } else {
+ sym = NULL;
+ len = 0;
+ }
}
else {
- sym = SvPV_nolen_const(sv);
+ sym = SvPV_const(sv, len);
}
if (!sym)
DIE(aTHX_ PL_no_usym, "a subroutine");
if (PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ PL_no_symref, sym, "a subroutine");
- cv = get_cv(sym, TRUE);
+ cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
break;
}
got_rv:
: "on an undefined value");
}
/* assume it's a package name */
- stash = gv_stashpvn(packname, packlen, FALSE);
+ stash = gv_stashpvn(packname, packlen, 0);
if (!stash)
packsv = sv;
else {
}
/* we're relying on gv_fetchmethod not autovivifying the stash */
- if (gv_stashpvn(packname, packlen, FALSE)) {
+ if (gv_stashpvn(packname, packlen, 0)) {
Perl_croak(aTHX_
"Can't locate object method \"%s\" via package \"%.*s\"",
leaf, (int)packlen, packname);
https://perl5.git.perl.org / perl5.git / blobdiff