[perl5.git] / gv.c

/* $RCSfile: gv.c,v $$Revision: 4.1 $$Date: 92/08/07 18:26:39 $
 *
 *    Copyright (c) 1991, 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.
 *
 * $Log:	gv.c,v $
 * Revision 4.1  92/08/07  18:26:39  lwall
 * 
 * Revision 4.0.1.4  92/06/08  15:32:19  lwall
 * patch20: fixed confusion between a *var's real name and its effective name
 * patch20: the debugger now warns you on lines that can't set a breakpoint
 * patch20: the debugger made perl forget the last pattern used by //
 * patch20: paragraph mode now skips extra newlines automatically
 * patch20: ($<,$>) = ... didn't work on some architectures
 * 
 * Revision 4.0.1.3  91/11/05  18:35:33  lwall
 * patch11: length($x) was sometimes wrong for numeric $x
 * patch11: perl now issues warning if $SIG{'ALARM'} is referenced
 * patch11: *foo = undef coredumped
 * patch11: solitary subroutine references no longer trigger typo warnings
 * patch11: local(*FILEHANDLE) had a memory leak
 * 
 * Revision 4.0.1.2  91/06/07  11:55:53  lwall
 * patch4: new copyright notice
 * patch4: added $^P variable to control calling of perldb routines
 * patch4: added $^F variable to specify maximum system fd, default 2
 * patch4: $` was busted inside s///
 * patch4: default top-of-form run_format is now FILEHANDLE_TOP
 * patch4: length($`), length($&), length($') now optimized to avoid string copy
 * patch4: $^D |= 1024 now does syntax tree dump at run-time
 * 
 * Revision 4.0.1.1  91/04/12  09:10:24  lwall
 * patch1: Configure now differentiates getgroups() type from getgid() type
 * patch1: you may now use "die" and "caller" in a signal handler
 * 
 * Revision 4.0  91/03/20  01:39:41  lwall
 * 4.0 baseline.
 * 
 */

#include "EXTERN.h"
#include "perl.h"

extern char rcsid[];

GV *
gv_AVadd(gv)
register GV *gv;
{
    if (!GvAV(gv))
	GvAV(gv) = newAV();
    return gv;
}

GV *
gv_HVadd(gv)
register GV *gv;
{
    if (!GvHV(gv))
	GvHV(gv) = newHV();
    return gv;
}

GV *
gv_fetchfile(name)
char *name;
{
    char tmpbuf[1200];
    GV *gv;

    sprintf(tmpbuf,"'_<%s", name);
    gv = gv_fetchpv(tmpbuf, TRUE);
    sv_setpv(GvSV(gv), name);
    if (perldb)
	hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
    return gv;
}

void
gv_init(gv, stash, name, len, multi)
GV *gv;
HV *stash;
char *name;
STRLEN len;
int multi;
{
    register GP *gp;

    sv_upgrade(gv, SVt_PVGV);
    if (SvLEN(gv))
	Safefree(SvPVX(gv));
    Newz(602,gp, 1, GP);
    GvGP(gv) = gp;
    GvREFCNT(gv) = 1;
    GvSV(gv) = NEWSV(72,0);
    GvLINE(gv) = curcop->cop_line;
    GvEGV(gv) = gv;
    sv_magic((SV*)gv, (SV*)gv, '*', name, len);
    GvSTASH(gv) = stash;
    GvNAME(gv) = nsavestr(name, len);
    GvNAMELEN(gv) = len;
    if (multi)
	SvMULTI_on(gv);
}

GV *
gv_fetchmeth(stash, name, len)
HV* stash;
char* name;
STRLEN len;
{
    AV* av;
    GV* topgv;
    GV* gv;
    GV** gvp;

    gvp = (GV**)hv_fetch(stash, name, len, TRUE);

    DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) );
    topgv = *gvp;
    if (SvTYPE(topgv) != SVt_PVGV)
	gv_init(topgv, stash, name, len, TRUE);

    if (GvCV(topgv)) {
	if (!GvCVGEN(topgv) || GvCVGEN(topgv) >= sub_generation)
	    return topgv;
    }

    gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
    if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
	SV** svp = AvARRAY(av);
	I32 items = AvFILL(av) + 1;
	while (items--) {
	    char tmpbuf[512];
	    SV* sv = *svp++;
	    *tmpbuf = '_';
	    SvUPGRADE(sv, SVt_PV);
	    strcpy(tmpbuf+1, SvPV(sv, na));
	    gv = gv_fetchpv(tmpbuf,FALSE);
	    if (!gv || !(stash = GvHV(gv))) {
		if (dowarn)
		    warn("Can't locate package %s for @%s'ISA",
			SvPVX(sv), HvNAME(stash));
		continue;
	    }
	    gv = gv_fetchmeth(stash, name, len);
	    if (gv) {
		GvCV(topgv) = GvCV(gv);			/* cache the CV */
		GvCVGEN(topgv) = sub_generation;	/* valid for now */
		return gv;
	    }
	}
    }
    return 0;
}

GV *
gv_fetchmethod(stash, name)
HV* stash;
char* name;
{
    register char *nend;
    
    for (nend = name; *nend; nend++) {
	if (*nend == ':' || *nend == '\'') {
	    return gv_fetchpv(name, FALSE);
	}
    }
    return gv_fetchmeth(stash, name, nend - name);
}

GV *
gv_fetchpv(nambeg,add)
char *nambeg;
I32 add;
{
    register char *name = nambeg;
    register GV *gv = 0;
    GV**gvp;
    I32 len;
    register char *namend;
    HV *stash = 0;
    bool global = FALSE;
    char tmpbuf[256];

    for (namend = name; *namend; namend++) {
	if ((*namend == '\'' && namend[1]) ||
	    (*namend == ':' && namend[1] == ':'))
	{
	    len = namend - name;
	    *tmpbuf = '_';
	    Copy(name, tmpbuf+1, len, char);
	    len++;
	    tmpbuf[len] = '\0';
	    if (!stash)
		stash = defstash;

	    if (len > 1) {
		gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
		if (!gvp || *gvp == (GV*)&sv_undef)
		    return Nullgv;
		gv = *gvp;
		if (SvTYPE(gv) == SVt_PVGV)
		    SvMULTI_on(gv);
		else
		    gv_init(gv, stash, nambeg, namend - nambeg, (add & 2));
		if (!(stash = GvHV(gv)))
		    stash = GvHV(gv) = newHV();
		if (!HvNAME(stash))
		    HvNAME(stash) = nsavestr(nambeg, namend - nambeg);
	    }

	    if (*namend == ':')
		namend++;
	    namend++;
	    name = namend;
	    if (!*name)
		return gv ? gv : defgv;
	}
    }

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

    if (!stash) {
	if (isIDFIRST(*name)) {
	    if (isUPPER(*name)) {
		if (*name > 'I') {
		    if (*name == 'S' && (
		      strEQ(name, "SIG") ||
		      strEQ(name, "STDIN") ||
		      strEQ(name, "STDOUT") ||
		      strEQ(name, "STDERR") ))
			global = TRUE;
		}
		else if (*name > 'E') {
		    if (*name == 'I' && strEQ(name, "INC"))
			global = TRUE;
		}
		else if (*name > 'A') {
		    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 = defstash;
	    else if ((COP*)curcop == &compiling)
		stash = curstash;
	    else
		stash = curcop->cop_stash;
	}
	else
	    stash = defstash;
    }

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

    if (!stash)
	croak("Global symbol \"%s\" requires explicit package name", name);
    len = namend - name;
    if (!len)
	len = 1;
    gvp = (GV**)hv_fetch(stash,name,len,add);
    if (!gvp || *gvp == (GV*)&sv_undef)
	return Nullgv;
    gv = *gvp;
    if (SvTYPE(gv) == SVt_PVGV) {
	SvMULTI_on(gv);
	return gv;
    }

    /* Adding a new symbol */

    gv_init(gv, stash, name, len, add & 2);

    /* set up magic where warranted */
    switch (*name) {
    case 'I':
	if (strEQ(name, "ISA")) {
	    AV* av = GvAVn(gv);
	    sv_magic((SV*)av, (SV*)gv, 'I', 0, 0);
	}
	break;
    case 'S':
	if (strEQ(name, "SIG")) {
	    HV *hv;
	    siggv = gv;
	    SvMULTI_on(siggv);
	    hv = GvHVn(siggv);
	    hv_magic(hv, siggv, 'S');

	    /* initialize signal stack */
	    signalstack = newAV();
	    av_store(signalstack, 32, Nullsv);
	    av_clear(signalstack);
	    AvREAL_off(signalstack);
	}
	break;

    case '&':
	if (len > 1)
	    break;
	ampergv = gv;
	sawampersand = TRUE;
	goto magicalize;

    case '`':
	if (len > 1)
	    break;
	leftgv = gv;
	sawampersand = TRUE;
	goto magicalize;

    case '\'':
	if (len > 1)
	    break;
	rightgv = gv;
	sawampersand = TRUE;
	goto magicalize;

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

    case '!':
    case '#':
    case '?':
    case '^':
    case '~':
    case '=':
    case '-':
    case '%':
    case '.':
    case '+':
    case '*':
    case '(':
    case ')':
    case '<':
    case '>':
    case ',':
    case '\\':
    case '/':
    case '[':
    case '|':
    case '\004':
    case '\t':
    case '\020':
    case '\024':
    case '\027':
    case '\006':
	if (len > 1)
	    break;
	goto magicalize;

    case '1':
    case '2':
    case '3':
    case '4':
    case '5':
    case '6':
    case '7':
    case '8':
    case '9':
      magicalize:
	sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
	break;

    case '\014':
	if (len > 1)
	    break;
	sv_setpv(GvSV(gv),"\f");
	formfeed = GvSV(gv);
	break;
    case ';':
	if (len > 1)
	    break;
	sv_setpv(GvSV(gv),"\034");
	break;
    case ']':
	if (len == 1) {
	    SV *sv;
	    sv = GvSV(gv);
	    sv_upgrade(sv, SVt_PVNV);
	    sv_setpv(sv,rcsid);
	    SvNVX(sv) = atof(patchlevel);
	    SvNOK_on(sv);
	}
	break;
    }
    return gv;
}

void
gv_fullname(sv,gv)
SV *sv;
GV *gv;
{
    HV *hv = GvSTASH(gv);

    if (!hv)
	return;
    sv_setpv(sv, sv == (SV*)gv ? "*" : "");
    sv_catpv(sv,HvNAME(hv));
    sv_catpvn(sv,"::", 2);
    sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
}

void
gv_efullname(sv,gv)
SV *sv;
GV *gv;
{
    GV* egv = GvEGV(gv);
    HV *hv = GvSTASH(egv);

    if (!hv)
	return;
    sv_setpv(sv, sv == (SV*)gv ? "*" : "");
    sv_catpv(sv,HvNAME(hv));
    sv_catpvn(sv,"::", 2);
    sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv));
}

IO *
newIO()
{
    IO *io;

    Newz(603,io,1,IO);
    io->page_len = 60;
    return io;
}

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

    for (i = 0; i <= HvMAX(stash); i++) {
	for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
	    if (isALPHA(*entry->hent_key)) {
		gv = (GV*)entry->hent_val;
		if (SvMULTI(gv))
		    continue;
		curcop->cop_line = GvLINE(gv);
		warn("Possible typo: \"%s::%s\"", HvNAME(stash), GvNAME(gv));
	    }
	    else if (*entry->hent_key == '_' &&
		(gv = (GV*)entry->hent_val) &&
		(hv = GvHV(gv)) && HvNAME(hv) && hv != defstash)
		     gv_check(hv);              /* nested package */
						      
	}
    }
}

GV *
newGVgen()
{
    (void)sprintf(tokenbuf,"_GEN_%d",gensym++);
    return gv_fetchpv(tokenbuf,TRUE);
}

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

GP*
gp_ref(gp)
GP* gp;
{
    gp->gp_refcnt++;
    return gp;

}

void
gp_free(gv)
GV* gv;
{
    IO *io;
    CV *cv;
    GP* gp;

    if (!gv || !(gp = GvGP(gv)))
	return;
    if (gp->gp_refcnt == 0) {
        warn("Attempt to free unreferenced glob pointers");
        return;
    }
    if (--gp->gp_refcnt > 0)
        return;

    sv_free((SV*)gp->gp_sv);
    sv_free((SV*)gp->gp_av);
    sv_free((SV*)gp->gp_hv);
    if (io = gp->gp_io) {
	do_close(gv,FALSE);
	Safefree(io->top_name);
	Safefree(io->fmt_name);
	Safefree(io);
    }
    if (cv = gp->gp_cv)
	sv_free((SV*)cv);
    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 */

GV *
fetch_gv(op,num)
OP *op;
I32 num;
{
    if (op->op_private < num)
	return 0;
    if (op->op_flags & OPf_STACKED)
        return gv_fetchpv(SvPVx(*(stack_sp--), na),TRUE);
    else
        return cGVOP->op_gv;
}

IO *
fetch_io(op,num)
OP *op;
I32 num;
{
    GV *gv;

    if (op->op_private < num)
	return 0;
    if (op->op_flags & OPf_STACKED)
        gv = gv_fetchpv(SvPVx(*(stack_sp--), na),TRUE);
    else
        gv = cGVOP->op_gv;

    if (!gv)
	return 0;

    return GvIOn(gv);
}
Commit	Line	Data
79072805 LW	1	/* $RCSfile: gv.c,v $$Revision: 4.1 $$Date: 92/08/07 18:26:39 $
	2	*
	3	* Copyright (c) 1991, Larry Wall
	4	*
	5	* You may distribute under the terms of either the GNU General Public
	6	* License or the Artistic License, as specified in the README file.
	7	*
	8	* $Log: gv.c,v $
	9	* Revision 4.1 92/08/07 18:26:39 lwall
	10	*
	11	* Revision 4.0.1.4 92/06/08 15:32:19 lwall
	12	* patch20: fixed confusion between a *var's real name and its effective name
	13	* patch20: the debugger now warns you on lines that can't set a breakpoint
	14	* patch20: the debugger made perl forget the last pattern used by //
	15	* patch20: paragraph mode now skips extra newlines automatically
	16	* patch20: ($<,$>) = ... didn't work on some architectures
	17	*
	18	* Revision 4.0.1.3 91/11/05 18:35:33 lwall
	19	* patch11: length($x) was sometimes wrong for numeric $x
	20	* patch11: perl now issues warning if $SIG{'ALARM'} is referenced
	21	* patch11: *foo = undef coredumped
	22	* patch11: solitary subroutine references no longer trigger typo warnings
	23	* patch11: local(*FILEHANDLE) had a memory leak
	24	*
	25	* Revision 4.0.1.2 91/06/07 11:55:53 lwall
	26	* patch4: new copyright notice
	27	* patch4: added $^P variable to control calling of perldb routines
	28	* patch4: added $^F variable to specify maximum system fd, default 2
	29	* patch4: $` was busted inside s///
	30	* patch4: default top-of-form run_format is now FILEHANDLE_TOP
	31	* patch4: length($`), length($&), length($') now optimized to avoid string copy
	32	* patch4: $^D \|= 1024 now does syntax tree dump at run-time
	33	*
	34	* Revision 4.0.1.1 91/04/12 09:10:24 lwall
	35	* patch1: Configure now differentiates getgroups() type from getgid() type
	36	* patch1: you may now use "die" and "caller" in a signal handler
	37	*
	38	* Revision 4.0 91/03/20 01:39:41 lwall
	39	* 4.0 baseline.
	40	*
	41	*/
	42
	43	#include "EXTERN.h"
	44	#include "perl.h"
	45
463ee0b2	46	extern char rcsid[];
93a17b20	47
79072805 LW	48	GV *
	49	gv_AVadd(gv)
	50	register GV *gv;
	51	{
	52	if (!GvAV(gv))
	53	GvAV(gv) = newAV();
	54	return gv;
	55	}
	56
	57	GV *
	58	gv_HVadd(gv)
	59	register GV *gv;
	60	{
	61	if (!GvHV(gv))
463ee0b2	62	GvHV(gv) = newHV();
79072805 LW	63	return gv;
	64	}
	65
	66	GV *
	67	gv_fetchfile(name)
	68	char *name;
	69	{
	70	char tmpbuf[1200];
	71	GV *gv;
	72
	73	sprintf(tmpbuf,"'_<%s", name);
	74	gv = gv_fetchpv(tmpbuf, TRUE);
	75	sv_setpv(GvSV(gv), name);
	76	if (perldb)
93a17b20	77	hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
79072805 LW	78	return gv;
	79	}
	80
463ee0b2 LW	81	void
	82	gv_init(gv, stash, name, len, multi)
	83	GV *gv;
	84	HV *stash;
	85	char *name;
	86	STRLEN len;
	87	int multi;
	88	{
	89	register GP *gp;
	90
	91	sv_upgrade(gv, SVt_PVGV);
	92	if (SvLEN(gv))
	93	Safefree(SvPVX(gv));
	94	Newz(602,gp, 1, GP);
	95	GvGP(gv) = gp;
	96	GvREFCNT(gv) = 1;
	97	GvSV(gv) = NEWSV(72,0);
	98	GvLINE(gv) = curcop->cop_line;
	99	GvEGV(gv) = gv;
	100	sv_magic((SV)gv, (SV)gv, '*', name, len);
	101	GvSTASH(gv) = stash;
	102	GvNAME(gv) = nsavestr(name, len);
	103	GvNAMELEN(gv) = len;
	104	if (multi)
	105	SvMULTI_on(gv);
	106	}
	107
79072805	108	GV *
463ee0b2	109	gv_fetchmeth(stash, name, len)
79072805 LW	110	HV* stash;
79072805 LW	111	char* name;
463ee0b2	112	STRLEN len;
79072805 LW	113	{
79072805 LW	114	AV* av;
463ee0b2	115	GV* topgv;
79072805	116	GV* gv;
463ee0b2 LW	117	GV** gvp;
	118
	119	gvp = (GV**)hv_fetch(stash, name, len, TRUE);
	120
	121	DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) );
	122	topgv = *gvp;
	123	if (SvTYPE(topgv) != SVt_PVGV)
	124	gv_init(topgv, stash, name, len, TRUE);
	125
	126	if (GvCV(topgv)) {
	127	if (!GvCVGEN(topgv) \|\| GvCVGEN(topgv) >= sub_generation)
	128	return topgv;
	129	}
79072805 LW	130
	131	gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
	132	if (gvp && (gv = gvp) != (GV)&sv_undef && (av = GvAV(gv))) {
	133	SV** svp = AvARRAY(av);
	134	I32 items = AvFILL(av) + 1;
	135	while (items--) {
	136	char tmpbuf[512];
	137	SV* sv = *svp++;
	138	*tmpbuf = '_';
	139	SvUPGRADE(sv, SVt_PV);
463ee0b2	140	strcpy(tmpbuf+1, SvPV(sv, na));
79072805 LW	141	gv = gv_fetchpv(tmpbuf,FALSE);
	142	if (!gv \|\| !(stash = GvHV(gv))) {
	143	if (dowarn)
	144	warn("Can't locate package %s for @%s'ISA",
463ee0b2	145	SvPVX(sv), HvNAME(stash));
79072805 LW	146	continue;
79072805 LW	147	}
463ee0b2 LW	148	gv = gv_fetchmeth(stash, name, len);
	149	if (gv) {
	150	GvCV(topgv) = GvCV(gv); /* cache the CV */
	151	GvCVGEN(topgv) = sub_generation; /* valid for now */
79072805	152	return gv;
463ee0b2	153	}
79072805 LW	154	}
	155	}
	156	return 0;
	157	}
	158
	159	GV *
463ee0b2 LW	160	gv_fetchmethod(stash, name)
	161	HV* stash;
	162	char* name;
	163	{
	164	register char *nend;
	165
	166	for (nend = name; *nend; nend++) {
	167	if (nend == ':' \|\| nend == '\'') {
	168	return gv_fetchpv(name, FALSE);
	169	}
	170	}
	171	return gv_fetchmeth(stash, name, nend - name);
	172	}
	173
	174	GV *
	175	gv_fetchpv(nambeg,add)
	176	char *nambeg;
79072805 LW	177	I32 add;
79072805 LW	178	{
463ee0b2 LW	179	register char *name = nambeg;
463ee0b2 LW	180	register GV *gv = 0;
79072805	181	GV**gvp;
79072805 LW	182	I32 len;
79072805 LW	183	register char *namend;
463ee0b2	184	HV *stash = 0;
79072805	185	bool global = FALSE;
463ee0b2	186	char tmpbuf[256];
79072805	187
79072805	188	for (namend = name; *namend; namend++) {
463ee0b2 LW	189	if ((*namend == '\'' && namend[1]) \|\|
	190	(*namend == ':' && namend[1] == ':'))
	191	{
	192	len = namend - name;
79072805	193	*tmpbuf = '_';
463ee0b2 LW	194	Copy(name, tmpbuf+1, len, char);
	195	len++;
	196	tmpbuf[len] = '\0';
	197	if (!stash)
	198	stash = defstash;
	199
	200	if (len > 1) {
	201	gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
	202	if (!gvp \|\| gvp == (GV)&sv_undef)
	203	return Nullgv;
	204	gv = *gvp;
	205	if (SvTYPE(gv) == SVt_PVGV)
	206	SvMULTI_on(gv);
	207	else
	208	gv_init(gv, stash, nambeg, namend - nambeg, (add & 2));
	209	if (!(stash = GvHV(gv)))
	210	stash = GvHV(gv) = newHV();
	211	if (!HvNAME(stash))
	212	HvNAME(stash) = nsavestr(nambeg, namend - nambeg);
	213	}
	214
	215	if (*namend == ':')
	216	namend++;
	217	namend++;
	218	name = namend;
	219	if (!*name)
	220	return gv ? gv : defgv;
79072805	221	}
79072805	222	}
463ee0b2 LW	223
	224	/* No stash in name, so see how we can default */
	225
	226	if (!stash) {
	227	if (isIDFIRST(*name)) {
	228	if (isUPPER(*name)) {
	229	if (*name > 'I') {
	230	if (*name == 'S' && (
	231	strEQ(name, "SIG") \|\|
	232	strEQ(name, "STDIN") \|\|
	233	strEQ(name, "STDOUT") \|\|
	234	strEQ(name, "STDERR") ))
	235	global = TRUE;
	236	}
	237	else if (*name > 'E') {
	238	if (*name == 'I' && strEQ(name, "INC"))
	239	global = TRUE;
	240	}
	241	else if (*name > 'A') {
	242	if (*name == 'E' && strEQ(name, "ENV"))
	243	global = TRUE;
	244	}
	245	else if (*name == 'A' && (
	246	strEQ(name, "ARGV") \|\|
	247	strEQ(name, "ARGVOUT") ))
	248	global = TRUE;
	249	}
	250	else if (*name == '_' && !name[1])
	251	global = TRUE;
	252	if (global)
	253	stash = defstash;
	254	else if ((COP*)curcop == &compiling)
	255	stash = curstash;
	256	else
	257	stash = curcop->cop_stash;
	258	}
	259	else
	260	stash = defstash;
	261	}
	262
	263	/* By this point we should have a stash and a name */
	264
93a17b20	265	if (!stash)
463ee0b2	266	croak("Global symbol \"%s\" requires explicit package name", name);
79072805	267	len = namend - name;
463ee0b2 LW	268	if (!len)
463ee0b2 LW	269	len = 1;
79072805 LW	270	gvp = (GV**)hv_fetch(stash,name,len,add);
	271	if (!gvp \|\| gvp == (GV)&sv_undef)
	272	return Nullgv;
	273	gv = *gvp;
	274	if (SvTYPE(gv) == SVt_PVGV) {
	275	SvMULTI_on(gv);
	276	return gv;
	277	}
93a17b20 LW	278
	279	/* Adding a new symbol */
	280
463ee0b2	281	gv_init(gv, stash, name, len, add & 2);
93a17b20 LW	282
	283	/* set up magic where warranted */
	284	switch (*name) {
463ee0b2 LW	285	case 'I':
	286	if (strEQ(name, "ISA")) {
	287	AV* av = GvAVn(gv);
	288	sv_magic((SV)av, (SV)gv, 'I', 0, 0);
	289	}
	290	break;
93a17b20 LW	291	case 'S':
	292	if (strEQ(name, "SIG")) {
	293	HV *hv;
	294	siggv = gv;
	295	SvMULTI_on(siggv);
	296	hv = GvHVn(siggv);
	297	hv_magic(hv, siggv, 'S');
	298
	299	/* initialize signal stack */
	300	signalstack = newAV();
	301	av_store(signalstack, 32, Nullsv);
	302	av_clear(signalstack);
	303	AvREAL_off(signalstack);
	304	}
	305	break;
	306
	307	case '&':
463ee0b2 LW	308	if (len > 1)
463ee0b2 LW	309	break;
93a17b20 LW	310	ampergv = gv;
	311	sawampersand = TRUE;
	312	goto magicalize;
	313
	314	case '`':
463ee0b2 LW	315	if (len > 1)
463ee0b2 LW	316	break;
93a17b20 LW	317	leftgv = gv;
	318	sawampersand = TRUE;
	319	goto magicalize;
	320
	321	case '\'':
463ee0b2 LW	322	if (len > 1)
463ee0b2 LW	323	break;
93a17b20 LW	324	rightgv = gv;
	325	sawampersand = TRUE;
	326	goto magicalize;
	327
	328	case ':':
463ee0b2 LW	329	if (len > 1)
463ee0b2 LW	330	break;
93a17b20 LW	331	sv_setpv(GvSV(gv),chopset);
	332	goto magicalize;
	333
	334	case '!':
	335	case '#':
	336	case '?':
	337	case '^':
	338	case '~':
	339	case '=':
	340	case '-':
	341	case '%':
	342	case '.':
	343	case '+':
	344	case '*':
	345	case '(':
	346	case ')':
	347	case '<':
	348	case '>':
	349	case ',':
	350	case '\\':
	351	case '/':
	352	case '[':
	353	case '\|':
	354	case '\004':
	355	case '\t':
	356	case '\020':
	357	case '\024':
	358	case '\027':
	359	case '\006':
463ee0b2 LW	360	if (len > 1)
	361	break;
	362	goto magicalize;
	363
	364	case '1':
	365	case '2':
	366	case '3':
	367	case '4':
	368	case '5':
	369	case '6':
	370	case '7':
	371	case '8':
	372	case '9':
93a17b20	373	magicalize:
463ee0b2	374	sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
93a17b20 LW	375	break;
	376
	377	case '\014':
463ee0b2 LW	378	if (len > 1)
463ee0b2 LW	379	break;
93a17b20 LW	380	sv_setpv(GvSV(gv),"\f");
	381	formfeed = GvSV(gv);
	382	break;
	383	case ';':
463ee0b2 LW	384	if (len > 1)
463ee0b2 LW	385	break;
93a17b20 LW	386	sv_setpv(GvSV(gv),"\034");
93a17b20 LW	387	break;
463ee0b2 LW	388	case ']':
463ee0b2 LW	389	if (len == 1) {
93a17b20 LW	390	SV *sv;
	391	sv = GvSV(gv);
	392	sv_upgrade(sv, SVt_PVNV);
	393	sv_setpv(sv,rcsid);
463ee0b2	394	SvNVX(sv) = atof(patchlevel);
93a17b20 LW	395	SvNOK_on(sv);
	396	}
	397	break;
79072805	398	}
93a17b20	399	return gv;
79072805 LW	400	}
	401
	402	void
	403	gv_fullname(sv,gv)
	404	SV *sv;
	405	GV *gv;
	406	{
	407	HV *hv = GvSTASH(gv);
	408
	409	if (!hv)
	410	return;
	411	sv_setpv(sv, sv == (SV)gv ? "" : "");
	412	sv_catpv(sv,HvNAME(hv));
463ee0b2	413	sv_catpvn(sv,"::", 2);
79072805 LW	414	sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
	415	}
	416
	417	void
	418	gv_efullname(sv,gv)
	419	SV *sv;
	420	GV *gv;
	421	{
	422	GV* egv = GvEGV(gv);
	423	HV *hv = GvSTASH(egv);
	424
	425	if (!hv)
	426	return;
	427	sv_setpv(sv, sv == (SV)gv ? "" : "");
	428	sv_catpv(sv,HvNAME(hv));
463ee0b2	429	sv_catpvn(sv,"::", 2);
79072805 LW	430	sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv));
	431	}
	432
	433	IO *
	434	newIO()
	435	{
	436	IO *io;
	437
	438	Newz(603,io,1,IO);
	439	io->page_len = 60;
	440	return io;
	441	}
	442
	443	void
463ee0b2 LW	444	gv_check(stash)
463ee0b2 LW	445	HV* stash;
79072805 LW	446	{
	447	register HE *entry;
	448	register I32 i;
	449	register GV *gv;
463ee0b2 LW	450	HV *hv;
	451
	452	for (i = 0; i <= HvMAX(stash); i++) {
	453	for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
	454	if (isALPHA(*entry->hent_key)) {
	455	gv = (GV*)entry->hent_val;
	456	if (SvMULTI(gv))
	457	continue;
	458	curcop->cop_line = GvLINE(gv);
	459	warn("Possible typo: \"%s::%s\"", HvNAME(stash), GvNAME(gv));
	460	}
	461	else if (*entry->hent_key == '_' &&
	462	(gv = (GV*)entry->hent_val) &&
	463	(hv = GvHV(gv)) && HvNAME(hv) && hv != defstash)
	464	gv_check(hv); /* nested package */
	465
79072805 LW	466	}
	467	}
	468	}
	469
	470	GV *
	471	newGVgen()
	472	{
	473	(void)sprintf(tokenbuf,"_GEN_%d",gensym++);
	474	return gv_fetchpv(tokenbuf,TRUE);
	475	}
	476
	477	/* hopefully this is only called on local symbol table entries */
	478
	479	GP*
	480	gp_ref(gp)
	481	GP* gp;
	482	{
	483	gp->gp_refcnt++;
	484	return gp;
	485
	486	}
	487
	488	void
	489	gp_free(gv)
	490	GV* gv;
	491	{
	492	IO *io;
	493	CV *cv;
	494	GP* gp;
	495
	496	if (!gv \|\| !(gp = GvGP(gv)))
	497	return;
	498	if (gp->gp_refcnt == 0) {
	499	warn("Attempt to free unreferenced glob pointers");
	500	return;
	501	}
	502	if (--gp->gp_refcnt > 0)
	503	return;
	504
463ee0b2 LW	505	sv_free((SV*)gp->gp_sv);
	506	sv_free((SV*)gp->gp_av);
	507	sv_free((SV*)gp->gp_hv);
79072805 LW	508	if (io = gp->gp_io) {
	509	do_close(gv,FALSE);
	510	Safefree(io->top_name);
	511	Safefree(io->fmt_name);
	512	Safefree(io);
	513	}
	514	if (cv = gp->gp_cv)
463ee0b2	515	sv_free((SV*)cv);
79072805 LW	516	Safefree(gp);
	517	GvGP(gv) = 0;
	518	}
	519
	520	#if defined(CRIPPLED_CC) && (defined(iAPX286) \|\| defined(M_I286) \|\| defined(I80286))
	521	#define MICROPORT
	522	#endif
	523
	524	#ifdef MICROPORT /* Microport 2.4 hack */
	525	AV *GvAVn(gv)
	526	register GV *gv;
	527	{
	528	if (GvGP(gv)->gp_av)
	529	return GvGP(gv)->gp_av;
	530	else
	531	return GvGP(gv_AVadd(gv))->gp_av;
	532	}
	533
	534	HV *GvHVn(gv)
	535	register GV *gv;
	536	{
	537	if (GvGP(gv)->gp_hv)
	538	return GvGP(gv)->gp_hv;
	539	else
	540	return GvGP(gv_HVadd(gv))->gp_hv;
	541	}
	542	#endif /* Microport 2.4 hack */
	543
	544	GV *
	545	fetch_gv(op,num)
	546	OP *op;
	547	I32 num;
	548	{
	549	if (op->op_private < num)
	550	return 0;
	551	if (op->op_flags & OPf_STACKED)
463ee0b2	552	return gv_fetchpv(SvPVx(*(stack_sp--), na),TRUE);
79072805 LW	553	else
	554	return cGVOP->op_gv;
	555	}
	556
	557	IO *
	558	fetch_io(op,num)
	559	OP *op;
	560	I32 num;
	561	{
	562	GV *gv;
	563
	564	if (op->op_private < num)
	565	return 0;
	566	if (op->op_flags & OPf_STACKED)
463ee0b2	567	gv = gv_fetchpv(SvPVx(*(stack_sp--), na),TRUE);
79072805 LW	568	else
	569	gv = cGVOP->op_gv;
	570
	571	if (!gv)
	572	return 0;
	573
	574	return GvIOn(gv);
	575	}