#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 BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
#define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
#define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \
- REPORT('~')
+ REPORT(PERLY_TILDE)
#define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
#define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP))
#define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
#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 */
TOKENTYPE_OPVAL
};
+#define DEBUG_TOKEN(Type, Name) \
+ { Name, TOKENTYPE_##Type, #Name }
+
static struct debug_tokens {
const int token;
enum token_type type;
{ 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" },
{ 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" },
{ OROR, TOKENTYPE_NONE, "OROR" },
{ PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
+ DEBUG_TOKEN (IVAL, PERLY_AMPERSAND),
+ DEBUG_TOKEN (IVAL, PERLY_BRACE_CLOSE),
+ DEBUG_TOKEN (IVAL, PERLY_BRACE_OPEN),
+ DEBUG_TOKEN (IVAL, PERLY_BRACKET_CLOSE),
+ DEBUG_TOKEN (IVAL, PERLY_BRACKET_OPEN),
+ DEBUG_TOKEN (IVAL, PERLY_COLON),
+ DEBUG_TOKEN (IVAL, PERLY_COMMA),
+ DEBUG_TOKEN (IVAL, PERLY_DOT),
+ DEBUG_TOKEN (IVAL, PERLY_EQUAL_SIGN),
+ DEBUG_TOKEN (IVAL, PERLY_EXCLAMATION_MARK),
+ DEBUG_TOKEN (IVAL, PERLY_MINUS),
+ DEBUG_TOKEN (IVAL, PERLY_PAREN_OPEN),
+ DEBUG_TOKEN (IVAL, PERLY_PERCENT_SIGN),
+ DEBUG_TOKEN (IVAL, PERLY_PLUS),
+ DEBUG_TOKEN (IVAL, PERLY_QUESTION_MARK),
+ DEBUG_TOKEN (IVAL, PERLY_SEMICOLON),
+ DEBUG_TOKEN (IVAL, PERLY_SLASH),
+ DEBUG_TOKEN (IVAL, PERLY_SNAIL),
+ DEBUG_TOKEN (IVAL, PERLY_STAR),
+ DEBUG_TOKEN (IVAL, PERLY_TILDE),
{ PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
{ PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
{ PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
{ 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" },
{ 0, TOKENTYPE_NONE, NULL }
};
+#undef DEBUG_TOKEN
+
/* dump the returned token in rv, plus any optional arg in pl_yylval */
STATIC int
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))
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
*/
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");
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 {
static int
S_postderef(pTHX_ int const funny, char const next)
{
- assert(funny == DOLSHARP || strchr("$@%&*", funny));
+ assert(funny == DOLSHARP
+ || memCHRs("$@%&*", funny)
+ || funny == PERLY_DOLLAR
+ || funny == PERLY_SNAIL
+ || funny == PERLY_PERCENT_SIGN
+ || funny == PERLY_AMPERSAND
+ || funny == PERLY_STAR
+ );
if (next == '*') {
PL_expect = XOPERATOR;
if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
- assert('@' == funny || '$' == funny || DOLSHARP == funny);
+ assert(PERLY_SNAIL == funny || PERLY_DOLLAR == funny || DOLSHARP == funny);
PL_lex_state = LEX_INTERPEND;
- if ('@' == funny)
+ if (PERLY_SNAIL == funny)
force_next(POSTJOIN);
}
- force_next(next);
+ force_next(PERLY_STAR);
PL_bufptr+=2;
}
else {
- if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
+ if (PERLY_SNAIL == funny && PL_lex_state == LEX_INTERPNORMAL
&& !PL_lex_brackets)
PL_lex_dojoin = 2;
PL_expect = XOPERATOR;
if (yyc != YYEMPTY) {
if (yyc) {
NEXTVAL_NEXTTOKE = PL_parser->yylval;
- if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
+ if (yyc == PERLY_BRACE_OPEN || yyc == HASHBRACK || yyc == PERLY_BRACKET_OPEN) {
PL_lex_allbrackets--;
PL_lex_brackets--;
yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
- } else if (yyc == '('/*)*/) {
+ } else if (yyc == PERLY_PAREN_OPEN) {
PL_lex_allbrackets--;
yyc |= (2<<24);
}
gv_fetchpvn_flags(s, len,
(PL_in_eval ? GV_ADDMULTI
: GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
- kind == '$' ? SVt_PV :
- kind == '@' ? SVt_PVAV :
- kind == '%' ? SVt_PVHV :
+ kind == PERLY_DOLLAR ? SVt_PV :
+ kind == PERLY_SNAIL ? SVt_PVAV :
+ kind == PERLY_PERCENT_SIGN ? SVt_PVHV :
SVt_PVGV
);
}
+ PL_parser->herelines;
PL_parser->herelines = 0;
}
- return '/';
+ return PERLY_SLASH;
}
else {
const line_t l = CopLINE(PL_curcop);
}
}
+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*
S_get_and_check_backslash_N_name_wrapper(pTHX_ const char* s, const char* const e)
{
* '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 d_is_utf8 = FALSE; /* Output constant is UTF8 */
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 */
- d_is_utf8 = PL_parser->lex_sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
- s_is_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");
* 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 */
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);
+ * 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. */
+ 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 */
while (e-- > max_ptr) {
*(e + 1) = *e;
}
- *(e + 1) = (char) ILLEGAL_UTF8_BYTE;
+ *(e + 1) = (char) RANGE_INDICATOR;
goto range_done;
}
*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);
}
{
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, send,
+ 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, send,
+ 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 = 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
*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);
}
}
}
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");
SvPOK_on(sv);
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;
}
case '@':
case '%':
/* spot stuff that looks like an prototype */
- if (strchr("$:@%&*;\\[]", *s)) {
+ if (memCHRs("$:@%&*;\\[]", *s)) {
yyerror("Illegal character following sigil in a subroutine signature");
break;
}
/* 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)) {
+ 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;
break;
}
- TOKEN(sigil);
+ switch (sigil) {
+ case ',': TOKEN (PERLY_COMMA);
+ case '$': TOKEN (PERLY_DOLLAR);
+ case '@': TOKEN (PERLY_SNAIL);
+ case '%': TOKEN (PERLY_PERCENT_SIGN);
+ case ')': TOKEN (PERLY_PAREN_CLOSE);
+ default: TOKEN (sigil);
+ }
}
static int
s++;
POSTDEREF(DOLSHARP);
}
- POSTDEREF('$');
+ POSTDEREF(PERLY_DOLLAR);
}
if ( s[1] == '#'
&& ( isIDFIRST_lazy_if_safe(s+2, PL_bufend, UTF)
- || strchr("{$:+-@", s[2])))
+ || memCHRs("{$:+-@", s[2])))
{
PL_tokenbuf[0] = '@';
s = scan_ident(s + 1, PL_tokenbuf + 1,
if (!PL_tokenbuf[1]) {
if (s == PL_bufend)
yyerror("Final $ should be \\$ or $name");
- PREREF('$');
+ PREREF(PERLY_DOLLAR);
}
{
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;
+ 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++ == ',') {
+ if (t < PL_bufend && *t++ == ',') {
PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
while (t < PL_bufend && *t != ']')
t++;
const bool islop = (PL_last_lop == PL_oldoldbufptr);
if (!islop || PL_last_lop_op == OP_GREPSTART)
PL_expect = XOPERATOR;
- else if (strchr("$@\"'`q", *s))
+ else if (memCHRs("$@\"'`q", *s))
PL_expect = XTERM; /* e.g. print $fh "foo" */
- else if ( strchr("&*<%", *s)
+ else if ( memCHRs("&*<%", *s)
&& isIDFIRST_lazy_if_safe(s+1, PL_bufend, UTF))
{
PL_expect = XTERM; /* e.g. print $fh &sub */
else if (*s == '.' && isDIGIT(s[1]))
PL_expect = XTERM; /* e.g. print $fh .3 */
else if ((*s == '?' || *s == '-' || *s == '+')
- && !isSPACE(s[1]) && s[1] != '=')
+ && !isSPACE(s[1]) && s[1] != '=')
PL_expect = XTERM; /* e.g. print $fh -1 */
else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
&& s[1] != '/')
}
}
force_ident_maybe_lex('$');
- TOKEN('$');
+ TOKEN(PERLY_DOLLAR);
}
static int
PL_lex_state = LEX_INTERPCONCAT;
}
PL_lex_allbrackets--;
- return REPORT(')');
+ return REPORT(PERLY_PAREN_CLOSE);
}
else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
/* Got an unpaired \E */
{
PL_lex_casestack[--PL_lex_casemods] = '\0';
PL_lex_allbrackets--;
- return REPORT(')');
+ return REPORT(PERLY_PAREN_CLOSE);
}
if (PL_lex_casemods > 10)
Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
PL_lex_casestack[PL_lex_casemods] = '\0';
PL_lex_state = LEX_INTERPCONCAT;
NEXTVAL_NEXTTOKE.ival = 0;
- force_next((2<<24)|'(');
+ force_next((2<<24)|PERLY_PAREN_OPEN);
if (*s == 'l')
NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
else if (*s == 'u')
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(',');
+ TOKEN(PERLY_COMMA);
else
AopNOASSIGN(OP_CONCAT);
}
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 */
+ OPERATOR(PERLY_MINUS); /* unary minus */
}
switch (tmp) {
case 'r': ftst = OP_FTEREAD; break;
s = skipspace(s);
if (((*s == '$' || *s == '&') && s[1] == '*')
||(*s == '$' && s[1] == '#' && s[2] == '*')
- ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
+ ||((*s == '@' || *s == '%') && memCHRs("*[{", s[1]))
||(*s == '*' && (s[1] == '*' || s[1] == '{'))
)
{
else {
if (isSPACE(*s) || !isSPACE(*PL_bufptr))
check_uni();
- OPERATOR('-'); /* unary minus */
+ OPERATOR(PERLY_MINUS); /* unary minus */
}
}
}
else {
if (isSPACE(*s) || !isSPACE(*PL_bufptr))
check_uni();
- OPERATOR('+');
+ OPERATOR(PERLY_PLUS);
}
}
yyl_star(pTHX_ char *s)
{
if (PL_expect == XPOSTDEREF)
- POSTDEREF('*');
+ POSTDEREF(PERLY_STAR);
if (PL_expect != XOPERATOR) {
s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
PL_expect = XOPERATOR;
- force_ident(PL_tokenbuf, '*');
+ force_ident(PL_tokenbuf, PERLY_STAR);
if (!*PL_tokenbuf)
- PREREF('*');
- TERM('*');
+ PREREF(PERLY_STAR);
+ TERM(PERLY_STAR);
}
s++;
TOKEN(0);
}
- PL_parser->saw_infix_sigil = 1;
Mop(OP_MULTIPLY);
}
TOKEN(0);
}
++s;
- PL_parser->saw_infix_sigil = 1;
Mop(OP_MODULO);
}
else if (PL_expect == XPOSTDEREF)
- POSTDEREF('%');
+ POSTDEREF(PERLY_PERCENT_SIGN);
PL_tokenbuf[0] = '%';
s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
pl_yylval.ival = 0;
if (!PL_tokenbuf[1]) {
- PREREF('%');
+ PREREF(PERLY_PERCENT_SIGN);
}
if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
&& intuit_more(s, PL_bufend)) {
}
PL_expect = XOPERATOR;
force_ident_maybe_lex('%');
- TERM('%');
+ TERM(PERLY_PERCENT_SIGN);
}
static int
: "Unterminated attribute list" ) );
if (attrs)
op_free(attrs);
- OPERATOR(':');
+ OPERATOR(PERLY_COLON);
}
got_attrs:
}
PL_lex_allbrackets--;
- OPERATOR(':');
+ OPERATOR(PERLY_COLON);
}
static int
}
static int
-yyl_leftcurly(pTHX_ char *s, U8 formbrack)
+yyl_leftcurly(pTHX_ char *s, const U8 formbrack)
{
char *d;
if (PL_lex_brackets > 100) {
const char minus = (PL_tokenbuf[0] == '-');
s = force_word(s + minus, BAREWORD, FALSE, TRUE);
if (minus)
- force_next('-');
+ force_next(PERLY_MINUS);
}
}
/* FALLTHROUGH */
}
term = *t;
open = term;
- if (term && (tmps = strchr("([{< )]}> )]}>",term)))
+ if (term && (tmps = memCHRs("([{< )]}> )]}>",term)))
term = tmps[5];
close = term;
if (open == close)
pl_yylval.ival = CopLINE(PL_curcop);
PL_copline = NOLINE; /* invalidate current command line number */
- TOKEN(formbrack ? '=' : '{');
+ TOKEN(formbrack ? PERLY_EQUAL_SIGN : PERLY_BRACE_OPEN);
}
static int
-yyl_rightcurly(pTHX_ char *s, U8 formbrack)
+yyl_rightcurly(pTHX_ char *s, const U8 formbrack)
{
+ assert(s != PL_bufend);
+ s++;
+
if (PL_lex_brackets <= 0)
/* diag_listed_as: Unmatched right %s bracket */
yyerror("Unmatched right curly bracket");
return yylex(); /* ignore fake brackets */
}
- force_next(formbrack ? '.' : '}');
+ force_next(formbrack ? PERLY_DOT : PERLY_BRACE_CLOSE);
if (formbrack) LEAVE_with_name("lex_format");
if (formbrack == 2) { /* means . where arguments were expected */
- force_next(';');
+ force_next(PERLY_SEMICOLON);
TOKEN(FORMRBRACK);
}
- TOKEN(';');
+ TOKEN(PERLY_SEMICOLON);
}
static int
yyl_ampersand(pTHX_ char *s)
{
if (PL_expect == XPOSTDEREF)
- POSTDEREF('&');
+ POSTDEREF(PERLY_AMPERSAND);
s++;
if (*s++ == '&') {
s--;
TOKEN(0);
}
- if (d == s) {
- PL_parser->saw_infix_sigil = 1;
+ if (d == s)
BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
- }
else
BAop(OP_SBIT_AND);
}
if (PL_tokenbuf[1])
force_ident_maybe_lex('&');
else
- PREREF('&');
+ PREREF(PERLY_AMPERSAND);
- TERM('&');
+ TERM(PERLY_AMPERSAND);
}
static int
TOKEN(0);
}
- Eop(OP_NE);
+ ChEop(OP_NE);
}
if (tmp == '~')
PMop(OP_NOT);
s--;
- OPERATOR('!');
+ OPERATOR(PERLY_EXCLAMATION_MARK);
}
static int
yyl_snail(pTHX_ char *s)
{
if (PL_expect == XPOSTDEREF)
- POSTDEREF('@');
+ POSTDEREF(PERLY_SNAIL);
PL_tokenbuf[0] = '@';
s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
if (PL_expect == XOPERATOR) {
}
pl_yylval.ival = 0;
if (!PL_tokenbuf[1]) {
- PREREF('@');
+ PREREF(PERLY_SNAIL);
}
if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
s = skipspace(s);
}
PL_expect = XOPERATOR;
force_ident_maybe_lex('@');
- TERM('@');
+ TERM(PERLY_SNAIL);
}
static int
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);
+ s++;
+ OPERATOR(PERLY_BRACKET_OPEN);
}
static int
PL_lex_state = LEX_INTERPEND;
}
}
- TERM(']');
+ TERM(PERLY_BRACKET_CLOSE);
}
static int
Perl_ck_warner_d(aTHX_
packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
"Smartmatch is experimental");
- Eop(OP_SMARTMATCH);
+ NCEop(OP_SMARTMATCH);
}
s++;
if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
PL_expect = XTERM;
s = skipspace(s);
PL_lex_allbrackets++;
- TOKEN('(');
+ TOKEN(PERLY_PAREN_OPEN);
}
static int
PL_lex_allbrackets--;
s = skipspace(s);
if (*s == '{')
- PREBLOCK(')');
- TERM(')');
+ PREBLOCK(PERLY_PAREN_CLOSE);
+ TERM(PERLY_PAREN_CLOSE);
}
static int
s -= 3;
TOKEN(0);
}
- Eop(OP_NCMP);
+ NCEop(OP_NCMP);
}
s--;
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
s -= 2;
TOKEN(0);
}
- Rop(OP_LE);
+ ChRop(OP_LE);
}
s--;
TOKEN(0);
}
- Rop(OP_LT);
+ ChRop(OP_LT);
}
static int
s -= 2;
TOKEN(0);
}
- Rop(OP_GE);
+ ChRop(OP_GE);
}
s--;
TOKEN(0);
}
- Rop(OP_GT);
+ ChRop(OP_GT);
}
static int
}
static int
-yyl_dblquote(pTHX_ char *s, STRLEN len)
+yyl_dblquote(pTHX_ char *s)
{
char *d;
+ STRLEN len;
s = scan_str(s,FALSE,FALSE,FALSE,NULL);
DEBUG_T( {
if (s)
}
static int
-yyl_my(pTHX_ char **sp, I32 my)
+yyl_my(pTHX_ char *s, I32 my)
{
- char *s = *sp;
if (PL_in_my) {
PL_bufptr = s;
yyerror(Perl_form(aTHX_
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")) {
- *sp = s;
- return SUB;
- }
+ 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];
OPERATOR(MY);
}
-static int yyl_try(pTHX_ char, char*, STRLEN, I32, GV*, GV**, U8, U32, const bool);
-
-#define RETRY() yyl_try(aTHX_ 0, s, len, orig_keyword, gv, gvp, \
- formbrack, fake_eof, saw_infix_sigil)
+static int yyl_try(pTHX_ char*);
-static int
-yyl_eol(pTHX_ char *s, STRLEN len,
- I32 orig_keyword, GV *gv, GV **gvp,
- U8 formbrack, U32 fake_eof, const bool saw_infix_sigil)
+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))
{
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
PL_lex_state = LEX_FORMLINE;
force_next(FORMRBRACK);
- TOKEN(';');
+ *ps = s;
+ return TRUE;
}
}
else {
incline(s, PL_bufend);
}
}
- return RETRY();
+ *ps = s;
+ return FALSE;
}
static int
-yyl_try(pTHX_ char initial_state, char *s, STRLEN len,
- I32 orig_keyword, GV *gv, GV **gvp,
- U8 formbrack, U32 fake_eof, const bool saw_infix_sigil)
+yyl_fake_eof(pTHX_ U32 fake_eof, bool bof, char *s)
{
char *d;
- bool bof = FALSE;
-
- switch (initial_state) {
- case '}': goto rightbracket;
- }
-
- switch (*s) {
- default:
- if (UTF ? isIDFIRST_utf8_safe(s, PL_bufend) : isALNUMC(*s))
- goto keylookup;
- yyl_croak_unrecognised(aTHX_ s);
-
- case 4:
- case 26:
- fake_eof = LEX_FAKE_EOF;
- 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)
- return 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. */
+ goto start;
- const char * const pdb = PerlEnv_getenv("PERL5DB");
+ do {
+ fake_eof = 0;
+ bof = cBOOL(PL_rsfp);
+ start:
- 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);
- return RETRY();
- }
- do {
- fake_eof = 0;
- bof = cBOOL(PL_rsfp);
- 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));
+ PL_bufptr = PL_bufend;
+ COPLINE_INC_WITH_HERELINES;
+ if (!lex_next_chunk(fake_eof)) {
+ CopLINE_dec(PL_curcop);
+ s = PL_bufptr;
+ TOKEN(PERLY_SEMICOLON); /* 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);
+ /* 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;
+ 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);
- }
+ 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 (d) {
+ char *ipath;
+ char *ipathend;
- while (isSPACE(*d))
- d++;
- ipath = d;
- while (*d && !isSPACE(*d))
- d++;
- ipathend = d;
+ 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);
- }
- }
- }
+ 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 {
- /* Anything to do if no copfilesv? */
- }
- TAINT_NOT; /* $^X is always tainted, but that's OK */
- }
+ 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");
+ /*
+ * 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;
- }
+ /* 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 */
- }
+ /*
+ * 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"))
- {
- dVAR;
- char **newargv;
+ 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;
- *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);
- return RETRY();
- }
- }
- }
- }
- }
- if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
- PL_lex_state = LEX_FORMLINE;
- force_next(FORMRBRACK);
- TOKEN(';');
- }
- return 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++;
- return RETRY();
+ 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;
+ }
+ }
+ }
+ }
+ }
- case '#':
- case '\n':
- return yyl_eol(aTHX_ s, len, orig_keyword, gv, gvp,
- formbrack, fake_eof, saw_infix_sigil);
+ if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
+ PL_lex_state = LEX_FORMLINE;
+ force_next(FORMRBRACK);
+ TOKEN(PERLY_SEMICOLON);
+ }
- case '-':
- return yyl_hyphen(aTHX_ s);
+ PL_bufptr = s;
+ return YYL_RETRY;
+}
- case '+':
- return yyl_plus(aTHX_ s);
+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);
+}
- case '*':
- return yyl_star(aTHX_ s);
+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);
+}
- case '%':
- return yyl_percent(aTHX_ s);
+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);
+ }
- case '^':
- return yyl_caret(aTHX_ s);
+ 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;
- case '[':
- return yyl_leftsquare(aTHX_ s);
+ /* Is there a prototype? */
+ if (SvPOK(cv)) {
+ int k = yyl_subproto(aTHX_ s, cv);
+ if (k != KEY_NULL)
+ return k;
+ }
- case '~':
- return yyl_tilde(aTHX_ s);
+ 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;
+ }
- 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;
- }
- return yyl_colon(aTHX_ s + 1);
+ TOKEN(NOAMP);
+}
- case '(':
- return yyl_leftparen(aTHX_ s + 1);
+/* 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;
+ }
- case ';':
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
- TOKEN(0);
- CLINE;
- s++;
- PL_expect = XSTATE;
- TOKEN(';');
+ 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;
+ }
+ }
+}
- case ')':
- return yyl_rightparen(aTHX_ s);
+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;
- case ']':
- return yyl_rightsquare(aTHX_ s);
+ 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;
+ }
- case '{':
- s++;
- leftbracket:
- return yyl_leftcurly(aTHX_ s, formbrack);
+ /* if we saw a global override before, get the right name */
- case '}':
- if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
- TOKEN(0);
- rightbracket:
- assert(s != PL_bufend);
- return yyl_rightcurly(aTHX_ s + 1, formbrack);
+ 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;
+ }
- case '&':
- return yyl_ampersand(aTHX_ s);
+ /* 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;
- case '|':
- return yyl_verticalbar(aTHX_ s);
+ /* (Now we can afford to cross potential line boundary.) */
+ s = skipspace(s);
- case '=':
- if (s[1] == '=' && (s == PL_linestart || s[-1] == '\n')
- && memBEGINs(s + 2, (STRLEN) (PL_bufend - s + 2), "====="))
+ /* 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)))
{
- s = vcs_conflict_marker(s + 7);
- return RETRY();
+ /* the code at method: doesn't use s */
+ goto method;
}
+ s = SvPVX(PL_linestr) + s_off;
- s++;
- {
- const char tmp = *s++;
- if (tmp == '=') {
- 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)
- {
- 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);
- return RETRY();
- }
- }
- }
- return RETRY();
- }
- s = PL_bufend;
- PL_parser->in_pod = 1;
- return 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 == '#') {
- 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);
+ /* 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);
+ }
+ }
- case '!':
- return yyl_bang(aTHX_ s + 1);
+ PL_expect = XOPERATOR;
+ s = skipspace(s);
- case '<':
- if (s[1] == '<' && (s == PL_linestart || s[-1] == '\n')
- && memBEGINs(s+2, (STRLEN) (PL_bufend - (s+2)), "<<<<<"))
- {
- s = vcs_conflict_marker(s + 7);
- return RETRY();
+ /* 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);
}
- return yyl_leftpointy(aTHX_ s);
+ 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(PERLY_AMPERSAND);
+ }
- case '>':
- if (s[1] == '>' && (s == PL_linestart || s[-1] == '\n')
- && memBEGINs(s + 2, (STRLEN) (PL_bufend - s + 2), ">>>>>"))
+ /* 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)
{
- s = vcs_conflict_marker(s + 7);
- return RETRY();
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
}
- return yyl_rightpointy(aTHX_ s + 1);
+ return REPORT(key);
+ }
- case '$':
- return yyl_dollar(aTHX_ s);
+ /* Not a method, so call it a subroutine (if defined) */
- case '@':
- return yyl_snail(aTHX_ s);
+ 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);
+ }
- case '/': /* may be division, defined-or, or pattern */
- return yyl_slash(aTHX_ s);
+ /* Call it a bare word */
- case '?': /* conditional */
- s++;
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
- {
- s--;
- TOKEN(0);
- }
- PL_lex_allbrackets++;
- OPERATOR('?');
+ if (PL_hints & HINT_STRICT_SUBS)
+ pl_yylval.opval->op_private |= OPpCONST_STRICT;
+ else
+ yyl_strictwarn_bareword(aTHX_ lastchar);
- 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);
+ op_free(c.rv2cv_op);
- case '\'':
- return yyl_sglquote(aTHX_ s);
+ return yyl_safe_bareword(aTHX_ s, lastchar);
+}
- case '"':
- return yyl_dblquote(aTHX_ s, len);
+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 '`':
- return yyl_backtick(aTHX_ s);
+ case KEY_chdir:
+ /* may use HOME */
+ (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
+ UNI(OP_CHDIR);
- case '\\':
- return yyl_backslash(aTHX_ s + 1);
+ case KEY_close:
+ UNI(OP_CLOSE);
- 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_closedir:
+ UNI(OP_CLOSEDIR);
- 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_cmp:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ NCEop(OP_SCMP);
- 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_caller:
+ UNI(OP_CALLER);
- PL_bufptr = s;
- s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
+ case KEY_crypt:
- /* Some keywords can be followed by any delimiter, including ':' */
- anydelim = word_takes_any_delimiter(PL_tokenbuf, len);
+ LOP(OP_CRYPT,XTERM);
- /* 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_chmod:
+ LOP(OP_CHMOD,XTERM);
- d = s;
- while (d < PL_bufend && isSPACE(*d))
- d++; /* no comments skipped here, or s### is misparsed */
+ case KEY_chown:
+ LOP(OP_CHOWN,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_connect:
+ LOP(OP_CONNECT,XTERM);
- /* 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_chr:
+ UNI(OP_CHR);
- /* 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.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);
- 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)
- tmp = yyl_secondclass_keyword(aTHX_ s, len, tmp, &orig_keyword, &gv, &gvp);
-
- 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_cos:
+ UNI(OP_COS);
- /* Get the rest if it looks like a package qualifier */
+ case KEY_chroot:
+ UNI(OP_CHROOT);
- 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_default:
+ PREBLOCK(DEFAULT);
- if (no_op_error)
- no_op("Bareword",s);
+ case KEY_do:
+ return yyl_do(aTHX_ s, orig_keyword);
- /* See if the name is "Foo::",
- in which case Foo is a bareword
- (and a package name). */
+ case KEY_die:
+ PL_hints |= HINT_BLOCK_SCOPE;
+ LOP(OP_DIE,XTERM);
- 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_defined:
+ UNI(OP_DEFINED);
- /* if we saw a global override before, get the right name */
+ case KEY_delete:
+ UNI(OP_DELETE);
- 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_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);
- /* 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_dump:
+ LOOPX(OP_DUMP);
- /* And if "Foo::", then that's what it certainly is. */
- if (safebw)
- goto safe_bareword;
+ case KEY_else:
+ PREBLOCK(ELSE);
- 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_elsif:
+ pl_yylval.ival = CopLINE(PL_curcop);
+ OPERATOR(ELSIF);
- /* Use this var to track whether intuit_method has been
- called. intuit_method returns 0 or > 255. */
- tmp = 1;
+ case KEY_eq:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChEop(OP_SEQ);
- /* See if it's the indirect object for a list operator. */
+ case KEY_exists:
+ UNI(OP_EXISTS);
- 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_exit:
+ UNI(OP_EXIT);
- 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_eval:
+ s = skipspace(s);
+ if (*s == '{') { /* block eval */
+ PL_expect = XTERMBLOCK;
+ UNIBRACK(OP_ENTERTRY);
+ }
+ else { /* string eval */
+ PL_expect = XTERM;
+ UNIBRACK(OP_ENTEREVAL);
+ }
- /* 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_evalbytes:
+ PL_expect = XTERM;
+ UNIBRACK(-OP_ENTEREVAL);
- /* If followed by var or block, call it a method (unless sub) */
+ case KEY_eof:
+ UNI(OP_EOF);
- 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_exp:
+ UNI(OP_EXP);
- /* If followed by a bareword, see if it looks like indir obj. */
+ case KEY_each:
+ UNI(OP_EACH);
- 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_exec:
+ LOP(OP_EXEC,XREF);
- /* 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_endhostent:
+ FUN0(OP_EHOSTENT);
- 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;
- }
+ case KEY_endnetent:
+ FUN0(OP_ENETENT);
- 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_endservent:
+ FUN0(OP_ESERVENT);
- /* Call it a bare word */
+ case KEY_endprotoent:
+ FUN0(OP_EPROTOENT);
- 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_endpwent:
+ FUN0(OP_EPWENT);
- 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);
- fake_eof = LEX_FAKE_EOF;
- 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_endgrent:
+ FUN0(OP_EGRENT);
- 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_for:
+ case KEY_foreach:
+ return yyl_foreach(aTHX_ s);
- case KEY_abs:
- UNI(OP_ABS);
+ case KEY_formline:
+ LOP(OP_FORMLINE,XTERM);
- case KEY_alarm:
- UNI(OP_ALARM);
+ case KEY_fork:
+ FUN0(OP_FORK);
- case KEY_accept:
- LOP(OP_ACCEPT,XTERM);
+ case KEY_fc:
+ UNI(OP_FC);
- case KEY_and:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
- return REPORT(0);
- OPERATOR(ANDOP);
+ case KEY_fcntl:
+ LOP(OP_FCNTL,XTERM);
- case KEY_atan2:
- LOP(OP_ATAN2,XTERM);
+ case KEY_fileno:
+ UNI(OP_FILENO);
- case KEY_bind:
- LOP(OP_BIND,XTERM);
+ case KEY_flock:
+ LOP(OP_FLOCK,XTERM);
- case KEY_binmode:
- LOP(OP_BINMODE,XTERM);
+ case KEY_gt:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChRop(OP_SGT);
- case KEY_bless:
- LOP(OP_BLESS,XTERM);
+ case KEY_ge:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChRop(OP_SGE);
- case KEY_break:
- FUN0(OP_BREAK);
+ case KEY_grep:
+ LOP(OP_GREPSTART, XREF);
- case KEY_chop:
- UNI(OP_CHOP);
+ case KEY_goto:
+ LOOPX(OP_GOTO);
- 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_gmtime:
+ UNI(OP_GMTIME);
- case KEY_chdir:
- /* may use HOME */
- (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
- UNI(OP_CHDIR);
+ case KEY_getc:
+ UNIDOR(OP_GETC);
- case KEY_close:
- UNI(OP_CLOSE);
+ case KEY_getppid:
+ FUN0(OP_GETPPID);
- case KEY_closedir:
- UNI(OP_CLOSEDIR);
+ case KEY_getpgrp:
+ UNI(OP_GETPGRP);
- case KEY_cmp:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Eop(OP_SCMP);
+ case KEY_getpriority:
+ LOP(OP_GETPRIORITY,XTERM);
- case KEY_caller:
- UNI(OP_CALLER);
+ case KEY_getprotobyname:
+ UNI(OP_GPBYNAME);
- case KEY_crypt:
-#ifdef FCRYPT
- if (!PL_cryptseen) {
- PL_cryptseen = TRUE;
- init_des();
- }
-#endif
- LOP(OP_CRYPT,XTERM);
+ case KEY_getprotobynumber:
+ LOP(OP_GPBYNUMBER,XTERM);
- case KEY_chmod:
- LOP(OP_CHMOD,XTERM);
+ case KEY_getprotoent:
+ FUN0(OP_GPROTOENT);
- case KEY_chown:
- LOP(OP_CHOWN,XTERM);
+ case KEY_getpwent:
+ FUN0(OP_GPWENT);
- case KEY_connect:
- LOP(OP_CONNECT,XTERM);
+ case KEY_getpwnam:
+ UNI(OP_GPWNAM);
- case KEY_chr:
- UNI(OP_CHR);
+ case KEY_getpwuid:
+ UNI(OP_GPWUID);
- case KEY_cos:
- UNI(OP_COS);
+ case KEY_getpeername:
+ UNI(OP_GETPEERNAME);
- case KEY_chroot:
- UNI(OP_CHROOT);
+ case KEY_gethostbyname:
+ UNI(OP_GHBYNAME);
- case KEY_default:
- PREBLOCK(DEFAULT);
+ case KEY_gethostbyaddr:
+ LOP(OP_GHBYADDR,XTERM);
- case KEY_do:
- return yyl_do(aTHX_ s, orig_keyword);
+ case KEY_gethostent:
+ FUN0(OP_GHOSTENT);
- case KEY_die:
- PL_hints |= HINT_BLOCK_SCOPE;
- LOP(OP_DIE,XTERM);
+ case KEY_getnetbyname:
+ UNI(OP_GNBYNAME);
- case KEY_defined:
- UNI(OP_DEFINED);
+ case KEY_getnetbyaddr:
+ LOP(OP_GNBYADDR,XTERM);
- case KEY_delete:
- UNI(OP_DELETE);
+ case KEY_getnetent:
+ FUN0(OP_GNETENT);
- 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_getservbyname:
+ LOP(OP_GSBYNAME,XTERM);
- case KEY_dbmclose:
- UNI(OP_DBMCLOSE);
+ case KEY_getservbyport:
+ LOP(OP_GSBYPORT,XTERM);
- case KEY_dump:
- LOOPX(OP_DUMP);
+ case KEY_getservent:
+ FUN0(OP_GSERVENT);
- case KEY_else:
- PREBLOCK(ELSE);
+ case KEY_getsockname:
+ UNI(OP_GETSOCKNAME);
- case KEY_elsif:
- pl_yylval.ival = CopLINE(PL_curcop);
- OPERATOR(ELSIF);
+ case KEY_getsockopt:
+ LOP(OP_GSOCKOPT,XTERM);
- case KEY_eq:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Eop(OP_SEQ);
+ case KEY_getgrent:
+ FUN0(OP_GGRENT);
- case KEY_exists:
- UNI(OP_EXISTS);
+ case KEY_getgrnam:
+ UNI(OP_GGRNAM);
- case KEY_exit:
- UNI(OP_EXIT);
+ case KEY_getgrgid:
+ UNI(OP_GGRGID);
- 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_getlogin:
+ FUN0(OP_GETLOGIN);
- case KEY_evalbytes:
- PL_expect = XTERM;
- UNIBRACK(-OP_ENTEREVAL);
+ 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_eof:
- UNI(OP_EOF);
+ case KEY_glob:
+ LOP( orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB, XTERM );
- case KEY_exp:
- UNI(OP_EXP);
+ case KEY_hex:
+ UNI(OP_HEX);
- case KEY_each:
- UNI(OP_EACH);
+ 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_exec:
- LOP(OP_EXEC,XREF);
+ case KEY_index:
+ LOP(OP_INDEX,XTERM);
- case KEY_endhostent:
- FUN0(OP_EHOSTENT);
+ case KEY_int:
+ UNI(OP_INT);
- case KEY_endnetent:
- FUN0(OP_ENETENT);
+ case KEY_ioctl:
+ LOP(OP_IOCTL,XTERM);
- case KEY_endservent:
- FUN0(OP_ESERVENT);
+ case KEY_isa:
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__ISA), "isa is experimental");
+ NCRop(OP_ISA);
- case KEY_endprotoent:
- FUN0(OP_EPROTOENT);
+ case KEY_join:
+ LOP(OP_JOIN,XTERM);
- case KEY_endpwent:
- FUN0(OP_EPWENT);
+ case KEY_keys:
+ UNI(OP_KEYS);
- case KEY_endgrent:
- FUN0(OP_EGRENT);
+ case KEY_kill:
+ LOP(OP_KILL,XTERM);
- case KEY_for:
- case KEY_foreach:
- return yyl_foreach(aTHX_ s);
+ case KEY_last:
+ LOOPX(OP_LAST);
- case KEY_formline:
- LOP(OP_FORMLINE,XTERM);
+ case KEY_lc:
+ UNI(OP_LC);
- case KEY_fork:
- FUN0(OP_FORK);
+ case KEY_lcfirst:
+ UNI(OP_LCFIRST);
- case KEY_fc:
- UNI(OP_FC);
+ case KEY_local:
+ OPERATOR(LOCAL);
- case KEY_fcntl:
- LOP(OP_FCNTL,XTERM);
+ case KEY_length:
+ UNI(OP_LENGTH);
- case KEY_fileno:
- UNI(OP_FILENO);
+ case KEY_lt:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChRop(OP_SLT);
- case KEY_flock:
- LOP(OP_FLOCK,XTERM);
+ case KEY_le:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChRop(OP_SLE);
- case KEY_gt:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Rop(OP_SGT);
+ case KEY_localtime:
+ UNI(OP_LOCALTIME);
- case KEY_ge:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Rop(OP_SGE);
+ case KEY_log:
+ UNI(OP_LOG);
- case KEY_grep:
- LOP(OP_GREPSTART, XREF);
+ case KEY_link:
+ LOP(OP_LINK,XTERM);
- case KEY_goto:
- LOOPX(OP_GOTO);
+ case KEY_listen:
+ LOP(OP_LISTEN,XTERM);
- case KEY_gmtime:
- UNI(OP_GMTIME);
+ case KEY_lock:
+ UNI(OP_LOCK);
- case KEY_getc:
- UNIDOR(OP_GETC);
+ case KEY_lstat:
+ UNI(OP_LSTAT);
- case KEY_getppid:
- FUN0(OP_GETPPID);
+ case KEY_m:
+ s = scan_pat(s,OP_MATCH);
+ TERM(sublex_start());
+
+ case KEY_map:
+ LOP(OP_MAPSTART, XREF);
+
+ case KEY_mkdir:
+ LOP(OP_MKDIR,XTERM);
+
+ case KEY_msgctl:
+ LOP(OP_MSGCTL,XTERM);
+
+ case KEY_msgget:
+ LOP(OP_MSGGET,XTERM);
+
+ case KEY_msgrcv:
+ LOP(OP_MSGRCV,XTERM);
- case KEY_getpgrp:
- UNI(OP_GETPGRP);
+ case KEY_msgsnd:
+ LOP(OP_MSGSND,XTERM);
+
+ case KEY_our:
+ case KEY_my:
+ case KEY_state:
+ return yyl_my(aTHX_ s, key);
+
+ case KEY_next:
+ LOOPX(OP_NEXT);
+
+ case KEY_ne:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChEop(OP_SNE);
+
+ case KEY_no:
+ s = tokenize_use(0, s);
+ TOKEN(USE);
+
+ 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_getpriority:
- LOP(OP_GETPRIORITY,XTERM);
+ 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_getprotobyname:
- UNI(OP_GPBYNAME);
+ 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_getprotobynumber:
- LOP(OP_GPBYNUMBER,XTERM);
+ case KEY_ord:
+ UNI(OP_ORD);
- case KEY_getprotoent:
- FUN0(OP_GPROTOENT);
+ case KEY_oct:
+ UNI(OP_OCT);
- case KEY_getpwent:
- FUN0(OP_GPWENT);
+ case KEY_opendir:
+ LOP(OP_OPEN_DIR,XTERM);
- case KEY_getpwnam:
- UNI(OP_GPWNAM);
+ case KEY_print:
+ checkcomma(s,PL_tokenbuf,"filehandle");
+ LOP(OP_PRINT,XREF);
- case KEY_getpwuid:
- UNI(OP_GPWUID);
+ case KEY_printf:
+ checkcomma(s,PL_tokenbuf,"filehandle");
+ LOP(OP_PRTF,XREF);
- case KEY_getpeername:
- UNI(OP_GETPEERNAME);
+ case KEY_prototype:
+ UNI(OP_PROTOTYPE);
- case KEY_gethostbyname:
- UNI(OP_GHBYNAME);
+ case KEY_push:
+ LOP(OP_PUSH,XTERM);
- case KEY_gethostbyaddr:
- LOP(OP_GHBYADDR,XTERM);
+ case KEY_pop:
+ UNIDOR(OP_POP);
- case KEY_gethostent:
- FUN0(OP_GHOSTENT);
+ case KEY_pos:
+ UNIDOR(OP_POS);
- case KEY_getnetbyname:
- UNI(OP_GNBYNAME);
+ case KEY_pack:
+ LOP(OP_PACK,XTERM);
- case KEY_getnetbyaddr:
- LOP(OP_GNBYADDR,XTERM);
+ case KEY_package:
+ s = force_word(s,BAREWORD,FALSE,TRUE);
+ s = skipspace(s);
+ s = force_strict_version(s);
+ PREBLOCK(PACKAGE);
- case KEY_getnetent:
- FUN0(OP_GNETENT);
+ case KEY_pipe:
+ LOP(OP_PIPE_OP,XTERM);
- case KEY_getservbyname:
- LOP(OP_GSBYNAME,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_getservbyport:
- LOP(OP_GSBYPORT,XTERM);
+ case KEY_quotemeta:
+ UNI(OP_QUOTEMETA);
- case KEY_getservent:
- FUN0(OP_GSERVENT);
+ case KEY_qw:
+ return yyl_qw(aTHX_ s, len);
- case KEY_getsockname:
- UNI(OP_GETSOCKNAME);
+ 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_getsockopt:
- LOP(OP_GSOCKOPT,XTERM);
+ case KEY_qr:
+ s = scan_pat(s,OP_QR);
+ TERM(sublex_start());
- case KEY_getgrent:
- FUN0(OP_GGRENT);
+ 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_getgrnam:
- UNI(OP_GGRNAM);
+ case KEY_return:
+ OLDLOP(OP_RETURN);
- case KEY_getgrgid:
- UNI(OP_GGRGID);
+ case KEY_require:
+ return yyl_require(aTHX_ s, orig_keyword);
- case KEY_getlogin:
- FUN0(OP_GETLOGIN);
+ case KEY_reset:
+ UNI(OP_RESET);
- 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_redo:
+ LOOPX(OP_REDO);
- case KEY_glob:
- LOP(
- orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
- XTERM
- );
+ case KEY_rename:
+ LOP(OP_RENAME,XTERM);
- case KEY_hex:
- UNI(OP_HEX);
+ case KEY_rand:
+ UNI(OP_RAND);
- 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_rmdir:
+ UNI(OP_RMDIR);
- case KEY_index:
- LOP(OP_INDEX,XTERM);
+ case KEY_rindex:
+ LOP(OP_RINDEX,XTERM);
- case KEY_int:
- UNI(OP_INT);
+ case KEY_read:
+ LOP(OP_READ,XTERM);
- case KEY_ioctl:
- LOP(OP_IOCTL,XTERM);
+ case KEY_readdir:
+ UNI(OP_READDIR);
- case KEY_join:
- LOP(OP_JOIN,XTERM);
+ case KEY_readline:
+ UNIDOR(OP_READLINE);
- case KEY_keys:
- UNI(OP_KEYS);
+ case KEY_readpipe:
+ UNIDOR(OP_BACKTICK);
- case KEY_kill:
- LOP(OP_KILL,XTERM);
+ case KEY_rewinddir:
+ UNI(OP_REWINDDIR);
- case KEY_last:
- LOOPX(OP_LAST);
+ case KEY_recv:
+ LOP(OP_RECV,XTERM);
- case KEY_lc:
- UNI(OP_LC);
+ case KEY_reverse:
+ LOP(OP_REVERSE,XTERM);
- case KEY_lcfirst:
- UNI(OP_LCFIRST);
+ case KEY_readlink:
+ UNIDOR(OP_READLINK);
- case KEY_local:
- OPERATOR(LOCAL);
+ case KEY_ref:
+ UNI(OP_REF);
- case KEY_length:
- UNI(OP_LENGTH);
+ case KEY_s:
+ s = scan_subst(s);
+ if (pl_yylval.opval)
+ TERM(sublex_start());
+ else
+ TOKEN(1); /* force error */
- case KEY_lt:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Rop(OP_SLT);
+ case KEY_say:
+ checkcomma(s,PL_tokenbuf,"filehandle");
+ LOP(OP_SAY,XREF);
- case KEY_le:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Rop(OP_SLE);
+ case KEY_chomp:
+ UNI(OP_CHOMP);
- case KEY_localtime:
- UNI(OP_LOCALTIME);
+ case KEY_scalar:
+ UNI(OP_SCALAR);
- case KEY_log:
- UNI(OP_LOG);
+ case KEY_select:
+ LOP(OP_SELECT,XTERM);
- case KEY_link:
- LOP(OP_LINK,XTERM);
+ case KEY_seek:
+ LOP(OP_SEEK,XTERM);
- case KEY_listen:
- LOP(OP_LISTEN,XTERM);
+ case KEY_semctl:
+ LOP(OP_SEMCTL,XTERM);
- case KEY_lock:
- UNI(OP_LOCK);
+ case KEY_semget:
+ LOP(OP_SEMGET,XTERM);
- case KEY_lstat:
- UNI(OP_LSTAT);
+ case KEY_semop:
+ LOP(OP_SEMOP,XTERM);
- case KEY_m:
- s = scan_pat(s,OP_MATCH);
- TERM(sublex_start());
+ case KEY_send:
+ LOP(OP_SEND,XTERM);
- case KEY_map:
- LOP(OP_MAPSTART, XREF);
+ case KEY_setpgrp:
+ LOP(OP_SETPGRP,XTERM);
- case KEY_mkdir:
- LOP(OP_MKDIR,XTERM);
+ case KEY_setpriority:
+ LOP(OP_SETPRIORITY,XTERM);
- case KEY_msgctl:
- LOP(OP_MSGCTL,XTERM);
+ case KEY_sethostent:
+ UNI(OP_SHOSTENT);
- case KEY_msgget:
- LOP(OP_MSGGET,XTERM);
+ case KEY_setnetent:
+ UNI(OP_SNETENT);
- case KEY_msgrcv:
- LOP(OP_MSGRCV,XTERM);
+ case KEY_setservent:
+ UNI(OP_SSERVENT);
- case KEY_msgsnd:
- LOP(OP_MSGSND,XTERM);
+ case KEY_setprotoent:
+ UNI(OP_SPROTOENT);
- case KEY_our:
- case KEY_my:
- case KEY_state: {
- int tok = yyl_my(aTHX_ &s, tmp);
- if (tok == SUB)
- goto really_sub;
- else
- return tok;
- }
+ case KEY_setpwent:
+ FUN0(OP_SPWENT);
- case KEY_next:
- LOOPX(OP_NEXT);
+ case KEY_setgrent:
+ FUN0(OP_SGRENT);
- case KEY_ne:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Eop(OP_SNE);
+ case KEY_seekdir:
+ LOP(OP_SEEKDIR,XTERM);
- case KEY_no:
- s = tokenize_use(0, s);
- TOKEN(USE);
+ case KEY_setsockopt:
+ LOP(OP_SSOCKOPT,XTERM);
- 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_shift:
+ UNIDOR(OP_SHIFT);
- 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_shmctl:
+ LOP(OP_SHMCTL,XTERM);
- 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_shmget:
+ LOP(OP_SHMGET,XTERM);
- case KEY_ord:
- UNI(OP_ORD);
+ case KEY_shmread:
+ LOP(OP_SHMREAD,XTERM);
- case KEY_oct:
- UNI(OP_OCT);
+ case KEY_shmwrite:
+ LOP(OP_SHMWRITE,XTERM);
- case KEY_opendir:
- LOP(OP_OPEN_DIR,XTERM);
+ case KEY_shutdown:
+ LOP(OP_SHUTDOWN,XTERM);
- case KEY_print:
- checkcomma(s,PL_tokenbuf,"filehandle");
- LOP(OP_PRINT,XREF);
+ case KEY_sin:
+ UNI(OP_SIN);
- case KEY_printf:
- checkcomma(s,PL_tokenbuf,"filehandle");
- LOP(OP_PRTF,XREF);
+ case KEY_sleep:
+ UNI(OP_SLEEP);
- case KEY_prototype:
- UNI(OP_PROTOTYPE);
+ case KEY_socket:
+ LOP(OP_SOCKET,XTERM);
- case KEY_push:
- LOP(OP_PUSH,XTERM);
+ case KEY_socketpair:
+ LOP(OP_SOCKPAIR,XTERM);
- case KEY_pop:
- UNIDOR(OP_POP);
+ 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_pos:
- UNIDOR(OP_POS);
+ case KEY_split:
+ LOP(OP_SPLIT,XTERM);
- case KEY_pack:
- LOP(OP_PACK,XTERM);
+ case KEY_sprintf:
+ LOP(OP_SPRINTF,XTERM);
- case KEY_package:
- s = force_word(s,BAREWORD,FALSE,TRUE);
- s = skipspace(s);
- s = force_strict_version(s);
- PREBLOCK(PACKAGE);
+ case KEY_splice:
+ LOP(OP_SPLICE,XTERM);
- case KEY_pipe:
- LOP(OP_PIPE_OP,XTERM);
+ case KEY_sqrt:
+ UNI(OP_SQRT);
- 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_srand:
+ UNI(OP_SRAND);
- case KEY_quotemeta:
- UNI(OP_QUOTEMETA);
+ case KEY_stat:
+ UNI(OP_STAT);
- case KEY_qw:
- return yyl_qw(aTHX_ s, len);
+ case KEY_study:
+ UNI(OP_STUDY);
- 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_substr:
+ LOP(OP_SUBSTR,XTERM);
- case KEY_return:
- OLDLOP(OP_RETURN);
+ case KEY_format:
+ case KEY_sub:
+ return yyl_sub(aTHX_ s, key);
- case KEY_require:
- return yyl_require(aTHX_ s, orig_keyword);
+ case KEY_system:
+ LOP(OP_SYSTEM,XREF);
- case KEY_reset:
- UNI(OP_RESET);
+ case KEY_symlink:
+ LOP(OP_SYMLINK,XTERM);
- case KEY_redo:
- LOOPX(OP_REDO);
+ case KEY_syscall:
+ LOP(OP_SYSCALL,XTERM);
- case KEY_rename:
- LOP(OP_RENAME,XTERM);
+ case KEY_sysopen:
+ LOP(OP_SYSOPEN,XTERM);
- case KEY_rand:
- UNI(OP_RAND);
+ case KEY_sysseek:
+ LOP(OP_SYSSEEK,XTERM);
- case KEY_rmdir:
- UNI(OP_RMDIR);
+ case KEY_sysread:
+ LOP(OP_SYSREAD,XTERM);
- case KEY_rindex:
- LOP(OP_RINDEX,XTERM);
+ case KEY_syswrite:
+ LOP(OP_SYSWRITE,XTERM);
- case KEY_read:
- LOP(OP_READ,XTERM);
+ case KEY_tr:
+ case KEY_y:
+ s = scan_trans(s);
+ TERM(sublex_start());
- case KEY_readdir:
- UNI(OP_READDIR);
+ case KEY_tell:
+ UNI(OP_TELL);
- case KEY_readline:
- UNIDOR(OP_READLINE);
+ case KEY_telldir:
+ UNI(OP_TELLDIR);
- case KEY_readpipe:
- UNIDOR(OP_BACKTICK);
+ case KEY_tie:
+ LOP(OP_TIE,XTERM);
- case KEY_rewinddir:
- UNI(OP_REWINDDIR);
+ case KEY_tied:
+ UNI(OP_TIED);
- case KEY_recv:
- LOP(OP_RECV,XTERM);
+ case KEY_time:
+ FUN0(OP_TIME);
- case KEY_reverse:
- LOP(OP_REVERSE,XTERM);
+ case KEY_times:
+ FUN0(OP_TMS);
- case KEY_readlink:
- UNIDOR(OP_READLINK);
+ case KEY_truncate:
+ LOP(OP_TRUNCATE,XTERM);
- case KEY_ref:
- UNI(OP_REF);
+ case KEY_uc:
+ UNI(OP_UC);
- case KEY_s:
- s = scan_subst(s);
- if (pl_yylval.opval)
- TERM(sublex_start());
- else
- TOKEN(1); /* force error */
+ case KEY_ucfirst:
+ UNI(OP_UCFIRST);
- case KEY_say:
- checkcomma(s,PL_tokenbuf,"filehandle");
- LOP(OP_SAY,XREF);
+ case KEY_untie:
+ UNI(OP_UNTIE);
- case KEY_chomp:
- UNI(OP_CHOMP);
+ 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_scalar:
- UNI(OP_SCALAR);
+ 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_select:
- LOP(OP_SELECT,XTERM);
+ case KEY_unlink:
+ LOP(OP_UNLINK,XTERM);
- case KEY_seek:
- LOP(OP_SEEK,XTERM);
+ case KEY_undef:
+ UNIDOR(OP_UNDEF);
- case KEY_semctl:
- LOP(OP_SEMCTL,XTERM);
+ case KEY_unpack:
+ LOP(OP_UNPACK,XTERM);
- case KEY_semget:
- LOP(OP_SEMGET,XTERM);
+ case KEY_utime:
+ LOP(OP_UTIME,XTERM);
- case KEY_semop:
- LOP(OP_SEMOP,XTERM);
+ case KEY_umask:
+ UNIDOR(OP_UMASK);
- case KEY_send:
- LOP(OP_SEND,XTERM);
+ case KEY_unshift:
+ LOP(OP_UNSHIFT,XTERM);
- case KEY_setpgrp:
- LOP(OP_SETPGRP,XTERM);
+ case KEY_use:
+ s = tokenize_use(1, s);
+ TOKEN(USE);
- case KEY_setpriority:
- LOP(OP_SETPRIORITY,XTERM);
+ case KEY_values:
+ UNI(OP_VALUES);
- case KEY_sethostent:
- UNI(OP_SHOSTENT);
+ case KEY_vec:
+ LOP(OP_VEC,XTERM);
- case KEY_setnetent:
- UNI(OP_SNETENT);
+ 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_setservent:
- UNI(OP_SSERVENT);
+ 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_setprotoent:
- UNI(OP_SPROTOENT);
+ case KEY_warn:
+ PL_hints |= HINT_BLOCK_SCOPE;
+ LOP(OP_WARN,XTERM);
- case KEY_setpwent:
- FUN0(OP_SPWENT);
+ case KEY_wait:
+ FUN0(OP_WAIT);
- case KEY_setgrent:
- FUN0(OP_SGRENT);
+ case KEY_waitpid:
+ LOP(OP_WAITPID,XTERM);
- case KEY_seekdir:
- LOP(OP_SEEKDIR,XTERM);
+ case KEY_wantarray:
+ FUN0(OP_WANTARRAY);
- case KEY_setsockopt:
- LOP(OP_SSOCKOPT,XTERM);
+ 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_shift:
- UNIDOR(OP_SHIFT);
+ 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_shmctl:
- LOP(OP_SHMCTL,XTERM);
+ case KEY_xor:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
+ return REPORT(0);
+ pl_yylval.ival = OP_XOR;
+ OPERATOR(OROP);
+ }
+}
- case KEY_shmget:
- LOP(OP_SHMGET,XTERM);
+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;
- case KEY_shmread:
- LOP(OP_SHMREAD,XTERM);
+ /* Known to be a reserved word at this point */
+ return yyl_word_or_keyword(aTHX_ s, len, key, orig_keyword, c);
+}
- case KEY_shmwrite:
- LOP(OP_SHMWRITE,XTERM);
+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_shutdown:
- LOP(OP_SHUTDOWN,XTERM);
+ c.gv = gv;
- case KEY_sin:
- UNI(OP_SIN);
+ PL_bufptr = s;
+ s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
- case KEY_sleep:
- UNI(OP_SLEEP);
+ /* Some keywords can be followed by any delimiter, including ':' */
+ anydelim = word_takes_any_delimiter(PL_tokenbuf, len);
- case KEY_socket:
- LOP(OP_SOCKET,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_socketpair:
- LOP(OP_SOCKPAIR,XTERM);
+ d = s;
+ while (d < PL_bufend && isSPACE(*d))
+ d++; /* no comments skipped here, or s### is misparsed */
- 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);
+ /* Is this a word before a => operator? */
+ if (*d == '=' && d[1] == '>') {
+ return yyl_fatcomma(aTHX_ s, len);
+ }
- case KEY_split:
- LOP(OP_SPLIT,XTERM);
+ /* 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_sprintf:
- LOP(OP_SPRINTF,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);
+ }
- case KEY_splice:
- LOP(OP_SPLICE,XTERM);
+ /* 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_sqrt:
- UNI(OP_SQRT);
+ /* Check for built-in keyword */
+ key = keyword(PL_tokenbuf, len, 0);
- case KEY_srand:
- UNI(OP_SRAND);
+ if (key < 0)
+ key = yyl_secondclass_keyword(aTHX_ s, len, key, &orig_keyword, &c.gv, &c.gvp);
- case KEY_stat:
- UNI(OP_STAT);
+ 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_study:
- UNI(OP_STUDY);
+ return yyl_word_or_keyword(aTHX_ s, len, key, orig_keyword, c);
+}
- case KEY_substr:
- LOP(OP_SUBSTR,XTERM);
+static int
+yyl_try(pTHX_ char *s)
+{
+ char *d;
+ GV *gv = NULL;
+ int tok;
- case KEY_format:
- case KEY_sub:
- really_sub:
- return yyl_sub(aTHX_ s, tmp);
+ 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_system:
- LOP(OP_SYSTEM,XREF);
+ 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_symlink:
- LOP(OP_SYMLINK,XTERM);
+ 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. */
- case KEY_syscall:
- LOP(OP_SYSCALL,XTERM);
+ const char * const pdb = PerlEnv_getenv("PERL5DB");
- case KEY_sysopen:
- LOP(OP_SYSOPEN,XTERM);
+ 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 {
+ /* "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;
+ }
+ if ((tok = yyl_fake_eof(aTHX_ 0, cBOOL(PL_rsfp), s)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
- case KEY_sysseek:
- LOP(OP_SYSSEEK,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_sysread:
- LOP(OP_SYSREAD,XTERM);
+ case '#':
+ case '\n': {
+ const bool needs_semicolon = yyl_eol_needs_semicolon(aTHX_ &s);
+ if (needs_semicolon)
+ TOKEN(PERLY_SEMICOLON);
+ else
+ goto retry;
+ }
- case KEY_syswrite:
- LOP(OP_SYSWRITE,XTERM);
+ case '-':
+ return yyl_hyphen(aTHX_ s);
- case KEY_tr:
- case KEY_y:
- s = scan_trans(s);
- TERM(sublex_start());
+ case '+':
+ return yyl_plus(aTHX_ s);
- case KEY_tell:
- UNI(OP_TELL);
+ case '*':
+ return yyl_star(aTHX_ s);
- case KEY_telldir:
- UNI(OP_TELLDIR);
+ case '%':
+ return yyl_percent(aTHX_ s);
- case KEY_tie:
- LOP(OP_TIE,XTERM);
+ case '^':
+ return yyl_caret(aTHX_ s);
- case KEY_tied:
- UNI(OP_TIED);
+ case '[':
+ return yyl_leftsquare(aTHX_ s);
- case KEY_time:
- FUN0(OP_TIME);
+ case '~':
+ return yyl_tilde(aTHX_ s);
- case KEY_times:
- FUN0(OP_TMS);
+ case ',':
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
+ TOKEN(0);
+ s++;
+ OPERATOR(PERLY_COMMA);
+ case ':':
+ if (s[1] == ':')
+ return yyl_just_a_word(aTHX_ s, 0, 0, no_code);
+ return yyl_colon(aTHX_ s + 1);
- case KEY_truncate:
- LOP(OP_TRUNCATE,XTERM);
+ case '(':
+ return yyl_leftparen(aTHX_ s + 1);
- case KEY_uc:
- UNI(OP_UC);
+ case ';':
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ TOKEN(0);
+ CLINE;
+ s++;
+ PL_expect = XSTATE;
+ TOKEN(PERLY_SEMICOLON);
- case KEY_ucfirst:
- UNI(OP_UCFIRST);
+ case ')':
+ return yyl_rightparen(aTHX_ s);
- case KEY_untie:
- UNI(OP_UNTIE);
+ case ']':
+ return yyl_rightsquare(aTHX_ s);
- 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 '{':
+ return yyl_leftcurly(aTHX_ s + 1, 0);
- 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 '}':
+ if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
+ TOKEN(0);
+ return yyl_rightcurly(aTHX_ s, 0);
- case KEY_unlink:
- LOP(OP_UNLINK,XTERM);
+ case '&':
+ return yyl_ampersand(aTHX_ s);
- case KEY_undef:
- UNIDOR(OP_UNDEF);
+ case '|':
+ return yyl_verticalbar(aTHX_ s);
- case KEY_unpack:
- LOP(OP_UNPACK,XTERM);
+ 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_utime:
- LOP(OP_UTIME,XTERM);
+ 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(PERLY_COMMA);
+ }
+ 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_umask:
- UNIDOR(OP_UMASK);
+ case '!':
+ return yyl_bang(aTHX_ s + 1);
- case KEY_unshift:
- LOP(OP_UNSHIFT,XTERM);
+ 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);
- case KEY_use:
- s = tokenize_use(1, s);
- TOKEN(USE);
+ 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 KEY_values:
- UNI(OP_VALUES);
+ case '$':
+ return yyl_dollar(aTHX_ s);
- case KEY_vec:
- LOP(OP_VEC,XTERM);
+ case '@':
+ return yyl_snail(aTHX_ s);
- 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 '/': /* may be division, defined-or, or pattern */
+ return yyl_slash(aTHX_ s);
- 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 '?': /* conditional */
+ s++;
+ if (!PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
+ {
+ s--;
+ TOKEN(0);
+ }
+ PL_lex_allbrackets++;
+ OPERATOR(PERLY_QUESTION_MARK);
- case KEY_warn:
- PL_hints |= HINT_BLOCK_SCOPE;
- LOP(OP_WARN,XTERM);
+ 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)
+ {
+ 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_wait:
- FUN0(OP_WAIT);
+ case '\'':
+ return yyl_sglquote(aTHX_ s);
- case KEY_waitpid:
- LOP(OP_WAITPID,XTERM);
+ case '"':
+ return yyl_dblquote(aTHX_ s);
- case KEY_wantarray:
- FUN0(OP_WANTARRAY);
+ case '`':
+ return yyl_backtick(aTHX_ s);
- 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 '\\':
+ return yyl_backslash(aTHX_ s + 1);
- case KEY_x:
- if (PL_expect == XOPERATOR) {
- if (*s == '=' && !PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
- {
- return REPORT(0);
+ 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;
}
- Mop(OP_REPEAT);
}
- check_uni();
- goto just_a_word;
+ /* 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_xor:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
- return REPORT(0);
- pl_yylval.ival = OP_XOR;
- OPERATOR(OROP);
+ 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 '_':
+ 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;
+ }
}
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
+ return yyl_just_a_word if there is one
see whether built-in keyword is overridden
switch on keyword number:
- - default: just_a_word:
+ - default: return yyl_just_a_word:
not a built-in keyword; handle bareword lookup
disambiguate between method and sub call
fall back to bareword
int
Perl_yylex(pTHX)
{
- dVAR;
char *s = PL_bufptr;
- const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
if (UNLIKELY(PL_parser->recheck_utf8_validity)) {
const U8* first_bad_char_loc;
PL_lex_state = LEX_INTERPNORMAL;
if (PL_lex_dojoin) {
NEXTVAL_NEXTTOKE.ival = 0;
- force_next(',');
- force_ident("\"", '$');
+ force_next(PERLY_COMMA);
+ force_ident("\"", PERLY_DOLLAR);
NEXTVAL_NEXTTOKE.ival = 0;
- force_next('$');
+ force_next(PERLY_DOLLAR);
NEXTVAL_NEXTTOKE.ival = 0;
- force_next((2<<24)|'(');
+ force_next((2<<24)|PERLY_PAREN_OPEN);
NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
force_next(FUNC);
}
s = PL_bufptr;
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (!PL_lex_casemods && PL_lex_inpat)
- TOKEN(',');
+ TOKEN(PERLY_COMMA);
else
AopNOASSIGN(OP_CONCAT);
}
PL_lex_dojoin = FALSE;
PL_lex_state = LEX_INTERPCONCAT;
PL_lex_allbrackets--;
- return REPORT(dojoin_was == 1 ? (int)')' : (int)POSTJOIN);
+ return REPORT(dojoin_was == 1 ? (int)PERLY_PAREN_CLOSE : (int)POSTJOIN);
}
if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
&& SvEVALED(PL_lex_repl))
force_next(THING);
PL_parser->lex_shared->re_eval_start = NULL;
PL_expect = XTERM;
- return REPORT(',');
+ return REPORT(PERLY_COMMA);
}
/* FALLTHROUGH */
if (PL_lex_starts++) {
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (!PL_lex_casemods && PL_lex_inpat)
- TOKEN(',');
+ TOKEN(PERLY_COMMA);
else
AopNOASSIGN(OP_CONCAT);
}
}
assert(PL_lex_formbrack);
s = scan_formline(PL_bufptr);
- if (!PL_lex_formbrack) {
- return yyl_try(aTHX_ '}', s, 0, 0, NULL, NULL, 1, 0, saw_infix_sigil);
- }
+ if (!PL_lex_formbrack)
+ return yyl_rightcurly(aTHX_ s, 1);
PL_bufptr = s;
return yylex();
}
s = PL_bufptr;
PL_oldoldbufptr = PL_oldbufptr;
PL_oldbufptr = s;
- PL_parser->saw_infix_sigil = 0;
if (PL_in_my == KEY_sigvar) {
+ PL_parser->saw_infix_sigil = 0;
return yyl_sigvar(aTHX_ s);
}
- return yyl_try(aTHX_ 0, s, 0, 0, NULL, NULL, 0, 0, saw_infix_sigil);
+ {
+ /* 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;
+ }
}
* 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;
+ }
+
+ cvp = hv_fetch(table, key, keylen, FALSE);
+ if (!cvp || !SvOK(*cvp)) {
+ why1 = "$^H{";
+ why2 = key;
+ why3 = "} is not defined";
+ goto report;
}
- now_ok:
+
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;
}
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);
}
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';
}
}
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;
}
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)))
/* 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
\d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
\.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
0b[01](_?[01])* binary integers
- 0[0-7](_?[0-7])* octal integers
+ 0o?[0-7](_?[0-7])* octal integers
0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
NV hexfp_mult = 1.0;
UV high_non_zero = 0; /* highest digit */
int non_zero_integer_digits = 0;
+ bool new_octal = FALSE; /* octal with "0o" prefix */
PERL_ARGS_ASSERT_SCAN_NUM;
"",
"037777777777",
"0xffffffff" };
- const char *base, *Base, *max;
/* check for hex */
if (isALPHA_FOLD_EQ(s[1], 'x')) {
else {
shift = 3;
s++;
+ if (isALPHA_FOLD_EQ(*s, 'o')) {
+ s++;
+ just_zero = FALSE;
+ new_octal = TRUE;
+ }
}
if (*s == '_') {
lastub = s++;
}
- base = bases[shift];
- Base = Bases[shift];
- max = maxima[shift];
-
/* read the rest of the number */
for (;;) {
/* x is used in the overflow test,
n = (NV) u;
Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
"Integer overflow in %s number",
- base);
+ bases[shift]);
} else
u = x | b; /* add the digit to the end */
}
}
}
- if (shift != 3 && !has_digs) {
- /* 0x or 0b with no digits, treat it as an error.
+ if (!just_zero && !has_digs) {
+ /* 0x, 0o 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".
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"));
+ bases[shift]));
PL_bufptr = oldbp;
}
if (n > 4294967295.0)
Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
"%s number > %s non-portable",
- Base, max);
+ Bases[shift],
+ new_octal ? "0o37777777777" : maxima[shift]);
sv = newSVnv(n);
}
else {
if (u > 0xffffffff)
Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
"%s number > %s non-portable",
- Base, max);
+ Bases[shift],
+ new_octal ? "0o37777777777" : maxima[shift]);
#endif
sv = newSVuv(u);
}
s = start + 2;
break;
case 3:
+ if (new_octal) {
+ *d++ = 'o';
+ s = start + 2;
+ break;
+ }
s = start + 1;
break;
case 1:
/* 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;
* processing unconditionally */
if (s != NULL) {
- if (!yychar || (yychar == ';' && !PL_rsfp))
+ if (!yychar || (yychar == PERLY_SEMICOLON && !PL_rsfp))
sv_catpvs(where_sv, "at EOF");
else if ( PL_oldoldbufptr
&& PL_bufptr > PL_oldoldbufptr
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));
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;
which covers all the compilation errors that occurred. Some compilation
errors, however, will throw an exception immediately.
+=for apidoc Amnh||PARSE_OPTIONAL
+
=cut
+
*/
OP *
https://perl5.git.perl.org / perl5.git / blobdiff