[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"

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(COEFFSIZE);
    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)
	(void)gv_HVadd(gv_AVadd(gv));
    return gv;
}

GV *
gv_fetchmethod(stash, name)
HV* stash;
char* name;
{
    AV* av;
    GV* gv;
    GV** gvp = (GV**)hv_fetch(stash,name,strlen(name),FALSE);
    if (gvp && (gv = *gvp) != (GV*)&sv_undef && GvCV(gv))
	return gv;

    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,SvPVn(sv));
	    gv = gv_fetchpv(tmpbuf,FALSE);
	    if (!gv || !(stash = GvHV(gv))) {
		if (dowarn)
		    warn("Can't locate package %s for @%s'ISA",
			SvPV(sv), HvNAME(stash));
		continue;
	    }
	    gv = gv_fetchmethod(stash, name);
	    if (gv)
		return gv;
	}
    }
    return 0;
}

GV *
gv_fetchpv(name,add)
register char *name;
I32 add;
{
    register GV *gv;
    GV**gvp;
    register GP *gp;
    I32 len;
    register char *namend;
    HV *stash;
    char *sawquote = Nullch;
    char *prevquote = Nullch;
    bool global = FALSE;

    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;
    }
    for (namend = name; *namend; namend++) {
	if (*namend == '\'' && namend[1])
	    prevquote = sawquote, sawquote = namend;
    }
    if (sawquote == name && name[1]) {
	stash = defstash;
	sawquote = Nullch;
	name++;
    }
    else if (!isALPHA(*name) || global)
	stash = defstash;
    else if ((COP*)curcop == &compiling)
	stash = curstash;
    else
	stash = curcop->cop_stash;
    if (sawquote) {
	char tmpbuf[256];
	char *s, *d;

	*sawquote = '\0';
	/*SUPPRESS 560*/
	if (s = prevquote) {
	    strncpy(tmpbuf,name,s-name+1);
	    d = tmpbuf+(s-name+1);
	    *d++ = '_';
	    strcpy(d,s+1);
	}
	else {
	    *tmpbuf = '_';
	    strcpy(tmpbuf+1,name);
	}
	gv = gv_fetchpv(tmpbuf,TRUE);
	if (!(stash = GvHV(gv)))
	    stash = GvHV(gv) = newHV(0);
	if (!HvNAME(stash))
	    HvNAME(stash) = savestr(name);
	name = sawquote+1;
	*sawquote = '\'';
    }
    len = namend - name;
    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;
    }
    else {
	sv_upgrade(gv, SVt_PVGV);
	if (SvLEN(gv))
	    Safefree(SvPV(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 (isDIGIT(*name) && *name != '0')
	    sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
	if (add & 2)
	    SvMULTI_on(gv);
	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,"'", 1);
    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,"'", 1);
    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(min,max)
I32 min;
register I32 max;
{
    register HE *entry;
    register I32 i;
    register GV *gv;

    for (i = min; i <= max; i++) {
	for (entry = HvARRAY(defstash)[i]; entry; entry = entry->hent_next) {
	    gv = (GV*)entry->hent_val;
	    if (SvMULTI(gv))
		continue;
	    curcop->cop_line = GvLINE(gv);
	    warn("Possible typo: \"%s\"", GvNAME(gv));
	}
    }
}

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(gp->gp_sv);
    sv_free(gp->gp_av);
    sv_free(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(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(SvPVnx(*(stack_sp--)),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(SvPVnx(*(stack_sp--)),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
	46	GV *
	47	gv_AVadd(gv)
	48	register GV *gv;
	49	{
	50	if (!GvAV(gv))
	51	GvAV(gv) = newAV();
	52	return gv;
	53	}
	54
	55	GV *
	56	gv_HVadd(gv)
	57	register GV *gv;
	58	{
	59	if (!GvHV(gv))
	60	GvHV(gv) = newHV(COEFFSIZE);
	61	return gv;
	62	}
	63
	64	GV *
65	gv_fetchfile(name)
66	char *name;
67	{
68	char tmpbuf[1200];
69	GV *gv;
70
71	sprintf(tmpbuf,"'_<%s", name);
72	gv = gv_fetchpv(tmpbuf, TRUE);
73	sv_setpv(GvSV(gv), name);
74	if (perldb)
75	(void)gv_HVadd(gv_AVadd(gv));
76	return gv;
77	}
78
79	GV *
80	gv_fetchmethod(stash, name)
81	HV* stash;
82	char* name;
83	{
84	AV* av;
85	GV* gv;
86	GV gvp = (GV)hv_fetch(stash,name,strlen(name),FALSE);
87	if (gvp && (gv = gvp) != (GV)&sv_undef && GvCV(gv))
88	return gv;
89
90	gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
91	if (gvp && (gv = gvp) != (GV)&sv_undef && (av = GvAV(gv))) {
92	SV** svp = AvARRAY(av);
93	I32 items = AvFILL(av) + 1;
94	while (items--) {
95	char tmpbuf[512];
96	SV* sv = *svp++;
97	*tmpbuf = '_';
98	SvUPGRADE(sv, SVt_PV);
99	strcpy(tmpbuf+1,SvPVn(sv));
100	gv = gv_fetchpv(tmpbuf,FALSE);
101	if (!gv \|\| !(stash = GvHV(gv))) {
102	if (dowarn)
103	warn("Can't locate package %s for @%s'ISA",
104	SvPV(sv), HvNAME(stash));
105	continue;
106	}
107	gv = gv_fetchmethod(stash, name);
108	if (gv)
109	return gv;
110	}
111	}
112	return 0;
113	}
114
115	GV *
116	gv_fetchpv(name,add)
117	register char *name;
118	I32 add;
119	{
120	register GV *gv;
121	GV**gvp;
122	register GP *gp;
123	I32 len;
124	register char *namend;
125	HV *stash;
126	char *sawquote = Nullch;
127	char *prevquote = Nullch;
128	bool global = FALSE;
129
130	if (isUPPER(*name)) {
131	if (*name > 'I') {
132	if (*name == 'S' && (
133	strEQ(name, "SIG") \|\|
134	strEQ(name, "STDIN") \|\|
135	strEQ(name, "STDOUT") \|\|
136	strEQ(name, "STDERR") ))
137	global = TRUE;
138	}
139	else if (*name > 'E') {
140	if (*name == 'I' && strEQ(name, "INC"))
141	global = TRUE;
142	}
143	else if (*name > 'A') {
144	if (*name == 'E' && strEQ(name, "ENV"))
145	global = TRUE;
146	}
147	else if (*name == 'A' && (
148	strEQ(name, "ARGV") \|\|
149	strEQ(name, "ARGVOUT") ))
150	global = TRUE;
151	}
152	for (namend = name; *namend; namend++) {
153	if (*namend == '\'' && namend[1])
154	prevquote = sawquote, sawquote = namend;
155	}
156	if (sawquote == name && name[1]) {
157	stash = defstash;
158	sawquote = Nullch;
159	name++;
160	}
161	else if (!isALPHA(*name) \|\| global)
162	stash = defstash;
163	else if ((COP*)curcop == &compiling)
164	stash = curstash;
165	else
166	stash = curcop->cop_stash;
167	if (sawquote) {
168	char tmpbuf[256];
169	char s, d;
170
171	*sawquote = '\0';
172	/SUPPRESS 560/
173	if (s = prevquote) {
174	strncpy(tmpbuf,name,s-name+1);
175	d = tmpbuf+(s-name+1);
176	*d++ = '_';
177	strcpy(d,s+1);
178	}
179	else {
180	*tmpbuf = '_';
181	strcpy(tmpbuf+1,name);
182	}
183	gv = gv_fetchpv(tmpbuf,TRUE);
184	if (!(stash = GvHV(gv)))
185	stash = GvHV(gv) = newHV(0);
186	if (!HvNAME(stash))
187	HvNAME(stash) = savestr(name);
188	name = sawquote+1;
189	*sawquote = '\'';
190	}
191	len = namend - name;
192	gvp = (GV**)hv_fetch(stash,name,len,add);
193	if (!gvp \|\| gvp == (GV)&sv_undef)
194	return Nullgv;
195	gv = *gvp;
196	if (SvTYPE(gv) == SVt_PVGV) {
197	SvMULTI_on(gv);
198	return gv;
199	}
200	else {
201	sv_upgrade(gv, SVt_PVGV);
202	if (SvLEN(gv))
203	Safefree(SvPV(gv));
204	Newz(602,gp, 1, GP);
205	GvGP(gv) = gp;
206	GvREFCNT(gv) = 1;
207	GvSV(gv) = NEWSV(72,0);
208	GvLINE(gv) = curcop->cop_line;
209	GvEGV(gv) = gv;
210	sv_magic((SV)gv, (SV)gv, '*', name, len);
211	GvSTASH(gv) = stash;
212	GvNAME(gv) = nsavestr(name, len);
213	GvNAMELEN(gv) = len;
214	if (isDIGIT(name) && name != '0')
215	sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
216	if (add & 2)
217	SvMULTI_on(gv);
218	return gv;
219	}
220	}
221
222	void
223	gv_fullname(sv,gv)
224	SV *sv;
225	GV *gv;
226	{
227	HV *hv = GvSTASH(gv);
228
229	if (!hv)
230	return;
231	sv_setpv(sv, sv == (SV)gv ? "" : "");
232	sv_catpv(sv,HvNAME(hv));
233	sv_catpvn(sv,"'", 1);
234	sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
235	}
236
237	void
238	gv_efullname(sv,gv)
239	SV *sv;
240	GV *gv;
241	{
242	GV* egv = GvEGV(gv);
243	HV *hv = GvSTASH(egv);
244
245	if (!hv)
246	return;
247	sv_setpv(sv, sv == (SV)gv ? "" : "");
248	sv_catpv(sv,HvNAME(hv));
249	sv_catpvn(sv,"'", 1);
250	sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv));
251	}
252
253	IO *
254	newIO()
255	{
256	IO *io;
257
258	Newz(603,io,1,IO);
259	io->page_len = 60;
260	return io;
261	}
262
263	void
264	gv_check(min,max)
265	I32 min;
266	register I32 max;
267	{
268	register HE *entry;
269	register I32 i;
270	register GV *gv;
271
272	for (i = min; i <= max; i++) {
273	for (entry = HvARRAY(defstash)[i]; entry; entry = entry->hent_next) {
274	gv = (GV*)entry->hent_val;
275	if (SvMULTI(gv))
276	continue;
277	curcop->cop_line = GvLINE(gv);
278	warn("Possible typo: \"%s\"", GvNAME(gv));
279	}
280	}
281	}
282
283	GV *
284	newGVgen()
285	{
286	(void)sprintf(tokenbuf,"_GEN_%d",gensym++);
287	return gv_fetchpv(tokenbuf,TRUE);
288	}
289
290	/* hopefully this is only called on local symbol table entries */
291
292	GP*
293	gp_ref(gp)
294	GP* gp;
295	{
296	gp->gp_refcnt++;
297	return gp;
298
299	}
300
301	void
302	gp_free(gv)
303	GV* gv;
304	{
305	IO *io;
306	CV *cv;
307	GP* gp;
308
309	if (!gv \|\| !(gp = GvGP(gv)))
310	return;
311	if (gp->gp_refcnt == 0) {
312	warn("Attempt to free unreferenced glob pointers");
313	return;
314	}
315	if (--gp->gp_refcnt > 0)
316	return;
317
318	sv_free(gp->gp_sv);
319	sv_free(gp->gp_av);
320	sv_free(gp->gp_hv);
321	if (io = gp->gp_io) {
322	do_close(gv,FALSE);
323	Safefree(io->top_name);
324	Safefree(io->fmt_name);
325	Safefree(io);
326	}
327	if (cv = gp->gp_cv)
328	sv_free(cv);
329	Safefree(gp);
330	GvGP(gv) = 0;
331	}
332
333	#if defined(CRIPPLED_CC) && (defined(iAPX286) \|\| defined(M_I286) \|\| defined(I80286))
334	#define MICROPORT
335	#endif
336
337	#ifdef MICROPORT /* Microport 2.4 hack */
338	AV *GvAVn(gv)
339	register GV *gv;
340	{
341	if (GvGP(gv)->gp_av)
342	return GvGP(gv)->gp_av;
343	else
344	return GvGP(gv_AVadd(gv))->gp_av;
345	}
346
347	HV *GvHVn(gv)
348	register GV *gv;
349	{
350	if (GvGP(gv)->gp_hv)
351	return GvGP(gv)->gp_hv;
352	else
353	return GvGP(gv_HVadd(gv))->gp_hv;
354	}
355	#endif /* Microport 2.4 hack */
356
357	GV *
358	fetch_gv(op,num)
359	OP *op;
360	I32 num;
361	{
362	if (op->op_private < num)
363	return 0;
364	if (op->op_flags & OPf_STACKED)
365	return gv_fetchpv(SvPVnx(*(stack_sp--)),TRUE);
366	else
367	return cGVOP->op_gv;
368	}
369
370	IO *
371	fetch_io(op,num)
372	OP *op;
373	I32 num;
374	{
375	GV *gv;
376
377	if (op->op_private < num)
378	return 0;
379	if (op->op_flags & OPf_STACKED)
380	gv = gv_fetchpv(SvPVnx(*(stack_sp--)),TRUE);
381	else
382	gv = cGVOP->op_gv;
383
384	if (!gv)
385	return 0;
386
387	return GvIOn(gv);
388	}