avoid nonportable example code

[p5sagit/p5-mst-13.2.git] / gv.c

/*    gv.c
 *
 *    Copyright (c) 1991-2000, Larry Wall
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

/*
 *   'Mercy!' cried Gandalf.  'If the giving of information is to be the cure
 * of your inquisitiveness, I shall spend all the rest of my days answering
 * you.  What more do you want to know?'
 *   'The names of all the stars, and of all living things, and the whole
 * history of Middle-earth and Over-heaven and of the Sundering Seas,'
 * laughed Pippin.
 */

#include "EXTERN.h"
#define PERL_IN_GV_C
#include "perl.h"

GV *
Perl_gv_AVadd(pTHX_ register GV *gv)
{
    if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
	Perl_croak(aTHX_ "Bad symbol for array");
    if (!GvAV(gv))
	GvAV(gv) = newAV();
    return gv;
}

GV *
Perl_gv_HVadd(pTHX_ register GV *gv)
{
    if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
	Perl_croak(aTHX_ "Bad symbol for hash");
    if (!GvHV(gv))
	GvHV(gv) = newHV();
    return gv;
}

GV *
Perl_gv_IOadd(pTHX_ register GV *gv)
{
    if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
	Perl_croak(aTHX_ "Bad symbol for filehandle");
    if (!GvIOp(gv))
	GvIOp(gv) = newIO();
    return gv;
}

GV *
Perl_gv_fetchfile(pTHX_ const char *name)
{
    dTHR;
    char smallbuf[256];
    char *tmpbuf;
    STRLEN tmplen;
    GV *gv;

    if (!PL_defstash)
	return Nullgv;

    tmplen = strlen(name) + 2;
    if (tmplen < sizeof smallbuf)
	tmpbuf = smallbuf;
    else
	New(603, tmpbuf, tmplen + 1, char);
    tmpbuf[0] = '_';
    tmpbuf[1] = '<';
    strcpy(tmpbuf + 2, name);
    gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
    if (!isGV(gv)) {
	gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
	sv_setpv(GvSV(gv), name);
	if (PERLDB_LINE)
	    hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, 'L');
    }
    if (tmpbuf != smallbuf)
	Safefree(tmpbuf);
    return gv;
}

void
Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
{
    dTHR;
    register GP *gp;
    bool doproto = SvTYPE(gv) > SVt_NULL;
    char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;

    sv_upgrade((SV*)gv, SVt_PVGV);
    if (SvLEN(gv)) {
	if (proto) {
	    SvPVX(gv) = NULL;
	    SvLEN(gv) = 0;
	    SvPOK_off(gv);
	} else
	    Safefree(SvPVX(gv));
    }
    Newz(602, gp, 1, GP);
    GvGP(gv) = gp_ref(gp);
    GvSV(gv) = NEWSV(72,0);
    GvLINE(gv) = CopLINE(PL_curcop);
    GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
    GvCVGEN(gv) = 0;
    GvEGV(gv) = gv;
    sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0);
    GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
    GvNAME(gv) = savepvn(name, len);
    GvNAMELEN(gv) = len;
    if (multi || doproto)              /* doproto means it _was_ mentioned */
	GvMULTI_on(gv);
    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;
	LEAVE;

	PL_sub_generation++;
	CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv);
	CvFILE(GvCV(gv)) = CopFILE(PL_curcop);
	CvSTASH(GvCV(gv)) = PL_curstash;
#ifdef USE_THREADS
	CvOWNER(GvCV(gv)) = 0;
	if (!CvMUTEXP(GvCV(gv))) {
	    New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
	    MUTEX_INIT(CvMUTEXP(GvCV(gv)));
	}
#endif /* USE_THREADS */
	if (proto) {
	    sv_setpv((SV*)GvCV(gv), proto);
	    Safefree(proto);
	}
    }
}

STATIC void
S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
{
    switch (sv_type) {
    case SVt_PVIO:
	(void)GvIOn(gv);
	break;
    case SVt_PVAV:
	(void)GvAVn(gv);
	break;
    case SVt_PVHV:
	(void)GvHVn(gv);
	break;
    }
}

/*
=for apidoc gv_fetchmeth

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.

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.  Similarly for all the searched stashes.

This function grants C<"SUPER"> token as a postfix of the stash name. The
GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
visible to Perl code.  So when calling C<call_sv>, you should not use
the GV directly; instead, you should use the method's CV, which can be
obtained from the GV with the C<GvCV> macro.

=cut
*/

GV *
Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
{
    AV* av;
    GV* topgv;
    GV* gv;
    GV** gvp;
    CV* cv;

    if (!stash)
	return 0;
    if ((level > 100) || (level < -100))
	Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
	      name, HvNAME(stash));

    DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );

    gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
    if (!gvp)
	topgv = Nullgv;
    else {
	topgv = *gvp;
	if (SvTYPE(topgv) != SVt_PVGV)
	    gv_init(topgv, stash, name, len, TRUE);
	if ((cv = GvCV(topgv))) {
	    /* If genuine method or valid cache entry, use it */
	    if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
		return topgv;
	    /* Stale cached entry: junk it */
	    SvREFCNT_dec(cv);
	    GvCV(topgv) = cv = Nullcv;
	    GvCVGEN(topgv) = 0;
	}
	else if (GvCVGEN(topgv) == PL_sub_generation)
	    return 0;  /* cache indicates sub doesn't exist */
    }

    gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
    av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;

    /* create and re-create @.*::SUPER::ISA on demand */
    if (!av || !SvMAGIC(av)) {
	char* packname = HvNAME(stash);
	STRLEN packlen = strlen(packname);

	if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
	    HV* basestash;

	    packlen -= 7;
	    basestash = gv_stashpvn(packname, packlen, TRUE);
	    gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
	    if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
		dTHR;		/* just for SvREFCNT_dec */
		gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
		if (!gvp || !(gv = *gvp))
		    Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
		if (SvTYPE(gv) != SVt_PVGV)
		    gv_init(gv, stash, "ISA", 3, TRUE);
		SvREFCNT_dec(GvAV(gv));
		GvAV(gv) = (AV*)SvREFCNT_inc(av);
	    }
	}
    }

    if (av) {
	SV** svp = AvARRAY(av);
	/* NOTE: No support for tied ISA */
	I32 items = AvFILLp(av) + 1;
	while (items--) {
	    SV* sv = *svp++;
	    HV* basestash = gv_stashsv(sv, FALSE);
	    if (!basestash) {
		dTHR;		/* just for ckWARN */
		if (ckWARN(WARN_MISC))
		    Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA",
			SvPVX(sv), HvNAME(stash));
		continue;
	    }
	    gv = gv_fetchmeth(basestash, name, len,
			      (level >= 0) ? level + 1 : level - 1);
	    if (gv)
		goto gotcha;
	}
    }

    /* if at top level, try UNIVERSAL */

    if (level == 0 || level == -1) {
	HV* lastchance;

	if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
	    if ((gv = gv_fetchmeth(lastchance, name, len,
				  (level >= 0) ? level + 1 : level - 1)))
	    {
	  gotcha:
		/*
		 * Cache method in topgv if:
		 *  1. topgv has no synonyms (else inheritance crosses wires)
		 *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
		 */
		if (topgv &&
		    GvREFCNT(topgv) == 1 &&
		    (cv = GvCV(gv)) &&
		    (CvROOT(cv) || CvXSUB(cv)))
		{
		    if ((cv = GvCV(topgv)))
			SvREFCNT_dec(cv);
		    GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
		    GvCVGEN(topgv) = PL_sub_generation;
		}
		return gv;
	    }
	    else if (topgv && GvREFCNT(topgv) == 1) {
		/* cache the fact that the method is not defined */
		GvCVGEN(topgv) = PL_sub_generation;
	    }
	}
    }

    return 0;
}

/*
=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
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
already setup.

The third parameter of C<gv_fetchmethod_autoload> determines whether
AUTOLOAD lookup is performed if the given method is not present: non-zero
means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
with a non-zero C<autoload> parameter.

These functions grant C<"SUPER"> token 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
created via a side effect to do this.

These functions have the same side-effects and as C<gv_fetchmeth> with
C<level==0>.  C<name> should be writable if contains C<':'> or C<'
''>. The warning against passing the GV returned by C<gv_fetchmeth> to
C<call_sv> apply equally to these functions.

=cut
*/

GV *
Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
{
    dTHR;
    register const char *nend;
    const char *nsplit = 0;
    GV* gv;

    for (nend = name; *nend; nend++) {
	if (*nend == '\'')
	    nsplit = nend;
	else if (*nend == ':' && *(nend + 1) == ':')
	    nsplit = ++nend;
    }
    if (nsplit) {
	const char *origname = name;
	name = nsplit + 1;
	if (*nsplit == ':')
	    --nsplit;
	if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
	    /* ->SUPER::method should really be looked up in original stash */
	    SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
						  CopSTASHPV(PL_curcop)));
	    stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
	    DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
			 origname, HvNAME(stash), name) );
	}
	else
	    stash = gv_stashpvn(origname, nsplit - origname, TRUE);
    }

    gv = gv_fetchmeth(stash, name, nend - name, 0);
    if (!gv) {
	if (strEQ(name,"import") || strEQ(name,"unimport"))
	    gv = (GV*)&PL_sv_yes;
	else if (autoload)
	    gv = gv_autoload4(stash, name, nend - name, TRUE);
    }
    else if (autoload) {
	CV* cv = GvCV(gv);
	if (!CvROOT(cv) && !CvXSUB(cv)) {
	    GV* stubgv;
	    GV* autogv;

	    if (CvANON(cv))
		stubgv = gv;
	    else {
		stubgv = CvGV(cv);
		if (GvCV(stubgv) != cv)		/* orphaned import */
		    stubgv = gv;
	    }
	    autogv = gv_autoload4(GvSTASH(stubgv),
				  GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
	    if (autogv)
		gv = autogv;
	}
    }

    return gv;
}

GV*
Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
{
    dTHR;
    static char autoload[] = "AUTOLOAD";
    static STRLEN autolen = 8;
    GV* gv;
    CV* cv;
    HV* varstash;
    GV* vargv;
    SV* varsv;

    if (len == autolen && strnEQ(name, autoload, autolen))
	return Nullgv;
    if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
	return Nullgv;
    cv = GvCV(gv);

    if (!CvROOT(cv))
	return Nullgv;

    /*
     * Inheriting AUTOLOAD for non-methods works ... for now.
     */
    if (ckWARN(WARN_DEPRECATED) && !method &&
	(GvCVGEN(gv) || GvSTASH(gv) != stash))
	Perl_warner(aTHX_ WARN_DEPRECATED,
	  "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
	     HvNAME(stash), (int)len, name);

    /*
     * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
     * The subroutine's original name may not be "AUTOLOAD", so we don't
     * use that, but for lack of anything better we will use the sub's
     * original package to look up $AUTOLOAD.
     */
    varstash = GvSTASH(CvGV(cv));
    vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
    ENTER;

#ifdef USE_THREADS
    sv_lock((SV *)varstash);
#endif
    if (!isGV(vargv))
	gv_init(vargv, varstash, autoload, autolen, FALSE);
    LEAVE;
    varsv = GvSV(vargv);
#ifdef USE_THREADS
    sv_lock(varsv);
#endif
    sv_setpv(varsv, HvNAME(stash));
    sv_catpvn(varsv, "::", 2);
    sv_catpvn(varsv, name, len);
    SvTAINTED_off(varsv);
    return gv;
}

/*
=for apidoc gv_stashpv

Returns a pointer to the stash for a specified package.  C<name> should
be a valid UTF-8 string.  If C<create> is set then the package will be
created if it does not already exist.  If C<create> is not set and the
package does not exist then NULL is returned.

=cut
*/

HV*
Perl_gv_stashpv(pTHX_ const char *name, I32 create)
{
    return gv_stashpvn(name, strlen(name), create);
}

HV*
Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
{
    char smallbuf[256];
    char *tmpbuf;
    HV *stash;
    GV *tmpgv;

    if (namelen + 3 < sizeof smallbuf)
	tmpbuf = smallbuf;
    else
	New(606, tmpbuf, namelen + 3, char);
    Copy(name,tmpbuf,namelen,char);
    tmpbuf[namelen++] = ':';
    tmpbuf[namelen++] = ':';
    tmpbuf[namelen] = '\0';
    tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
    if (tmpbuf != smallbuf)
	Safefree(tmpbuf);
    if (!tmpgv)
	return 0;
    if (!GvHV(tmpgv))
	GvHV(tmpgv) = newHV();
    stash = GvHV(tmpgv);
    if (!HvNAME(stash))
	HvNAME(stash) = savepv(name);
    return stash;
}

/*
=for apidoc gv_stashsv

Returns a pointer to the stash for a specified package, which must be a
valid UTF-8 string.  See C<gv_stashpv>.

=cut
*/

HV*
Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
{
    register char *ptr;
    STRLEN len;
    ptr = SvPV(sv,len);
    return gv_stashpvn(ptr, len, create);
}


GV *
Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
{
    dTHR;
    register const char *name = nambeg;
    register GV *gv = 0;
    GV**gvp;
    I32 len;
    register const char *namend;
    HV *stash = 0;

    if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
	name++;

    for (namend = name; *namend; namend++) {
	if ((*namend == ':' && namend[1] == ':')
	    || (*namend == '\'' && namend[1]))
	{
	    if (!stash)
		stash = PL_defstash;
	    if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
		return Nullgv;

	    len = namend - name;
	    if (len > 0) {
		char smallbuf[256];
		char *tmpbuf;

		if (len + 3 < sizeof smallbuf)
		    tmpbuf = smallbuf;
		else
		    New(601, tmpbuf, len+3, char);
		Copy(name, tmpbuf, len, char);
		tmpbuf[len++] = ':';
		tmpbuf[len++] = ':';
		tmpbuf[len] = '\0';
		gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
		gv = gvp ? *gvp : Nullgv;
		if (gv && gv != (GV*)&PL_sv_undef) {
		    if (SvTYPE(gv) != SVt_PVGV)
			gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
		    else
			GvMULTI_on(gv);
		}
		if (tmpbuf != smallbuf)
		    Safefree(tmpbuf);
		if (!gv || gv == (GV*)&PL_sv_undef)
		    return Nullgv;

		if (!(stash = GvHV(gv)))
		    stash = GvHV(gv) = newHV();

		if (!HvNAME(stash))
		    HvNAME(stash) = savepvn(nambeg, namend - nambeg);
	    }

	    if (*namend == ':')
		namend++;
	    namend++;
	    name = namend;
	    if (!*name)
		return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
	}
    }
    len = namend - name;
    if (!len)
	len = 1;

    /* No stash in name, so see how we can default */

    if (!stash) {
	if (isIDFIRST_lazy(name)) {
	    bool global = FALSE;

	    if (isUPPER(*name)) {
		if (*name == 'S' && (
		    strEQ(name, "SIG") ||
		    strEQ(name, "STDIN") ||
		    strEQ(name, "STDOUT") ||
		    strEQ(name, "STDERR")))
		    global = TRUE;
		else if (*name == 'I' && strEQ(name, "INC"))
		    global = TRUE;
		else if (*name == 'E' && strEQ(name, "ENV"))
		    global = TRUE;
		else if (*name == 'A' && (
		  strEQ(name, "ARGV") ||
		  strEQ(name, "ARGVOUT")))
		    global = TRUE;
	    }
	    else if (*name == '_' && !name[1])
		global = TRUE;

	    if (global)
		stash = PL_defstash;
	    else if ((COP*)PL_curcop == &PL_compiling) {
		stash = PL_curstash;
		if (add && (PL_hints & HINT_STRICT_VARS) &&
		    sv_type != SVt_PVCV &&
		    sv_type != SVt_PVGV &&
		    sv_type != SVt_PVFM &&
		    sv_type != SVt_PVIO &&
		    !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
		{
		    gvp = (GV**)hv_fetch(stash,name,len,0);
		    if (!gvp ||
			*gvp == (GV*)&PL_sv_undef ||
			SvTYPE(*gvp) != SVt_PVGV)
		    {
			stash = 0;
		    }
		    else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
			     (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
			     (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
		    {
			Perl_warn(aTHX_ "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);
			stash = 0;
		    }
		}
	    }
	    else
		stash = CopSTASH(PL_curcop);
	}
	else
	    stash = PL_defstash;
    }

    /* By this point we should have a stash and a name */

    if (!stash) {
	if (add) {
	    qerror(Perl_mess(aTHX_
		 "Global symbol \"%s%s\" requires explicit package name",
		 (sv_type == SVt_PV ? "$"
		  : sv_type == SVt_PVAV ? "@"
		  : sv_type == SVt_PVHV ? "%"
		  : ""), name));
	    stash = PL_nullstash;
	}
	else
	    return Nullgv;
    }

    if (!SvREFCNT(stash))	/* symbol table under destruction */
	return Nullgv;

    gvp = (GV**)hv_fetch(stash,name,len,add);
    if (!gvp || *gvp == (GV*)&PL_sv_undef)
	return Nullgv;
    gv = *gvp;
    if (SvTYPE(gv) == SVt_PVGV) {
	if (add) {
	    GvMULTI_on(gv);
	    gv_init_sv(gv, sv_type);
	}
	return gv;
    } else if (add & GV_NOINIT) {
	return gv;
    }

    /* Adding a new symbol */

    if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
	Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
    gv_init(gv, stash, name, len, add & GV_ADDMULTI);
    gv_init_sv(gv, sv_type);

    if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE))
        GvMULTI_on(gv) ;

    /* set up magic where warranted */
    switch (*name) {
    case 'A':
	if (strEQ(name, "ARGV")) {
	    IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
	}
	break;
    case 'E':
	if (strnEQ(name, "EXPORT", 6))
	    GvMULTI_on(gv);
	break;
    case 'I':
	if (strEQ(name, "ISA")) {
	    AV* av = GvAVn(gv);
	    GvMULTI_on(gv);
	    sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
	    /* NOTE: No support for tied ISA */
	    if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
		&& AvFILLp(av) == -1)
	    {
		char *pname;
		av_push(av, newSVpvn(pname = "NDBM_File",9));
		gv_stashpvn(pname, 9, TRUE);
		av_push(av, newSVpvn(pname = "DB_File",7));
		gv_stashpvn(pname, 7, TRUE);
		av_push(av, newSVpvn(pname = "GDBM_File",9));
		gv_stashpvn(pname, 9, TRUE);
		av_push(av, newSVpvn(pname = "SDBM_File",9));
		gv_stashpvn(pname, 9, TRUE);
		av_push(av, newSVpvn(pname = "ODBM_File",9));
		gv_stashpvn(pname, 9, TRUE);
	    }
	}
	break;
    case 'O':
        if (strEQ(name, "OVERLOAD")) {
            HV* hv = GvHVn(gv);
            GvMULTI_on(gv);
            hv_magic(hv, Nullgv, 'A');
        }
        break;
    case 'S':
	if (strEQ(name, "SIG")) {
	    HV *hv;
	    I32 i;
	    if (!PL_psig_ptr) {
		int sig_num[] = { SIG_NUM };
		New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
		New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
	    }
	    GvMULTI_on(gv);
	    hv = GvHVn(gv);
	    hv_magic(hv, Nullgv, 'S');
	    for (i = 1; PL_sig_name[i]; i++) {
	    	SV ** init;
	    	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;
	    	PL_psig_name[i] = 0;
	    }
	}
	break;
    case 'V':
	if (strEQ(name, "VERSION"))
	    GvMULTI_on(gv);
	break;

    case '&':
	if (len > 1)
	    break;
	PL_sawampersand = TRUE;
	goto ro_magicalize;

    case '`':
	if (len > 1)
	    break;
	PL_sawampersand = TRUE;
	goto ro_magicalize;

    case '\'':
	if (len > 1)
	    break;
	PL_sawampersand = TRUE;
	goto ro_magicalize;

    case ':':
	if (len > 1)
	    break;
	sv_setpv(GvSV(gv),PL_chopset);
	goto magicalize;

    case '?':
	if (len > 1)
	    break;
#ifdef COMPLEX_STATUS
	(void)SvUPGRADE(GvSV(gv), SVt_PVLV);
#endif
	goto magicalize;

    case '!':
	if (len > 1)
	    break;
	if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
	    HV* stash = gv_stashpvn("Errno",5,FALSE);
	    if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
		dSP;
		PUTBACK;
		require_pv("Errno.pm");
		SPAGAIN;
		stash = gv_stashpvn("Errno",5,FALSE);
		if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
		    Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
	    }
	}
	goto magicalize;
    case '-':
	if (len > 1)
	    break;
	else {
            AV* av = GvAVn(gv);
            sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
	    SvREADONLY_on(av);
        }
	goto magicalize;
    case '#':
    case '*':
	if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
	    Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
	/* FALL THROUGH */
    case '[':
    case '^':
    case '~':
    case '=':
    case '%':
    case '.':
    case '(':
    case ')':
    case '<':
    case '>':
    case ',':
    case '\\':
    case '/':
    case '|':
    case '\001':	/* $^A */
    case '\003':	/* $^C */
    case '\004':	/* $^D */
    case '\005':	/* $^E */
    case '\006':	/* $^F */
    case '\010':	/* $^H */
    case '\011':	/* $^I, NOT \t in EBCDIC */
    case '\017':	/* $^O */
    case '\020':	/* $^P */
    case '\024':	/* $^T */
	if (len > 1)
	    break;
	goto magicalize;
    case '\023':	/* $^S */
	if (len > 1)
	    break;
	goto ro_magicalize;
    case '\027':	/* $^W & $^WARNING_BITS */
	if (len > 1 && strNE(name, "\027ARNING_BITS")
	    && strNE(name, "\027IDE_SYSTEM_CALLS"))
	    break;
	goto magicalize;

    case '+':
	if (len > 1)
	    break;
	else {
            AV* av = GvAVn(gv);
            sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
	    SvREADONLY_on(av);
        }
	/* FALL THROUGH */
    case '1':
    case '2':
    case '3':
    case '4':
    case '5':
    case '6':
    case '7':
    case '8':
    case '9':
      ro_magicalize:
	SvREADONLY_on(GvSV(gv));
      magicalize:
	sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
	break;

    case '\014':	/* $^L */
	if (len > 1)
	    break;
	sv_setpv(GvSV(gv),"\f");
	PL_formfeed = GvSV(gv);
	break;
    case ';':
	if (len > 1)
	    break;
	sv_setpv(GvSV(gv),"\034");
	break;
    case ']':
	if (len == 1) {
	    SV *sv = GvSV(gv);
	    (void)SvUPGRADE(sv, SVt_PVNV);
	    Perl_sv_setpvf(aTHX_ sv,
#if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
			    "%8.6"
#else
			    "%5.3"
#endif
			    NVff,
			    SvNVX(PL_patchlevel));
	    SvNVX(sv) = SvNVX(PL_patchlevel);
	    SvNOK_on(sv);
	    SvREADONLY_on(sv);
	}
	break;
    case '\026':	/* $^V */
	if (len == 1) {
	    SV *sv = GvSV(gv);
	    GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
	    SvREFCNT_dec(sv);
	}
	break;
    }
    return gv;
}

void
Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
{
    HV *hv = GvSTASH(gv);
    if (!hv) {
	(void)SvOK_off(sv);
	return;
    }
    sv_setpv(sv, prefix ? prefix : "");
    if (keepmain || strNE(HvNAME(hv), "main")) {
	sv_catpv(sv,HvNAME(hv));
	sv_catpvn(sv,"::", 2);
    }
    sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
}

void
Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
{
    HV *hv = GvSTASH(gv);
    if (!hv) {
	(void)SvOK_off(sv);
	return;
    }
    sv_setpv(sv, prefix ? prefix : "");
    sv_catpv(sv,HvNAME(hv));
    sv_catpvn(sv,"::", 2);
    sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
}

void
Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
{
    GV *egv = GvEGV(gv);
    if (!egv)
	egv = gv;
    gv_fullname4(sv, egv, prefix, keepmain);
}

void
Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
{
    GV *egv = GvEGV(gv);
    if (!egv)
	egv = gv;
    gv_fullname3(sv, egv, prefix);
}

/* XXX compatibility with versions <= 5.003. */
void
Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
{
    gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
}

/* XXX compatibility with versions <= 5.003. */
void
Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
{
    gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
}

IO *
Perl_newIO(pTHX)
{
    dTHR;
    IO *io;
    GV *iogv;

    io = (IO*)NEWSV(0,0);
    sv_upgrade((SV *)io,SVt_PVIO);
    SvREFCNT(io) = 1;
    SvOBJECT_on(io);
    iogv = gv_fetchpv("FileHandle::", FALSE, 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);
    SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
    return io;
}

void
Perl_gv_check(pTHX_ HV *stash)
{
    dTHR;
    register HE *entry;
    register I32 i;
    register GV *gv;
    HV *hv;

    if (!HvARRAY(stash))
	return;
    for (i = 0; i <= (I32) HvMAX(stash); i++) {
	for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
	    if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
		(gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
	    {
		if (hv != PL_defstash && hv != stash)
		     gv_check(hv);              /* nested package */
	    }
	    else if (isALPHA(*HeKEY(entry))) {
		char *file;
		gv = (GV*)HeVAL(entry);
		if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
		    continue;
		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)
		    && (instr(file, "/lib/") || instr(file, ".pm")))
		{
		    continue;
		}
		CopLINE_set(PL_curcop, GvLINE(gv));
#ifdef USE_ITHREADS
		CopFILE(PL_curcop) = file;	/* set for warning */
#else
		CopFILEGV(PL_curcop) = gv_fetchfile(file);
#endif
		Perl_warner(aTHX_ WARN_ONCE,
			"Name \"%s::%s\" used only once: possible typo",
			HvNAME(stash), GvNAME(gv));
	    }
	}
    }
}

GV *
Perl_newGVgen(pTHX_ char *pack)
{
    return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
		      TRUE, SVt_PVGV);
}

/* hopefully this is only called on local symbol table entries */

GP*
Perl_gp_ref(pTHX_ GP *gp)
{
    if (!gp)
	return (GP*)NULL;
    gp->gp_refcnt++;
    if (gp->gp_cv) {
	if (gp->gp_cvgen) {
	    /* multi-named GPs cannot be used for method cache */
	    SvREFCNT_dec(gp->gp_cv);
	    gp->gp_cv = Nullcv;
	    gp->gp_cvgen = 0;
	}
	else {
	    /* Adding a new name to a subroutine invalidates method cache */
	    PL_sub_generation++;
	}
    }
    return gp;
}

void
Perl_gp_free(pTHX_ GV *gv)
{
    dTHR;
    GP* gp;

    if (!gv || !(gp = GvGP(gv)))
	return;
    if (gp->gp_refcnt == 0) {
	if (ckWARN_d(WARN_INTERNAL))
	    Perl_warner(aTHX_ WARN_INTERNAL,
			"Attempt to free unreferenced glob pointers");
        return;
    }
    if (gp->gp_cv) {
	/* Deleting the name of a subroutine invalidates method cache */
	PL_sub_generation++;
    }
    if (--gp->gp_refcnt > 0) {
	if (gp->gp_egv == gv)
	    gp->gp_egv = 0;
        return;
    }

    SvREFCNT_dec(gp->gp_sv);
    SvREFCNT_dec(gp->gp_av);
    SvREFCNT_dec(gp->gp_hv);
    SvREFCNT_dec(gp->gp_io);
    SvREFCNT_dec(gp->gp_cv);
    SvREFCNT_dec(gp->gp_form);

    Safefree(gp);
    GvGP(gv) = 0;
}

#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
#define MICROPORT
#endif

#ifdef	MICROPORT	/* Microport 2.4 hack */
AV *GvAVn(gv)
register GV *gv;
{
    if (GvGP(gv)->gp_av)
	return GvGP(gv)->gp_av;
    else
	return GvGP(gv_AVadd(gv))->gp_av;
}

HV *GvHVn(gv)
register GV *gv;
{
    if (GvGP(gv)->gp_hv)
	return GvGP(gv)->gp_hv;
    else
	return GvGP(gv_HVadd(gv))->gp_hv;
}
#endif			/* Microport 2.4 hack */

/* Updates and caches the CV's */

bool
Perl_Gv_AMupdate(pTHX_ HV *stash)
{
  dTHR;
  GV* gv;
  CV* cv;
  MAGIC* mg=mg_find((SV*)stash,'c');
  AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
  AMT amt;
  STRLEN n_a;
#ifdef OVERLOAD_VIA_HASH
  GV** gvp;
  HV* hv;
#endif

  if (mg && amtp->was_ok_am == PL_amagic_generation
      && amtp->was_ok_sub == PL_sub_generation)
      return AMT_AMAGIC(amtp);
  if (amtp && AMT_AMAGIC(amtp)) {	/* Have table. */
    int i;
    for (i=1; i<NofAMmeth; i++) {
      if (amtp->table[i]) {
	SvREFCNT_dec(amtp->table[i]);
      }
    }
  }
  sv_unmagic((SV*)stash, 'c');

  DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );

  amt.was_ok_am = PL_amagic_generation;
  amt.was_ok_sub = PL_sub_generation;
  amt.fallback = AMGfallNO;
  amt.flags = 0;

#ifdef OVERLOAD_VIA_HASH
  gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE);	/* A shortcut */
  if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
    int filled=0;
    int i;
    char *cp;
    SV* sv;
    SV** svp;

    /* Work with "fallback" key, which we assume to be first in PL_AMG_names */

    if (( cp = (char *)PL_AMG_names[0] ) &&
	(svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
      if (SvTRUE(sv)) amt.fallback=AMGfallYES;
      else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
    }
    for (i = 1; i < NofAMmeth; i++) {
      cv = 0;
      cp = (char *)PL_AMG_names[i];

        svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
        if (svp && ((sv = *svp) != &PL_sv_undef)) {
          switch (SvTYPE(sv)) {
            default:
              if (!SvROK(sv)) {
                if (!SvOK(sv)) break;
		gv = gv_fetchmethod(stash, SvPV(sv, n_a));
                if (gv) cv = GvCV(gv);
                break;
              }
              cv = (CV*)SvRV(sv);
              if (SvTYPE(cv) == SVt_PVCV)
                  break;
                /* FALL THROUGH */
            case SVt_PVHV:
            case SVt_PVAV:
	      Perl_croak(aTHX_ "Not a subroutine reference in overload table");
	      return FALSE;
            case SVt_PVCV:
              cv = (CV*)sv;
              break;
            case SVt_PVGV:
              if (!(cv = GvCVu((GV*)sv)))
                cv = sv_2cv(sv, &stash, &gv, FALSE);
              break;
          }
          if (cv) filled=1;
	  else {
	    Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
		cp,HvNAME(stash));
	    return FALSE;
	  }
        }
#else
  {
    int filled = 0;
    int i;
    const char *cp;
    SV* sv = NULL;

    /* Work with "fallback" key, which we assume to be first in PL_AMG_names */

    if ((cp = PL_AMG_names[0])) {
	/* Try to find via inheritance. */
	gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
	if (gv)
	    sv = GvSV(gv);

	if (!gv)
	    goto no_table;
	else if (SvTRUE(sv))
	    amt.fallback=AMGfallYES;
	else if (SvOK(sv))
	    amt.fallback=AMGfallNEVER;
    }

    for (i = 1; i < NofAMmeth; i++) {
	SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
	DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
		     cp, HvNAME(stash)) );
	/* don't fill the cache while looking up! */
	gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
        cv = 0;
        if(gv && (cv = GvCV(gv))) {
	    if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
		&& strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
		/* GvSV contains the name of the method. */
		GV *ngv;
		
		DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
			     SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
		if (!SvPOK(GvSV(gv))
		    || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
						       FALSE)))
		{
		    /* Can be an import stub (created by `can'). */
		    if (GvCVGEN(gv)) {
			Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
			      (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
			      cp, HvNAME(stash));
		    } else
			Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
			      (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
			      cp, HvNAME(stash));
		}
		cv = GvCV(gv = ngv);
	    }
	    DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
			 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
			 GvNAME(CvGV(cv))) );
	    filled = 1;
	}
#endif
	amt.table[i]=(CV*)SvREFCNT_inc(cv);
    }
    if (filled) {
      AMT_AMAGIC_on(&amt);
      sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
      return TRUE;
    }
  }
  /* Here we have no table: */
 no_table:
  AMT_AMAGIC_off(&amt);
  sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
  return FALSE;
}

SV*
Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
{
  dTHR;
  MAGIC *mg;
  CV *cv;
  CV **cvp=NULL, **ocvp=NULL;
  AMT *amtp, *oamtp;
  int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
  int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
  HV* stash;
  if (!(AMGf_noleft & flags) && SvAMAGIC(left)
      && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
      && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
			? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
			: (CV **) NULL))
      && ((cv = cvp[off=method+assignshift])
	  || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
						          * usual method */
		  (fl = 1, cv = cvp[off=method])))) {
    lr = -1;			/* Call method for left argument */
  } else {
    if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
      int logic;

      /* look for substituted methods */
      /* In all the covered cases we should be called with assign==0. */
	 switch (method) {
	 case inc_amg:
	   force_cpy = 1;
	   if ((cv = cvp[off=add_ass_amg])
	       || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
	     right = &PL_sv_yes; lr = -1; assign = 1;
	   }
	   break;
	 case dec_amg:
	   force_cpy = 1;
	   if ((cv = cvp[off = subtr_ass_amg])
	       || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
	     right = &PL_sv_yes; lr = -1; assign = 1;
	   }
	   break;
	 case bool__amg:
	   (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
	   break;
	 case numer_amg:
	   (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
	   break;
	 case string_amg:
	   (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
	   break;
 case not_amg:
   (void)((cv = cvp[off=bool__amg])
	  || (cv = cvp[off=numer_amg])
	  || (cv = cvp[off=string_amg]));
   postpr = 1;
   break;
	 case copy_amg:
	   {
	     /*
		  * SV* ref causes confusion with the interpreter variable of
		  * the same name
		  */
	     SV* tmpRef=SvRV(left);
	     if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
		/*
		 * Just to be extra cautious.  Maybe in some
		 * additional cases sv_setsv is safe, too.
		 */
		SV* newref = newSVsv(tmpRef);
		SvOBJECT_on(newref);
		SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
		return newref;
	     }
	   }
	   break;
	 case abs_amg:
	   if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
	       && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
	     SV* nullsv=sv_2mortal(newSViv(0));
	     if (off1==lt_amg) {
	       SV* lessp = amagic_call(left,nullsv,
				       lt_amg,AMGf_noright);
	       logic = SvTRUE(lessp);
	     } else {
	       SV* lessp = amagic_call(left,nullsv,
				       ncmp_amg,AMGf_noright);
	       logic = (SvNV(lessp) < 0);
	     }
	     if (logic) {
	       if (off==subtr_amg) {
		 right = left;
		 left = nullsv;
		 lr = 1;
	       }
	     } else {
	       return left;
	     }
	   }
	   break;
	 case neg_amg:
	   if ((cv = cvp[off=subtr_amg])) {
	     right = left;
	     left = sv_2mortal(newSViv(0));
	     lr = 1;
	   }
	   break;
	 case iter_amg:			/* XXXX Eventually should do to_gv. */
	     /* FAIL safe */
	     return NULL;	/* Delegate operation to standard mechanisms. */
	     break;
	 case to_sv_amg:
	 case to_av_amg:
	 case to_hv_amg:
	 case to_gv_amg:
	 case to_cv_amg:
	     /* FAIL safe */
	     return left;	/* Delegate operation to standard mechanisms. */
	     break;
	 default:
	   goto not_found;
	 }
	 if (!cv) goto not_found;
    } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
	       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
	       && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
			  ? (amtp = (AMT*)mg->mg_ptr)->table
			  : (CV **) NULL))
	       && (cv = cvp[off=method])) { /* Method for right
					     * argument found */
      lr=1;
    } else if (((ocvp && oamtp->fallback > AMGfallNEVER
		 && (cvp=ocvp) && (lr = -1))
		|| (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
	       && !(flags & AMGf_unary)) {
				/* We look for substitution for
				 * comparison operations and
				 * concatenation */
      if (method==concat_amg || method==concat_ass_amg
	  || method==repeat_amg || method==repeat_ass_amg) {
	return NULL;		/* Delegate operation to string conversion */
      }
      off = -1;
      switch (method) {
	 case lt_amg:
	 case le_amg:
	 case gt_amg:
	 case ge_amg:
	 case eq_amg:
	 case ne_amg:
	   postpr = 1; 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;
	 }
      if (off != -1) cv = cvp[off];
      if (!cv) {
	goto not_found;
      }
    } else {
    not_found:			/* No method found, either report or croak */
      switch (method) {
	 case to_sv_amg:
	 case to_av_amg:
	 case to_hv_amg:
	 case to_gv_amg:
	 case to_cv_amg:
	     /* FAIL safe */
	     return left;	/* Delegate operation to standard mechanisms. */
	     break;
      }
      if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
	notfound = 1; lr = -1;
      } else if (cvp && (cv=cvp[nomethod_amg])) {
	notfound = 1; lr = 1;
      } else {
	SV *msg;
	if (off==-1) off=method;
	msg = sv_2mortal(Perl_newSVpvf(aTHX_
		      "Operation `%s': no method found,%sargument %s%s%s%s",
		      PL_AMG_names[method + assignshift],
		      (flags & AMGf_unary ? " " : "\n\tleft "),
		      SvAMAGIC(left)?
		        "in overloaded package ":
		        "has no overloaded magic",
		      SvAMAGIC(left)?
		        HvNAME(SvSTASH(SvRV(left))):
		        "",
		      SvAMAGIC(right)?
		        ",\n\tright argument in overloaded package ":
		        (flags & AMGf_unary
			 ? ""
			 : ",\n\tright argument has no overloaded magic"),
		      SvAMAGIC(right)?
		        HvNAME(SvSTASH(SvRV(right))):
		        ""));
	if (amtp && amtp->fallback >= AMGfallYES) {
	  DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
	} else {
	  Perl_croak(aTHX_ "%"SVf, msg);
	}
	return NULL;
      }
      force_cpy = force_cpy || assign;
    }
  }
  if (!notfound) {
    DEBUG_o( Perl_deb(aTHX_
  "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
		 PL_AMG_names[off],
		 method+assignshift==off? "" :
		             " (initially `",
		 method+assignshift==off? "" :
		             PL_AMG_names[method+assignshift],
		 method+assignshift==off? "" : "')",
		 flags & AMGf_unary? "" :
		   lr==1 ? " for right argument": " for left argument",
		 flags & AMGf_unary? " for argument" : "",
		 HvNAME(stash),
		 fl? ",\n\tassignment variant used": "") );
  }
    /* Since we use shallow copy during assignment, we need
     * to dublicate the contents, probably calling user-supplied
     * version of copy operator
     */
    /* We need to copy in following cases:
     * a) Assignment form was called.
     * 		assignshift==1,  assign==T, method + 1 == off
     * b) Increment or decrement, called directly.
     * 		assignshift==0,  assign==0, method + 0 == off
     * c) Increment or decrement, translated to assignment add/subtr.
     * 		assignshift==0,  assign==T,
     *		force_cpy == T
     * d) Increment or decrement, translated to nomethod.
     * 		assignshift==0,  assign==0,
     *		force_cpy == T
     * e) Assignment form translated to nomethod.
     * 		assignshift==1,  assign==T, method + 1 != off
     *		force_cpy == T
     */
    /*	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)
	&& (assign || (method == inc_amg) || (method == dec_amg)))
      || force_cpy)
    RvDEEPCP(left);
  {
    dSP;
    BINOP myop;
    SV* res;
    bool oldcatch = CATCH_GET;

    CATCH_SET(TRUE);
    Zero(&myop, 1, BINOP);
    myop.op_last = (OP *) &myop;
    myop.op_next = Nullop;
    myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;

    PUSHSTACKi(PERLSI_OVERLOAD);
    ENTER;
    SAVEOP();
    PL_op = (OP *) &myop;
    if (PERLDB_SUB && PL_curstash != PL_debstash)
	PL_op->op_private |= OPpENTERSUB_DB;
    PUTBACK;
    pp_pushmark();

    EXTEND(SP, notfound + 5);
    PUSHs(lr>0? right: left);
    PUSHs(lr>0? left: right);
    PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
    if (notfound) {
      PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
    }
    PUSHs((SV*)cv);
    PUTBACK;

    if ((PL_op = Perl_pp_entersub(aTHX)))
      CALLRUNOPS(aTHX);
    LEAVE;
    SPAGAIN;

    res=POPs;
    PUTBACK;
    POPSTACK;
    CATCH_SET(oldcatch);

    if (postpr) {
      int ans;
      switch (method) {
      case le_amg:
      case sle_amg:
	ans=SvIV(res)<=0; break;
      case lt_amg:
      case slt_amg:
	ans=SvIV(res)<0; break;
      case ge_amg:
      case sge_amg:
	ans=SvIV(res)>=0; break;
      case gt_amg:
      case sgt_amg:
	ans=SvIV(res)>0; break;
      case eq_amg:
      case seq_amg:
	ans=SvIV(res)==0; break;
      case ne_amg:
      case sne_amg:
	ans=SvIV(res)!=0; break;
      case inc_amg:
      case dec_amg:
	SvSetSV(left,res); return left;
      case not_amg:
	ans=!SvTRUE(res); break;
      }
      return boolSV(ans);
    } else if (method==copy_amg) {
      if (!SvROK(res)) {
	Perl_croak(aTHX_ "Copy method did not return a reference");
      }
      return SvREFCNT_inc(SvRV(res));
    } else {
      return res;
    }
  }
}

/*
=for apidoc is_gv_magical

Returns C<TRUE> if given the name of a magical GV.

Currently only useful internally when determining if a GV should be
created even in rvalue contexts.

C<flags> is not used at present but available for future extension to
allow selecting particular classes of magical variable.

=cut
*/
bool
Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
{
    if (!len)
	return FALSE;

    switch (*name) {
    case 'I':
	if (len == 3 && strEQ(name, "ISA"))
	    goto yes;
	break;
    case 'O':
	if (len == 8 && strEQ(name, "OVERLOAD"))
	    goto yes;
	break;
    case 'S':
	if (len == 3 && strEQ(name, "SIG"))
	    goto yes;
	break;
    case '\027':   /* $^W & $^WARNING_BITS */
	if (len == 1
	    || (len == 12 && strEQ(name, "\027ARNING_BITS"))
	    || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
	{
	    goto yes;
	}
	break;

    case '&':
    case '`':
    case '\'':
    case ':':
    case '?':
    case '!':
    case '-':
    case '#':
    case '*':
    case '[':
    case '^':
    case '~':
    case '=':
    case '%':
    case '.':
    case '(':
    case ')':
    case '<':
    case '>':
    case ',':
    case '\\':
    case '/':
    case '|':
    case '+':
    case ';':
    case ']':
    case '\001':   /* $^A */
    case '\003':   /* $^C */
    case '\004':   /* $^D */
    case '\005':   /* $^E */
    case '\006':   /* $^F */
    case '\010':   /* $^H */
    case '\011':   /* $^I, NOT \t in EBCDIC */
    case '\014':   /* $^L */
    case '\017':   /* $^O */
    case '\020':   /* $^P */
    case '\023':   /* $^S */
    case '\024':   /* $^T */
    case '\026':   /* $^V */
	if (len == 1)
	    goto yes;
	break;
    case '1':
    case '2':
    case '3':
    case '4':
    case '5':
    case '6':
    case '7':
    case '8':
    case '9':
	if (len > 1) {
	    char *end = name + len;
	    while (--end > name) {
		if (!isDIGIT(*end))
		    return FALSE;
	    }
	}
    yes:
	return TRUE;
    default:
	break;
    }
    return FALSE;
}