case OP_GGRGID:
case OP_GETLOGIN:
case OP_PROTOTYPE:
+ case OP_RUNCV:
func_ops:
if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
/* Otherwise it's "Useless use of grep iterator" */
else if (!(o->op_flags & OPf_KIDS))
break;
if (o->op_targ != OP_LIST) {
+ case OP_SCALAR:
op_lvalue(cBINOPo->op_first, type);
break;
}
PVOP *pvop;
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
+ || type == OP_RUNCV
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
NewOp(1101, pvop, 1, PVOP);
newSTATEOP(0, NULL, imop) ));
if (use_version) {
+ HV * const hinthv = GvHV(PL_hintgv);
+ const bool hhoff = !hinthv || !(PL_hints & HINT_LOCALIZE_HH);
+ SV *importsv;
+
+ /* Turn features off */
+ ENTER_with_name("load_feature");
+ Perl_load_module(aTHX_
+ PERL_LOADMOD_DENY, newSVpvs("feature"), NULL, NULL
+ );
+
/* If we request a version >= 5.9.5, load feature.pm with the
* feature bundle that corresponds to the required version. */
use_version = sv_2mortal(new_version(use_version));
if (vcmp(use_version,
sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
- SV *const importsv = vnormal(use_version);
+ importsv = vnormal(use_version);
*SvPVX_mutable(importsv) = ':';
- ENTER_with_name("load_feature");
- Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
- LEAVE_with_name("load_feature");
}
+ else importsv = newSVpvs(":default");
+ Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
+ LEAVE_with_name("load_feature");
/* If a version >= 5.11.0 is requested, strictures are on by default! */
if (vcmp(use_version,
sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
- PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
+ if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
+ PL_hints |= HINT_STRICT_REFS;
+ if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
+ PL_hints |= HINT_STRICT_SUBS;
+ if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
+ PL_hints |= HINT_STRICT_VARS;
+ }
+ /* otherwise they are off */
+ else {
+ if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
+ PL_hints &= ~HINT_STRICT_REFS;
+ if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
+ PL_hints &= ~HINT_STRICT_SUBS;
+ if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
+ PL_hints &= ~HINT_STRICT_VARS;
}
}
Note that the actual module name, not its filename, should be given.
Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
-(or 0 for no flags). ver, if specified, provides version semantics
+(or 0 for no flags). ver, if specified and not NULL, provides version semantics
similar to C<use Foo::Bar VERSION>. The optional trailing SV*
arguments can be used to specify arguments to the module's import()
method, similar to C<use Foo::Bar VERSION LIST>. They must be
Otherwise at least a single NULL pointer to designate the default
import list is required.
+The reference count for each specified C<SV*> parameter is decremented.
+
=cut */
void
/* This is a default {} block */
enterop->op_first = block;
enterop->op_flags |= OPf_SPECIAL;
+ o ->op_flags |= OPf_SPECIAL;
o->op_next = (OP *) enterop;
}
&& block->op_type != OP_NULL
#endif
) {
- const char *hvname;
- if ( (ckWARN(WARN_REDEFINE)
- && !(
- CvGV(cv) && GvSTASH(CvGV(cv))
- && HvNAMELEN(GvSTASH(CvGV(cv))) == 7
- && (hvname = HvNAME(GvSTASH(CvGV(cv))),
- strEQ(hvname, "autouse"))
- ))
- || (CvCONST(cv)
- && ckWARN_d(WARN_REDEFINE)
- && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
- {
- const line_t oldline = CopLINE(PL_curcop);
- if (PL_parser && PL_parser->copline != NOLINE)
+ const line_t oldline = CopLINE(PL_curcop);
+ if (PL_parser && PL_parser->copline != NOLINE)
CopLINE_set(PL_curcop, PL_parser->copline);
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- CvCONST(cv) ? "Constant subroutine %"SVf" redefined"
- : "Subroutine %"SVf" redefined",
- SVfARG(cSVOPo->op_sv));
- CopLINE_set(PL_curcop, oldline);
- }
+ report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
+ CopLINE_set(PL_curcop, oldline);
#ifdef PERL_MAD
if (!PL_minus_c) /* keep old one around for madskills */
#endif
}
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
/* already defined (or promised) */
- const char *redefined_name;
- if (CvCONST(cv) && const_svp
- && cv_const_sv(cv) == *const_svp) {
- NOOP;
- /* They are 2 constant subroutines generated from
- the same constant. This probably means that
- they are really the "same" proxy subroutine
- instantiated in 2 places. Most likely this is
- when a constant is exported twice. Don't warn.
- */
- }
- else if ((ckWARN(WARN_REDEFINE)
- && !(
- CvGV(cv) && GvSTASH(CvGV(cv))
- && HvNAMELEN(GvSTASH(CvGV(cv))) == 7
- && (redefined_name = HvNAME(GvSTASH(CvGV(cv))),
- strEQ(redefined_name, "autouse"))
- )
- )
- || (CvCONST(cv)
- && ckWARN_d(WARN_REDEFINE)
- && ( !const_svp
- || sv_cmp(cv_const_sv(cv), *const_svp) )
- )
- ) {
+ /* Redundant check that allows us to avoid creating an SV
+ most of the time: */
+ if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
const line_t oldline = CopLINE(PL_curcop);
if (PL_parser && PL_parser->copline != NOLINE)
CopLINE_set(PL_curcop, PL_parser->copline);
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- CvCONST(cv)
- ? "Constant subroutine %"SVf
- " redefined"
- : "Subroutine %"SVf" redefined",
- newSVpvn_flags(
+ report_redefined_cv(newSVpvn_flags(
name,len,(flags&SVf_UTF8)|SVs_TEMP
- ));
+ ),
+ cv, const_svp);
CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
op_getmad(oldo,o,'O');
}
o->op_targ = (PADOFFSET)PL_hints;
+ if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
if ((PL_hints & HINT_LOCALIZE_HH) != 0
&& !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
/* Store a copy of %^H that pp_entereval can pick up. */
const char *name = NULL;
STRLEN len = 0;
U32 name_utf8 = 0;
+ bool want_dollar = TRUE;
flags = 0;
/* Set a flag to tell rv2gv to vivify
if (!name) {
name = "__ANONIO__";
len = 10;
+ want_dollar = FALSE;
}
op_lvalue(kid, type);
}
targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
namesv = PAD_SVl(targ);
SvUPGRADE(namesv, SVt_PV);
- if (*name != '$')
+ if (want_dollar && *name != '$')
sv_setpvs(namesv, "$");
sv_catpvn(namesv, name, len);
if ( name_utf8 ) SvUTF8_on(namesv);
(void)too_many_arguments(aop, GvNAME(namegv));
op_free(aop);
}
- return newOP(opnum,0);
+ return opnum == OP_RUNCV
+ ? newPVOP(OP_RUNCV,0,NULL)
+ : newOP(opnum,0);
default:
return convert(opnum,0,aop);
}
}
break;
+ case OP_RUNCV:
+ if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
+ SV *sv;
+ if (CvUNIQUE(PL_compcv)) sv = &PL_sv_undef;
+ else {
+ sv = newRV((SV *)PL_compcv);
+ sv_rvweaken(sv);
+ SvREADONLY_on(sv);
+ }
+ o->op_type = OP_CONST;
+ o->op_ppaddr = PL_ppaddr[OP_CONST];
+ o->op_flags |= OPf_SPECIAL;
+ cSVOPo->op_sv = sv;
+ }
+ break;
+
+ case OP_SASSIGN:
+ if (OP_GIMME(o,0) == G_VOID) {
+ OP *right = cBINOP->op_first;
+ if (right) {
+ OP *left = right->op_sibling;
+ if (left->op_type == OP_SUBSTR
+ && (left->op_private & 7) < 4) {
+ op_null(o);
+ cBINOP->op_first = left;
+ right->op_sibling =
+ cBINOPx(left)->op_first->op_sibling;
+ cBINOPx(left)->op_first->op_sibling = right;
+ left->op_private |= OPpSUBSTR_REPL_FIRST;
+ left->op_flags =
+ (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
+ }
+ }
+ }
+ break;
+
case OP_CUSTOM: {
Perl_cpeep_t cpeep =
XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
return op_append_elem(
OP_LINESEQ, argop,
newOP(opnum,
- opnum == OP_WANTARRAY ? OPpOFFBYONE << 8 : 0)
+ opnum == OP_WANTARRAY || opnum == OP_RUNCV
+ ? OPpOFFBYONE << 8 : 0)
);
case OA_BASEOP_OR_UNOP:
if (opnum == OP_ENTEREVAL) {
}
}
+void
+Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
+ SV * const *new_const_svp)
+{
+ const char *hvname;
+ bool is_const = !!CvCONST(old_cv);
+ SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
+
+ PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
+
+ if (is_const && new_const_svp && old_const_sv == *new_const_svp)
+ return;
+ /* They are 2 constant subroutines generated from
+ the same constant. This probably means that
+ they are really the "same" proxy subroutine
+ instantiated in 2 places. Most likely this is
+ when a constant is exported twice. Don't warn.
+ */
+ if (
+ (ckWARN(WARN_REDEFINE)
+ && !(
+ CvGV(old_cv) && GvSTASH(CvGV(old_cv))
+ && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
+ && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
+ strEQ(hvname, "autouse"))
+ )
+ )
+ || (is_const
+ && ckWARN_d(WARN_REDEFINE)
+ && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
+ )
+ )
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ is_const
+ ? "Constant subroutine %"SVf" redefined"
+ : "Subroutine %"SVf" redefined",
+ name);
+}
+
#include "XSUB.h"
/* Efficient sub that returns a constant scalar value. */
https://perl5.git.perl.org / perl5.git / blobdiff