[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, SVt_PVGV);
    sv_setpv(GvSV(gv), name);
    if (*name == '/')
	SvMULTI_on(gv);
    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_ref(gp);
    GvREFCNT(gv) = 1;
    GvSV(gv) = NEWSV(72,0);
    GvLINE(gv) = curcop->cop_line;
    GvFILEGV(gv) = curcop->cop_filegv;
    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, SVt_PVCV);
	}
    }
    return gv_fetchmeth(stash, name, nend - name);
}

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

    for (namend = name; *namend; namend++) {
	if ((*namend == '\'' && namend[1]) ||
	    (*namend == ':' && namend[1] == ':'))
	{
	    if (!stash)
		stash = defstash;

	    len = namend - name;
	    if (len > 0) {
		New(601, tmpbuf, len+2, char);
		*tmpbuf = '_';
		Copy(name, tmpbuf+1, len, char);
		tmpbuf[++len] = '\0';
		gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
		Safefree(tmpbuf);
		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) {
		if (!(hints & HINT_STRICT_VARS) || svtype == SVt_PVCV)
		    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);
	    SvMULTI_on(gv);
	    sv_magic((SV*)av, (SV*)gv, 'I', 0, 0);
	    if (add & 2 && strEQ(nambeg,"Any_DBM_File::ISA") && AvFILL(av) == -1)
	    {
		av_push(av, newSVpv("NDBM_File",0));
		av_push(av, newSVpv("DB_File",0));
		av_push(av, newSVpv("GDBM_File",0));
		av_push(av, newSVpv("SDBM_File",0));
		av_push(av, newSVpv("ODBM_File",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;
    GV *iogv;

    io = (IO*)NEWSV(0,0);
    sv_upgrade(io,SVt_PVIO);
    SvREFCNT(io) = 1;
    SvOBJECT_on(io);
    iogv = gv_fetchpv("FileHandle::", TRUE, SVt_PVIO);
    SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
    return io;
}

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

    if (!HvARRAY(stash))
	return;
    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);
		curcop->cop_filegv = GvFILEGV(gv);
		if (SvMULTI(GvFILEGV(gv)))	/* Filename began with slash */
		    continue;
		warn("Identifier \"%s::%s\" used only once: possible typo", 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, SVt_PVGV);
}

/* 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;

    SvREFCNT_dec(gp->gp_sv);
    SvREFCNT_dec(gp->gp_av);
    SvREFCNT_dec(gp->gp_hv);
    if ((io = gp->gp_io) && SvTYPE(io) != SVTYPEMASK) {
	do_close(gv,FALSE);
	SvREFCNT_dec(io);
    }
    if ((cv = gp->gp_cv) && !GvCVGEN(gv))
	SvREFCNT_dec(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 */
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
8990e307	73	sprintf(tmpbuf,"::_<%s", name);
85e6fe83	74	gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV);
79072805	75	sv_setpv(GvSV(gv), name);
8990e307 LW	76	if (*name == '/')
8990e307 LW	77	SvMULTI_on(gv);
79072805	78	if (perldb)
93a17b20	79	hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
79072805 LW	80	return gv;
	81	}
	82
463ee0b2 LW	83	void
	84	gv_init(gv, stash, name, len, multi)
	85	GV *gv;
	86	HV *stash;
	87	char *name;
	88	STRLEN len;
	89	int multi;
	90	{
	91	register GP *gp;
	92
	93	sv_upgrade(gv, SVt_PVGV);
	94	if (SvLEN(gv))
	95	Safefree(SvPVX(gv));
	96	Newz(602,gp, 1, GP);
8990e307	97	GvGP(gv) = gp_ref(gp);
463ee0b2 LW	98	GvREFCNT(gv) = 1;
	99	GvSV(gv) = NEWSV(72,0);
	100	GvLINE(gv) = curcop->cop_line;
8990e307	101	GvFILEGV(gv) = curcop->cop_filegv;
463ee0b2 LW	102	GvEGV(gv) = gv;
	103	sv_magic((SV)gv, (SV)gv, '*', name, len);
	104	GvSTASH(gv) = stash;
	105	GvNAME(gv) = nsavestr(name, len);
	106	GvNAMELEN(gv) = len;
	107	if (multi)
	108	SvMULTI_on(gv);
	109	}
	110
79072805	111	GV *
463ee0b2	112	gv_fetchmeth(stash, name, len)
79072805 LW	113	HV* stash;
79072805 LW	114	char* name;
463ee0b2	115	STRLEN len;
79072805 LW	116	{
79072805 LW	117	AV* av;
463ee0b2	118	GV* topgv;
79072805	119	GV* gv;
463ee0b2 LW	120	GV** gvp;
	121
	122	gvp = (GV**)hv_fetch(stash, name, len, TRUE);
	123
	124	DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) );
	125	topgv = *gvp;
	126	if (SvTYPE(topgv) != SVt_PVGV)
	127	gv_init(topgv, stash, name, len, TRUE);
	128
	129	if (GvCV(topgv)) {
	130	if (!GvCVGEN(topgv) \|\| GvCVGEN(topgv) >= sub_generation)
	131	return topgv;
	132	}
79072805 LW	133
	134	gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
	135	if (gvp && (gv = gvp) != (GV)&sv_undef && (av = GvAV(gv))) {
	136	SV** svp = AvARRAY(av);
	137	I32 items = AvFILL(av) + 1;
	138	while (items--) {
79072805	139	SV* sv = *svp++;
9bbf4081 LW	140	HV* basestash = fetch_stash(sv, FALSE);
9bbf4081 LW	141	if (!basestash) {
79072805 LW	142	if (dowarn)
79072805 LW	143	warn("Can't locate package %s for @%s'ISA",
463ee0b2	144	SvPVX(sv), HvNAME(stash));
79072805 LW	145	continue;
79072805 LW	146	}
9bbf4081	147	gv = gv_fetchmeth(basestash, name, len);
463ee0b2 LW	148	if (gv) {
	149	GvCV(topgv) = GvCV(gv); /* cache the CV */
	150	GvCVGEN(topgv) = sub_generation; /* valid for now */
79072805	151	return gv;
463ee0b2	152	}
79072805 LW	153	}
	154	}
	155	return 0;
	156	}
	157
	158	GV *
463ee0b2 LW	159	gv_fetchmethod(stash, name)
	160	HV* stash;
	161	char* name;
	162	{
	163	register char *nend;
	164
	165	for (nend = name; *nend; nend++) {
	166	if (nend == ':' \|\| nend == '\'') {
85e6fe83	167	return gv_fetchpv(name, FALSE, SVt_PVCV);
463ee0b2 LW	168	}
	169	}
	170	return gv_fetchmeth(stash, name, nend - name);
	171	}
	172
	173	GV *
85e6fe83	174	gv_fetchpv(nambeg,add,svtype)
463ee0b2	175	char *nambeg;
79072805	176	I32 add;
85e6fe83	177	I32 svtype;
79072805	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;
85e6fe83	186	char *tmpbuf;
79072805	187
79072805	188	for (namend = name; *namend; namend++) {
463ee0b2 LW	189	if ((*namend == '\'' && namend[1]) \|\|
	190	(*namend == ':' && namend[1] == ':'))
	191	{
463ee0b2 LW	192	if (!stash)
	193	stash = defstash;
	194
85e6fe83 LW	195	len = namend - name;
	196	if (len > 0) {
	197	New(601, tmpbuf, len+2, char);
	198	*tmpbuf = '_';
	199	Copy(name, tmpbuf+1, len, char);
	200	tmpbuf[++len] = '\0';
463ee0b2	201	gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
85e6fe83	202	Safefree(tmpbuf);
463ee0b2 LW	203	if (!gvp \|\| gvp == (GV)&sv_undef)
	204	return Nullgv;
	205	gv = *gvp;
85e6fe83	206
463ee0b2 LW	207	if (SvTYPE(gv) == SVt_PVGV)
	208	SvMULTI_on(gv);
	209	else
	210	gv_init(gv, stash, nambeg, namend - nambeg, (add & 2));
85e6fe83	211
463ee0b2 LW	212	if (!(stash = GvHV(gv)))
463ee0b2 LW	213	stash = GvHV(gv) = newHV();
85e6fe83	214
463ee0b2 LW	215	if (!HvNAME(stash))
	216	HvNAME(stash) = nsavestr(nambeg, namend - nambeg);
	217	}
	218
	219	if (*namend == ':')
	220	namend++;
	221	namend++;
	222	name = namend;
	223	if (!*name)
	224	return gv ? gv : defgv;
79072805	225	}
79072805	226	}
463ee0b2 LW	227
	228	/* No stash in name, so see how we can default */
	229
	230	if (!stash) {
	231	if (isIDFIRST(*name)) {
	232	if (isUPPER(*name)) {
	233	if (*name > 'I') {
	234	if (*name == 'S' && (
	235	strEQ(name, "SIG") \|\|
	236	strEQ(name, "STDIN") \|\|
	237	strEQ(name, "STDOUT") \|\|
	238	strEQ(name, "STDERR") ))
	239	global = TRUE;
	240	}
	241	else if (*name > 'E') {
	242	if (*name == 'I' && strEQ(name, "INC"))
	243	global = TRUE;
	244	}
	245	else if (*name > 'A') {
	246	if (*name == 'E' && strEQ(name, "ENV"))
	247	global = TRUE;
	248	}
	249	else if (*name == 'A' && (
	250	strEQ(name, "ARGV") \|\|
	251	strEQ(name, "ARGVOUT") ))
	252	global = TRUE;
	253	}
	254	else if (*name == '_' && !name[1])
	255	global = TRUE;
	256	if (global)
	257	stash = defstash;
85e6fe83 LW	258	else if ((COP*)curcop == &compiling) {
	259	if (!(hints & HINT_STRICT_VARS) \|\| svtype == SVt_PVCV)
	260	stash = curstash;
	261	}
463ee0b2 LW	262	else
	263	stash = curcop->cop_stash;
	264	}
	265	else
	266	stash = defstash;
	267	}
	268
	269	/* By this point we should have a stash and a name */
	270
93a17b20	271	if (!stash)
463ee0b2	272	croak("Global symbol \"%s\" requires explicit package name", name);
79072805	273	len = namend - name;
463ee0b2 LW	274	if (!len)
463ee0b2 LW	275	len = 1;
79072805 LW	276	gvp = (GV**)hv_fetch(stash,name,len,add);
	277	if (!gvp \|\| gvp == (GV)&sv_undef)
	278	return Nullgv;
	279	gv = *gvp;
	280	if (SvTYPE(gv) == SVt_PVGV) {
	281	SvMULTI_on(gv);
	282	return gv;
	283	}
93a17b20 LW	284
	285	/* Adding a new symbol */
	286
463ee0b2	287	gv_init(gv, stash, name, len, add & 2);
93a17b20 LW	288
	289	/* set up magic where warranted */
	290	switch (*name) {
ed6116ce LW	291	case 'a':
	292	case 'b':
	293	if (len == 1)
	294	SvMULTI_on(gv);
	295	break;
463ee0b2 LW	296	case 'I':
	297	if (strEQ(name, "ISA")) {
	298	AV* av = GvAVn(gv);
8990e307	299	SvMULTI_on(gv);
463ee0b2	300	sv_magic((SV)av, (SV)gv, 'I', 0, 0);
85e6fe83 LW	301	if (add & 2 && strEQ(nambeg,"Any_DBM_File::ISA") && AvFILL(av) == -1)
	302	{
	303	av_push(av, newSVpv("NDBM_File",0));
	304	av_push(av, newSVpv("DB_File",0));
	305	av_push(av, newSVpv("GDBM_File",0));
	306	av_push(av, newSVpv("SDBM_File",0));
	307	av_push(av, newSVpv("ODBM_File",0));
	308	}
463ee0b2 LW	309	}
463ee0b2 LW	310	break;
93a17b20 LW	311	case 'S':
	312	if (strEQ(name, "SIG")) {
	313	HV *hv;
	314	siggv = gv;
	315	SvMULTI_on(siggv);
	316	hv = GvHVn(siggv);
	317	hv_magic(hv, siggv, 'S');
	318
	319	/* initialize signal stack */
	320	signalstack = newAV();
	321	av_store(signalstack, 32, Nullsv);
	322	av_clear(signalstack);
	323	AvREAL_off(signalstack);
	324	}
	325	break;
	326
	327	case '&':
463ee0b2 LW	328	if (len > 1)
463ee0b2 LW	329	break;
93a17b20 LW	330	ampergv = gv;
	331	sawampersand = TRUE;
	332	goto magicalize;
	333
	334	case '`':
463ee0b2 LW	335	if (len > 1)
463ee0b2 LW	336	break;
93a17b20 LW	337	leftgv = gv;
	338	sawampersand = TRUE;
	339	goto magicalize;
	340
	341	case '\'':
463ee0b2 LW	342	if (len > 1)
463ee0b2 LW	343	break;
93a17b20 LW	344	rightgv = gv;
	345	sawampersand = TRUE;
	346	goto magicalize;
	347
	348	case ':':
463ee0b2 LW	349	if (len > 1)
463ee0b2 LW	350	break;
93a17b20 LW	351	sv_setpv(GvSV(gv),chopset);
	352	goto magicalize;
	353
	354	case '!':
	355	case '#':
	356	case '?':
	357	case '^':
	358	case '~':
	359	case '=':
	360	case '-':
	361	case '%':
	362	case '.':
	363	case '+':
	364	case '*':
	365	case '(':
	366	case ')':
	367	case '<':
	368	case '>':
	369	case ',':
	370	case '\\':
	371	case '/':
	372	case '[':
	373	case '\|':
	374	case '\004':
	375	case '\t':
	376	case '\020':
	377	case '\024':
	378	case '\027':
	379	case '\006':
463ee0b2 LW	380	if (len > 1)
	381	break;
	382	goto magicalize;
	383
	384	case '1':
	385	case '2':
	386	case '3':
	387	case '4':
	388	case '5':
	389	case '6':
	390	case '7':
	391	case '8':
	392	case '9':
93a17b20	393	magicalize:
463ee0b2	394	sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
93a17b20 LW	395	break;
	396
	397	case '\014':
463ee0b2 LW	398	if (len > 1)
463ee0b2 LW	399	break;
93a17b20 LW	400	sv_setpv(GvSV(gv),"\f");
	401	formfeed = GvSV(gv);
	402	break;
	403	case ';':
463ee0b2 LW	404	if (len > 1)
463ee0b2 LW	405	break;
93a17b20 LW	406	sv_setpv(GvSV(gv),"\034");
93a17b20 LW	407	break;
463ee0b2 LW	408	case ']':
463ee0b2 LW	409	if (len == 1) {
93a17b20 LW	410	SV *sv;
	411	sv = GvSV(gv);
	412	sv_upgrade(sv, SVt_PVNV);
	413	sv_setpv(sv,rcsid);
463ee0b2	414	SvNVX(sv) = atof(patchlevel);
93a17b20 LW	415	SvNOK_on(sv);
	416	}
	417	break;
79072805	418	}
93a17b20	419	return gv;
79072805 LW	420	}
	421
	422	void
	423	gv_fullname(sv,gv)
	424	SV *sv;
	425	GV *gv;
	426	{
	427	HV *hv = GvSTASH(gv);
	428
	429	if (!hv)
	430	return;
	431	sv_setpv(sv, sv == (SV)gv ? "" : "");
	432	sv_catpv(sv,HvNAME(hv));
463ee0b2	433	sv_catpvn(sv,"::", 2);
79072805 LW	434	sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
	435	}
	436
	437	void
	438	gv_efullname(sv,gv)
	439	SV *sv;
	440	GV *gv;
	441	{
	442	GV* egv = GvEGV(gv);
	443	HV *hv = GvSTASH(egv);
	444
	445	if (!hv)
	446	return;
	447	sv_setpv(sv, sv == (SV)gv ? "" : "");
	448	sv_catpv(sv,HvNAME(hv));
463ee0b2	449	sv_catpvn(sv,"::", 2);
79072805 LW	450	sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv));
	451	}
	452
	453	IO *
	454	newIO()
	455	{
	456	IO *io;
8990e307 LW	457	GV *iogv;
	458
	459	io = (IO*)NEWSV(0,0);
	460	sv_upgrade(io,SVt_PVIO);
	461	SvREFCNT(io) = 1;
	462	SvOBJECT_on(io);
85e6fe83	463	iogv = gv_fetchpv("FileHandle::", TRUE, SVt_PVIO);
8990e307	464	SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
79072805 LW	465	return io;
	466	}
	467
	468	void
463ee0b2 LW	469	gv_check(stash)
463ee0b2 LW	470	HV* stash;
79072805 LW	471	{
	472	register HE *entry;
	473	register I32 i;
	474	register GV *gv;
463ee0b2 LW	475	HV *hv;
463ee0b2 LW	476
8990e307 LW	477	if (!HvARRAY(stash))
8990e307 LW	478	return;
463ee0b2 LW	479	for (i = 0; i <= HvMAX(stash); i++) {
	480	for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
	481	if (isALPHA(*entry->hent_key)) {
	482	gv = (GV*)entry->hent_val;
	483	if (SvMULTI(gv))
	484	continue;
	485	curcop->cop_line = GvLINE(gv);
8990e307 LW	486	curcop->cop_filegv = GvFILEGV(gv);
	487	if (SvMULTI(GvFILEGV(gv))) /* Filename began with slash */
	488	continue;
2304df62	489	warn("Identifier \"%s::%s\" used only once: possible typo", HvNAME(stash), GvNAME(gv));
463ee0b2 LW	490	}
	491	else if (*entry->hent_key == '_' &&
	492	(gv = (GV*)entry->hent_val) &&
	493	(hv = GvHV(gv)) && HvNAME(hv) && hv != defstash)
	494	gv_check(hv); /* nested package */
	495
79072805 LW	496	}
	497	}
	498	}
	499
	500	GV *
	501	newGVgen()
	502	{
	503	(void)sprintf(tokenbuf,"_GEN_%d",gensym++);
85e6fe83	504	return gv_fetchpv(tokenbuf,TRUE, SVt_PVGV);
79072805 LW	505	}
	506
	507	/* hopefully this is only called on local symbol table entries */
	508
	509	GP*
	510	gp_ref(gp)
	511	GP* gp;
	512	{
	513	gp->gp_refcnt++;
	514	return gp;
	515
	516	}
	517
	518	void
	519	gp_free(gv)
	520	GV* gv;
	521	{
	522	IO *io;
	523	CV *cv;
	524	GP* gp;
	525
	526	if (!gv \|\| !(gp = GvGP(gv)))
	527	return;
	528	if (gp->gp_refcnt == 0) {
	529	warn("Attempt to free unreferenced glob pointers");
	530	return;
	531	}
	532	if (--gp->gp_refcnt > 0)
	533	return;
	534
8990e307 LW	535	SvREFCNT_dec(gp->gp_sv);
	536	SvREFCNT_dec(gp->gp_av);
	537	SvREFCNT_dec(gp->gp_hv);
	538	if ((io = gp->gp_io) && SvTYPE(io) != SVTYPEMASK) {
79072805	539	do_close(gv,FALSE);
8990e307	540	SvREFCNT_dec(io);
79072805	541	}
8990e307 LW	542	if ((cv = gp->gp_cv) && !GvCVGEN(gv))
8990e307 LW	543	SvREFCNT_dec(cv);
79072805 LW	544	Safefree(gp);
	545	GvGP(gv) = 0;
	546	}
	547
	548	#if defined(CRIPPLED_CC) && (defined(iAPX286) \|\| defined(M_I286) \|\| defined(I80286))
	549	#define MICROPORT
	550	#endif
	551
	552	#ifdef MICROPORT /* Microport 2.4 hack */
	553	AV *GvAVn(gv)
	554	register GV *gv;
	555	{
	556	if (GvGP(gv)->gp_av)
	557	return GvGP(gv)->gp_av;
	558	else
	559	return GvGP(gv_AVadd(gv))->gp_av;
	560	}
	561
	562	HV *GvHVn(gv)
	563	register GV *gv;
	564	{
	565	if (GvGP(gv)->gp_hv)
	566	return GvGP(gv)->gp_hv;
	567	else
	568	return GvGP(gv_HVadd(gv))->gp_hv;
	569	}
	570	#endif /* Microport 2.4 hack */