dVAR;
const U32 old_type = SvTYPE(gv);
const bool doproto = old_type > SVt_NULL;
- char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
+ char * const proto = (doproto && SvPOK(gv))
+ ? (SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0), SvPVX(gv))
+ : NULL;
const STRLEN protolen = proto ? SvCUR(gv) : 0;
const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
CV *cv;
ENTER;
if (has_constant) {
- char *name0 = NULL;
- if (name[len])
- /* newCONSTSUB doesn't take a len arg, so make sure we
- * give it a \0-terminated string */
- name0 = savepvn(name,len);
-
/* newCONSTSUB takes ownership of the reference from us. */
- cv = newCONSTSUB_flags(stash, (name0 ? name0 : name), flags, has_constant);
+ cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
/* In case op.c:S_process_special_blocks stole it: */
if (!GvCV(gv))
GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
- if (name0)
- Safefree(name0);
/* If this reference was a copy of another, then the subroutine
must have been "imported", by a Perl space assignment to a GV
from a reference to CV. */
* via the SvPVX field in the CV, and the stash in CvSTASH.
*
* Due to an unfortunate accident of history, the SvPVX field
- * serves two purposes. It is also used for the subroutine’s pro-
+ * serves two purposes. It is also used for the subroutine's pro-
* type. Since SvPVX has been documented as returning the sub name
* for a long time, but not as returning the prototype, we have
* to preserve the SvPVX AUTOLOAD behaviour and put the prototype
tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
sv_catpvn_flags(
varsv, name, len,
- SV_GMAGIC|SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
+ SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
);
if (is_utf8)
SvUTF8_on(varsv);
PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
- if (!stash || !(gv_fetchmethod(stash, methpv))) {
+ if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
SV *module = newSVsv(namesv);
char varname = *varpv; /* varpv might be clobbered by load_module,
so save it. For the moment it's always
a single char. */
+ const char type = varname == '[' ? '$' : '%';
dSP;
ENTER;
if ( flags & 1 )
SPAGAIN;
stash = gv_stashsv(namesv, 0);
if (!stash)
- Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
- varname, SVfARG(namesv));
+ Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
+ type, varname, SVfARG(namesv));
else if (!gv_fetchmethod(stash, methpv))
- Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
- varname, SVfARG(namesv), methpv);
+ Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
+ type, varname, SVfARG(namesv), methpv);
}
SvREFCNT_dec(namesv);
return stash;
if (add) {
GvMULTI_on(gv);
gv_init_svtype(gv, sv_type);
- if (len == 1 && stash == PL_defstash
- && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
+ if (len == 1 && stash == PL_defstash) {
+ if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
if (*name == '!')
require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
else if (*name == '-' || *name == '+')
require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
+ }
+ if ((sv_type==SVt_PV || sv_type==SVt_PVGV) && *name == '[')
+ require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
}
else if (len == 3 && sv_type == SVt_PVAV
&& strnEQ(name, "ISA", 3)
hv_magic(hv, NULL, PERL_MAGIC_hints);
}
goto magicalize;
+ case '[': /* $[ */
+ if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
+ && FEATURE_IS_ENABLED_d("$[")) {
+ if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
+ require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+ addmg = 0;
+ }
+ else goto magicalize;
+ break;
case '\023': /* $^S */
ro_magicalize:
SvREADONLY_on(GvSVn(gv));
case '7': /* $7 */
case '8': /* $8 */
case '9': /* $9 */
- case '[': /* $[ */
case '^': /* $^ */
case '~': /* $~ */
case '=': /* $= */
PERL_ARGS_ASSERT_GV_FULLNAME4;
- if (!hv) {
- SvOK_off(sv);
- return;
- }
sv_setpv(sv, prefix ? prefix : "");
- if ((name = HvNAME(hv))) {
+ if (hv && (name = HvNAME(hv))) {
const STRLEN len = HvNAMELEN(hv);
if (keepmain || strnNE(name, "main", len)) {
sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
/* off is method, method+assignshift, or a result of opcode substitution.
* In the latter case assignshift==0, so only notfound case is important.
*/
- if (( (method + assignshift == off)
+ if ( (lr == -1) && ( ( (method + assignshift == off)
&& (assign || (method == inc_amg) || (method == dec_amg)))
- || force_cpy)
+ || force_cpy) )
{
/* newSVsv does not behave as advertised, so we copy missing
* information by hand */
https://perl5.git.perl.org / perl5.git / blobdiff