/* gv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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.
GV *
Perl_gv_IOadd(pTHX_ register GV *gv)
{
- if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
- Perl_croak(aTHX_ "Bad symbol for filehandle");
+ dVAR;
+ if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) {
+
+ /*
+ * if it walks like a dirhandle, then let's assume that
+ * this is a dirhandle.
+ */
+ const char *fh = PL_op->op_type == OP_READDIR ||
+ PL_op->op_type == OP_TELLDIR ||
+ PL_op->op_type == OP_SEEKDIR ||
+ PL_op->op_type == OP_REWINDDIR ||
+ PL_op->op_type == OP_CLOSEDIR ?
+ "dirhandle" : "filehandle";
+ Perl_croak(aTHX_ "Bad symbol for %s", fh);
+ }
+
if (!GvIOp(gv)) {
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE(gv)) {
GV *
Perl_gv_fetchfile(pTHX_ const char *name)
{
+ dVAR;
char smallbuf[256];
char *tmpbuf;
STRLEN tmplen;
return gv;
}
+/*
+=for apidoc gv_const_sv
+
+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.
+
+=cut
+*/
+
+SV *
+Perl_gv_const_sv(pTHX_ GV *gv)
+{
+ if (SvTYPE(gv) == SVt_PVGV)
+ return cv_const_sv(GvCVu(gv));
+ return SvROK(gv) ? SvRV(gv) : NULL;
+}
+
void
Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
{
register GP *gp;
const bool doproto = SvTYPE(gv) > SVt_NULL;
const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL;
+ SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
+
+ assert (!(proto && has_constant));
+
+ if (has_constant) {
+ /* The constant has to be a simple scalar type. */
+ switch (SvTYPE(has_constant)) {
+ case SVt_PVAV:
+ case SVt_PVHV:
+ case SVt_PVCV:
+ case SVt_PVFM:
+ case SVt_PVIO:
+ Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
+ sv_reftype(has_constant, 0));
+ }
+ SvRV_set(gv, NULL);
+ SvROK_off(gv);
+ }
sv_upgrade((SV*)gv, SVt_PVGV);
if (SvLEN(gv)) {
Newxz(gp, 1, GP);
GvGP(gv) = gp_ref(gp);
#ifdef PERL_DONT_CREATE_GVSV
- GvSV(gv) = 0;
+ GvSV(gv) = NULL;
#else
GvSV(gv) = NEWSV(72,0);
#endif
if (doproto) { /* Replicate part of newSUB here. */
SvIOK_off(gv);
ENTER;
- /* XXX unsafe for threads if eval_owner isn't held */
- start_subparse(0,0); /* Create CV in compcv. */
- GvCV(gv) = PL_compcv;
+ if (has_constant) {
+ /* newCONSTSUB takes ownership of the reference from us. */
+ GvCV(gv) = newCONSTSUB(stash, name, has_constant);
+ } else {
+ /* XXX unsafe for threads if eval_owner isn't held */
+ (void) start_subparse(0,0); /* Create empty CV in compcv. */
+ GvCV(gv) = PL_compcv;
+ }
LEAVE;
PL_sub_generation++;
GV *
Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
{
+ dVAR;
AV* av;
GV* topgv;
GV* gv;
/* UNIVERSAL methods should be callable without a stash */
if (!stash) {
level = -1; /* probably appropriate */
- if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
+ if(!(stash = gv_stashpvs("UNIVERSAL", FALSE)))
return 0;
}
}
gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
- av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
+ av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
/* create and re-create @.*::SUPER::ISA on demand */
if (!av || !SvMAGIC(av)) {
/* NOTE: No support for tied ISA */
I32 items = AvFILLp(av) + 1;
while (items--) {
- SV* sv = *svp++;
- HV* basestash = gv_stashsv(sv, FALSE);
+ SV* const sv = *svp++;
+ HV* const basestash = gv_stashsv(sv, FALSE);
if (!basestash) {
if (ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
/* if at top level, try UNIVERSAL */
if (level == 0 || level == -1) {
- HV* lastchance;
+ HV* const lastchance = gv_stashpvs("UNIVERSAL", FALSE);
- if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
+ if (lastchance) {
if ((gv = gv_fetchmeth(lastchance, name, len,
(level >= 0) ? level + 1 : level - 1)))
{
}
/*
-=for apidoc gv_fetchmethod
-
-See L<gv_fetchmethod_autoload>.
-
-=cut
-*/
-
-GV *
-Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
-{
- return gv_fetchmethod_autoload(stash, name, TRUE);
-}
-
-/*
=for apidoc gv_fetchmethod_autoload
Returns the glob which contains the subroutine to call to invoke the method
GV *
Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
{
+ dVAR;
register const char *nend;
- const char *nsplit = 0;
+ const char *nsplit = NULL;
GV* gv;
HV* ostash = stash;
if (stash && SvTYPE(stash) < SVt_PVHV)
- stash = Nullhv;
+ stash = NULL;
for (nend = name; *nend; nend++) {
if (*nend == '\'')
if (stash) {
if (SvTYPE(stash) < SVt_PVHV) {
packname = SvPV_const((SV*)stash, packname_len);
- stash = Nullhv;
+ stash = NULL;
}
else {
packname = HvNAME_get(stash);
LEAVE;
varsv = GvSVn(vargv);
sv_setpvn(varsv, packname, packname_len);
- sv_catpvn(varsv, "::", 2);
+ sv_catpvs(varsv, "::");
sv_catpvn(varsv, name, len);
SvTAINTED_off(varsv);
return gv;
S_require_errno(pTHX_ GV *gv)
{
dVAR;
- HV* stash = gv_stashpvn("Errno",5,FALSE);
+ HV* stash = gv_stashpvs("Errno", FALSE);
if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
dSP;
ENTER;
save_scalar(gv); /* keep the value of $! */
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvn("Errno",5), Nullsv);
+ newSVpvs("Errno"), Nullsv);
LEAVE;
SPAGAIN;
- stash = gv_stashpvn("Errno",5,FALSE);
+ stash = gv_stashpvs("Errno", FALSE);
if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
}
HV*
Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
{
- char smallbuf[256];
+ char smallbuf[128];
char *tmpbuf;
HV *stash;
GV *tmpgv;
tmpbuf[namelen++] = ':';
tmpbuf[namelen++] = ':';
tmpbuf[namelen] = '\0';
- tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
+ tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, create, SVt_PVHV);
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
if (!tmpgv)
GvHV(tmpgv) = newHV();
stash = GvHV(tmpgv);
if (!HvNAME_get(stash))
- Perl_hv_name_set(aTHX_ stash, name, namelen, 0);
+ hv_name_set(stash, name, namelen, 0);
return stash;
}
Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
I32 sv_type)
{
+ dVAR;
register const char *name = nambeg;
- register GV *gv = 0;
+ register GV *gv = NULL;
GV**gvp;
I32 len;
register const char *namend;
- HV *stash = 0;
- const I32 add = flags & ~SVf_UTF8;
+ HV *stash = NULL;
+ const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
+ const I32 no_expand = flags & GV_NOEXPAND;
+ const I32 add = flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND;
PERL_UNUSED_ARG(full_len);
len = namend - name;
if (len > 0) {
- char smallbuf[256];
+ char smallbuf[128];
char *tmpbuf;
if (len + 3 < sizeof (smallbuf))
stash = GvHV(gv) = newHV();
if (!HvNAME_get(stash))
- Perl_hv_name_set(aTHX_ stash, nambeg, namend - nambeg, 0);
+ hv_name_set(stash, nambeg, namend - nambeg, 0);
}
if (*namend == ':')
if (USE_UTF8_IN_NAMES)
SvUTF8_on(err);
qerror(err);
- stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
+ stash = GvHV(gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV));
}
else
return Nullgv;
require_errno(gv);
}
return gv;
- } else if (add & GV_NOINIT) {
+ } else if (no_init) {
+ return gv;
+ } else if (no_expand && SvROK(gv)) {
return gv;
}
hv = GvHVn(gv);
hv_magic(hv, Nullgv, PERL_MAGIC_sig);
for (i = 1; i < SIG_SIZE; i++) {
- SV ** const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
+ SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
if (init)
sv_setsv(*init, &PL_sv_undef);
PL_psig_ptr[i] = 0;
{
SV * const sv = GvSVn(gv);
if (!sv_derived_from(PL_patchlevel, "version"))
- (void *)upg_version(PL_patchlevel);
+ upg_version(PL_patchlevel);
GvSV(gv) = vnumify(PL_patchlevel);
SvREADONLY_on(GvSV(gv));
SvREFCNT_dec(sv);
if (keepmain || strNE(name, "main")) {
sv_catpvn(sv,name,namelen);
- sv_catpvn(sv,"::", 2);
+ sv_catpvs(sv,"::");
}
sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
}
void
-Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
-{
- gv_fullname4(sv, gv, prefix, TRUE);
-}
-
-void
Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
{
const GV * const egv = GvEGV(gv);
gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
}
-void
-Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
-{
- gv_efullname4(sv, gv, prefix, TRUE);
-}
-
-/* compatibility with versions <= 5.003. */
-void
-Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
-{
- gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
-}
-
-/* compatibility with versions <= 5.003. */
-void
-Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
-{
- gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
-}
-
IO *
Perl_newIO(pTHX)
{
+ dVAR;
GV *iogv;
IO * const io = (IO*)NEWSV(0,0);
sv_upgrade((SV *)io,SVt_PVIO);
- SvREFCNT(io) = 1;
+ /* This used to read SvREFCNT(io) = 1;
+ It's not clear why the reference count needed an explicit reset. NWC
+ */
+ assert (SvREFCNT(io) == 1);
SvOBJECT_on(io);
/* Clear the stashcache because a new IO could overrule a package name */
hv_clear(PL_stashcache);
- iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
+ iogv = gv_fetchpvn_flags("FileHandle::", 12, 0, SVt_PVHV);
/* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
- iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
+ iogv = gv_fetchpvn_flags("IO::Handle::", 12, TRUE, SVt_PVHV);
SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
return io;
}
void
Perl_gv_check(pTHX_ HV *stash)
{
+ dVAR;
register I32 i;
if (!HvARRAY(stash))
file = GvFILE(gv);
/* performance hack: if filename is absolute and it's a standard
* module, don't bother warning */
- if (file
- && PERL_FILE_IS_ABSOLUTE(file)
#ifdef MACOS_TRADITIONAL
- && (instr(file, ":lib:")
+# define LIB_COMPONENT ":lib:"
#else
- && (instr(file, "/lib/")
+# define LIB_COMPONENT "/lib/"
#endif
- || instr(file, ".pm")))
+ if (file
+ && PERL_FILE_IS_ABSOLUTE(file)
+ && (instr(file, LIB_COMPONENT) || instr(file, ".pm")))
{
continue;
}
GV *
Perl_newGVgen(pTHX_ const char *pack)
{
+ dVAR;
return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
TRUE, SVt_PVGV);
}
GP*
Perl_gp_ref(pTHX_ GP *gp)
{
+ dVAR;
if (!gp)
return (GP*)NULL;
gp->gp_refcnt++;
void
Perl_gp_free(pTHX_ GV *gv)
{
+ dVAR;
GP* gp;
if (!gv || !(gp = GvGP(gv)))
bool
Perl_Gv_AMupdate(pTHX_ HV *stash)
{
+ dVAR;
MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
AMT amt;
CV*
Perl_gv_handler(pTHX_ HV *stash, I32 id)
{
+ dVAR;
MAGIC *mg;
AMT *amtp;
https://perl5.git.perl.org / perl5.git / blobdiff