perl 5.0 alpha 2perl-5a2

[editor's note: from history.perl.org.  The sparc executables
originally included in the distribution are not in this commit.]

1 files changed, 388 insertions, 0 deletions

diff --git a/gv.c b/gv.c
new file mode 100644
index 0000000000..9e1f5337d4
--- /dev/null
+++ b/gv.c
@@ -0,0 +1,388 @@
+/* $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);
+}