(sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
{
/* diag_listed_as: Variable "%s" is not imported%s */
- Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
+ Perl_ck_warner_d(
+ aTHX_ packWARN(WARN_MISC),
+ "Variable \"%c%s\" is not imported",
sv_type == SVt_PVAV ? '@' :
sv_type == SVt_PVHV ? '%' : '$',
name);
if (GvCVu(*gvp))
- Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
+ Perl_ck_warner_d(
+ aTHX_ packWARN(WARN_MISC),
+ "\t(Did you mean &%s instead?)\n", name
+ );
stash = NULL;
}
}
/* Names of length 1. (Or 0. But name is NUL terminated, so that will
be case '\0' in this switch statement (ie a default case) */
switch (*name) {
- case '&':
- case '`':
- case '\'':
+ case '&': /* $& */
+ case '`': /* $` */
+ case '\'': /* $' */
if (
sv_type == SVt_PVAV ||
sv_type == SVt_PVHV ||
PL_sawampersand = TRUE;
goto magicalize;
- case ':':
+ case ':': /* $: */
sv_setpv(GvSVn(gv),PL_chopset);
goto magicalize;
- case '?':
+ case '?': /* $? */
#ifdef COMPLEX_STATUS
SvUPGRADE(GvSVn(gv), SVt_PVLV);
#endif
goto magicalize;
- case '!':
+ case '!': /* $! */
GvMULTI_on(gv);
/* If %! has been used, automatically load Errno.pm. */
require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
break;
- case '-':
- case '+':
+ case '-': /* $- */
+ case '+': /* $+ */
GvMULTI_on(gv); /* no used once warnings here */
{
AV* const av = GvAVn(gv);
break;
}
- case '*':
- case '#':
+ case '*': /* $* */
+ case '#': /* $# */
if (sv_type == SVt_PV)
Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"$%c is no longer supported", *name);
break;
- case '|':
+ case '|': /* $| */
sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
goto magicalize;
ro_magicalize:
SvREADONLY_on(GvSVn(gv));
/* FALL THROUGH */
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- case '[':
- case '^':
- case '~':
- case '=':
- case '%':
- case '.':
- case '(':
- case ')':
- case '<':
- case '>':
- case '\\':
- case '/':
+ case '0': /* $0 */
+ case '1': /* $1 */
+ case '2': /* $2 */
+ case '3': /* $3 */
+ case '4': /* $4 */
+ case '5': /* $5 */
+ case '6': /* $6 */
+ case '7': /* $7 */
+ case '8': /* $8 */
+ case '9': /* $9 */
+ case '[': /* $[ */
+ case '^': /* $^ */
+ case '~': /* $~ */
+ case '=': /* $= */
+ case '%': /* $% */
+ case '.': /* $. */
+ case '(': /* $( */
+ case ')': /* $) */
+ case '<': /* $< */
+ case '>': /* $> */
+ case '\\': /* $\ */
+ case '/': /* $/ */
case '\001': /* $^A */
case '\003': /* $^C */
case '\004': /* $^D */
sv_setpvs(GvSVn(gv),"\f");
PL_formfeed = GvSVn(gv);
break;
- case ';':
+ case ';': /* $; */
sv_setpvs(GvSVn(gv),"\034");
break;
- case ']':
+ case ']': /* $] */
{
SV * const sv = GvSVn(gv);
if (!sv_derived_from(PL_patchlevel, "version"))
void
Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
{
- const GV * const egv = GvEGV(gv);
+ const GV * const egv = GvEGVx(gv);
PERL_ARGS_ASSERT_GV_EFULLNAME4;
}
+/* Implement tryAMAGICun_MG macro.
+ Do get magic, then see if the stack arg is overloaded and if so call it.
+ Flags:
+ AMGf_set return the arg using SETs rather than assigning to
+ the targ
+ AMGf_numeric apply sv_2num to the stack arg.
+*/
+
+bool
+Perl_try_amagic_un(pTHX_ int method, int flags) {
+ dVAR;
+ dSP;
+ SV* tmpsv;
+ SV* const arg = TOPs;
+
+ SvGETMAGIC(arg);
+
+ if (SvAMAGIC(arg) && (tmpsv = AMG_CALLun_var(arg,method))) {
+ if (flags & AMGf_set) {
+ SETs(tmpsv);
+ }
+ else {
+ dTARGET;
+ if (SvPADMY(TARG)) {
+ sv_setsv(TARG, tmpsv);
+ SETTARG;
+ }
+ else
+ SETs(tmpsv);
+ }
+ PUTBACK;
+ return TRUE;
+ }
+
+ if ((flags & AMGf_numeric) && SvROK(arg))
+ *sp = sv_2num(arg);
+ return FALSE;
+}
+
+
+/* Implement tryAMAGICbin_MG macro.
+ Do get magic, then see if the two stack args are overloaded and if so
+ call it.
+ Flags:
+ AMGf_set return the arg using SETs rather than assigning to
+ the targ
+ AMGf_assign op may be called as mutator (eg +=)
+ AMGf_numeric apply sv_2num to the stack arg.
+*/
+
+bool
+Perl_try_amagic_bin(pTHX_ int method, int flags) {
+ dVAR;
+ dSP;
+ SV* const left = TOPm1s;
+ SV* const right = TOPs;
+
+ SvGETMAGIC(left);
+ if (left != right)
+ SvGETMAGIC(right);
+
+ if (SvAMAGIC(left) || SvAMAGIC(right)) {
+ SV * const tmpsv = amagic_call(left, right, method,
+ ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
+ if (tmpsv) {
+ if (flags & AMGf_set) {
+ (void)POPs;
+ SETs(tmpsv);
+ }
+ else {
+ dATARGET;
+ (void)POPs;
+ if (opASSIGN || SvPADMY(TARG)) {
+ sv_setsv(TARG, tmpsv);
+ SETTARG;
+ }
+ else
+ SETs(tmpsv);
+ }
+ PUTBACK;
+ return TRUE;
+ }
+ }
+ if (flags & AMGf_numeric) {
+ if (SvROK(left))
+ *(sp-1) = sv_2num(left);
+ if (SvROK(right))
+ *sp = sv_2num(right);
+ }
+ return FALSE;
+}
+
+
SV*
Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
{
(void)((cv = cvp[off=bool__amg])
|| (cv = cvp[off=numer_amg])
|| (cv = cvp[off=string_amg]));
- postpr = 1;
+ if (cv)
+ postpr = 1;
break;
case copy_amg:
{
case ge_amg:
case eq_amg:
case ne_amg:
- postpr = 1; off=ncmp_amg; break;
+ off = ncmp_amg;
+ break;
case slt_amg:
case sle_amg:
case sgt_amg:
case sge_amg:
case seq_amg:
case sne_amg:
- postpr = 1; off=scmp_amg; break;
+ off = scmp_amg;
+ break;
}
- if (off != -1) cv = cvp[off];
- if (!cv) {
- goto not_found;
- }
+ if ((off != -1) && (cv = cvp[off]))
+ postpr = 1;
+ else
+ goto not_found;
} else {
not_found: /* No method found, either report or croak */
switch (method) {
- case lt_amg:
- case le_amg:
- case gt_amg:
- case ge_amg:
- case eq_amg:
- case ne_amg:
- case slt_amg:
- case sle_amg:
- case sgt_amg:
- case sge_amg:
- case seq_amg:
- case sne_amg:
- postpr = 0; break;
case to_sv_amg:
case to_av_amg:
case to_hv_amg:
if (( (method + assignshift == off)
&& (assign || (method == inc_amg) || (method == dec_amg)))
|| force_cpy)
+ {
RvDEEPCP(left);
+ }
+
{
dSP;
BINOP myop;
/*
=for apidoc gv_try_downgrade
-If C<gv> is a typeglob containing only a constant sub, and is only
-referenced from its package, and both the typeglob and the sub are
-sufficiently ordinary, replace the typeglob (in the package) with a
-placeholder that more compactly represents the same thing. This is meant
-to be used when a placeholder has been upgraded, most likely because
-something wanted to look at a proper code object, and it has turned out
-to be a constant sub to which a proper reference is no longer required.
+If the typeglob C<gv> can be expressed more succinctly, by having
+something other than a real GV in its place in the stash, replace it
+with the optimised form. Basic requirements for this are that C<gv>
+is a real typeglob, is sufficiently ordinary, and is only referenced
+from its package. This function is meant to be used when a GV has been
+looked up in part to see what was there, causing upgrading, but based
+on what was found it turns out that the real GV isn't required after all.
+
+If C<gv> is a completely empty typeglob, it is deleted from the stash.
+
+If C<gv> is a typeglob containing only a sufficiently-ordinary constant
+sub, the typeglob is replaced with a scalar-reference placeholder that
+more compactly represents the same thing.
=cut
*/
HEK *namehek;
SV **gvp;
PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
- if (SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
+ if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
!SvOBJECT(gv) && !SvMAGICAL(gv) && !SvREADONLY(gv) &&
isGV_with_GP(gv) && GvGP(gv) &&
- GvMULTI(gv) && !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
+ !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
!GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
- GvEGV(gv) == gv && (stash = GvSTASH(gv)) && (cv = GvCV(gv)) &&
+ GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
+ return;
+ cv = GvCV(gv);
+ if (!cv) {
+ HEK *gvnhek = GvNAME_HEK(gv);
+ (void)hv_delete(stash, HEK_KEY(gvnhek),
+ HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
+ } else if (GvMULTI(gv) && cv &&
!SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
CvSTASH(cv) == stash && CvGV(cv) == gv &&
CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
projects / p5sagit/p5-mst-13.2.git / blobdiff