#include "EXTERN.h"
#define PERL_IN_GV_C
#include "perl.h"
-#include "overload.c"
+#include "overload.inc"
#include "keywords.h"
#include "feature.h"
static const char S_autoload[] = "AUTOLOAD";
-static const STRLEN S_autolen = sizeof(S_autoload)-1;
+#define S_autolen (sizeof("AUTOLOAD")-1)
-SV *
-Perl_gv_add_by_type_p(pTHX_ GV *gv, gv_add_type type)
+GV *
+Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
{
SV **where;
- SV * sv;
- PERL_ARGS_ASSERT_GV_ADD_BY_TYPE_P;
- if ( SvTYPE((const SV *)gv) != SVt_PVGV
+ if (
+ !gv
+ || (
+ SvTYPE((const SV *)gv) != SVt_PVGV
&& SvTYPE((const SV *)gv) != SVt_PVLV
+ )
) {
const char *what;
- if (type == GPe_IO) {
+ if (type == SVt_PVIO) {
/*
* if it walks like a dirhandle, then let's assume that
* this is a dirhandle.
*/
what = OP_IS_DIRHOP(PL_op->op_type) ?
"dirhandle" : "filehandle";
- } else if (type == GPe_HV) {
+ } else if (type == SVt_PVHV) {
what = "hash";
} else {
- what = type == GPe_AV ? "array" : "scalar";
+ what = type == SVt_PVAV ? "array" : "scalar";
}
/* diag_listed_as: Bad symbol for filehandle */
Perl_croak(aTHX_ "Bad symbol for %s", what);
}
- where = (SV **)((Size_t)GvGP(gv)+ (Size_t)type);
-
- sv = *where;
- if (!sv) {
-/* this is table of GP members to their SV types, SVt_LAST triggers a panic */
- static const U8 addtype_to_svtype
-#if PTRSIZE == 8
- /*gp_sv , gp_io , gp_cv , cvgn/cnt, gp_hv , gp_av */
- [6] = {SVt_NULL, SVt_PVIO, SVt_LAST, SVt_LAST, SVt_PVHV, SVt_PVAV};
-#elif PTRSIZE == 4
- /*gp_sv , gp_io , gp_cv , gp_cvgen, gp_rfcnt, gp_hv , gp_av */
- [7] = {SVt_NULL, SVt_PVIO, SVt_LAST, SVt_LAST, SVt_LAST, SVt_PVHV, SVt_PVAV};
-#else
-# error unknown pointer size
-#endif
- svtype svtypevar = (svtype)addtype_to_svtype[PTRPTR2IDX(type)];
+ if (type == SVt_PVHV) {
+ where = (SV **)&GvHV(gv);
+ } else if (type == SVt_PVAV) {
+ where = (SV **)&GvAV(gv);
+ } else if (type == SVt_PVIO) {
+ where = (SV **)&GvIOp(gv);
+ } else {
+ where = &GvSV(gv);
+ }
- assert(PTRPTR2IDX(type) < sizeof(addtype_to_svtype));
- sv = *where = newSV_type(svtypevar);
- if (type == GPe_AV && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA"))
- sv_magic(sv, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
+ if (!*where)
+ {
+ *where = newSV_type(type);
+ if (type == SVt_PVAV && GvNAMELEN(gv) == 3
+ && strnEQ(GvNAME(gv), "ISA", 3))
+ sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
}
- return sv;
+ return gv;
}
GV *
sv_setpvn(GvSV(gv), name, namelen);
#endif
}
- if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv))
+ if (PERLDB_LINE_OR_SAVESRC && !GvAV(gv))
hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile);
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
inlining, or C<gv> is a placeholder reference that would be promoted to such
a typeglob, then returns the value returned by the sub. Otherwise, returns
-NULL.
+C<NULL>.
=cut
*/
if (SvTYPE(gv) == SVt_PVGV)
return cv_const_sv(GvCVu(gv));
- return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV ? SvRV(gv) : NULL;
+ return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV && SvTYPE(SvRV(gv)) != SVt_PVCV ? SvRV(gv) : NULL;
}
GP *
Converts a scalar into a typeglob. This is an incoercible typeglob;
assigning a reference to it will assign to one of its slots, instead of
-overwriting it as happens with typeglobs created by SvSetSV. Converting
-any scalar that is SvOK() may produce unpredictable results and is reserved
+overwriting it as happens with typeglobs created by C<SvSetSV>. Converting
+any scalar that is C<SvOK()> may produce unpredictable results and is reserved
for perl's internal use.
C<gv> is the scalar to be converted.
passed to this function matches the name of the element. If it does not
match, perl's internal bookkeeping will get out of sync.
-C<flags> can be set to SVf_UTF8 if C<name> is a UTF8 string, or
+C<flags> can be set to C<SVf_UTF8> if C<name> is a UTF-8 string, or
the return value of SvUTF8(sv). It can also take the
-GV_ADDMULTI flag, which means to pretend that the GV has been
+C<GV_ADDMULTI> flag, which means to pretend that the GV has been
seen before (i.e., suppress "Used once" warnings).
=for apidoc gv_init
-The old form of gv_init_pvn(). It does not work with UTF8 strings, as it
+The old form of C<gv_init_pvn()>. It does not work with UTF-8 strings, as it
has no flags parameter. If the C<multi> parameter is set, the
-GV_ADDMULTI flag will be passed to gv_init_pvn().
+C<GV_ADDMULTI> flag will be passed to C<gv_init_pvn()>.
=for apidoc gv_init_pv
-Same as gv_init_pvn(), but takes a nul-terminated string for the name
+Same as C<gv_init_pvn()>, but takes a nul-terminated string for the name
instead of separate char * and length parameters.
=for apidoc gv_init_sv
-Same as gv_init_pvn(), but takes an SV * for the name instead of separate
+Same as C<gv_init_pvn()>, but takes an SV * for the name instead of separate
char * and length parameters. C<flags> is currently unused.
=cut
STATIC void
S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
{
- Size_t addtype;
-#define SGVINIT_SKIP 0xFF
+ PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
+
+ switch (sv_type) {
+ case SVt_PVIO:
+ (void)GvIOn(gv);
+ break;
+ case SVt_PVAV:
+ (void)GvAVn(gv);
+ break;
+ case SVt_PVHV:
+ (void)GvHVn(gv);
+ break;
#ifdef PERL_DONT_CREATE_GVSV
-# define SGVINIT_SV GPe_SV
-#else
-# define SGVINIT_SV SGVINIT_SKIP
+ case SVt_NULL:
+ case SVt_PVCV:
+ case SVt_PVFM:
+ case SVt_PVGV:
+ break;
+ default:
+ if(GvSVn(gv)) {
+ /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
+ If we just cast GvSVn(gv) to void, it ignores evaluating it for
+ its side effect */
+ }
#endif
- static const U8 svtype2add [] = {
- /*SVt_NULL, 0 */
- SGVINIT_SKIP,
- /*SVt_IV, 1 */
- SGVINIT_SV,
- /*SVt_NV, 2 */
- SGVINIT_SV,
- /*SVt_PV, 3 */
- SGVINIT_SV,
- /*SVt_INVLIST, 4 implemented as a PV */
- SGVINIT_SV,
- /*SVt_PVIV, 5 */
- SGVINIT_SV,
- /*SVt_PVNV, 6 */
- SGVINIT_SV,
- /*SVt_PVMG, 7 */
- SGVINIT_SV,
- /*SVt_REGEXP, 8 */
- SGVINIT_SV,
- /*SVt_PVGV, 9 */
- SGVINIT_SKIP,
- /*SVt_PVLV, 10 */
- SGVINIT_SV,
- /*SVt_PVAV, 11 */
- GPe_AV,
- /*SVt_PVHV, 12 */
- GPe_HV,
- /*SVt_PVCV, 13 */
- SGVINIT_SKIP,
- /*SVt_PVFM, 14 */
- SGVINIT_SKIP,
- /*SVt_PVIO, 15 */
- GPe_IO,
- /*SVt_LAST keep last in enum. used to size arrays */
- /* invalid, this is slot 0x10, dont define it so this array is
- a nice 16 bytes long */
- };
- PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
- addtype = svtype2add[sv_type];
- if(addtype != SGVINIT_SKIP) {
- SV ** where = (SV **)((Size_t)GvGP(gv)+ addtype);
- if (!*where)
- gv_add_by_type_p(gv, (gv_add_type)addtype);
- }
- return;
-#undef SGVINIT_SV
-#undef SGVINIT_SKIP
+ }
}
static void core_xsub(pTHX_ CV* cv);
}
CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
from PL_curcop. */
- (void)gv_fetchfile(file);
+ /* XSUBs can't be perl lang/perl5db.pl debugged
+ if (PERLDB_LINE_OR_SAVESRC)
+ (void)gv_fetchfile(file); */
CvFILE(cv) = (char *)file;
/* XXX This is inefficient, as doing things this order causes
a prototype check in newATTRSUB. But we have to do
Returns the glob with the given C<name> and a defined subroutine or
C<NULL>. The glob lives in the given C<stash>, or in the stashes
-accessible via @ISA and UNIVERSAL::.
+accessible via C<@ISA> and C<UNIVERSAL::>.
The argument C<level> should be either 0 or -1. If C<level==0>, as a
side-effect creates a glob with the given C<name> in the given C<stash>
which in the case of success contains an alias for the subroutine, and sets
up caching info for this glob.
-The only significant values for C<flags> are GV_SUPER and SVf_UTF8.
+The only significant values for C<flags> are C<GV_SUPER> and C<SVf_UTF8>.
-GV_SUPER indicates that we want to look up the method in the superclasses
+C<GV_SUPER> indicates that we want to look up the method in the superclasses
of the C<stash>.
The
/*
=for apidoc gv_fetchmeth_pvn_autoload
-Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too.
+Same as C<gv_fetchmeth_pvn()>, but looks for autoloaded subroutines too.
Returns a glob for the subroutine.
For an autoloaded subroutine without a GV, will create a GV even
-if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
+if C<level < 0>. For an autoloaded subroutine without a stub, C<GvCV()>
of the result may be zero.
-Currently, the only significant value for C<flags> is SVf_UTF8.
+Currently, the only significant value for C<flags> is C<SVf_UTF8>.
=cut
*/
Returns the glob which contains the subroutine to call to invoke the method
on the C<stash>. In fact in the presence of autoloading this may be the
-glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
+glob for "AUTOLOAD". In this case the corresponding variable C<$AUTOLOAD> is
already setup.
The third parameter of C<gv_fetchmethod_autoload> determines whether
as a prefix of the method name. Note
that if you want to keep the returned glob for a long time, you need to
check for it being "AUTOLOAD", since at the later time the call may load a
-different subroutine due to $AUTOLOAD changing its value. Use the glob
+different subroutine due to C<$AUTOLOAD> changing its value. Use the glob
created as a side effect to do this.
These functions have the same side-effects as C<gv_fetchmeth> with
parameter indicates the length of the C<name>, in bytes. C<flags> is passed
to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
created if it does not already exist. If the package does not exist and
-C<flags> is 0 (or any other setting that does not create packages) then NULL
+C<flags> is 0 (or any other setting that does not create packages) then C<NULL>
is returned.
Flags may be one of:
GV_NOEXPAND
GV_ADDMG
-The most important of which are probably GV_ADD and SVf_UTF8.
+The most important of which are probably C<GV_ADD> and C<SVf_UTF8>.
Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
recommended for performance reasons.
tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
- if (!tmpgv)
+ if (!tmpgv || !isGV_with_GP(tmpgv))
return NULL;
stash = GvHV(tmpgv);
if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
Requires one of either namesv or namepv to be non-null.
-See C<gv_stashpvn> for details on "flags".
+See C<L</gv_stashpvn>> for details on "flags".
Note the sv interface is strongly preferred for performance reasons.
/*
=for apidoc gv_stashsv
-Returns a pointer to the stash for a specified package. See C<gv_stashpvn>.
+Returns a pointer to the stash for a specified package. See
+C<L</gv_stashpvn>>.
-Note this interface is strongly preferred over C<gv_stashpvn> for performance reasons.
+Note this interface is strongly preferred over C<gv_stashpvn> for performance
+reasons.
=cut
*/
case '\027': /* $^WARNING_BITS */
if (strEQ(name2, "ARNING_BITS"))
goto magicalize;
+#ifdef WIN32
+ else if (strEQ(name2, "IN32_SLOPPY_STAT"))
+ goto magicalize;
+#endif
break;
case '1':
case '2':
{
/* Ensures that we have an all-digit variable, ${"1foo"} fails
this test */
- /* This snippet is taken from is_gv_magical */
- const char *end = name + len;
- while (--end > name) {
- if (!isDIGIT(*end))
- return addmg;
- }
- paren = grok_atou(name, NULL);
+ UV uv;
+ if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX)
+ return addmg;
+ /* XXX why are we using a SSize_t? */
+ paren = (SSize_t)(I32)uv;
goto storeparen;
}
}
Somehow gp->gp_hv can end up pointing at freed garbage. */
if (hv && SvTYPE(hv) == SVt_PVHV) {
const HEK *hvname_hek = HvNAME_HEK(hv);
- DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", HEKfARG(hvname_hek)));
- if (PL_stashcache && hvname_hek)
+ if (PL_stashcache && hvname_hek) {
+ DEBUG_o(Perl_deb(aTHX_
+ "gp_free clearing PL_stashcache for '%"HEKf"'\n",
+ HEKfARG(hvname_hek)));
(void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
+ }
SvREFCNT_dec(hv);
}
if (io && SvREFCNT(io) == 1 && IoIFP(io)
SvGETMAGIC(arg);
if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
- AMGf_noright | AMGf_unary))) {
+ AMGf_noright | AMGf_unary
+ | (flags & AMGf_numarg))))
+ {
if (flags & AMGf_set) {
SETs(tmpsv);
}
if (SvAMAGIC(left) || SvAMAGIC(right)) {
SV * const tmpsv = amagic_call(left, right, method,
- ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
+ ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0)
+ | (flags & AMGf_numarg));
if (tmpsv) {
if (flags & AMGf_set) {
(void)POPs;
case band_amg:
case bor_amg:
case bxor_amg:
+ case sband_amg:
+ case sbor_amg:
+ case sbxor_amg:
if (assign)
force_scalar = 1;
break;
PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
AMG_id2namelen(method + assignshift), SVs_TEMP));
}
+ else if (flags & AMGf_numarg)
+ PUSHs(&PL_sv_undef);
+ if (flags & AMGf_numarg)
+ PUSHs(&PL_sv_yes);
PUSHs(MUTABLE_SV(cv));
PUTBACK;
oldmark = TOPMARK;
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff