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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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;
         }
     }