X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=b68f2128604e4f67b5f4d9f6a860934b2cddf9a8;hb=392db708ea3e6ba973f656d139373678acbb4e63;hp=7f630d94a2bb355117dfd138c2654eb4a840a681;hpb=133706a6af5890d9737eb5c4dacb6252623311ea;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/gv.c b/gv.c
index 7f630d9..b68f212 100644
--- a/gv.c
+++ b/gv.c
@@ -576,9 +576,9 @@ S_require_errno(pTHX_ GV *gv)
 =for apidoc gv_stashpv
 
 Returns a pointer to the stash for a specified package.  C<name> should
-be a valid UTF-8 string.  If C<create> is set then the package will be
-created if it does not already exist.  If C<create> is not set and the
-package does not exist then NULL is returned.
+be a valid UTF-8 string and must be null-terminated.  If C<create> is set
+then the package will be created if it does not already exist.  If C<create>
+is not set and the package does not exist then NULL is returned.
 
 =cut
 */
@@ -589,6 +589,18 @@ Perl_gv_stashpv(pTHX_ const char *name, I32 create)
     return gv_stashpvn(name, strlen(name), create);
 }
 
+/*
+=for apidoc gv_stashpvn
+
+Returns a pointer to the stash for a specified package.  C<name> should
+be a valid UTF-8 string.  The C<namelen> parameter indicates the length of
+the C<name>, in bytes.  If C<create> is set then the package will be
+created if it does not already exist.  If C<create> is not set and the
+package does not exist then NULL is returned.
+
+=cut
+*/
+
 HV*
 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
 {
@@ -708,24 +720,31 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 	if (isIDFIRST_lazy(name)) {
 	    bool global = FALSE;
 
-	    if (isUPPER(*name)) {
-		if (*name == 'S' && (
-		    strEQ(name, "SIG") ||
-		    strEQ(name, "STDIN") ||
-		    strEQ(name, "STDOUT") ||
-		    strEQ(name, "STDERR")))
+	    /* name is always \0 terminated, and initial \0 wouldn't return
+	       true from isIDFIRST_lazy, so we know that name[1] is defined  */
+	    switch (name[1]) {
+	    case '\0':
+		if (*name == '_')
+		    global = TRUE;
+		break;
+	    case 'N':
+		if (strEQ(name, "INC") || strEQ(name, "ENV"))
 		    global = TRUE;
-		else if (*name == 'I' && strEQ(name, "INC"))
+		break;
+	    case 'I':
+		if (strEQ(name, "SIG"))
 		    global = TRUE;
-		else if (*name == 'E' && strEQ(name, "ENV"))
+		break;
+	    case 'T':
+		if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") ||
+		    strEQ(name, "STDERR"))
 		    global = TRUE;
-		else if (*name == 'A' && (
-		  strEQ(name, "ARGV") ||
-		  strEQ(name, "ARGVOUT")))
+		break;
+	    case 'R':
+		if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT"))
 		    global = TRUE;
+		break;
 	    }
-	    else if (*name == '_' && !name[1])
-		global = TRUE;
 
 	    if (global)
 		stash = PL_defstash;
@@ -817,246 +836,242 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
         GvMULTI_on(gv) ;
 
     /* set up magic where warranted */
-    switch (*name) {
-    case 'A':
-	if (strEQ(name, "ARGV")) {
-	    IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
-	}
-	break;
-    case 'E':
-	if (strnEQ(name, "EXPORT", 6))
-	    GvMULTI_on(gv);
-	break;
-    case 'I':
-	if (strEQ(name, "ISA")) {
-	    AV* av = GvAVn(gv);
-	    GvMULTI_on(gv);
-	    sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
-	    /* NOTE: No support for tied ISA */
-	    if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
-		&& AvFILLp(av) == -1)
+    if (len > 1) {
+	if (*name > 'V' ) {
+	    /* Nothing else to do.
+	       The compiler will probably turn the switch statement into a
+	       branch table. Make sure we avoid even that small overhead for
+	       the common case of lower case variable names.  */
+	} else {
+	    const char *name2 = name + 1;
+	    switch (*name) {
+	    case 'A':
+		if (strEQ(name2, "RGV")) {
+		    IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
+		}
+		break;
+	    case 'E':
+		if (strnEQ(name2, "XPORT", 5))
+		    GvMULTI_on(gv);
+		break;
+	    case 'I':
+		if (strEQ(name2, "SA")) {
+		    AV* av = GvAVn(gv);
+		    GvMULTI_on(gv);
+		    sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
+		    /* NOTE: No support for tied ISA */
+		    if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
+			&& AvFILLp(av) == -1)
+			{
+			    char *pname;
+			    av_push(av, newSVpvn(pname = "NDBM_File",9));
+			    gv_stashpvn(pname, 9, TRUE);
+			    av_push(av, newSVpvn(pname = "DB_File",7));
+			    gv_stashpvn(pname, 7, TRUE);
+			    av_push(av, newSVpvn(pname = "GDBM_File",9));
+			    gv_stashpvn(pname, 9, TRUE);
+			    av_push(av, newSVpvn(pname = "SDBM_File",9));
+			    gv_stashpvn(pname, 9, TRUE);
+			    av_push(av, newSVpvn(pname = "ODBM_File",9));
+			    gv_stashpvn(pname, 9, TRUE);
+			}
+		}
+		break;
+	    case 'O':
+		if (strEQ(name2, "VERLOAD")) {
+		    HV* hv = GvHVn(gv);
+		    GvMULTI_on(gv);
+		    hv_magic(hv, Nullgv, PERL_MAGIC_overload);
+		}
+		break;
+	    case 'S':
+		if (strEQ(name2, "IG")) {
+		    HV *hv;
+		    I32 i;
+		    if (!PL_psig_ptr) {
+			Newz(73, PL_psig_ptr,  SIG_SIZE, SV*);
+			Newz(73, PL_psig_name, SIG_SIZE, SV*);
+			Newz(73, PL_psig_pend, SIG_SIZE, int);
+		    }
+		    GvMULTI_on(gv);
+		    hv = GvHVn(gv);
+		    hv_magic(hv, Nullgv, PERL_MAGIC_sig);
+		    for (i = 1; i < SIG_SIZE; i++) {
+			SV ** init;
+			init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
+			if (init)
+			    sv_setsv(*init, &PL_sv_undef);
+			PL_psig_ptr[i] = 0;
+			PL_psig_name[i] = 0;
+			PL_psig_pend[i] = 0;
+		    }
+		}
+		break;
+	    case 'V':
+		if (strEQ(name2, "ERSION"))
+		    GvMULTI_on(gv);
+		break;
+	    case '\005':	/* $^ENCODING */
+		if (strEQ(name2, "NCODING"))
+		    goto magicalize;
+		break;
+	    case '\017':	/* $^OPEN */
+		if (strEQ(name2, "PEN"))
+		    goto magicalize;
+		break;
+	    case '\024':	/* ${^TAINT} */
+		if (strEQ(name2, "AINT"))
+		    goto ro_magicalize;
+		break;
+	    case '\025':	/* $^UNICODE */
+		if (strEQ(name2, "NICODE")) 
+		    goto ro_magicalize;
+		break;
+	    case '\027':	/* $^WARNING_BITS */
+		if (strEQ(name2, "ARNING_BITS"))
+		    goto magicalize;
+		break;
+	    case '1':
+	    case '2':
+	    case '3':
+	    case '4':
+	    case '5':
+	    case '6':
+	    case '7':
+	    case '8':
+	    case '9':
 	    {
-		char *pname;
-		av_push(av, newSVpvn(pname = "NDBM_File",9));
-		gv_stashpvn(pname, 9, TRUE);
-		av_push(av, newSVpvn(pname = "DB_File",7));
-		gv_stashpvn(pname, 7, TRUE);
-		av_push(av, newSVpvn(pname = "GDBM_File",9));
-		gv_stashpvn(pname, 9, TRUE);
-		av_push(av, newSVpvn(pname = "SDBM_File",9));
-		gv_stashpvn(pname, 9, TRUE);
-		av_push(av, newSVpvn(pname = "ODBM_File",9));
-		gv_stashpvn(pname, 9, TRUE);
-	    }
-	}
-	break;
-    case 'O':
-        if (strEQ(name, "OVERLOAD")) {
-            HV* hv = GvHVn(gv);
-            GvMULTI_on(gv);
-            hv_magic(hv, Nullgv, PERL_MAGIC_overload);
-        }
-        break;
-    case 'S':
-	if (strEQ(name, "SIG")) {
-	    HV *hv;
-	    I32 i;
-	    if (!PL_psig_ptr) {
-		Newz(73, PL_psig_ptr,  SIG_SIZE, SV*);
-		Newz(73, PL_psig_name, SIG_SIZE, SV*);
-		Newz(73, PL_psig_pend, SIG_SIZE, int);
+		/* ensures variable is only digits */
+		/* ${"1foo"} fails this test (and is thus writeable) */
+		/* added by japhy, but borrowed from is_gv_magical */
+		const char *end = name + len;
+		while (--end > name) {
+		    if (!isDIGIT(*end)) return gv;
+		}
+		goto ro_magicalize;
 	    }
-	    GvMULTI_on(gv);
-	    hv = GvHVn(gv);
-	    hv_magic(hv, Nullgv, PERL_MAGIC_sig);
-	    for (i = 1; i < SIG_SIZE; i++) {
-	    	SV ** init;
-	    	init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
-	    	if (init)
-		    sv_setsv(*init, &PL_sv_undef);
-	    	PL_psig_ptr[i] = 0;
-	    	PL_psig_name[i] = 0;
-	    	PL_psig_pend[i] = 0;
 	    }
 	}
-	break;
-    case 'V':
-	if (strEQ(name, "VERSION"))
-	    GvMULTI_on(gv);
-	break;
-
-    case '&':
-    case '`':
-    case '\'':
-       if (
-           len > 1 ||
-           sv_type == SVt_PVAV ||
-           sv_type == SVt_PVHV ||
-           sv_type == SVt_PVCV ||
-           sv_type == SVt_PVFM ||
-           sv_type == SVt_PVIO
-       ) { break; }
-	PL_sawampersand = TRUE;
-	goto ro_magicalize;
-
-    case ':':
-	if (len > 1)
-	    break;
-	sv_setpv(GvSV(gv),PL_chopset);
-	goto magicalize;
-
-    case '?':
-	if (len > 1)
-	    break;
+    } else {
+	/* Names of length 1.  (Or 0. But name is NUL terminated, so that will
+	   be case '\0' in this switch statement (ie a default case)  */
+	switch (*name) {
+	case '&':
+	case '`':
+	case '\'':
+	    if (
+		sv_type == SVt_PVAV ||
+		sv_type == SVt_PVHV ||
+		sv_type == SVt_PVCV ||
+		sv_type == SVt_PVFM ||
+		sv_type == SVt_PVIO
+		) { break; }
+	    PL_sawampersand = TRUE;
+	    goto ro_magicalize;
+
+	case ':':
+	    sv_setpv(GvSV(gv),PL_chopset);
+	    goto magicalize;
+
+	case '?':
 #ifdef COMPLEX_STATUS
-	(void)SvUPGRADE(GvSV(gv), SVt_PVLV);
+	    (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
 #endif
-	goto magicalize;
+	    goto magicalize;
 
-    case '!':
-	if (len > 1)
-	    break;
+	case '!':
 
-	/* If %! has been used, automatically load Errno.pm.
-	   The require will itself set errno, so in order to
-	   preserve its value we have to set up the magic
-	   now (rather than going to magicalize)
-	*/
+	    /* If %! has been used, automatically load Errno.pm.
+	       The require will itself set errno, so in order to
+	       preserve its value we have to set up the magic
+	       now (rather than going to magicalize)
+	    */
 
-	sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
+	    sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
 
-	if (sv_type == SVt_PVHV)
-	    require_errno(gv);
+	    if (sv_type == SVt_PVHV)
+		require_errno(gv);
 
-	break;
-    case '-':
-	if (len > 1)
 	    break;
-	else {
+	case '-':
+	{
             AV* av = GvAVn(gv);
             sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
 	    SvREADONLY_on(av);
-        }
-	goto magicalize;
-    case '*':
-	if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
-	    Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-		    "$* is no longer supported");
-	break;
-    case '#':
-	if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
-	    Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-		    "Use of $# is deprecated");
-	/* FALL THROUGH */
-    case '[':
-    case '^':
-    case '~':
-    case '=':
-    case '%':
-    case '.':
-    case '(':
-    case ')':
-    case '<':
-    case '>':
-    case ',':
-    case '\\':
-    case '/':
-    case '\001':	/* $^A */
-    case '\003':	/* $^C */
-    case '\004':	/* $^D */
-    case '\006':	/* $^F */
-    case '\010':	/* $^H */
-    case '\011':	/* $^I, NOT \t in EBCDIC */
-    case '\016':        /* $^N */
-    case '\020':	/* $^P */
-	if (len > 1)
-	    break;
-	goto magicalize;
-    case '|':
-	if (len > 1)
-	    break;
-	sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
-	goto magicalize;
-    case '\005':	/* $^E && $^ENCODING */
-	if (len > 1 && strNE(name, "\005NCODING"))
-	    break;
-	goto magicalize;
-
-    case '\017':	/* $^O & $^OPEN */
-	if (len > 1 && strNE(name, "\017PEN"))
-	    break;
-	goto magicalize;
-    case '\023':	/* $^S */
-	if (len > 1)
-	    break;
-	goto ro_magicalize;
-    case '\024':	/* $^T, ${^TAINT} */
-        if (len == 1)
-            goto magicalize;
-        else if (strEQ(name, "\024AINT"))
-            goto ro_magicalize;
-        else
-            break;
-    case '\025':
-        if (len > 1 && strNE(name, "\025NICODE")) 
-	    break;
-	goto ro_magicalize;
-
-    case '\027':	/* $^W & $^WARNING_BITS */
-	if (len > 1
-	    && strNE(name, "\027ARNING_BITS")
-	    )
-	    break;
-	goto magicalize;
-
-    case '+':
-	if (len > 1)
+	    goto magicalize;
+	}
+	case '*':
+	    if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
+		Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+			    "$* is no longer supported");
 	    break;
-	else {
-            AV* av = GvAVn(gv);
+	case '#':
+	    if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
+		Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+			    "Use of $# is deprecated");
+	    goto magicalize;
+	case '|':
+	    sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
+	    goto magicalize;
+
+	case '+':
+	{
+	    AV* av = GvAVn(gv);
             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
 	    SvREADONLY_on(av);
-        }
-	/* FALL THROUGH */
-    case '1':
-    case '2':
-    case '3':
-    case '4':
-    case '5':
-    case '6':
-    case '7':
-    case '8':
-    case '9':
-	/* ensures variable is only digits */
-	/* ${"1foo"} fails this test (and is thus writeable) */
-	/* added by japhy, but borrowed from is_gv_magical */
-
-	if (len > 1) {
-	    const char *end = name + len;
-	    while (--end > name) {
-		if (!isDIGIT(*end)) return gv;
-	    }
+	    /* FALL THROUGH */
 	}
+	case '\023':	/* $^S */
+	case '1':
+	case '2':
+	case '3':
+	case '4':
+	case '5':
+	case '6':
+	case '7':
+	case '8':
+	case '9':
+	ro_magicalize:
+	    SvREADONLY_on(GvSV(gv));
+	    /* FALL THROUGH */
+	case '[':
+	case '^':
+	case '~':
+	case '=':
+	case '%':
+	case '.':
+	case '(':
+	case ')':
+	case '<':
+	case '>':
+	case ',':
+	case '\\':
+	case '/':
+	case '\001':	/* $^A */
+	case '\003':	/* $^C */
+	case '\004':	/* $^D */
+	case '\005':	/* $^E */
+	case '\006':	/* $^F */
+	case '\010':	/* $^H */
+	case '\011':	/* $^I, NOT \t in EBCDIC */
+	case '\016':	/* $^N */
+	case '\017':	/* $^O */
+	case '\020':	/* $^P */
+	case '\024':	/* $^T */
+	case '\027':	/* $^W */
+	magicalize:
+	    sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
+	    break;
 
-      ro_magicalize:
-	SvREADONLY_on(GvSV(gv));
-      magicalize:
-	sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
-	break;
-
-    case '\014':	/* $^L */
-	if (len > 1)
+	case '\014':	/* $^L */
+	    sv_setpv(GvSV(gv),"\f");
+	    PL_formfeed = GvSV(gv);
 	    break;
-	sv_setpv(GvSV(gv),"\f");
-	PL_formfeed = GvSV(gv);
-	break;
-    case ';':
-	if (len > 1)
+	case ';':
+	    sv_setpv(GvSV(gv),"\034");
 	    break;
-	sv_setpv(GvSV(gv),"\034");
-	break;
-    case ']':
-	if (len == 1) {
+	case ']':
+	{
 	    SV *sv = GvSV(gv);
 	    if (!sv_derived_from(PL_patchlevel, "version"))
 		(void *)upg_version(PL_patchlevel);
@@ -1065,14 +1080,15 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 	    SvREFCNT_dec(sv);
 	}
 	break;
-    case '\026':	/* $^V */
-	if (len == 1) {
+	case '\026':	/* $^V */
+	{
 	    SV *sv = GvSV(gv);
 	    GvSV(gv) = new_version(PL_patchlevel);
 	    SvREADONLY_on(GvSV(gv));
 	    SvREFCNT_dec(sv);
 	}
 	break;
+	}
     }
     return gv;
 }
@@ -1093,7 +1109,8 @@ Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
 	name = "__ANON__";
 	
     if (keepmain || strNE(name, "main")) {
-	Perl_sv_catpvf(aTHX_ sv,"%s::", name);
+	sv_catpv(sv,name);
+	sv_catpvn(sv,"::", 2);
     }
     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 }