Simplify yytoke()

Message-ID: <20010708132434.A9448@deep-dark-truthful-mirror>

Split out pending_ident().

p4raw-id: //depot/perl@11213

diff --git a/embed.h b/embed.h
index 21bde98..ba67052 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1125,6 +1125,7 @@
 #define force_version          S_force_version
 #define force_word             S_force_word
 #define tokeq                  S_tokeq
+#define pending_ident          S_pending_ident
 #define scan_const             S_scan_const
 #define scan_formline          S_scan_formline
 #define scan_heredoc           S_scan_heredoc
@@ -1212,6 +1213,7 @@
 #define ck_match               Perl_ck_match
 #define ck_method              Perl_ck_method
 #define ck_null                        Perl_ck_null
+#define ck_octmode             Perl_ck_octmode
 #define ck_open                        Perl_ck_open
 #define ck_repeat              Perl_ck_repeat
 #define ck_require             Perl_ck_require
@@ -2624,6 +2626,7 @@
 #define force_version(a)       S_force_version(aTHX_ a)
 #define force_word(a,b,c,d,e)  S_force_word(aTHX_ a,b,c,d,e)
 #define tokeq(a)               S_tokeq(aTHX_ a)
+#define pending_ident()                S_pending_ident(aTHX)
 #define scan_const(a)          S_scan_const(aTHX_ a)
 #define scan_formline(a)       S_scan_formline(aTHX_ a)
 #define scan_heredoc(a)                S_scan_heredoc(aTHX_ a)
@@ -2711,6 +2714,7 @@
 #define ck_match(a)            Perl_ck_match(aTHX_ a)
 #define ck_method(a)           Perl_ck_method(aTHX_ a)
 #define ck_null(a)             Perl_ck_null(aTHX_ a)
+#define ck_octmode(a)          Perl_ck_octmode(aTHX_ a)
 #define ck_open(a)             Perl_ck_open(aTHX_ a)
 #define ck_repeat(a)           Perl_ck_repeat(aTHX_ a)
 #define ck_require(a)          Perl_ck_require(aTHX_ a)
@@ -5109,6 +5113,8 @@
 #define force_word             S_force_word
 #define S_tokeq                        CPerlObj::S_tokeq
 #define tokeq                  S_tokeq
+#define S_pending_ident                CPerlObj::S_pending_ident
+#define pending_ident          S_pending_ident
 #define S_scan_const           CPerlObj::S_scan_const
 #define scan_const             S_scan_const
 #define S_scan_formline                CPerlObj::S_scan_formline
@@ -5264,6 +5270,8 @@
 #define ck_method              Perl_ck_method
 #define Perl_ck_null           CPerlObj::Perl_ck_null
 #define ck_null                        Perl_ck_null
+#define Perl_ck_octmode                CPerlObj::Perl_ck_octmode
+#define ck_octmode             Perl_ck_octmode
 #define Perl_ck_open           CPerlObj::Perl_ck_open
 #define ck_open                        Perl_ck_open
 #define Perl_ck_repeat         CPerlObj::Perl_ck_repeat

diff --git a/embed.pl b/embed.pl
index e322ae2..c2f5351 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2534,6 +2534,7 @@ s |char*  |force_version  |char *start
 s      |char*  |force_word     |char *start|int token|int check_keyword \
                                |int allow_pack|int allow_tick
 s      |SV*    |tokeq          |SV *sv
+s      |int    |pending_ident
 s      |char*  |scan_const     |char *start
 s      |char*  |scan_formline  |char *s
 s      |char*  |scan_heredoc   |char *s

diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index bd794e2..bee65f6 100644 (file)
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -1344,17 +1344,6 @@ SV is B<not> incremented.
 =for hackers
 Found in file sv.c
 
-=item newSV
-
-Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
-with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
-macro.
-
-       SV*     newSV(STRLEN len)
-
-=for hackers
-Found in file sv.c
-
 =item NEWSV
 
 Creates a new SV.  A non-zero C<len> parameter indicates the number of
@@ -1368,6 +1357,17 @@ C<id> is an integer id between 0 and 1299 (used to identify leaks).
 =for hackers
 Found in file handy.h
 
+=item newSV
+
+Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
+with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
+macro.
+
+       SV*     newSV(STRLEN len)
+
+=for hackers
+Found in file sv.c
+
 =item newSViv
 
 Creates a new SV and copies an integer into it.  The reference count for the
@@ -2234,22 +2234,22 @@ which guarantees to evaluate sv only once.
 =for hackers
 Found in file sv.h
 
-=item SvNVX
+=item SvNVx
 
-Returns the raw value in the SV's NV slot, without checks or conversions.
-Only use when you are sure SvNOK is true. See also C<SvNV()>.
+Coerces the given SV to a double and returns it. Guarantees to evaluate
+sv only once. Use the more efficent C<SvNV> otherwise.
 
-       NV      SvNVX(SV* sv)
+       NV      SvNVx(SV* sv)
 
 =for hackers
 Found in file sv.h
 
-=item SvNVx
+=item SvNVX
 
-Coerces the given SV to a double and returns it. Guarantees to evaluate
-sv only once. Use the more efficent C<SvNV> otherwise.
+Returns the raw value in the SV's NV slot, without checks or conversions.
+Only use when you are sure SvNOK is true. See also C<SvNV()>.
 
-       NV      SvNVx(SV* sv)
+       NV      SvNVX(SV* sv)
 
 =for hackers
 Found in file sv.h

diff --git a/proto.h b/proto.h
index 50d552a..5110345 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1258,6 +1258,7 @@ STATIC void       S_force_next(pTHX_ I32 type);
 STATIC char*   S_force_version(pTHX_ char *start);
 STATIC char*   S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack, int allow_tick);
 STATIC SV*     S_tokeq(pTHX_ SV *sv);
+STATIC int     S_pending_ident(pTHX);
 STATIC char*   S_scan_const(pTHX_ char *start);
 STATIC char*   S_scan_formline(pTHX_ char *s);
 STATIC char*   S_scan_heredoc(pTHX_ char *s);

diff --git a/toke.c b/toke.c
index fa2b2bd..26b99d3 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -2166,132 +2166,8 @@ Perl_yylex(pTHX)
     bool bof = FALSE;
 
     /* check if there's an identifier for us to look at */
-    if (PL_pending_ident) {
-        /* pit holds the identifier we read and pending_ident is reset */
-       char pit = PL_pending_ident;
-       PL_pending_ident = 0;
-
-       DEBUG_T({ PerlIO_printf(Perl_debug_log,
-              "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
-
-       /* if we're in a my(), we can't allow dynamics here.
-          $foo'bar has already been turned into $foo::bar, so
-          just check for colons.
-
-          if it's a legal name, the OP is a PADANY.
-       */
-       if (PL_in_my) {
-           if (PL_in_my == KEY_our) {  /* "our" is merely analogous to "my" */
-               if (strchr(PL_tokenbuf,':'))
-                   yyerror(Perl_form(aTHX_ "No package name allowed for "
-                                     "variable %s in \"our\"",
-                                     PL_tokenbuf));
-               tmp = pad_allocmy(PL_tokenbuf);
-           }
-           else {
-               if (strchr(PL_tokenbuf,':'))
-                   yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
-
-               yylval.opval = newOP(OP_PADANY, 0);
-               yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
-               return PRIVATEREF;
-           }
-       }
-
-       /*
-          build the ops for accesses to a my() variable.
-
-          Deny my($a) or my($b) in a sort block, *if* $a or $b is
-          then used in a comparison.  This catches most, but not
-          all cases.  For instance, it catches
-              sort { my($a); $a <=> $b }
-          but not
-              sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
-          (although why you'd do that is anyone's guess).
-       */
-
-       if (!strchr(PL_tokenbuf,':')) {
-#ifdef USE_THREADS
-           /* Check for single character per-thread SVs */
-           if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
-               && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
-               && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
-           {
-               yylval.opval = newOP(OP_THREADSV, 0);
-               yylval.opval->op_targ = tmp;
-               return PRIVATEREF;
-           }
-#endif /* USE_THREADS */
-           if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
-               SV *namesv = AvARRAY(PL_comppad_name)[tmp];
-               /* might be an "our" variable" */
-               if (SvFLAGS(namesv) & SVpad_OUR) {
-                   /* build ops for a bareword */
-                   SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
-                   sv_catpvn(sym, "::", 2);
-                   sv_catpv(sym, PL_tokenbuf+1);
-                   yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
-                   yylval.opval->op_private = OPpCONST_ENTERED;
-                   gv_fetchpv(SvPVX(sym),
-                       (PL_in_eval
-                           ? (GV_ADDMULTI | GV_ADDINEVAL)
-                           : TRUE
-                       ),
-                       ((PL_tokenbuf[0] == '$') ? SVt_PV
-                        : (PL_tokenbuf[0] == '@') ? SVt_PVAV
-                        : SVt_PVHV));
-                   return WORD;
-               }
-
-               /* if it's a sort block and they're naming $a or $b */
-               if (PL_last_lop_op == OP_SORT &&
-                   PL_tokenbuf[0] == '$' &&
-                   (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
-                   && !PL_tokenbuf[2])
-               {
-                   for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
-                        d < PL_bufend && *d != '\n';
-                        d++)
-                   {
-                       if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
-                           Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
-                                 PL_tokenbuf);
-                       }
-                   }
-               }
-
-               yylval.opval = newOP(OP_PADANY, 0);
-               yylval.opval->op_targ = tmp;
-               return PRIVATEREF;
-           }
-       }
-
-       /*
-          Whine if they've said @foo in a doublequoted string,
-          and @foo isn't a variable we can find in the symbol
-          table.
-       */
-       if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
-           GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
-           if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
-                && ckWARN(WARN_AMBIGUOUS))
-           {
-                /* Downgraded from fatal to warning 20000522 mjd */
-               Perl_warner(aTHX_ WARN_AMBIGUOUS,
-                           "Possible unintended interpolation of %s in string",
-                            PL_tokenbuf);
-           }
-       }
-
-       /* build ops for a bareword */
-       yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
-       yylval.opval->op_private = OPpCONST_ENTERED;
-       gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
-                  ((PL_tokenbuf[0] == '$') ? SVt_PV
-                   : (PL_tokenbuf[0] == '@') ? SVt_PVAV
-                   : SVt_PVHV));
-       return WORD;
-    }
+    if (PL_pending_ident) 
+        return pending_ident(aTHX);
 
     /* no identifier pending identification */
 
@@ -5236,6 +5112,136 @@ Perl_yylex(pTHX)
 #pragma segment Main
 #endif
 
+int S_pending_ident(pTHX)
+{
+    register char *d;
+    register I32 tmp;
+    /* pit holds the identifier we read and pending_ident is reset */
+    char pit = PL_pending_ident;
+    PL_pending_ident = 0;
+
+    DEBUG_T({ PerlIO_printf(Perl_debug_log,
+          "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
+
+    /* if we're in a my(), we can't allow dynamics here.
+       $foo'bar has already been turned into $foo::bar, so
+       just check for colons.
+
+       if it's a legal name, the OP is a PADANY.
+    */
+    if (PL_in_my) {
+        if (PL_in_my == KEY_our) {     /* "our" is merely analogous to "my" */
+            if (strchr(PL_tokenbuf,':'))
+                yyerror(Perl_form(aTHX_ "No package name allowed for "
+                                  "variable %s in \"our\"",
+                                  PL_tokenbuf));
+            tmp = pad_allocmy(PL_tokenbuf);
+        }
+        else {
+            if (strchr(PL_tokenbuf,':'))
+                yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
+
+            yylval.opval = newOP(OP_PADANY, 0);
+            yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
+            return PRIVATEREF;
+        }
+    }
+
+    /*
+       build the ops for accesses to a my() variable.
+
+       Deny my($a) or my($b) in a sort block, *if* $a or $b is
+       then used in a comparison.  This catches most, but not
+       all cases.  For instance, it catches
+           sort { my($a); $a <=> $b }
+       but not
+           sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
+       (although why you'd do that is anyone's guess).
+    */
+
+    if (!strchr(PL_tokenbuf,':')) {
+#ifdef USE_THREADS
+        /* Check for single character per-thread SVs */
+        if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
+            && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
+            && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
+        {
+            yylval.opval = newOP(OP_THREADSV, 0);
+            yylval.opval->op_targ = tmp;
+            return PRIVATEREF;
+        }
+#endif /* USE_THREADS */
+        if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
+            SV *namesv = AvARRAY(PL_comppad_name)[tmp];
+            /* might be an "our" variable" */
+            if (SvFLAGS(namesv) & SVpad_OUR) {
+                /* build ops for a bareword */
+                SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
+                sv_catpvn(sym, "::", 2);
+                sv_catpv(sym, PL_tokenbuf+1);
+                yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
+                yylval.opval->op_private = OPpCONST_ENTERED;
+                gv_fetchpv(SvPVX(sym),
+                    (PL_in_eval
+                        ? (GV_ADDMULTI | GV_ADDINEVAL)
+                        : TRUE
+                    ),
+                    ((PL_tokenbuf[0] == '$') ? SVt_PV
+                     : (PL_tokenbuf[0] == '@') ? SVt_PVAV
+                     : SVt_PVHV));
+                return WORD;
+            }
+
+            /* if it's a sort block and they're naming $a or $b */
+            if (PL_last_lop_op == OP_SORT &&
+                PL_tokenbuf[0] == '$' &&
+                (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
+                && !PL_tokenbuf[2])
+            {
+                for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
+                     d < PL_bufend && *d != '\n';
+                     d++)
+                {
+                    if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
+                        Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
+                              PL_tokenbuf);
+                    }
+                }
+            }
+
+            yylval.opval = newOP(OP_PADANY, 0);
+            yylval.opval->op_targ = tmp;
+            return PRIVATEREF;
+        }
+    }
+
+    /*
+       Whine if they've said @foo in a doublequoted string,
+       and @foo isn't a variable we can find in the symbol
+       table.
+    */
+    if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
+        GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
+        if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
+             && ckWARN(WARN_AMBIGUOUS))
+        {
+            /* Downgraded from fatal to warning 20000522 mjd */
+            Perl_warner(aTHX_ WARN_AMBIGUOUS,
+                        "Possible unintended interpolation of %s in string",
+                         PL_tokenbuf);
+        }
+    }
+
+    /* build ops for a bareword */
+    yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
+    yylval.opval->op_private = OPpCONST_ENTERED;
+    gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
+               ((PL_tokenbuf[0] == '$') ? SVt_PV
+                : (PL_tokenbuf[0] == '@') ? SVt_PVAV
+                : SVt_PVHV));
+    return WORD;
+}
+
 I32
 Perl_keyword(pTHX_ register char *d, I32 len)
 {