[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--) {
	    SV* sv = *svp++;
	    HV* basestash = fetch_stash(sv, FALSE);
	    if (!basestash) {
		if (dowarn)
		    warn("Can't locate package %s for @%s'ISA",
			SvPVX(sv), HvNAME(stash));
		continue;
	    }
	    gv = gv_fetchmeth(basestash, 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 'a':
    case 'b':
	if (len == 1)
	    SvMULTI_on(gv);
	break;
    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--) {
79072805	136	SV* sv = *svp++;
9bbf4081 LW	137	HV* basestash = fetch_stash(sv, FALSE);
9bbf4081 LW	138	if (!basestash) {
79072805 LW	139	if (dowarn)
79072805 LW	140	warn("Can't locate package %s for @%s'ISA",
463ee0b2	141	SvPVX(sv), HvNAME(stash));
79072805 LW	142	continue;
79072805 LW	143	}
9bbf4081	144	gv = gv_fetchmeth(basestash, name, len);
463ee0b2 LW	145	if (gv) {
	146	GvCV(topgv) = GvCV(gv); /* cache the CV */
	147	GvCVGEN(topgv) = sub_generation; /* valid for now */
79072805	148	return gv;
463ee0b2	149	}
79072805 LW	150	}
	151	}
	152	return 0;
	153	}
	154
	155	GV *
463ee0b2 LW	156	gv_fetchmethod(stash, name)
	157	HV* stash;
	158	char* name;
	159	{
	160	register char *nend;
	161
	162	for (nend = name; *nend; nend++) {
	163	if (nend == ':' \|\| nend == '\'') {
	164	return gv_fetchpv(name, FALSE);
	165	}
	166	}
	167	return gv_fetchmeth(stash, name, nend - name);
	168	}
	169
	170	GV *
	171	gv_fetchpv(nambeg,add)
	172	char *nambeg;
79072805 LW	173	I32 add;
79072805 LW	174	{
463ee0b2 LW	175	register char *name = nambeg;
463ee0b2 LW	176	register GV *gv = 0;
79072805	177	GV**gvp;
79072805 LW	178	I32 len;
79072805 LW	179	register char *namend;
463ee0b2	180	HV *stash = 0;
79072805	181	bool global = FALSE;
463ee0b2	182	char tmpbuf[256];
79072805	183
79072805	184	for (namend = name; *namend; namend++) {
463ee0b2 LW	185	if ((*namend == '\'' && namend[1]) \|\|
	186	(*namend == ':' && namend[1] == ':'))
	187	{
	188	len = namend - name;
79072805	189	*tmpbuf = '_';
463ee0b2 LW	190	Copy(name, tmpbuf+1, len, char);
	191	len++;
	192	tmpbuf[len] = '\0';
	193	if (!stash)
	194	stash = defstash;
	195
	196	if (len > 1) {
	197	gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
	198	if (!gvp \|\| gvp == (GV)&sv_undef)
	199	return Nullgv;
	200	gv = *gvp;
	201	if (SvTYPE(gv) == SVt_PVGV)
	202	SvMULTI_on(gv);
	203	else
	204	gv_init(gv, stash, nambeg, namend - nambeg, (add & 2));
	205	if (!(stash = GvHV(gv)))
	206	stash = GvHV(gv) = newHV();
	207	if (!HvNAME(stash))
	208	HvNAME(stash) = nsavestr(nambeg, namend - nambeg);
	209	}
	210
	211	if (*namend == ':')
	212	namend++;
	213	namend++;
	214	name = namend;
	215	if (!*name)
	216	return gv ? gv : defgv;
79072805	217	}
79072805	218	}
463ee0b2 LW	219
	220	/* No stash in name, so see how we can default */
	221
	222	if (!stash) {
	223	if (isIDFIRST(*name)) {
	224	if (isUPPER(*name)) {
	225	if (*name > 'I') {
	226	if (*name == 'S' && (
	227	strEQ(name, "SIG") \|\|
	228	strEQ(name, "STDIN") \|\|
	229	strEQ(name, "STDOUT") \|\|
	230	strEQ(name, "STDERR") ))
	231	global = TRUE;
	232	}
	233	else if (*name > 'E') {
	234	if (*name == 'I' && strEQ(name, "INC"))
	235	global = TRUE;
	236	}
	237	else if (*name > 'A') {
	238	if (*name == 'E' && strEQ(name, "ENV"))
	239	global = TRUE;
	240	}
	241	else if (*name == 'A' && (
	242	strEQ(name, "ARGV") \|\|
	243	strEQ(name, "ARGVOUT") ))
	244	global = TRUE;
	245	}
	246	else if (*name == '_' && !name[1])
	247	global = TRUE;
	248	if (global)
	249	stash = defstash;
	250	else if ((COP*)curcop == &compiling)
	251	stash = curstash;
	252	else
	253	stash = curcop->cop_stash;
	254	}
	255	else
	256	stash = defstash;
	257	}
	258
	259	/* By this point we should have a stash and a name */
	260
93a17b20	261	if (!stash)
463ee0b2	262	croak("Global symbol \"%s\" requires explicit package name", name);
79072805	263	len = namend - name;
463ee0b2 LW	264	if (!len)
463ee0b2 LW	265	len = 1;
79072805 LW	266	gvp = (GV**)hv_fetch(stash,name,len,add);
	267	if (!gvp \|\| gvp == (GV)&sv_undef)
	268	return Nullgv;
	269	gv = *gvp;
	270	if (SvTYPE(gv) == SVt_PVGV) {
	271	SvMULTI_on(gv);
	272	return gv;
	273	}
93a17b20 LW	274
	275	/* Adding a new symbol */
	276
463ee0b2	277	gv_init(gv, stash, name, len, add & 2);
93a17b20 LW	278
	279	/* set up magic where warranted */
	280	switch (*name) {
ed6116ce LW	281	case 'a':
	282	case 'b':
	283	if (len == 1)
	284	SvMULTI_on(gv);
	285	break;
463ee0b2 LW	286	case 'I':
	287	if (strEQ(name, "ISA")) {
	288	AV* av = GvAVn(gv);
	289	sv_magic((SV)av, (SV)gv, 'I', 0, 0);
	290	}
	291	break;
93a17b20 LW	292	case 'S':
	293	if (strEQ(name, "SIG")) {
	294	HV *hv;
	295	siggv = gv;
	296	SvMULTI_on(siggv);
	297	hv = GvHVn(siggv);
	298	hv_magic(hv, siggv, 'S');
	299
	300	/* initialize signal stack */
	301	signalstack = newAV();
	302	av_store(signalstack, 32, Nullsv);
	303	av_clear(signalstack);
	304	AvREAL_off(signalstack);
	305	}
	306	break;
	307
	308	case '&':
463ee0b2 LW	309	if (len > 1)
463ee0b2 LW	310	break;
93a17b20 LW	311	ampergv = gv;
	312	sawampersand = TRUE;
	313	goto magicalize;
	314
	315	case '`':
463ee0b2 LW	316	if (len > 1)
463ee0b2 LW	317	break;
93a17b20 LW	318	leftgv = gv;
	319	sawampersand = TRUE;
	320	goto magicalize;
	321
	322	case '\'':
463ee0b2 LW	323	if (len > 1)
463ee0b2 LW	324	break;
93a17b20 LW	325	rightgv = gv;
	326	sawampersand = TRUE;
	327	goto magicalize;
	328
	329	case ':':
463ee0b2 LW	330	if (len > 1)
463ee0b2 LW	331	break;
93a17b20 LW	332	sv_setpv(GvSV(gv),chopset);
	333	goto magicalize;
	334
	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 '\|':
	355	case '\004':
	356	case '\t':
	357	case '\020':
	358	case '\024':
	359	case '\027':
	360	case '\006':
463ee0b2 LW	361	if (len > 1)
	362	break;
	363	goto magicalize;
	364
	365	case '1':
	366	case '2':
	367	case '3':
	368	case '4':
	369	case '5':
	370	case '6':
	371	case '7':
	372	case '8':
	373	case '9':
93a17b20	374	magicalize:
463ee0b2	375	sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
93a17b20 LW	376	break;
	377
	378	case '\014':
463ee0b2 LW	379	if (len > 1)
463ee0b2 LW	380	break;
93a17b20 LW	381	sv_setpv(GvSV(gv),"\f");
	382	formfeed = GvSV(gv);
	383	break;
	384	case ';':
463ee0b2 LW	385	if (len > 1)
463ee0b2 LW	386	break;
93a17b20 LW	387	sv_setpv(GvSV(gv),"\034");
93a17b20 LW	388	break;
463ee0b2 LW	389	case ']':
463ee0b2 LW	390	if (len == 1) {
93a17b20 LW	391	SV *sv;
	392	sv = GvSV(gv);
	393	sv_upgrade(sv, SVt_PVNV);
	394	sv_setpv(sv,rcsid);
463ee0b2	395	SvNVX(sv) = atof(patchlevel);
93a17b20 LW	396	SvNOK_on(sv);
	397	}
	398	break;
79072805	399	}
93a17b20	400	return gv;
79072805 LW	401	}
	402
	403	void
	404	gv_fullname(sv,gv)
	405	SV *sv;
	406	GV *gv;
	407	{
	408	HV *hv = GvSTASH(gv);
	409
	410	if (!hv)
	411	return;
	412	sv_setpv(sv, sv == (SV)gv ? "" : "");
	413	sv_catpv(sv,HvNAME(hv));
463ee0b2	414	sv_catpvn(sv,"::", 2);
79072805 LW	415	sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
	416	}
	417
	418	void
	419	gv_efullname(sv,gv)
	420	SV *sv;
	421	GV *gv;
	422	{
	423	GV* egv = GvEGV(gv);
	424	HV *hv = GvSTASH(egv);
	425
	426	if (!hv)
	427	return;
	428	sv_setpv(sv, sv == (SV)gv ? "" : "");
	429	sv_catpv(sv,HvNAME(hv));
463ee0b2	430	sv_catpvn(sv,"::", 2);
79072805 LW	431	sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv));
	432	}
	433
	434	IO *
	435	newIO()
	436	{
	437	IO *io;
	438
	439	Newz(603,io,1,IO);
	440	io->page_len = 60;
	441	return io;
	442	}
	443
	444	void
463ee0b2 LW	445	gv_check(stash)
463ee0b2 LW	446	HV* stash;
79072805 LW	447	{
	448	register HE *entry;
	449	register I32 i;
	450	register GV *gv;
463ee0b2 LW	451	HV *hv;
	452
	453	for (i = 0; i <= HvMAX(stash); i++) {
	454	for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
	455	if (isALPHA(*entry->hent_key)) {
	456	gv = (GV*)entry->hent_val;
	457	if (SvMULTI(gv))
	458	continue;
	459	curcop->cop_line = GvLINE(gv);
	460	warn("Possible typo: \"%s::%s\"", HvNAME(stash), GvNAME(gv));
	461	}
	462	else if (*entry->hent_key == '_' &&
	463	(gv = (GV*)entry->hent_val) &&
	464	(hv = GvHV(gv)) && HvNAME(hv) && hv != defstash)
	465	gv_check(hv); /* nested package */
	466
79072805 LW	467	}
	468	}
	469	}
	470
	471	GV *
	472	newGVgen()
	473	{
	474	(void)sprintf(tokenbuf,"_GEN_%d",gensym++);
	475	return gv_fetchpv(tokenbuf,TRUE);
	476	}
	477
	478	/* hopefully this is only called on local symbol table entries */
	479
	480	GP*
	481	gp_ref(gp)
	482	GP* gp;
	483	{
	484	gp->gp_refcnt++;
	485	return gp;
	486
	487	}
	488
	489	void
	490	gp_free(gv)
	491	GV* gv;
	492	{
	493	IO *io;
	494	CV *cv;
	495	GP* gp;
	496
	497	if (!gv \|\| !(gp = GvGP(gv)))
	498	return;
	499	if (gp->gp_refcnt == 0) {
	500	warn("Attempt to free unreferenced glob pointers");
	501	return;
	502	}
	503	if (--gp->gp_refcnt > 0)
	504	return;
	505
463ee0b2 LW	506	sv_free((SV*)gp->gp_sv);
	507	sv_free((SV*)gp->gp_av);
	508	sv_free((SV*)gp->gp_hv);
79072805 LW	509	if (io = gp->gp_io) {
	510	do_close(gv,FALSE);
	511	Safefree(io->top_name);
	512	Safefree(io->fmt_name);
	513	Safefree(io);
	514	}
	515	if (cv = gp->gp_cv)
463ee0b2	516	sv_free((SV*)cv);
79072805 LW	517	Safefree(gp);
	518	GvGP(gv) = 0;
	519	}
	520
	521	#if defined(CRIPPLED_CC) && (defined(iAPX286) \|\| defined(M_I286) \|\| defined(I80286))
	522	#define MICROPORT
	523	#endif
	524
	525	#ifdef MICROPORT /* Microport 2.4 hack */
	526	AV *GvAVn(gv)
	527	register GV *gv;
	528	{
	529	if (GvGP(gv)->gp_av)
	530	return GvGP(gv)->gp_av;
	531	else
	532	return GvGP(gv_AVadd(gv))->gp_av;
	533	}
	534
	535	HV *GvHVn(gv)
	536	register GV *gv;
	537	{
	538	if (GvGP(gv)->gp_hv)
	539	return GvGP(gv)->gp_hv;
	540	else
	541	return GvGP(gv_HVadd(gv))->gp_hv;
	542	}
	543	#endif /* Microport 2.4 hack */
	544
	545	GV *
	546	fetch_gv(op,num)
	547	OP *op;
	548	I32 num;
	549	{
	550	if (op->op_private < num)
	551	return 0;
	552	if (op->op_flags & OPf_STACKED)
463ee0b2	553	return gv_fetchpv(SvPVx(*(stack_sp--), na),TRUE);
79072805 LW	554	else
	555	return cGVOP->op_gv;
	556	}
	557
	558	IO *
	559	fetch_io(op,num)
	560	OP *op;
	561	I32 num;
	562	{
	563	GV *gv;
	564
	565	if (op->op_private < num)
	566	return 0;
	567	if (op->op_flags & OPf_STACKED)
463ee0b2	568	gv = gv_fetchpv(SvPVx(*(stack_sp--), na),TRUE);
79072805 LW	569	else
	570	gv = cGVOP->op_gv;
	571
	572	if (!gv)
	573	return 0;
	574
	575	return GvIOn(gv);
	576	}