From: Nicholas Clark <nick@ccl4.org>
Date: Sun, 8 Nov 2009 10:18:02 +0000 (+0000)
Subject: Add length and flags arguments to Perl_allocmy().
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d6447115bb9638af823243dbe17f2c14e71cf57d;p=p5sagit%2Fp5-mst-13.2.git

Add length and flags arguments to Perl_allocmy().

Currently no flags bits are used, and the length is cross-checked against
strlen() on the pointer, but the intent is to re-work the entire pad API to
be UTF-8 aware, from the current situation of char * pointers only.
---

diff --git a/embed.fnc b/embed.fnc
index 755c42d..440ada4 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -744,7 +744,8 @@ p	|void	|package_version|NN OP* v
 : Used in op.c
 pd	|PADOFFSET|pad_alloc	|I32 optype|U32 tmptype
 : Used in toke.c and perly.y
-p	|PADOFFSET|allocmy	|NN const char *const name
+p	|PADOFFSET|allocmy	|NN const char *const name|const STRLEN len\
+				|const U32 flags
 : Used in op.c and toke.c
 AMpdR	|PADOFFSET|pad_findmy	|NN const char* name|STRLEN len|U32 flags
 Ap	|PADOFFSET|find_rundefsvoffset	|
diff --git a/embed.h b/embed.h
index e80384a..9938096 100644
--- a/embed.h
+++ b/embed.h
@@ -3007,7 +3007,7 @@
 #ifdef PERL_CORE
 #define package_version(a)	Perl_package_version(aTHX_ a)
 #define pad_alloc(a,b)		Perl_pad_alloc(aTHX_ a,b)
-#define allocmy(a)		Perl_allocmy(aTHX_ a)
+#define allocmy(a,b,c)		Perl_allocmy(aTHX_ a,b,c)
 #endif
 #define pad_findmy(a,b,c)	Perl_pad_findmy(aTHX_ a,b,c)
 #define find_rundefsvoffset()	Perl_find_rundefsvoffset(aTHX)
diff --git a/op.c b/op.c
index 6add236..b42bb54 100644
--- a/op.c
+++ b/op.c
@@ -372,7 +372,7 @@ S_no_bareword_allowed(pTHX_ const OP *o)
 /* "register" allocation */
 
 PADOFFSET
-Perl_allocmy(pTHX_ const char *const name)
+Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 {
     dVAR;
     PADOFFSET off;
@@ -380,20 +380,28 @@ Perl_allocmy(pTHX_ const char *const name)
 
     PERL_ARGS_ASSERT_ALLOCMY;
 
+    if (flags)
+	Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
+		   (UV)flags);
+
+    /* Until we're using the length for real, cross check that we're being
+       told the truth.  */
+    assert(strlen(name) == len);
+
     /* complain about "my $<special_var>" etc etc */
-    if (*name &&
+    if (len &&
 	!(is_our ||
 	  isALPHA(name[1]) ||
 	  (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
-	  (name[1] == '_' && (*name == '$' || name[2]))))
+	  (name[1] == '_' && (*name == '$' || len > 2))))
     {
 	/* name[2] is true if strlen(name) > 2  */
 	if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
-	    yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
-			      name[0], toCTRL(name[1]), name + 2,
+	    yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
+			      name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 			      PL_parser->in_my == KEY_state ? "state" : "my"));
 	} else {
-	    yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
+	    yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 			      PL_parser->in_my == KEY_state ? "state" : "my"));
 	}
     }
diff --git a/perly.act b/perly.act
index d37a45d..6d6801b 100644
--- a/perly.act
+++ b/perly.act
@@ -20,7 +20,7 @@ case 2:
 
   case 5:
 #line 161 "perly.y"
-    { (yyval.ival) = (I32) allocmy("$_"); ;}
+    { (yyval.ival) = (I32) Perl_allocmy(aTHX_ STR_WITH_LEN("$_"), 0); ;}
     break;
 
   case 6:
diff --git a/perly.y b/perly.y
index 544c2e9..4e9908e 100644
--- a/perly.y
+++ b/perly.y
@@ -158,7 +158,7 @@ remember:	/* NULL */	/* start a full lexical scope */
 	;
 
 mydefsv:	/* NULL */	/* lexicalize $_ */
-			{ $$ = (I32) allocmy("$_"); }
+			{ $$ = (I32) Perl_allocmy(aTHX_ STR_WITH_LEN("$_"), 0); }
 	;
 
 progstart:
diff --git a/proto.h b/proto.h
index 2a3b118..20f8551 100644
--- a/proto.h
+++ b/proto.h
@@ -2357,7 +2357,7 @@ PERL_CALLCONV void	Perl_package_version(pTHX_ OP* v)
 	assert(v)
 
 PERL_CALLCONV PADOFFSET	Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype);
-PERL_CALLCONV PADOFFSET	Perl_allocmy(pTHX_ const char *const name)
+PERL_CALLCONV PADOFFSET	Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_ALLOCMY	\
 	assert(name)
diff --git a/toke.c b/toke.c
index 680d8a2..b8abbd8 100644
--- a/toke.c
+++ b/toke.c
@@ -7094,7 +7094,7 @@ S_pending_ident(pTHX)
                 yyerror(Perl_form(aTHX_ "No package name allowed for "
                                   "variable %s in \"our\"",
                                   PL_tokenbuf));
-            tmp = allocmy(PL_tokenbuf);
+            tmp = allocmy(PL_tokenbuf, tokenbuf_len, 0);
         }
         else {
             if (has_colon)
@@ -7102,7 +7102,7 @@ S_pending_ident(pTHX)
 			    PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
 
             pl_yylval.opval = newOP(OP_PADANY, 0);
-            pl_yylval.opval->op_targ = allocmy(PL_tokenbuf);
+            pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len, 0);
             return PRIVATEREF;
         }
     }