=head1 Lexer interface
This is the lower layer of the Perl parser, managing characters and tokens.
-=for apidoc AmU|yy_parser *|PL_parser
+=for apidoc AmnU|yy_parser *|PL_parser
Pointer to a structure encapsulating the state of the parsing operation
currently in progress. The pointer can be locally changed to perform
#include "EXTERN.h"
#define PERL_IN_TOKE_C
#include "perl.h"
-#include "dquote_inline.h"
#include "invlist_inline.h"
#define new_constant(a,b,c,d,e,f,g, h) \
&& ((XPVIV*)SvANY(sv))->xiv_u.xivu_eval_seen)
static const char* const ident_too_long = "Identifier too long";
+static const char* const ident_var_zero_multi_digit = "Numeric variables with more than one digit may not start with '0'";
# define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
/* In variables named $^X, these are the legal values for X.
* 1999-02-27 mjd-perl-patch@plover.com */
-#define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
+#define isCONTROLVAR(x) (isUPPER(x) || memCHRs("[\\]^_?", (x)))
#define SPACE_OR_TAB(c) isBLANK_A(c)
#define LEX_INTERPCONST 2 /* NOT USED */
#define LEX_FORMLINE 1 /* expecting a format line */
+/* returned to yyl_try() to request it to retry the parse loop, expected to only
+ be returned directly by yyl_fake_eof(), but functions that call yyl_fake_eof()
+ can also return it.
+
+ yylex (aka Perl_yylex) returns 0 on EOF rather than returning -1,
+ other token values are 258 or higher (see perly.h), so -1 should be
+ a safe value here.
+*/
+#define YYL_RETRY (-1)
#ifdef DEBUGGING
static const char* const lex_state_names[] = {
* Aop : addition-level operator
* AopNOASSIGN : addition-level operator that is never part of .=
* Mop : multiplication-level operator
- * Eop : equality-testing operator
- * Rop : relational operator <= != gt
+ * ChEop : chaining equality-testing operator
+ * NCEop : non-chaining comparison operator at equality precedence
+ * ChRop : chaining relational operator <= != gt
+ * NCRop : non-chaining relational operator isa
*
* Also see LOP and lop() below.
*/
#define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
#define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
#define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
-#define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
-#define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
+#define ChEop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)CHEQOP))
+#define NCEop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)NCEQOP))
+#define ChRop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)CHRELOP))
+#define NCRop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)NCRELOP))
/* This bit of chicanery makes a unary function followed by
* a parenthesis into a function with one argument, highest precedence.
} STMT_END
+/* A file-local structure for passing around information about subroutines and
+ * related definable words */
+struct code {
+ SV *sv;
+ CV *cv;
+ GV *gv, **gvp;
+ OP *rv2cv_op;
+ PADOFFSET off;
+ bool lex;
+};
+
+static const struct code no_code = { NULL, NULL, NULL, NULL, NULL, 0, FALSE };
+
#ifdef DEBUGGING
/* how to interpret the pl_yylval associated with the token */
{ ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
{ BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
{ BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
+ { CHEQOP, TOKENTYPE_OPNUM, "CHEQOP" },
+ { CHRELOP, TOKENTYPE_OPNUM, "CHRELOP" },
{ COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
{ CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
{ DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
{ DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
{ ELSE, TOKENTYPE_NONE, "ELSE" },
{ ELSIF, TOKENTYPE_IVAL, "ELSIF" },
- { EQOP, TOKENTYPE_OPNUM, "EQOP" },
{ FOR, TOKENTYPE_IVAL, "FOR" },
{ FORMAT, TOKENTYPE_NONE, "FORMAT" },
{ FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
{ GIVEN, TOKENTYPE_IVAL, "GIVEN" },
{ HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
{ IF, TOKENTYPE_IVAL, "IF" },
- { LABEL, TOKENTYPE_PVAL, "LABEL" },
+ { LABEL, TOKENTYPE_OPVAL, "LABEL" },
{ LOCAL, TOKENTYPE_IVAL, "LOCAL" },
{ LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
{ LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
{ METHOD, TOKENTYPE_OPVAL, "METHOD" },
{ MULOP, TOKENTYPE_OPNUM, "MULOP" },
{ MY, TOKENTYPE_IVAL, "MY" },
+ { NCEQOP, TOKENTYPE_OPNUM, "NCEQOP" },
+ { NCRELOP, TOKENTYPE_OPNUM, "NCRELOP" },
{ NOAMP, TOKENTYPE_NONE, "NOAMP" },
{ NOTOP, TOKENTYPE_NONE, "NOTOP" },
{ OROP, TOKENTYPE_IVAL, "OROP" },
{ PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
{ QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
{ REFGEN, TOKENTYPE_NONE, "REFGEN" },
- { RELOP, TOKENTYPE_OPNUM, "RELOP" },
{ REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
{ SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
{ SIGSUB, TOKENTYPE_NONE, "SIGSUB" },
{ SUB, TOKENTYPE_NONE, "SUB" },
+ { SUBLEXEND, TOKENTYPE_NONE, "SUBLEXEND" },
+ { SUBLEXSTART, TOKENTYPE_NONE, "SUBLEXSTART" },
{ THING, TOKENTYPE_OPVAL, "THING" },
{ UMINUS, TOKENTYPE_NONE, "UMINUS" },
{ UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
#include "feature.h"
/*
- * Check whether the named feature is enabled.
- */
-bool
-Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
-{
- char he_name[8 + MAX_FEATURE_LEN] = "feature_";
-
- PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
-
- assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
-
- if (namelen > MAX_FEATURE_LEN)
- return FALSE;
- memcpy(&he_name[8], name, namelen);
-
- return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
- REFCOUNTED_HE_EXISTS));
-}
-
-/*
* experimental text filters for win32 carriage-returns, utf16-to-utf8 and
* utf16-to-utf8-reversed.
*/
#endif
/*
-=for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
+=for apidoc lex_start
Creates and initialises a new lexer/parser state object, supplying
a context in which to lex and parse from a new source of Perl code.
parser->lex_state = LEX_NORMAL;
parser->expect = XSTATE;
parser->rsfp = rsfp;
- parser->recheck_utf8_validity = FALSE;
+ parser->recheck_utf8_validity = TRUE;
parser->rsfp_filters =
!(flags & LEX_START_SAME_FILTER) || !oparser
? NULL
/*
-=for apidoc AmxU|SV *|PL_parser-E<gt>linestr
+=for apidoc AmnxUN|SV *|PL_parser-E<gt>linestr
Buffer scalar containing the chunk currently under consideration of the
text currently being lexed. This is always a plain string scalar (for
of these pointers is usually preferable to examination of the scalar
through normal scalar means.
-=for apidoc AmxU|char *|PL_parser-E<gt>bufend
+=for apidoc AmnxUN|char *|PL_parser-E<gt>bufend
Direct pointer to the end of the chunk of text currently being lexed, the
end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
always located at the end of the buffer, and does not count as part of
the buffer's contents.
-=for apidoc AmxU|char *|PL_parser-E<gt>bufptr
+=for apidoc AmnxUN|char *|PL_parser-E<gt>bufptr
Points to the current position of lexing inside the lexer buffer.
Characters around this point may be freely examined, within
using the slightly higher-level functions L</lex_peek_unichar> and
L</lex_read_unichar>.
-=for apidoc AmxU|char *|PL_parser-E<gt>linestart
+=for apidoc AmnxUN|char *|PL_parser-E<gt>linestart
Points to the start of the current line inside the lexer buffer.
This is useful for indicating at which column an error occurred, and
*/
/*
-=for apidoc Amx|bool|lex_bufutf8
+=for apidoc lex_bufutf8
Indicates whether the octets in the lexer buffer
(L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
}
/*
-=for apidoc Amx|char *|lex_grow_linestr|STRLEN len
+=for apidoc lex_grow_linestr
Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
at least C<len> octets (including terminating C<NUL>). Returns a
}
/*
-=for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
+=for apidoc lex_stuff_pvn
Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
function is more convenient.
+=for apidoc Amnh||LEX_STUFF_UTF8
+
=cut
*/
void
Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
{
- dVAR;
char *bufptr;
PERL_ARGS_ASSERT_LEX_STUFF_PVN;
if (flags & ~(LEX_STUFF_UTF8))
}
/*
-=for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
+=for apidoc lex_stuff_pv
Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
}
/*
-=for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
+=for apidoc lex_stuff_sv
Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
}
/*
-=for apidoc Amx|void|lex_unstuff|char *ptr
+=for apidoc lex_unstuff
Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
C<ptr>. Text following C<ptr> will be moved, and the buffer shortened.
}
/*
-=for apidoc Amx|void|lex_read_to|char *ptr
+=for apidoc lex_read_to
Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
to C<ptr>. This advances L</PL_parser-E<gt>bufptr> to match C<ptr>,
}
/*
-=for apidoc Amx|void|lex_discard_to|char *ptr
+=for apidoc lex_discard_to
Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
up to C<ptr>. The remaining content of the buffer will be moved, and
}
/*
-=for apidoc Amx|bool|lex_next_chunk|U32 flags
+=for apidoc lex_next_chunk
Reads in the next chunk of text to be lexed, appending it to
L</PL_parser-E<gt>linestr>. This should be called when lexing code has
Returns true if some new text was added to the buffer, or false if the
buffer has reached the end of the input text.
+=for apidoc Amnh||LEX_KEEP_PREVIOUS
+
=cut
*/
PL_parser->last_lop = NULL;
last_uni_pos = last_lop_pos = 0;
*buf = 0;
- SvCUR(linestr) = 0;
+ SvCUR_set(linestr, 0);
} else {
old_bufend_pos = PL_parser->bufend - buf;
bufptr_pos = PL_parser->bufptr - buf;
}
/*
-=for apidoc Amx|I32|lex_peek_unichar|U32 flags
+=for apidoc lex_peek_unichar
Looks ahead one (Unicode) character in the text currently being lexed.
Returns the codepoint (unsigned integer value) of the next character,
I32
Perl_lex_peek_unichar(pTHX_ U32 flags)
{
- dVAR;
char *s, *bufend;
if (flags & ~(LEX_KEEP_PREVIOUS))
Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
}
/*
-=for apidoc Amx|I32|lex_read_unichar|U32 flags
+=for apidoc lex_read_unichar
Reads the next (Unicode) character in the text currently being lexed.
Returns the codepoint (unsigned integer value) of the character read,
}
/*
-=for apidoc Amx|void|lex_read_space|U32 flags
+=for apidoc lex_read_space
Reads optional spaces, in Perl style, in the text currently being
lexed. The spaces may include ordinary whitespace characters and
/*
-=for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
+=for apidoc validate_proto
This function performs syntax checking on a prototype, C<proto>.
If C<warn> is true, any illegal characters or mismatched brackets
if (must_be_last)
proto_after_greedy_proto = TRUE;
if (underscore) {
- if (!strchr(";@%", *p))
+ if (!memCHRs(";@%", *p))
bad_proto_after_underscore = TRUE;
underscore = FALSE;
}
- if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
+ if (!memCHRs("$@%*;[]&\\_+", *p) || *p == '\0') {
bad_proto = TRUE;
}
else {
#define skipspace(s) skipspace_flags(s, 0)
#define peekspace(s) skipspace_flags(s, LEX_NO_INCLINE)
-STATIC char *
-S_skipspace_flags(pTHX_ char *s, U32 flags)
+char *
+Perl_skipspace_flags(pTHX_ char *s, U32 flags)
{
PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
static int
S_postderef(pTHX_ int const funny, char const next)
{
- assert(funny == DOLSHARP || strchr("$@%&*", funny));
+ assert(funny == DOLSHARP || memCHRs("$@%&*", funny));
if (next == '*') {
PL_expect = XOPERATOR;
if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
PL_in_eval &= ~EVAL_RE_REPARSING;
- return '(';
+ return SUBLEXSTART;
}
/*
PL_bufend = SvPVX(PL_linestr);
PL_bufend += SvCUR(PL_linestr);
PL_expect = XOPERATOR;
- return ')';
+ return SUBLEXEND;
+ }
+}
+
+HV *
+Perl_load_charnames(pTHX_ SV * char_name, const char * context,
+ const STRLEN context_len, const char ** error_msg)
+{
+ /* Load the official _charnames module if not already there. The
+ * parameters are just to give info for any error messages generated:
+ * char_name a name to look up which is the reason for loading this
+ * context 'char_name' in the context in the input in which it appears
+ * context_len how many bytes 'context' occupies
+ * error_msg *error_msg will be set to any error
+ *
+ * Returns the ^H table if success; otherwise NULL */
+
+ unsigned int i;
+ HV * table;
+ SV **cvp;
+ SV * res;
+
+ PERL_ARGS_ASSERT_LOAD_CHARNAMES;
+
+ /* This loop is executed 1 1/2 times. On the first time through, if it
+ * isn't already loaded, try loading it, and iterate just once to see if it
+ * worked. */
+ for (i = 0; i < 2; i++) {
+ table = GvHV(PL_hintgv); /* ^H */
+
+ if ( table
+ && (PL_hints & HINT_LOCALIZE_HH)
+ && (cvp = hv_fetchs(table, "charnames", FALSE))
+ && SvOK(*cvp))
+ {
+ return table; /* Quit if already loaded */
+ }
+
+ if (i == 0) {
+ Perl_load_module(aTHX_
+ 0,
+ newSVpvs("_charnames"),
+
+ /* version parameter; no need to specify it, as if we get too early
+ * a version, will fail anyway, not being able to find 'charnames'
+ * */
+ NULL,
+ newSVpvs(":full"),
+ newSVpvs(":short"),
+ NULL);
+ }
}
+
+ /* Here, it failed; new_constant will give appropriate error messages */
+ *error_msg = NULL;
+ res = new_constant( NULL, 0, "charnames", char_name, NULL,
+ context, context_len, error_msg);
+ SvREFCNT_dec(res);
+
+ return NULL;
}
STATIC SV*
* 'is_utf8' is TRUE if we know we want the result to be UTF-8 even if it
* doesn't have to be. */
+ SV* char_name;
SV* res;
HV * table;
SV **cvp;
SV *cv;
SV *rv;
HV *stash;
- const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
- dVAR;
+
+ /* Points to the beginning of the \N{... so that any messages include the
+ * context of what's failing*/
+ const char* context = s - 3;
+ STRLEN context_len = e - context + 1; /* include all of \N{...} */
+
PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
assert(e >= s);
assert(s > (char *) 3);
- res = newSVpvn_flags(s, e - s, (is_utf8) ? SVf_UTF8 : 0);
+ char_name = newSVpvn_flags(s, e - s, (is_utf8) ? SVf_UTF8 : 0);
- if (!SvCUR(res)) {
- SvREFCNT_dec_NN(res);
+ if (!SvCUR(char_name)) {
+ SvREFCNT_dec_NN(char_name);
/* diag_listed_as: Unknown charname '%s' */
*error_msg = Perl_form(aTHX_ "Unknown charname ''");
return NULL;
}
- res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
- /* include the <}> */
- e - backslash_ptr + 1, error_msg);
- if (! SvPOK(res)) {
- SvREFCNT_dec_NN(res);
+ /* Autoload the charnames module */
+
+ table = load_charnames(char_name, context, context_len, error_msg);
+ if (table == NULL) {
+ return NULL;
+ }
+
+ *error_msg = NULL;
+ res = new_constant( NULL, 0, "charnames", char_name, NULL,
+ context, context_len, error_msg);
+ if (*error_msg) {
+ *error_msg = Perl_form(aTHX_ "Unknown charname '%s'", SvPVX(char_name));
+
+ SvREFCNT_dec(res);
return NULL;
}
/* See if the charnames handler is the Perl core's, and if so, we can skip
* the validation needed for a user-supplied one, as Perl's does its own
* validation. */
- table = GvHV(PL_hintgv); /* ^H */
cvp = hv_fetchs(table, "charnames", FALSE);
if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
}
else {
/* Similarly for utf8. For invariants can check directly; for other
- * Latin1, can calculate their code point and check; otherwise use a
- * swash */
+ * Latin1, can calculate their code point and check; otherwise use an
+ * inversion list */
if (UTF8_IS_INVARIANT(*s)) {
if (! isALPHAU(*s)) {
goto bad_charname;
*error_msg = Perl_form(aTHX_
"charnames alias definitions may not contain trailing "
"white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
- (int)(s - backslash_ptr + 1), backslash_ptr,
+ (int)(s - context + 1), context,
(int)(e - s + 1), s + 1);
return NULL;
}
immediately after '%s' */
*error_msg = Perl_form(aTHX_
"Malformed UTF-8 returned by %.*s immediately after '%.*s'",
- (int) (e - backslash_ptr + 1), backslash_ptr,
+ (int) context_len, context,
(int) ((char *) first_bad_char_loc - str), str);
return NULL;
}
in \N{%s} */
*error_msg = Perl_form(aTHX_
"Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
- (int)(s - backslash_ptr + 1), backslash_ptr,
+ (int)(s - context + 1), context,
(int)(e - s + 1), s + 1);
return NULL;
}
*error_msg = Perl_form(aTHX_
"charnames alias definitions may not contain a sequence of "
"multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
- (int)(s - backslash_ptr + 1), backslash_ptr,
+ (int)(s - context + 1), context,
(int)(e - s + 1), s + 1);
return NULL;
}
bool dorange = FALSE; /* are we in a translit range? */
bool didrange = FALSE; /* did we just finish a range? */
bool in_charclass = FALSE; /* within /[...]/ */
- bool has_utf8 = FALSE; /* Output constant is UTF8 */
- bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
+ bool s_is_utf8 = cBOOL(UTF); /* Is the source string assumed to be
UTF8? But, this can show as true
when the source isn't utf8, as for
example when it is entirely composed
of hex constants */
+ bool d_is_utf8 = FALSE; /* Output constant is UTF8 */
STRLEN utf8_variant_count = 0; /* When not in UTF-8, this counts the
number of characters found so far
that will expand (into 2 bytes)
PERL_ARGS_ASSERT_SCAN_CONST;
assert(PL_lex_inwhat != OP_TRANSR);
- if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
- /* If we are doing a trans and we know we want UTF8 set expectation */
- has_utf8 = PL_parser->lex_sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
- this_utf8 = PL_parser->lex_sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
- }
/* Protect sv from errors and fatal warnings. */
ENTER_with_name("scan_const");
SAVEFREESV(sv);
+ /* A bunch of code in the loop below assumes that if s[n] exists and is not
+ * NUL, then s[n+1] exists. This assertion makes sure that assumption is
+ * valid */
+ assert(*send == '\0');
+
while (s < send
|| dorange /* Handle tr/// range at right edge of input */
) {
* order to make the transliteration a simple table look-up.
* Ranges that extend above Latin1 have to be done differently, so
* there is no advantage to expanding them here, so they are
- * stored here as Min, ILLEGAL_UTF8_BYTE, Max. The illegal byte
- * signifies a hyphen without any possible ambiguity. On EBCDIC
- * machines, if the range is expressed as Unicode, the Latin1
- * portion is expanded out even if the range extends above
- * Latin1. This is because each code point in it has to be
- * processed here individually to get its native translation */
+ * stored here as Min, RANGE_INDICATOR, Max. 'RANGE_INDICATOR' is
+ * a byte that can't occur in legal UTF-8, and hence can signify a
+ * hyphen without any possible ambiguity. On EBCDIC machines, if
+ * the range is expressed as Unicode, the Latin1 portion is
+ * expanded out even if the range extends above Latin1. This is
+ * because each code point in it has to be processed here
+ * individually to get its native translation */
if (! dorange) {
* is not a hyphen; or if it is a hyphen, but it's too close to
* either edge to indicate a range, or if we haven't output any
* characters yet then it's a regular character. */
- if (*s != '-' || s >= send - 1 || s == start || d == SvPVX(sv)) {
+ if (*s != '-' || s >= send - 1 || s == start || d == SvPVX(sv))
+ {
/* A regular character. Process like any other, but first
* clear any flags */
* occurences in the constant, except those added by a
* backslash escape sequence, like \x{100}. Mostly, those
* set 'has_above_latin1' as appropriate */
- if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
+ if (s_is_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
has_above_latin1 = TRUE;
}
s++; /* Skip past the hyphen */
/* d now points to where the end-range character will be
- * placed. Save it so won't have to go finding it later,
- * and drop down to get that character. (Actually we
- * instead save the offset, to handle the case where a
- * realloc in the meantime could change the actual
- * pointer). We'll finish processing the range the next
- * time through the loop */
- offset_to_max = d - SvPVX_const(sv);
-
- if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
+ * placed. Drop down to get that character. We'll finish
+ * processing the range the next time through the loop */
+
+ if (s_is_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
has_above_latin1 = TRUE;
}
* are the range start and range end, in order.
* 'd' points to just beyond the range end in the 'sv' string,
* where we would next place something
- * 'offset_to_max' is the offset in 'sv' at which the character
- * (the range's maximum end point) before 'd' begins.
*/
- char * max_ptr = SvPVX(sv) + offset_to_max;
+ char * max_ptr;
char * min_ptr;
IV range_min;
IV range_max; /* last character in range */
IV real_range_max = 0;
#endif
/* Get the code point values of the range ends. */
- if (has_utf8) {
+ max_ptr = (d_is_utf8) ? (char *) utf8_hop( (U8*) d, -1) : d - 1;
+ offset_to_max = max_ptr - SvPVX_const(sv);
+ if (d_is_utf8) {
/* We know the utf8 is valid, because we just constructed
* it ourselves in previous loop iterations */
min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1);
* get it out of the way now.) */
if (UNLIKELY(range_max == range_min)) {
d = max_ptr;
- if (! has_utf8 && ! UVCHR_IS_INVARIANT(range_max)) {
+ if (! d_is_utf8 && ! UVCHR_IS_INVARIANT(range_max)) {
utf8_variant_count--;
}
goto range_done;
/* Here the range contains at least 3 code points */
- if (has_utf8) {
+ if (d_is_utf8) {
/* If everything in the transliteration is below 256, we
* can avoid special handling later. A translation table
&& (range_min > 255 || ! convert_unicode)
#endif
) {
+ const STRLEN off = d - SvPVX(sv);
+ const STRLEN extra = 1 + (send - s) + 1;
+ char *e;
+
/* Move the high character one byte to the right; then
* insert between it and the range begin, an illegal
* byte which serves to indicate this is a range (using
* a '-' would be ambiguous). */
- char *e = d++;
+
+ if (off + extra > SvLEN(sv)) {
+ d = off + SvGROW(sv, off + extra);
+ max_ptr = d - off + offset_to_max;
+ }
+
+ e = d++;
while (e-- > max_ptr) {
*(e + 1) = *e;
}
- *(e + 1) = (char) ILLEGAL_UTF8_BYTE;
+ *(e + 1) = (char) RANGE_INDICATOR;
goto range_done;
}
* */
grow = (range_max - 1) - (range_min + 1) + 1;
- if (has_utf8) {
+ if (d_is_utf8) {
#ifdef EBCDIC
/* In some cases in EBCDIC, we haven't yet calculated a
* precise amount needed for the UTF-8 variants. Just
/* Recall that the min and max are now in Unicode terms, so
* we have to convert each character to its native
* equivalent */
- if (has_utf8) {
+ if (d_is_utf8) {
for (i = range_min; i <= range_max; i++) {
append_utf8_from_native_byte(
LATIN1_TO_NATIVE((U8) i),
/* Here, no conversions are necessary, which means that the
* first character in the range is already in 'd' and
* valid, so we can skip overwriting it */
- if (has_utf8) {
+ if (d_is_utf8) {
SSize_t i;
d += UTF8SKIP(d);
for (i = range_min + 1; i <= range_max; i++) {
*d++ = (char) UTF8_TWO_BYTE_LO(0x100);
if (real_range_max > 0x100) {
if (real_range_max > 0x101) {
- *d++ = (char) ILLEGAL_UTF8_BYTE;
+ *d++ = (char) RANGE_INDICATOR;
}
d = (char*)uvchr_to_utf8((U8*)d, real_range_max);
}
* friends */
else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
if (s[2] == '#') {
- while (s+1 < send && *s != ')')
- *d++ = *s++;
+ if (s_is_utf8) {
+ PERL_UINT_FAST8_T len = UTF8SKIP(s);
+
+ while (s + len < send && *s != ')') {
+ Copy(s, d, len, U8);
+ d += len;
+ s += len;
+ len = UTF8_SAFE_SKIP(s, send);
+ }
+ }
+ else while (s+1 < send && *s != ')') {
+ *d++ = *s++;
+ }
}
else if (!PL_lex_casemods
&& ( s[2] == '{' /* This should match regcomp.c */
{
break;
}
- if (strchr(":'{$", s[1]))
+ if (memCHRs(":'{$", s[1]))
break;
if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
break; /* in regexp, neither @+ nor @- are interpolated */
else if (*s == '$') {
if (!PL_lex_inpat) /* not a regexp, so $ must be var */
break;
- if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
+ if (s + 1 < send && !memCHRs("()| \r\n\t", s[1])) {
if (s[1] == '\\') {
Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Possible unintended interpolation of $\\ in regex");
}
/* string-change backslash escapes */
- if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
+ if (PL_lex_inwhat != OP_TRANS && *s && memCHRs("lLuUEQF", *s)) {
--s;
break;
}
case '0': case '1': case '2': case '3':
case '4': case '5': case '6': case '7':
{
- I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
+ I32 flags = PERL_SCAN_SILENT_ILLDIGIT
+ | PERL_SCAN_NOTIFY_ILLDIGIT;
STRLEN len = 3;
- uv = grok_oct(s, &len, &flags, NULL);
- s += len;
- if (len < 3 && s < send && isDIGIT(*s)
+ uv = grok_oct(s, &len, &flags, NULL);
+ s += len;
+ if ( (flags & PERL_SCAN_NOTIFY_ILLDIGIT)
+ && s < send
+ && isDIGIT(*s) /* like \08, \178 */
&& ckWARN(WARN_MISC))
{
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "%s", form_short_octal_warning(s, len));
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "%s",
+ form_alien_digit_msg(8, len, s, send, UTF, FALSE));
}
}
goto NUM_ESCAPE_INSERT;
{
const char* error;
- bool valid = grok_bslash_o(&s, PL_bufend,
+ if (! grok_bslash_o(&s, send,
&uv, &error,
- TRUE, /* Output warning */
+ NULL,
FALSE, /* Not strict */
- TRUE, /* Output warnings for
- non-portables */
- UTF);
- if (! valid) {
+ FALSE, /* No illegal cp's */
+ UTF))
+ {
yyerror(error);
uv = 0; /* drop through to ensure range ends are set */
}
{
const char* error;
- bool valid = grok_bslash_x(&s, PL_bufend,
+ if (! grok_bslash_x(&s, send,
&uv, &error,
- TRUE, /* Output warning */
+ NULL,
FALSE, /* Not strict */
- TRUE, /* Output warnings for
- non-portables */
- UTF);
- if (! valid) {
+ FALSE, /* No illegal cp's */
+ UTF))
+ {
yyerror(error);
uv = 0; /* drop through to ensure range ends are set */
}
*d++ = (char) uv;
}
else {
- if (!has_utf8 && uv > 255) {
+ if (!d_is_utf8 && uv > 255) {
/* Here, 'uv' won't fit unless we convert to UTF-8.
* If we've only seen invariants so far, all we have to
}
has_above_latin1 = TRUE;
- has_utf8 = TRUE;
+ d_is_utf8 = TRUE;
}
- if (! has_utf8) {
+ if (! d_is_utf8) {
*d++ = (char)uv;
utf8_variant_count++;
}
d = SvCUR(sv) + SvGROW(sv, needed);
}
- d = (char*)uvchr_to_utf8((U8*)d, uv);
- if (PL_lex_inwhat == OP_TRANS
- && PL_parser->lex_sub_op)
- {
- PL_parser->lex_sub_op->op_private |=
- (PL_lex_repl ? OPpTRANS_FROM_UTF
- : OPpTRANS_TO_UTF);
- }
+ d = (char*) uvchr_to_utf8_flags((U8*)d, uv,
+ (ckWARN(WARN_PORTABLE))
+ ? UNICODE_WARN_PERL_EXTENDED
+ : 0);
}
}
#ifdef EBCDIC
}
else { /* Not a pattern: convert the hex to string */
I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
- | PERL_SCAN_SILENT_ILLDIGIT
- | PERL_SCAN_DISALLOW_PREFIX;
+ | PERL_SCAN_SILENT_ILLDIGIT
+ | PERL_SCAN_SILENT_OVERFLOW
+ | PERL_SCAN_DISALLOW_PREFIX;
STRLEN len = e - s;
+
uv = grok_hex(s, &len, &flags, NULL);
if (len == 0 || (len != (STRLEN)(e - s)))
goto bad_NU;
+ if ( uv > MAX_LEGAL_CP
+ || (flags & PERL_SCAN_GREATER_THAN_UV_MAX))
+ {
+ yyerror(form_cp_too_large_msg(16, s, len, 0));
+ uv = 0; /* drop through to ensure range ends are
+ set */
+ }
+
/* For non-tr///, if the destination is not in utf8,
* unconditionally recode it to be so. This is
* because \N{} implies Unicode semantics, and scalars
* tr/// doesn't care about Unicode rules, so no need
* there to upgrade to UTF-8 for small enough code
* points */
- if (! has_utf8 && ( uv > 0xFF
+ if (! d_is_utf8 && ( uv > 0xFF
|| PL_lex_inwhat != OP_TRANS))
{
/* See Note on sizing above. */
d = SvPVX(sv) + SvCUR(sv);
}
- has_utf8 = TRUE;
+ d_is_utf8 = TRUE;
has_above_latin1 = TRUE;
}
/* Add the (Unicode) code point to the output. */
- if (! has_utf8 || OFFUNI_IS_INVARIANT(uv)) {
+ if (! d_is_utf8 || OFFUNI_IS_INVARIANT(uv)) {
*d++ = (char) LATIN1_TO_NATIVE(uv);
}
else {
- d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
+ d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv,
+ (ckWARN(WARN_PORTABLE))
+ ? UNICODE_WARN_PERL_EXTENDED
+ : 0);
}
}
}
/* Upgrade destination to be utf8 if this new
* component is */
- if (! has_utf8 && SvUTF8(res)) {
+ if (! d_is_utf8 && SvUTF8(res)) {
/* See Note on sizing above. */
const STRLEN extra = len + (send - s) + 1;
extra);
d = SvPVX(sv) + SvCUR(sv);
}
- has_utf8 = TRUE;
+ d_is_utf8 = TRUE;
} else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
/* See Note on sizing above. (NOTE: SvCUR() is not
case 'c':
s++;
if (s < send) {
- *d++ = grok_bslash_c(*s, 1);
+ const char * message;
+
+ if (! grok_bslash_c(*s, (U8 *) d, &message, NULL)) {
+ yyerror(message);
+ yyquit(); /* Have always immediately croaked on
+ errors in this */
+ }
+ d++;
}
else {
yyerror("Missing control char name in \\c");
if (NATIVE_BYTE_IS_INVARIANT((U8)(*s))) {
*d++ = *s++;
}
- else if (! this_utf8 && ! has_utf8) {
+ else if (! s_is_utf8 && ! d_is_utf8) {
/* If neither source nor output is UTF-8, is also a single byte,
* just copy it; but this byte counts should we later have to
* convert to UTF-8 */
*d++ = *s++;
utf8_variant_count++;
}
- else if (this_utf8 && has_utf8) { /* Both UTF-8, can just copy */
+ else if (s_is_utf8 && d_is_utf8) { /* Both UTF-8, can just copy */
const STRLEN len = UTF8SKIP(s);
/* We expect the source to have already been checked for
d += len;
s += len;
}
- else { /* UTF8ness matters and doesn't match, need to convert */
- STRLEN len = 1;
- const UV nextuv = (this_utf8)
- ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
- : (UV) ((U8) *s);
- STRLEN need = UVCHR_SKIP(nextuv);
-
- if (!has_utf8) {
- SvCUR_set(sv, d - SvPVX_const(sv));
- SvPOK_on(sv);
- *d = '\0';
+ else if (s_is_utf8) { /* UTF8ness matters: convert output to utf8 */
+ STRLEN need = send - s + 1; /* See Note on sizing above. */
- /* See Note on sizing above. */
- need += (STRLEN)(send - s) + 1;
+ SvCUR_set(sv, d - SvPVX_const(sv));
+ SvPOK_on(sv);
+ *d = '\0';
- if (utf8_variant_count == 0) {
- SvUTF8_on(sv);
- d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + need);
- }
- else {
- sv_utf8_upgrade_flags_grow(sv,
- SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
- need);
- d = SvPVX(sv) + SvCUR(sv);
- }
- has_utf8 = TRUE;
- } else if (need > len) {
- /* encoded value larger than old, may need extra space (NOTE:
- * SvCUR() is not set correctly here). See Note on sizing
- * above. */
- const STRLEN extra = need + (send - s) + 1;
- const STRLEN off = d - SvPVX_const(sv);
+ if (utf8_variant_count == 0) {
+ SvUTF8_on(sv);
+ d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + need);
+ }
+ else {
+ sv_utf8_upgrade_flags_grow(sv,
+ SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
+ need);
+ d = SvPVX(sv) + SvCUR(sv);
+ }
+ d_is_utf8 = TRUE;
+ goto default_action; /* Redo, having upgraded so both are UTF-8 */
+ }
+ else { /* UTF8ness matters: convert this non-UTF8 source char to
+ UTF-8 for output. It will occupy 2 bytes, but don't include
+ the input byte since we haven't incremented 's' yet. See
+ Note on sizing above. */
+ const STRLEN off = d - SvPVX(sv);
+ const STRLEN extra = 2 + (send - s - 1) + 1;
+ if (off + extra > SvLEN(sv)) {
d = off + SvGROW(sv, off + extra);
}
- s += len;
-
- d = (char*)uvchr_to_utf8((U8*)d, nextuv);
+ *d++ = UTF8_EIGHT_BIT_HI(*s);
+ *d++ = UTF8_EIGHT_BIT_LO(*s);
+ s++;
}
} /* while loop to process each character */
+ {
+ const STRLEN off = d - SvPVX(sv);
+
+ /* See if room for the terminating NUL */
+ if (UNLIKELY(off >= SvLEN(sv))) {
+
+#ifndef DEBUGGING
+
+ if (off > SvLEN(sv))
+#endif
+ Perl_croak(aTHX_ "panic: constant overflowed allocated space,"
+ " %" UVuf " >= %" UVuf, (UV)off, (UV)SvLEN(sv));
+
+ /* Whew! Here we don't have room for the terminating NUL, but
+ * everything else so far has fit. It's not too late to grow
+ * to fit the NUL and continue on. But it is a bug, as the code
+ * above was supposed to have made room for this, so under
+ * DEBUGGING builds, we panic anyway. */
+ d = off + SvGROW(sv, off + 1);
+ }
+ }
+
/* terminate the string and set up the sv */
*d = '\0';
SvCUR_set(sv, d - SvPVX_const(sv));
- if (SvCUR(sv) >= SvLEN(sv))
- Perl_croak(aTHX_ "panic: constant overflowed allocated space, %" UVuf
- " >= %" UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
SvPOK_on(sv);
- if (has_utf8) {
+ if (d_is_utf8) {
SvUTF8_on(sv);
- if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
- PL_parser->lex_sub_op->op_private |=
- (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
- }
}
/* shrink the sv if we allocated more than we used */
} else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
type = "q";
typelen = 1;
- } else {
+ } else {
type = "qq";
typelen = 2;
}
if (*s == '-' && s[1] == '>'
&& FEATURE_POSTDEREF_QQ_IS_ENABLED
&& ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
- ||(s[2] == '@' && strchr("*[{",s[3])) ))
+ ||(s[2] == '@' && memCHRs("*[{",s[3])) ))
return TRUE;
if (*s != '{' && *s != '[')
return FALSE;
}
else if (*s == '$'
&& s[1]
- && strchr("[#!%*<>()-=",s[1]))
+ && memCHRs("[#!%*<>()-=",s[1]))
{
- if (/*{*/ strchr("])} =",s[2]))
+ if (/*{*/ memCHRs("])} =",s[2]))
weight -= 10;
else
weight -= 1;
case '\\':
un_char = 254;
if (s[1]) {
- if (strchr("wds]",s[1]))
+ if (memCHRs("wds]",s[1]))
weight += 100;
else if (seen[(U8)'\''] || seen[(U8)'"'])
weight += 1;
- else if (strchr("rnftbxcav",s[1]))
+ else if (memCHRs("rnftbxcav",s[1]))
weight += 40;
else if (isDIGIT(s[1])) {
weight += 40;
case '-':
if (s[1] == '\\')
weight += 50;
- if (strchr("aA01! ",last_un_char))
+ if (memCHRs("aA01! ",last_un_char))
weight += 30;
- if (strchr("zZ79~",s[1]))
+ if (memCHRs("zZ79~",s[1]))
weight += 30;
if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
weight -= 5; /* cope with negative subscript */
PERL_ARGS_ASSERT_INTUIT_METHOD;
+ if (!FEATURE_INDIRECT_IS_ENABLED)
+ return 0;
+
if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
return 0;
if (cv && SvPOK(cv)) {
STATIC bool
S_word_takes_any_delimiter(char *p, STRLEN len)
{
- return (len == 1 && strchr("msyq", p[0]))
+ return (len == 1 && memCHRs("msyq", p[0]))
|| (len == 2
&& ((p[0] == 't' && p[1] == 'r')
- || (p[0] == 'q' && strchr("qwxr", p[1]))));
+ || (p[0] == 'q' && memCHRs("qwxr", p[1]))));
}
static void
return;
}
while ( isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF)
- || (*s && strchr(" \t$#+-'\"", *s)))
+ || (*s && memCHRs(" \t$#+-'\"", *s)))
{
s += UTF ? UTF8SKIP(s) : 1;
}
return s;
}
-/*
- yylex
+static int
+yyl_sigvar(pTHX_ char *s)
+{
+ /* we expect the sigil and optional var name part of a
+ * signature element here. Since a '$' is not necessarily
+ * followed by a var name, handle it specially here; the general
+ * yylex code would otherwise try to interpret whatever follows
+ * as a var; e.g. ($, ...) would be seen as the var '$,'
+ */
- Works out what to call the token just pulled out of the input
- stream. The yacc parser takes care of taking the ops we return and
- stitching them into a tree.
+ U8 sigil;
- Returns:
- The type of the next token
+ s = skipspace(s);
+ sigil = *s++;
+ PL_bufptr = s; /* for error reporting */
+ switch (sigil) {
+ case '$':
+ case '@':
+ case '%':
+ /* spot stuff that looks like an prototype */
+ if (memCHRs("$:@%&*;\\[]", *s)) {
+ yyerror("Illegal character following sigil in a subroutine signature");
+ break;
+ }
+ /* '$#' is banned, while '$ # comment' isn't */
+ if (*s == '#') {
+ yyerror("'#' not allowed immediately following a sigil in a subroutine signature");
+ break;
+ }
+ s = skipspace(s);
+ if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
+ char *dest = PL_tokenbuf + 1;
+ /* read var name, including sigil, into PL_tokenbuf */
+ PL_tokenbuf[0] = sigil;
+ parse_ident(&s, &dest, dest + sizeof(PL_tokenbuf) - 1,
+ 0, cBOOL(UTF), FALSE, FALSE);
+ *dest = '\0';
+ assert(PL_tokenbuf[1]); /* we have a variable name */
+ }
+ else {
+ *PL_tokenbuf = 0;
+ PL_in_my = 0;
+ }
- Structure:
- Check if we have already built the token; if so, use it.
- Switch based on the current state:
- - if we have a case modifier in a string, deal with that
- - handle other cases of interpolation inside a string
- - scan the next line if we are inside a format
- In the normal state, switch on the next character:
- - default:
- if alphabetic, go to key lookup
- unrecognized character - croak
- - 0/4/26: handle end-of-line or EOF
- - cases for whitespace
- - \n and #: handle comments and line numbers
- - various operators, brackets and sigils
- - numbers
- - quotes
- - 'v': vstrings (or go to key lookup)
- - 'x' repetition operator (or go to key lookup)
- - other ASCII alphanumerics (key lookup begins here):
- word before => ?
- keyword plugin
- scan built-in keyword (but do nothing with it yet)
- check for statement label
- check for lexical subs
- goto just_a_word if there is one
- see whether built-in keyword is overridden
- switch on keyword number:
- - default: just_a_word:
- not a built-in keyword; handle bareword lookup
- disambiguate between method and sub call
- fall back to bareword
- - cases for built-in keywords
-*/
+ s = skipspace(s);
+ /* parse the = for the default ourselves to avoid '+=' etc being accepted here
+ * as the ASSIGNOP, and exclude other tokens that start with =
+ */
+ if (*s == '=' && (!s[1] || memCHRs("=~>", s[1]) == 0)) {
+ /* save now to report with the same context as we did when
+ * all ASSIGNOPS were accepted */
+ PL_oldbufptr = s;
+
+ ++s;
+ NEXTVAL_NEXTTOKE.ival = 0;
+ force_next(ASSIGNOP);
+ PL_expect = XTERM;
+ }
+ else if (*s == ',' || *s == ')') {
+ PL_expect = XOPERATOR;
+ }
+ else {
+ /* make sure the context shows the unexpected character and
+ * hopefully a bit more */
+ if (*s) ++s;
+ while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
+ s++;
+ PL_bufptr = s; /* for error reporting */
+ yyerror("Illegal operator following parameter in a subroutine signature");
+ PL_in_my = 0;
+ }
+ if (*PL_tokenbuf) {
+ NEXTVAL_NEXTTOKE.ival = sigil;
+ force_next('p'); /* force a signature pending identifier */
+ }
+ break;
+
+ case ')':
+ PL_expect = XBLOCK;
+ break;
+ case ',': /* handle ($a,,$b) */
+ break;
+ default:
+ PL_in_my = 0;
+ yyerror("A signature parameter must start with '$', '@' or '%'");
+ /* very crude error recovery: skip to likely next signature
+ * element */
+ while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
+ s++;
+ break;
+ }
-int
-Perl_yylex(pTHX)
+ TOKEN(sigil);
+}
+
+static int
+yyl_dollar(pTHX_ char *s)
{
- dVAR;
- char *s = PL_bufptr;
- char *d;
- STRLEN len;
- bool bof = FALSE;
- const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
- U8 formbrack = 0;
- U32 fake_eof = 0;
-
- /* orig_keyword, gvp, and gv are initialized here because
- * jump to the label just_a_word_zero can bypass their
- * initialization later. */
- I32 orig_keyword = 0;
- GV *gv = NULL;
- GV **gvp = NULL;
+ CLINE;
- if (UNLIKELY(PL_parser->recheck_utf8_validity)) {
- const U8* first_bad_char_loc;
- if (UTF && UNLIKELY(! is_utf8_string_loc((U8 *) PL_bufptr,
- PL_bufend - PL_bufptr,
- &first_bad_char_loc)))
- {
- _force_out_malformed_utf8_message(first_bad_char_loc,
- (U8 *) PL_bufend,
- 0,
- 1 /* 1 means die */ );
- NOT_REACHED; /* NOTREACHED */
+ if (PL_expect == XPOSTDEREF) {
+ if (s[1] == '#') {
+ s++;
+ POSTDEREF(DOLSHARP);
}
- PL_parser->recheck_utf8_validity = FALSE;
+ POSTDEREF('$');
}
- DEBUG_T( {
- SV* tmp = newSVpvs("");
- PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n",
- (IV)CopLINE(PL_curcop),
- lex_state_names[PL_lex_state],
- exp_name[PL_expect],
- pv_display(tmp, s, strlen(s), 0, 60));
- SvREFCNT_dec(tmp);
- } );
- /* when we've already built the next token, just pull it out of the queue */
- if (PL_nexttoke) {
- PL_nexttoke--;
- pl_yylval = PL_nextval[PL_nexttoke];
- {
- I32 next_type;
- next_type = PL_nexttype[PL_nexttoke];
- if (next_type & (7<<24)) {
- if (next_type & (1<<24)) {
- if (PL_lex_brackets > 100)
- Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
- PL_lex_brackstack[PL_lex_brackets++] =
- (char) ((next_type >> 16) & 0xff);
- }
- if (next_type & (2<<24))
- PL_lex_allbrackets++;
- if (next_type & (4<<24))
- PL_lex_allbrackets--;
- next_type &= 0xffff;
- }
- return REPORT(next_type == 'p' ? pending_ident() : next_type);
- }
+ if ( s[1] == '#'
+ && ( isIDFIRST_lazy_if_safe(s+2, PL_bufend, UTF)
+ || memCHRs("{$:+-@", s[2])))
+ {
+ PL_tokenbuf[0] = '@';
+ s = scan_ident(s + 1, PL_tokenbuf + 1,
+ sizeof PL_tokenbuf - 1, FALSE);
+ if (PL_expect == XOPERATOR) {
+ char *d = s;
+ if (PL_bufptr > s) {
+ d = PL_bufptr-1;
+ PL_bufptr = PL_oldbufptr;
+ }
+ no_op("Array length", d);
+ }
+ if (!PL_tokenbuf[1])
+ PREREF(DOLSHARP);
+ PL_expect = XOPERATOR;
+ force_ident_maybe_lex('#');
+ TOKEN(DOLSHARP);
+ }
+
+ PL_tokenbuf[0] = '$';
+ s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
+ if (PL_expect == XOPERATOR) {
+ char *d = s;
+ if (PL_bufptr > s) {
+ d = PL_bufptr-1;
+ PL_bufptr = PL_oldbufptr;
+ }
+ no_op("Scalar", d);
+ }
+ if (!PL_tokenbuf[1]) {
+ if (s == PL_bufend)
+ yyerror("Final $ should be \\$ or $name");
+ PREREF('$');
}
- switch (PL_lex_state) {
- case LEX_NORMAL:
- case LEX_INTERPNORMAL:
- break;
+ {
+ const char tmp = *s;
+ if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
+ s = skipspace(s);
- /* interpolated case modifiers like \L \U, including \Q and \E.
- when we get here, PL_bufptr is at the \
- */
- case LEX_INTERPCASEMOD:
-#ifdef DEBUGGING
- if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
- Perl_croak(aTHX_
- "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
- PL_bufptr, PL_bufend, *PL_bufptr);
-#endif
- /* handle \E or end of string */
- if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
- /* if at a \E */
- if (PL_lex_casemods) {
- const char oldmod = PL_lex_casestack[--PL_lex_casemods];
- PL_lex_casestack[PL_lex_casemods] = '\0';
-
- if (PL_bufptr != PL_bufend
- && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
- || oldmod == 'F')) {
- PL_bufptr += 2;
- PL_lex_state = LEX_INTERPCONCAT;
- }
- PL_lex_allbrackets--;
- return REPORT(')');
- }
- else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
- /* Got an unpaired \E */
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
- "Useless use of \\E");
+ if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
+ && intuit_more(s, PL_bufend)) {
+ if (*s == '[') {
+ PL_tokenbuf[0] = '@';
+ if (ckWARN(WARN_SYNTAX)) {
+ char *t = s+1;
+
+ while ( t < PL_bufend ) {
+ if (isSPACE(*t)) {
+ do { t += UTF ? UTF8SKIP(t) : 1; } while (t < PL_bufend && isSPACE(*t));
+ /* consumed one or more space chars */
+ } else if (*t == '$' || *t == '@') {
+ /* could be more than one '$' like $$ref or @$ref */
+ do { t++; } while (t < PL_bufend && *t == '$');
+
+ /* could be an abigail style identifier like $ foo */
+ while (t < PL_bufend && *t == ' ') t++;
+
+ /* strip off the name of the var */
+ while (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
+ t += UTF ? UTF8SKIP(t) : 1;
+ /* consumed a varname */
+ } else if (isDIGIT(*t)) {
+ /* deal with hex constants like 0x11 */
+ if (t[0] == '0' && t[1] == 'x') {
+ t += 2;
+ while (t < PL_bufend && isXDIGIT(*t)) t++;
+ } else {
+ /* deal with decimal/octal constants like 1 and 0123 */
+ do { t++; } while (isDIGIT(*t));
+ if (t<PL_bufend && *t == '.') {
+ do { t++; } while (isDIGIT(*t));
+ }
+ }
+ /* consumed a number */
+ } else {
+ /* not a var nor a space nor a number */
+ break;
+ }
+ }
+ if (t < PL_bufend && *t++ == ',') {
+ PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
+ while (t < PL_bufend && *t != ']')
+ t++;
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Multidimensional syntax %" UTF8f " not supported",
+ UTF8fARG(UTF,(int)((t - PL_bufptr) + 1), PL_bufptr));
+ }
+ }
}
- if (PL_bufptr != PL_bufend)
- PL_bufptr += 2;
- PL_lex_state = LEX_INTERPCONCAT;
- return yylex();
- }
- else {
- DEBUG_T({ PerlIO_printf(Perl_debug_log,
- "### Saw case modifier\n"); });
- s = PL_bufptr + 1;
- if (s[1] == '\\' && s[2] == 'E') {
- PL_bufptr = s + 3;
- PL_lex_state = LEX_INTERPCONCAT;
- return yylex();
- }
- else {
- I32 tmp;
- if ( memBEGINs(s, (STRLEN) (PL_bufend - s), "L\\u")
- || memBEGINs(s, (STRLEN) (PL_bufend - s), "U\\l"))
+ else if (*s == '{') {
+ char *t;
+ PL_tokenbuf[0] = '%';
+ if ( strEQ(PL_tokenbuf+1, "SIG")
+ && ckWARN(WARN_SYNTAX)
+ && (t = (char *) memchr(s, '}', PL_bufend - s))
+ && (t = (char *) memchr(t, '=', PL_bufend - t)))
{
- tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
+ char tmpbuf[sizeof PL_tokenbuf];
+ do {
+ t++;
+ } while (isSPACE(*t));
+ if (isIDFIRST_lazy_if_safe(t, PL_bufend, UTF)) {
+ STRLEN len;
+ t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
+ &len);
+ while (isSPACE(*t))
+ t++;
+ if ( *t == ';'
+ && get_cvn_flags(tmpbuf, len, UTF
+ ? SVf_UTF8
+ : 0))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "You need to quote \"%" UTF8f "\"",
+ UTF8fARG(UTF, len, tmpbuf));
+ }
+ }
}
- if ((*s == 'L' || *s == 'U' || *s == 'F')
- && (strpbrk(PL_lex_casestack, "LUF")))
- {
- PL_lex_casestack[--PL_lex_casemods] = '\0';
- PL_lex_allbrackets--;
- return REPORT(')');
- }
- if (PL_lex_casemods > 10)
- Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
- PL_lex_casestack[PL_lex_casemods++] = *s;
- PL_lex_casestack[PL_lex_casemods] = '\0';
- PL_lex_state = LEX_INTERPCONCAT;
- NEXTVAL_NEXTTOKE.ival = 0;
- force_next((2<<24)|'(');
- if (*s == 'l')
- NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
- else if (*s == 'u')
- NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
- else if (*s == 'L')
- NEXTVAL_NEXTTOKE.ival = OP_LC;
- else if (*s == 'U')
- NEXTVAL_NEXTTOKE.ival = OP_UC;
- else if (*s == 'Q')
- NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
- else if (*s == 'F')
- NEXTVAL_NEXTTOKE.ival = OP_FC;
- else
- Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
- PL_bufptr = s + 1;
- }
- force_next(FUNC);
- if (PL_lex_starts) {
- s = PL_bufptr;
- PL_lex_starts = 0;
- /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
- if (PL_lex_casemods == 1 && PL_lex_inpat)
- TOKEN(',');
- else
- AopNOASSIGN(OP_CONCAT);
- }
- else
- return yylex();
- }
-
- case LEX_INTERPPUSH:
- return REPORT(sublex_push());
-
- case LEX_INTERPSTART:
- if (PL_bufptr == PL_bufend)
- return REPORT(sublex_done());
- DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
- "### Interpolated variable\n"); });
- PL_expect = XTERM;
- /* for /@a/, we leave the joining for the regex engine to do
- * (unless we're within \Q etc) */
- PL_lex_dojoin = (*PL_bufptr == '@'
- && (!PL_lex_inpat || PL_lex_casemods));
- PL_lex_state = LEX_INTERPNORMAL;
- if (PL_lex_dojoin) {
- NEXTVAL_NEXTTOKE.ival = 0;
- force_next(',');
- force_ident("\"", '$');
- NEXTVAL_NEXTTOKE.ival = 0;
- force_next('$');
- NEXTVAL_NEXTTOKE.ival = 0;
- force_next((2<<24)|'(');
- NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
- force_next(FUNC);
- }
- /* Convert (?{...}) and friends to 'do {...}' */
- if (PL_lex_inpat && *PL_bufptr == '(') {
- PL_parser->lex_shared->re_eval_start = PL_bufptr;
- PL_bufptr += 2;
- if (*PL_bufptr != '{')
- PL_bufptr++;
- PL_expect = XTERMBLOCK;
- force_next(DO);
- }
+ }
+ }
- if (PL_lex_starts++) {
- s = PL_bufptr;
- /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
- if (!PL_lex_casemods && PL_lex_inpat)
- TOKEN(',');
- else
- AopNOASSIGN(OP_CONCAT);
- }
- return yylex();
+ PL_expect = XOPERATOR;
+ if ((PL_lex_state == LEX_NORMAL || PL_lex_brackets) && isSPACE((char)tmp)) {
+ const bool islop = (PL_last_lop == PL_oldoldbufptr);
+ if (!islop || PL_last_lop_op == OP_GREPSTART)
+ PL_expect = XOPERATOR;
+ else if (memCHRs("$@\"'`q", *s))
+ PL_expect = XTERM; /* e.g. print $fh "foo" */
+ else if ( memCHRs("&*<%", *s)
+ && isIDFIRST_lazy_if_safe(s+1, PL_bufend, UTF))
+ {
+ PL_expect = XTERM; /* e.g. print $fh &sub */
+ }
+ else if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
+ char tmpbuf[sizeof PL_tokenbuf];
+ int t2;
+ STRLEN len;
+ scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
+ if ((t2 = keyword(tmpbuf, len, 0))) {
+ /* binary operators exclude handle interpretations */
+ switch (t2) {
+ case -KEY_x:
+ case -KEY_eq:
+ case -KEY_ne:
+ case -KEY_gt:
+ case -KEY_lt:
+ case -KEY_ge:
+ case -KEY_le:
+ case -KEY_cmp:
+ break;
+ default:
+ PL_expect = XTERM; /* e.g. print $fh length() */
+ break;
+ }
+ }
+ else {
+ PL_expect = XTERM; /* e.g. print $fh subr() */
+ }
+ }
+ else if (isDIGIT(*s))
+ PL_expect = XTERM; /* e.g. print $fh 3 */
+ else if (*s == '.' && isDIGIT(s[1]))
+ PL_expect = XTERM; /* e.g. print $fh .3 */
+ else if ((*s == '?' || *s == '-' || *s == '+')
+ && !isSPACE(s[1]) && s[1] != '=')
+ PL_expect = XTERM; /* e.g. print $fh -1 */
+ else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
+ && s[1] != '/')
+ PL_expect = XTERM; /* e.g. print $fh /.../
+ XXX except DORDOR operator
+ */
+ else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
+ && s[2] != '=')
+ PL_expect = XTERM; /* print $fh <<"EOF" */
+ }
+ }
+ force_ident_maybe_lex('$');
+ TOKEN('$');
+}
- case LEX_INTERPENDMAYBE:
- if (intuit_more(PL_bufptr, PL_bufend)) {
- PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
- break;
- }
- /* FALLTHROUGH */
+static int
+yyl_sub(pTHX_ char *s, const int key)
+{
+ char * const tmpbuf = PL_tokenbuf + 1;
+ bool have_name, have_proto;
+ STRLEN len;
+ SV *format_name = NULL;
+ bool is_sigsub = FEATURE_SIGNATURES_IS_ENABLED;
- case LEX_INTERPEND:
- if (PL_lex_dojoin) {
- const U8 dojoin_was = PL_lex_dojoin;
- PL_lex_dojoin = FALSE;
- PL_lex_state = LEX_INTERPCONCAT;
- PL_lex_allbrackets--;
- return REPORT(dojoin_was == 1 ? (int)')' : (int)POSTJOIN);
- }
- if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
- && SvEVALED(PL_lex_repl))
- {
- if (PL_bufptr != PL_bufend)
- Perl_croak(aTHX_ "Bad evalled substitution pattern");
- PL_lex_repl = NULL;
- }
- /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
- re_eval_str. If the here-doc body’s length equals the previous
- value of re_eval_start, re_eval_start will now be null. So
- check re_eval_str as well. */
- if (PL_parser->lex_shared->re_eval_start
- || PL_parser->lex_shared->re_eval_str) {
- SV *sv;
- if (*PL_bufptr != ')')
- Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
- PL_bufptr++;
- /* having compiled a (?{..}) expression, return the original
- * text too, as a const */
- if (PL_parser->lex_shared->re_eval_str) {
- sv = PL_parser->lex_shared->re_eval_str;
- PL_parser->lex_shared->re_eval_str = NULL;
- SvCUR_set(sv,
- PL_bufptr - PL_parser->lex_shared->re_eval_start);
- SvPV_shrink_to_cur(sv);
- }
- else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
- PL_bufptr - PL_parser->lex_shared->re_eval_start);
- NEXTVAL_NEXTTOKE.opval =
- newSVOP(OP_CONST, 0,
- sv);
- force_next(THING);
- PL_parser->lex_shared->re_eval_start = NULL;
- PL_expect = XTERM;
- return REPORT(',');
- }
+ SSize_t off = s-SvPVX(PL_linestr);
+ char *d;
- /* FALLTHROUGH */
- case LEX_INTERPCONCAT:
-#ifdef DEBUGGING
- if (PL_lex_brackets)
- Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
- (long) PL_lex_brackets);
-#endif
- if (PL_bufptr == PL_bufend)
- return REPORT(sublex_done());
+ s = skipspace(s); /* can move PL_linestr */
- /* m'foo' still needs to be parsed for possible (?{...}) */
- if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
- SV *sv = newSVsv(PL_linestr);
- sv = tokeq(sv);
- pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
- s = PL_bufend;
- }
- else {
- int save_error_count = PL_error_count;
+ d = SvPVX(PL_linestr)+off;
- s = scan_const(PL_bufptr);
+ SAVEBOOL(PL_parser->sig_seen);
+ PL_parser->sig_seen = FALSE;
- /* Set flag if this was a pattern and there were errors. op.c will
- * refuse to compile a pattern with this flag set. Otherwise, we
- * could get segfaults, etc. */
- if (PL_lex_inpat && PL_error_count > save_error_count) {
- ((PMOP*)PL_lex_inpat)->op_pmflags |= PMf_HAS_ERROR;
- }
- if (*s == '\\')
- PL_lex_state = LEX_INTERPCASEMOD;
- else
- PL_lex_state = LEX_INTERPSTART;
- }
+ if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
+ || *s == '\''
+ || (*s == ':' && s[1] == ':'))
+ {
- if (s != PL_bufptr) {
- NEXTVAL_NEXTTOKE = pl_yylval;
- PL_expect = XTERM;
- force_next(THING);
- if (PL_lex_starts++) {
- /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
- if (!PL_lex_casemods && PL_lex_inpat)
- TOKEN(',');
- else
- AopNOASSIGN(OP_CONCAT);
- }
- else {
- PL_bufptr = s;
- return yylex();
- }
- }
+ PL_expect = XATTRBLOCK;
+ d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
+ &len);
+ if (key == KEY_format)
+ format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
+ *PL_tokenbuf = '&';
+ if (memchr(tmpbuf, ':', len) || key != KEY_sub
+ || pad_findmy_pvn(
+ PL_tokenbuf, len + 1, 0
+ ) != NOT_IN_PAD)
+ sv_setpvn(PL_subname, tmpbuf, len);
+ else {
+ sv_setsv(PL_subname,PL_curstname);
+ sv_catpvs(PL_subname,"::");
+ sv_catpvn(PL_subname,tmpbuf,len);
+ }
+ if (SvUTF8(PL_linestr))
+ SvUTF8_on(PL_subname);
+ have_name = TRUE;
- return yylex();
- case LEX_FORMLINE:
- if (PL_parser->sub_error_count != PL_error_count) {
- /* There was an error parsing a formline, which tends to
- mess up the parser.
- Unlike interpolated sub-parsing, we can't treat any of
- these as recoverable, so no need to check sub_no_recover.
- */
- yyquit();
+ s = skipspace(d);
+ }
+ else {
+ if (key == KEY_my || key == KEY_our || key==KEY_state) {
+ *d = '\0';
+ /* diag_listed_as: Missing name in "%s sub" */
+ Perl_croak(aTHX_
+ "Missing name in \"%s\"", PL_bufptr);
}
- assert(PL_lex_formbrack);
- s = scan_formline(PL_bufptr);
- if (!PL_lex_formbrack)
- {
- formbrack = 1;
- goto rightbracket;
- }
- PL_bufptr = s;
- return yylex();
+ PL_expect = XATTRTERM;
+ sv_setpvs(PL_subname,"?");
+ have_name = FALSE;
}
- /* We really do *not* want PL_linestr ever becoming a COW. */
- assert (!SvIsCOW(PL_linestr));
- s = PL_bufptr;
- PL_oldoldbufptr = PL_oldbufptr;
- PL_oldbufptr = s;
- PL_parser->saw_infix_sigil = 0;
-
- if (PL_in_my == KEY_sigvar) {
- /* we expect the sigil and optional var name part of a
- * signature element here. Since a '$' is not necessarily
- * followed by a var name, handle it specially here; the general
- * yylex code would otherwise try to interpret whatever follows
- * as a var; e.g. ($, ...) would be seen as the var '$,'
- */
+ if (key == KEY_format) {
+ if (format_name) {
+ NEXTVAL_NEXTTOKE.opval
+ = newSVOP(OP_CONST,0, format_name);
+ NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
+ force_next(BAREWORD);
+ }
+ PREBLOCK(FORMAT);
+ }
- U8 sigil;
+ /* Look for a prototype */
+ if (*s == '(' && !is_sigsub) {
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
+ if (!s)
+ Perl_croak(aTHX_ "Prototype not terminated");
+ COPLINE_SET_FROM_MULTI_END;
+ (void)validate_proto(PL_subname, PL_lex_stuff,
+ ckWARN(WARN_ILLEGALPROTO), 0);
+ have_proto = TRUE;
s = skipspace(s);
- sigil = *s++;
- PL_bufptr = s; /* for error reporting */
- switch (sigil) {
- case '$':
- case '@':
- case '%':
- /* spot stuff that looks like an prototype */
- if (strchr("$:@%&*;\\[]", *s)) {
- yyerror("Illegal character following sigil in a subroutine signature");
- break;
- }
- /* '$#' is banned, while '$ # comment' isn't */
- if (*s == '#') {
- yyerror("'#' not allowed immediately following a sigil in a subroutine signature");
- break;
- }
- s = skipspace(s);
- if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
- char *dest = PL_tokenbuf + 1;
- /* read var name, including sigil, into PL_tokenbuf */
- PL_tokenbuf[0] = sigil;
- parse_ident(&s, &dest, dest + sizeof(PL_tokenbuf) - 1,
- 0, cBOOL(UTF), FALSE, FALSE);
- *dest = '\0';
- assert(PL_tokenbuf[1]); /* we have a variable name */
- }
- else {
- *PL_tokenbuf = 0;
- PL_in_my = 0;
- }
+ }
+ else
+ have_proto = FALSE;
- s = skipspace(s);
- /* parse the = for the default ourselves to avoid '+=' etc being accepted here
- * as the ASSIGNOP, and exclude other tokens that start with =
- */
- if (*s == '=' && (!s[1] || strchr("=~>", s[1]) == 0)) {
- /* save now to report with the same context as we did when
- * all ASSIGNOPS were accepted */
- PL_oldbufptr = s;
-
- ++s;
- NEXTVAL_NEXTTOKE.ival = 0;
- force_next(ASSIGNOP);
- PL_expect = XTERM;
- }
- else if (*s == ',' || *s == ')') {
- PL_expect = XOPERATOR;
- }
- else {
- /* make sure the context shows the unexpected character and
- * hopefully a bit more */
- if (*s) ++s;
- while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
- s++;
- PL_bufptr = s; /* for error reporting */
- yyerror("Illegal operator following parameter in a subroutine signature");
- PL_in_my = 0;
- }
- if (*PL_tokenbuf) {
- NEXTVAL_NEXTTOKE.ival = sigil;
- force_next('p'); /* force a signature pending identifier */
- }
- break;
+ if ( !(*s == ':' && s[1] != ':')
+ && (*s != '{' && *s != '(') && key != KEY_format)
+ {
+ assert(key == KEY_sub || key == KEY_AUTOLOAD ||
+ key == KEY_DESTROY || key == KEY_BEGIN ||
+ key == KEY_UNITCHECK || key == KEY_CHECK ||
+ key == KEY_INIT || key == KEY_END ||
+ key == KEY_my || key == KEY_state ||
+ key == KEY_our);
+ if (!have_name)
+ Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
+ else if (*s != ';' && *s != '}')
+ Perl_croak(aTHX_ "Illegal declaration of subroutine %" SVf, SVfARG(PL_subname));
+ }
+
+ if (have_proto) {
+ NEXTVAL_NEXTTOKE.opval =
+ newSVOP(OP_CONST, 0, PL_lex_stuff);
+ PL_lex_stuff = NULL;
+ force_next(THING);
+ }
+ if (!have_name) {
+ if (PL_curstash)
+ sv_setpvs(PL_subname, "__ANON__");
+ else
+ sv_setpvs(PL_subname, "__ANON__::__ANON__");
+ if (is_sigsub)
+ TOKEN(ANON_SIGSUB);
+ else
+ TOKEN(ANONSUB);
+ }
+ force_ident_maybe_lex('&');
+ if (is_sigsub)
+ TOKEN(SIGSUB);
+ else
+ TOKEN(SUB);
+}
- case ')':
- PL_expect = XBLOCK;
- break;
- case ',': /* handle ($a,,$b) */
- break;
+static int
+yyl_interpcasemod(pTHX_ char *s)
+{
+#ifdef DEBUGGING
+ if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
+ Perl_croak(aTHX_
+ "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
+ PL_bufptr, PL_bufend, *PL_bufptr);
+#endif
- default:
- PL_in_my = 0;
- yyerror("A signature parameter must start with '$', '@' or '%'");
- /* very crude error recovery: skip to likely next signature
- * element */
- while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
- s++;
- break;
+ if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
+ /* if at a \E */
+ if (PL_lex_casemods) {
+ const char oldmod = PL_lex_casestack[--PL_lex_casemods];
+ PL_lex_casestack[PL_lex_casemods] = '\0';
+
+ if (PL_bufptr != PL_bufend
+ && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
+ || oldmod == 'F')) {
+ PL_bufptr += 2;
+ PL_lex_state = LEX_INTERPCONCAT;
+ }
+ PL_lex_allbrackets--;
+ return REPORT(')');
}
- TOKEN(sigil);
+ else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
+ /* Got an unpaired \E */
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ "Useless use of \\E");
+ }
+ if (PL_bufptr != PL_bufend)
+ PL_bufptr += 2;
+ PL_lex_state = LEX_INTERPCONCAT;
+ return yylex();
}
-
- retry:
- switch (*s) {
- default:
- if (UTF) {
- if (isIDFIRST_utf8_safe(s, PL_bufend)) {
- goto keylookup;
+ else {
+ DEBUG_T({
+ PerlIO_printf(Perl_debug_log, "### Saw case modifier\n");
+ });
+ s = PL_bufptr + 1;
+ if (s[1] == '\\' && s[2] == 'E') {
+ PL_bufptr = s + 3;
+ PL_lex_state = LEX_INTERPCONCAT;
+ return yylex();
+ }
+ else {
+ I32 tmp;
+ if ( memBEGINs(s, (STRLEN) (PL_bufend - s), "L\\u")
+ || memBEGINs(s, (STRLEN) (PL_bufend - s), "U\\l"))
+ {
+ tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
+ }
+ if ((*s == 'L' || *s == 'U' || *s == 'F')
+ && (strpbrk(PL_lex_casestack, "LUF")))
+ {
+ PL_lex_casestack[--PL_lex_casemods] = '\0';
+ PL_lex_allbrackets--;
+ return REPORT(')');
}
+ if (PL_lex_casemods > 10)
+ Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
+ PL_lex_casestack[PL_lex_casemods++] = *s;
+ PL_lex_casestack[PL_lex_casemods] = '\0';
+ PL_lex_state = LEX_INTERPCONCAT;
+ NEXTVAL_NEXTTOKE.ival = 0;
+ force_next((2<<24)|'(');
+ if (*s == 'l')
+ NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
+ else if (*s == 'u')
+ NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
+ else if (*s == 'L')
+ NEXTVAL_NEXTTOKE.ival = OP_LC;
+ else if (*s == 'U')
+ NEXTVAL_NEXTTOKE.ival = OP_UC;
+ else if (*s == 'Q')
+ NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
+ else if (*s == 'F')
+ NEXTVAL_NEXTTOKE.ival = OP_FC;
+ else
+ Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
+ PL_bufptr = s + 1;
}
- else if (isALNUMC(*s)) {
- goto keylookup;
- }
+ force_next(FUNC);
+ if (PL_lex_starts) {
+ s = PL_bufptr;
+ PL_lex_starts = 0;
+ /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
+ if (PL_lex_casemods == 1 && PL_lex_inpat)
+ TOKEN(',');
+ else
+ AopNOASSIGN(OP_CONCAT);
+ }
+ else
+ return yylex();
+ }
+}
+
+static int
+yyl_secondclass_keyword(pTHX_ char *s, STRLEN len, int key, I32 *orig_keyword,
+ GV **pgv, GV ***pgvp)
+{
+ GV *ogv = NULL; /* override (winner) */
+ GV *hgv = NULL; /* hidden (loser) */
+ GV *gv = *pgv;
+
+ if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
+ CV *cv;
+ if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
+ (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
+ SVt_PVCV))
+ && (cv = GvCVu(gv)))
+ {
+ if (GvIMPORTED_CV(gv))
+ ogv = gv;
+ else if (! CvMETHOD(cv))
+ hgv = gv;
+ }
+ if (!ogv
+ && (*pgvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf, len, FALSE))
+ && (gv = **pgvp)
+ && (isGV_with_GP(gv)
+ ? GvCVu(gv) && GvIMPORTED_CV(gv)
+ : SvPCS_IMPORTED(gv)
+ && (gv_init(gv, PL_globalstash, PL_tokenbuf,
+ len, 0), 1)))
+ {
+ ogv = gv;
+ }
+ }
+
+ *pgv = gv;
+
+ if (ogv) {
+ *orig_keyword = key;
+ return 0; /* overridden by import or by GLOBAL */
+ }
+ else if (gv && !*pgvp
+ && -key==KEY_lock /* XXX generalizable kludge */
+ && GvCVu(gv))
{
- SV *dsv = newSVpvs_flags("", SVs_TEMP);
- const char *c;
- if (UTF) {
- STRLEN skiplen = UTF8SKIP(s);
- STRLEN stravail = PL_bufend - s;
- c = sv_uni_display(dsv, newSVpvn_flags(s,
- skiplen > stravail ? stravail : skiplen,
- SVs_TEMP | SVf_UTF8),
- 10, UNI_DISPLAY_ISPRINT);
+ return 0; /* any sub overrides "weak" keyword */
+ }
+ else { /* no override */
+ key = -key;
+ if (key == KEY_dump) {
+ Perl_croak(aTHX_ "dump() must be written as CORE::dump() as of Perl 5.30");
}
- else {
- c = Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
+ *pgv = NULL;
+ *pgvp = 0;
+ if (hgv && key != KEY_x) /* never ambiguous */
+ Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
+ "Ambiguous call resolved as CORE::%s(), "
+ "qualify as such or use &",
+ GvENAME(hgv));
+ return key;
+ }
+}
+
+static int
+yyl_qw(pTHX_ char *s, STRLEN len)
+{
+ OP *words = NULL;
+
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
+ if (!s)
+ missingterm(NULL, 0);
+
+ COPLINE_SET_FROM_MULTI_END;
+ PL_expect = XOPERATOR;
+ if (SvCUR(PL_lex_stuff)) {
+ int warned_comma = !ckWARN(WARN_QW);
+ int warned_comment = warned_comma;
+ char *d = SvPV_force(PL_lex_stuff, len);
+ while (len) {
+ for (; isSPACE(*d) && len; --len, ++d)
+ /**/;
+ if (len) {
+ SV *sv;
+ const char *b = d;
+ if (!warned_comma || !warned_comment) {
+ for (; !isSPACE(*d) && len; --len, ++d) {
+ if (!warned_comma && *d == ',') {
+ Perl_warner(aTHX_ packWARN(WARN_QW),
+ "Possible attempt to separate words with commas");
+ ++warned_comma;
+ }
+ else if (!warned_comment && *d == '#') {
+ Perl_warner(aTHX_ packWARN(WARN_QW),
+ "Possible attempt to put comments in qw() list");
+ ++warned_comment;
+ }
+ }
+ }
+ else {
+ for (; !isSPACE(*d) && len; --len, ++d)
+ /**/;
+ }
+ sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
+ words = op_append_elem(OP_LIST, words,
+ newSVOP(OP_CONST, 0, tokeq(sv)));
+ }
}
+ }
+ if (!words)
+ words = newNULLLIST();
+ SvREFCNT_dec_NN(PL_lex_stuff);
+ PL_lex_stuff = NULL;
+ PL_expect = XOPERATOR;
+ pl_yylval.opval = sawparens(words);
+ TOKEN(QWLIST);
+}
+
+static int
+yyl_hyphen(pTHX_ char *s)
+{
+ if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
+ I32 ftst = 0;
+ char tmp;
+
+ s++;
+ PL_bufptr = s;
+ tmp = *s++;
- if (s >= PL_linestart) {
- d = PL_linestart;
+ while (s < PL_bufend && SPACE_OR_TAB(*s))
+ s++;
+
+ if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=>")) {
+ s = force_word(PL_bufptr,BAREWORD,FALSE,FALSE);
+ DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
+ OPERATOR('-'); /* unary minus */
+ }
+ switch (tmp) {
+ case 'r': ftst = OP_FTEREAD; break;
+ case 'w': ftst = OP_FTEWRITE; break;
+ case 'x': ftst = OP_FTEEXEC; break;
+ case 'o': ftst = OP_FTEOWNED; break;
+ case 'R': ftst = OP_FTRREAD; break;
+ case 'W': ftst = OP_FTRWRITE; break;
+ case 'X': ftst = OP_FTREXEC; break;
+ case 'O': ftst = OP_FTROWNED; break;
+ case 'e': ftst = OP_FTIS; break;
+ case 'z': ftst = OP_FTZERO; break;
+ case 's': ftst = OP_FTSIZE; break;
+ case 'f': ftst = OP_FTFILE; break;
+ case 'd': ftst = OP_FTDIR; break;
+ case 'l': ftst = OP_FTLINK; break;
+ case 'p': ftst = OP_FTPIPE; break;
+ case 'S': ftst = OP_FTSOCK; break;
+ case 'u': ftst = OP_FTSUID; break;
+ case 'g': ftst = OP_FTSGID; break;
+ case 'k': ftst = OP_FTSVTX; break;
+ case 'b': ftst = OP_FTBLK; break;
+ case 'c': ftst = OP_FTCHR; break;
+ case 't': ftst = OP_FTTTY; break;
+ case 'T': ftst = OP_FTTEXT; break;
+ case 'B': ftst = OP_FTBINARY; break;
+ case 'M': case 'A': case 'C':
+ gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
+ switch (tmp) {
+ case 'M': ftst = OP_FTMTIME; break;
+ case 'A': ftst = OP_FTATIME; break;
+ case 'C': ftst = OP_FTCTIME; break;
+ default: break;
+ }
+ break;
+ default:
+ break;
+ }
+ if (ftst) {
+ PL_last_uni = PL_oldbufptr;
+ PL_last_lop_op = (OPCODE)ftst;
+ DEBUG_T( {
+ PerlIO_printf(Perl_debug_log, "### Saw file test %c\n", (int)tmp);
+ } );
+ FTST(ftst);
}
else {
- /* somehow (probably due to a parse failure), PL_linestart has advanced
- * pass PL_bufptr, get a reasonable beginning of line
- */
- d = s;
- while (d > SvPVX(PL_linestr) && d[-1] && d[-1] != '\n')
- --d;
+ /* Assume it was a minus followed by a one-letter named
+ * subroutine call (or a -bareword), then. */
+ DEBUG_T( {
+ PerlIO_printf(Perl_debug_log,
+ "### '-%c' looked like a file test but was not\n",
+ (int) tmp);
+ } );
+ s = --PL_bufptr;
+ }
+ }
+ {
+ const char tmp = *s++;
+ if (*s == tmp) {
+ s++;
+ if (PL_expect == XOPERATOR)
+ TERM(POSTDEC);
+ else
+ OPERATOR(PREDEC);
+ }
+ else if (*s == '>') {
+ s++;
+ s = skipspace(s);
+ if (((*s == '$' || *s == '&') && s[1] == '*')
+ ||(*s == '$' && s[1] == '#' && s[2] == '*')
+ ||((*s == '@' || *s == '%') && memCHRs("*[{", s[1]))
+ ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
+ )
+ {
+ PL_expect = XPOSTDEREF;
+ TOKEN(ARROW);
+ }
+ if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
+ s = force_word(s,METHOD,FALSE,TRUE);
+ TOKEN(ARROW);
+ }
+ else if (*s == '$')
+ OPERATOR(ARROW);
+ else
+ TERM(ARROW);
+ }
+ if (PL_expect == XOPERATOR) {
+ if (*s == '='
+ && !PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
+ {
+ s--;
+ TOKEN(0);
+ }
+ Aop(OP_SUBTRACT);
}
- len = UTF ? Perl_utf8_length(aTHX_ (U8 *) d, (U8 *) s) : (STRLEN) (s - d);
- if (len > UNRECOGNIZED_PRECEDE_COUNT) {
- d = UTF ? (char *) utf8_hop_back((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT, (U8 *)d) : s - UNRECOGNIZED_PRECEDE_COUNT;
+ else {
+ if (isSPACE(*s) || !isSPACE(*PL_bufptr))
+ check_uni();
+ OPERATOR('-'); /* unary minus */
}
+ }
+}
- Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %" UTF8f "<-- HERE near column %d", c,
- UTF8fARG(UTF, (s - d), d),
- (int) len + 1);
+static int
+yyl_plus(pTHX_ char *s)
+{
+ const char tmp = *s++;
+ if (*s == tmp) {
+ s++;
+ if (PL_expect == XOPERATOR)
+ TERM(POSTINC);
+ else
+ OPERATOR(PREINC);
}
- case 4:
- case 26:
- goto fake_eof; /* emulate EOF on ^D or ^Z */
- case 0:
- if ((!PL_rsfp || PL_lex_inwhat)
- && (!PL_parser->filtered || s+1 < PL_bufend)) {
- PL_last_uni = 0;
- PL_last_lop = 0;
- if (PL_lex_brackets
- && PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF)
- {
- yyerror((const char *)
- (PL_lex_formbrack
- ? "Format not terminated"
- : "Missing right curly or square bracket"));
- }
- DEBUG_T( { PerlIO_printf(Perl_debug_log,
- "### Tokener got EOF\n");
- } );
- TOKEN(0);
- }
- if (s++ < PL_bufend)
- goto retry; /* ignore stray nulls */
- PL_last_uni = 0;
- PL_last_lop = 0;
- if (!PL_in_eval && !PL_preambled) {
- PL_preambled = TRUE;
- if (PL_perldb) {
- /* Generate a string of Perl code to load the debugger.
- * If PERL5DB is set, it will return the contents of that,
- * otherwise a compile-time require of perl5db.pl. */
+ if (PL_expect == XOPERATOR) {
+ if (*s == '='
+ && !PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
+ {
+ s--;
+ TOKEN(0);
+ }
+ Aop(OP_ADD);
+ }
+ else {
+ if (isSPACE(*s) || !isSPACE(*PL_bufptr))
+ check_uni();
+ OPERATOR('+');
+ }
+}
- const char * const pdb = PerlEnv_getenv("PERL5DB");
+static int
+yyl_star(pTHX_ char *s)
+{
+ if (PL_expect == XPOSTDEREF)
+ POSTDEREF('*');
- if (pdb) {
- sv_setpv(PL_linestr, pdb);
- sv_catpvs(PL_linestr,";");
- } else {
- SETERRNO(0,SS_NORMAL);
- sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
- }
- PL_parser->preambling = CopLINE(PL_curcop);
- } else
- SvPVCLEAR(PL_linestr);
- if (PL_preambleav) {
- SV **svp = AvARRAY(PL_preambleav);
- SV **const end = svp + AvFILLp(PL_preambleav);
- while(svp <= end) {
- sv_catsv(PL_linestr, *svp);
- ++svp;
- sv_catpvs(PL_linestr, ";");
- }
- sv_free(MUTABLE_SV(PL_preambleav));
- PL_preambleav = NULL;
- }
- if (PL_minus_E)
- sv_catpvs(PL_linestr,
- "use feature ':5." STRINGIFY(PERL_VERSION) "';");
- if (PL_minus_n || PL_minus_p) {
- sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
- if (PL_minus_l)
- sv_catpvs(PL_linestr,"chomp;");
- if (PL_minus_a) {
- if (PL_minus_F) {
- if ( ( *PL_splitstr == '/'
- || *PL_splitstr == '\''
- || *PL_splitstr == '"')
- && strchr(PL_splitstr + 1, *PL_splitstr))
- {
- /* strchr is ok, because -F pattern can't contain
- * embeddded NULs */
- Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
- }
- else {
- /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
- bytes can be used as quoting characters. :-) */
- const char *splits = PL_splitstr;
- sv_catpvs(PL_linestr, "our @F=split(q\0");
- do {
- /* Need to \ \s */
- if (*splits == '\\')
- sv_catpvn(PL_linestr, splits, 1);
- sv_catpvn(PL_linestr, splits, 1);
- } while (*splits++);
- /* This loop will embed the trailing NUL of
- PL_linestr as the last thing it does before
- terminating. */
- sv_catpvs(PL_linestr, ");");
- }
- }
- else
- sv_catpvs(PL_linestr,"our @F=split(' ');");
- }
- }
- sv_catpvs(PL_linestr, "\n");
- PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = NULL;
- if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
- update_debugger_info(PL_linestr, NULL, 0);
- goto retry;
- }
- do {
- fake_eof = 0;
- bof = cBOOL(PL_rsfp);
- if (0) {
- fake_eof:
- fake_eof = LEX_FAKE_EOF;
- }
- PL_bufptr = PL_bufend;
- COPLINE_INC_WITH_HERELINES;
- if (!lex_next_chunk(fake_eof)) {
- CopLINE_dec(PL_curcop);
- s = PL_bufptr;
- TOKEN(';'); /* not infinite loop because rsfp is NULL now */
- }
- CopLINE_dec(PL_curcop);
- s = PL_bufptr;
- /* If it looks like the start of a BOM or raw UTF-16,
- * check if it in fact is. */
- if (bof && PL_rsfp
- && ( *s == 0
- || *(U8*)s == BOM_UTF8_FIRST_BYTE
- || *(U8*)s >= 0xFE
- || s[1] == 0))
- {
- Off_t offset = (IV)PerlIO_tell(PL_rsfp);
- bof = (offset == (Off_t)SvCUR(PL_linestr));
-#if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
- /* offset may include swallowed CR */
- if (!bof)
- bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
-#endif
- if (bof) {
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- s = swallow_bom((U8*)s);
- }
- }
- if (PL_parser->in_pod) {
- /* Incest with pod. */
- if ( memBEGINPs(s, (STRLEN) (PL_bufend - s), "=cut")
- && !isALPHA(s[4]))
- {
- SvPVCLEAR(PL_linestr);
- PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = NULL;
- PL_parser->in_pod = 0;
- }
- }
- if (PL_rsfp || PL_parser->filtered)
- incline(s, PL_bufend);
- } while (PL_parser->in_pod);
- PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = NULL;
- if (CopLINE(PL_curcop) == 1) {
- while (s < PL_bufend && isSPACE(*s))
- s++;
- if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
- s++;
- d = NULL;
- if (!PL_in_eval) {
- if (*s == '#' && *(s+1) == '!')
- d = s + 2;
-#ifdef ALTERNATE_SHEBANG
- else {
- static char const as[] = ALTERNATE_SHEBANG;
- if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
- d = s + (sizeof(as) - 1);
- }
-#endif /* ALTERNATE_SHEBANG */
- }
- if (d) {
- char *ipath;
- char *ipathend;
+ if (PL_expect != XOPERATOR) {
+ s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
+ PL_expect = XOPERATOR;
+ force_ident(PL_tokenbuf, '*');
+ if (!*PL_tokenbuf)
+ PREREF('*');
+ TERM('*');
+ }
- while (isSPACE(*d))
- d++;
- ipath = d;
- while (*d && !isSPACE(*d))
- d++;
- ipathend = d;
+ s++;
+ if (*s == '*') {
+ s++;
+ if (*s == '=' && !PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
+ {
+ s -= 2;
+ TOKEN(0);
+ }
+ PWop(OP_POW);
+ }
-#ifdef ARG_ZERO_IS_SCRIPT
- if (ipathend > ipath) {
- /*
- * HP-UX (at least) sets argv[0] to the script name,
- * which makes $^X incorrect. And Digital UNIX and Linux,
- * at least, set argv[0] to the basename of the Perl
- * interpreter. So, having found "#!", we'll set it right.
- */
- SV* copfilesv = CopFILESV(PL_curcop);
- if (copfilesv) {
- SV * const x =
- GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
- SVt_PV)); /* $^X */
- assert(SvPOK(x) || SvGMAGICAL(x));
- if (sv_eq(x, copfilesv)) {
- sv_setpvn(x, ipath, ipathend - ipath);
- SvSETMAGIC(x);
- }
- else {
- STRLEN blen;
- STRLEN llen;
- const char *bstart = SvPV_const(copfilesv, blen);
- const char * const lstart = SvPV_const(x, llen);
- if (llen < blen) {
- bstart += blen - llen;
- if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
- sv_setpvn(x, ipath, ipathend - ipath);
- SvSETMAGIC(x);
- }
- }
- }
- }
- else {
- /* Anything to do if no copfilesv? */
- }
- TAINT_NOT; /* $^X is always tainted, but that's OK */
- }
-#endif /* ARG_ZERO_IS_SCRIPT */
+ if (*s == '='
+ && !PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
+ {
+ s--;
+ TOKEN(0);
+ }
- /*
- * Look for options.
- */
- d = instr(s,"perl -");
- if (!d) {
- d = instr(s,"perl");
-#if defined(DOSISH)
- /* avoid getting into infinite loops when shebang
- * line contains "Perl" rather than "perl" */
- if (!d) {
- for (d = ipathend-4; d >= ipath; --d) {
- if (isALPHA_FOLD_EQ(*d, 'p')
- && !ibcmp(d, "perl", 4))
- {
- break;
- }
- }
- if (d < ipath)
- d = NULL;
- }
-#endif
- }
-#ifdef ALTERNATE_SHEBANG
- /*
- * If the ALTERNATE_SHEBANG on this system starts with a
- * character that can be part of a Perl expression, then if
- * we see it but not "perl", we're probably looking at the
- * start of Perl code, not a request to hand off to some
- * other interpreter. Similarly, if "perl" is there, but
- * not in the first 'word' of the line, we assume the line
- * contains the start of the Perl program.
- */
- if (d && *s != '#') {
- const char *c = ipath;
- while (*c && !strchr("; \t\r\n\f\v#", *c))
- c++;
- if (c < d)
- d = NULL; /* "perl" not in first word; ignore */
- else
- *s = '#'; /* Don't try to parse shebang line */
- }
-#endif /* ALTERNATE_SHEBANG */
- if (!d
- && *s == '#'
- && ipathend > ipath
- && !PL_minus_c
- && !instr(s,"indir")
- && instr(PL_origargv[0],"perl"))
- {
- dVAR;
- char **newargv;
+ Mop(OP_MULTIPLY);
+}
- *ipathend = '\0';
- s = ipathend + 1;
- while (s < PL_bufend && isSPACE(*s))
- s++;
- if (s < PL_bufend) {
- Newx(newargv,PL_origargc+3,char*);
- newargv[1] = s;
- while (s < PL_bufend && !isSPACE(*s))
- s++;
- *s = '\0';
- Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
- }
- else
- newargv = PL_origargv;
- newargv[0] = ipath;
- PERL_FPU_PRE_EXEC
- PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
- PERL_FPU_POST_EXEC
- Perl_croak(aTHX_ "Can't exec %s", ipath);
- }
- if (d) {
- while (*d && !isSPACE(*d))
- d++;
- while (SPACE_OR_TAB(*d))
- d++;
-
- if (*d++ == '-') {
- const bool switches_done = PL_doswitches;
- const U32 oldpdb = PL_perldb;
- const bool oldn = PL_minus_n;
- const bool oldp = PL_minus_p;
- const char *d1 = d;
-
- do {
- bool baduni = FALSE;
- if (*d1 == 'C') {
- const char *d2 = d1 + 1;
- if (parse_unicode_opts((const char **)&d2)
- != PL_unicode)
- baduni = TRUE;
- }
- if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
- const char * const m = d1;
- while (*d1 && !isSPACE(*d1))
- d1++;
- Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
- (int)(d1 - m), m);
- }
- d1 = moreswitches(d1);
- } while (d1);
- if (PL_doswitches && !switches_done) {
- int argc = PL_origargc;
- char **argv = PL_origargv;
- do {
- argc--,argv++;
- } while (argc && argv[0][0] == '-' && argv[0][1]);
- init_argv_symbols(argc,argv);
- }
- if ( (PERLDB_LINE_OR_SAVESRC && !oldpdb)
- || ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
- /* if we have already added "LINE: while (<>) {",
- we must not do it again */
- {
- SvPVCLEAR(PL_linestr);
- PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = NULL;
- PL_preambled = FALSE;
- if (PERLDB_LINE_OR_SAVESRC)
- (void)gv_fetchfile(PL_origfilename);
- goto retry;
- }
- }
- }
- }
- }
- if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
- PL_lex_state = LEX_FORMLINE;
- force_next(FORMRBRACK);
- TOKEN(';');
- }
- goto retry;
- case '\r':
-#ifdef PERL_STRICT_CR
- Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
- Perl_croak(aTHX_
- "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
-#endif
- case ' ': case '\t': case '\f': case '\v':
- s++;
- goto retry;
- case '#':
- case '\n':
- if (PL_lex_state != LEX_NORMAL
- || (PL_in_eval && !PL_rsfp && !PL_parser->filtered))
+static int
+yyl_percent(pTHX_ char *s)
+{
+ if (PL_expect == XOPERATOR) {
+ if (s[1] == '='
+ && !PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
{
- const bool in_comment = *s == '#';
- if (*s == '#' && s == PL_linestart && PL_in_eval
- && !PL_rsfp && !PL_parser->filtered) {
- /* handle eval qq[#line 1 "foo"\n ...] */
- CopLINE_dec(PL_curcop);
- incline(s, PL_bufend);
- }
- d = s;
- while (d < PL_bufend && *d != '\n')
- d++;
- if (d < PL_bufend)
- d++;
- s = d;
- if (in_comment && d == PL_bufend
- && PL_lex_state == LEX_INTERPNORMAL
- && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
- && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
- else
- incline(s, PL_bufend);
- if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
- PL_lex_state = LEX_FORMLINE;
- force_next(FORMRBRACK);
- TOKEN(';');
- }
- }
- else {
- while (s < PL_bufend && *s != '\n')
- s++;
- if (s < PL_bufend)
- {
- s++;
- if (s < PL_bufend)
- incline(s, PL_bufend);
+ TOKEN(0);
+ }
+ ++s;
+ Mop(OP_MODULO);
+ }
+ else if (PL_expect == XPOSTDEREF)
+ POSTDEREF('%');
+
+ PL_tokenbuf[0] = '%';
+ s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
+ pl_yylval.ival = 0;
+ if (!PL_tokenbuf[1]) {
+ PREREF('%');
+ }
+ if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
+ && intuit_more(s, PL_bufend)) {
+ if (*s == '[')
+ PL_tokenbuf[0] = '@';
+ }
+ PL_expect = XOPERATOR;
+ force_ident_maybe_lex('%');
+ TERM('%');
+}
+
+static int
+yyl_caret(pTHX_ char *s)
+{
+ char *d = s;
+ const bool bof = cBOOL(FEATURE_BITWISE_IS_ENABLED);
+ if (bof && s[1] == '.')
+ s++;
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
+ {
+ s = d;
+ TOKEN(0);
+ }
+ s++;
+ BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
+}
+
+static int
+yyl_colon(pTHX_ char *s)
+{
+ OP *attrs;
+
+ switch (PL_expect) {
+ case XOPERATOR:
+ if (!PL_in_my || (PL_lex_state != LEX_NORMAL && !PL_lex_brackets))
+ break;
+ PL_bufptr = s; /* update in case we back off */
+ if (*s == '=') {
+ Perl_croak(aTHX_
+ "Use of := for an empty attribute list is not allowed");
+ }
+ goto grabattrs;
+ case XATTRBLOCK:
+ PL_expect = XBLOCK;
+ goto grabattrs;
+ case XATTRTERM:
+ PL_expect = XTERMBLOCK;
+ grabattrs:
+ /* NB: as well as parsing normal attributes, we also end up
+ * here if there is something looking like attributes
+ * following a signature (which is illegal, but used to be
+ * legal in 5.20..5.26). If the latter, we still parse the
+ * attributes so that error messages(s) are less confusing,
+ * but ignore them (parser->sig_seen).
+ */
+ s = skipspace(s);
+ attrs = NULL;
+ while (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
+ bool sig = PL_parser->sig_seen;
+ I32 tmp;
+ SV *sv;
+ STRLEN len;
+ char *d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
+ if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
+ if (tmp < 0) tmp = -tmp;
+ switch (tmp) {
+ case KEY_or:
+ case KEY_and:
+ case KEY_for:
+ case KEY_foreach:
+ case KEY_unless:
+ case KEY_if:
+ case KEY_while:
+ case KEY_until:
+ goto got_attrs;
+ default:
+ break;
}
- }
- goto retry;
- case '-':
- if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
- I32 ftst = 0;
- char tmp;
+ }
+ sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
+ if (*d == '(') {
+ d = scan_str(d,TRUE,TRUE,FALSE,NULL);
+ if (!d) {
+ if (attrs)
+ op_free(attrs);
+ sv_free(sv);
+ Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
+ }
+ COPLINE_SET_FROM_MULTI_END;
+ }
+ if (PL_lex_stuff) {
+ sv_catsv(sv, PL_lex_stuff);
+ attrs = op_append_elem(OP_LIST, attrs,
+ newSVOP(OP_CONST, 0, sv));
+ SvREFCNT_dec_NN(PL_lex_stuff);
+ PL_lex_stuff = NULL;
+ }
+ else {
+ /* NOTE: any CV attrs applied here need to be part of
+ the CVf_BUILTIN_ATTRS define in cv.h! */
+ if (!PL_in_my && memEQs(SvPVX(sv), len, "lvalue")) {
+ sv_free(sv);
+ if (!sig)
+ CvLVALUE_on(PL_compcv);
+ }
+ else if (!PL_in_my && memEQs(SvPVX(sv), len, "method")) {
+ sv_free(sv);
+ if (!sig)
+ CvMETHOD_on(PL_compcv);
+ }
+ else if (!PL_in_my && memEQs(SvPVX(sv), len, "const")) {
+ sv_free(sv);
+ if (!sig) {
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
+ ":const is experimental"
+ );
+ CvANONCONST_on(PL_compcv);
+ if (!CvANON(PL_compcv))
+ yyerror(":const is not permitted on named "
+ "subroutines");
+ }
+ }
+ /* After we've set the flags, it could be argued that
+ we don't need to do the attributes.pm-based setting
+ process, and shouldn't bother appending recognized
+ flags. To experiment with that, uncomment the
+ following "else". (Note that's already been
+ uncommented. That keeps the above-applied built-in
+ attributes from being intercepted (and possibly
+ rejected) by a package's attribute routines, but is
+ justified by the performance win for the common case
+ of applying only built-in attributes.) */
+ else
+ attrs = op_append_elem(OP_LIST, attrs,
+ newSVOP(OP_CONST, 0,
+ sv));
+ }
+ s = skipspace(d);
+ if (*s == ':' && s[1] != ':')
+ s = skipspace(s+1);
+ else if (s == d)
+ break; /* require real whitespace or :'s */
+ /* XXX losing whitespace on sequential attributes here */
+ }
- s++;
- PL_bufptr = s;
- tmp = *s++;
+ if (*s != ';'
+ && *s != '}'
+ && !(PL_expect == XOPERATOR
+ ? (*s == '=' || *s == ')')
+ : (*s == '{' || *s == '(')))
+ {
+ const char q = ((*s == '\'') ? '"' : '\'');
+ /* If here for an expression, and parsed no attrs, back off. */
+ if (PL_expect == XOPERATOR && !attrs) {
+ s = PL_bufptr;
+ break;
+ }
+ /* MUST advance bufptr here to avoid bogus "at end of line"
+ context messages from yyerror().
+ */
+ PL_bufptr = s;
+ yyerror( (const char *)
+ (*s
+ ? Perl_form(aTHX_ "Invalid separator character "
+ "%c%c%c in attribute list", q, *s, q)
+ : "Unterminated attribute list" ) );
+ if (attrs)
+ op_free(attrs);
+ OPERATOR(':');
+ }
- while (s < PL_bufend && SPACE_OR_TAB(*s))
- s++;
+ got_attrs:
+ if (PL_parser->sig_seen) {
+ /* see comment about about sig_seen and parser error
+ * handling */
+ if (attrs)
+ op_free(attrs);
+ Perl_croak(aTHX_ "Subroutine attributes must come "
+ "before the signature");
+ }
+ if (attrs) {
+ NEXTVAL_NEXTTOKE.opval = attrs;
+ force_next(THING);
+ }
+ TOKEN(COLONATTR);
+ }
- if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=>")) {
- s = force_word(PL_bufptr,BAREWORD,FALSE,FALSE);
- DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
- OPERATOR('-'); /* unary minus */
- }
- switch (tmp) {
- case 'r': ftst = OP_FTEREAD; break;
- case 'w': ftst = OP_FTEWRITE; break;
- case 'x': ftst = OP_FTEEXEC; break;
- case 'o': ftst = OP_FTEOWNED; break;
- case 'R': ftst = OP_FTRREAD; break;
- case 'W': ftst = OP_FTRWRITE; break;
- case 'X': ftst = OP_FTREXEC; break;
- case 'O': ftst = OP_FTROWNED; break;
- case 'e': ftst = OP_FTIS; break;
- case 'z': ftst = OP_FTZERO; break;
- case 's': ftst = OP_FTSIZE; break;
- case 'f': ftst = OP_FTFILE; break;
- case 'd': ftst = OP_FTDIR; break;
- case 'l': ftst = OP_FTLINK; break;
- case 'p': ftst = OP_FTPIPE; break;
- case 'S': ftst = OP_FTSOCK; break;
- case 'u': ftst = OP_FTSUID; break;
- case 'g': ftst = OP_FTSGID; break;
- case 'k': ftst = OP_FTSVTX; break;
- case 'b': ftst = OP_FTBLK; break;
- case 'c': ftst = OP_FTCHR; break;
- case 't': ftst = OP_FTTTY; break;
- case 'T': ftst = OP_FTTEXT; break;
- case 'B': ftst = OP_FTBINARY; break;
- case 'M': case 'A': case 'C':
- gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
- switch (tmp) {
- case 'M': ftst = OP_FTMTIME; break;
- case 'A': ftst = OP_FTATIME; break;
- case 'C': ftst = OP_FTCTIME; break;
- default: break;
- }
- break;
- default:
- break;
- }
- if (ftst) {
- PL_last_uni = PL_oldbufptr;
- PL_last_lop_op = (OPCODE)ftst;
- DEBUG_T( { PerlIO_printf(Perl_debug_log,
- "### Saw file test %c\n", (int)tmp);
- } );
- FTST(ftst);
- }
- else {
- /* Assume it was a minus followed by a one-letter named
- * subroutine call (or a -bareword), then. */
- DEBUG_T( { PerlIO_printf(Perl_debug_log,
- "### '-%c' looked like a file test but was not\n",
- (int) tmp);
- } );
- s = --PL_bufptr;
- }
- }
- {
- const char tmp = *s++;
- if (*s == tmp) {
- s++;
- if (PL_expect == XOPERATOR)
- TERM(POSTDEC);
- else
- OPERATOR(PREDEC);
- }
- else if (*s == '>') {
- s++;
- s = skipspace(s);
- if (((*s == '$' || *s == '&') && s[1] == '*')
- ||(*s == '$' && s[1] == '#' && s[2] == '*')
- ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
- ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
- )
- {
- PL_expect = XPOSTDEREF;
- TOKEN(ARROW);
- }
- if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
- s = force_word(s,METHOD,FALSE,TRUE);
- TOKEN(ARROW);
- }
- else if (*s == '$')
- OPERATOR(ARROW);
- else
- TERM(ARROW);
- }
- if (PL_expect == XOPERATOR) {
- if (*s == '='
- && !PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
- {
- s--;
- TOKEN(0);
- }
- Aop(OP_SUBTRACT);
- }
- else {
- if (isSPACE(*s) || !isSPACE(*PL_bufptr))
- check_uni();
- OPERATOR('-'); /* unary minus */
- }
- }
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
+ s--;
+ TOKEN(0);
+ }
- case '+':
- {
- const char tmp = *s++;
- if (*s == tmp) {
- s++;
- if (PL_expect == XOPERATOR)
- TERM(POSTINC);
- else
- OPERATOR(PREINC);
- }
- if (PL_expect == XOPERATOR) {
- if (*s == '='
- && !PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
- {
- s--;
- TOKEN(0);
- }
- Aop(OP_ADD);
- }
- else {
- if (isSPACE(*s) || !isSPACE(*PL_bufptr))
- check_uni();
- OPERATOR('+');
- }
- }
+ PL_lex_allbrackets--;
+ OPERATOR(':');
+}
- case '*':
- if (PL_expect == XPOSTDEREF) POSTDEREF('*');
- if (PL_expect != XOPERATOR) {
- s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
- PL_expect = XOPERATOR;
- force_ident(PL_tokenbuf, '*');
- if (!*PL_tokenbuf)
- PREREF('*');
- TERM('*');
- }
- s++;
- if (*s == '*') {
- s++;
- if (*s == '=' && !PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
- {
- s -= 2;
- TOKEN(0);
- }
- PWop(OP_POW);
- }
- if (*s == '='
- && !PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
- {
- s--;
- TOKEN(0);
- }
- PL_parser->saw_infix_sigil = 1;
- Mop(OP_MULTIPLY);
+static int
+yyl_subproto(pTHX_ char *s, CV *cv)
+{
+ STRLEN protolen = CvPROTOLEN(cv);
+ const char *proto = CvPROTO(cv);
+ bool optional;
- case '%':
- {
- if (PL_expect == XOPERATOR) {
- if (s[1] == '='
- && !PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
- {
- TOKEN(0);
- }
- ++s;
- PL_parser->saw_infix_sigil = 1;
- Mop(OP_MODULO);
- }
- else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
- PL_tokenbuf[0] = '%';
- s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
- pl_yylval.ival = 0;
- if (!PL_tokenbuf[1]) {
- PREREF('%');
- }
- if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
- && intuit_more(s, PL_bufend)) {
- if (*s == '[')
- PL_tokenbuf[0] = '@';
- }
- PL_expect = XOPERATOR;
- force_ident_maybe_lex('%');
- TERM('%');
+ proto = S_strip_spaces(aTHX_ proto, &protolen);
+ if (!protolen)
+ TERM(FUNC0SUB);
+ if ((optional = *proto == ';')) {
+ do {
+ proto++;
+ } while (*proto == ';');
}
- case '^':
- d = s;
- bof = FEATURE_BITWISE_IS_ENABLED;
- if (bof && s[1] == '.')
- s++;
- if (!PL_lex_allbrackets && PL_lex_fakeeof >=
- (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
- {
- s = d;
- TOKEN(0);
- }
- s++;
- BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
- case '[':
- if (PL_lex_brackets > 100)
- Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
- PL_lex_brackstack[PL_lex_brackets++] = 0;
- PL_lex_allbrackets++;
- {
- const char tmp = *s++;
- OPERATOR(tmp);
- }
- case '~':
- if (s[1] == '~'
- && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
- {
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- TOKEN(0);
- s += 2;
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
- "Smartmatch is experimental");
- Eop(OP_SMARTMATCH);
- }
- s++;
- if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
- s++;
- BCop(OP_SCOMPLEMENT);
- }
- BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
- case ',':
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
- TOKEN(0);
- s++;
- OPERATOR(',');
- case ':':
- if (s[1] == ':') {
- len = 0;
- goto just_a_word_zero_gv;
- }
- s++;
+
+ if (
+ (
+ (
+ *proto == '$' || *proto == '_'
+ || *proto == '*' || *proto == '+'
+ )
+ && proto[1] == '\0'
+ )
+ || (
+ *proto == '\\' && proto[1] && proto[2] == '\0'
+ )
+ ) {
+ UNIPROTO(UNIOPSUB,optional);
+ }
+
+ if (*proto == '\\' && proto[1] == '[') {
+ const char *p = proto + 2;
+ while(*p && *p != ']')
+ ++p;
+ if(*p == ']' && !p[1])
+ UNIPROTO(UNIOPSUB,optional);
+ }
+
+ if (*proto == '&' && *s == '{') {
+ if (PL_curstash)
+ sv_setpvs(PL_subname, "__ANON__");
+ else
+ sv_setpvs(PL_subname, "__ANON__::__ANON__");
+ if (!PL_lex_allbrackets
+ && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
{
- OP *attrs;
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
+ }
+ PREBLOCK(LSTOPSUB);
+ }
- switch (PL_expect) {
- case XOPERATOR:
- if (!PL_in_my || PL_lex_state != LEX_NORMAL)
- break;
- PL_bufptr = s; /* update in case we back off */
- if (*s == '=') {
- Perl_croak(aTHX_
- "Use of := for an empty attribute list is not allowed");
- }
- goto grabattrs;
- case XATTRBLOCK:
- PL_expect = XBLOCK;
- goto grabattrs;
- case XATTRTERM:
- PL_expect = XTERMBLOCK;
- grabattrs:
- /* NB: as well as parsing normal attributes, we also end up
- * here if there is something looking like attributes
- * following a signature (which is illegal, but used to be
- * legal in 5.20..5.26). If the latter, we still parse the
- * attributes so that error messages(s) are less confusing,
- * but ignore them (parser->sig_seen).
+ return KEY_NULL;
+}
+
+static int
+yyl_leftcurly(pTHX_ char *s, const U8 formbrack)
+{
+ char *d;
+ if (PL_lex_brackets > 100) {
+ Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
+ }
+
+ switch (PL_expect) {
+ case XTERM:
+ case XTERMORDORDOR:
+ PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
+ PL_lex_allbrackets++;
+ OPERATOR(HASHBRACK);
+ case XOPERATOR:
+ while (s < PL_bufend && SPACE_OR_TAB(*s))
+ s++;
+ d = s;
+ PL_tokenbuf[0] = '\0';
+ if (d < PL_bufend && *d == '-') {
+ PL_tokenbuf[0] = '-';
+ d++;
+ while (d < PL_bufend && SPACE_OR_TAB(*d))
+ d++;
+ }
+ if (d < PL_bufend && isIDFIRST_lazy_if_safe(d, PL_bufend, UTF)) {
+ STRLEN len;
+ d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
+ FALSE, &len);
+ while (d < PL_bufend && SPACE_OR_TAB(*d))
+ d++;
+ if (*d == '}') {
+ const char minus = (PL_tokenbuf[0] == '-');
+ s = force_word(s + minus, BAREWORD, FALSE, TRUE);
+ if (minus)
+ force_next('-');
+ }
+ }
+ /* FALLTHROUGH */
+ case XATTRTERM:
+ case XTERMBLOCK:
+ PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
+ PL_lex_allbrackets++;
+ PL_expect = XSTATE;
+ break;
+ case XATTRBLOCK:
+ case XBLOCK:
+ PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
+ PL_lex_allbrackets++;
+ PL_expect = XSTATE;
+ break;
+ case XBLOCKTERM:
+ PL_lex_brackstack[PL_lex_brackets++] = XTERM;
+ PL_lex_allbrackets++;
+ PL_expect = XSTATE;
+ break;
+ default: {
+ const char *t;
+ if (PL_oldoldbufptr == PL_last_lop)
+ PL_lex_brackstack[PL_lex_brackets++] = XTERM;
+ else
+ PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
+ PL_lex_allbrackets++;
+ s = skipspace(s);
+ if (*s == '}') {
+ if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
+ PL_expect = XTERM;
+ /* This hack is to get the ${} in the message. */
+ PL_bufptr = s+1;
+ yyerror("syntax error");
+ break;
+ }
+ OPERATOR(HASHBRACK);
+ }
+ if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
+ /* ${...} or @{...} etc., but not print {...}
+ * Skip the disambiguation and treat this as a block.
+ */
+ goto block_expectation;
+ }
+ /* This hack serves to disambiguate a pair of curlies
+ * as being a block or an anon hash. Normally, expectation
+ * determines that, but in cases where we're not in a
+ * position to expect anything in particular (like inside
+ * eval"") we have to resolve the ambiguity. This code
+ * covers the case where the first term in the curlies is a
+ * quoted string. Most other cases need to be explicitly
+ * disambiguated by prepending a "+" before the opening
+ * curly in order to force resolution as an anon hash.
+ *
+ * XXX should probably propagate the outer expectation
+ * into eval"" to rely less on this hack, but that could
+ * potentially break current behavior of eval"".
+ * GSAR 97-07-21
*/
- s = skipspace(s);
- attrs = NULL;
- while (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
- bool sig = PL_parser->sig_seen;
- I32 tmp;
- SV *sv;
- d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
- if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
- if (tmp < 0) tmp = -tmp;
- switch (tmp) {
- case KEY_or:
- case KEY_and:
- case KEY_for:
- case KEY_foreach:
- case KEY_unless:
- case KEY_if:
- case KEY_while:
- case KEY_until:
- goto got_attrs;
- default:
- break;
- }
- }
- sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
- if (*d == '(') {
- d = scan_str(d,TRUE,TRUE,FALSE,NULL);
- if (!d) {
- if (attrs)
- op_free(attrs);
- sv_free(sv);
- Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
- }
- COPLINE_SET_FROM_MULTI_END;
- }
- if (PL_lex_stuff) {
- sv_catsv(sv, PL_lex_stuff);
- attrs = op_append_elem(OP_LIST, attrs,
- newSVOP(OP_CONST, 0, sv));
- SvREFCNT_dec_NN(PL_lex_stuff);
- PL_lex_stuff = NULL;
- }
- else {
- /* NOTE: any CV attrs applied here need to be part of
- the CVf_BUILTIN_ATTRS define in cv.h! */
- if (!PL_in_my && memEQs(SvPVX(sv), len, "lvalue")) {
- sv_free(sv);
- if (!sig)
- CvLVALUE_on(PL_compcv);
- }
- else if (!PL_in_my && memEQs(SvPVX(sv), len, "method")) {
- sv_free(sv);
- if (!sig)
- CvMETHOD_on(PL_compcv);
- }
- else if (!PL_in_my && memEQs(SvPVX(sv), len, "const"))
- {
- sv_free(sv);
- if (!sig) {
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
- ":const is experimental"
- );
- CvANONCONST_on(PL_compcv);
- if (!CvANON(PL_compcv))
- yyerror(":const is not permitted on named "
- "subroutines");
- }
- }
- /* After we've set the flags, it could be argued that
- we don't need to do the attributes.pm-based setting
- process, and shouldn't bother appending recognized
- flags. To experiment with that, uncomment the
- following "else". (Note that's already been
- uncommented. That keeps the above-applied built-in
- attributes from being intercepted (and possibly
- rejected) by a package's attribute routines, but is
- justified by the performance win for the common case
- of applying only built-in attributes.) */
- else
- attrs = op_append_elem(OP_LIST, attrs,
- newSVOP(OP_CONST, 0,
- sv));
- }
- s = skipspace(d);
- if (*s == ':' && s[1] != ':')
- s = skipspace(s+1);
- else if (s == d)
- break; /* require real whitespace or :'s */
- /* XXX losing whitespace on sequential attributes here */
- }
- {
- if (*s != ';'
- && *s != '}'
- && !(PL_expect == XOPERATOR
- ? (*s == '=' || *s == ')')
- : (*s == '{' || *s == '(')))
+ t = s;
+ if (*s == '\'' || *s == '"' || *s == '`') {
+ /* common case: get past first string, handling escapes */
+ for (t++; t < PL_bufend && *t != *s;)
+ if (*t++ == '\\')
+ t++;
+ t++;
+ }
+ else if (*s == 'q') {
+ if (++t < PL_bufend
+ && (!isWORDCHAR(*t)
+ || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
+ && !isWORDCHAR(*t))))
{
- const char q = ((*s == '\'') ? '"' : '\'');
- /* If here for an expression, and parsed no attrs, back
- off. */
- if (PL_expect == XOPERATOR && !attrs) {
- s = PL_bufptr;
- break;
- }
- /* MUST advance bufptr here to avoid bogus "at end of line"
- context messages from yyerror().
- */
- PL_bufptr = s;
- yyerror( (const char *)
- (*s
- ? Perl_form(aTHX_ "Invalid separator character "
- "%c%c%c in attribute list", q, *s, q)
- : "Unterminated attribute list" ) );
- if (attrs)
- op_free(attrs);
- OPERATOR(':');
- }
- }
- got_attrs:
- if (PL_parser->sig_seen) {
- /* see comment about about sig_seen and parser error
- * handling */
- if (attrs)
- op_free(attrs);
- Perl_croak(aTHX_ "Subroutine attributes must come "
- "before the signature");
+ /* skip q//-like construct */
+ const char *tmps;
+ char open, close, term;
+ I32 brackets = 1;
+
+ while (t < PL_bufend && isSPACE(*t))
+ t++;
+ /* check for q => */
+ if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
+ OPERATOR(HASHBRACK);
+ }
+ term = *t;
+ open = term;
+ if (term && (tmps = memCHRs("([{< )]}> )]}>",term)))
+ term = tmps[5];
+ close = term;
+ if (open == close)
+ for (t++; t < PL_bufend; t++) {
+ if (*t == '\\' && t+1 < PL_bufend && open != '\\')
+ t++;
+ else if (*t == open)
+ break;
+ }
+ else {
+ for (t++; t < PL_bufend; t++) {
+ if (*t == '\\' && t+1 < PL_bufend)
+ t++;
+ else if (*t == close && --brackets <= 0)
+ break;
+ else if (*t == open)
+ brackets++;
+ }
+ }
+ t++;
}
- if (attrs) {
- NEXTVAL_NEXTTOKE.opval = attrs;
- force_next(THING);
- }
- TOKEN(COLONATTR);
- }
- }
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
- s--;
- TOKEN(0);
- }
- PL_lex_allbrackets--;
- OPERATOR(':');
- case '(':
- s++;
- if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
- PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
- else
- PL_expect = XTERM;
- s = skipspace(s);
- PL_lex_allbrackets++;
- TOKEN('(');
- case ';':
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
- TOKEN(0);
- CLINE;
- s++;
- PL_expect = XSTATE;
- TOKEN(';');
- case ')':
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
- TOKEN(0);
- s++;
- PL_lex_allbrackets--;
- s = skipspace(s);
- if (*s == '{')
- PREBLOCK(')');
- TERM(')');
- case ']':
- if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
- TOKEN(0);
- s++;
- if (PL_lex_brackets <= 0)
- /* diag_listed_as: Unmatched right %s bracket */
- yyerror("Unmatched right square bracket");
- else
- --PL_lex_brackets;
- PL_lex_allbrackets--;
- if (PL_lex_state == LEX_INTERPNORMAL) {
- if (PL_lex_brackets == 0) {
- if (*s == '-' && s[1] == '>')
- PL_lex_state = LEX_INTERPENDMAYBE;
- else if (*s != '[' && *s != '{')
- PL_lex_state = LEX_INTERPEND;
- }
- }
- TERM(']');
- case '{':
- s++;
- leftbracket:
- if (PL_lex_brackets > 100) {
- Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
- }
- switch (PL_expect) {
- case XTERM:
- case XTERMORDORDOR:
- PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
- PL_lex_allbrackets++;
- OPERATOR(HASHBRACK);
- case XOPERATOR:
- while (s < PL_bufend && SPACE_OR_TAB(*s))
- s++;
- d = s;
- PL_tokenbuf[0] = '\0';
- if (d < PL_bufend && *d == '-') {
- PL_tokenbuf[0] = '-';
- d++;
- while (d < PL_bufend && SPACE_OR_TAB(*d))
- d++;
- }
- if (d < PL_bufend && isIDFIRST_lazy_if_safe(d, PL_bufend, UTF)) {
- d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
- FALSE, &len);
- while (d < PL_bufend && SPACE_OR_TAB(*d))
- d++;
- if (*d == '}') {
- const char minus = (PL_tokenbuf[0] == '-');
- s = force_word(s + minus, BAREWORD, FALSE, TRUE);
- if (minus)
- force_next('-');
- }
- }
- /* FALLTHROUGH */
- case XATTRTERM:
- case XTERMBLOCK:
- PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
- PL_lex_allbrackets++;
- PL_expect = XSTATE;
- break;
- case XATTRBLOCK:
- case XBLOCK:
- PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
- PL_lex_allbrackets++;
- PL_expect = XSTATE;
- break;
- case XBLOCKTERM:
- PL_lex_brackstack[PL_lex_brackets++] = XTERM;
- PL_lex_allbrackets++;
- PL_expect = XSTATE;
- break;
- default: {
- const char *t;
- if (PL_oldoldbufptr == PL_last_lop)
- PL_lex_brackstack[PL_lex_brackets++] = XTERM;
- else
- PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
- PL_lex_allbrackets++;
- s = skipspace(s);
- if (*s == '}') {
- if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
- PL_expect = XTERM;
- /* This hack is to get the ${} in the message. */
- PL_bufptr = s+1;
- yyerror("syntax error");
- break;
- }
- OPERATOR(HASHBRACK);
- }
- if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
- /* ${...} or @{...} etc., but not print {...}
- * Skip the disambiguation and treat this as a block.
- */
- goto block_expectation;
- }
- /* This hack serves to disambiguate a pair of curlies
- * as being a block or an anon hash. Normally, expectation
- * determines that, but in cases where we're not in a
- * position to expect anything in particular (like inside
- * eval"") we have to resolve the ambiguity. This code
- * covers the case where the first term in the curlies is a
- * quoted string. Most other cases need to be explicitly
- * disambiguated by prepending a "+" before the opening
- * curly in order to force resolution as an anon hash.
- *
- * XXX should probably propagate the outer expectation
- * into eval"" to rely less on this hack, but that could
- * potentially break current behavior of eval"".
- * GSAR 97-07-21
- */
- t = s;
- if (*s == '\'' || *s == '"' || *s == '`') {
- /* common case: get past first string, handling escapes */
- for (t++; t < PL_bufend && *t != *s;)
- if (*t++ == '\\')
- t++;
- t++;
- }
- else if (*s == 'q') {
- if (++t < PL_bufend
- && (!isWORDCHAR(*t)
- || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
- && !isWORDCHAR(*t))))
- {
- /* skip q//-like construct */
- const char *tmps;
- char open, close, term;
- I32 brackets = 1;
-
- while (t < PL_bufend && isSPACE(*t))
- t++;
- /* check for q => */
- if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
- OPERATOR(HASHBRACK);
- }
- term = *t;
- open = term;
- if (term && (tmps = strchr("([{< )]}> )]}>",term)))
- term = tmps[5];
- close = term;
- if (open == close)
- for (t++; t < PL_bufend; t++) {
- if (*t == '\\' && t+1 < PL_bufend && open != '\\')
- t++;
- else if (*t == open)
- break;
- }
- else {
- for (t++; t < PL_bufend; t++) {
- if (*t == '\\' && t+1 < PL_bufend)
- t++;
- else if (*t == close && --brackets <= 0)
- break;
- else if (*t == open)
- brackets++;
- }
- }
- t++;
- }
- else
- /* skip plain q word */
- while ( t < PL_bufend
- && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
- {
- t += UTF ? UTF8SKIP(t) : 1;
- }
- }
- else if (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)) {
- t += UTF ? UTF8SKIP(t) : 1;
- while ( t < PL_bufend
+ else
+ /* skip plain q word */
+ while ( t < PL_bufend
&& isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
{
- t += UTF ? UTF8SKIP(t) : 1;
+ t += UTF ? UTF8SKIP(t) : 1;
}
- }
- while (t < PL_bufend && isSPACE(*t))
- t++;
- /* if comma follows first term, call it an anon hash */
- /* XXX it could be a comma expression with loop modifiers */
- if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
- || (*t == '=' && t[1] == '>')))
- OPERATOR(HASHBRACK);
- if (PL_expect == XREF)
- {
- block_expectation:
- /* If there is an opening brace or 'sub:', treat it
- as a term to make ${{...}}{k} and &{sub:attr...}
- dwim. Otherwise, treat it as a statement, so
- map {no strict; ...} works.
- */
- s = skipspace(s);
- if (*s == '{') {
- PL_expect = XTERM;
- break;
- }
- if (memBEGINs(s, (STRLEN) (PL_bufend - s), "sub")) {
- PL_bufptr = s;
- d = s + 3;
- d = skipspace(d);
- s = PL_bufptr;
- if (*d == ':') {
- PL_expect = XTERM;
- break;
- }
- }
- PL_expect = XSTATE;
- }
- else {
- PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
- PL_expect = XSTATE;
- }
- }
- break;
- }
- pl_yylval.ival = CopLINE(PL_curcop);
- PL_copline = NOLINE; /* invalidate current command line number */
- TOKEN(formbrack ? '=' : '{');
- case '}':
- if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
- TOKEN(0);
- rightbracket:
- assert(s != PL_bufend);
- s++;
- if (PL_lex_brackets <= 0)
- /* diag_listed_as: Unmatched right %s bracket */
- yyerror("Unmatched right curly bracket");
- else
- PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
- PL_lex_allbrackets--;
- if (PL_lex_state == LEX_INTERPNORMAL) {
- if (PL_lex_brackets == 0) {
- if (PL_expect & XFAKEBRACK) {
- PL_expect &= XENUMMASK;
- PL_lex_state = LEX_INTERPEND;
- PL_bufptr = s;
- return yylex(); /* ignore fake brackets */
- }
- if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
- && SvEVALED(PL_lex_repl))
- PL_lex_state = LEX_INTERPEND;
- else if (*s == '-' && s[1] == '>')
- PL_lex_state = LEX_INTERPENDMAYBE;
- else if (*s != '[' && *s != '{')
- PL_lex_state = LEX_INTERPEND;
- }
- }
- if (PL_expect & XFAKEBRACK) {
- PL_expect &= XENUMMASK;
- PL_bufptr = s;
- return yylex(); /* ignore fake brackets */
- }
- force_next(formbrack ? '.' : '}');
- if (formbrack) LEAVE_with_name("lex_format");
- if (formbrack == 2) { /* means . where arguments were expected */
- force_next(';');
- TOKEN(FORMRBRACK);
- }
- TOKEN(';');
- case '&':
- if (PL_expect == XPOSTDEREF) POSTDEREF('&');
- s++;
- if (*s++ == '&') {
- if (!PL_lex_allbrackets && PL_lex_fakeeof >=
- (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
- s -= 2;
- TOKEN(0);
- }
- AOPERATOR(ANDAND);
- }
- s--;
- if (PL_expect == XOPERATOR) {
- if ( PL_bufptr == PL_linestart
- && ckWARN(WARN_SEMICOLON)
- && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
- {
- CopLINE_dec(PL_curcop);
- Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
- CopLINE_inc(PL_curcop);
- }
- d = s;
- if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
- s++;
- if (!PL_lex_allbrackets && PL_lex_fakeeof >=
- (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
- s = d;
- s--;
- TOKEN(0);
- }
- if (d == s) {
- PL_parser->saw_infix_sigil = 1;
- BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
- }
- else
- BAop(OP_SBIT_AND);
- }
-
- PL_tokenbuf[0] = '&';
- s = scan_ident(s - 1, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
- pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
- if (PL_tokenbuf[1]) {
- force_ident_maybe_lex('&');
- }
- else
- PREREF('&');
- TERM('&');
-
- case '|':
- s++;
- if (*s++ == '|') {
- if (!PL_lex_allbrackets && PL_lex_fakeeof >=
- (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
- s -= 2;
- TOKEN(0);
- }
- AOPERATOR(OROR);
- }
- s--;
- d = s;
- if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
- s++;
- if (!PL_lex_allbrackets && PL_lex_fakeeof >=
- (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
- s = d - 1;
- TOKEN(0);
- }
- BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
- case '=':
- s++;
- {
- const char tmp = *s++;
- if (tmp == '=') {
- if ( (s == PL_linestart+2 || s[-3] == '\n')
- && memBEGINs(s, (STRLEN) (PL_bufend - s), "====="))
- {
- s = vcs_conflict_marker(s + 5);
- goto retry;
- }
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- {
- s -= 2;
- TOKEN(0);
- }
- Eop(OP_EQ);
- }
- if (tmp == '>') {
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
- {
- s -= 2;
- TOKEN(0);
- }
- OPERATOR(',');
- }
- if (tmp == '~')
- PMop(OP_MATCH);
- if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
- && strchr("+-*/%.^&|<",tmp))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Reversed %c= operator",(int)tmp);
- s--;
- if (PL_expect == XSTATE
- && isALPHA(tmp)
- && (s == PL_linestart+1 || s[-2] == '\n') )
- {
- if ( (PL_in_eval && !PL_rsfp && !PL_parser->filtered)
- || PL_lex_state != LEX_NORMAL)
+ }
+ else if (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)) {
+ t += UTF ? UTF8SKIP(t) : 1;
+ while ( t < PL_bufend
+ && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
{
- d = PL_bufend;
- while (s < d) {
- if (*s++ == '\n') {
- incline(s, PL_bufend);
- if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=cut"))
- {
- s = (char *) memchr(s,'\n', d - s);
- if (s)
- s++;
- else
- s = d;
- incline(s, PL_bufend);
- goto retry;
- }
- }
+ t += UTF ? UTF8SKIP(t) : 1;
+ }
+ }
+ while (t < PL_bufend && isSPACE(*t))
+ t++;
+ /* if comma follows first term, call it an anon hash */
+ /* XXX it could be a comma expression with loop modifiers */
+ if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
+ || (*t == '=' && t[1] == '>')))
+ OPERATOR(HASHBRACK);
+ if (PL_expect == XREF) {
+ block_expectation:
+ /* If there is an opening brace or 'sub:', treat it
+ as a term to make ${{...}}{k} and &{sub:attr...}
+ dwim. Otherwise, treat it as a statement, so
+ map {no strict; ...} works.
+ */
+ s = skipspace(s);
+ if (*s == '{') {
+ PL_expect = XTERM;
+ break;
+ }
+ if (memBEGINs(s, (STRLEN) (PL_bufend - s), "sub")) {
+ PL_bufptr = s;
+ d = s + 3;
+ d = skipspace(d);
+ s = PL_bufptr;
+ if (*d == ':') {
+ PL_expect = XTERM;
+ break;
}
- goto retry;
}
- s = PL_bufend;
- PL_parser->in_pod = 1;
- goto retry;
+ PL_expect = XSTATE;
}
- }
- if (PL_expect == XBLOCK) {
- const char *t = s;
-#ifdef PERL_STRICT_CR
- while (SPACE_OR_TAB(*t))
-#else
- while (SPACE_OR_TAB(*t) || *t == '\r')
-#endif
- t++;
- if (*t == '\n' || *t == '#') {
- formbrack = 1;
- ENTER_with_name("lex_format");
- SAVEI8(PL_parser->form_lex_state);
- SAVEI32(PL_lex_formbrack);
- PL_parser->form_lex_state = PL_lex_state;
- PL_lex_formbrack = PL_lex_brackets + 1;
- PL_parser->sub_error_count = PL_error_count;
- goto leftbracket;
- }
- }
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
- s--;
- TOKEN(0);
- }
- pl_yylval.ival = 0;
- OPERATOR(ASSIGNOP);
- case '!':
- s++;
- {
- const char tmp = *s++;
- if (tmp == '=') {
- /* was this !=~ where !~ was meant?
- * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
+ else {
+ PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
+ PL_expect = XSTATE;
+ }
+ }
+ break;
+ }
- if (*s == '~' && ckWARN(WARN_SYNTAX)) {
- const char *t = s+1;
+ pl_yylval.ival = CopLINE(PL_curcop);
+ PL_copline = NOLINE; /* invalidate current command line number */
+ TOKEN(formbrack ? '=' : '{');
+}
- while (t < PL_bufend && isSPACE(*t))
- ++t;
+static int
+yyl_rightcurly(pTHX_ char *s, const U8 formbrack)
+{
+ assert(s != PL_bufend);
+ s++;
- if (*t == '/' || *t == '?'
- || ((*t == 'm' || *t == 's' || *t == 'y')
- && !isWORDCHAR(t[1]))
- || (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "!=~ should be !~");
- }
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- {
- s -= 2;
- TOKEN(0);
- }
- Eop(OP_NE);
- }
- if (tmp == '~')
- PMop(OP_NOT);
- }
- s--;
- OPERATOR('!');
- case '<':
- if (PL_expect != XOPERATOR) {
- if (s[1] != '<' && !memchr(s,'>', PL_bufend - s))
- check_uni();
- if (s[1] == '<' && s[2] != '>') {
- if ( (s == PL_linestart || s[-1] == '\n')
- && memBEGINs(s+2, (STRLEN) (PL_bufend - (s+2)), "<<<<<"))
- {
- s = vcs_conflict_marker(s + 7);
- goto retry;
- }
- s = scan_heredoc(s);
- }
- else
- s = scan_inputsymbol(s);
- PL_expect = XOPERATOR;
- TOKEN(sublex_start());
- }
- s++;
- {
- char tmp = *s++;
- if (tmp == '<') {
- if ( (s == PL_linestart+2 || s[-3] == '\n')
- && memBEGINs(s, (STRLEN) (PL_bufend - s), "<<<<<"))
- {
- s = vcs_conflict_marker(s + 5);
- goto retry;
- }
- if (*s == '=' && !PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
- {
- s -= 2;
- TOKEN(0);
- }
- SHop(OP_LEFT_SHIFT);
- }
- if (tmp == '=') {
- tmp = *s++;
- if (tmp == '>') {
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- {
- s -= 3;
- TOKEN(0);
- }
- Eop(OP_NCMP);
- }
- s--;
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- {
- s -= 2;
- TOKEN(0);
- }
- Rop(OP_LE);
- }
- }
- s--;
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
- s--;
- TOKEN(0);
- }
- Rop(OP_LT);
- case '>':
- s++;
- {
- const char tmp = *s++;
- if (tmp == '>') {
- if ( (s == PL_linestart+2 || s[-3] == '\n')
- && memBEGINs(s, (STRLEN) (PL_bufend - s), ">>>>>"))
- {
- s = vcs_conflict_marker(s + 5);
- goto retry;
- }
- if (*s == '=' && !PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
- {
- s -= 2;
- TOKEN(0);
- }
- SHop(OP_RIGHT_SHIFT);
- }
- else if (tmp == '=') {
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- {
- s -= 2;
- TOKEN(0);
- }
- Rop(OP_GE);
- }
- }
- s--;
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
- s--;
- TOKEN(0);
- }
- Rop(OP_GT);
+ if (PL_lex_brackets <= 0)
+ /* diag_listed_as: Unmatched right %s bracket */
+ yyerror("Unmatched right curly bracket");
+ else
+ PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
+
+ PL_lex_allbrackets--;
+
+ if (PL_lex_state == LEX_INTERPNORMAL) {
+ if (PL_lex_brackets == 0) {
+ if (PL_expect & XFAKEBRACK) {
+ PL_expect &= XENUMMASK;
+ PL_lex_state = LEX_INTERPEND;
+ PL_bufptr = s;
+ return yylex(); /* ignore fake brackets */
+ }
+ if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
+ && SvEVALED(PL_lex_repl))
+ PL_lex_state = LEX_INTERPEND;
+ else if (*s == '-' && s[1] == '>')
+ PL_lex_state = LEX_INTERPENDMAYBE;
+ else if (*s != '[' && *s != '{')
+ PL_lex_state = LEX_INTERPEND;
+ }
+ }
+
+ if (PL_expect & XFAKEBRACK) {
+ PL_expect &= XENUMMASK;
+ PL_bufptr = s;
+ return yylex(); /* ignore fake brackets */
+ }
+
+ force_next(formbrack ? '.' : '}');
+ if (formbrack) LEAVE_with_name("lex_format");
+ if (formbrack == 2) { /* means . where arguments were expected */
+ force_next(';');
+ TOKEN(FORMRBRACK);
+ }
+
+ TOKEN(';');
+}
+
+static int
+yyl_ampersand(pTHX_ char *s)
+{
+ if (PL_expect == XPOSTDEREF)
+ POSTDEREF('&');
+
+ s++;
+ if (*s++ == '&') {
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
+ s -= 2;
+ TOKEN(0);
+ }
+ AOPERATOR(ANDAND);
+ }
+ s--;
+
+ if (PL_expect == XOPERATOR) {
+ char *d;
+ bool bof;
+ if ( PL_bufptr == PL_linestart
+ && ckWARN(WARN_SEMICOLON)
+ && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
+ {
+ CopLINE_dec(PL_curcop);
+ Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
+ CopLINE_inc(PL_curcop);
+ }
+ d = s;
+ if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
+ s++;
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
+ s = d;
+ s--;
+ TOKEN(0);
+ }
+ if (d == s)
+ BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
+ else
+ BAop(OP_SBIT_AND);
+ }
+
+ PL_tokenbuf[0] = '&';
+ s = scan_ident(s - 1, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
+ pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
+
+ if (PL_tokenbuf[1])
+ force_ident_maybe_lex('&');
+ else
+ PREREF('&');
+
+ TERM('&');
+}
+
+static int
+yyl_verticalbar(pTHX_ char *s)
+{
+ char *d;
+ bool bof;
+
+ s++;
+ if (*s++ == '|') {
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
+ s -= 2;
+ TOKEN(0);
+ }
+ AOPERATOR(OROR);
+ }
+
+ s--;
+ d = s;
+ if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
+ s++;
+
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
+ s = d - 1;
+ TOKEN(0);
+ }
+
+ BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
+}
+
+static int
+yyl_bang(pTHX_ char *s)
+{
+ const char tmp = *s++;
+ if (tmp == '=') {
+ /* was this !=~ where !~ was meant?
+ * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
+
+ if (*s == '~' && ckWARN(WARN_SYNTAX)) {
+ const char *t = s+1;
+
+ while (t < PL_bufend && isSPACE(*t))
+ ++t;
+
+ if (*t == '/' || *t == '?'
+ || ((*t == 'm' || *t == 's' || *t == 'y')
+ && !isWORDCHAR(t[1]))
+ || (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "!=~ should be !~");
+ }
+
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s -= 2;
+ TOKEN(0);
+ }
+
+ ChEop(OP_NE);
+ }
+
+ if (tmp == '~')
+ PMop(OP_NOT);
+
+ s--;
+ OPERATOR('!');
+}
+
+static int
+yyl_snail(pTHX_ char *s)
+{
+ if (PL_expect == XPOSTDEREF)
+ POSTDEREF('@');
+ PL_tokenbuf[0] = '@';
+ s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
+ if (PL_expect == XOPERATOR) {
+ char *d = s;
+ if (PL_bufptr > s) {
+ d = PL_bufptr-1;
+ PL_bufptr = PL_oldbufptr;
+ }
+ no_op("Array", d);
+ }
+ pl_yylval.ival = 0;
+ if (!PL_tokenbuf[1]) {
+ PREREF('@');
+ }
+ if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
+ s = skipspace(s);
+ if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
+ && intuit_more(s, PL_bufend))
+ {
+ if (*s == '{')
+ PL_tokenbuf[0] = '%';
+
+ /* Warn about @ where they meant $. */
+ if (*s == '[' || *s == '{') {
+ if (ckWARN(WARN_SYNTAX)) {
+ S_check_scalar_slice(aTHX_ s);
+ }
+ }
+ }
+ PL_expect = XOPERATOR;
+ force_ident_maybe_lex('@');
+ TERM('@');
+}
+
+static int
+yyl_slash(pTHX_ char *s)
+{
+ if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
+ TOKEN(0);
+ s += 2;
+ AOPERATOR(DORDOR);
+ }
+ else if (PL_expect == XOPERATOR) {
+ s++;
+ if (*s == '=' && !PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
+ {
+ s--;
+ TOKEN(0);
+ }
+ Mop(OP_DIVIDE);
+ }
+ else {
+ /* Disable warning on "study /blah/" */
+ if ( PL_oldoldbufptr == PL_last_uni
+ && ( *PL_last_uni != 's' || s - PL_last_uni < 5
+ || memNE(PL_last_uni, "study", 5)
+ || isWORDCHAR_lazy_if_safe(PL_last_uni+5, PL_bufend, UTF)
+ ))
+ check_uni();
+ s = scan_pat(s,OP_MATCH);
+ TERM(sublex_start());
+ }
+}
+
+static int
+yyl_leftsquare(pTHX_ char *s)
+{
+ char tmp;
+
+ if (PL_lex_brackets > 100)
+ Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
+ PL_lex_brackstack[PL_lex_brackets++] = 0;
+ PL_lex_allbrackets++;
+ tmp = *s++;
+ OPERATOR(tmp);
+}
+
+static int
+yyl_rightsquare(pTHX_ char *s)
+{
+ if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
+ TOKEN(0);
+ s++;
+ if (PL_lex_brackets <= 0)
+ /* diag_listed_as: Unmatched right %s bracket */
+ yyerror("Unmatched right square bracket");
+ else
+ --PL_lex_brackets;
+ PL_lex_allbrackets--;
+ if (PL_lex_state == LEX_INTERPNORMAL) {
+ if (PL_lex_brackets == 0) {
+ if (*s == '-' && s[1] == '>')
+ PL_lex_state = LEX_INTERPENDMAYBE;
+ else if (*s != '[' && *s != '{')
+ PL_lex_state = LEX_INTERPEND;
+ }
+ }
+ TERM(']');
+}
+
+static int
+yyl_tilde(pTHX_ char *s)
+{
+ bool bof;
+ if (s[1] == '~' && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)) {
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ TOKEN(0);
+ s += 2;
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
+ "Smartmatch is experimental");
+ NCEop(OP_SMARTMATCH);
+ }
+ s++;
+ if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
+ s++;
+ BCop(OP_SCOMPLEMENT);
+ }
+ BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
+}
+
+static int
+yyl_leftparen(pTHX_ char *s)
+{
+ if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
+ PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
+ else
+ PL_expect = XTERM;
+ s = skipspace(s);
+ PL_lex_allbrackets++;
+ TOKEN('(');
+}
+
+static int
+yyl_rightparen(pTHX_ char *s)
+{
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
+ TOKEN(0);
+ s++;
+ PL_lex_allbrackets--;
+ s = skipspace(s);
+ if (*s == '{')
+ PREBLOCK(')');
+ TERM(')');
+}
+
+static int
+yyl_leftpointy(pTHX_ char *s)
+{
+ char tmp;
+
+ if (PL_expect != XOPERATOR) {
+ if (s[1] != '<' && !memchr(s,'>', PL_bufend - s))
+ check_uni();
+ if (s[1] == '<' && s[2] != '>')
+ s = scan_heredoc(s);
+ else
+ s = scan_inputsymbol(s);
+ PL_expect = XOPERATOR;
+ TOKEN(sublex_start());
+ }
+
+ s++;
+
+ tmp = *s++;
+ if (tmp == '<') {
+ if (*s == '=' && !PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s -= 2;
+ TOKEN(0);
+ }
+ SHop(OP_LEFT_SHIFT);
+ }
+ if (tmp == '=') {
+ tmp = *s++;
+ if (tmp == '>') {
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s -= 3;
+ TOKEN(0);
+ }
+ NCEop(OP_NCMP);
+ }
+ s--;
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s -= 2;
+ TOKEN(0);
+ }
+ ChRop(OP_LE);
+ }
+
+ s--;
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s--;
+ TOKEN(0);
+ }
+
+ ChRop(OP_LT);
+}
+
+static int
+yyl_rightpointy(pTHX_ char *s)
+{
+ const char tmp = *s++;
+
+ if (tmp == '>') {
+ if (*s == '=' && !PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s -= 2;
+ TOKEN(0);
+ }
+ SHop(OP_RIGHT_SHIFT);
+ }
+ else if (tmp == '=') {
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s -= 2;
+ TOKEN(0);
+ }
+ ChRop(OP_GE);
+ }
+
+ s--;
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s--;
+ TOKEN(0);
+ }
+
+ ChRop(OP_GT);
+}
+
+static int
+yyl_sglquote(pTHX_ char *s)
+{
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
+ if (!s)
+ missingterm(NULL, 0);
+ COPLINE_SET_FROM_MULTI_END;
+ DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
+ if (PL_expect == XOPERATOR) {
+ no_op("String",s);
+ }
+ pl_yylval.ival = OP_CONST;
+ TERM(sublex_start());
+}
+
+static int
+yyl_dblquote(pTHX_ char *s)
+{
+ char *d;
+ STRLEN len;
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
+ DEBUG_T( {
+ if (s)
+ printbuf("### Saw string before %s\n", s);
+ else
+ PerlIO_printf(Perl_debug_log,
+ "### Saw unterminated string\n");
+ } );
+ if (PL_expect == XOPERATOR) {
+ no_op("String",s);
+ }
+ if (!s)
+ missingterm(NULL, 0);
+ pl_yylval.ival = OP_CONST;
+ /* FIXME. I think that this can be const if char *d is replaced by
+ more localised variables. */
+ for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
+ if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
+ pl_yylval.ival = OP_STRINGIFY;
+ break;
+ }
+ }
+ if (pl_yylval.ival == OP_CONST)
+ COPLINE_SET_FROM_MULTI_END;
+ TERM(sublex_start());
+}
+
+static int
+yyl_backtick(pTHX_ char *s)
+{
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
+ DEBUG_T( {
+ if (s)
+ printbuf("### Saw backtick string before %s\n", s);
+ else
+ PerlIO_printf(Perl_debug_log,
+ "### Saw unterminated backtick string\n");
+ } );
+ if (PL_expect == XOPERATOR)
+ no_op("Backticks",s);
+ if (!s)
+ missingterm(NULL, 0);
+ pl_yylval.ival = OP_BACKTICK;
+ TERM(sublex_start());
+}
+
+static int
+yyl_backslash(pTHX_ char *s)
+{
+ if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr && isDIGIT(*s))
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
+ *s, *s);
+ if (PL_expect == XOPERATOR)
+ no_op("Backslash",s);
+ OPERATOR(REFGEN);
+}
+
+static void
+yyl_data_handle(pTHX)
+{
+ HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
+ ? PL_curstash
+ : PL_defstash;
+ GV *gv = (GV *)*hv_fetchs(stash, "DATA", 1);
+
+ if (!isGV(gv))
+ gv_init(gv,stash,"DATA",4,0);
+
+ GvMULTI_on(gv);
+ if (!GvIO(gv))
+ GvIOp(gv) = newIO();
+ IoIFP(GvIOp(gv)) = PL_rsfp;
+
+ /* Mark this internal pseudo-handle as clean */
+ IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
+ if ((PerlIO*)PL_rsfp == PerlIO_stdin())
+ IoTYPE(GvIOp(gv)) = IoTYPE_STD;
+ else
+ IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
+
+#if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
+ /* if the script was opened in binmode, we need to revert
+ * it to text mode for compatibility; but only iff it has CRs
+ * XXX this is a questionable hack at best. */
+ if (PL_bufend-PL_bufptr > 2
+ && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
+ {
+ Off_t loc = 0;
+ if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
+ loc = PerlIO_tell(PL_rsfp);
+ (void)PerlIO_seek(PL_rsfp, 0L, 0);
+ }
+ if (PerlLIO_setmode(RSFP_FILENO, O_TEXT) != -1) {
+ if (loc > 0)
+ PerlIO_seek(PL_rsfp, loc, 0);
+ }
+ }
+#endif
+
+#ifdef PERLIO_LAYERS
+ if (!IN_BYTES) {
+ if (UTF)
+ PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
+ }
+#endif
+
+ PL_rsfp = NULL;
+}
+
+PERL_STATIC_NO_RET void yyl_croak_unrecognised(pTHX_ char*)
+ __attribute__noreturn__;
+
+PERL_STATIC_NO_RET void
+yyl_croak_unrecognised(pTHX_ char *s)
+{
+ SV *dsv = newSVpvs_flags("", SVs_TEMP);
+ const char *c;
+ char *d;
+ STRLEN len;
+
+ if (UTF) {
+ STRLEN skiplen = UTF8SKIP(s);
+ STRLEN stravail = PL_bufend - s;
+ c = sv_uni_display(dsv, newSVpvn_flags(s,
+ skiplen > stravail ? stravail : skiplen,
+ SVs_TEMP | SVf_UTF8),
+ 10, UNI_DISPLAY_ISPRINT);
+ }
+ else {
+ c = Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
+ }
+
+ if (s >= PL_linestart) {
+ d = PL_linestart;
+ }
+ else {
+ /* somehow (probably due to a parse failure), PL_linestart has advanced
+ * pass PL_bufptr, get a reasonable beginning of line
+ */
+ d = s;
+ while (d > SvPVX(PL_linestr) && d[-1] && d[-1] != '\n')
+ --d;
+ }
+ len = UTF ? Perl_utf8_length(aTHX_ (U8 *) d, (U8 *) s) : (STRLEN) (s - d);
+ if (len > UNRECOGNIZED_PRECEDE_COUNT) {
+ d = UTF ? (char *) utf8_hop_back((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT, (U8 *)d) : s - UNRECOGNIZED_PRECEDE_COUNT;
+ }
+
+ Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %" UTF8f "<-- HERE near column %d", c,
+ UTF8fARG(UTF, (s - d), d),
+ (int) len + 1);
+}
+
+static int
+yyl_require(pTHX_ char *s, I32 orig_keyword)
+{
+ s = skipspace(s);
+ if (isDIGIT(*s)) {
+ s = force_version(s, FALSE);
+ }
+ else if (*s != 'v' || !isDIGIT(s[1])
+ || (s = force_version(s, TRUE), *s == 'v'))
+ {
+ *PL_tokenbuf = '\0';
+ s = force_word(s,BAREWORD,TRUE,TRUE);
+ if (isIDFIRST_lazy_if_safe(PL_tokenbuf,
+ PL_tokenbuf + sizeof(PL_tokenbuf),
+ UTF))
+ {
+ gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
+ GV_ADD | (UTF ? SVf_UTF8 : 0));
+ }
+ else if (*s == '<')
+ yyerror("<> at require-statement should be quotes");
+ }
+
+ if (orig_keyword == KEY_require)
+ pl_yylval.ival = 1;
+ else
+ pl_yylval.ival = 0;
+
+ PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
+ PL_bufptr = s;
+ PL_last_uni = PL_oldbufptr;
+ PL_last_lop_op = OP_REQUIRE;
+ s = skipspace(s);
+ return REPORT( (int)REQUIRE );
+}
+
+static int
+yyl_foreach(pTHX_ char *s)
+{
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ return REPORT(0);
+ pl_yylval.ival = CopLINE(PL_curcop);
+ s = skipspace(s);
+ if (PL_expect == XSTATE && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
+ char *p = s;
+ SSize_t s_off = s - SvPVX(PL_linestr);
+ STRLEN len;
+
+ if (memBEGINPs(p, (STRLEN) (PL_bufend - p), "my") && isSPACE(p[2])) {
+ p += 2;
+ }
+ else if (memBEGINPs(p, (STRLEN) (PL_bufend - p), "our") && isSPACE(p[3])) {
+ p += 3;
+ }
+
+ p = skipspace(p);
+ /* skip optional package name, as in "for my abc $x (..)" */
+ if (isIDFIRST_lazy_if_safe(p, PL_bufend, UTF)) {
+ p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
+ p = skipspace(p);
+ }
+ if (*p != '$' && *p != '\\')
+ Perl_croak(aTHX_ "Missing $ on loop variable");
+
+ /* The buffer may have been reallocated, update s */
+ s = SvPVX(PL_linestr) + s_off;
+ }
+ OPERATOR(FOR);
+}
+
+static int
+yyl_do(pTHX_ char *s, I32 orig_keyword)
+{
+ s = skipspace(s);
+ if (*s == '{')
+ PRETERMBLOCK(DO);
+ if (*s != '\'') {
+ char *d;
+ STRLEN len;
+ *PL_tokenbuf = '&';
+ d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
+ 1, &len);
+ if (len && memNEs(PL_tokenbuf+1, len, "CORE")
+ && !keyword(PL_tokenbuf + 1, len, 0)) {
+ SSize_t off = s-SvPVX(PL_linestr);
+ d = skipspace(d);
+ s = SvPVX(PL_linestr)+off;
+ if (*d == '(') {
+ force_ident_maybe_lex('&');
+ s = d;
+ }
+ }
+ }
+ if (orig_keyword == KEY_do)
+ pl_yylval.ival = 1;
+ else
+ pl_yylval.ival = 0;
+ OPERATOR(DO);
+}
+
+static int
+yyl_my(pTHX_ char *s, I32 my)
+{
+ if (PL_in_my) {
+ PL_bufptr = s;
+ yyerror(Perl_form(aTHX_
+ "Can't redeclare \"%s\" in \"%s\"",
+ my == KEY_my ? "my" :
+ my == KEY_state ? "state" : "our",
+ PL_in_my == KEY_my ? "my" :
+ PL_in_my == KEY_state ? "state" : "our"));
+ }
+ PL_in_my = (U16)my;
+ s = skipspace(s);
+ if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
+ STRLEN len;
+ s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
+ if (memEQs(PL_tokenbuf, len, "sub"))
+ return yyl_sub(aTHX_ s, my);
+ PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
+ if (!PL_in_my_stash) {
+ char tmpbuf[1024];
+ int i;
+ PL_bufptr = s;
+ i = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
+ PERL_MY_SNPRINTF_POST_GUARD(i, sizeof(tmpbuf));
+ yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
+ }
+ }
+ else if (*s == '\\') {
+ if (!FEATURE_MYREF_IS_ENABLED)
+ Perl_croak(aTHX_ "The experimental declared_refs "
+ "feature is not enabled");
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
+ "Declaring references is experimental");
+ }
+ OPERATOR(MY);
+}
+
+static int yyl_try(pTHX_ char*);
+
+static bool
+yyl_eol_needs_semicolon(pTHX_ char **ps)
+{
+ char *s = *ps;
+ if (PL_lex_state != LEX_NORMAL
+ || (PL_in_eval && !PL_rsfp && !PL_parser->filtered))
+ {
+ const bool in_comment = *s == '#';
+ char *d;
+ if (*s == '#' && s == PL_linestart && PL_in_eval
+ && !PL_rsfp && !PL_parser->filtered) {
+ /* handle eval qq[#line 1 "foo"\n ...] */
+ CopLINE_dec(PL_curcop);
+ incline(s, PL_bufend);
+ }
+ d = s;
+ while (d < PL_bufend && *d != '\n')
+ d++;
+ if (d < PL_bufend)
+ d++;
+ s = d;
+ if (in_comment && d == PL_bufend
+ && PL_lex_state == LEX_INTERPNORMAL
+ && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
+ && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
+ else
+ incline(s, PL_bufend);
+ if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
+ PL_lex_state = LEX_FORMLINE;
+ force_next(FORMRBRACK);
+ *ps = s;
+ return TRUE;
+ }
+ }
+ else {
+ while (s < PL_bufend && *s != '\n')
+ s++;
+ if (s < PL_bufend) {
+ s++;
+ if (s < PL_bufend)
+ incline(s, PL_bufend);
+ }
+ }
+ *ps = s;
+ return FALSE;
+}
+
+static int
+yyl_fake_eof(pTHX_ U32 fake_eof, bool bof, char *s)
+{
+ char *d;
+
+ goto start;
+
+ do {
+ fake_eof = 0;
+ bof = cBOOL(PL_rsfp);
+ start:
+
+ PL_bufptr = PL_bufend;
+ COPLINE_INC_WITH_HERELINES;
+ if (!lex_next_chunk(fake_eof)) {
+ CopLINE_dec(PL_curcop);
+ s = PL_bufptr;
+ TOKEN(';'); /* not infinite loop because rsfp is NULL now */
+ }
+ CopLINE_dec(PL_curcop);
+ s = PL_bufptr;
+ /* If it looks like the start of a BOM or raw UTF-16,
+ * check if it in fact is. */
+ if (bof && PL_rsfp
+ && ( *s == 0
+ || *(U8*)s == BOM_UTF8_FIRST_BYTE
+ || *(U8*)s >= 0xFE
+ || s[1] == 0))
+ {
+ Off_t offset = (IV)PerlIO_tell(PL_rsfp);
+ bof = (offset == (Off_t)SvCUR(PL_linestr));
+#if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
+ /* offset may include swallowed CR */
+ if (!bof)
+ bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
+#endif
+ if (bof) {
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ s = swallow_bom((U8*)s);
+ }
+ }
+ if (PL_parser->in_pod) {
+ /* Incest with pod. */
+ if ( memBEGINPs(s, (STRLEN) (PL_bufend - s), "=cut")
+ && !isALPHA(s[4]))
+ {
+ SvPVCLEAR(PL_linestr);
+ PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = NULL;
+ PL_parser->in_pod = 0;
+ }
+ }
+ if (PL_rsfp || PL_parser->filtered)
+ incline(s, PL_bufend);
+ } while (PL_parser->in_pod);
+
+ PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = NULL;
+ if (CopLINE(PL_curcop) == 1) {
+ while (s < PL_bufend && isSPACE(*s))
+ s++;
+ if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
+ s++;
+ d = NULL;
+ if (!PL_in_eval) {
+ if (*s == '#' && *(s+1) == '!')
+ d = s + 2;
+#ifdef ALTERNATE_SHEBANG
+ else {
+ static char const as[] = ALTERNATE_SHEBANG;
+ if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
+ d = s + (sizeof(as) - 1);
+ }
+#endif /* ALTERNATE_SHEBANG */
+ }
+ if (d) {
+ char *ipath;
+ char *ipathend;
+
+ while (isSPACE(*d))
+ d++;
+ ipath = d;
+ while (*d && !isSPACE(*d))
+ d++;
+ ipathend = d;
+
+#ifdef ARG_ZERO_IS_SCRIPT
+ if (ipathend > ipath) {
+ /*
+ * HP-UX (at least) sets argv[0] to the script name,
+ * which makes $^X incorrect. And Digital UNIX and Linux,
+ * at least, set argv[0] to the basename of the Perl
+ * interpreter. So, having found "#!", we'll set it right.
+ */
+ SV* copfilesv = CopFILESV(PL_curcop);
+ if (copfilesv) {
+ SV * const x =
+ GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
+ SVt_PV)); /* $^X */
+ assert(SvPOK(x) || SvGMAGICAL(x));
+ if (sv_eq(x, copfilesv)) {
+ sv_setpvn(x, ipath, ipathend - ipath);
+ SvSETMAGIC(x);
+ }
+ else {
+ STRLEN blen;
+ STRLEN llen;
+ const char *bstart = SvPV_const(copfilesv, blen);
+ const char * const lstart = SvPV_const(x, llen);
+ if (llen < blen) {
+ bstart += blen - llen;
+ if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
+ sv_setpvn(x, ipath, ipathend - ipath);
+ SvSETMAGIC(x);
+ }
+ }
+ }
+ }
+ else {
+ /* Anything to do if no copfilesv? */
+ }
+ TAINT_NOT; /* $^X is always tainted, but that's OK */
+ }
+#endif /* ARG_ZERO_IS_SCRIPT */
+
+ /*
+ * Look for options.
+ */
+ d = instr(s,"perl -");
+ if (!d) {
+ d = instr(s,"perl");
+#if defined(DOSISH)
+ /* avoid getting into infinite loops when shebang
+ * line contains "Perl" rather than "perl" */
+ if (!d) {
+ for (d = ipathend-4; d >= ipath; --d) {
+ if (isALPHA_FOLD_EQ(*d, 'p')
+ && !ibcmp(d, "perl", 4))
+ {
+ break;
+ }
+ }
+ if (d < ipath)
+ d = NULL;
+ }
+#endif
+ }
+#ifdef ALTERNATE_SHEBANG
+ /*
+ * If the ALTERNATE_SHEBANG on this system starts with a
+ * character that can be part of a Perl expression, then if
+ * we see it but not "perl", we're probably looking at the
+ * start of Perl code, not a request to hand off to some
+ * other interpreter. Similarly, if "perl" is there, but
+ * not in the first 'word' of the line, we assume the line
+ * contains the start of the Perl program.
+ */
+ if (d && *s != '#') {
+ const char *c = ipath;
+ while (*c && !memCHRs("; \t\r\n\f\v#", *c))
+ c++;
+ if (c < d)
+ d = NULL; /* "perl" not in first word; ignore */
+ else
+ *s = '#'; /* Don't try to parse shebang line */
+ }
+#endif /* ALTERNATE_SHEBANG */
+ if (!d
+ && *s == '#'
+ && ipathend > ipath
+ && !PL_minus_c
+ && !instr(s,"indir")
+ && instr(PL_origargv[0],"perl"))
+ {
+ char **newargv;
+
+ *ipathend = '\0';
+ s = ipathend + 1;
+ while (s < PL_bufend && isSPACE(*s))
+ s++;
+ if (s < PL_bufend) {
+ Newx(newargv,PL_origargc+3,char*);
+ newargv[1] = s;
+ while (s < PL_bufend && !isSPACE(*s))
+ s++;
+ *s = '\0';
+ Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
+ }
+ else
+ newargv = PL_origargv;
+ newargv[0] = ipath;
+ PERL_FPU_PRE_EXEC
+ PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
+ PERL_FPU_POST_EXEC
+ Perl_croak(aTHX_ "Can't exec %s", ipath);
+ }
+ if (d) {
+ while (*d && !isSPACE(*d))
+ d++;
+ while (SPACE_OR_TAB(*d))
+ d++;
+
+ if (*d++ == '-') {
+ const bool switches_done = PL_doswitches;
+ const U32 oldpdb = PL_perldb;
+ const bool oldn = PL_minus_n;
+ const bool oldp = PL_minus_p;
+ const char *d1 = d;
+
+ do {
+ bool baduni = FALSE;
+ if (*d1 == 'C') {
+ const char *d2 = d1 + 1;
+ if (parse_unicode_opts((const char **)&d2)
+ != PL_unicode)
+ baduni = TRUE;
+ }
+ if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
+ const char * const m = d1;
+ while (*d1 && !isSPACE(*d1))
+ d1++;
+ Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
+ (int)(d1 - m), m);
+ }
+ d1 = moreswitches(d1);
+ } while (d1);
+ if (PL_doswitches && !switches_done) {
+ int argc = PL_origargc;
+ char **argv = PL_origargv;
+ do {
+ argc--,argv++;
+ } while (argc && argv[0][0] == '-' && argv[0][1]);
+ init_argv_symbols(argc,argv);
+ }
+ if ( (PERLDB_LINE_OR_SAVESRC && !oldpdb)
+ || ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
+ /* if we have already added "LINE: while (<>) {",
+ we must not do it again */
+ {
+ SvPVCLEAR(PL_linestr);
+ PL_bufptr = PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = NULL;
+ PL_preambled = FALSE;
+ if (PERLDB_LINE_OR_SAVESRC)
+ (void)gv_fetchfile(PL_origfilename);
+ return YYL_RETRY;
+ }
+ }
+ }
+ }
+ }
+
+ if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
+ PL_lex_state = LEX_FORMLINE;
+ force_next(FORMRBRACK);
+ TOKEN(';');
+ }
+
+ PL_bufptr = s;
+ return YYL_RETRY;
+}
+
+static int
+yyl_fatcomma(pTHX_ char *s, STRLEN len)
+{
+ CLINE;
+ pl_yylval.opval
+ = newSVOP(OP_CONST, 0,
+ S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
+ pl_yylval.opval->op_private = OPpCONST_BARE;
+ TERM(BAREWORD);
+}
+
+static int
+yyl_safe_bareword(pTHX_ char *s, const char lastchar)
+{
+ if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
+ && PL_parser->saw_infix_sigil)
+ {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
+ "Operator or semicolon missing before %c%" UTF8f,
+ lastchar,
+ UTF8fARG(UTF, strlen(PL_tokenbuf),
+ PL_tokenbuf));
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
+ "Ambiguous use of %c resolved as operator %c",
+ lastchar, lastchar);
+ }
+ TOKEN(BAREWORD);
+}
+
+static int
+yyl_constant_op(pTHX_ char *s, SV *sv, CV *cv, OP *rv2cv_op, PADOFFSET off)
+{
+ if (sv) {
+ op_free(rv2cv_op);
+ SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
+ ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
+ if (SvTYPE(sv) == SVt_PVAV)
+ pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
+ pl_yylval.opval);
+ else {
+ pl_yylval.opval->op_private = 0;
+ pl_yylval.opval->op_folded = 1;
+ pl_yylval.opval->op_flags |= OPf_SPECIAL;
+ }
+ TOKEN(BAREWORD);
+ }
+
+ op_free(pl_yylval.opval);
+ pl_yylval.opval =
+ off ? newCVREF(0, rv2cv_op) : rv2cv_op;
+ pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
+ PL_last_lop = PL_oldbufptr;
+ PL_last_lop_op = OP_ENTERSUB;
+
+ /* Is there a prototype? */
+ if (SvPOK(cv)) {
+ int k = yyl_subproto(aTHX_ s, cv);
+ if (k != KEY_NULL)
+ return k;
+ }
+
+ NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
+ PL_expect = XTERM;
+ force_next(off ? PRIVATEREF : BAREWORD);
+ if (!PL_lex_allbrackets
+ && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
+ {
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
+ }
+
+ TOKEN(NOAMP);
+}
+
+/* Honour "reserved word" warnings, and enforce strict subs */
+static void
+yyl_strictwarn_bareword(pTHX_ const char lastchar)
+{
+ /* after "print" and similar functions (corresponding to
+ * "F? L" in opcode.pl), whatever wasn't already parsed as
+ * a filehandle should be subject to "strict subs".
+ * Likewise for the optional indirect-object argument to system
+ * or exec, which can't be a bareword */
+ if ((PL_last_lop_op == OP_PRINT
+ || PL_last_lop_op == OP_PRTF
+ || PL_last_lop_op == OP_SAY
+ || PL_last_lop_op == OP_SYSTEM
+ || PL_last_lop_op == OP_EXEC)
+ && (PL_hints & HINT_STRICT_SUBS))
+ {
+ pl_yylval.opval->op_private |= OPpCONST_STRICT;
+ }
+
+ if (lastchar != '-' && ckWARN(WARN_RESERVED)) {
+ char *d = PL_tokenbuf;
+ while (isLOWER(*d))
+ d++;
+ if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0)) {
+ /* PL_warn_reserved is constant */
+ GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
+ Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
+ PL_tokenbuf);
+ GCC_DIAG_RESTORE_STMT;
+ }
+ }
+}
+
+static int
+yyl_just_a_word(pTHX_ char *s, STRLEN len, I32 orig_keyword, struct code c)
+{
+ int pkgname = 0;
+ const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
+ bool safebw;
+ bool no_op_error = FALSE;
+ /* Use this var to track whether intuit_method has been
+ called. intuit_method returns 0 or > 255. */
+ int key = 1;
+
+ if (PL_expect == XOPERATOR) {
+ if (PL_bufptr == PL_linestart) {
+ CopLINE_dec(PL_curcop);
+ Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
+ CopLINE_inc(PL_curcop);
+ }
+ else
+ /* We want to call no_op with s pointing after the
+ bareword, so defer it. But we want it to come
+ before the Bad name croak. */
+ no_op_error = TRUE;
+ }
+
+ /* Get the rest if it looks like a package qualifier */
+
+ if (*s == '\'' || (*s == ':' && s[1] == ':')) {
+ STRLEN morelen;
+ s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
+ TRUE, &morelen);
+ if (no_op_error) {
+ no_op("Bareword",s);
+ no_op_error = FALSE;
+ }
+ if (!morelen)
+ Perl_croak(aTHX_ "Bad name after %" UTF8f "%s",
+ UTF8fARG(UTF, len, PL_tokenbuf),
+ *s == '\'' ? "'" : "::");
+ len += morelen;
+ pkgname = 1;
+ }
+
+ if (no_op_error)
+ no_op("Bareword",s);
+
+ /* See if the name is "Foo::",
+ in which case Foo is a bareword
+ (and a package name). */
+
+ if (len > 2 && PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':') {
+ if (ckWARN(WARN_BAREWORD)
+ && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
+ Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
+ "Bareword \"%" UTF8f
+ "\" refers to nonexistent package",
+ UTF8fARG(UTF, len, PL_tokenbuf));
+ len -= 2;
+ PL_tokenbuf[len] = '\0';
+ c.gv = NULL;
+ c.gvp = 0;
+ safebw = TRUE;
+ }
+ else {
+ safebw = FALSE;
+ }
+
+ /* if we saw a global override before, get the right name */
+
+ if (!c.sv)
+ c.sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len);
+ if (c.gvp) {
+ SV *sv = newSVpvs("CORE::GLOBAL::");
+ sv_catsv(sv, c.sv);
+ SvREFCNT_dec(c.sv);
+ c.sv = sv;
+ }
+
+ /* Presume this is going to be a bareword of some sort. */
+ CLINE;
+ pl_yylval.opval = newSVOP(OP_CONST, 0, c.sv);
+ pl_yylval.opval->op_private = OPpCONST_BARE;
+
+ /* And if "Foo::", then that's what it certainly is. */
+ if (safebw)
+ return yyl_safe_bareword(aTHX_ s, lastchar);
+
+ if (!c.off) {
+ OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(c.sv));
+ const_op->op_private = OPpCONST_BARE;
+ c.rv2cv_op = newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
+ c.cv = c.lex
+ ? isGV(c.gv)
+ ? GvCV(c.gv)
+ : SvROK(c.gv) && SvTYPE(SvRV(c.gv)) == SVt_PVCV
+ ? (CV *)SvRV(c.gv)
+ : ((CV *)c.gv)
+ : rv2cv_op_cv(c.rv2cv_op, RV2CVOPCV_RETURN_STUB);
+ }
+
+ /* See if it's the indirect object for a list operator. */
+
+ if (PL_oldoldbufptr
+ && PL_oldoldbufptr < PL_bufptr
+ && (PL_oldoldbufptr == PL_last_lop
+ || PL_oldoldbufptr == PL_last_uni)
+ && /* NO SKIPSPACE BEFORE HERE! */
+ (PL_expect == XREF
+ || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7)
+ == OA_FILEREF))
+ {
+ bool immediate_paren = *s == '(';
+ SSize_t s_off;
+
+ /* (Now we can afford to cross potential line boundary.) */
+ s = skipspace(s);
+
+ /* intuit_method() can indirectly call lex_next_chunk(),
+ * invalidating s
+ */
+ s_off = s - SvPVX(PL_linestr);
+ /* Two barewords in a row may indicate method call. */
+ if ( ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
+ || *s == '$')
+ && (key = intuit_method(s, c.lex ? NULL : c.sv, c.cv)))
+ {
+ /* the code at method: doesn't use s */
+ goto method;
+ }
+ s = SvPVX(PL_linestr) + s_off;
+
+ /* If not a declared subroutine, it's an indirect object. */
+ /* (But it's an indir obj regardless for sort.) */
+ /* Also, if "_" follows a filetest operator, it's a bareword */
+
+ if (
+ ( !immediate_paren && (PL_last_lop_op == OP_SORT
+ || (!c.cv
+ && (PL_last_lop_op != OP_MAPSTART
+ && PL_last_lop_op != OP_GREPSTART))))
+ || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
+ && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK)
+ == OA_FILESTATOP))
+ )
+ {
+ PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
+ yyl_strictwarn_bareword(aTHX_ lastchar);
+ op_free(c.rv2cv_op);
+ return yyl_safe_bareword(aTHX_ s, lastchar);
+ }
+ }
+
+ PL_expect = XOPERATOR;
+ s = skipspace(s);
+
+ /* Is this a word before a => operator? */
+ if (*s == '=' && s[1] == '>' && !pkgname) {
+ op_free(c.rv2cv_op);
+ CLINE;
+ if (c.gvp || (c.lex && !c.off)) {
+ assert (cSVOPx(pl_yylval.opval)->op_sv == c.sv);
+ /* This is our own scalar, created a few lines
+ above, so this is safe. */
+ SvREADONLY_off(c.sv);
+ sv_setpv(c.sv, PL_tokenbuf);
+ if (UTF && !IN_BYTES
+ && is_utf8_string((U8*)PL_tokenbuf, len))
+ SvUTF8_on(c.sv);
+ SvREADONLY_on(c.sv);
+ }
+ TERM(BAREWORD);
+ }
+
+ /* If followed by a paren, it's certainly a subroutine. */
+ if (*s == '(') {
+ CLINE;
+ if (c.cv) {
+ char *d = s + 1;
+ while (SPACE_OR_TAB(*d))
+ d++;
+ if (*d == ')' && (c.sv = cv_const_sv_or_av(c.cv)))
+ return yyl_constant_op(aTHX_ d + 1, c.sv, c.cv, c.rv2cv_op, c.off);
+ }
+ NEXTVAL_NEXTTOKE.opval =
+ c.off ? c.rv2cv_op : pl_yylval.opval;
+ if (c.off)
+ op_free(pl_yylval.opval), force_next(PRIVATEREF);
+ else op_free(c.rv2cv_op), force_next(BAREWORD);
+ pl_yylval.ival = 0;
+ TOKEN('&');
+ }
+
+ /* If followed by var or block, call it a method (unless sub) */
+
+ if ((*s == '$' || *s == '{') && !c.cv && FEATURE_INDIRECT_IS_ENABLED) {
+ op_free(c.rv2cv_op);
+ PL_last_lop = PL_oldbufptr;
+ PL_last_lop_op = OP_METHOD;
+ if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
+ PL_expect = XBLOCKTERM;
+ PL_bufptr = s;
+ return REPORT(METHOD);
+ }
+
+ /* If followed by a bareword, see if it looks like indir obj. */
+
+ if ( key == 1
+ && !orig_keyword
+ && (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF) || *s == '$')
+ && (key = intuit_method(s, c.lex ? NULL : c.sv, c.cv)))
+ {
+ method:
+ if (c.lex && !c.off) {
+ assert(cSVOPx(pl_yylval.opval)->op_sv == c.sv);
+ SvREADONLY_off(c.sv);
+ sv_setpvn(c.sv, PL_tokenbuf, len);
+ if (UTF && !IN_BYTES
+ && is_utf8_string((U8*)PL_tokenbuf, len))
+ SvUTF8_on(c.sv);
+ else SvUTF8_off(c.sv);
+ }
+ op_free(c.rv2cv_op);
+ if (key == METHOD && !PL_lex_allbrackets
+ && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
+ {
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
+ }
+ return REPORT(key);
+ }
+
+ /* Not a method, so call it a subroutine (if defined) */
+
+ if (c.cv) {
+ /* Check for a constant sub */
+ c.sv = cv_const_sv_or_av(c.cv);
+ return yyl_constant_op(aTHX_ s, c.sv, c.cv, c.rv2cv_op, c.off);
+ }
+
+ /* Call it a bare word */
+
+ if (PL_hints & HINT_STRICT_SUBS)
+ pl_yylval.opval->op_private |= OPpCONST_STRICT;
+ else
+ yyl_strictwarn_bareword(aTHX_ lastchar);
+
+ op_free(c.rv2cv_op);
+
+ return yyl_safe_bareword(aTHX_ s, lastchar);
+}
+
+static int
+yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct code c)
+{
+ switch (key) {
+ default: /* not a keyword */
+ return yyl_just_a_word(aTHX_ s, len, orig_keyword, c);
+
+ case KEY___FILE__:
+ FUN0OP( newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0)) );
+
+ case KEY___LINE__:
+ FUN0OP(
+ newSVOP(OP_CONST, 0,
+ Perl_newSVpvf(aTHX_ "%" IVdf, (IV)CopLINE(PL_curcop)))
+ );
+
+ case KEY___PACKAGE__:
+ FUN0OP(
+ newSVOP(OP_CONST, 0, (PL_curstash
+ ? newSVhek(HvNAME_HEK(PL_curstash))
+ : &PL_sv_undef))
+ );
+
+ case KEY___DATA__:
+ case KEY___END__:
+ if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D'))
+ yyl_data_handle(aTHX);
+ return yyl_fake_eof(aTHX_ LEX_FAKE_EOF, FALSE, s);
+
+ case KEY___SUB__:
+ FUN0OP(CvCLONE(PL_compcv)
+ ? newOP(OP_RUNCV, 0)
+ : newPVOP(OP_RUNCV,0,NULL));
+
+ case KEY_AUTOLOAD:
+ case KEY_DESTROY:
+ case KEY_BEGIN:
+ case KEY_UNITCHECK:
+ case KEY_CHECK:
+ case KEY_INIT:
+ case KEY_END:
+ if (PL_expect == XSTATE)
+ return yyl_sub(aTHX_ PL_bufptr, key);
+ return yyl_just_a_word(aTHX_ s, len, orig_keyword, c);
+
+ case KEY_abs:
+ UNI(OP_ABS);
+
+ case KEY_alarm:
+ UNI(OP_ALARM);
+
+ case KEY_accept:
+ LOP(OP_ACCEPT,XTERM);
+
+ case KEY_and:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
+ return REPORT(0);
+ OPERATOR(ANDOP);
+
+ case KEY_atan2:
+ LOP(OP_ATAN2,XTERM);
+
+ case KEY_bind:
+ LOP(OP_BIND,XTERM);
+
+ case KEY_binmode:
+ LOP(OP_BINMODE,XTERM);
+
+ case KEY_bless:
+ LOP(OP_BLESS,XTERM);
+
+ case KEY_break:
+ FUN0(OP_BREAK);
+
+ case KEY_chop:
+ UNI(OP_CHOP);
+
+ case KEY_continue:
+ /* We have to disambiguate the two senses of
+ "continue". If the next token is a '{' then
+ treat it as the start of a continue block;
+ otherwise treat it as a control operator.
+ */
+ s = skipspace(s);
+ if (*s == '{')
+ PREBLOCK(CONTINUE);
+ else
+ FUN0(OP_CONTINUE);
+
+ case KEY_chdir:
+ /* may use HOME */
+ (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
+ UNI(OP_CHDIR);
+
+ case KEY_close:
+ UNI(OP_CLOSE);
+
+ case KEY_closedir:
+ UNI(OP_CLOSEDIR);
+
+ case KEY_cmp:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ NCEop(OP_SCMP);
+
+ case KEY_caller:
+ UNI(OP_CALLER);
+
+ case KEY_crypt:
- case '$':
- CLINE;
+ LOP(OP_CRYPT,XTERM);
- if (PL_expect == XPOSTDEREF) {
- if (s[1] == '#') {
- s++;
- POSTDEREF(DOLSHARP);
- }
- POSTDEREF('$');
- }
+ case KEY_chmod:
+ LOP(OP_CHMOD,XTERM);
- if ( s[1] == '#'
- && ( isIDFIRST_lazy_if_safe(s+2, PL_bufend, UTF)
- || strchr("{$:+-@", s[2])))
- {
- PL_tokenbuf[0] = '@';
- s = scan_ident(s + 1, PL_tokenbuf + 1,
- sizeof PL_tokenbuf - 1, FALSE);
- if (PL_expect == XOPERATOR) {
- d = s;
- if (PL_bufptr > s) {
- d = PL_bufptr-1;
- PL_bufptr = PL_oldbufptr;
- }
- no_op("Array length", d);
- }
- if (!PL_tokenbuf[1])
- PREREF(DOLSHARP);
- PL_expect = XOPERATOR;
- force_ident_maybe_lex('#');
- TOKEN(DOLSHARP);
- }
-
- PL_tokenbuf[0] = '$';
- s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
- if (PL_expect == XOPERATOR) {
- d = s;
- if (PL_bufptr > s) {
- d = PL_bufptr-1;
- PL_bufptr = PL_oldbufptr;
- }
- no_op("Scalar", d);
- }
- if (!PL_tokenbuf[1]) {
- if (s == PL_bufend)
- yyerror("Final $ should be \\$ or $name");
- PREREF('$');
- }
+ case KEY_chown:
+ LOP(OP_CHOWN,XTERM);
- d = s;
- {
- const char tmp = *s;
- if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
- s = skipspace(s);
-
- if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
- && intuit_more(s, PL_bufend)) {
- if (*s == '[') {
- PL_tokenbuf[0] = '@';
- if (ckWARN(WARN_SYNTAX)) {
- char *t = s+1;
-
- while ( isSPACE(*t)
- || isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)
- || *t == '$')
- {
- t += UTF ? UTF8SKIP(t) : 1;
- }
- if (*t++ == ',') {
- PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
- while (t < PL_bufend && *t != ']')
- t++;
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Multidimensional syntax %" UTF8f " not supported",
- UTF8fARG(UTF,(int)((t - PL_bufptr) + 1), PL_bufptr));
- }
- }
- }
- else if (*s == '{') {
- char *t;
- PL_tokenbuf[0] = '%';
- if ( strEQ(PL_tokenbuf+1, "SIG")
- && ckWARN(WARN_SYNTAX)
- && (t = (char *) memchr(s, '}', PL_bufend - s))
- && (t = (char *) memchr(t, '=', PL_bufend - t)))
- {
- char tmpbuf[sizeof PL_tokenbuf];
- do {
- t++;
- } while (isSPACE(*t));
- if (isIDFIRST_lazy_if_safe(t, PL_bufend, UTF)) {
- STRLEN len;
- t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
- &len);
- while (isSPACE(*t))
- t++;
- if ( *t == ';'
- && get_cvn_flags(tmpbuf, len, UTF
- ? SVf_UTF8
- : 0))
- {
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "You need to quote \"%" UTF8f "\"",
- UTF8fARG(UTF, len, tmpbuf));
- }
- }
- }
- }
- }
+ case KEY_connect:
+ LOP(OP_CONNECT,XTERM);
- PL_expect = XOPERATOR;
- if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
- const bool islop = (PL_last_lop == PL_oldoldbufptr);
- if (!islop || PL_last_lop_op == OP_GREPSTART)
- PL_expect = XOPERATOR;
- else if (strchr("$@\"'`q", *s))
- PL_expect = XTERM; /* e.g. print $fh "foo" */
- else if ( strchr("&*<%", *s)
- && isIDFIRST_lazy_if_safe(s+1, PL_bufend, UTF))
- {
- PL_expect = XTERM; /* e.g. print $fh &sub */
- }
- else if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
- char tmpbuf[sizeof PL_tokenbuf];
- int t2;
- scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
- if ((t2 = keyword(tmpbuf, len, 0))) {
- /* binary operators exclude handle interpretations */
- switch (t2) {
- case -KEY_x:
- case -KEY_eq:
- case -KEY_ne:
- case -KEY_gt:
- case -KEY_lt:
- case -KEY_ge:
- case -KEY_le:
- case -KEY_cmp:
- break;
- default:
- PL_expect = XTERM; /* e.g. print $fh length() */
- break;
- }
- }
- else {
- PL_expect = XTERM; /* e.g. print $fh subr() */
- }
- }
- else if (isDIGIT(*s))
- PL_expect = XTERM; /* e.g. print $fh 3 */
- else if (*s == '.' && isDIGIT(s[1]))
- PL_expect = XTERM; /* e.g. print $fh .3 */
- else if ((*s == '?' || *s == '-' || *s == '+')
- && !isSPACE(s[1]) && s[1] != '=')
- PL_expect = XTERM; /* e.g. print $fh -1 */
- else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
- && s[1] != '/')
- PL_expect = XTERM; /* e.g. print $fh /.../
- XXX except DORDOR operator
- */
- else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
- && s[2] != '=')
- PL_expect = XTERM; /* print $fh <<"EOF" */
- }
- }
- force_ident_maybe_lex('$');
- TOKEN('$');
+ case KEY_chr:
+ UNI(OP_CHR);
- case '@':
- if (PL_expect == XPOSTDEREF)
- POSTDEREF('@');
- PL_tokenbuf[0] = '@';
- s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
- if (PL_expect == XOPERATOR) {
- d = s;
- if (PL_bufptr > s) {
- d = PL_bufptr-1;
- PL_bufptr = PL_oldbufptr;
- }
- no_op("Array", d);
- }
- pl_yylval.ival = 0;
- if (!PL_tokenbuf[1]) {
- PREREF('@');
- }
- if (PL_lex_state == LEX_NORMAL)
- s = skipspace(s);
- if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
- && intuit_more(s, PL_bufend))
- {
- if (*s == '{')
- PL_tokenbuf[0] = '%';
+ case KEY_cos:
+ UNI(OP_COS);
- /* Warn about @ where they meant $. */
- if (*s == '[' || *s == '{') {
- if (ckWARN(WARN_SYNTAX)) {
- S_check_scalar_slice(aTHX_ s);
- }
- }
- }
- PL_expect = XOPERATOR;
- force_ident_maybe_lex('@');
- TERM('@');
+ case KEY_chroot:
+ UNI(OP_CHROOT);
- case '/': /* may be division, defined-or, or pattern */
- if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
- if (!PL_lex_allbrackets && PL_lex_fakeeof >=
- (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
- TOKEN(0);
- s += 2;
- AOPERATOR(DORDOR);
- }
- else if (PL_expect == XOPERATOR) {
- s++;
- if (*s == '=' && !PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
- {
- s--;
- TOKEN(0);
- }
- Mop(OP_DIVIDE);
+ case KEY_default:
+ PREBLOCK(DEFAULT);
+
+ case KEY_do:
+ return yyl_do(aTHX_ s, orig_keyword);
+
+ case KEY_die:
+ PL_hints |= HINT_BLOCK_SCOPE;
+ LOP(OP_DIE,XTERM);
+
+ case KEY_defined:
+ UNI(OP_DEFINED);
+
+ case KEY_delete:
+ UNI(OP_DELETE);
+
+ case KEY_dbmopen:
+ Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
+ STR_WITH_LEN("NDBM_File::"),
+ STR_WITH_LEN("DB_File::"),
+ STR_WITH_LEN("GDBM_File::"),
+ STR_WITH_LEN("SDBM_File::"),
+ STR_WITH_LEN("ODBM_File::"),
+ NULL);
+ LOP(OP_DBMOPEN,XTERM);
+
+ case KEY_dbmclose:
+ UNI(OP_DBMCLOSE);
+
+ case KEY_dump:
+ LOOPX(OP_DUMP);
+
+ case KEY_else:
+ PREBLOCK(ELSE);
+
+ case KEY_elsif:
+ pl_yylval.ival = CopLINE(PL_curcop);
+ OPERATOR(ELSIF);
+
+ case KEY_eq:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChEop(OP_SEQ);
+
+ case KEY_exists:
+ UNI(OP_EXISTS);
+
+ case KEY_exit:
+ UNI(OP_EXIT);
+
+ case KEY_eval:
+ s = skipspace(s);
+ if (*s == '{') { /* block eval */
+ PL_expect = XTERMBLOCK;
+ UNIBRACK(OP_ENTERTRY);
+ }
+ else { /* string eval */
+ PL_expect = XTERM;
+ UNIBRACK(OP_ENTEREVAL);
}
- else {
- /* Disable warning on "study /blah/" */
- if ( PL_oldoldbufptr == PL_last_uni
- && ( *PL_last_uni != 's' || s - PL_last_uni < 5
- || memNE(PL_last_uni, "study", 5)
- || isWORDCHAR_lazy_if_safe(PL_last_uni+5, PL_bufend, UTF)
- ))
- check_uni();
- s = scan_pat(s,OP_MATCH);
- TERM(sublex_start());
- }
- case '?': /* conditional */
- s++;
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
- {
- s--;
- TOKEN(0);
- }
- PL_lex_allbrackets++;
- OPERATOR('?');
+ case KEY_evalbytes:
+ PL_expect = XTERM;
+ UNIBRACK(-OP_ENTEREVAL);
- case '.':
- if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
-#ifdef PERL_STRICT_CR
- && s[1] == '\n'
-#else
- && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
-#endif
- && (s == PL_linestart || s[-1] == '\n') )
- {
- PL_expect = XSTATE;
- formbrack = 2; /* dot seen where arguments expected */
- goto rightbracket;
- }
- if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
- s += 3;
- OPERATOR(YADAYADA);
- }
- if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
- char tmp = *s++;
- if (*s == tmp) {
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_RANGE)
- {
- s--;
- TOKEN(0);
- }
- s++;
- if (*s == tmp) {
- s++;
- pl_yylval.ival = OPf_SPECIAL;
- }
- else
- pl_yylval.ival = 0;
- OPERATOR(DOTDOT);
- }
- if (*s == '=' && !PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
- {
- s--;
- TOKEN(0);
- }
- Aop(OP_CONCAT);
- }
- /* FALLTHROUGH */
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- s = scan_num(s, &pl_yylval);
- DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
- if (PL_expect == XOPERATOR)
- no_op("Number",s);
- TERM(THING);
+ case KEY_eof:
+ UNI(OP_EOF);
- case '\'':
- s = scan_str(s,FALSE,FALSE,FALSE,NULL);
- if (!s)
- missingterm(NULL, 0);
- COPLINE_SET_FROM_MULTI_END;
- DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
- if (PL_expect == XOPERATOR) {
- no_op("String",s);
- }
- pl_yylval.ival = OP_CONST;
- TERM(sublex_start());
+ case KEY_exp:
+ UNI(OP_EXP);
- case '"':
- s = scan_str(s,FALSE,FALSE,FALSE,NULL);
- DEBUG_T( {
- if (s)
- printbuf("### Saw string before %s\n", s);
- else
- PerlIO_printf(Perl_debug_log,
- "### Saw unterminated string\n");
- } );
- if (PL_expect == XOPERATOR) {
- no_op("String",s);
- }
- if (!s)
- missingterm(NULL, 0);
- pl_yylval.ival = OP_CONST;
- /* FIXME. I think that this can be const if char *d is replaced by
- more localised variables. */
- for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
- if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
- pl_yylval.ival = OP_STRINGIFY;
- break;
- }
- }
- if (pl_yylval.ival == OP_CONST)
- COPLINE_SET_FROM_MULTI_END;
- TERM(sublex_start());
+ case KEY_each:
+ UNI(OP_EACH);
- case '`':
- s = scan_str(s,FALSE,FALSE,FALSE,NULL);
- DEBUG_T( {
- if (s)
- printbuf("### Saw backtick string before %s\n", s);
- else
- PerlIO_printf(Perl_debug_log,
- "### Saw unterminated backtick string\n");
- } );
- if (PL_expect == XOPERATOR)
- no_op("Backticks",s);
- if (!s)
- missingterm(NULL, 0);
- pl_yylval.ival = OP_BACKTICK;
- TERM(sublex_start());
+ case KEY_exec:
+ LOP(OP_EXEC,XREF);
- case '\\':
- s++;
- if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
- && isDIGIT(*s))
- Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
- *s, *s);
- if (PL_expect == XOPERATOR)
- no_op("Backslash",s);
- OPERATOR(REFGEN);
+ case KEY_endhostent:
+ FUN0(OP_EHOSTENT);
- case 'v':
- if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
- char *start = s + 2;
- while (isDIGIT(*start) || *start == '_')
- start++;
- if (*start == '.' && isDIGIT(start[1])) {
- s = scan_num(s, &pl_yylval);
- TERM(THING);
- }
- else if ((*start == ':' && start[1] == ':')
- || (PL_expect == XSTATE && *start == ':'))
- goto keylookup;
- else if (PL_expect == XSTATE) {
- d = start;
- while (d < PL_bufend && isSPACE(*d)) d++;
- if (*d == ':') goto keylookup;
- }
- /* avoid v123abc() or $h{v1}, allow C<print v10;> */
- if (!isALPHA(*start) && (PL_expect == XTERM
- || PL_expect == XREF || PL_expect == XSTATE
- || PL_expect == XTERMORDORDOR)) {
- GV *const gv = gv_fetchpvn_flags(s, start - s,
- UTF ? SVf_UTF8 : 0, SVt_PVCV);
- if (!gv) {
- s = scan_num(s, &pl_yylval);
- TERM(THING);
- }
- }
- }
- goto keylookup;
- case 'x':
- if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
- s++;
- Mop(OP_REPEAT);
- }
- goto keylookup;
+ case KEY_endnetent:
+ FUN0(OP_ENETENT);
- case '_':
- case 'a': case 'A':
- case 'b': case 'B':
- case 'c': case 'C':
- case 'd': case 'D':
- case 'e': case 'E':
- case 'f': case 'F':
- case 'g': case 'G':
- case 'h': case 'H':
- case 'i': case 'I':
- case 'j': case 'J':
- case 'k': case 'K':
- case 'l': case 'L':
- case 'm': case 'M':
- case 'n': case 'N':
- case 'o': case 'O':
- case 'p': case 'P':
- case 'q': case 'Q':
- case 'r': case 'R':
- case 's': case 'S':
- case 't': case 'T':
- case 'u': case 'U':
- case 'V':
- case 'w': case 'W':
- case 'X':
- case 'y': case 'Y':
- case 'z': case 'Z':
+ case KEY_endservent:
+ FUN0(OP_ESERVENT);
- keylookup: {
- bool anydelim;
- bool lex;
- I32 tmp;
- SV *sv;
- CV *cv;
- PADOFFSET off;
- OP *rv2cv_op;
-
- lex = FALSE;
- orig_keyword = 0;
- off = 0;
- sv = NULL;
- cv = NULL;
- gv = NULL;
- gvp = NULL;
- rv2cv_op = NULL;
+ case KEY_endprotoent:
+ FUN0(OP_EPROTOENT);
- PL_bufptr = s;
- s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
+ case KEY_endpwent:
+ FUN0(OP_EPWENT);
- /* Some keywords can be followed by any delimiter, including ':' */
- anydelim = word_takes_any_delimiter(PL_tokenbuf, len);
+ case KEY_endgrent:
+ FUN0(OP_EGRENT);
- /* x::* is just a word, unless x is "CORE" */
- if (!anydelim && *s == ':' && s[1] == ':') {
- if (memEQs(PL_tokenbuf, len, "CORE")) goto case_KEY_CORE;
- goto just_a_word;
- }
+ case KEY_for:
+ case KEY_foreach:
+ return yyl_foreach(aTHX_ s);
- d = s;
- while (d < PL_bufend && isSPACE(*d))
- d++; /* no comments skipped here, or s### is misparsed */
+ case KEY_formline:
+ LOP(OP_FORMLINE,XTERM);
- /* Is this a word before a => operator? */
- if (*d == '=' && d[1] == '>') {
- fat_arrow:
- CLINE;
- pl_yylval.opval
- = newSVOP(OP_CONST, 0,
- S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
- pl_yylval.opval->op_private = OPpCONST_BARE;
- TERM(BAREWORD);
- }
+ case KEY_fork:
+ FUN0(OP_FORK);
- /* Check for plugged-in keyword */
- {
- OP *o;
- int result;
- char *saved_bufptr = PL_bufptr;
- PL_bufptr = s;
- result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
- s = PL_bufptr;
- if (result == KEYWORD_PLUGIN_DECLINE) {
- /* not a plugged-in keyword */
- PL_bufptr = saved_bufptr;
- } else if (result == KEYWORD_PLUGIN_STMT) {
- pl_yylval.opval = o;
- CLINE;
- if (!PL_nexttoke) PL_expect = XSTATE;
- return REPORT(PLUGSTMT);
- } else if (result == KEYWORD_PLUGIN_EXPR) {
- pl_yylval.opval = o;
- CLINE;
- if (!PL_nexttoke) PL_expect = XOPERATOR;
- return REPORT(PLUGEXPR);
- } else {
- Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
- PL_tokenbuf);
- }
- }
+ case KEY_fc:
+ UNI(OP_FC);
+
+ case KEY_fcntl:
+ LOP(OP_FCNTL,XTERM);
+
+ case KEY_fileno:
+ UNI(OP_FILENO);
+
+ case KEY_flock:
+ LOP(OP_FLOCK,XTERM);
+
+ case KEY_gt:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChRop(OP_SGT);
+
+ case KEY_ge:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChRop(OP_SGE);
+
+ case KEY_grep:
+ LOP(OP_GREPSTART, XREF);
+
+ case KEY_goto:
+ LOOPX(OP_GOTO);
+
+ case KEY_gmtime:
+ UNI(OP_GMTIME);
+
+ case KEY_getc:
+ UNIDOR(OP_GETC);
+
+ case KEY_getppid:
+ FUN0(OP_GETPPID);
+
+ case KEY_getpgrp:
+ UNI(OP_GETPGRP);
+
+ case KEY_getpriority:
+ LOP(OP_GETPRIORITY,XTERM);
+
+ case KEY_getprotobyname:
+ UNI(OP_GPBYNAME);
+
+ case KEY_getprotobynumber:
+ LOP(OP_GPBYNUMBER,XTERM);
+
+ case KEY_getprotoent:
+ FUN0(OP_GPROTOENT);
+
+ case KEY_getpwent:
+ FUN0(OP_GPWENT);
+
+ case KEY_getpwnam:
+ UNI(OP_GPWNAM);
+
+ case KEY_getpwuid:
+ UNI(OP_GPWUID);
+
+ case KEY_getpeername:
+ UNI(OP_GETPEERNAME);
+
+ case KEY_gethostbyname:
+ UNI(OP_GHBYNAME);
+
+ case KEY_gethostbyaddr:
+ LOP(OP_GHBYADDR,XTERM);
+
+ case KEY_gethostent:
+ FUN0(OP_GHOSTENT);
+
+ case KEY_getnetbyname:
+ UNI(OP_GNBYNAME);
+
+ case KEY_getnetbyaddr:
+ LOP(OP_GNBYADDR,XTERM);
+
+ case KEY_getnetent:
+ FUN0(OP_GNETENT);
+
+ case KEY_getservbyname:
+ LOP(OP_GSBYNAME,XTERM);
+
+ case KEY_getservbyport:
+ LOP(OP_GSBYPORT,XTERM);
+
+ case KEY_getservent:
+ FUN0(OP_GSERVENT);
+
+ case KEY_getsockname:
+ UNI(OP_GETSOCKNAME);
+
+ case KEY_getsockopt:
+ LOP(OP_GSOCKOPT,XTERM);
+
+ case KEY_getgrent:
+ FUN0(OP_GGRENT);
- /* Check for built-in keyword */
- tmp = keyword(PL_tokenbuf, len, 0);
-
- /* Is this a label? */
- if (!anydelim && PL_expect == XSTATE
- && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
- s = d + 1;
- pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
- pl_yylval.pval[len] = '\0';
- pl_yylval.pval[len+1] = UTF ? 1 : 0;
- CLINE;
- TOKEN(LABEL);
- }
-
- /* Check for lexical sub */
- if (PL_expect != XOPERATOR) {
- char tmpbuf[sizeof PL_tokenbuf + 1];
- *tmpbuf = '&';
- Copy(PL_tokenbuf, tmpbuf+1, len, char);
- off = pad_findmy_pvn(tmpbuf, len+1, 0);
- if (off != NOT_IN_PAD) {
- assert(off); /* we assume this is boolean-true below */
- if (PAD_COMPNAME_FLAGS_isOUR(off)) {
- HV * const stash = PAD_COMPNAME_OURSTASH(off);
- HEK * const stashname = HvNAME_HEK(stash);
- sv = newSVhek(stashname);
- sv_catpvs(sv, "::");
- sv_catpvn_flags(sv, PL_tokenbuf, len,
- (UTF ? SV_CATUTF8 : SV_CATBYTES));
- gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
- SVt_PVCV);
- off = 0;
- if (!gv) {
- sv_free(sv);
- sv = NULL;
- goto just_a_word;
- }
- }
- else {
- rv2cv_op = newOP(OP_PADANY, 0);
- rv2cv_op->op_targ = off;
- cv = find_lexical_cv(off);
- }
- lex = TRUE;
- goto just_a_word;
- }
- off = 0;
- }
-
- if (tmp < 0) { /* second-class keyword? */
- GV *ogv = NULL; /* override (winner) */
- GV *hgv = NULL; /* hidden (loser) */
- if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
- CV *cv;
- if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
- (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
- SVt_PVCV))
- && (cv = GvCVu(gv)))
- {
- if (GvIMPORTED_CV(gv))
- ogv = gv;
- else if (! CvMETHOD(cv))
- hgv = gv;
- }
- if (!ogv
- && (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
- len, FALSE))
- && (gv = *gvp)
- && (isGV_with_GP(gv)
- ? GvCVu(gv) && GvIMPORTED_CV(gv)
- : SvPCS_IMPORTED(gv)
- && (gv_init(gv, PL_globalstash, PL_tokenbuf,
- len, 0), 1)))
- {
- ogv = gv;
- }
- }
- if (ogv) {
- orig_keyword = tmp;
- tmp = 0; /* overridden by import or by GLOBAL */
- }
- else if (gv && !gvp
- && -tmp==KEY_lock /* XXX generalizable kludge */
- && GvCVu(gv))
- {
- tmp = 0; /* any sub overrides "weak" keyword */
- }
- else { /* no override */
- tmp = -tmp;
- if (tmp == KEY_dump) {
- Perl_croak(aTHX_ "dump() must be written as CORE::dump() as of Perl 5.30");
- }
- gv = NULL;
- gvp = 0;
- if (hgv && tmp != KEY_x) /* never ambiguous */
- Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Ambiguous call resolved as CORE::%s(), "
- "qualify as such or use &",
- GvENAME(hgv));
- }
- }
+ case KEY_getgrnam:
+ UNI(OP_GGRNAM);
- if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
- && (!anydelim || *s != '#')) {
- /* no override, and not s### either; skipspace is safe here
- * check for => on following line */
- bool arrow;
- STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
- STRLEN soff = s - SvPVX(PL_linestr);
- s = peekspace(s);
- arrow = *s == '=' && s[1] == '>';
- PL_bufptr = SvPVX(PL_linestr) + bufoff;
- s = SvPVX(PL_linestr) + soff;
- if (arrow)
- goto fat_arrow;
- }
-
- reserved_word:
- switch (tmp) {
-
- /* Trade off - by using this evil construction we can pull the
- variable gv into the block labelled keylookup. If not, then
- we have to give it function scope so that the goto from the
- earlier ':' case doesn't bypass the initialisation. */
- just_a_word_zero_gv:
- sv = NULL;
- cv = NULL;
- gv = NULL;
- gvp = NULL;
- rv2cv_op = NULL;
- orig_keyword = 0;
- lex = 0;
- off = 0;
- /* FALLTHROUGH */
- default: /* not a keyword */
- just_a_word: {
- int pkgname = 0;
- const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
- bool safebw;
- bool no_op_error = FALSE;
-
- if (PL_expect == XOPERATOR) {
- if (PL_bufptr == PL_linestart) {
- CopLINE_dec(PL_curcop);
- Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
- CopLINE_inc(PL_curcop);
- }
- else
- /* We want to call no_op with s pointing after the
- bareword, so defer it. But we want it to come
- before the Bad name croak. */
- no_op_error = TRUE;
- }
+ case KEY_getgrgid:
+ UNI(OP_GGRGID);
- /* Get the rest if it looks like a package qualifier */
+ case KEY_getlogin:
+ FUN0(OP_GETLOGIN);
- if (*s == '\'' || (*s == ':' && s[1] == ':')) {
- STRLEN morelen;
- s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
- TRUE, &morelen);
- if (no_op_error) {
- no_op("Bareword",s);
- no_op_error = FALSE;
- }
- if (!morelen)
- Perl_croak(aTHX_ "Bad name after %" UTF8f "%s",
- UTF8fARG(UTF, len, PL_tokenbuf),
- *s == '\'' ? "'" : "::");
- len += morelen;
- pkgname = 1;
- }
+ case KEY_given:
+ pl_yylval.ival = CopLINE(PL_curcop);
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
+ "given is experimental");
+ OPERATOR(GIVEN);
- if (no_op_error)
- no_op("Bareword",s);
+ case KEY_glob:
+ LOP( orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB, XTERM );
- /* See if the name is "Foo::",
- in which case Foo is a bareword
- (and a package name). */
+ case KEY_hex:
+ UNI(OP_HEX);
- if (len > 2
- && PL_tokenbuf[len - 2] == ':'
- && PL_tokenbuf[len - 1] == ':')
- {
- if (ckWARN(WARN_BAREWORD)
- && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
- Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
- "Bareword \"%" UTF8f
- "\" refers to nonexistent package",
- UTF8fARG(UTF, len, PL_tokenbuf));
- len -= 2;
- PL_tokenbuf[len] = '\0';
- gv = NULL;
- gvp = 0;
- safebw = TRUE;
- }
- else {
- safebw = FALSE;
- }
+ case KEY_if:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ return REPORT(0);
+ pl_yylval.ival = CopLINE(PL_curcop);
+ OPERATOR(IF);
- /* if we saw a global override before, get the right name */
+ case KEY_index:
+ LOP(OP_INDEX,XTERM);
- if (!sv)
- sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
- len);
- if (gvp) {
- SV * const tmp_sv = sv;
- sv = newSVpvs("CORE::GLOBAL::");
- sv_catsv(sv, tmp_sv);
- SvREFCNT_dec(tmp_sv);
- }
+ case KEY_int:
+ UNI(OP_INT);
+ case KEY_ioctl:
+ LOP(OP_IOCTL,XTERM);
- /* Presume this is going to be a bareword of some sort. */
- CLINE;
- pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
- pl_yylval.opval->op_private = OPpCONST_BARE;
+ case KEY_isa:
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__ISA), "isa is experimental");
+ NCRop(OP_ISA);
- /* And if "Foo::", then that's what it certainly is. */
- if (safebw)
- goto safe_bareword;
+ case KEY_join:
+ LOP(OP_JOIN,XTERM);
- if (!off)
- {
- OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
- const_op->op_private = OPpCONST_BARE;
- rv2cv_op =
- newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
- cv = lex
- ? isGV(gv)
- ? GvCV(gv)
- : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
- ? (CV *)SvRV(gv)
- : ((CV *)gv)
- : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
- }
+ case KEY_keys:
+ UNI(OP_KEYS);
- /* Use this var to track whether intuit_method has been
- called. intuit_method returns 0 or > 255. */
- tmp = 1;
+ case KEY_kill:
+ LOP(OP_KILL,XTERM);
- /* See if it's the indirect object for a list operator. */
+ case KEY_last:
+ LOOPX(OP_LAST);
- if (PL_oldoldbufptr
- && PL_oldoldbufptr < PL_bufptr
- && (PL_oldoldbufptr == PL_last_lop
- || PL_oldoldbufptr == PL_last_uni)
- && /* NO SKIPSPACE BEFORE HERE! */
- (PL_expect == XREF
- || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7)
- == OA_FILEREF))
- {
- bool immediate_paren = *s == '(';
- SSize_t s_off;
-
- /* (Now we can afford to cross potential line boundary.) */
- s = skipspace(s);
-
- /* intuit_method() can indirectly call lex_next_chunk(),
- * invalidating s
- */
- s_off = s - SvPVX(PL_linestr);
- /* Two barewords in a row may indicate method call. */
- if ( ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
- || *s == '$')
- && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
- {
- /* the code at method: doesn't use s */
- goto method;
- }
- s = SvPVX(PL_linestr) + s_off;
-
- /* If not a declared subroutine, it's an indirect object. */
- /* (But it's an indir obj regardless for sort.) */
- /* Also, if "_" follows a filetest operator, it's a bareword */
-
- if (
- ( !immediate_paren && (PL_last_lop_op == OP_SORT
- || (!cv
- && (PL_last_lop_op != OP_MAPSTART
- && PL_last_lop_op != OP_GREPSTART))))
- || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
- && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK)
- == OA_FILESTATOP))
- )
- {
- PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
- goto bareword;
- }
- }
+ case KEY_lc:
+ UNI(OP_LC);
- PL_expect = XOPERATOR;
- s = skipspace(s);
-
- /* Is this a word before a => operator? */
- if (*s == '=' && s[1] == '>' && !pkgname) {
- op_free(rv2cv_op);
- CLINE;
- if (gvp || (lex && !off)) {
- assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
- /* This is our own scalar, created a few lines
- above, so this is safe. */
- SvREADONLY_off(sv);
- sv_setpv(sv, PL_tokenbuf);
- if (UTF && !IN_BYTES
- && is_utf8_string((U8*)PL_tokenbuf, len))
- SvUTF8_on(sv);
- SvREADONLY_on(sv);
- }
- TERM(BAREWORD);
- }
+ case KEY_lcfirst:
+ UNI(OP_LCFIRST);
- /* If followed by a paren, it's certainly a subroutine. */
- if (*s == '(') {
- CLINE;
- if (cv) {
- d = s + 1;
- while (SPACE_OR_TAB(*d))
- d++;
- if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
- s = d + 1;
- goto its_constant;
- }
- }
- NEXTVAL_NEXTTOKE.opval =
- off ? rv2cv_op : pl_yylval.opval;
- if (off)
- op_free(pl_yylval.opval), force_next(PRIVATEREF);
- else op_free(rv2cv_op), force_next(BAREWORD);
- pl_yylval.ival = 0;
- TOKEN('&');
- }
+ case KEY_local:
+ OPERATOR(LOCAL);
- /* If followed by var or block, call it a method (unless sub) */
+ case KEY_length:
+ UNI(OP_LENGTH);
- if ((*s == '$' || *s == '{') && !cv) {
- op_free(rv2cv_op);
- PL_last_lop = PL_oldbufptr;
- PL_last_lop_op = OP_METHOD;
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
- {
- PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
- }
- PL_expect = XBLOCKTERM;
- PL_bufptr = s;
- return REPORT(METHOD);
- }
+ case KEY_lt:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChRop(OP_SLT);
- /* If followed by a bareword, see if it looks like indir obj. */
+ case KEY_le:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChRop(OP_SLE);
- if ( tmp == 1
- && !orig_keyword
- && (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF) || *s == '$')
- && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
- {
- method:
- if (lex && !off) {
- assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
- SvREADONLY_off(sv);
- sv_setpvn(sv, PL_tokenbuf, len);
- if (UTF && !IN_BYTES
- && is_utf8_string((U8*)PL_tokenbuf, len))
- SvUTF8_on (sv);
- else SvUTF8_off(sv);
- }
- op_free(rv2cv_op);
- if (tmp == METHOD && !PL_lex_allbrackets
- && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
- {
- PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
- }
- return REPORT(tmp);
- }
+ case KEY_localtime:
+ UNI(OP_LOCALTIME);
- /* Not a method, so call it a subroutine (if defined) */
-
- if (cv) {
- /* Check for a constant sub */
- if ((sv = cv_const_sv_or_av(cv))) {
- its_constant:
- op_free(rv2cv_op);
- SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
- ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
- if (SvTYPE(sv) == SVt_PVAV)
- pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
- pl_yylval.opval);
- else {
- pl_yylval.opval->op_private = 0;
- pl_yylval.opval->op_folded = 1;
- pl_yylval.opval->op_flags |= OPf_SPECIAL;
- }
- TOKEN(BAREWORD);
- }
+ case KEY_log:
+ UNI(OP_LOG);
- op_free(pl_yylval.opval);
- pl_yylval.opval =
- off ? newCVREF(0, rv2cv_op) : rv2cv_op;
- pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
- PL_last_lop = PL_oldbufptr;
- PL_last_lop_op = OP_ENTERSUB;
- /* Is there a prototype? */
- if (
- SvPOK(cv))
- {
- STRLEN protolen = CvPROTOLEN(cv);
- const char *proto = CvPROTO(cv);
- bool optional;
- proto = S_strip_spaces(aTHX_ proto, &protolen);
- if (!protolen)
- TERM(FUNC0SUB);
- if ((optional = *proto == ';'))
- do
- proto++;
- while (*proto == ';');
- if (
- (
- (
- *proto == '$' || *proto == '_'
- || *proto == '*' || *proto == '+'
- )
- && proto[1] == '\0'
- )
- || (
- *proto == '\\' && proto[1] && proto[2] == '\0'
- )
- )
- UNIPROTO(UNIOPSUB,optional);
- if (*proto == '\\' && proto[1] == '[') {
- const char *p = proto + 2;
- while(*p && *p != ']')
- ++p;
- if(*p == ']' && !p[1])
- UNIPROTO(UNIOPSUB,optional);
- }
- if (*proto == '&' && *s == '{') {
- if (PL_curstash)
- sv_setpvs(PL_subname, "__ANON__");
- else
- sv_setpvs(PL_subname, "__ANON__::__ANON__");
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
- {
- PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
- }
- PREBLOCK(LSTOPSUB);
- }
- }
- NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
- PL_expect = XTERM;
- force_next(off ? PRIVATEREF : BAREWORD);
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
- {
- PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
- }
- TOKEN(NOAMP);
- }
+ case KEY_link:
+ LOP(OP_LINK,XTERM);
- /* Call it a bare word */
+ case KEY_listen:
+ LOP(OP_LISTEN,XTERM);
- if (PL_hints & HINT_STRICT_SUBS)
- pl_yylval.opval->op_private |= OPpCONST_STRICT;
- else {
- bareword:
- /* after "print" and similar functions (corresponding to
- * "F? L" in opcode.pl), whatever wasn't already parsed as
- * a filehandle should be subject to "strict subs".
- * Likewise for the optional indirect-object argument to system
- * or exec, which can't be a bareword */
- if ((PL_last_lop_op == OP_PRINT
- || PL_last_lop_op == OP_PRTF
- || PL_last_lop_op == OP_SAY
- || PL_last_lop_op == OP_SYSTEM
- || PL_last_lop_op == OP_EXEC)
- && (PL_hints & HINT_STRICT_SUBS))
- pl_yylval.opval->op_private |= OPpCONST_STRICT;
- if (lastchar != '-') {
- if (ckWARN(WARN_RESERVED)) {
- d = PL_tokenbuf;
- while (isLOWER(*d))
- d++;
- if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
- {
- /* PL_warn_reserved is constant */
- GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
- Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
- PL_tokenbuf);
- GCC_DIAG_RESTORE_STMT;
- }
- }
- }
- }
- op_free(rv2cv_op);
-
- safe_bareword:
- if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
- && saw_infix_sigil) {
- Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Operator or semicolon missing before %c%" UTF8f,
- lastchar,
- UTF8fARG(UTF, strlen(PL_tokenbuf),
- PL_tokenbuf));
- Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Ambiguous use of %c resolved as operator %c",
- lastchar, lastchar);
- }
- TOKEN(BAREWORD);
- }
+ case KEY_lock:
+ UNI(OP_LOCK);
- case KEY___FILE__:
- FUN0OP(
- newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
- );
-
- case KEY___LINE__:
- FUN0OP(
- newSVOP(OP_CONST, 0,
- Perl_newSVpvf(aTHX_ "%" IVdf, (IV)CopLINE(PL_curcop)))
- );
-
- case KEY___PACKAGE__:
- FUN0OP(
- newSVOP(OP_CONST, 0,
- (PL_curstash
- ? newSVhek(HvNAME_HEK(PL_curstash))
- : &PL_sv_undef))
- );
-
- case KEY___DATA__:
- case KEY___END__: {
- GV *gv;
- if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
- HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
- ? PL_curstash
- : PL_defstash;
- gv = (GV *)*hv_fetchs(stash, "DATA", 1);
- if (!isGV(gv))
- gv_init(gv,stash,"DATA",4,0);
- GvMULTI_on(gv);
- if (!GvIO(gv))
- GvIOp(gv) = newIO();
- IoIFP(GvIOp(gv)) = PL_rsfp;
- /* Mark this internal pseudo-handle as clean */
- IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
- if ((PerlIO*)PL_rsfp == PerlIO_stdin())
- IoTYPE(GvIOp(gv)) = IoTYPE_STD;
- else
- IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
-#if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
- /* if the script was opened in binmode, we need to revert
- * it to text mode for compatibility; but only iff it has CRs
- * XXX this is a questionable hack at best. */
- if (PL_bufend-PL_bufptr > 2
- && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
- {
- Off_t loc = 0;
- if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
- loc = PerlIO_tell(PL_rsfp);
- (void)PerlIO_seek(PL_rsfp, 0L, 0);
- }
-#ifdef NETWARE
- if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
-#else
- if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
-#endif /* NETWARE */
- if (loc > 0)
- PerlIO_seek(PL_rsfp, loc, 0);
- }
- }
-#endif
-#ifdef PERLIO_LAYERS
- if (!IN_BYTES) {
- if (UTF)
- PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
- }
-#endif
- PL_rsfp = NULL;
- }
- goto fake_eof;
- }
-
- case KEY___SUB__:
- FUN0OP(CvCLONE(PL_compcv)
- ? newOP(OP_RUNCV, 0)
- : newPVOP(OP_RUNCV,0,NULL));
-
- case KEY_AUTOLOAD:
- case KEY_DESTROY:
- case KEY_BEGIN:
- case KEY_UNITCHECK:
- case KEY_CHECK:
- case KEY_INIT:
- case KEY_END:
- if (PL_expect == XSTATE) {
- s = PL_bufptr;
- goto really_sub;
- }
- goto just_a_word;
+ case KEY_lstat:
+ UNI(OP_LSTAT);
- case_KEY_CORE:
- {
- STRLEN olen = len;
- d = s;
- s += 2;
- s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
- if ((*s == ':' && s[1] == ':')
- || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
- {
- s = d;
- len = olen;
- Copy(PL_bufptr, PL_tokenbuf, olen, char);
- goto just_a_word;
- }
- if (!tmp)
- Perl_croak(aTHX_ "CORE::%" UTF8f " is not a keyword",
- UTF8fARG(UTF, len, PL_tokenbuf));
- if (tmp < 0)
- tmp = -tmp;
- else if (tmp == KEY_require || tmp == KEY_do
- || tmp == KEY_glob)
- /* that's a way to remember we saw "CORE::" */
- orig_keyword = tmp;
- goto reserved_word;
- }
+ case KEY_m:
+ s = scan_pat(s,OP_MATCH);
+ TERM(sublex_start());
- case KEY_abs:
- UNI(OP_ABS);
+ case KEY_map:
+ LOP(OP_MAPSTART, XREF);
- case KEY_alarm:
- UNI(OP_ALARM);
+ case KEY_mkdir:
+ LOP(OP_MKDIR,XTERM);
- case KEY_accept:
- LOP(OP_ACCEPT,XTERM);
+ case KEY_msgctl:
+ LOP(OP_MSGCTL,XTERM);
- case KEY_and:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
- return REPORT(0);
- OPERATOR(ANDOP);
+ case KEY_msgget:
+ LOP(OP_MSGGET,XTERM);
- case KEY_atan2:
- LOP(OP_ATAN2,XTERM);
+ case KEY_msgrcv:
+ LOP(OP_MSGRCV,XTERM);
- case KEY_bind:
- LOP(OP_BIND,XTERM);
+ case KEY_msgsnd:
+ LOP(OP_MSGSND,XTERM);
- case KEY_binmode:
- LOP(OP_BINMODE,XTERM);
+ case KEY_our:
+ case KEY_my:
+ case KEY_state:
+ return yyl_my(aTHX_ s, key);
- case KEY_bless:
- LOP(OP_BLESS,XTERM);
+ case KEY_next:
+ LOOPX(OP_NEXT);
- case KEY_break:
- FUN0(OP_BREAK);
+ case KEY_ne:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChEop(OP_SNE);
- case KEY_chop:
- UNI(OP_CHOP);
+ case KEY_no:
+ s = tokenize_use(0, s);
+ TOKEN(USE);
- case KEY_continue:
- /* We have to disambiguate the two senses of
- "continue". If the next token is a '{' then
- treat it as the start of a continue block;
- otherwise treat it as a control operator.
- */
- s = skipspace(s);
- if (*s == '{')
- PREBLOCK(CONTINUE);
- else
- FUN0(OP_CONTINUE);
+ case KEY_not:
+ if (*s == '(' || (s = skipspace(s), *s == '('))
+ FUN1(OP_NOT);
+ else {
+ if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
+ OPERATOR(NOTOP);
+ }
- case KEY_chdir:
- /* may use HOME */
- (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
- UNI(OP_CHDIR);
+ case KEY_open:
+ s = skipspace(s);
+ if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
+ const char *t;
+ char *d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
+ for (t=d; isSPACE(*t);)
+ t++;
+ if ( *t && memCHRs("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
+ /* [perl #16184] */
+ && !(t[0] == '=' && t[1] == '>')
+ && !(t[0] == ':' && t[1] == ':')
+ && !keyword(s, d-s, 0)
+ ) {
+ Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
+ "Precedence problem: open %" UTF8f " should be open(%" UTF8f ")",
+ UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
+ }
+ }
+ LOP(OP_OPEN,XTERM);
- case KEY_close:
- UNI(OP_CLOSE);
+ case KEY_or:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
+ return REPORT(0);
+ pl_yylval.ival = OP_OR;
+ OPERATOR(OROP);
- case KEY_closedir:
- UNI(OP_CLOSEDIR);
+ case KEY_ord:
+ UNI(OP_ORD);
- case KEY_cmp:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Eop(OP_SCMP);
+ case KEY_oct:
+ UNI(OP_OCT);
- case KEY_caller:
- UNI(OP_CALLER);
+ case KEY_opendir:
+ LOP(OP_OPEN_DIR,XTERM);
- case KEY_crypt:
-#ifdef FCRYPT
- if (!PL_cryptseen) {
- PL_cryptseen = TRUE;
- init_des();
- }
-#endif
- LOP(OP_CRYPT,XTERM);
+ case KEY_print:
+ checkcomma(s,PL_tokenbuf,"filehandle");
+ LOP(OP_PRINT,XREF);
- case KEY_chmod:
- LOP(OP_CHMOD,XTERM);
+ case KEY_printf:
+ checkcomma(s,PL_tokenbuf,"filehandle");
+ LOP(OP_PRTF,XREF);
- case KEY_chown:
- LOP(OP_CHOWN,XTERM);
+ case KEY_prototype:
+ UNI(OP_PROTOTYPE);
- case KEY_connect:
- LOP(OP_CONNECT,XTERM);
+ case KEY_push:
+ LOP(OP_PUSH,XTERM);
- case KEY_chr:
- UNI(OP_CHR);
+ case KEY_pop:
+ UNIDOR(OP_POP);
- case KEY_cos:
- UNI(OP_COS);
+ case KEY_pos:
+ UNIDOR(OP_POS);
- case KEY_chroot:
- UNI(OP_CHROOT);
+ case KEY_pack:
+ LOP(OP_PACK,XTERM);
- case KEY_default:
- PREBLOCK(DEFAULT);
+ case KEY_package:
+ s = force_word(s,BAREWORD,FALSE,TRUE);
+ s = skipspace(s);
+ s = force_strict_version(s);
+ PREBLOCK(PACKAGE);
- case KEY_do:
- s = skipspace(s);
- if (*s == '{')
- PRETERMBLOCK(DO);
- if (*s != '\'') {
- *PL_tokenbuf = '&';
- d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
- 1, &len);
- if (len && memNEs(PL_tokenbuf+1, len, "CORE")
- && !keyword(PL_tokenbuf + 1, len, 0)) {
- SSize_t off = s-SvPVX(PL_linestr);
- d = skipspace(d);
- s = SvPVX(PL_linestr)+off;
- if (*d == '(') {
- force_ident_maybe_lex('&');
- s = d;
- }
- }
- }
- if (orig_keyword == KEY_do) {
- orig_keyword = 0;
- pl_yylval.ival = 1;
- }
- else
- pl_yylval.ival = 0;
- OPERATOR(DO);
+ case KEY_pipe:
+ LOP(OP_PIPE_OP,XTERM);
- case KEY_die:
- PL_hints |= HINT_BLOCK_SCOPE;
- LOP(OP_DIE,XTERM);
+ case KEY_q:
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
+ if (!s)
+ missingterm(NULL, 0);
+ COPLINE_SET_FROM_MULTI_END;
+ pl_yylval.ival = OP_CONST;
+ TERM(sublex_start());
- case KEY_defined:
- UNI(OP_DEFINED);
+ case KEY_quotemeta:
+ UNI(OP_QUOTEMETA);
- case KEY_delete:
- UNI(OP_DELETE);
+ case KEY_qw:
+ return yyl_qw(aTHX_ s, len);
- case KEY_dbmopen:
- Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
- STR_WITH_LEN("NDBM_File::"),
- STR_WITH_LEN("DB_File::"),
- STR_WITH_LEN("GDBM_File::"),
- STR_WITH_LEN("SDBM_File::"),
- STR_WITH_LEN("ODBM_File::"),
- NULL);
- LOP(OP_DBMOPEN,XTERM);
+ case KEY_qq:
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
+ if (!s)
+ missingterm(NULL, 0);
+ pl_yylval.ival = OP_STRINGIFY;
+ if (SvIVX(PL_lex_stuff) == '\'')
+ SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
+ TERM(sublex_start());
- case KEY_dbmclose:
- UNI(OP_DBMCLOSE);
+ case KEY_qr:
+ s = scan_pat(s,OP_QR);
+ TERM(sublex_start());
- case KEY_dump:
- LOOPX(OP_DUMP);
+ case KEY_qx:
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
+ if (!s)
+ missingterm(NULL, 0);
+ pl_yylval.ival = OP_BACKTICK;
+ TERM(sublex_start());
- case KEY_else:
- PREBLOCK(ELSE);
+ case KEY_return:
+ OLDLOP(OP_RETURN);
- case KEY_elsif:
- pl_yylval.ival = CopLINE(PL_curcop);
- OPERATOR(ELSIF);
+ case KEY_require:
+ return yyl_require(aTHX_ s, orig_keyword);
- case KEY_eq:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Eop(OP_SEQ);
+ case KEY_reset:
+ UNI(OP_RESET);
- case KEY_exists:
- UNI(OP_EXISTS);
+ case KEY_redo:
+ LOOPX(OP_REDO);
- case KEY_exit:
- UNI(OP_EXIT);
+ case KEY_rename:
+ LOP(OP_RENAME,XTERM);
- case KEY_eval:
- s = skipspace(s);
- if (*s == '{') { /* block eval */
- PL_expect = XTERMBLOCK;
- UNIBRACK(OP_ENTERTRY);
- }
- else { /* string eval */
- PL_expect = XTERM;
- UNIBRACK(OP_ENTEREVAL);
- }
+ case KEY_rand:
+ UNI(OP_RAND);
- case KEY_evalbytes:
- PL_expect = XTERM;
- UNIBRACK(-OP_ENTEREVAL);
+ case KEY_rmdir:
+ UNI(OP_RMDIR);
- case KEY_eof:
- UNI(OP_EOF);
+ case KEY_rindex:
+ LOP(OP_RINDEX,XTERM);
- case KEY_exp:
- UNI(OP_EXP);
+ case KEY_read:
+ LOP(OP_READ,XTERM);
- case KEY_each:
- UNI(OP_EACH);
+ case KEY_readdir:
+ UNI(OP_READDIR);
- case KEY_exec:
- LOP(OP_EXEC,XREF);
+ case KEY_readline:
+ UNIDOR(OP_READLINE);
- case KEY_endhostent:
- FUN0(OP_EHOSTENT);
+ case KEY_readpipe:
+ UNIDOR(OP_BACKTICK);
- case KEY_endnetent:
- FUN0(OP_ENETENT);
+ case KEY_rewinddir:
+ UNI(OP_REWINDDIR);
- case KEY_endservent:
- FUN0(OP_ESERVENT);
+ case KEY_recv:
+ LOP(OP_RECV,XTERM);
- case KEY_endprotoent:
- FUN0(OP_EPROTOENT);
+ case KEY_reverse:
+ LOP(OP_REVERSE,XTERM);
- case KEY_endpwent:
- FUN0(OP_EPWENT);
+ case KEY_readlink:
+ UNIDOR(OP_READLINK);
- case KEY_endgrent:
- FUN0(OP_EGRENT);
+ case KEY_ref:
+ UNI(OP_REF);
- case KEY_for:
- case KEY_foreach:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
- return REPORT(0);
- pl_yylval.ival = CopLINE(PL_curcop);
- s = skipspace(s);
- if ( PL_expect == XSTATE
- && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
- {
- char *p = s;
- SSize_t s_off = s - SvPVX(PL_linestr);
+ case KEY_s:
+ s = scan_subst(s);
+ if (pl_yylval.opval)
+ TERM(sublex_start());
+ else
+ TOKEN(1); /* force error */
- if ( memBEGINPs(p, (STRLEN) (PL_bufend - p), "my")
- && isSPACE(*(p + 2)))
- {
- p += 2;
- }
- else if ( memBEGINPs(p, (STRLEN) (PL_bufend - p), "our")
- && isSPACE(*(p + 3)))
- {
- p += 3;
- }
+ case KEY_say:
+ checkcomma(s,PL_tokenbuf,"filehandle");
+ LOP(OP_SAY,XREF);
- p = skipspace(p);
- /* skip optional package name, as in "for my abc $x (..)" */
- if (isIDFIRST_lazy_if_safe(p, PL_bufend, UTF)) {
- p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
- p = skipspace(p);
- }
- if (*p != '$' && *p != '\\')
- Perl_croak(aTHX_ "Missing $ on loop variable");
+ case KEY_chomp:
+ UNI(OP_CHOMP);
- /* The buffer may have been reallocated, update s */
- s = SvPVX(PL_linestr) + s_off;
- }
- OPERATOR(FOR);
+ case KEY_scalar:
+ UNI(OP_SCALAR);
- case KEY_formline:
- LOP(OP_FORMLINE,XTERM);
+ case KEY_select:
+ LOP(OP_SELECT,XTERM);
- case KEY_fork:
- FUN0(OP_FORK);
+ case KEY_seek:
+ LOP(OP_SEEK,XTERM);
- case KEY_fc:
- UNI(OP_FC);
+ case KEY_semctl:
+ LOP(OP_SEMCTL,XTERM);
- case KEY_fcntl:
- LOP(OP_FCNTL,XTERM);
+ case KEY_semget:
+ LOP(OP_SEMGET,XTERM);
- case KEY_fileno:
- UNI(OP_FILENO);
+ case KEY_semop:
+ LOP(OP_SEMOP,XTERM);
- case KEY_flock:
- LOP(OP_FLOCK,XTERM);
+ case KEY_send:
+ LOP(OP_SEND,XTERM);
- case KEY_gt:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Rop(OP_SGT);
+ case KEY_setpgrp:
+ LOP(OP_SETPGRP,XTERM);
- case KEY_ge:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Rop(OP_SGE);
+ case KEY_setpriority:
+ LOP(OP_SETPRIORITY,XTERM);
- case KEY_grep:
- LOP(OP_GREPSTART, XREF);
+ case KEY_sethostent:
+ UNI(OP_SHOSTENT);
- case KEY_goto:
- LOOPX(OP_GOTO);
+ case KEY_setnetent:
+ UNI(OP_SNETENT);
- case KEY_gmtime:
- UNI(OP_GMTIME);
+ case KEY_setservent:
+ UNI(OP_SSERVENT);
- case KEY_getc:
- UNIDOR(OP_GETC);
+ case KEY_setprotoent:
+ UNI(OP_SPROTOENT);
- case KEY_getppid:
- FUN0(OP_GETPPID);
+ case KEY_setpwent:
+ FUN0(OP_SPWENT);
- case KEY_getpgrp:
- UNI(OP_GETPGRP);
+ case KEY_setgrent:
+ FUN0(OP_SGRENT);
- case KEY_getpriority:
- LOP(OP_GETPRIORITY,XTERM);
+ case KEY_seekdir:
+ LOP(OP_SEEKDIR,XTERM);
- case KEY_getprotobyname:
- UNI(OP_GPBYNAME);
+ case KEY_setsockopt:
+ LOP(OP_SSOCKOPT,XTERM);
- case KEY_getprotobynumber:
- LOP(OP_GPBYNUMBER,XTERM);
+ case KEY_shift:
+ UNIDOR(OP_SHIFT);
- case KEY_getprotoent:
- FUN0(OP_GPROTOENT);
+ case KEY_shmctl:
+ LOP(OP_SHMCTL,XTERM);
- case KEY_getpwent:
- FUN0(OP_GPWENT);
+ case KEY_shmget:
+ LOP(OP_SHMGET,XTERM);
- case KEY_getpwnam:
- UNI(OP_GPWNAM);
+ case KEY_shmread:
+ LOP(OP_SHMREAD,XTERM);
- case KEY_getpwuid:
- UNI(OP_GPWUID);
+ case KEY_shmwrite:
+ LOP(OP_SHMWRITE,XTERM);
- case KEY_getpeername:
- UNI(OP_GETPEERNAME);
+ case KEY_shutdown:
+ LOP(OP_SHUTDOWN,XTERM);
- case KEY_gethostbyname:
- UNI(OP_GHBYNAME);
+ case KEY_sin:
+ UNI(OP_SIN);
- case KEY_gethostbyaddr:
- LOP(OP_GHBYADDR,XTERM);
+ case KEY_sleep:
+ UNI(OP_SLEEP);
- case KEY_gethostent:
- FUN0(OP_GHOSTENT);
+ case KEY_socket:
+ LOP(OP_SOCKET,XTERM);
- case KEY_getnetbyname:
- UNI(OP_GNBYNAME);
+ case KEY_socketpair:
+ LOP(OP_SOCKPAIR,XTERM);
- case KEY_getnetbyaddr:
- LOP(OP_GNBYADDR,XTERM);
+ case KEY_sort:
+ checkcomma(s,PL_tokenbuf,"subroutine name");
+ s = skipspace(s);
+ PL_expect = XTERM;
+ s = force_word(s,BAREWORD,TRUE,TRUE);
+ LOP(OP_SORT,XREF);
- case KEY_getnetent:
- FUN0(OP_GNETENT);
+ case KEY_split:
+ LOP(OP_SPLIT,XTERM);
- case KEY_getservbyname:
- LOP(OP_GSBYNAME,XTERM);
+ case KEY_sprintf:
+ LOP(OP_SPRINTF,XTERM);
- case KEY_getservbyport:
- LOP(OP_GSBYPORT,XTERM);
+ case KEY_splice:
+ LOP(OP_SPLICE,XTERM);
- case KEY_getservent:
- FUN0(OP_GSERVENT);
+ case KEY_sqrt:
+ UNI(OP_SQRT);
- case KEY_getsockname:
- UNI(OP_GETSOCKNAME);
+ case KEY_srand:
+ UNI(OP_SRAND);
- case KEY_getsockopt:
- LOP(OP_GSOCKOPT,XTERM);
+ case KEY_stat:
+ UNI(OP_STAT);
- case KEY_getgrent:
- FUN0(OP_GGRENT);
+ case KEY_study:
+ UNI(OP_STUDY);
- case KEY_getgrnam:
- UNI(OP_GGRNAM);
+ case KEY_substr:
+ LOP(OP_SUBSTR,XTERM);
- case KEY_getgrgid:
- UNI(OP_GGRGID);
+ case KEY_format:
+ case KEY_sub:
+ return yyl_sub(aTHX_ s, key);
- case KEY_getlogin:
- FUN0(OP_GETLOGIN);
+ case KEY_system:
+ LOP(OP_SYSTEM,XREF);
- case KEY_given:
- pl_yylval.ival = CopLINE(PL_curcop);
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
- "given is experimental");
- OPERATOR(GIVEN);
+ case KEY_symlink:
+ LOP(OP_SYMLINK,XTERM);
- case KEY_glob:
- LOP(
- orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
- XTERM
- );
+ case KEY_syscall:
+ LOP(OP_SYSCALL,XTERM);
- case KEY_hex:
- UNI(OP_HEX);
+ case KEY_sysopen:
+ LOP(OP_SYSOPEN,XTERM);
- case KEY_if:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
- return REPORT(0);
- pl_yylval.ival = CopLINE(PL_curcop);
- OPERATOR(IF);
+ case KEY_sysseek:
+ LOP(OP_SYSSEEK,XTERM);
- case KEY_index:
- LOP(OP_INDEX,XTERM);
+ case KEY_sysread:
+ LOP(OP_SYSREAD,XTERM);
- case KEY_int:
- UNI(OP_INT);
+ case KEY_syswrite:
+ LOP(OP_SYSWRITE,XTERM);
- case KEY_ioctl:
- LOP(OP_IOCTL,XTERM);
+ case KEY_tr:
+ case KEY_y:
+ s = scan_trans(s);
+ TERM(sublex_start());
- case KEY_join:
- LOP(OP_JOIN,XTERM);
+ case KEY_tell:
+ UNI(OP_TELL);
- case KEY_keys:
- UNI(OP_KEYS);
+ case KEY_telldir:
+ UNI(OP_TELLDIR);
- case KEY_kill:
- LOP(OP_KILL,XTERM);
+ case KEY_tie:
+ LOP(OP_TIE,XTERM);
- case KEY_last:
- LOOPX(OP_LAST);
+ case KEY_tied:
+ UNI(OP_TIED);
- case KEY_lc:
- UNI(OP_LC);
+ case KEY_time:
+ FUN0(OP_TIME);
- case KEY_lcfirst:
- UNI(OP_LCFIRST);
+ case KEY_times:
+ FUN0(OP_TMS);
- case KEY_local:
- OPERATOR(LOCAL);
+ case KEY_truncate:
+ LOP(OP_TRUNCATE,XTERM);
- case KEY_length:
- UNI(OP_LENGTH);
+ case KEY_uc:
+ UNI(OP_UC);
- case KEY_lt:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Rop(OP_SLT);
+ case KEY_ucfirst:
+ UNI(OP_UCFIRST);
- case KEY_le:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Rop(OP_SLE);
+ case KEY_untie:
+ UNI(OP_UNTIE);
- case KEY_localtime:
- UNI(OP_LOCALTIME);
+ case KEY_until:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ return REPORT(0);
+ pl_yylval.ival = CopLINE(PL_curcop);
+ OPERATOR(UNTIL);
- case KEY_log:
- UNI(OP_LOG);
+ case KEY_unless:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ return REPORT(0);
+ pl_yylval.ival = CopLINE(PL_curcop);
+ OPERATOR(UNLESS);
- case KEY_link:
- LOP(OP_LINK,XTERM);
+ case KEY_unlink:
+ LOP(OP_UNLINK,XTERM);
- case KEY_listen:
- LOP(OP_LISTEN,XTERM);
+ case KEY_undef:
+ UNIDOR(OP_UNDEF);
- case KEY_lock:
- UNI(OP_LOCK);
+ case KEY_unpack:
+ LOP(OP_UNPACK,XTERM);
- case KEY_lstat:
- UNI(OP_LSTAT);
+ case KEY_utime:
+ LOP(OP_UTIME,XTERM);
- case KEY_m:
- s = scan_pat(s,OP_MATCH);
- TERM(sublex_start());
+ case KEY_umask:
+ UNIDOR(OP_UMASK);
- case KEY_map:
- LOP(OP_MAPSTART, XREF);
+ case KEY_unshift:
+ LOP(OP_UNSHIFT,XTERM);
- case KEY_mkdir:
- LOP(OP_MKDIR,XTERM);
+ case KEY_use:
+ s = tokenize_use(1, s);
+ TOKEN(USE);
- case KEY_msgctl:
- LOP(OP_MSGCTL,XTERM);
+ case KEY_values:
+ UNI(OP_VALUES);
- case KEY_msgget:
- LOP(OP_MSGGET,XTERM);
+ case KEY_vec:
+ LOP(OP_VEC,XTERM);
- case KEY_msgrcv:
- LOP(OP_MSGRCV,XTERM);
+ case KEY_when:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ return REPORT(0);
+ pl_yylval.ival = CopLINE(PL_curcop);
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
+ "when is experimental");
+ OPERATOR(WHEN);
- case KEY_msgsnd:
- LOP(OP_MSGSND,XTERM);
+ case KEY_while:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ return REPORT(0);
+ pl_yylval.ival = CopLINE(PL_curcop);
+ OPERATOR(WHILE);
- case KEY_our:
- case KEY_my:
- case KEY_state:
- if (PL_in_my) {
- PL_bufptr = s;
- yyerror(Perl_form(aTHX_
- "Can't redeclare \"%s\" in \"%s\"",
- tmp == KEY_my ? "my" :
- tmp == KEY_state ? "state" : "our",
- PL_in_my == KEY_my ? "my" :
- PL_in_my == KEY_state ? "state" : "our"));
- }
- PL_in_my = (U16)tmp;
- s = skipspace(s);
- if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
- s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
- if (memEQs(PL_tokenbuf, len, "sub"))
- goto really_sub;
- PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
- if (!PL_in_my_stash) {
- char tmpbuf[1024];
- int len;
- PL_bufptr = s;
- len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
- PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
- yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
- }
- }
- else if (*s == '\\') {
- if (!FEATURE_MYREF_IS_ENABLED)
- Perl_croak(aTHX_ "The experimental declared_refs "
- "feature is not enabled");
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
- "Declaring references is experimental");
- }
- OPERATOR(MY);
+ case KEY_warn:
+ PL_hints |= HINT_BLOCK_SCOPE;
+ LOP(OP_WARN,XTERM);
- case KEY_next:
- LOOPX(OP_NEXT);
+ case KEY_wait:
+ FUN0(OP_WAIT);
- case KEY_ne:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Eop(OP_SNE);
+ case KEY_waitpid:
+ LOP(OP_WAITPID,XTERM);
- case KEY_no:
- s = tokenize_use(0, s);
- TOKEN(USE);
+ case KEY_wantarray:
+ FUN0(OP_WANTARRAY);
- case KEY_not:
- if (*s == '(' || (s = skipspace(s), *s == '('))
- FUN1(OP_NOT);
- else {
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
- {
- PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
- }
- OPERATOR(NOTOP);
- }
+ case KEY_write:
+ /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
+ * we use the same number on EBCDIC */
+ gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
+ UNI(OP_ENTERWRITE);
- case KEY_open:
- s = skipspace(s);
- if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
- const char *t;
- d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
- &len);
- for (t=d; isSPACE(*t);)
- t++;
- if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
- /* [perl #16184] */
- && !(t[0] == '=' && t[1] == '>')
- && !(t[0] == ':' && t[1] == ':')
- && !keyword(s, d-s, 0)
- ) {
- Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
- "Precedence problem: open %" UTF8f " should be open(%" UTF8f ")",
- UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
- }
- }
- LOP(OP_OPEN,XTERM);
+ case KEY_x:
+ if (PL_expect == XOPERATOR) {
+ if (*s == '=' && !PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
+ {
+ return REPORT(0);
+ }
+ Mop(OP_REPEAT);
+ }
+ check_uni();
+ return yyl_just_a_word(aTHX_ s, len, orig_keyword, c);
+
+ case KEY_xor:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
+ return REPORT(0);
+ pl_yylval.ival = OP_XOR;
+ OPERATOR(OROP);
+ }
+}
+
+static int
+yyl_key_core(pTHX_ char *s, STRLEN len, struct code c)
+{
+ I32 key = 0;
+ I32 orig_keyword = 0;
+ STRLEN olen = len;
+ char *d = s;
+ s += 2;
+ s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
+ if ((*s == ':' && s[1] == ':')
+ || (!(key = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
+ {
+ Copy(PL_bufptr, PL_tokenbuf, olen, char);
+ return yyl_just_a_word(aTHX_ d, olen, 0, c);
+ }
+ if (!key)
+ Perl_croak(aTHX_ "CORE::%" UTF8f " is not a keyword",
+ UTF8fARG(UTF, len, PL_tokenbuf));
+ if (key < 0)
+ key = -key;
+ else if (key == KEY_require || key == KEY_do
+ || key == KEY_glob)
+ /* that's a way to remember we saw "CORE::" */
+ orig_keyword = key;
+
+ /* Known to be a reserved word at this point */
+ return yyl_word_or_keyword(aTHX_ s, len, key, orig_keyword, c);
+}
+
+static int
+yyl_keylookup(pTHX_ char *s, GV *gv)
+{
+ STRLEN len;
+ bool anydelim;
+ I32 key;
+ struct code c = no_code;
+ I32 orig_keyword = 0;
+ char *d;
- case KEY_or:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
- return REPORT(0);
- pl_yylval.ival = OP_OR;
- OPERATOR(OROP);
+ c.gv = gv;
- case KEY_ord:
- UNI(OP_ORD);
+ PL_bufptr = s;
+ s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
- case KEY_oct:
- UNI(OP_OCT);
+ /* Some keywords can be followed by any delimiter, including ':' */
+ anydelim = word_takes_any_delimiter(PL_tokenbuf, len);
- case KEY_opendir:
- LOP(OP_OPEN_DIR,XTERM);
+ /* x::* is just a word, unless x is "CORE" */
+ if (!anydelim && *s == ':' && s[1] == ':') {
+ if (memEQs(PL_tokenbuf, len, "CORE"))
+ return yyl_key_core(aTHX_ s, len, c);
+ return yyl_just_a_word(aTHX_ s, len, 0, c);
+ }
- case KEY_print:
- checkcomma(s,PL_tokenbuf,"filehandle");
- LOP(OP_PRINT,XREF);
+ d = s;
+ while (d < PL_bufend && isSPACE(*d))
+ d++; /* no comments skipped here, or s### is misparsed */
- case KEY_printf:
- checkcomma(s,PL_tokenbuf,"filehandle");
- LOP(OP_PRTF,XREF);
+ /* Is this a word before a => operator? */
+ if (*d == '=' && d[1] == '>') {
+ return yyl_fatcomma(aTHX_ s, len);
+ }
- case KEY_prototype:
- UNI(OP_PROTOTYPE);
+ /* Check for plugged-in keyword */
+ {
+ OP *o;
+ int result;
+ char *saved_bufptr = PL_bufptr;
+ PL_bufptr = s;
+ result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
+ s = PL_bufptr;
+ if (result == KEYWORD_PLUGIN_DECLINE) {
+ /* not a plugged-in keyword */
+ PL_bufptr = saved_bufptr;
+ } else if (result == KEYWORD_PLUGIN_STMT) {
+ pl_yylval.opval = o;
+ CLINE;
+ if (!PL_nexttoke) PL_expect = XSTATE;
+ return REPORT(PLUGSTMT);
+ } else if (result == KEYWORD_PLUGIN_EXPR) {
+ pl_yylval.opval = o;
+ CLINE;
+ if (!PL_nexttoke) PL_expect = XOPERATOR;
+ return REPORT(PLUGEXPR);
+ } else {
+ Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'", PL_tokenbuf);
+ }
+ }
- case KEY_push:
- LOP(OP_PUSH,XTERM);
+ /* Is this a label? */
+ if (!anydelim && PL_expect == XSTATE
+ && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
+ s = d + 1;
+ pl_yylval.opval =
+ newSVOP(OP_CONST, 0,
+ newSVpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0));
+ CLINE;
+ TOKEN(LABEL);
+ }
+
+ /* Check for lexical sub */
+ if (PL_expect != XOPERATOR) {
+ char tmpbuf[sizeof PL_tokenbuf + 1];
+ *tmpbuf = '&';
+ Copy(PL_tokenbuf, tmpbuf+1, len, char);
+ c.off = pad_findmy_pvn(tmpbuf, len+1, 0);
+ if (c.off != NOT_IN_PAD) {
+ assert(c.off); /* we assume this is boolean-true below */
+ if (PAD_COMPNAME_FLAGS_isOUR(c.off)) {
+ HV * const stash = PAD_COMPNAME_OURSTASH(c.off);
+ HEK * const stashname = HvNAME_HEK(stash);
+ c.sv = newSVhek(stashname);
+ sv_catpvs(c.sv, "::");
+ sv_catpvn_flags(c.sv, PL_tokenbuf, len,
+ (UTF ? SV_CATUTF8 : SV_CATBYTES));
+ c.gv = gv_fetchsv(c.sv, GV_NOADD_NOINIT | SvUTF8(c.sv),
+ SVt_PVCV);
+ c.off = 0;
+ if (!c.gv) {
+ sv_free(c.sv);
+ c.sv = NULL;
+ return yyl_just_a_word(aTHX_ s, len, 0, c);
+ }
+ }
+ else {
+ c.rv2cv_op = newOP(OP_PADANY, 0);
+ c.rv2cv_op->op_targ = c.off;
+ c.cv = find_lexical_cv(c.off);
+ }
+ c.lex = TRUE;
+ return yyl_just_a_word(aTHX_ s, len, 0, c);
+ }
+ c.off = 0;
+ }
- case KEY_pop:
- UNIDOR(OP_POP);
+ /* Check for built-in keyword */
+ key = keyword(PL_tokenbuf, len, 0);
- case KEY_pos:
- UNIDOR(OP_POS);
+ if (key < 0)
+ key = yyl_secondclass_keyword(aTHX_ s, len, key, &orig_keyword, &c.gv, &c.gvp);
- case KEY_pack:
- LOP(OP_PACK,XTERM);
+ if (key && key != KEY___DATA__ && key != KEY___END__
+ && (!anydelim || *s != '#')) {
+ /* no override, and not s### either; skipspace is safe here
+ * check for => on following line */
+ bool arrow;
+ STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
+ STRLEN soff = s - SvPVX(PL_linestr);
+ s = peekspace(s);
+ arrow = *s == '=' && s[1] == '>';
+ PL_bufptr = SvPVX(PL_linestr) + bufoff;
+ s = SvPVX(PL_linestr) + soff;
+ if (arrow)
+ return yyl_fatcomma(aTHX_ s, len);
+ }
- case KEY_package:
- s = force_word(s,BAREWORD,FALSE,TRUE);
- s = skipspace(s);
- s = force_strict_version(s);
- PREBLOCK(PACKAGE);
+ return yyl_word_or_keyword(aTHX_ s, len, key, orig_keyword, c);
+}
- case KEY_pipe:
- LOP(OP_PIPE_OP,XTERM);
+static int
+yyl_try(pTHX_ char *s)
+{
+ char *d;
+ GV *gv = NULL;
+ int tok;
- case KEY_q:
- s = scan_str(s,FALSE,FALSE,FALSE,NULL);
- if (!s)
- missingterm(NULL, 0);
- COPLINE_SET_FROM_MULTI_END;
- pl_yylval.ival = OP_CONST;
- TERM(sublex_start());
+ retry:
+ switch (*s) {
+ default:
+ if (UTF ? isIDFIRST_utf8_safe(s, PL_bufend) : isALNUMC(*s)) {
+ if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
+ }
+ yyl_croak_unrecognised(aTHX_ s);
- case KEY_quotemeta:
- UNI(OP_QUOTEMETA);
+ case 4:
+ case 26:
+ /* emulate EOF on ^D or ^Z */
+ if ((tok = yyl_fake_eof(aTHX_ LEX_FAKE_EOF, FALSE, s)) != YYL_RETRY)
+ return tok;
+ retry_bufptr:
+ s = PL_bufptr;
+ goto retry;
- case KEY_qw: {
- OP *words = NULL;
- s = scan_str(s,FALSE,FALSE,FALSE,NULL);
- if (!s)
- missingterm(NULL, 0);
- COPLINE_SET_FROM_MULTI_END;
- PL_expect = XOPERATOR;
- if (SvCUR(PL_lex_stuff)) {
- int warned_comma = !ckWARN(WARN_QW);
- int warned_comment = warned_comma;
- d = SvPV_force(PL_lex_stuff, len);
- while (len) {
- for (; isSPACE(*d) && len; --len, ++d)
- /**/;
- if (len) {
- SV *sv;
- const char *b = d;
- if (!warned_comma || !warned_comment) {
- for (; !isSPACE(*d) && len; --len, ++d) {
- if (!warned_comma && *d == ',') {
- Perl_warner(aTHX_ packWARN(WARN_QW),
- "Possible attempt to separate words with commas");
- ++warned_comma;
- }
- else if (!warned_comment && *d == '#') {
- Perl_warner(aTHX_ packWARN(WARN_QW),
- "Possible attempt to put comments in qw() list");
- ++warned_comment;
- }
- }
- }
+ case 0:
+ if ((!PL_rsfp || PL_lex_inwhat)
+ && (!PL_parser->filtered || s+1 < PL_bufend)) {
+ PL_last_uni = 0;
+ PL_last_lop = 0;
+ if (PL_lex_brackets
+ && PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF)
+ {
+ yyerror((const char *)
+ (PL_lex_formbrack
+ ? "Format not terminated"
+ : "Missing right curly or square bracket"));
+ }
+ DEBUG_T({
+ PerlIO_printf(Perl_debug_log, "### Tokener got EOF\n");
+ });
+ TOKEN(0);
+ }
+ if (s++ < PL_bufend)
+ goto retry; /* ignore stray nulls */
+ PL_last_uni = 0;
+ PL_last_lop = 0;
+ if (!PL_in_eval && !PL_preambled) {
+ PL_preambled = TRUE;
+ if (PL_perldb) {
+ /* Generate a string of Perl code to load the debugger.
+ * If PERL5DB is set, it will return the contents of that,
+ * otherwise a compile-time require of perl5db.pl. */
+
+ const char * const pdb = PerlEnv_getenv("PERL5DB");
+
+ if (pdb) {
+ sv_setpv(PL_linestr, pdb);
+ sv_catpvs(PL_linestr,";");
+ } else {
+ SETERRNO(0,SS_NORMAL);
+ sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
+ }
+ PL_parser->preambling = CopLINE(PL_curcop);
+ } else
+ SvPVCLEAR(PL_linestr);
+ if (PL_preambleav) {
+ SV **svp = AvARRAY(PL_preambleav);
+ SV **const end = svp + AvFILLp(PL_preambleav);
+ while(svp <= end) {
+ sv_catsv(PL_linestr, *svp);
+ ++svp;
+ sv_catpvs(PL_linestr, ";");
+ }
+ sv_free(MUTABLE_SV(PL_preambleav));
+ PL_preambleav = NULL;
+ }
+ if (PL_minus_E)
+ sv_catpvs(PL_linestr,
+ "use feature ':" STRINGIFY(PERL_REVISION) "." STRINGIFY(PERL_VERSION) "';");
+ if (PL_minus_n || PL_minus_p) {
+ sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
+ if (PL_minus_l)
+ sv_catpvs(PL_linestr,"chomp;");
+ if (PL_minus_a) {
+ if (PL_minus_F) {
+ if ( ( *PL_splitstr == '/'
+ || *PL_splitstr == '\''
+ || *PL_splitstr == '"')
+ && strchr(PL_splitstr + 1, *PL_splitstr))
+ {
+ /* strchr is ok, because -F pattern can't contain
+ * embeddded NULs */
+ Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
+ }
else {
- for (; !isSPACE(*d) && len; --len, ++d)
- /**/;
+ /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
+ bytes can be used as quoting characters. :-) */
+ const char *splits = PL_splitstr;
+ sv_catpvs(PL_linestr, "our @F=split(q\0");
+ do {
+ /* Need to \ \s */
+ if (*splits == '\\')
+ sv_catpvn(PL_linestr, splits, 1);
+ sv_catpvn(PL_linestr, splits, 1);
+ } while (*splits++);
+ /* This loop will embed the trailing NUL of
+ PL_linestr as the last thing it does before
+ terminating. */
+ sv_catpvs(PL_linestr, ");");
}
- sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
- words = op_append_elem(OP_LIST, words,
- newSVOP(OP_CONST, 0, tokeq(sv)));
}
+ else
+ sv_catpvs(PL_linestr,"our @F=split(' ');");
}
}
- if (!words)
- words = newNULLLIST();
- SvREFCNT_dec_NN(PL_lex_stuff);
- PL_lex_stuff = NULL;
- PL_expect = XOPERATOR;
- pl_yylval.opval = sawparens(words);
- TOKEN(QWLIST);
+ sv_catpvs(PL_linestr, "\n");
+ PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = NULL;
+ if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
+ update_debugger_info(PL_linestr, NULL, 0);
+ goto retry;
}
+ if ((tok = yyl_fake_eof(aTHX_ 0, cBOOL(PL_rsfp), s)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
- case KEY_qq:
- s = scan_str(s,FALSE,FALSE,FALSE,NULL);
- if (!s)
- missingterm(NULL, 0);
- pl_yylval.ival = OP_STRINGIFY;
- if (SvIVX(PL_lex_stuff) == '\'')
- SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
- TERM(sublex_start());
-
- case KEY_qr:
- s = scan_pat(s,OP_QR);
- TERM(sublex_start());
-
- case KEY_qx:
- s = scan_str(s,FALSE,FALSE,FALSE,NULL);
- if (!s)
- missingterm(NULL, 0);
- pl_yylval.ival = OP_BACKTICK;
- TERM(sublex_start());
-
- case KEY_return:
- OLDLOP(OP_RETURN);
-
- case KEY_require:
- s = skipspace(s);
- if (isDIGIT(*s)) {
- s = force_version(s, FALSE);
- }
- else if (*s != 'v' || !isDIGIT(s[1])
- || (s = force_version(s, TRUE), *s == 'v'))
- {
- *PL_tokenbuf = '\0';
- s = force_word(s,BAREWORD,TRUE,TRUE);
- if (isIDFIRST_lazy_if_safe(PL_tokenbuf,
- PL_tokenbuf + sizeof(PL_tokenbuf),
- UTF))
- {
- gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
- GV_ADD | (UTF ? SVf_UTF8 : 0));
- }
- else if (*s == '<')
- yyerror("<> at require-statement should be quotes");
- }
- if (orig_keyword == KEY_require) {
- orig_keyword = 0;
- pl_yylval.ival = 1;
- }
- else
- pl_yylval.ival = 0;
- PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
- PL_bufptr = s;
- PL_last_uni = PL_oldbufptr;
- PL_last_lop_op = OP_REQUIRE;
- s = skipspace(s);
- return REPORT( (int)REQUIRE );
-
- case KEY_reset:
- UNI(OP_RESET);
-
- case KEY_redo:
- LOOPX(OP_REDO);
-
- case KEY_rename:
- LOP(OP_RENAME,XTERM);
-
- case KEY_rand:
- UNI(OP_RAND);
-
- case KEY_rmdir:
- UNI(OP_RMDIR);
-
- case KEY_rindex:
- LOP(OP_RINDEX,XTERM);
-
- case KEY_read:
- LOP(OP_READ,XTERM);
-
- case KEY_readdir:
- UNI(OP_READDIR);
-
- case KEY_readline:
- UNIDOR(OP_READLINE);
-
- case KEY_readpipe:
- UNIDOR(OP_BACKTICK);
-
- case KEY_rewinddir:
- UNI(OP_REWINDDIR);
-
- case KEY_recv:
- LOP(OP_RECV,XTERM);
-
- case KEY_reverse:
- LOP(OP_REVERSE,XTERM);
-
- case KEY_readlink:
- UNIDOR(OP_READLINK);
-
- case KEY_ref:
- UNI(OP_REF);
-
- case KEY_s:
- s = scan_subst(s);
- if (pl_yylval.opval)
- TERM(sublex_start());
- else
- TOKEN(1); /* force error */
-
- case KEY_say:
- checkcomma(s,PL_tokenbuf,"filehandle");
- LOP(OP_SAY,XREF);
-
- case KEY_chomp:
- UNI(OP_CHOMP);
-
- case KEY_scalar:
- UNI(OP_SCALAR);
-
- case KEY_select:
- LOP(OP_SELECT,XTERM);
-
- case KEY_seek:
- LOP(OP_SEEK,XTERM);
-
- case KEY_semctl:
- LOP(OP_SEMCTL,XTERM);
-
- case KEY_semget:
- LOP(OP_SEMGET,XTERM);
-
- case KEY_semop:
- LOP(OP_SEMOP,XTERM);
-
- case KEY_send:
- LOP(OP_SEND,XTERM);
-
- case KEY_setpgrp:
- LOP(OP_SETPGRP,XTERM);
-
- case KEY_setpriority:
- LOP(OP_SETPRIORITY,XTERM);
-
- case KEY_sethostent:
- UNI(OP_SHOSTENT);
-
- case KEY_setnetent:
- UNI(OP_SNETENT);
-
- case KEY_setservent:
- UNI(OP_SSERVENT);
-
- case KEY_setprotoent:
- UNI(OP_SPROTOENT);
-
- case KEY_setpwent:
- FUN0(OP_SPWENT);
-
- case KEY_setgrent:
- FUN0(OP_SGRENT);
-
- case KEY_seekdir:
- LOP(OP_SEEKDIR,XTERM);
+ case '\r':
+#ifdef PERL_STRICT_CR
+ Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
+ Perl_croak(aTHX_
+ "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
+#endif
+ case ' ': case '\t': case '\f': case '\v':
+ s++;
+ goto retry;
- case KEY_setsockopt:
- LOP(OP_SSOCKOPT,XTERM);
+ case '#':
+ case '\n': {
+ const bool needs_semicolon = yyl_eol_needs_semicolon(aTHX_ &s);
+ if (needs_semicolon)
+ TOKEN(';');
+ else
+ goto retry;
+ }
- case KEY_shift:
- UNIDOR(OP_SHIFT);
+ case '-':
+ return yyl_hyphen(aTHX_ s);
- case KEY_shmctl:
- LOP(OP_SHMCTL,XTERM);
+ case '+':
+ return yyl_plus(aTHX_ s);
- case KEY_shmget:
- LOP(OP_SHMGET,XTERM);
+ case '*':
+ return yyl_star(aTHX_ s);
- case KEY_shmread:
- LOP(OP_SHMREAD,XTERM);
+ case '%':
+ return yyl_percent(aTHX_ s);
- case KEY_shmwrite:
- LOP(OP_SHMWRITE,XTERM);
+ case '^':
+ return yyl_caret(aTHX_ s);
- case KEY_shutdown:
- LOP(OP_SHUTDOWN,XTERM);
+ case '[':
+ return yyl_leftsquare(aTHX_ s);
- case KEY_sin:
- UNI(OP_SIN);
+ case '~':
+ return yyl_tilde(aTHX_ s);
- case KEY_sleep:
- UNI(OP_SLEEP);
+ case ',':
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
+ TOKEN(0);
+ s++;
+ OPERATOR(',');
+ case ':':
+ if (s[1] == ':')
+ return yyl_just_a_word(aTHX_ s, 0, 0, no_code);
+ return yyl_colon(aTHX_ s + 1);
- case KEY_socket:
- LOP(OP_SOCKET,XTERM);
+ case '(':
+ return yyl_leftparen(aTHX_ s + 1);
- case KEY_socketpair:
- LOP(OP_SOCKPAIR,XTERM);
+ case ';':
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ TOKEN(0);
+ CLINE;
+ s++;
+ PL_expect = XSTATE;
+ TOKEN(';');
- case KEY_sort:
- checkcomma(s,PL_tokenbuf,"subroutine name");
- s = skipspace(s);
- PL_expect = XTERM;
- s = force_word(s,BAREWORD,TRUE,TRUE);
- LOP(OP_SORT,XREF);
+ case ')':
+ return yyl_rightparen(aTHX_ s);
- case KEY_split:
- LOP(OP_SPLIT,XTERM);
+ case ']':
+ return yyl_rightsquare(aTHX_ s);
- case KEY_sprintf:
- LOP(OP_SPRINTF,XTERM);
+ case '{':
+ return yyl_leftcurly(aTHX_ s + 1, 0);
- case KEY_splice:
- LOP(OP_SPLICE,XTERM);
+ case '}':
+ if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
+ TOKEN(0);
+ return yyl_rightcurly(aTHX_ s, 0);
- case KEY_sqrt:
- UNI(OP_SQRT);
+ case '&':
+ return yyl_ampersand(aTHX_ s);
- case KEY_srand:
- UNI(OP_SRAND);
+ case '|':
+ return yyl_verticalbar(aTHX_ s);
- case KEY_stat:
- UNI(OP_STAT);
+ case '=':
+ if (s[1] == '=' && (s == PL_linestart || s[-1] == '\n')
+ && memBEGINs(s + 2, (STRLEN) (PL_bufend - (s + 2)), "====="))
+ {
+ s = vcs_conflict_marker(s + 7);
+ goto retry;
+ }
- case KEY_study:
- UNI(OP_STUDY);
+ s++;
+ {
+ const char tmp = *s++;
+ if (tmp == '=') {
+ if (!PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ {
+ s -= 2;
+ TOKEN(0);
+ }
+ ChEop(OP_EQ);
+ }
+ if (tmp == '>') {
+ if (!PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
+ {
+ s -= 2;
+ TOKEN(0);
+ }
+ OPERATOR(',');
+ }
+ if (tmp == '~')
+ PMop(OP_MATCH);
+ if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
+ && memCHRs("+-*/%.^&|<",tmp))
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Reversed %c= operator",(int)tmp);
+ s--;
+ if (PL_expect == XSTATE
+ && isALPHA(tmp)
+ && (s == PL_linestart+1 || s[-2] == '\n') )
+ {
+ if ( (PL_in_eval && !PL_rsfp && !PL_parser->filtered)
+ || PL_lex_state != LEX_NORMAL)
+ {
+ d = PL_bufend;
+ while (s < d) {
+ if (*s++ == '\n') {
+ incline(s, PL_bufend);
+ if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=cut"))
+ {
+ s = (char *) memchr(s,'\n', d - s);
+ if (s)
+ s++;
+ else
+ s = d;
+ incline(s, PL_bufend);
+ goto retry;
+ }
+ }
+ }
+ goto retry;
+ }
+ s = PL_bufend;
+ PL_parser->in_pod = 1;
+ goto retry;
+ }
+ }
+ if (PL_expect == XBLOCK) {
+ const char *t = s;
+#ifdef PERL_STRICT_CR
+ while (SPACE_OR_TAB(*t))
+#else
+ while (SPACE_OR_TAB(*t) || *t == '\r')
+#endif
+ t++;
+ if (*t == '\n' || *t == '#') {
+ ENTER_with_name("lex_format");
+ SAVEI8(PL_parser->form_lex_state);
+ SAVEI32(PL_lex_formbrack);
+ PL_parser->form_lex_state = PL_lex_state;
+ PL_lex_formbrack = PL_lex_brackets + 1;
+ PL_parser->sub_error_count = PL_error_count;
+ return yyl_leftcurly(aTHX_ s, 1);
+ }
+ }
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s--;
+ TOKEN(0);
+ }
+ pl_yylval.ival = 0;
+ OPERATOR(ASSIGNOP);
- case KEY_substr:
- LOP(OP_SUBSTR,XTERM);
+ case '!':
+ return yyl_bang(aTHX_ s + 1);
- case KEY_format:
- case KEY_sub:
- really_sub:
- {
- char * const tmpbuf = PL_tokenbuf + 1;
- bool have_name, have_proto;
- const int key = tmp;
- SV *format_name = NULL;
- bool is_sigsub = FEATURE_SIGNATURES_IS_ENABLED;
-
- SSize_t off = s-SvPVX(PL_linestr);
- s = skipspace(s);
- d = SvPVX(PL_linestr)+off;
-
- SAVEBOOL(PL_parser->sig_seen);
- PL_parser->sig_seen = FALSE;
-
- if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
- || *s == '\''
- || (*s == ':' && s[1] == ':'))
- {
+ case '<':
+ if (s[1] == '<' && (s == PL_linestart || s[-1] == '\n')
+ && memBEGINs(s + 2, (STRLEN) (PL_bufend - (s + 2)), "<<<<<"))
+ {
+ s = vcs_conflict_marker(s + 7);
+ goto retry;
+ }
+ return yyl_leftpointy(aTHX_ s);
- PL_expect = XATTRBLOCK;
- d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
- &len);
- if (key == KEY_format)
- format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
- *PL_tokenbuf = '&';
- if (memchr(tmpbuf, ':', len) || key != KEY_sub
- || pad_findmy_pvn(
- PL_tokenbuf, len + 1, 0
- ) != NOT_IN_PAD)
- sv_setpvn(PL_subname, tmpbuf, len);
- else {
- sv_setsv(PL_subname,PL_curstname);
- sv_catpvs(PL_subname,"::");
- sv_catpvn(PL_subname,tmpbuf,len);
- }
- if (SvUTF8(PL_linestr))
- SvUTF8_on(PL_subname);
- have_name = TRUE;
+ case '>':
+ if (s[1] == '>' && (s == PL_linestart || s[-1] == '\n')
+ && memBEGINs(s + 2, (STRLEN) (PL_bufend - (s + 2)), ">>>>>"))
+ {
+ s = vcs_conflict_marker(s + 7);
+ goto retry;
+ }
+ return yyl_rightpointy(aTHX_ s + 1);
+ case '$':
+ return yyl_dollar(aTHX_ s);
- s = skipspace(d);
- }
- else {
- if (key == KEY_my || key == KEY_our || key==KEY_state)
- {
- *d = '\0';
- /* diag_listed_as: Missing name in "%s sub" */
- Perl_croak(aTHX_
- "Missing name in \"%s\"", PL_bufptr);
- }
- PL_expect = XATTRTERM;
- sv_setpvs(PL_subname,"?");
- have_name = FALSE;
- }
+ case '@':
+ return yyl_snail(aTHX_ s);
- if (key == KEY_format) {
- if (format_name) {
- NEXTVAL_NEXTTOKE.opval
- = newSVOP(OP_CONST,0, format_name);
- NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
- force_next(BAREWORD);
- }
- PREBLOCK(FORMAT);
- }
+ case '/': /* may be division, defined-or, or pattern */
+ return yyl_slash(aTHX_ s);
- /* Look for a prototype */
- if (*s == '(' && !is_sigsub) {
- s = scan_str(s,FALSE,FALSE,FALSE,NULL);
- if (!s)
- Perl_croak(aTHX_ "Prototype not terminated");
- COPLINE_SET_FROM_MULTI_END;
- (void)validate_proto(PL_subname, PL_lex_stuff,
- ckWARN(WARN_ILLEGALPROTO), 0);
- have_proto = TRUE;
-
- s = skipspace(s);
- }
- else
- have_proto = FALSE;
+ case '?': /* conditional */
+ s++;
+ if (!PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
+ {
+ s--;
+ TOKEN(0);
+ }
+ PL_lex_allbrackets++;
+ OPERATOR('?');
- if ( !(*s == ':' && s[1] != ':')
- && (*s != '{' && *s != '(') && key != KEY_format)
+ case '.':
+ if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
+#ifdef PERL_STRICT_CR
+ && s[1] == '\n'
+#else
+ && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
+#endif
+ && (s == PL_linestart || s[-1] == '\n') )
+ {
+ PL_expect = XSTATE;
+ /* formbrack==2 means dot seen where arguments expected */
+ return yyl_rightcurly(aTHX_ s, 2);
+ }
+ if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
+ s += 3;
+ OPERATOR(YADAYADA);
+ }
+ if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
+ char tmp = *s++;
+ if (*s == tmp) {
+ if (!PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_RANGE)
{
- assert(key == KEY_sub || key == KEY_AUTOLOAD ||
- key == KEY_DESTROY || key == KEY_BEGIN ||
- key == KEY_UNITCHECK || key == KEY_CHECK ||
- key == KEY_INIT || key == KEY_END ||
- key == KEY_my || key == KEY_state ||
- key == KEY_our);
- if (!have_name)
- Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
- else if (*s != ';' && *s != '}')
- Perl_croak(aTHX_ "Illegal declaration of subroutine %" SVf, SVfARG(PL_subname));
- }
-
- if (have_proto) {
- NEXTVAL_NEXTTOKE.opval =
- newSVOP(OP_CONST, 0, PL_lex_stuff);
- PL_lex_stuff = NULL;
- force_next(THING);
+ s--;
+ TOKEN(0);
}
- if (!have_name) {
- if (PL_curstash)
- sv_setpvs(PL_subname, "__ANON__");
- else
- sv_setpvs(PL_subname, "__ANON__::__ANON__");
- if (is_sigsub)
- TOKEN(ANON_SIGSUB);
- else
- TOKEN(ANONSUB);
+ s++;
+ if (*s == tmp) {
+ s++;
+ pl_yylval.ival = OPf_SPECIAL;
}
- force_ident_maybe_lex('&');
- if (is_sigsub)
- TOKEN(SIGSUB);
- else
- TOKEN(SUB);
+ else
+ pl_yylval.ival = 0;
+ OPERATOR(DOTDOT);
}
+ if (*s == '=' && !PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
+ {
+ s--;
+ TOKEN(0);
+ }
+ Aop(OP_CONCAT);
+ }
+ /* FALLTHROUGH */
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ s = scan_num(s, &pl_yylval);
+ DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
+ if (PL_expect == XOPERATOR)
+ no_op("Number",s);
+ TERM(THING);
- case KEY_system:
- LOP(OP_SYSTEM,XREF);
-
- case KEY_symlink:
- LOP(OP_SYMLINK,XTERM);
-
- case KEY_syscall:
- LOP(OP_SYSCALL,XTERM);
-
- case KEY_sysopen:
- LOP(OP_SYSOPEN,XTERM);
-
- case KEY_sysseek:
- LOP(OP_SYSSEEK,XTERM);
-
- case KEY_sysread:
- LOP(OP_SYSREAD,XTERM);
+ case '\'':
+ return yyl_sglquote(aTHX_ s);
- case KEY_syswrite:
- LOP(OP_SYSWRITE,XTERM);
+ case '"':
+ return yyl_dblquote(aTHX_ s);
- case KEY_tr:
- case KEY_y:
- s = scan_trans(s);
- TERM(sublex_start());
+ case '`':
+ return yyl_backtick(aTHX_ s);
- case KEY_tell:
- UNI(OP_TELL);
+ case '\\':
+ return yyl_backslash(aTHX_ s + 1);
- case KEY_telldir:
- UNI(OP_TELLDIR);
+ case 'v':
+ if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
+ char *start = s + 2;
+ while (isDIGIT(*start) || *start == '_')
+ start++;
+ if (*start == '.' && isDIGIT(start[1])) {
+ s = scan_num(s, &pl_yylval);
+ TERM(THING);
+ }
+ else if ((*start == ':' && start[1] == ':')
+ || (PL_expect == XSTATE && *start == ':')) {
+ if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
+ }
+ else if (PL_expect == XSTATE) {
+ d = start;
+ while (d < PL_bufend && isSPACE(*d)) d++;
+ if (*d == ':') {
+ if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
+ }
+ }
+ /* avoid v123abc() or $h{v1}, allow C<print v10;> */
+ if (!isALPHA(*start) && (PL_expect == XTERM
+ || PL_expect == XREF || PL_expect == XSTATE
+ || PL_expect == XTERMORDORDOR)) {
+ GV *const gv = gv_fetchpvn_flags(s, start - s,
+ UTF ? SVf_UTF8 : 0, SVt_PVCV);
+ if (!gv) {
+ s = scan_num(s, &pl_yylval);
+ TERM(THING);
+ }
+ }
+ }
+ if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
- case KEY_tie:
- LOP(OP_TIE,XTERM);
+ case 'x':
+ if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
+ s++;
+ Mop(OP_REPEAT);
+ }
+ if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
- case KEY_tied:
- UNI(OP_TIED);
+ case '_':
+ case 'a': case 'A':
+ case 'b': case 'B':
+ case 'c': case 'C':
+ case 'd': case 'D':
+ case 'e': case 'E':
+ case 'f': case 'F':
+ case 'g': case 'G':
+ case 'h': case 'H':
+ case 'i': case 'I':
+ case 'j': case 'J':
+ case 'k': case 'K':
+ case 'l': case 'L':
+ case 'm': case 'M':
+ case 'n': case 'N':
+ case 'o': case 'O':
+ case 'p': case 'P':
+ case 'q': case 'Q':
+ case 'r': case 'R':
+ case 's': case 'S':
+ case 't': case 'T':
+ case 'u': case 'U':
+ case 'V':
+ case 'w': case 'W':
+ case 'X':
+ case 'y': case 'Y':
+ case 'z': case 'Z':
+ if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
+ }
+}
- case KEY_time:
- FUN0(OP_TIME);
- case KEY_times:
- FUN0(OP_TMS);
+/*
+ yylex
- case KEY_truncate:
- LOP(OP_TRUNCATE,XTERM);
+ Works out what to call the token just pulled out of the input
+ stream. The yacc parser takes care of taking the ops we return and
+ stitching them into a tree.
- case KEY_uc:
- UNI(OP_UC);
+ Returns:
+ The type of the next token
- case KEY_ucfirst:
- UNI(OP_UCFIRST);
+ Structure:
+ Check if we have already built the token; if so, use it.
+ Switch based on the current state:
+ - if we have a case modifier in a string, deal with that
+ - handle other cases of interpolation inside a string
+ - scan the next line if we are inside a format
+ In the normal state, switch on the next character:
+ - default:
+ if alphabetic, go to key lookup
+ unrecognized character - croak
+ - 0/4/26: handle end-of-line or EOF
+ - cases for whitespace
+ - \n and #: handle comments and line numbers
+ - various operators, brackets and sigils
+ - numbers
+ - quotes
+ - 'v': vstrings (or go to key lookup)
+ - 'x' repetition operator (or go to key lookup)
+ - other ASCII alphanumerics (key lookup begins here):
+ word before => ?
+ keyword plugin
+ scan built-in keyword (but do nothing with it yet)
+ check for statement label
+ check for lexical subs
+ return yyl_just_a_word if there is one
+ see whether built-in keyword is overridden
+ switch on keyword number:
+ - default: return yyl_just_a_word:
+ not a built-in keyword; handle bareword lookup
+ disambiguate between method and sub call
+ fall back to bareword
+ - cases for built-in keywords
+*/
- case KEY_untie:
- UNI(OP_UNTIE);
+#ifdef NETWARE
+#define RSFP_FILENO (PL_rsfp)
+#else
+#define RSFP_FILENO (PerlIO_fileno(PL_rsfp))
+#endif
- case KEY_until:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
- return REPORT(0);
- pl_yylval.ival = CopLINE(PL_curcop);
- OPERATOR(UNTIL);
- case KEY_unless:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
- return REPORT(0);
- pl_yylval.ival = CopLINE(PL_curcop);
- OPERATOR(UNLESS);
+int
+Perl_yylex(pTHX)
+{
+ char *s = PL_bufptr;
- case KEY_unlink:
- LOP(OP_UNLINK,XTERM);
+ if (UNLIKELY(PL_parser->recheck_utf8_validity)) {
+ const U8* first_bad_char_loc;
+ if (UTF && UNLIKELY(! is_utf8_string_loc((U8 *) PL_bufptr,
+ PL_bufend - PL_bufptr,
+ &first_bad_char_loc)))
+ {
+ _force_out_malformed_utf8_message(first_bad_char_loc,
+ (U8 *) PL_bufend,
+ 0,
+ 1 /* 1 means die */ );
+ NOT_REACHED; /* NOTREACHED */
+ }
+ PL_parser->recheck_utf8_validity = FALSE;
+ }
+ DEBUG_T( {
+ SV* tmp = newSVpvs("");
+ PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n",
+ (IV)CopLINE(PL_curcop),
+ lex_state_names[PL_lex_state],
+ exp_name[PL_expect],
+ pv_display(tmp, s, strlen(s), 0, 60));
+ SvREFCNT_dec(tmp);
+ } );
- case KEY_undef:
- UNIDOR(OP_UNDEF);
+ /* when we've already built the next token, just pull it out of the queue */
+ if (PL_nexttoke) {
+ PL_nexttoke--;
+ pl_yylval = PL_nextval[PL_nexttoke];
+ {
+ I32 next_type;
+ next_type = PL_nexttype[PL_nexttoke];
+ if (next_type & (7<<24)) {
+ if (next_type & (1<<24)) {
+ if (PL_lex_brackets > 100)
+ Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
+ PL_lex_brackstack[PL_lex_brackets++] =
+ (char) ((next_type >> 16) & 0xff);
+ }
+ if (next_type & (2<<24))
+ PL_lex_allbrackets++;
+ if (next_type & (4<<24))
+ PL_lex_allbrackets--;
+ next_type &= 0xffff;
+ }
+ return REPORT(next_type == 'p' ? pending_ident() : next_type);
+ }
+ }
- case KEY_unpack:
- LOP(OP_UNPACK,XTERM);
+ switch (PL_lex_state) {
+ case LEX_NORMAL:
+ case LEX_INTERPNORMAL:
+ break;
- case KEY_utime:
- LOP(OP_UTIME,XTERM);
+ /* interpolated case modifiers like \L \U, including \Q and \E.
+ when we get here, PL_bufptr is at the \
+ */
+ case LEX_INTERPCASEMOD:
+ /* handle \E or end of string */
+ return yyl_interpcasemod(aTHX_ s);
- case KEY_umask:
- UNIDOR(OP_UMASK);
+ case LEX_INTERPPUSH:
+ return REPORT(sublex_push());
- case KEY_unshift:
- LOP(OP_UNSHIFT,XTERM);
+ case LEX_INTERPSTART:
+ if (PL_bufptr == PL_bufend)
+ return REPORT(sublex_done());
+ DEBUG_T({
+ if(*PL_bufptr != '(')
+ PerlIO_printf(Perl_debug_log, "### Interpolated variable\n");
+ });
+ PL_expect = XTERM;
+ /* for /@a/, we leave the joining for the regex engine to do
+ * (unless we're within \Q etc) */
+ PL_lex_dojoin = (*PL_bufptr == '@'
+ && (!PL_lex_inpat || PL_lex_casemods));
+ PL_lex_state = LEX_INTERPNORMAL;
+ if (PL_lex_dojoin) {
+ NEXTVAL_NEXTTOKE.ival = 0;
+ force_next(',');
+ force_ident("\"", '$');
+ NEXTVAL_NEXTTOKE.ival = 0;
+ force_next('$');
+ NEXTVAL_NEXTTOKE.ival = 0;
+ force_next((2<<24)|'(');
+ NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
+ force_next(FUNC);
+ }
+ /* Convert (?{...}) and friends to 'do {...}' */
+ if (PL_lex_inpat && *PL_bufptr == '(') {
+ PL_parser->lex_shared->re_eval_start = PL_bufptr;
+ PL_bufptr += 2;
+ if (*PL_bufptr != '{')
+ PL_bufptr++;
+ PL_expect = XTERMBLOCK;
+ force_next(DO);
+ }
- case KEY_use:
- s = tokenize_use(1, s);
- TOKEN(USE);
+ if (PL_lex_starts++) {
+ s = PL_bufptr;
+ /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
+ if (!PL_lex_casemods && PL_lex_inpat)
+ TOKEN(',');
+ else
+ AopNOASSIGN(OP_CONCAT);
+ }
+ return yylex();
- case KEY_values:
- UNI(OP_VALUES);
+ case LEX_INTERPENDMAYBE:
+ if (intuit_more(PL_bufptr, PL_bufend)) {
+ PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
+ break;
+ }
+ /* FALLTHROUGH */
- case KEY_vec:
- LOP(OP_VEC,XTERM);
+ case LEX_INTERPEND:
+ if (PL_lex_dojoin) {
+ const U8 dojoin_was = PL_lex_dojoin;
+ PL_lex_dojoin = FALSE;
+ PL_lex_state = LEX_INTERPCONCAT;
+ PL_lex_allbrackets--;
+ return REPORT(dojoin_was == 1 ? (int)')' : (int)POSTJOIN);
+ }
+ if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
+ && SvEVALED(PL_lex_repl))
+ {
+ if (PL_bufptr != PL_bufend)
+ Perl_croak(aTHX_ "Bad evalled substitution pattern");
+ PL_lex_repl = NULL;
+ }
+ /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
+ re_eval_str. If the here-doc body’s length equals the previous
+ value of re_eval_start, re_eval_start will now be null. So
+ check re_eval_str as well. */
+ if (PL_parser->lex_shared->re_eval_start
+ || PL_parser->lex_shared->re_eval_str) {
+ SV *sv;
+ if (*PL_bufptr != ')')
+ Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
+ PL_bufptr++;
+ /* having compiled a (?{..}) expression, return the original
+ * text too, as a const */
+ if (PL_parser->lex_shared->re_eval_str) {
+ sv = PL_parser->lex_shared->re_eval_str;
+ PL_parser->lex_shared->re_eval_str = NULL;
+ SvCUR_set(sv,
+ PL_bufptr - PL_parser->lex_shared->re_eval_start);
+ SvPV_shrink_to_cur(sv);
+ }
+ else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
+ PL_bufptr - PL_parser->lex_shared->re_eval_start);
+ NEXTVAL_NEXTTOKE.opval =
+ newSVOP(OP_CONST, 0,
+ sv);
+ force_next(THING);
+ PL_parser->lex_shared->re_eval_start = NULL;
+ PL_expect = XTERM;
+ return REPORT(',');
+ }
- case KEY_when:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
- return REPORT(0);
- pl_yylval.ival = CopLINE(PL_curcop);
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
- "when is experimental");
- OPERATOR(WHEN);
+ /* FALLTHROUGH */
+ case LEX_INTERPCONCAT:
+#ifdef DEBUGGING
+ if (PL_lex_brackets)
+ Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
+ (long) PL_lex_brackets);
+#endif
+ if (PL_bufptr == PL_bufend)
+ return REPORT(sublex_done());
- case KEY_while:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
- return REPORT(0);
- pl_yylval.ival = CopLINE(PL_curcop);
- OPERATOR(WHILE);
+ /* m'foo' still needs to be parsed for possible (?{...}) */
+ if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
+ SV *sv = newSVsv(PL_linestr);
+ sv = tokeq(sv);
+ pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
+ s = PL_bufend;
+ }
+ else {
+ int save_error_count = PL_error_count;
- case KEY_warn:
- PL_hints |= HINT_BLOCK_SCOPE;
- LOP(OP_WARN,XTERM);
+ s = scan_const(PL_bufptr);
- case KEY_wait:
- FUN0(OP_WAIT);
+ /* Set flag if this was a pattern and there were errors. op.c will
+ * refuse to compile a pattern with this flag set. Otherwise, we
+ * could get segfaults, etc. */
+ if (PL_lex_inpat && PL_error_count > save_error_count) {
+ ((PMOP*)PL_lex_inpat)->op_pmflags |= PMf_HAS_ERROR;
+ }
+ if (*s == '\\')
+ PL_lex_state = LEX_INTERPCASEMOD;
+ else
+ PL_lex_state = LEX_INTERPSTART;
+ }
- case KEY_waitpid:
- LOP(OP_WAITPID,XTERM);
+ if (s != PL_bufptr) {
+ NEXTVAL_NEXTTOKE = pl_yylval;
+ PL_expect = XTERM;
+ force_next(THING);
+ if (PL_lex_starts++) {
+ /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
+ if (!PL_lex_casemods && PL_lex_inpat)
+ TOKEN(',');
+ else
+ AopNOASSIGN(OP_CONCAT);
+ }
+ else {
+ PL_bufptr = s;
+ return yylex();
+ }
+ }
- case KEY_wantarray:
- FUN0(OP_WANTARRAY);
+ return yylex();
+ case LEX_FORMLINE:
+ if (PL_parser->sub_error_count != PL_error_count) {
+ /* There was an error parsing a formline, which tends to
+ mess up the parser.
+ Unlike interpolated sub-parsing, we can't treat any of
+ these as recoverable, so no need to check sub_no_recover.
+ */
+ yyquit();
+ }
+ assert(PL_lex_formbrack);
+ s = scan_formline(PL_bufptr);
+ if (!PL_lex_formbrack)
+ return yyl_rightcurly(aTHX_ s, 1);
+ PL_bufptr = s;
+ return yylex();
+ }
- case KEY_write:
- /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
- * we use the same number on EBCDIC */
- gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
- UNI(OP_ENTERWRITE);
+ /* We really do *not* want PL_linestr ever becoming a COW. */
+ assert (!SvIsCOW(PL_linestr));
+ s = PL_bufptr;
+ PL_oldoldbufptr = PL_oldbufptr;
+ PL_oldbufptr = s;
- case KEY_x:
- if (PL_expect == XOPERATOR) {
- if (*s == '=' && !PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
- {
- return REPORT(0);
- }
- Mop(OP_REPEAT);
- }
- check_uni();
- goto just_a_word;
+ if (PL_in_my == KEY_sigvar) {
+ PL_parser->saw_infix_sigil = 0;
+ return yyl_sigvar(aTHX_ s);
+ }
- case KEY_xor:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
- return REPORT(0);
- pl_yylval.ival = OP_XOR;
- OPERATOR(OROP);
- }
- }}
+ {
+ /* yyl_try() and its callees might consult PL_parser->saw_infix_sigil.
+ On its return, we then need to set it to indicate whether the token
+ we just encountered was an infix operator that (if we hadn't been
+ expecting an operator) have been a sigil.
+ */
+ bool expected_operator = (PL_expect == XOPERATOR);
+ int ret = yyl_try(aTHX_ s);
+ switch (pl_yylval.ival) {
+ case OP_BIT_AND:
+ case OP_MODULO:
+ case OP_MULTIPLY:
+ case OP_NBIT_AND:
+ if (expected_operator) {
+ PL_parser->saw_infix_sigil = 1;
+ break;
+ }
+ /* FALLTHROUGH */
+ default:
+ PL_parser->saw_infix_sigil = 0;
+ }
+ return ret;
+ }
}
+
/*
S_pending_ident
Looks up an identifier in the pad or in a package
- is_sig indicates that this is a subroutine signature variable
+ PL_in_my == KEY_sigvar indicates that this is a subroutine signature variable
rather than a plain pad var.
Returns:
/* diag_listed_as: No package name allowed for variable %s
in "our" */
yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
- "%se %s in \"our\"",
- *PL_tokenbuf=='&' ?"subroutin":"variabl",
+ "%s %s in \"our\"",
+ *PL_tokenbuf=='&' ? "subroutine" : "variable",
PL_tokenbuf), UTF ? SVf_UTF8 : 0);
tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
}
GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
PL_in_my == KEY_my ? "my" : "state",
- *PL_tokenbuf == '&' ? "subroutin" : "variabl",
+ *PL_tokenbuf == '&' ? "subroutine" : "variable",
PL_tokenbuf),
UTF ? SVf_UTF8 : 0);
GCC_DIAG_RESTORE_STMT;
* block / parens, boolean operators (&&, ||, //) and branch
* constructs (or, and, if, until, unless, while, err, for).
* Not a very solid hack... */
- if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
+ if (!*w || !memCHRs(";&/|})]oaiuwef!=", *w))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"%s (...) interpreted as function",name);
}
SV **cvp;
SV *cv, *typesv;
const char *why1 = "", *why2 = "", *why3 = "";
+ const char * optional_colon = ":"; /* Only some messages have a colon */
+ char *msg;
PERL_ARGS_ASSERT_NEW_CONSTANT;
/* We assume that this is true: */
- if (*key == 'c') { assert (strEQ(key, "charnames")); }
assert(type || s);
sv_2mortal(sv); /* Parent created it permanently */
- if (!table
- || ! (PL_hints & HINT_LOCALIZE_HH)
- || ! (cvp = hv_fetch(table, key, keylen, FALSE))
- || ! SvOK(*cvp))
+
+ if ( ! table
+ || ! (PL_hints & HINT_LOCALIZE_HH))
{
- char *msg;
-
- /* Here haven't found what we're looking for. If it is charnames,
- * perhaps it needs to be loaded. Try doing that before giving up */
- if (*key == 'c') {
- Perl_load_module(aTHX_
- 0,
- newSVpvs("_charnames"),
- /* version parameter; no need to specify it, as if
- * we get too early a version, will fail anyway,
- * not being able to find '_charnames' */
- NULL,
- newSVpvs(":full"),
- newSVpvs(":short"),
- NULL);
- assert(sp == PL_stack_sp);
- table = GvHV(PL_hintgv);
- if (table
- && (PL_hints & HINT_LOCALIZE_HH)
- && (cvp = hv_fetch(table, key, keylen, FALSE))
- && SvOK(*cvp))
- {
- goto now_ok;
- }
- }
- if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
- msg = Perl_form(aTHX_
- "Constant(%.*s) unknown",
- (int)(type ? typelen : len),
- (type ? type: s));
- }
- else {
- why1 = "$^H{";
- why2 = key;
- why3 = "} is not defined";
- report:
- if (*key == 'c') {
- msg = Perl_form(aTHX_
- /* The +3 is for '\N{'; -4 for that, plus '}' */
- "Unknown charname '%.*s'", (int)typelen - 4, type + 3
- );
- }
- else {
- msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
- (int)(type ? typelen : len),
- (type ? type: s), why1, why2, why3);
- }
- }
- if (error_msg) {
- *error_msg = msg;
- }
- else {
- yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
- }
- return SvREFCNT_inc_simple_NN(sv);
+ why1 = "unknown";
+ optional_colon = "";
+ goto report;
}
- now_ok:
+
+ cvp = hv_fetch(table, key, keylen, FALSE);
+ if (!cvp || !SvOK(*cvp)) {
+ why1 = "$^H{";
+ why2 = key;
+ why3 = "} is not defined";
+ goto report;
+ }
+
cv = *cvp;
if (!pv && s)
pv = newSVpvn_flags(s, len, SVs_TEMP);
LEAVE ;
POPSTACK;
- if (!SvOK(res)) {
- why1 = "Call to &{$^H{";
- why2 = key;
- why3 = "}} did not return a defined value";
- sv = res;
- (void)sv_2mortal(sv);
- goto report;
+ if (SvOK(res)) {
+ return res;
}
- return res;
+ sv = res;
+ (void)sv_2mortal(sv);
+
+ why1 = "Call to &{$^H{";
+ why2 = key;
+ why3 = "}} did not return a defined value";
+
+ report:
+
+ msg = Perl_form(aTHX_ "Constant(%.*s)%s %s%s%s",
+ (int)(type ? typelen : len),
+ (type ? type: s),
+ optional_colon,
+ why1, why2, why3);
+ if (error_msg) {
+ *error_msg = msg;
+ }
+ else {
+ yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
+ }
+ return SvREFCNT_inc_simple_NN(sv);
}
PERL_STATIC_INLINE void
}
if (UNLIKELY(tick_warn && saw_tick && PL_lex_state == LEX_INTERPNORMAL
&& !PL_lex_brackets && ckWARN(WARN_SYNTAX))) {
- char *d;
+ char *this_d;
char *d2;
- Newx(d, *s - olds + saw_tick + 2, char); /* +2 for $# */
- d2 = d;
- SAVEFREEPV(d);
+ Newx(this_d, *s - olds + saw_tick + 2, char); /* +2 for $# */
+ d2 = this_d;
+ SAVEFREEPV(this_d);
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Old package separator used in string");
if (olds[-1] == '#')
}
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"\t(Did you mean \"%" UTF8f "\" instead?)\n",
- UTF8fARG(is_utf8, d2-d, d));
+ UTF8fARG(is_utf8, d2-this_d, this_d));
}
return;
}
/* Returns a NUL terminated string, with the length of the string written to
*slp
*/
-STATIC char *
-S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
+char *
+Perl_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
char *d = dest;
char * const e = d + destlen - 3; /* two-character token, ending NUL */
if (isSPACE(*s) || !*s)
s = skipspace(s);
- if (isDIGIT(*s)) {
- while (isDIGIT(*s)) {
- if (d >= e)
- Perl_croak(aTHX_ "%s", ident_too_long);
- *d++ = *s++;
- }
+ if (isDIGIT(*s)) { /* handle $0 and $1 $2 and $10 and etc */
+ bool is_zero= *s == '0' ? TRUE : FALSE;
+ char *digit_start= d;
+ *d++ = *s++;
+ while (s < PL_bufend && isDIGIT(*s)) {
+ if (d >= e)
+ Perl_croak(aTHX_ "%s", ident_too_long);
+ *d++ = *s++;
+ }
+ if (is_zero && d - digit_start > 1)
+ Perl_croak(aTHX_ ident_var_zero_multi_digit);
}
else { /* See if it is a "normal" identifier */
parse_ident(&s, &d, e, 1, is_utf8, FALSE, TRUE);
s = skipspace(s);
}
}
- if ((s <= PL_bufend - (is_utf8)
+ if ((s <= PL_bufend - ((is_utf8)
? UTF8SKIP(s)
- : 1)
+ : 1))
&& VALID_LEN_ONE_IDENT(s, PL_bufend, is_utf8))
{
if (is_utf8) {
}
else {
*d = *s++;
+ /* special case to handle ${10}, ${11} the same way we handle ${1} etc */
+ if (isDIGIT(*d)) {
+ bool is_zero= *d == '0' ? TRUE : FALSE;
+ char *digit_start= d;
+ while (s < PL_bufend && isDIGIT(*s)) {
+ d++;
+ if (d >= e)
+ Perl_croak(aTHX_ "%s", ident_too_long);
+ *d= *s++;
+ }
+ if (is_zero && d - digit_start > 1)
+ Perl_croak(aTHX_ ident_var_zero_multi_digit);
+ }
d[1] = '\0';
}
}
PL_lex_state = LEX_INTERPEND;
PL_expect = XREF;
}
- if (PL_lex_state == LEX_NORMAL) {
+ if (PL_lex_state == LEX_NORMAL || PL_lex_brackets) {
if (ckWARN(WARN_AMBIGUOUS)
&& (keyword(dest, d - dest, 0)
|| get_cvn_flags(dest, d - dest, is_utf8
o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
o->op_private &= ~OPpTRANS_ALL;
- o->op_private |= del|squash|complement|
- (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
- (DO_UTF8(PL_parser->lex_sub_repl) ? OPpTRANS_TO_UTF : 0);
+ o->op_private |= del|squash|complement;
PL_lex_op = o;
pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
*PL_tokenbuf = '\n';
peek = s;
+
if (*peek == '~') {
indented = TRUE;
peek++; s++;
}
+
while (SPACE_OR_TAB(*peek))
peek++;
+
if (*peek == '`' || *peek == '\'' || *peek =='"') {
s = peek;
term = *s++;
s++, term = '\'';
else
term = '"';
+
if (! isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
Perl_croak(aTHX_ "Use of bare << to mean <<\"\" is forbidden");
+
peek = s;
+
while (isWORDCHAR_lazy_if_safe(peek, PL_bufend, UTF)) {
peek += UTF ? UTF8SKIP(peek) : 1;
}
+
len = (peek - s >= e - d) ? (e - d) : (peek - s);
Copy(s, d, len, char);
s += len;
d += len;
}
+
if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
Perl_croak(aTHX_ "Delimiter for here document is too long");
+
*d++ = '\n';
*d = '\0';
len = d - PL_tokenbuf;
PL_multi_start = origline + 1 + PL_parser->herelines;
PL_multi_open = PL_multi_close = '<';
+
/* inside a string eval or quote-like operator */
if (!infile || PL_lex_inwhat) {
SV *linestr;
entered. But we need them set here. */
shared->ls_bufptr = s;
shared->ls_linestr = PL_linestr;
- if (PL_lex_inwhat)
- /* Look for a newline. If the current buffer does not have one,
- peek into the line buffer of the parent lexing scope, going
- up as many levels as necessary to find one with a newline
- after bufptr.
- */
- while (!(s = (char *)memchr(
- (void *)shared->ls_bufptr, '\n',
- SvEND(shared->ls_linestr)-shared->ls_bufptr
- ))) {
- shared = shared->ls_prev;
- /* shared is only null if we have gone beyond the outermost
- lexing scope. In a file, we will have broken out of the
- loop in the previous iteration. In an eval, the string buf-
- fer ends with "\n;", so the while condition above will have
- evaluated to false. So shared can never be null. Or so you
- might think. Odd syntax errors like s;@{<<; can gobble up
- the implicit semicolon at the end of a flie, causing the
- file handle to be closed even when we are not in a string
- eval. So shared may be null in that case.
- (Closing '}' here to balance the earlier open brace for
- editors that look for matched pairs.) */
- if (UNLIKELY(!shared))
- goto interminable;
- /* A LEXSHARED struct with a null ls_prev pointer is the outer-
- most lexing scope. In a file, shared->ls_linestr at that
- level is just one line, so there is no body to steal. */
- if (infile && !shared->ls_prev) {
- s = olds;
- goto streaming;
- }
- }
+
+ if (PL_lex_inwhat) {
+ /* Look for a newline. If the current buffer does not have one,
+ peek into the line buffer of the parent lexing scope, going
+ up as many levels as necessary to find one with a newline
+ after bufptr.
+ */
+ while (!(s = (char *)memchr(
+ (void *)shared->ls_bufptr, '\n',
+ SvEND(shared->ls_linestr)-shared->ls_bufptr
+ )))
+ {
+ shared = shared->ls_prev;
+ /* shared is only null if we have gone beyond the outermost
+ lexing scope. In a file, we will have broken out of the
+ loop in the previous iteration. In an eval, the string buf-
+ fer ends with "\n;", so the while condition above will have
+ evaluated to false. So shared can never be null. Or so you
+ might think. Odd syntax errors like s;@{<<; can gobble up
+ the implicit semicolon at the end of a flie, causing the
+ file handle to be closed even when we are not in a string
+ eval. So shared may be null in that case.
+ (Closing '>>}' here to balance the earlier open brace for
+ editors that look for matched pairs.) */
+ if (UNLIKELY(!shared))
+ goto interminable;
+ /* A LEXSHARED struct with a null ls_prev pointer is the outer-
+ most lexing scope. In a file, shared->ls_linestr at that
+ level is just one line, so there is no body to steal. */
+ if (infile && !shared->ls_prev) {
+ s = olds;
+ goto streaming;
+ }
+ }
+ }
else { /* eval or we've already hit EOF */
s = (char*)memchr((void*)s, '\n', PL_bufend - s);
if (!s)
goto interminable;
}
+
linestr = shared->ls_linestr;
bufend = SvEND(linestr);
d = s;
if (! SPACE_OR_TAB(*backup)) {
break;
}
-
indent_len++;
}
}
}
}
- } else {
+ }
+ else {
while (s < bufend - len + 1
&& memNE(s,PL_tokenbuf,len) )
{
if (s >= bufend - len + 1) {
goto interminable;
}
+
sv_setpvn(tmpstr,d+1,s-d);
s += len - 1;
/* the preceding stmt passes a newline */
bufend - shared->re_eval_start);
shared->re_eval_start -= s-d;
}
+
if (cxstack_ix >= 0
&& CxTYPE(cx) == CXt_EVAL
&& CxOLD_OP_TYPE(cx) == OP_ENTEREVAL
cx->blk_eval.cur_text = newSVsv(linestr);
cx->blk_u16 |= 0x40; /* indicate cur_text is ref counted */
}
+
/* Copy everything from s onwards back to d. */
Move(s,d,bufend-s + 1,char);
SvCUR_set(linestr, SvCUR(linestr) - (s-d));
/* Setting PL_bufend only applies when we have not dug deeper
into other scopes, because sublex_done sets PL_bufend to
SvEND(PL_linestr). */
- if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
+ if (shared == PL_parser->lex_shared)
+ PL_bufend = SvEND(linestr);
s = olds;
}
- else
- {
- SV *linestr_save;
- char *oldbufptr_save;
- char *oldoldbufptr_save;
- streaming:
- SvPVCLEAR(tmpstr); /* avoid "uninitialized" warning */
- term = PL_tokenbuf[1];
- len--;
- linestr_save = PL_linestr; /* must restore this afterwards */
- d = s; /* and this */
- oldbufptr_save = PL_oldbufptr;
- oldoldbufptr_save = PL_oldoldbufptr;
- PL_linestr = newSVpvs("");
- PL_bufend = SvPVX(PL_linestr);
- while (1) {
- PL_bufptr = PL_bufend;
- CopLINE_set(PL_curcop,
- origline + 1 + PL_parser->herelines);
- if (!lex_next_chunk(LEX_NO_TERM)
- && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
- /* Simply freeing linestr_save might seem simpler here, as it
- does not matter what PL_linestr points to, since we are
- about to croak; but in a quote-like op, linestr_save
- will have been prospectively freed already, via
- SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
- restore PL_linestr. */
- SvREFCNT_dec_NN(PL_linestr);
- PL_linestr = linestr_save;
- PL_oldbufptr = oldbufptr_save;
- PL_oldoldbufptr = oldoldbufptr_save;
- goto interminable;
- }
- CopLINE_set(PL_curcop, origline);
- if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
- s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
- /* ^That should be enough to avoid this needing to grow: */
- sv_catpvs(PL_linestr, "\n\0");
- assert(s == SvPVX(PL_linestr));
- PL_bufend = SvEND(PL_linestr);
- }
- s = PL_bufptr;
- PL_parser->herelines++;
- PL_last_lop = PL_last_uni = NULL;
+ else {
+ SV *linestr_save;
+ char *oldbufptr_save;
+ char *oldoldbufptr_save;
+ streaming:
+ SvPVCLEAR(tmpstr); /* avoid "uninitialized" warning */
+ term = PL_tokenbuf[1];
+ len--;
+ linestr_save = PL_linestr; /* must restore this afterwards */
+ d = s; /* and this */
+ oldbufptr_save = PL_oldbufptr;
+ oldoldbufptr_save = PL_oldoldbufptr;
+ PL_linestr = newSVpvs("");
+ PL_bufend = SvPVX(PL_linestr);
+
+ while (1) {
+ PL_bufptr = PL_bufend;
+ CopLINE_set(PL_curcop,
+ origline + 1 + PL_parser->herelines);
+
+ if ( !lex_next_chunk(LEX_NO_TERM)
+ && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n'))
+ {
+ /* Simply freeing linestr_save might seem simpler here, as it
+ does not matter what PL_linestr points to, since we are
+ about to croak; but in a quote-like op, linestr_save
+ will have been prospectively freed already, via
+ SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
+ restore PL_linestr. */
+ SvREFCNT_dec_NN(PL_linestr);
+ PL_linestr = linestr_save;
+ PL_oldbufptr = oldbufptr_save;
+ PL_oldoldbufptr = oldoldbufptr_save;
+ goto interminable;
+ }
+
+ CopLINE_set(PL_curcop, origline);
+
+ if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
+ s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
+ /* ^That should be enough to avoid this needing to grow: */
+ sv_catpvs(PL_linestr, "\n\0");
+ assert(s == SvPVX(PL_linestr));
+ PL_bufend = SvEND(PL_linestr);
+ }
+
+ s = PL_bufptr;
+ PL_parser->herelines++;
+ PL_last_lop = PL_last_uni = NULL;
+
#ifndef PERL_STRICT_CR
- if (PL_bufend - PL_linestart >= 2) {
- if ( (PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n')
- || (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
- {
- PL_bufend[-2] = '\n';
- PL_bufend--;
- SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
- }
- else if (PL_bufend[-1] == '\r')
- PL_bufend[-1] = '\n';
- }
- else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
- PL_bufend[-1] = '\n';
+ if (PL_bufend - PL_linestart >= 2) {
+ if ( (PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n')
+ || (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
+ {
+ PL_bufend[-2] = '\n';
+ PL_bufend--;
+ SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
+ }
+ else if (PL_bufend[-1] == '\r')
+ PL_bufend[-1] = '\n';
+ }
+ else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
+ PL_bufend[-1] = '\n';
#endif
- if (indented && (PL_bufend-s) >= len) {
- char * found = ninstr(s, PL_bufend, (PL_tokenbuf + 1), (PL_tokenbuf +1 + len));
- if (found) {
- char *backup = found;
- indent_len = 0;
+ if (indented && (PL_bufend-s) >= len) {
+ char * found = ninstr(s, PL_bufend, (PL_tokenbuf + 1), (PL_tokenbuf +1 + len));
- /* Only valid if it's preceded by whitespace only */
- while (backup != s && --backup >= s) {
- if (! SPACE_OR_TAB(*backup)) {
- break;
- }
- indent_len++;
- }
+ if (found) {
+ char *backup = found;
+ indent_len = 0;
- /* All whitespace or none! */
- if (backup == found || SPACE_OR_TAB(*backup)) {
- Newx(indent, indent_len + 1, char);
- memcpy(indent, backup, indent_len);
- indent[indent_len] = 0;
- SvREFCNT_dec(PL_linestr);
- PL_linestr = linestr_save;
- PL_linestart = SvPVX(linestr_save);
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_oldbufptr = oldbufptr_save;
- PL_oldoldbufptr = oldoldbufptr_save;
- s = d;
- break;
- }
- }
+ /* Only valid if it's preceded by whitespace only */
+ while (backup != s && --backup >= s) {
+ if (! SPACE_OR_TAB(*backup)) {
+ break;
+ }
+ indent_len++;
+ }
- /* Didn't find it */
- sv_catsv(tmpstr,PL_linestr);
- } else {
- if (*s == term && PL_bufend-s >= len
- && memEQ(s,PL_tokenbuf + 1,len))
- {
- SvREFCNT_dec(PL_linestr);
- PL_linestr = linestr_save;
- PL_linestart = SvPVX(linestr_save);
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_oldbufptr = oldbufptr_save;
- PL_oldoldbufptr = oldoldbufptr_save;
- s = d;
- break;
- } else {
- sv_catsv(tmpstr,PL_linestr);
- }
- }
- }
+ /* All whitespace or none! */
+ if (backup == found || SPACE_OR_TAB(*backup)) {
+ Newx(indent, indent_len + 1, char);
+ memcpy(indent, backup, indent_len);
+ indent[indent_len] = 0;
+ SvREFCNT_dec(PL_linestr);
+ PL_linestr = linestr_save;
+ PL_linestart = SvPVX(linestr_save);
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_oldbufptr = oldbufptr_save;
+ PL_oldoldbufptr = oldoldbufptr_save;
+ s = d;
+ break;
+ }
+ }
+
+ /* Didn't find it */
+ sv_catsv(tmpstr,PL_linestr);
+ }
+ else {
+ if (*s == term && PL_bufend-s >= len
+ && memEQ(s,PL_tokenbuf + 1,len))
+ {
+ SvREFCNT_dec(PL_linestr);
+ PL_linestr = linestr_save;
+ PL_linestart = SvPVX(linestr_save);
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_oldbufptr = oldbufptr_save;
+ PL_oldoldbufptr = oldoldbufptr_save;
+ s = d;
+ break;
+ }
+ else {
+ sv_catsv(tmpstr,PL_linestr);
+ }
+ }
+ } /* while (1) */
}
+
PL_multi_end = origline + PL_parser->herelines;
+
if (indented && indent) {
STRLEN linecount = 1;
STRLEN herelen = SvCUR(tmpstr);
linecount++;
/* Found our indentation? Strip it */
- } else if (se - ss >= indent_len
+ }
+ else if (se - ss >= indent_len
&& memEQ(ss, indent, indent_len))
{
STRLEN le = 0;
-
ss += indent_len;
while ((ss + le) < se && *(ss + le) != '\n')
le++;
sv_catpvn(newstr, ss, le);
-
ss += le;
/* Line doesn't begin with our indentation? Croak */
- } else {
+ }
+ else {
+ Safefree(indent);
Perl_croak(aTHX_
"Indentation on line %d of here-doc doesn't match delimiter",
(int)linecount
);
}
- }
+ } /* while */
+
/* avoid sv_setsv() as we dont wan't to COW here */
sv_setpvn(tmpstr,SvPVX(newstr),SvCUR(newstr));
Safefree(indent);
SvREFCNT_dec_NN(newstr);
}
+
if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
SvPV_shrink_to_cur(tmpstr);
}
+
if (!IN_BYTES) {
if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
SvUTF8_on(tmpstr);
}
+
PL_lex_stuff = tmpstr;
pl_yylval.ival = op_type;
return s;
interminable:
+ if (indent)
+ Safefree(indent);
SvREFCNT_dec(tmpstr);
CopLINE_set(PL_curcop, origline);
missingterm(PL_tokenbuf + 1, sizeof(PL_tokenbuf) - 1);
}
+
/* scan_inputsymbol
takes: position of first '<' in input buffer
returns: position of first char following the matching '>' in
SvIVX of the SV.
*/
-STATIC char *
-S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
+char *
+Perl_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
char **delimp
)
{
char term; /* terminating character */
char *to; /* current position in the sv's data */
I32 brackets = 1; /* bracket nesting level */
- bool has_utf8 = FALSE; /* is there any utf8 content? */
+ bool d_is_utf8 = FALSE; /* is there any utf8 content? */
IV termcode; /* terminating char. code */
U8 termstr[UTF8_MAXBYTES+1]; /* terminating string */
STRLEN termlen; /* length of terminating string */
}
else {
termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
- if (UTF && UNLIKELY(! _is_grapheme((U8 *) start,
+ if (UTF && UNLIKELY(! is_grapheme((U8 *) start,
(U8 *) s,
(U8 *) PL_bufend,
termcode)))
&& memEQ(s + 1, (char*)termstr + 1, termlen - 1))
{
if ( UTF
- && UNLIKELY(! _is_grapheme((U8 *) start,
+ && UNLIKELY(! is_grapheme((U8 *) start,
(U8 *) s,
(U8 *) PL_bufend,
termcode)))
break;
}
}
- else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) {
- has_utf8 = TRUE;
+ else if (!d_is_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) {
+ d_is_utf8 = TRUE;
}
*to = *s;
break;
else if ((UV)*s == PL_multi_open)
brackets++;
- else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
- has_utf8 = TRUE;
+ else if (!d_is_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
+ d_is_utf8 = TRUE;
*to = *s;
}
}
sv_catpvn(sv, s, termlen);
s += termlen;
- if (has_utf8)
+ if (d_is_utf8)
SvUTF8_on(sv);
PL_multi_end = CopLINE(PL_curcop);
/* if we allocated too much space, give some back */
if (SvCUR(sv) + 5 < SvLEN(sv)) {
SvLEN_set(sv, SvCUR(sv) + 1);
- SvPV_renew(sv, SvLEN(sv));
+ SvPV_shrink_to_cur(sv);
}
/* decide whether this is the first or second quoted string we've read
const char *lastub = NULL; /* position of last underbar */
static const char* const number_too_long = "Number too long";
bool warned_about_underscore = 0;
+ I32 shift; /* shift per digit for hex/oct/bin, hoisted here for fp */
#define WARN_ABOUT_UNDERSCORE() \
do { \
if (!warned_about_underscore) { \
{
/* variables:
u holds the "number so far"
- shift the power of 2 of the base
- (hex == 4, octal == 3, binary == 1)
overflowed was the number more than we can hold?
Shift is used when we add a digit. It also serves as an "are
*/
NV n = 0.0;
UV u = 0;
- I32 shift;
bool overflowed = FALSE;
bool just_zero = TRUE; /* just plain 0 or binary number? */
+ bool has_digs = FALSE;
static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
static const char* const bases[5] =
{ "", "binary", "", "octal", "hexadecimal" };
digit:
just_zero = FALSE;
+ has_digs = TRUE;
if (!overflowed) {
assert(shift >= 0);
x = u << shift; /* make room for the digit */
}
}
+ if (shift != 3 && !has_digs) {
+ /* 0x or 0b with no digits, treat it as an error.
+ Originally this backed up the parse before the b or
+ x, but that has the potential for silent changes in
+ behaviour, like for: "0x.3" and "0x+$foo".
+ */
+ const char *d = s;
+ char *oldbp = PL_bufptr;
+ if (*d) ++d; /* so the user sees the bad non-digit */
+ PL_bufptr = (char *)d; /* so yyerror reports the context */
+ yyerror(Perl_form(aTHX_ "No digits found for %s literal",
+ shift == 4 ? "hexadecimal" : "binary"));
+ PL_bufptr = oldbp;
+ }
+
if (overflowed) {
if (n > 4294967295.0)
Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
if (hexfp) {
floatit = TRUE;
*d++ = '0';
- *d++ = 'x';
- s = start + 2;
+ switch (shift) {
+ case 4:
+ *d++ = 'x';
+ s = start + 2;
+ break;
+ case 3:
+ s = start + 1;
+ break;
+ case 1:
+ *d++ = 'b';
+ s = start + 2;
+ break;
+ default:
+ NOT_REACHED; /* NOTREACHED */
+ }
}
/* read next group of digits and _ and copy into d */
/* read exponent part, if present */
if ((isALPHA_FOLD_EQ(*s, 'e')
|| UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
- && strchr("+-0123456789_", s[1]))
+ && memCHRs("+-0123456789_", s[1]))
{
int exp_digits = 0;
const char *save_s = s;
while (1) {
STRLEN chars;
STRLEN have;
- I32 newlen;
+ Size_t newlen;
U8 *end;
/* First, look in our buffer of existing UTF-8 data: */
char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
}
/*
-=for apidoc Amx|void|wrap_keyword_plugin|Perl_keyword_plugin_t new_plugin|Perl_keyword_plugin_t *old_plugin_p
+=for apidoc wrap_keyword_plugin
Puts a C function into the chain of keyword plugins. This is the
preferred way to manipulate the L</PL_keyword_plugin> variable.
static Perl_keyword_plugin_t next_keyword_plugin;
static OP *my_keyword_plugin(pTHX_
- char *keyword_plugin, STRLEN keyword_len, OP **op_ptr)
+ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
{
if (memEQs(keyword_ptr, keyword_len,
"my_new_keyword")) {
Perl_wrap_keyword_plugin(pTHX_
Perl_keyword_plugin_t new_plugin, Perl_keyword_plugin_t *old_plugin_p)
{
- dVAR;
PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_WRAP_KEYWORD_PLUGIN;
}
/*
-=for apidoc Amx|OP *|parse_arithexpr|U32 flags
+=for apidoc parse_arithexpr
Parse a Perl arithmetic expression. This may contain operators of precedence
down to the bit shift operators. The expression must be followed (and thus
which covers all the compilation errors that occurred. Some compilation
errors, however, will throw an exception immediately.
+=for apidoc Amnh||PARSE_OPTIONAL
+
=cut
+
*/
OP *
}
/*
-=for apidoc Amx|OP *|parse_termexpr|U32 flags
+=for apidoc parse_termexpr
Parse a Perl term expression. This may contain operators of precedence
down to the assignment operators. The expression must be followed (and thus
}
/*
-=for apidoc Amx|OP *|parse_listexpr|U32 flags
+=for apidoc parse_listexpr
Parse a Perl list expression. This may contain operators of precedence
down to the comma operator. The expression must be followed (and thus
}
/*
-=for apidoc Amx|OP *|parse_fullexpr|U32 flags
+=for apidoc parse_fullexpr
Parse a single complete Perl expression. This allows the full
expression grammar, including the lowest-precedence operators such
}
/*
-=for apidoc Amx|OP *|parse_block|U32 flags
+=for apidoc parse_block
Parse a single complete Perl code block. This consists of an opening
brace, a sequence of statements, and a closing brace. The block
}
/*
-=for apidoc Amx|OP *|parse_barestmt|U32 flags
+=for apidoc parse_barestmt
Parse a single unadorned Perl statement. This may be a normal imperative
statement or a declaration that has compile-time effect. It does not
}
/*
-=for apidoc Amx|SV *|parse_label|U32 flags
+=for apidoc parse_label
Parse a single label, possibly optional, of the type that may prefix a
Perl statement. It is up to the caller to ensure that the dynamic parser
if (PL_nexttoke) {
PL_parser->yychar = yylex();
if (PL_parser->yychar == LABEL) {
- char * const lpv = pl_yylval.pval;
- STRLEN llen = strlen(lpv);
+ SV * const labelsv = cSVOPx(pl_yylval.opval)->op_sv;
PL_parser->yychar = YYEMPTY;
- return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
+ cSVOPx(pl_yylval.opval)->op_sv = NULL;
+ op_free(pl_yylval.opval);
+ return labelsv;
} else {
yyunlex();
goto no_label;
}
/*
-=for apidoc Amx|OP *|parse_fullstmt|U32 flags
+=for apidoc parse_fullstmt
Parse a single complete Perl statement. This may be a normal imperative
statement or a declaration that has compile-time effect, and may include
}
/*
-=for apidoc Amx|OP *|parse_stmtseq|U32 flags
+=for apidoc parse_stmtseq
Parse a sequence of zero or more Perl statements. These may be normal
imperative statements, including optional labels, or declarations
}
/*
+=for apidoc parse_subsignature
+
+Parse a subroutine signature declaration. This is the contents of the
+parentheses following a named or anonymous subroutine declaration when the
+C<signatures> feature is enabled. Note that this function neither expects
+nor consumes the opening and closing parentheses around the signature; it
+is the caller's job to handle these.
+
+This function must only be called during parsing of a subroutine; after
+L</start_subparse> has been called. It might allocate lexical variables on
+the pad for the current subroutine.
+
+The op tree to unpack the arguments from the stack at runtime is returned.
+This op tree should appear at the beginning of the compiled function. The
+caller may wish to use L</op_append_list> to build their function body
+after it, or splice it together with the body before calling L</newATTRSUB>.
+
+The C<flags> parameter is reserved for future use, and must always
+be zero.
+
+=cut
+*/
+
+OP *
+Perl_parse_subsignature(pTHX_ U32 flags)
+{
+ if (flags)
+ Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_subsignature");
+ return parse_recdescent_for_op(GRAMSUBSIGNATURE, LEX_FAKEEOF_NONEXPR);
+}
+
+/*
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff