#include "EXTERN.h"
#define PERL_IN_TOKE_C
#include "perl.h"
-#include "dquote_inline.h"
#include "invlist_inline.h"
#define new_constant(a,b,c,d,e,f,g, h) \
&& ((XPVIV*)SvANY(sv))->xiv_u.xivu_eval_seen)
static const char* const ident_too_long = "Identifier too long";
+static const char* const ident_var_zero_multi_digit = "Numeric variables with more than one digit may not start with '0'";
# define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
/* In variables named $^X, these are the legal values for X.
* 1999-02-27 mjd-perl-patch@plover.com */
-#define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
+#define isCONTROLVAR(x) (isUPPER(x) || memCHRs("[\\]^_?", (x)))
#define SPACE_OR_TAB(c) isBLANK_A(c)
#define LEX_INTERPCONST 2 /* NOT USED */
#define LEX_FORMLINE 1 /* expecting a format line */
+/* returned to yyl_try() to request it to retry the parse loop, expected to only
+ be returned directly by yyl_fake_eof(), but functions that call yyl_fake_eof()
+ can also return it.
+
+ yylex (aka Perl_yylex) returns 0 on EOF rather than returning -1,
+ other token values are 258 or higher (see perly.h), so -1 should be
+ a safe value here.
+*/
+#define YYL_RETRY (-1)
#ifdef DEBUGGING
static const char* const lex_state_names[] = {
* Aop : addition-level operator
* AopNOASSIGN : addition-level operator that is never part of .=
* Mop : multiplication-level operator
- * Eop : equality-testing operator
- * Rop : relational operator <= != gt
+ * ChEop : chaining equality-testing operator
+ * NCEop : non-chaining comparison operator at equality precedence
+ * ChRop : chaining relational operator <= != gt
+ * NCRop : non-chaining relational operator isa
*
* Also see LOP and lop() below.
*/
#define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
#define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
#define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
-#define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
-#define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
+#define ChEop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)CHEQOP))
+#define NCEop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)NCEQOP))
+#define ChRop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)CHRELOP))
+#define NCRop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)NCRELOP))
/* This bit of chicanery makes a unary function followed by
* a parenthesis into a function with one argument, highest precedence.
} STMT_END
+/* A file-local structure for passing around information about subroutines and
+ * related definable words */
+struct code {
+ SV *sv;
+ CV *cv;
+ GV *gv, **gvp;
+ OP *rv2cv_op;
+ PADOFFSET off;
+ bool lex;
+};
+
+static const struct code no_code = { NULL, NULL, NULL, NULL, NULL, 0, FALSE };
+
#ifdef DEBUGGING
/* how to interpret the pl_yylval associated with the token */
{ ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
{ BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
{ BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
+ { CHEQOP, TOKENTYPE_OPNUM, "CHEQOP" },
+ { CHRELOP, TOKENTYPE_OPNUM, "CHRELOP" },
{ COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
{ CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
{ DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
{ DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
{ ELSE, TOKENTYPE_NONE, "ELSE" },
{ ELSIF, TOKENTYPE_IVAL, "ELSIF" },
- { EQOP, TOKENTYPE_OPNUM, "EQOP" },
{ FOR, TOKENTYPE_IVAL, "FOR" },
{ FORMAT, TOKENTYPE_NONE, "FORMAT" },
{ FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
{ METHOD, TOKENTYPE_OPVAL, "METHOD" },
{ MULOP, TOKENTYPE_OPNUM, "MULOP" },
{ MY, TOKENTYPE_IVAL, "MY" },
+ { NCEQOP, TOKENTYPE_OPNUM, "NCEQOP" },
+ { NCRELOP, TOKENTYPE_OPNUM, "NCRELOP" },
{ NOAMP, TOKENTYPE_NONE, "NOAMP" },
{ NOTOP, TOKENTYPE_NONE, "NOTOP" },
{ OROP, TOKENTYPE_IVAL, "OROP" },
{ PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
{ QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
{ REFGEN, TOKENTYPE_NONE, "REFGEN" },
- { RELOP, TOKENTYPE_OPNUM, "RELOP" },
{ REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
{ SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
{ SIGSUB, TOKENTYPE_NONE, "SIGSUB" },
#include "feature.h"
/*
- * Check whether the named feature is enabled.
- */
-bool
-Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
-{
- char he_name[8 + MAX_FEATURE_LEN] = "feature_";
-
- PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
-
- assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
-
- if (namelen > MAX_FEATURE_LEN)
- return FALSE;
- memcpy(&he_name[8], name, namelen);
-
- return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
- REFCOUNTED_HE_EXISTS));
-}
-
-/*
* experimental text filters for win32 carriage-returns, utf16-to-utf8 and
* utf16-to-utf8-reversed.
*/
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));
if (next == '*') {
PL_expect = XOPERATOR;
if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
}
}
+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;
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 (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 */
bool is_sigsub = FEATURE_SIGNATURES_IS_ENABLED;
SSize_t off = s-SvPVX(PL_linestr);
- char *d = SvPVX(PL_linestr)+off;
- s = skipspace(s);
+ char *d;
+
+ s = skipspace(s); /* can move PL_linestr */
+
+ d = SvPVX(PL_linestr)+off;
SAVEBOOL(PL_parser->sig_seen);
PL_parser->sig_seen = FALSE;
}
static int
-yyl_secondclass_keyword(pTHX_ char *s, STRLEN len, int key, int *orig_keyword,
+yyl_secondclass_keyword(pTHX_ char *s, STRLEN len, int key, I32 *orig_keyword,
GV **pgv, GV ***pgvp)
{
GV *ogv = NULL; /* override (winner) */
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] == '{'))
)
{
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)
}
static int
+yyl_caret(pTHX_ char *s)
+{
+ char *d = s;
+ const bool bof = cBOOL(FEATURE_BITWISE_IS_ENABLED);
+ if (bof && s[1] == '.')
+ s++;
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
+ {
+ s = d;
+ TOKEN(0);
+ }
+ s++;
+ BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
+}
+
+static int
+yyl_colon(pTHX_ char *s)
+{
+ OP *attrs;
+
+ switch (PL_expect) {
+ case XOPERATOR:
+ if (!PL_in_my || (PL_lex_state != LEX_NORMAL && !PL_lex_brackets))
+ break;
+ PL_bufptr = s; /* update in case we back off */
+ if (*s == '=') {
+ Perl_croak(aTHX_
+ "Use of := for an empty attribute list is not allowed");
+ }
+ goto grabattrs;
+ case XATTRBLOCK:
+ PL_expect = XBLOCK;
+ goto grabattrs;
+ case XATTRTERM:
+ PL_expect = XTERMBLOCK;
+ grabattrs:
+ /* NB: as well as parsing normal attributes, we also end up
+ * here if there is something looking like attributes
+ * following a signature (which is illegal, but used to be
+ * legal in 5.20..5.26). If the latter, we still parse the
+ * attributes so that error messages(s) are less confusing,
+ * but ignore them (parser->sig_seen).
+ */
+ s = skipspace(s);
+ attrs = NULL;
+ while (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
+ bool sig = PL_parser->sig_seen;
+ I32 tmp;
+ SV *sv;
+ STRLEN len;
+ char *d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
+ if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
+ if (tmp < 0) tmp = -tmp;
+ switch (tmp) {
+ case KEY_or:
+ case KEY_and:
+ case KEY_for:
+ case KEY_foreach:
+ case KEY_unless:
+ case KEY_if:
+ case KEY_while:
+ case KEY_until:
+ goto got_attrs;
+ default:
+ break;
+ }
+ }
+ sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
+ if (*d == '(') {
+ d = scan_str(d,TRUE,TRUE,FALSE,NULL);
+ if (!d) {
+ if (attrs)
+ op_free(attrs);
+ sv_free(sv);
+ Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
+ }
+ COPLINE_SET_FROM_MULTI_END;
+ }
+ if (PL_lex_stuff) {
+ sv_catsv(sv, PL_lex_stuff);
+ attrs = op_append_elem(OP_LIST, attrs,
+ newSVOP(OP_CONST, 0, sv));
+ SvREFCNT_dec_NN(PL_lex_stuff);
+ PL_lex_stuff = NULL;
+ }
+ else {
+ /* NOTE: any CV attrs applied here need to be part of
+ the CVf_BUILTIN_ATTRS define in cv.h! */
+ if (!PL_in_my && memEQs(SvPVX(sv), len, "lvalue")) {
+ sv_free(sv);
+ if (!sig)
+ CvLVALUE_on(PL_compcv);
+ }
+ else if (!PL_in_my && memEQs(SvPVX(sv), len, "method")) {
+ sv_free(sv);
+ if (!sig)
+ CvMETHOD_on(PL_compcv);
+ }
+ else if (!PL_in_my && memEQs(SvPVX(sv), len, "const")) {
+ sv_free(sv);
+ if (!sig) {
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
+ ":const is experimental"
+ );
+ CvANONCONST_on(PL_compcv);
+ if (!CvANON(PL_compcv))
+ yyerror(":const is not permitted on named "
+ "subroutines");
+ }
+ }
+ /* After we've set the flags, it could be argued that
+ we don't need to do the attributes.pm-based setting
+ process, and shouldn't bother appending recognized
+ flags. To experiment with that, uncomment the
+ following "else". (Note that's already been
+ uncommented. That keeps the above-applied built-in
+ attributes from being intercepted (and possibly
+ rejected) by a package's attribute routines, but is
+ justified by the performance win for the common case
+ of applying only built-in attributes.) */
+ else
+ attrs = op_append_elem(OP_LIST, attrs,
+ newSVOP(OP_CONST, 0,
+ sv));
+ }
+ s = skipspace(d);
+ if (*s == ':' && s[1] != ':')
+ s = skipspace(s+1);
+ else if (s == d)
+ break; /* require real whitespace or :'s */
+ /* XXX losing whitespace on sequential attributes here */
+ }
+
+ if (*s != ';'
+ && *s != '}'
+ && !(PL_expect == XOPERATOR
+ ? (*s == '=' || *s == ')')
+ : (*s == '{' || *s == '(')))
+ {
+ const char q = ((*s == '\'') ? '"' : '\'');
+ /* If here for an expression, and parsed no attrs, back off. */
+ if (PL_expect == XOPERATOR && !attrs) {
+ s = PL_bufptr;
+ break;
+ }
+ /* MUST advance bufptr here to avoid bogus "at end of line"
+ context messages from yyerror().
+ */
+ PL_bufptr = s;
+ yyerror( (const char *)
+ (*s
+ ? Perl_form(aTHX_ "Invalid separator character "
+ "%c%c%c in attribute list", q, *s, q)
+ : "Unterminated attribute list" ) );
+ if (attrs)
+ op_free(attrs);
+ OPERATOR(':');
+ }
+
+ got_attrs:
+ if (PL_parser->sig_seen) {
+ /* see comment about about sig_seen and parser error
+ * handling */
+ if (attrs)
+ op_free(attrs);
+ Perl_croak(aTHX_ "Subroutine attributes must come "
+ "before the signature");
+ }
+ if (attrs) {
+ NEXTVAL_NEXTTOKE.opval = attrs;
+ force_next(THING);
+ }
+ TOKEN(COLONATTR);
+ }
+
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
+ s--;
+ TOKEN(0);
+ }
+
+ PL_lex_allbrackets--;
+ OPERATOR(':');
+}
+
+static int
yyl_subproto(pTHX_ char *s, CV *cv)
{
STRLEN protolen = CvPROTOLEN(cv);
return KEY_NULL;
}
-/*
- yylex
+static int
+yyl_leftcurly(pTHX_ char *s, const U8 formbrack)
+{
+ char *d;
+ if (PL_lex_brackets > 100) {
+ Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
+ }
- Works out what to call the token just pulled out of the input
- stream. The yacc parser takes care of taking the ops we return and
- stitching them into a tree.
+ switch (PL_expect) {
+ case XTERM:
+ case XTERMORDORDOR:
+ PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
+ PL_lex_allbrackets++;
+ OPERATOR(HASHBRACK);
+ case XOPERATOR:
+ while (s < PL_bufend && SPACE_OR_TAB(*s))
+ s++;
+ d = s;
+ PL_tokenbuf[0] = '\0';
+ if (d < PL_bufend && *d == '-') {
+ PL_tokenbuf[0] = '-';
+ d++;
+ while (d < PL_bufend && SPACE_OR_TAB(*d))
+ d++;
+ }
+ if (d < PL_bufend && isIDFIRST_lazy_if_safe(d, PL_bufend, UTF)) {
+ STRLEN len;
+ d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
+ FALSE, &len);
+ while (d < PL_bufend && SPACE_OR_TAB(*d))
+ d++;
+ if (*d == '}') {
+ const char minus = (PL_tokenbuf[0] == '-');
+ s = force_word(s + minus, BAREWORD, FALSE, TRUE);
+ if (minus)
+ force_next('-');
+ }
+ }
+ /* FALLTHROUGH */
+ case XATTRTERM:
+ case XTERMBLOCK:
+ PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
+ PL_lex_allbrackets++;
+ PL_expect = XSTATE;
+ break;
+ case XATTRBLOCK:
+ case XBLOCK:
+ PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
+ PL_lex_allbrackets++;
+ PL_expect = XSTATE;
+ break;
+ case XBLOCKTERM:
+ PL_lex_brackstack[PL_lex_brackets++] = XTERM;
+ PL_lex_allbrackets++;
+ PL_expect = XSTATE;
+ break;
+ default: {
+ const char *t;
+ if (PL_oldoldbufptr == PL_last_lop)
+ PL_lex_brackstack[PL_lex_brackets++] = XTERM;
+ else
+ PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
+ PL_lex_allbrackets++;
+ s = skipspace(s);
+ if (*s == '}') {
+ if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
+ PL_expect = XTERM;
+ /* This hack is to get the ${} in the message. */
+ PL_bufptr = s+1;
+ yyerror("syntax error");
+ break;
+ }
+ OPERATOR(HASHBRACK);
+ }
+ if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
+ /* ${...} or @{...} etc., but not print {...}
+ * Skip the disambiguation and treat this as a block.
+ */
+ goto block_expectation;
+ }
+ /* This hack serves to disambiguate a pair of curlies
+ * as being a block or an anon hash. Normally, expectation
+ * determines that, but in cases where we're not in a
+ * position to expect anything in particular (like inside
+ * eval"") we have to resolve the ambiguity. This code
+ * covers the case where the first term in the curlies is a
+ * quoted string. Most other cases need to be explicitly
+ * disambiguated by prepending a "+" before the opening
+ * curly in order to force resolution as an anon hash.
+ *
+ * XXX should probably propagate the outer expectation
+ * into eval"" to rely less on this hack, but that could
+ * potentially break current behavior of eval"".
+ * GSAR 97-07-21
+ */
+ t = s;
+ if (*s == '\'' || *s == '"' || *s == '`') {
+ /* common case: get past first string, handling escapes */
+ for (t++; t < PL_bufend && *t != *s;)
+ if (*t++ == '\\')
+ t++;
+ t++;
+ }
+ else if (*s == 'q') {
+ if (++t < PL_bufend
+ && (!isWORDCHAR(*t)
+ || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
+ && !isWORDCHAR(*t))))
+ {
+ /* skip q//-like construct */
+ const char *tmps;
+ char open, close, term;
+ I32 brackets = 1;
- Returns:
- The type of the next token
+ while (t < PL_bufend && isSPACE(*t))
+ t++;
+ /* check for q => */
+ if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
+ OPERATOR(HASHBRACK);
+ }
+ term = *t;
+ open = term;
+ if (term && (tmps = memCHRs("([{< )]}> )]}>",term)))
+ term = tmps[5];
+ close = term;
+ if (open == close)
+ for (t++; t < PL_bufend; t++) {
+ if (*t == '\\' && t+1 < PL_bufend && open != '\\')
+ t++;
+ else if (*t == open)
+ break;
+ }
+ else {
+ for (t++; t < PL_bufend; t++) {
+ if (*t == '\\' && t+1 < PL_bufend)
+ t++;
+ else if (*t == close && --brackets <= 0)
+ break;
+ else if (*t == open)
+ brackets++;
+ }
+ }
+ t++;
+ }
+ else
+ /* skip plain q word */
+ while ( t < PL_bufend
+ && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
+ {
+ t += UTF ? UTF8SKIP(t) : 1;
+ }
+ }
+ else if (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)) {
+ t += UTF ? UTF8SKIP(t) : 1;
+ while ( t < PL_bufend
+ && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
+ {
+ t += UTF ? UTF8SKIP(t) : 1;
+ }
+ }
+ while (t < PL_bufend && isSPACE(*t))
+ t++;
+ /* if comma follows first term, call it an anon hash */
+ /* XXX it could be a comma expression with loop modifiers */
+ if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
+ || (*t == '=' && t[1] == '>')))
+ OPERATOR(HASHBRACK);
+ if (PL_expect == XREF) {
+ block_expectation:
+ /* If there is an opening brace or 'sub:', treat it
+ as a term to make ${{...}}{k} and &{sub:attr...}
+ dwim. Otherwise, treat it as a statement, so
+ map {no strict; ...} works.
+ */
+ s = skipspace(s);
+ if (*s == '{') {
+ PL_expect = XTERM;
+ break;
+ }
+ if (memBEGINs(s, (STRLEN) (PL_bufend - s), "sub")) {
+ PL_bufptr = s;
+ d = s + 3;
+ d = skipspace(d);
+ s = PL_bufptr;
+ if (*d == ':') {
+ PL_expect = XTERM;
+ break;
+ }
+ }
+ PL_expect = XSTATE;
+ }
+ else {
+ PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
+ PL_expect = XSTATE;
+ }
+ }
+ break;
+ }
- Structure:
- Check if we have already built the token; if so, use it.
- Switch based on the current state:
- - if we have a case modifier in a string, deal with that
- - handle other cases of interpolation inside a string
- - scan the next line if we are inside a format
- In the normal state, switch on the next character:
- - default:
- if alphabetic, go to key lookup
- unrecognized character - croak
- - 0/4/26: handle end-of-line or EOF
- - cases for whitespace
- - \n and #: handle comments and line numbers
- - various operators, brackets and sigils
- - numbers
- - quotes
- - 'v': vstrings (or go to key lookup)
- - 'x' repetition operator (or go to key lookup)
- - other ASCII alphanumerics (key lookup begins here):
- word before => ?
- keyword plugin
- scan built-in keyword (but do nothing with it yet)
- check for statement label
- check for lexical subs
- goto just_a_word if there is one
- see whether built-in keyword is overridden
- switch on keyword number:
- - default: just_a_word:
- not a built-in keyword; handle bareword lookup
- disambiguate between method and sub call
- fall back to bareword
- - cases for built-in keywords
-*/
+ pl_yylval.ival = CopLINE(PL_curcop);
+ PL_copline = NOLINE; /* invalidate current command line number */
+ TOKEN(formbrack ? '=' : '{');
+}
-#ifdef NETWARE
-#define RSFP_FILENO (PL_rsfp)
-#else
-#define RSFP_FILENO (PerlIO_fileno(PL_rsfp))
-#endif
+static int
+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");
+ else
+ PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
-int
-Perl_yylex(pTHX)
-{
- dVAR;
- char *s = PL_bufptr;
- char *d;
- STRLEN len;
- bool bof = FALSE;
- const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
- U8 formbrack = 0;
- U32 fake_eof = 0;
-
- /* orig_keyword, gvp, and gv are initialized here because
- * jump to the label just_a_word_zero can bypass their
- * initialization later. */
- I32 orig_keyword = 0;
- GV *gv = NULL;
- GV **gvp = NULL;
+ PL_lex_allbrackets--;
- if (UNLIKELY(PL_parser->recheck_utf8_validity)) {
- const U8* first_bad_char_loc;
- if (UTF && UNLIKELY(! is_utf8_string_loc((U8 *) PL_bufptr,
- PL_bufend - PL_bufptr,
- &first_bad_char_loc)))
- {
- _force_out_malformed_utf8_message(first_bad_char_loc,
- (U8 *) PL_bufend,
- 0,
- 1 /* 1 means die */ );
- NOT_REACHED; /* NOTREACHED */
+ if (PL_lex_state == LEX_INTERPNORMAL) {
+ if (PL_lex_brackets == 0) {
+ if (PL_expect & XFAKEBRACK) {
+ PL_expect &= XENUMMASK;
+ PL_lex_state = LEX_INTERPEND;
+ PL_bufptr = s;
+ return yylex(); /* ignore fake brackets */
+ }
+ if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
+ && SvEVALED(PL_lex_repl))
+ PL_lex_state = LEX_INTERPEND;
+ else if (*s == '-' && s[1] == '>')
+ PL_lex_state = LEX_INTERPENDMAYBE;
+ else if (*s != '[' && *s != '{')
+ PL_lex_state = LEX_INTERPEND;
}
- PL_parser->recheck_utf8_validity = FALSE;
}
- DEBUG_T( {
- SV* tmp = newSVpvs("");
- PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n",
- (IV)CopLINE(PL_curcop),
- lex_state_names[PL_lex_state],
- exp_name[PL_expect],
- pv_display(tmp, s, strlen(s), 0, 60));
- SvREFCNT_dec(tmp);
- } );
- /* when we've already built the next token, just pull it out of the queue */
- if (PL_nexttoke) {
- PL_nexttoke--;
- pl_yylval = PL_nextval[PL_nexttoke];
- {
- I32 next_type;
- next_type = PL_nexttype[PL_nexttoke];
- if (next_type & (7<<24)) {
- if (next_type & (1<<24)) {
- if (PL_lex_brackets > 100)
- Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
- PL_lex_brackstack[PL_lex_brackets++] =
- (char) ((next_type >> 16) & 0xff);
- }
- if (next_type & (2<<24))
- PL_lex_allbrackets++;
- if (next_type & (4<<24))
- PL_lex_allbrackets--;
- next_type &= 0xffff;
- }
- return REPORT(next_type == 'p' ? pending_ident() : next_type);
- }
+ if (PL_expect & XFAKEBRACK) {
+ PL_expect &= XENUMMASK;
+ PL_bufptr = s;
+ return yylex(); /* ignore fake brackets */
}
- switch (PL_lex_state) {
- case LEX_NORMAL:
- case LEX_INTERPNORMAL:
- break;
-
- /* interpolated case modifiers like \L \U, including \Q and \E.
- when we get here, PL_bufptr is at the \
- */
- case LEX_INTERPCASEMOD:
- /* handle \E or end of string */
- return yyl_interpcasemod(aTHX_ s);
-
- case LEX_INTERPPUSH:
- return REPORT(sublex_push());
-
- case LEX_INTERPSTART:
- if (PL_bufptr == PL_bufend)
- return REPORT(sublex_done());
- DEBUG_T({
- if(*PL_bufptr != '(')
- PerlIO_printf(Perl_debug_log, "### Interpolated variable\n");
- });
- PL_expect = XTERM;
- /* for /@a/, we leave the joining for the regex engine to do
- * (unless we're within \Q etc) */
- PL_lex_dojoin = (*PL_bufptr == '@'
- && (!PL_lex_inpat || PL_lex_casemods));
- PL_lex_state = LEX_INTERPNORMAL;
- if (PL_lex_dojoin) {
- NEXTVAL_NEXTTOKE.ival = 0;
- force_next(',');
- force_ident("\"", '$');
- NEXTVAL_NEXTTOKE.ival = 0;
- force_next('$');
- NEXTVAL_NEXTTOKE.ival = 0;
- force_next((2<<24)|'(');
- NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
- force_next(FUNC);
- }
- /* Convert (?{...}) and friends to 'do {...}' */
- if (PL_lex_inpat && *PL_bufptr == '(') {
- PL_parser->lex_shared->re_eval_start = PL_bufptr;
- PL_bufptr += 2;
- if (*PL_bufptr != '{')
- PL_bufptr++;
- PL_expect = XTERMBLOCK;
- force_next(DO);
- }
+ force_next(formbrack ? '.' : '}');
+ if (formbrack) LEAVE_with_name("lex_format");
+ if (formbrack == 2) { /* means . where arguments were expected */
+ force_next(';');
+ TOKEN(FORMRBRACK);
+ }
- if (PL_lex_starts++) {
- s = PL_bufptr;
- /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
- if (!PL_lex_casemods && PL_lex_inpat)
- TOKEN(',');
- else
- AopNOASSIGN(OP_CONCAT);
- }
- return yylex();
+ TOKEN(';');
+}
- case LEX_INTERPENDMAYBE:
- if (intuit_more(PL_bufptr, PL_bufend)) {
- PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
- break;
- }
- /* FALLTHROUGH */
+static int
+yyl_ampersand(pTHX_ char *s)
+{
+ if (PL_expect == XPOSTDEREF)
+ POSTDEREF('&');
- case LEX_INTERPEND:
- if (PL_lex_dojoin) {
- const U8 dojoin_was = PL_lex_dojoin;
- PL_lex_dojoin = FALSE;
- PL_lex_state = LEX_INTERPCONCAT;
- PL_lex_allbrackets--;
- return REPORT(dojoin_was == 1 ? (int)')' : (int)POSTJOIN);
- }
- if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
- && SvEVALED(PL_lex_repl))
- {
- if (PL_bufptr != PL_bufend)
- Perl_croak(aTHX_ "Bad evalled substitution pattern");
- PL_lex_repl = NULL;
- }
- /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
- re_eval_str. If the here-doc body’s length equals the previous
- value of re_eval_start, re_eval_start will now be null. So
- check re_eval_str as well. */
- if (PL_parser->lex_shared->re_eval_start
- || PL_parser->lex_shared->re_eval_str) {
- SV *sv;
- if (*PL_bufptr != ')')
- Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
- PL_bufptr++;
- /* having compiled a (?{..}) expression, return the original
- * text too, as a const */
- if (PL_parser->lex_shared->re_eval_str) {
- sv = PL_parser->lex_shared->re_eval_str;
- PL_parser->lex_shared->re_eval_str = NULL;
- SvCUR_set(sv,
- PL_bufptr - PL_parser->lex_shared->re_eval_start);
- SvPV_shrink_to_cur(sv);
- }
- else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
- PL_bufptr - PL_parser->lex_shared->re_eval_start);
- NEXTVAL_NEXTTOKE.opval =
- newSVOP(OP_CONST, 0,
- sv);
- force_next(THING);
- PL_parser->lex_shared->re_eval_start = NULL;
- PL_expect = XTERM;
- return REPORT(',');
- }
+ s++;
+ if (*s++ == '&') {
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
+ s -= 2;
+ TOKEN(0);
+ }
+ AOPERATOR(ANDAND);
+ }
+ s--;
- /* FALLTHROUGH */
- case LEX_INTERPCONCAT:
-#ifdef DEBUGGING
- if (PL_lex_brackets)
- Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
- (long) PL_lex_brackets);
-#endif
- if (PL_bufptr == PL_bufend)
- return REPORT(sublex_done());
+ if (PL_expect == XOPERATOR) {
+ char *d;
+ bool bof;
+ if ( PL_bufptr == PL_linestart
+ && ckWARN(WARN_SEMICOLON)
+ && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
+ {
+ CopLINE_dec(PL_curcop);
+ Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
+ CopLINE_inc(PL_curcop);
+ }
+ d = s;
+ if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
+ s++;
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
+ s = d;
+ s--;
+ TOKEN(0);
+ }
+ if (d == s)
+ BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
+ else
+ BAop(OP_SBIT_AND);
+ }
- /* m'foo' still needs to be parsed for possible (?{...}) */
- if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
- SV *sv = newSVsv(PL_linestr);
- sv = tokeq(sv);
- pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
- s = PL_bufend;
- }
- else {
- int save_error_count = PL_error_count;
+ PL_tokenbuf[0] = '&';
+ s = scan_ident(s - 1, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
+ pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
- s = scan_const(PL_bufptr);
+ if (PL_tokenbuf[1])
+ force_ident_maybe_lex('&');
+ else
+ PREREF('&');
- /* Set flag if this was a pattern and there were errors. op.c will
- * refuse to compile a pattern with this flag set. Otherwise, we
- * could get segfaults, etc. */
- if (PL_lex_inpat && PL_error_count > save_error_count) {
- ((PMOP*)PL_lex_inpat)->op_pmflags |= PMf_HAS_ERROR;
- }
- if (*s == '\\')
- PL_lex_state = LEX_INTERPCASEMOD;
- else
- PL_lex_state = LEX_INTERPSTART;
- }
+ TERM('&');
+}
- if (s != PL_bufptr) {
- NEXTVAL_NEXTTOKE = pl_yylval;
- PL_expect = XTERM;
- force_next(THING);
- if (PL_lex_starts++) {
- /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
- if (!PL_lex_casemods && PL_lex_inpat)
- TOKEN(',');
- else
- AopNOASSIGN(OP_CONCAT);
- }
- else {
- PL_bufptr = s;
- return yylex();
- }
- }
+static int
+yyl_verticalbar(pTHX_ char *s)
+{
+ char *d;
+ bool bof;
- return yylex();
- case LEX_FORMLINE:
- if (PL_parser->sub_error_count != PL_error_count) {
- /* There was an error parsing a formline, which tends to
- mess up the parser.
- Unlike interpolated sub-parsing, we can't treat any of
- these as recoverable, so no need to check sub_no_recover.
- */
- yyquit();
+ s++;
+ if (*s++ == '|') {
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
+ s -= 2;
+ TOKEN(0);
}
- assert(PL_lex_formbrack);
- s = scan_formline(PL_bufptr);
- if (!PL_lex_formbrack)
- {
- formbrack = 1;
- goto rightbracket;
- }
- PL_bufptr = s;
- return yylex();
+ AOPERATOR(OROR);
}
- /* We really do *not* want PL_linestr ever becoming a COW. */
- assert (!SvIsCOW(PL_linestr));
- s = PL_bufptr;
- PL_oldoldbufptr = PL_oldbufptr;
- PL_oldbufptr = s;
- PL_parser->saw_infix_sigil = 0;
+ s--;
+ d = s;
+ if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
+ s++;
- if (PL_in_my == KEY_sigvar) {
- return yyl_sigvar(aTHX_ s);
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
+ s = d - 1;
+ TOKEN(0);
}
- retry:
- switch (*s) {
- default:
- if (UTF ? isIDFIRST_utf8_safe(s, PL_bufend) : isALNUMC(*s)) {
- goto keylookup;
- }
- {
- SV *dsv = newSVpvs_flags("", SVs_TEMP);
- const char *c;
- if (UTF) {
- STRLEN skiplen = UTF8SKIP(s);
- STRLEN stravail = PL_bufend - s;
- c = sv_uni_display(dsv, newSVpvn_flags(s,
- skiplen > stravail ? stravail : skiplen,
- SVs_TEMP | SVf_UTF8),
- 10, UNI_DISPLAY_ISPRINT);
- }
- else {
- c = Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
- }
+ BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
+}
- if (s >= PL_linestart) {
- d = PL_linestart;
- }
- else {
- /* somehow (probably due to a parse failure), PL_linestart has advanced
- * pass PL_bufptr, get a reasonable beginning of line
- */
- d = s;
- while (d > SvPVX(PL_linestr) && d[-1] && d[-1] != '\n')
- --d;
+static int
+yyl_bang(pTHX_ char *s)
+{
+ const char tmp = *s++;
+ if (tmp == '=') {
+ /* was this !=~ where !~ was meant?
+ * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
+
+ if (*s == '~' && ckWARN(WARN_SYNTAX)) {
+ const char *t = s+1;
+
+ while (t < PL_bufend && isSPACE(*t))
+ ++t;
+
+ if (*t == '/' || *t == '?'
+ || ((*t == 'm' || *t == 's' || *t == 'y')
+ && !isWORDCHAR(t[1]))
+ || (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "!=~ should be !~");
}
- len = UTF ? Perl_utf8_length(aTHX_ (U8 *) d, (U8 *) s) : (STRLEN) (s - d);
- if (len > UNRECOGNIZED_PRECEDE_COUNT) {
- d = UTF ? (char *) utf8_hop_back((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT, (U8 *)d) : s - UNRECOGNIZED_PRECEDE_COUNT;
+
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s -= 2;
+ TOKEN(0);
}
- Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %" UTF8f "<-- HERE near column %d", c,
- UTF8fARG(UTF, (s - d), d),
- (int) len + 1);
+ ChEop(OP_NE);
}
- case 4:
- case 26:
- goto fake_eof; /* emulate EOF on ^D or ^Z */
- case 0:
- if ((!PL_rsfp || PL_lex_inwhat)
- && (!PL_parser->filtered || s+1 < PL_bufend)) {
- PL_last_uni = 0;
- PL_last_lop = 0;
- if (PL_lex_brackets
- && PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF)
- {
- yyerror((const char *)
- (PL_lex_formbrack
- ? "Format not terminated"
- : "Missing right curly or square bracket"));
- }
- DEBUG_T({
- PerlIO_printf(Perl_debug_log, "### Tokener got EOF\n");
- });
- TOKEN(0);
- }
- if (s++ < PL_bufend)
- goto retry; /* ignore stray nulls */
- PL_last_uni = 0;
- PL_last_lop = 0;
- if (!PL_in_eval && !PL_preambled) {
- PL_preambled = TRUE;
- if (PL_perldb) {
- /* Generate a string of Perl code to load the debugger.
- * If PERL5DB is set, it will return the contents of that,
- * otherwise a compile-time require of perl5db.pl. */
-
- const char * const pdb = PerlEnv_getenv("PERL5DB");
- if (pdb) {
- sv_setpv(PL_linestr, pdb);
- sv_catpvs(PL_linestr,";");
- } else {
- SETERRNO(0,SS_NORMAL);
- sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
- }
- PL_parser->preambling = CopLINE(PL_curcop);
- } else
- SvPVCLEAR(PL_linestr);
- if (PL_preambleav) {
- SV **svp = AvARRAY(PL_preambleav);
- SV **const end = svp + AvFILLp(PL_preambleav);
- while(svp <= end) {
- sv_catsv(PL_linestr, *svp);
- ++svp;
- sv_catpvs(PL_linestr, ";");
- }
- sv_free(MUTABLE_SV(PL_preambleav));
- PL_preambleav = NULL;
- }
- if (PL_minus_E)
- sv_catpvs(PL_linestr,
- "use feature ':5." STRINGIFY(PERL_VERSION) "';");
- if (PL_minus_n || PL_minus_p) {
- sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
- if (PL_minus_l)
- sv_catpvs(PL_linestr,"chomp;");
- if (PL_minus_a) {
- if (PL_minus_F) {
- if ( ( *PL_splitstr == '/'
- || *PL_splitstr == '\''
- || *PL_splitstr == '"')
- && strchr(PL_splitstr + 1, *PL_splitstr))
- {
- /* strchr is ok, because -F pattern can't contain
- * embeddded NULs */
- Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
- }
- else {
- /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
- bytes can be used as quoting characters. :-) */
- const char *splits = PL_splitstr;
- sv_catpvs(PL_linestr, "our @F=split(q\0");
- do {
- /* Need to \ \s */
- if (*splits == '\\')
- sv_catpvn(PL_linestr, splits, 1);
- sv_catpvn(PL_linestr, splits, 1);
- } while (*splits++);
- /* This loop will embed the trailing NUL of
- PL_linestr as the last thing it does before
- terminating. */
- sv_catpvs(PL_linestr, ");");
- }
- }
- else
- sv_catpvs(PL_linestr,"our @F=split(' ');");
- }
- }
- sv_catpvs(PL_linestr, "\n");
- PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = NULL;
- if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
- update_debugger_info(PL_linestr, NULL, 0);
- goto retry;
- }
- do {
- fake_eof = 0;
- bof = cBOOL(PL_rsfp);
- if (0) {
- fake_eof:
- fake_eof = LEX_FAKE_EOF;
- }
- PL_bufptr = PL_bufend;
- COPLINE_INC_WITH_HERELINES;
- if (!lex_next_chunk(fake_eof)) {
- CopLINE_dec(PL_curcop);
- s = PL_bufptr;
- TOKEN(';'); /* not infinite loop because rsfp is NULL now */
- }
- CopLINE_dec(PL_curcop);
- s = PL_bufptr;
- /* If it looks like the start of a BOM or raw UTF-16,
- * check if it in fact is. */
- if (bof && PL_rsfp
- && ( *s == 0
- || *(U8*)s == BOM_UTF8_FIRST_BYTE
- || *(U8*)s >= 0xFE
- || s[1] == 0))
- {
- Off_t offset = (IV)PerlIO_tell(PL_rsfp);
- bof = (offset == (Off_t)SvCUR(PL_linestr));
-#if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
- /* offset may include swallowed CR */
- if (!bof)
- bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
-#endif
- if (bof) {
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- s = swallow_bom((U8*)s);
- }
- }
- if (PL_parser->in_pod) {
- /* Incest with pod. */
- if ( memBEGINPs(s, (STRLEN) (PL_bufend - s), "=cut")
- && !isALPHA(s[4]))
- {
- SvPVCLEAR(PL_linestr);
- PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = NULL;
- PL_parser->in_pod = 0;
- }
- }
- if (PL_rsfp || PL_parser->filtered)
- incline(s, PL_bufend);
- } while (PL_parser->in_pod);
- PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = NULL;
- if (CopLINE(PL_curcop) == 1) {
- while (s < PL_bufend && isSPACE(*s))
- s++;
- if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
- s++;
- d = NULL;
- if (!PL_in_eval) {
- if (*s == '#' && *(s+1) == '!')
- d = s + 2;
-#ifdef ALTERNATE_SHEBANG
- else {
- static char const as[] = ALTERNATE_SHEBANG;
- if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
- d = s + (sizeof(as) - 1);
- }
-#endif /* ALTERNATE_SHEBANG */
- }
- if (d) {
- char *ipath;
- char *ipathend;
+ if (tmp == '~')
+ PMop(OP_NOT);
- while (isSPACE(*d))
- d++;
- ipath = d;
- while (*d && !isSPACE(*d))
- d++;
- ipathend = d;
+ s--;
+ OPERATOR('!');
+}
-#ifdef ARG_ZERO_IS_SCRIPT
- if (ipathend > ipath) {
- /*
- * HP-UX (at least) sets argv[0] to the script name,
- * which makes $^X incorrect. And Digital UNIX and Linux,
- * at least, set argv[0] to the basename of the Perl
- * interpreter. So, having found "#!", we'll set it right.
- */
- SV* copfilesv = CopFILESV(PL_curcop);
- if (copfilesv) {
- SV * const x =
- GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
- SVt_PV)); /* $^X */
- assert(SvPOK(x) || SvGMAGICAL(x));
- if (sv_eq(x, copfilesv)) {
- sv_setpvn(x, ipath, ipathend - ipath);
- SvSETMAGIC(x);
- }
- else {
- STRLEN blen;
- STRLEN llen;
- const char *bstart = SvPV_const(copfilesv, blen);
- const char * const lstart = SvPV_const(x, llen);
- if (llen < blen) {
- bstart += blen - llen;
- if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
- sv_setpvn(x, ipath, ipathend - ipath);
- SvSETMAGIC(x);
- }
- }
- }
- }
- else {
- /* Anything to do if no copfilesv? */
- }
- TAINT_NOT; /* $^X is always tainted, but that's OK */
- }
-#endif /* ARG_ZERO_IS_SCRIPT */
+static int
+yyl_snail(pTHX_ char *s)
+{
+ if (PL_expect == XPOSTDEREF)
+ POSTDEREF('@');
+ PL_tokenbuf[0] = '@';
+ s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
+ if (PL_expect == XOPERATOR) {
+ char *d = s;
+ if (PL_bufptr > s) {
+ d = PL_bufptr-1;
+ PL_bufptr = PL_oldbufptr;
+ }
+ no_op("Array", d);
+ }
+ pl_yylval.ival = 0;
+ if (!PL_tokenbuf[1]) {
+ PREREF('@');
+ }
+ if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
+ s = skipspace(s);
+ if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
+ && intuit_more(s, PL_bufend))
+ {
+ if (*s == '{')
+ PL_tokenbuf[0] = '%';
- /*
- * Look for options.
- */
- d = instr(s,"perl -");
- if (!d) {
- d = instr(s,"perl");
-#if defined(DOSISH)
- /* avoid getting into infinite loops when shebang
- * line contains "Perl" rather than "perl" */
- if (!d) {
- for (d = ipathend-4; d >= ipath; --d) {
- if (isALPHA_FOLD_EQ(*d, 'p')
- && !ibcmp(d, "perl", 4))
- {
- break;
- }
- }
- if (d < ipath)
- d = NULL;
- }
-#endif
- }
-#ifdef ALTERNATE_SHEBANG
- /*
- * If the ALTERNATE_SHEBANG on this system starts with a
- * character that can be part of a Perl expression, then if
- * we see it but not "perl", we're probably looking at the
- * start of Perl code, not a request to hand off to some
- * other interpreter. Similarly, if "perl" is there, but
- * not in the first 'word' of the line, we assume the line
- * contains the start of the Perl program.
- */
- if (d && *s != '#') {
- const char *c = ipath;
- while (*c && !strchr("; \t\r\n\f\v#", *c))
- c++;
- if (c < d)
- d = NULL; /* "perl" not in first word; ignore */
- else
- *s = '#'; /* Don't try to parse shebang line */
- }
-#endif /* ALTERNATE_SHEBANG */
- if (!d
- && *s == '#'
- && ipathend > ipath
- && !PL_minus_c
- && !instr(s,"indir")
- && instr(PL_origargv[0],"perl"))
- {
- dVAR;
- char **newargv;
+ /* Warn about @ where they meant $. */
+ if (*s == '[' || *s == '{') {
+ if (ckWARN(WARN_SYNTAX)) {
+ S_check_scalar_slice(aTHX_ s);
+ }
+ }
+ }
+ PL_expect = XOPERATOR;
+ force_ident_maybe_lex('@');
+ TERM('@');
+}
- *ipathend = '\0';
- s = ipathend + 1;
- while (s < PL_bufend && isSPACE(*s))
- s++;
- if (s < PL_bufend) {
- Newx(newargv,PL_origargc+3,char*);
- newargv[1] = s;
- while (s < PL_bufend && !isSPACE(*s))
- s++;
- *s = '\0';
- Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
- }
- else
- newargv = PL_origargv;
- newargv[0] = ipath;
- PERL_FPU_PRE_EXEC
- PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
- PERL_FPU_POST_EXEC
- Perl_croak(aTHX_ "Can't exec %s", ipath);
- }
- if (d) {
- while (*d && !isSPACE(*d))
- d++;
- while (SPACE_OR_TAB(*d))
- d++;
-
- if (*d++ == '-') {
- const bool switches_done = PL_doswitches;
- const U32 oldpdb = PL_perldb;
- const bool oldn = PL_minus_n;
- const bool oldp = PL_minus_p;
- const char *d1 = d;
-
- do {
- bool baduni = FALSE;
- if (*d1 == 'C') {
- const char *d2 = d1 + 1;
- if (parse_unicode_opts((const char **)&d2)
- != PL_unicode)
- baduni = TRUE;
- }
- if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
- const char * const m = d1;
- while (*d1 && !isSPACE(*d1))
- d1++;
- Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
- (int)(d1 - m), m);
- }
- d1 = moreswitches(d1);
- } while (d1);
- if (PL_doswitches && !switches_done) {
- int argc = PL_origargc;
- char **argv = PL_origargv;
- do {
- argc--,argv++;
- } while (argc && argv[0][0] == '-' && argv[0][1]);
- init_argv_symbols(argc,argv);
- }
- if ( (PERLDB_LINE_OR_SAVESRC && !oldpdb)
- || ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
- /* if we have already added "LINE: while (<>) {",
- we must not do it again */
- {
- SvPVCLEAR(PL_linestr);
- PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_last_lop = PL_last_uni = NULL;
- PL_preambled = FALSE;
- if (PERLDB_LINE_OR_SAVESRC)
- (void)gv_fetchfile(PL_origfilename);
- goto retry;
- }
- }
- }
- }
- }
- if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
- PL_lex_state = LEX_FORMLINE;
- force_next(FORMRBRACK);
- TOKEN(';');
- }
- goto retry;
- case '\r':
-#ifdef PERL_STRICT_CR
- Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
- Perl_croak(aTHX_
- "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
-#endif
- case ' ': case '\t': case '\f': case '\v':
- s++;
- goto retry;
- case '#':
- case '\n':
- if (PL_lex_state != LEX_NORMAL
- || (PL_in_eval && !PL_rsfp && !PL_parser->filtered))
+static int
+yyl_slash(pTHX_ char *s)
+{
+ if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >=
+ (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
+ TOKEN(0);
+ s += 2;
+ AOPERATOR(DORDOR);
+ }
+ else if (PL_expect == XOPERATOR) {
+ s++;
+ if (*s == '=' && !PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
{
- const bool in_comment = *s == '#';
- if (*s == '#' && s == PL_linestart && PL_in_eval
- && !PL_rsfp && !PL_parser->filtered) {
- /* handle eval qq[#line 1 "foo"\n ...] */
- CopLINE_dec(PL_curcop);
- incline(s, PL_bufend);
- }
- d = s;
- while (d < PL_bufend && *d != '\n')
- d++;
- if (d < PL_bufend)
- d++;
- s = d;
- if (in_comment && d == PL_bufend
- && PL_lex_state == LEX_INTERPNORMAL
- && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
- && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
- else
- incline(s, PL_bufend);
- if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
- PL_lex_state = LEX_FORMLINE;
- force_next(FORMRBRACK);
- TOKEN(';');
- }
- }
- else {
- while (s < PL_bufend && *s != '\n')
- s++;
- if (s < PL_bufend)
- {
- s++;
- if (s < PL_bufend)
- incline(s, PL_bufend);
- }
- }
- goto retry;
- case '-':
- return yyl_hyphen(aTHX_ s);
+ s--;
+ TOKEN(0);
+ }
+ Mop(OP_DIVIDE);
+ }
+ else {
+ /* Disable warning on "study /blah/" */
+ if ( PL_oldoldbufptr == PL_last_uni
+ && ( *PL_last_uni != 's' || s - PL_last_uni < 5
+ || memNE(PL_last_uni, "study", 5)
+ || isWORDCHAR_lazy_if_safe(PL_last_uni+5, PL_bufend, UTF)
+ ))
+ check_uni();
+ s = scan_pat(s,OP_MATCH);
+ TERM(sublex_start());
+ }
+}
- case '+':
- return yyl_plus(aTHX_ s);
+static int
+yyl_leftsquare(pTHX_ char *s)
+{
+ char tmp;
- case '*':
- return yyl_star(aTHX_ s);
+ 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);
+}
- case '%':
- return yyl_percent(aTHX_ s);
+static int
+yyl_rightsquare(pTHX_ char *s)
+{
+ if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
+ TOKEN(0);
+ s++;
+ if (PL_lex_brackets <= 0)
+ /* diag_listed_as: Unmatched right %s bracket */
+ yyerror("Unmatched right square bracket");
+ else
+ --PL_lex_brackets;
+ PL_lex_allbrackets--;
+ if (PL_lex_state == LEX_INTERPNORMAL) {
+ if (PL_lex_brackets == 0) {
+ if (*s == '-' && s[1] == '>')
+ PL_lex_state = LEX_INTERPENDMAYBE;
+ else if (*s != '[' && *s != '{')
+ PL_lex_state = LEX_INTERPEND;
+ }
+ }
+ TERM(']');
+}
- case '^':
- d = s;
- bof = FEATURE_BITWISE_IS_ENABLED;
- if (bof && s[1] == '.')
- s++;
- if (!PL_lex_allbrackets && PL_lex_fakeeof >=
- (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
- {
- s = d;
- TOKEN(0);
- }
- s++;
- BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
- case '[':
- if (PL_lex_brackets > 100)
- Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
- PL_lex_brackstack[PL_lex_brackets++] = 0;
- PL_lex_allbrackets++;
- {
- const char tmp = *s++;
- OPERATOR(tmp);
- }
- case '~':
- if (s[1] == '~'
- && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
- {
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- TOKEN(0);
- s += 2;
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
- "Smartmatch is experimental");
- Eop(OP_SMARTMATCH);
- }
- s++;
- if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
- s++;
- BCop(OP_SCOMPLEMENT);
- }
- BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
- case ',':
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
- TOKEN(0);
- s++;
- OPERATOR(',');
- case ':':
- if (s[1] == ':') {
- len = 0;
- goto just_a_word_zero_gv;
- }
- s++;
+static int
+yyl_tilde(pTHX_ char *s)
+{
+ bool bof;
+ if (s[1] == '~' && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)) {
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ TOKEN(0);
+ s += 2;
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
+ "Smartmatch is experimental");
+ NCEop(OP_SMARTMATCH);
+ }
+ s++;
+ if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
+ s++;
+ BCop(OP_SCOMPLEMENT);
+ }
+ BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
+}
+
+static int
+yyl_leftparen(pTHX_ char *s)
+{
+ if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
+ PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
+ else
+ PL_expect = XTERM;
+ s = skipspace(s);
+ PL_lex_allbrackets++;
+ TOKEN('(');
+}
+
+static int
+yyl_rightparen(pTHX_ char *s)
+{
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
+ TOKEN(0);
+ s++;
+ PL_lex_allbrackets--;
+ s = skipspace(s);
+ if (*s == '{')
+ PREBLOCK(')');
+ TERM(')');
+}
+
+static int
+yyl_leftpointy(pTHX_ char *s)
+{
+ char tmp;
+
+ if (PL_expect != XOPERATOR) {
+ if (s[1] != '<' && !memchr(s,'>', PL_bufend - s))
+ check_uni();
+ if (s[1] == '<' && s[2] != '>')
+ s = scan_heredoc(s);
+ else
+ s = scan_inputsymbol(s);
+ PL_expect = XOPERATOR;
+ TOKEN(sublex_start());
+ }
+
+ s++;
+
+ tmp = *s++;
+ if (tmp == '<') {
+ if (*s == '=' && !PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s -= 2;
+ TOKEN(0);
+ }
+ SHop(OP_LEFT_SHIFT);
+ }
+ if (tmp == '=') {
+ tmp = *s++;
+ if (tmp == '>') {
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s -= 3;
+ TOKEN(0);
+ }
+ NCEop(OP_NCMP);
+ }
+ s--;
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s -= 2;
+ TOKEN(0);
+ }
+ ChRop(OP_LE);
+ }
+
+ s--;
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s--;
+ TOKEN(0);
+ }
+
+ ChRop(OP_LT);
+}
+
+static int
+yyl_rightpointy(pTHX_ char *s)
+{
+ const char tmp = *s++;
+
+ if (tmp == '>') {
+ if (*s == '=' && !PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s -= 2;
+ TOKEN(0);
+ }
+ SHop(OP_RIGHT_SHIFT);
+ }
+ else if (tmp == '=') {
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s -= 2;
+ TOKEN(0);
+ }
+ ChRop(OP_GE);
+ }
+
+ s--;
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
+ s--;
+ TOKEN(0);
+ }
+
+ ChRop(OP_GT);
+}
+
+static int
+yyl_sglquote(pTHX_ char *s)
+{
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
+ if (!s)
+ missingterm(NULL, 0);
+ COPLINE_SET_FROM_MULTI_END;
+ DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
+ if (PL_expect == XOPERATOR) {
+ no_op("String",s);
+ }
+ pl_yylval.ival = OP_CONST;
+ TERM(sublex_start());
+}
+
+static int
+yyl_dblquote(pTHX_ char *s)
+{
+ char *d;
+ STRLEN len;
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
+ DEBUG_T( {
+ if (s)
+ printbuf("### Saw string before %s\n", s);
+ else
+ PerlIO_printf(Perl_debug_log,
+ "### Saw unterminated string\n");
+ } );
+ if (PL_expect == XOPERATOR) {
+ no_op("String",s);
+ }
+ if (!s)
+ missingterm(NULL, 0);
+ pl_yylval.ival = OP_CONST;
+ /* FIXME. I think that this can be const if char *d is replaced by
+ more localised variables. */
+ for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
+ if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
+ pl_yylval.ival = OP_STRINGIFY;
+ break;
+ }
+ }
+ if (pl_yylval.ival == OP_CONST)
+ COPLINE_SET_FROM_MULTI_END;
+ TERM(sublex_start());
+}
+
+static int
+yyl_backtick(pTHX_ char *s)
+{
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
+ DEBUG_T( {
+ if (s)
+ printbuf("### Saw backtick string before %s\n", s);
+ else
+ PerlIO_printf(Perl_debug_log,
+ "### Saw unterminated backtick string\n");
+ } );
+ if (PL_expect == XOPERATOR)
+ no_op("Backticks",s);
+ if (!s)
+ missingterm(NULL, 0);
+ pl_yylval.ival = OP_BACKTICK;
+ TERM(sublex_start());
+}
+
+static int
+yyl_backslash(pTHX_ char *s)
+{
+ if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr && isDIGIT(*s))
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
+ *s, *s);
+ if (PL_expect == XOPERATOR)
+ no_op("Backslash",s);
+ OPERATOR(REFGEN);
+}
+
+static void
+yyl_data_handle(pTHX)
+{
+ HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
+ ? PL_curstash
+ : PL_defstash;
+ GV *gv = (GV *)*hv_fetchs(stash, "DATA", 1);
+
+ if (!isGV(gv))
+ gv_init(gv,stash,"DATA",4,0);
+
+ GvMULTI_on(gv);
+ if (!GvIO(gv))
+ GvIOp(gv) = newIO();
+ IoIFP(GvIOp(gv)) = PL_rsfp;
+
+ /* Mark this internal pseudo-handle as clean */
+ IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
+ if ((PerlIO*)PL_rsfp == PerlIO_stdin())
+ IoTYPE(GvIOp(gv)) = IoTYPE_STD;
+ else
+ IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
+
+#if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
+ /* if the script was opened in binmode, we need to revert
+ * it to text mode for compatibility; but only iff it has CRs
+ * XXX this is a questionable hack at best. */
+ if (PL_bufend-PL_bufptr > 2
+ && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
+ {
+ Off_t loc = 0;
+ if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
+ loc = PerlIO_tell(PL_rsfp);
+ (void)PerlIO_seek(PL_rsfp, 0L, 0);
+ }
+ if (PerlLIO_setmode(RSFP_FILENO, O_TEXT) != -1) {
+ if (loc > 0)
+ PerlIO_seek(PL_rsfp, loc, 0);
+ }
+ }
+#endif
+
+#ifdef PERLIO_LAYERS
+ if (!IN_BYTES) {
+ if (UTF)
+ PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
+ }
+#endif
+
+ PL_rsfp = NULL;
+}
+
+PERL_STATIC_NO_RET void yyl_croak_unrecognised(pTHX_ char*)
+ __attribute__noreturn__;
+
+PERL_STATIC_NO_RET void
+yyl_croak_unrecognised(pTHX_ char *s)
+{
+ SV *dsv = newSVpvs_flags("", SVs_TEMP);
+ const char *c;
+ char *d;
+ STRLEN len;
+
+ if (UTF) {
+ STRLEN skiplen = UTF8SKIP(s);
+ STRLEN stravail = PL_bufend - s;
+ c = sv_uni_display(dsv, newSVpvn_flags(s,
+ skiplen > stravail ? stravail : skiplen,
+ SVs_TEMP | SVf_UTF8),
+ 10, UNI_DISPLAY_ISPRINT);
+ }
+ else {
+ c = Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
+ }
+
+ if (s >= PL_linestart) {
+ d = PL_linestart;
+ }
+ else {
+ /* somehow (probably due to a parse failure), PL_linestart has advanced
+ * pass PL_bufptr, get a reasonable beginning of line
+ */
+ d = s;
+ while (d > SvPVX(PL_linestr) && d[-1] && d[-1] != '\n')
+ --d;
+ }
+ len = UTF ? Perl_utf8_length(aTHX_ (U8 *) d, (U8 *) s) : (STRLEN) (s - d);
+ if (len > UNRECOGNIZED_PRECEDE_COUNT) {
+ d = UTF ? (char *) utf8_hop_back((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT, (U8 *)d) : s - UNRECOGNIZED_PRECEDE_COUNT;
+ }
+
+ Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %" UTF8f "<-- HERE near column %d", c,
+ UTF8fARG(UTF, (s - d), d),
+ (int) len + 1);
+}
+
+static int
+yyl_require(pTHX_ char *s, I32 orig_keyword)
+{
+ s = skipspace(s);
+ if (isDIGIT(*s)) {
+ s = force_version(s, FALSE);
+ }
+ else if (*s != 'v' || !isDIGIT(s[1])
+ || (s = force_version(s, TRUE), *s == 'v'))
+ {
+ *PL_tokenbuf = '\0';
+ s = force_word(s,BAREWORD,TRUE,TRUE);
+ if (isIDFIRST_lazy_if_safe(PL_tokenbuf,
+ PL_tokenbuf + sizeof(PL_tokenbuf),
+ UTF))
{
- OP *attrs;
+ gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
+ GV_ADD | (UTF ? SVf_UTF8 : 0));
+ }
+ else if (*s == '<')
+ yyerror("<> at require-statement should be quotes");
+ }
- switch (PL_expect) {
- case XOPERATOR:
- if (!PL_in_my || (PL_lex_state != LEX_NORMAL && !PL_lex_brackets))
- break;
- PL_bufptr = s; /* update in case we back off */
- if (*s == '=') {
- Perl_croak(aTHX_
- "Use of := for an empty attribute list is not allowed");
- }
- goto grabattrs;
- case XATTRBLOCK:
- PL_expect = XBLOCK;
- goto grabattrs;
- case XATTRTERM:
- PL_expect = XTERMBLOCK;
- grabattrs:
- /* NB: as well as parsing normal attributes, we also end up
- * here if there is something looking like attributes
- * following a signature (which is illegal, but used to be
- * legal in 5.20..5.26). If the latter, we still parse the
- * attributes so that error messages(s) are less confusing,
- * but ignore them (parser->sig_seen).
- */
- s = skipspace(s);
- attrs = NULL;
- while (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
- bool sig = PL_parser->sig_seen;
- I32 tmp;
- SV *sv;
- d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
- if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
- if (tmp < 0) tmp = -tmp;
- switch (tmp) {
- case KEY_or:
- case KEY_and:
- case KEY_for:
- case KEY_foreach:
- case KEY_unless:
- case KEY_if:
- case KEY_while:
- case KEY_until:
- goto got_attrs;
- default:
- break;
- }
- }
- sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
- if (*d == '(') {
- d = scan_str(d,TRUE,TRUE,FALSE,NULL);
- if (!d) {
- if (attrs)
- op_free(attrs);
- sv_free(sv);
- Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
- }
- COPLINE_SET_FROM_MULTI_END;
- }
- if (PL_lex_stuff) {
- sv_catsv(sv, PL_lex_stuff);
- attrs = op_append_elem(OP_LIST, attrs,
- newSVOP(OP_CONST, 0, sv));
- SvREFCNT_dec_NN(PL_lex_stuff);
- PL_lex_stuff = NULL;
- }
- else {
- /* NOTE: any CV attrs applied here need to be part of
- the CVf_BUILTIN_ATTRS define in cv.h! */
- if (!PL_in_my && memEQs(SvPVX(sv), len, "lvalue")) {
- sv_free(sv);
- if (!sig)
- CvLVALUE_on(PL_compcv);
- }
- else if (!PL_in_my && memEQs(SvPVX(sv), len, "method")) {
- sv_free(sv);
- if (!sig)
- CvMETHOD_on(PL_compcv);
- }
- else if (!PL_in_my && memEQs(SvPVX(sv), len, "const"))
- {
- sv_free(sv);
- if (!sig) {
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
- ":const is experimental"
- );
- CvANONCONST_on(PL_compcv);
- if (!CvANON(PL_compcv))
- yyerror(":const is not permitted on named "
- "subroutines");
+ if (orig_keyword == KEY_require)
+ pl_yylval.ival = 1;
+ else
+ pl_yylval.ival = 0;
+
+ PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
+ PL_bufptr = s;
+ PL_last_uni = PL_oldbufptr;
+ PL_last_lop_op = OP_REQUIRE;
+ s = skipspace(s);
+ return REPORT( (int)REQUIRE );
+}
+
+static int
+yyl_foreach(pTHX_ char *s)
+{
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ return REPORT(0);
+ pl_yylval.ival = CopLINE(PL_curcop);
+ s = skipspace(s);
+ if (PL_expect == XSTATE && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
+ char *p = s;
+ SSize_t s_off = s - SvPVX(PL_linestr);
+ STRLEN len;
+
+ if (memBEGINPs(p, (STRLEN) (PL_bufend - p), "my") && isSPACE(p[2])) {
+ p += 2;
+ }
+ else if (memBEGINPs(p, (STRLEN) (PL_bufend - p), "our") && isSPACE(p[3])) {
+ p += 3;
+ }
+
+ p = skipspace(p);
+ /* skip optional package name, as in "for my abc $x (..)" */
+ if (isIDFIRST_lazy_if_safe(p, PL_bufend, UTF)) {
+ p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
+ p = skipspace(p);
+ }
+ if (*p != '$' && *p != '\\')
+ Perl_croak(aTHX_ "Missing $ on loop variable");
+
+ /* The buffer may have been reallocated, update s */
+ s = SvPVX(PL_linestr) + s_off;
+ }
+ OPERATOR(FOR);
+}
+
+static int
+yyl_do(pTHX_ char *s, I32 orig_keyword)
+{
+ s = skipspace(s);
+ if (*s == '{')
+ PRETERMBLOCK(DO);
+ if (*s != '\'') {
+ char *d;
+ STRLEN len;
+ *PL_tokenbuf = '&';
+ d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
+ 1, &len);
+ if (len && memNEs(PL_tokenbuf+1, len, "CORE")
+ && !keyword(PL_tokenbuf + 1, len, 0)) {
+ SSize_t off = s-SvPVX(PL_linestr);
+ d = skipspace(d);
+ s = SvPVX(PL_linestr)+off;
+ if (*d == '(') {
+ force_ident_maybe_lex('&');
+ s = d;
+ }
+ }
+ }
+ if (orig_keyword == KEY_do)
+ pl_yylval.ival = 1;
+ else
+ pl_yylval.ival = 0;
+ OPERATOR(DO);
+}
+
+static int
+yyl_my(pTHX_ char *s, I32 my)
+{
+ if (PL_in_my) {
+ PL_bufptr = s;
+ yyerror(Perl_form(aTHX_
+ "Can't redeclare \"%s\" in \"%s\"",
+ my == KEY_my ? "my" :
+ my == KEY_state ? "state" : "our",
+ PL_in_my == KEY_my ? "my" :
+ PL_in_my == KEY_state ? "state" : "our"));
+ }
+ PL_in_my = (U16)my;
+ s = skipspace(s);
+ if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
+ STRLEN len;
+ s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
+ if (memEQs(PL_tokenbuf, len, "sub"))
+ return yyl_sub(aTHX_ s, my);
+ PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
+ if (!PL_in_my_stash) {
+ char tmpbuf[1024];
+ int i;
+ PL_bufptr = s;
+ i = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
+ PERL_MY_SNPRINTF_POST_GUARD(i, sizeof(tmpbuf));
+ yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
+ }
+ }
+ else if (*s == '\\') {
+ if (!FEATURE_MYREF_IS_ENABLED)
+ Perl_croak(aTHX_ "The experimental declared_refs "
+ "feature is not enabled");
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
+ "Declaring references is experimental");
+ }
+ OPERATOR(MY);
+}
+
+static int yyl_try(pTHX_ char*);
+
+static bool
+yyl_eol_needs_semicolon(pTHX_ char **ps)
+{
+ char *s = *ps;
+ if (PL_lex_state != LEX_NORMAL
+ || (PL_in_eval && !PL_rsfp && !PL_parser->filtered))
+ {
+ const bool in_comment = *s == '#';
+ char *d;
+ if (*s == '#' && s == PL_linestart && PL_in_eval
+ && !PL_rsfp && !PL_parser->filtered) {
+ /* handle eval qq[#line 1 "foo"\n ...] */
+ CopLINE_dec(PL_curcop);
+ incline(s, PL_bufend);
+ }
+ d = s;
+ while (d < PL_bufend && *d != '\n')
+ d++;
+ if (d < PL_bufend)
+ d++;
+ s = d;
+ if (in_comment && d == PL_bufend
+ && PL_lex_state == LEX_INTERPNORMAL
+ && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
+ && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
+ else
+ incline(s, PL_bufend);
+ if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
+ PL_lex_state = LEX_FORMLINE;
+ force_next(FORMRBRACK);
+ *ps = s;
+ return TRUE;
+ }
+ }
+ else {
+ while (s < PL_bufend && *s != '\n')
+ s++;
+ if (s < PL_bufend) {
+ s++;
+ if (s < PL_bufend)
+ incline(s, PL_bufend);
+ }
+ }
+ *ps = s;
+ return FALSE;
+}
+
+static int
+yyl_fake_eof(pTHX_ U32 fake_eof, bool bof, char *s)
+{
+ char *d;
+
+ goto start;
+
+ do {
+ fake_eof = 0;
+ bof = cBOOL(PL_rsfp);
+ start:
+
+ PL_bufptr = PL_bufend;
+ COPLINE_INC_WITH_HERELINES;
+ if (!lex_next_chunk(fake_eof)) {
+ CopLINE_dec(PL_curcop);
+ s = PL_bufptr;
+ TOKEN(';'); /* not infinite loop because rsfp is NULL now */
+ }
+ CopLINE_dec(PL_curcop);
+ s = PL_bufptr;
+ /* If it looks like the start of a BOM or raw UTF-16,
+ * check if it in fact is. */
+ if (bof && PL_rsfp
+ && ( *s == 0
+ || *(U8*)s == BOM_UTF8_FIRST_BYTE
+ || *(U8*)s >= 0xFE
+ || s[1] == 0))
+ {
+ Off_t offset = (IV)PerlIO_tell(PL_rsfp);
+ bof = (offset == (Off_t)SvCUR(PL_linestr));
+#if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
+ /* offset may include swallowed CR */
+ if (!bof)
+ bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
+#endif
+ if (bof) {
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ s = swallow_bom((U8*)s);
+ }
+ }
+ if (PL_parser->in_pod) {
+ /* Incest with pod. */
+ if ( memBEGINPs(s, (STRLEN) (PL_bufend - s), "=cut")
+ && !isALPHA(s[4]))
+ {
+ SvPVCLEAR(PL_linestr);
+ PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = NULL;
+ PL_parser->in_pod = 0;
+ }
+ }
+ if (PL_rsfp || PL_parser->filtered)
+ incline(s, PL_bufend);
+ } while (PL_parser->in_pod);
+
+ PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = NULL;
+ if (CopLINE(PL_curcop) == 1) {
+ while (s < PL_bufend && isSPACE(*s))
+ s++;
+ if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
+ s++;
+ d = NULL;
+ if (!PL_in_eval) {
+ if (*s == '#' && *(s+1) == '!')
+ d = s + 2;
+#ifdef ALTERNATE_SHEBANG
+ else {
+ static char const as[] = ALTERNATE_SHEBANG;
+ if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
+ d = s + (sizeof(as) - 1);
+ }
+#endif /* ALTERNATE_SHEBANG */
+ }
+ if (d) {
+ char *ipath;
+ char *ipathend;
+
+ while (isSPACE(*d))
+ d++;
+ ipath = d;
+ while (*d && !isSPACE(*d))
+ d++;
+ ipathend = d;
+
+#ifdef ARG_ZERO_IS_SCRIPT
+ if (ipathend > ipath) {
+ /*
+ * HP-UX (at least) sets argv[0] to the script name,
+ * which makes $^X incorrect. And Digital UNIX and Linux,
+ * at least, set argv[0] to the basename of the Perl
+ * interpreter. So, having found "#!", we'll set it right.
+ */
+ SV* copfilesv = CopFILESV(PL_curcop);
+ if (copfilesv) {
+ SV * const x =
+ GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
+ SVt_PV)); /* $^X */
+ assert(SvPOK(x) || SvGMAGICAL(x));
+ if (sv_eq(x, copfilesv)) {
+ sv_setpvn(x, ipath, ipathend - ipath);
+ SvSETMAGIC(x);
+ }
+ else {
+ STRLEN blen;
+ STRLEN llen;
+ const char *bstart = SvPV_const(copfilesv, blen);
+ const char * const lstart = SvPV_const(x, llen);
+ if (llen < blen) {
+ bstart += blen - llen;
+ if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
+ sv_setpvn(x, ipath, ipathend - ipath);
+ SvSETMAGIC(x);
+ }
}
- }
- /* After we've set the flags, it could be argued that
- we don't need to do the attributes.pm-based setting
- process, and shouldn't bother appending recognized
- flags. To experiment with that, uncomment the
- following "else". (Note that's already been
- uncommented. That keeps the above-applied built-in
- attributes from being intercepted (and possibly
- rejected) by a package's attribute routines, but is
- justified by the performance win for the common case
- of applying only built-in attributes.) */
- else
- attrs = op_append_elem(OP_LIST, attrs,
- newSVOP(OP_CONST, 0,
- sv));
- }
- s = skipspace(d);
- if (*s == ':' && s[1] != ':')
- s = skipspace(s+1);
- else if (s == d)
- break; /* require real whitespace or :'s */
- /* XXX losing whitespace on sequential attributes here */
- }
- {
- if (*s != ';'
- && *s != '}'
- && !(PL_expect == XOPERATOR
- ? (*s == '=' || *s == ')')
- : (*s == '{' || *s == '(')))
- {
- const char q = ((*s == '\'') ? '"' : '\'');
- /* If here for an expression, and parsed no attrs, back
- off. */
- if (PL_expect == XOPERATOR && !attrs) {
- s = PL_bufptr;
- break;
- }
- /* MUST advance bufptr here to avoid bogus "at end of line"
- context messages from yyerror().
- */
- PL_bufptr = s;
- yyerror( (const char *)
- (*s
- ? Perl_form(aTHX_ "Invalid separator character "
- "%c%c%c in attribute list", q, *s, q)
- : "Unterminated attribute list" ) );
- if (attrs)
- op_free(attrs);
- OPERATOR(':');
- }
- }
- got_attrs:
- if (PL_parser->sig_seen) {
- /* see comment about about sig_seen and parser error
- * handling */
- if (attrs)
- op_free(attrs);
- Perl_croak(aTHX_ "Subroutine attributes must come "
- "before the signature");
+ }
}
- if (attrs) {
- NEXTVAL_NEXTTOKE.opval = attrs;
- force_next(THING);
- }
- TOKEN(COLONATTR);
- }
- }
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
- s--;
- TOKEN(0);
- }
- PL_lex_allbrackets--;
- OPERATOR(':');
- case '(':
- s++;
- if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
- PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
- else
- PL_expect = XTERM;
- s = skipspace(s);
- PL_lex_allbrackets++;
- TOKEN('(');
- case ';':
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
- TOKEN(0);
- CLINE;
- s++;
- PL_expect = XSTATE;
- TOKEN(';');
- case ')':
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
- TOKEN(0);
- s++;
- PL_lex_allbrackets--;
- s = skipspace(s);
- if (*s == '{')
- PREBLOCK(')');
- TERM(')');
- case ']':
- if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
- TOKEN(0);
- s++;
- if (PL_lex_brackets <= 0)
- /* diag_listed_as: Unmatched right %s bracket */
- yyerror("Unmatched right square bracket");
- else
- --PL_lex_brackets;
- PL_lex_allbrackets--;
- if (PL_lex_state == LEX_INTERPNORMAL) {
- if (PL_lex_brackets == 0) {
- if (*s == '-' && s[1] == '>')
- PL_lex_state = LEX_INTERPENDMAYBE;
- else if (*s != '[' && *s != '{')
- PL_lex_state = LEX_INTERPEND;
- }
- }
- TERM(']');
- case '{':
- s++;
- leftbracket:
- if (PL_lex_brackets > 100) {
- Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
- }
- switch (PL_expect) {
- case XTERM:
- case XTERMORDORDOR:
- PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
- PL_lex_allbrackets++;
- OPERATOR(HASHBRACK);
- case XOPERATOR:
- while (s < PL_bufend && SPACE_OR_TAB(*s))
- s++;
- d = s;
- PL_tokenbuf[0] = '\0';
- if (d < PL_bufend && *d == '-') {
- PL_tokenbuf[0] = '-';
- d++;
- while (d < PL_bufend && SPACE_OR_TAB(*d))
- d++;
- }
- if (d < PL_bufend && isIDFIRST_lazy_if_safe(d, PL_bufend, UTF)) {
- d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
- FALSE, &len);
- while (d < PL_bufend && SPACE_OR_TAB(*d))
- d++;
- if (*d == '}') {
- const char minus = (PL_tokenbuf[0] == '-');
- s = force_word(s + minus, BAREWORD, FALSE, TRUE);
- if (minus)
- force_next('-');
- }
- }
- /* FALLTHROUGH */
- case XATTRTERM:
- case XTERMBLOCK:
- PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
- PL_lex_allbrackets++;
- PL_expect = XSTATE;
- break;
- case XATTRBLOCK:
- case XBLOCK:
- PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
- PL_lex_allbrackets++;
- PL_expect = XSTATE;
- break;
- case XBLOCKTERM:
- PL_lex_brackstack[PL_lex_brackets++] = XTERM;
- PL_lex_allbrackets++;
- PL_expect = XSTATE;
- break;
- default: {
- const char *t;
- if (PL_oldoldbufptr == PL_last_lop)
- PL_lex_brackstack[PL_lex_brackets++] = XTERM;
- else
- PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
- PL_lex_allbrackets++;
- s = skipspace(s);
- if (*s == '}') {
- if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
- PL_expect = XTERM;
- /* This hack is to get the ${} in the message. */
- PL_bufptr = s+1;
- yyerror("syntax error");
- break;
- }
- OPERATOR(HASHBRACK);
- }
- if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
- /* ${...} or @{...} etc., but not print {...}
- * Skip the disambiguation and treat this as a block.
- */
- goto block_expectation;
- }
- /* This hack serves to disambiguate a pair of curlies
- * as being a block or an anon hash. Normally, expectation
- * determines that, but in cases where we're not in a
- * position to expect anything in particular (like inside
- * eval"") we have to resolve the ambiguity. This code
- * covers the case where the first term in the curlies is a
- * quoted string. Most other cases need to be explicitly
- * disambiguated by prepending a "+" before the opening
- * curly in order to force resolution as an anon hash.
- *
- * XXX should probably propagate the outer expectation
- * into eval"" to rely less on this hack, but that could
- * potentially break current behavior of eval"".
- * GSAR 97-07-21
- */
- t = s;
- if (*s == '\'' || *s == '"' || *s == '`') {
- /* common case: get past first string, handling escapes */
- for (t++; t < PL_bufend && *t != *s;)
- if (*t++ == '\\')
- t++;
- t++;
- }
- else if (*s == 'q') {
- if (++t < PL_bufend
- && (!isWORDCHAR(*t)
- || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
- && !isWORDCHAR(*t))))
- {
- /* skip q//-like construct */
- const char *tmps;
- char open, close, term;
- I32 brackets = 1;
-
- while (t < PL_bufend && isSPACE(*t))
- t++;
- /* check for q => */
- if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
- OPERATOR(HASHBRACK);
- }
- term = *t;
- open = term;
- if (term && (tmps = strchr("([{< )]}> )]}>",term)))
- term = tmps[5];
- close = term;
- if (open == close)
- for (t++; t < PL_bufend; t++) {
- if (*t == '\\' && t+1 < PL_bufend && open != '\\')
- t++;
- else if (*t == open)
- break;
- }
- else {
- for (t++; t < PL_bufend; t++) {
- if (*t == '\\' && t+1 < PL_bufend)
- t++;
- else if (*t == close && --brackets <= 0)
- break;
- else if (*t == open)
- brackets++;
- }
- }
- t++;
- }
- else
- /* skip plain q word */
- while ( t < PL_bufend
- && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
+ else {
+ /* Anything to do if no copfilesv? */
+ }
+ TAINT_NOT; /* $^X is always tainted, but that's OK */
+ }
+#endif /* ARG_ZERO_IS_SCRIPT */
+
+ /*
+ * Look for options.
+ */
+ d = instr(s,"perl -");
+ if (!d) {
+ d = instr(s,"perl");
+#if defined(DOSISH)
+ /* avoid getting into infinite loops when shebang
+ * line contains "Perl" rather than "perl" */
+ if (!d) {
+ for (d = ipathend-4; d >= ipath; --d) {
+ if (isALPHA_FOLD_EQ(*d, 'p')
+ && !ibcmp(d, "perl", 4))
{
- t += UTF ? UTF8SKIP(t) : 1;
+ break;
}
- }
- else if (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)) {
- t += UTF ? UTF8SKIP(t) : 1;
- while ( t < PL_bufend
- && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
- {
- t += UTF ? UTF8SKIP(t) : 1;
}
- }
- while (t < PL_bufend && isSPACE(*t))
- t++;
- /* if comma follows first term, call it an anon hash */
- /* XXX it could be a comma expression with loop modifiers */
- if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
- || (*t == '=' && t[1] == '>')))
- OPERATOR(HASHBRACK);
- if (PL_expect == XREF)
- {
- block_expectation:
- /* If there is an opening brace or 'sub:', treat it
- as a term to make ${{...}}{k} and &{sub:attr...}
- dwim. Otherwise, treat it as a statement, so
- map {no strict; ...} works.
- */
- s = skipspace(s);
- if (*s == '{') {
- PL_expect = XTERM;
- break;
- }
- if (memBEGINs(s, (STRLEN) (PL_bufend - s), "sub")) {
- PL_bufptr = s;
- d = s + 3;
- d = skipspace(d);
- s = PL_bufptr;
- if (*d == ':') {
- PL_expect = XTERM;
- break;
- }
- }
- PL_expect = XSTATE;
- }
- else {
- PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
- PL_expect = XSTATE;
- }
- }
- break;
- }
- pl_yylval.ival = CopLINE(PL_curcop);
- PL_copline = NOLINE; /* invalidate current command line number */
- TOKEN(formbrack ? '=' : '{');
- case '}':
- if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
- TOKEN(0);
- rightbracket:
- assert(s != PL_bufend);
- s++;
- if (PL_lex_brackets <= 0)
- /* diag_listed_as: Unmatched right %s bracket */
- yyerror("Unmatched right curly bracket");
- else
- PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
- PL_lex_allbrackets--;
- if (PL_lex_state == LEX_INTERPNORMAL) {
- if (PL_lex_brackets == 0) {
- if (PL_expect & XFAKEBRACK) {
- PL_expect &= XENUMMASK;
- PL_lex_state = LEX_INTERPEND;
- PL_bufptr = s;
- return yylex(); /* ignore fake brackets */
- }
- if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
- && SvEVALED(PL_lex_repl))
- PL_lex_state = LEX_INTERPEND;
- else if (*s == '-' && s[1] == '>')
- PL_lex_state = LEX_INTERPENDMAYBE;
- else if (*s != '[' && *s != '{')
- PL_lex_state = LEX_INTERPEND;
- }
- }
- if (PL_expect & XFAKEBRACK) {
- PL_expect &= XENUMMASK;
- PL_bufptr = s;
- return yylex(); /* ignore fake brackets */
- }
- force_next(formbrack ? '.' : '}');
- if (formbrack) LEAVE_with_name("lex_format");
- if (formbrack == 2) { /* means . where arguments were expected */
- force_next(';');
- TOKEN(FORMRBRACK);
- }
- TOKEN(';');
- case '&':
- if (PL_expect == XPOSTDEREF) POSTDEREF('&');
- s++;
- if (*s++ == '&') {
- if (!PL_lex_allbrackets && PL_lex_fakeeof >=
- (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
- s -= 2;
- TOKEN(0);
- }
- AOPERATOR(ANDAND);
- }
- s--;
- if (PL_expect == XOPERATOR) {
- if ( PL_bufptr == PL_linestart
- && ckWARN(WARN_SEMICOLON)
- && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
- {
- CopLINE_dec(PL_curcop);
- Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
- CopLINE_inc(PL_curcop);
- }
- d = s;
- if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
- s++;
- if (!PL_lex_allbrackets && PL_lex_fakeeof >=
- (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
- s = d;
- s--;
- TOKEN(0);
- }
- if (d == s) {
- PL_parser->saw_infix_sigil = 1;
- BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
- }
- else
- BAop(OP_SBIT_AND);
- }
-
- PL_tokenbuf[0] = '&';
- s = scan_ident(s - 1, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
- pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
- if (PL_tokenbuf[1]) {
- force_ident_maybe_lex('&');
- }
- else
- PREREF('&');
- TERM('&');
-
- case '|':
- s++;
- if (*s++ == '|') {
- if (!PL_lex_allbrackets && PL_lex_fakeeof >=
- (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
- s -= 2;
- TOKEN(0);
- }
- AOPERATOR(OROR);
- }
- s--;
- d = s;
- if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
- s++;
- if (!PL_lex_allbrackets && PL_lex_fakeeof >=
- (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
- s = d - 1;
- TOKEN(0);
- }
- BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
- case '=':
- s++;
- {
- const char tmp = *s++;
- if (tmp == '=') {
- if ( (s == PL_linestart+2 || s[-3] == '\n')
- && memBEGINs(s, (STRLEN) (PL_bufend - s), "====="))
- {
- s = vcs_conflict_marker(s + 5);
- goto retry;
- }
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- {
- s -= 2;
- TOKEN(0);
- }
- Eop(OP_EQ);
- }
- if (tmp == '>') {
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
- {
- s -= 2;
- TOKEN(0);
- }
- OPERATOR(',');
- }
- if (tmp == '~')
- PMop(OP_MATCH);
- if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
- && strchr("+-*/%.^&|<",tmp))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Reversed %c= operator",(int)tmp);
- s--;
- if (PL_expect == XSTATE
- && isALPHA(tmp)
- && (s == PL_linestart+1 || s[-2] == '\n') )
- {
- if ( (PL_in_eval && !PL_rsfp && !PL_parser->filtered)
- || PL_lex_state != LEX_NORMAL)
- {
- 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;
- }
+ if (d < ipath)
+ d = NULL;
+ }
+#endif
+ }
+#ifdef ALTERNATE_SHEBANG
+ /*
+ * If the ALTERNATE_SHEBANG on this system starts with a
+ * character that can be part of a Perl expression, then if
+ * we see it but not "perl", we're probably looking at the
+ * start of Perl code, not a request to hand off to some
+ * other interpreter. Similarly, if "perl" is there, but
+ * not in the first 'word' of the line, we assume the line
+ * contains the start of the Perl program.
+ */
+ if (d && *s != '#') {
+ const char *c = ipath;
+ while (*c && !memCHRs("; \t\r\n\f\v#", *c))
+ c++;
+ if (c < d)
+ d = NULL; /* "perl" not in first word; ignore */
+ else
+ *s = '#'; /* Don't try to parse shebang line */
+ }
+#endif /* ALTERNATE_SHEBANG */
+ if (!d
+ && *s == '#'
+ && ipathend > ipath
+ && !PL_minus_c
+ && !instr(s,"indir")
+ && instr(PL_origargv[0],"perl"))
+ {
+ char **newargv;
+
+ *ipathend = '\0';
+ s = ipathend + 1;
+ while (s < PL_bufend && isSPACE(*s))
+ s++;
+ if (s < PL_bufend) {
+ Newx(newargv,PL_origargc+3,char*);
+ newargv[1] = s;
+ while (s < PL_bufend && !isSPACE(*s))
+ s++;
+ *s = '\0';
+ Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
+ }
+ else
+ newargv = PL_origargv;
+ newargv[0] = ipath;
+ PERL_FPU_PRE_EXEC
+ PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
+ PERL_FPU_POST_EXEC
+ Perl_croak(aTHX_ "Can't exec %s", ipath);
+ }
+ if (d) {
+ while (*d && !isSPACE(*d))
+ d++;
+ while (SPACE_OR_TAB(*d))
+ d++;
+
+ if (*d++ == '-') {
+ const bool switches_done = PL_doswitches;
+ const U32 oldpdb = PL_perldb;
+ const bool oldn = PL_minus_n;
+ const bool oldp = PL_minus_p;
+ const char *d1 = d;
+
+ do {
+ bool baduni = FALSE;
+ if (*d1 == 'C') {
+ const char *d2 = d1 + 1;
+ if (parse_unicode_opts((const char **)&d2)
+ != PL_unicode)
+ baduni = TRUE;
}
+ if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
+ const char * const m = d1;
+ while (*d1 && !isSPACE(*d1))
+ d1++;
+ Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
+ (int)(d1 - m), m);
+ }
+ d1 = moreswitches(d1);
+ } while (d1);
+ if (PL_doswitches && !switches_done) {
+ int argc = PL_origargc;
+ char **argv = PL_origargv;
+ do {
+ argc--,argv++;
+ } while (argc && argv[0][0] == '-' && argv[0][1]);
+ init_argv_symbols(argc,argv);
+ }
+ if ( (PERLDB_LINE_OR_SAVESRC && !oldpdb)
+ || ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
+ /* if we have already added "LINE: while (<>) {",
+ we must not do it again */
+ {
+ SvPVCLEAR(PL_linestr);
+ PL_bufptr = PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_last_lop = PL_last_uni = NULL;
+ PL_preambled = FALSE;
+ if (PERLDB_LINE_OR_SAVESRC)
+ (void)gv_fetchfile(PL_origfilename);
+ return YYL_RETRY;
}
- 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 == '#') {
- formbrack = 1;
- ENTER_with_name("lex_format");
- SAVEI8(PL_parser->form_lex_state);
- SAVEI32(PL_lex_formbrack);
- PL_parser->form_lex_state = PL_lex_state;
- PL_lex_formbrack = PL_lex_brackets + 1;
- PL_parser->sub_error_count = PL_error_count;
- goto leftbracket;
- }
- }
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
- s--;
- TOKEN(0);
- }
- pl_yylval.ival = 0;
- OPERATOR(ASSIGNOP);
- case '!':
- s++;
- {
- const char tmp = *s++;
- if (tmp == '=') {
- /* was this !=~ where !~ was meant?
- * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
+ }
+ }
- if (*s == '~' && ckWARN(WARN_SYNTAX)) {
- const char *t = s+1;
+ if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
+ PL_lex_state = LEX_FORMLINE;
+ force_next(FORMRBRACK);
+ TOKEN(';');
+ }
- while (t < PL_bufend && isSPACE(*t))
- ++t;
+ PL_bufptr = s;
+ return YYL_RETRY;
+}
- if (*t == '/' || *t == '?'
- || ((*t == 'm' || *t == 's' || *t == 'y')
- && !isWORDCHAR(t[1]))
- || (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "!=~ should be !~");
- }
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- {
- s -= 2;
- TOKEN(0);
- }
- Eop(OP_NE);
- }
- if (tmp == '~')
- PMop(OP_NOT);
- }
- s--;
- OPERATOR('!');
- case '<':
- if (PL_expect != XOPERATOR) {
- if (s[1] != '<' && !memchr(s,'>', PL_bufend - s))
- check_uni();
- if (s[1] == '<' && s[2] != '>') {
- if ( (s == PL_linestart || s[-1] == '\n')
- && memBEGINs(s+2, (STRLEN) (PL_bufend - (s+2)), "<<<<<"))
- {
- s = vcs_conflict_marker(s + 7);
- goto retry;
- }
- s = scan_heredoc(s);
- }
- else
- s = scan_inputsymbol(s);
- PL_expect = XOPERATOR;
- TOKEN(sublex_start());
- }
- s++;
- {
- char tmp = *s++;
- if (tmp == '<') {
- if ( (s == PL_linestart+2 || s[-3] == '\n')
- && memBEGINs(s, (STRLEN) (PL_bufend - s), "<<<<<"))
- {
- s = vcs_conflict_marker(s + 5);
- goto retry;
- }
- if (*s == '=' && !PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
- {
- s -= 2;
- TOKEN(0);
- }
- SHop(OP_LEFT_SHIFT);
- }
- if (tmp == '=') {
- tmp = *s++;
- if (tmp == '>') {
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- {
- s -= 3;
- TOKEN(0);
- }
- Eop(OP_NCMP);
- }
- s--;
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- {
- s -= 2;
- TOKEN(0);
- }
- Rop(OP_LE);
- }
- }
- s--;
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
- s--;
- TOKEN(0);
- }
- Rop(OP_LT);
- case '>':
- s++;
- {
- const char tmp = *s++;
- if (tmp == '>') {
- if ( (s == PL_linestart+2 || s[-3] == '\n')
- && memBEGINs(s, (STRLEN) (PL_bufend - s), ">>>>>"))
- {
- s = vcs_conflict_marker(s + 5);
- goto retry;
- }
- if (*s == '=' && !PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
- {
- s -= 2;
- TOKEN(0);
- }
- SHop(OP_RIGHT_SHIFT);
- }
- else if (tmp == '=') {
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- {
- s -= 2;
- TOKEN(0);
- }
- Rop(OP_GE);
- }
- }
- s--;
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
- s--;
- TOKEN(0);
- }
- Rop(OP_GT);
+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_dollar(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 '@':
- if (PL_expect == XPOSTDEREF)
- POSTDEREF('@');
- PL_tokenbuf[0] = '@';
- s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
- if (PL_expect == XOPERATOR) {
- d = s;
- if (PL_bufptr > s) {
- d = PL_bufptr-1;
- PL_bufptr = PL_oldbufptr;
- }
- no_op("Array", d);
+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;
}
- pl_yylval.ival = 0;
- if (!PL_tokenbuf[1]) {
- PREREF('@');
- }
- if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
- s = skipspace(s);
- if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
- && intuit_more(s, PL_bufend))
+ TOKEN(BAREWORD);
+ }
+
+ op_free(pl_yylval.opval);
+ pl_yylval.opval =
+ off ? newCVREF(0, rv2cv_op) : rv2cv_op;
+ pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
+ PL_last_lop = PL_oldbufptr;
+ PL_last_lop_op = OP_ENTERSUB;
+
+ /* Is there a prototype? */
+ if (SvPOK(cv)) {
+ int k = yyl_subproto(aTHX_ s, cv);
+ if (k != KEY_NULL)
+ return k;
+ }
+
+ NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
+ PL_expect = XTERM;
+ force_next(off ? PRIVATEREF : BAREWORD);
+ if (!PL_lex_allbrackets
+ && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
+ {
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
+ }
+
+ TOKEN(NOAMP);
+}
+
+/* Honour "reserved word" warnings, and enforce strict subs */
+static void
+yyl_strictwarn_bareword(pTHX_ const char lastchar)
+{
+ /* after "print" and similar functions (corresponding to
+ * "F? L" in opcode.pl), whatever wasn't already parsed as
+ * a filehandle should be subject to "strict subs".
+ * Likewise for the optional indirect-object argument to system
+ * or exec, which can't be a bareword */
+ if ((PL_last_lop_op == OP_PRINT
+ || PL_last_lop_op == OP_PRTF
+ || PL_last_lop_op == OP_SAY
+ || PL_last_lop_op == OP_SYSTEM
+ || PL_last_lop_op == OP_EXEC)
+ && (PL_hints & HINT_STRICT_SUBS))
+ {
+ pl_yylval.opval->op_private |= OPpCONST_STRICT;
+ }
+
+ if (lastchar != '-' && ckWARN(WARN_RESERVED)) {
+ char *d = PL_tokenbuf;
+ while (isLOWER(*d))
+ d++;
+ if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0)) {
+ /* PL_warn_reserved is constant */
+ GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
+ Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
+ PL_tokenbuf);
+ GCC_DIAG_RESTORE_STMT;
+ }
+ }
+}
+
+static int
+yyl_just_a_word(pTHX_ char *s, STRLEN len, I32 orig_keyword, struct code c)
+{
+ int pkgname = 0;
+ const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
+ bool safebw;
+ bool no_op_error = FALSE;
+ /* Use this var to track whether intuit_method has been
+ called. intuit_method returns 0 or > 255. */
+ int key = 1;
+
+ if (PL_expect == XOPERATOR) {
+ if (PL_bufptr == PL_linestart) {
+ CopLINE_dec(PL_curcop);
+ Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
+ CopLINE_inc(PL_curcop);
+ }
+ else
+ /* We want to call no_op with s pointing after the
+ bareword, so defer it. But we want it to come
+ before the Bad name croak. */
+ no_op_error = TRUE;
+ }
+
+ /* Get the rest if it looks like a package qualifier */
+
+ if (*s == '\'' || (*s == ':' && s[1] == ':')) {
+ STRLEN morelen;
+ s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
+ TRUE, &morelen);
+ if (no_op_error) {
+ no_op("Bareword",s);
+ no_op_error = FALSE;
+ }
+ if (!morelen)
+ Perl_croak(aTHX_ "Bad name after %" UTF8f "%s",
+ UTF8fARG(UTF, len, PL_tokenbuf),
+ *s == '\'' ? "'" : "::");
+ len += morelen;
+ pkgname = 1;
+ }
+
+ if (no_op_error)
+ no_op("Bareword",s);
+
+ /* See if the name is "Foo::",
+ in which case Foo is a bareword
+ (and a package name). */
+
+ if (len > 2 && PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':') {
+ if (ckWARN(WARN_BAREWORD)
+ && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
+ Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
+ "Bareword \"%" UTF8f
+ "\" refers to nonexistent package",
+ UTF8fARG(UTF, len, PL_tokenbuf));
+ len -= 2;
+ PL_tokenbuf[len] = '\0';
+ c.gv = NULL;
+ c.gvp = 0;
+ safebw = TRUE;
+ }
+ else {
+ safebw = FALSE;
+ }
+
+ /* if we saw a global override before, get the right name */
+
+ if (!c.sv)
+ c.sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len);
+ if (c.gvp) {
+ SV *sv = newSVpvs("CORE::GLOBAL::");
+ sv_catsv(sv, c.sv);
+ SvREFCNT_dec(c.sv);
+ c.sv = sv;
+ }
+
+ /* Presume this is going to be a bareword of some sort. */
+ CLINE;
+ pl_yylval.opval = newSVOP(OP_CONST, 0, c.sv);
+ pl_yylval.opval->op_private = OPpCONST_BARE;
+
+ /* And if "Foo::", then that's what it certainly is. */
+ if (safebw)
+ return yyl_safe_bareword(aTHX_ s, lastchar);
+
+ if (!c.off) {
+ OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(c.sv));
+ const_op->op_private = OPpCONST_BARE;
+ c.rv2cv_op = newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
+ c.cv = c.lex
+ ? isGV(c.gv)
+ ? GvCV(c.gv)
+ : SvROK(c.gv) && SvTYPE(SvRV(c.gv)) == SVt_PVCV
+ ? (CV *)SvRV(c.gv)
+ : ((CV *)c.gv)
+ : rv2cv_op_cv(c.rv2cv_op, RV2CVOPCV_RETURN_STUB);
+ }
+
+ /* See if it's the indirect object for a list operator. */
+
+ if (PL_oldoldbufptr
+ && PL_oldoldbufptr < PL_bufptr
+ && (PL_oldoldbufptr == PL_last_lop
+ || PL_oldoldbufptr == PL_last_uni)
+ && /* NO SKIPSPACE BEFORE HERE! */
+ (PL_expect == XREF
+ || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7)
+ == OA_FILEREF))
+ {
+ bool immediate_paren = *s == '(';
+ SSize_t s_off;
+
+ /* (Now we can afford to cross potential line boundary.) */
+ s = skipspace(s);
+
+ /* intuit_method() can indirectly call lex_next_chunk(),
+ * invalidating s
+ */
+ s_off = s - SvPVX(PL_linestr);
+ /* Two barewords in a row may indicate method call. */
+ if ( ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
+ || *s == '$')
+ && (key = intuit_method(s, c.lex ? NULL : c.sv, c.cv)))
+ {
+ /* the code at method: doesn't use s */
+ goto method;
+ }
+ s = SvPVX(PL_linestr) + s_off;
+
+ /* If not a declared subroutine, it's an indirect object. */
+ /* (But it's an indir obj regardless for sort.) */
+ /* Also, if "_" follows a filetest operator, it's a bareword */
+
+ if (
+ ( !immediate_paren && (PL_last_lop_op == OP_SORT
+ || (!c.cv
+ && (PL_last_lop_op != OP_MAPSTART
+ && PL_last_lop_op != OP_GREPSTART))))
+ || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
+ && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK)
+ == OA_FILESTATOP))
+ )
{
- if (*s == '{')
- PL_tokenbuf[0] = '%';
+ 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);
+ }
+ }
- /* Warn about @ where they meant $. */
- if (*s == '[' || *s == '{') {
- if (ckWARN(WARN_SYNTAX)) {
- S_check_scalar_slice(aTHX_ s);
- }
- }
- }
- PL_expect = XOPERATOR;
- force_ident_maybe_lex('@');
- TERM('@');
+ PL_expect = XOPERATOR;
+ s = skipspace(s);
- case '/': /* may be division, defined-or, or pattern */
- if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
- if (!PL_lex_allbrackets && PL_lex_fakeeof >=
- (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
- TOKEN(0);
- s += 2;
- AOPERATOR(DORDOR);
- }
- else if (PL_expect == XOPERATOR) {
- s++;
- if (*s == '=' && !PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
- {
- s--;
- TOKEN(0);
- }
- Mop(OP_DIVIDE);
+ /* Is this a word before a => operator? */
+ if (*s == '=' && s[1] == '>' && !pkgname) {
+ op_free(c.rv2cv_op);
+ CLINE;
+ if (c.gvp || (c.lex && !c.off)) {
+ assert (cSVOPx(pl_yylval.opval)->op_sv == c.sv);
+ /* This is our own scalar, created a few lines
+ above, so this is safe. */
+ SvREADONLY_off(c.sv);
+ sv_setpv(c.sv, PL_tokenbuf);
+ if (UTF && !IN_BYTES
+ && is_utf8_string((U8*)PL_tokenbuf, len))
+ SvUTF8_on(c.sv);
+ SvREADONLY_on(c.sv);
+ }
+ TERM(BAREWORD);
+ }
+
+ /* If followed by a paren, it's certainly a subroutine. */
+ if (*s == '(') {
+ CLINE;
+ if (c.cv) {
+ char *d = s + 1;
+ while (SPACE_OR_TAB(*d))
+ d++;
+ if (*d == ')' && (c.sv = cv_const_sv_or_av(c.cv)))
+ return yyl_constant_op(aTHX_ d + 1, c.sv, c.cv, c.rv2cv_op, c.off);
+ }
+ NEXTVAL_NEXTTOKE.opval =
+ c.off ? c.rv2cv_op : pl_yylval.opval;
+ if (c.off)
+ op_free(pl_yylval.opval), force_next(PRIVATEREF);
+ else op_free(c.rv2cv_op), force_next(BAREWORD);
+ pl_yylval.ival = 0;
+ TOKEN('&');
+ }
+
+ /* If followed by var or block, call it a method (unless sub) */
+
+ if ((*s == '$' || *s == '{') && !c.cv && FEATURE_INDIRECT_IS_ENABLED) {
+ op_free(c.rv2cv_op);
+ PL_last_lop = PL_oldbufptr;
+ PL_last_lop_op = OP_METHOD;
+ if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
+ PL_expect = XBLOCKTERM;
+ PL_bufptr = s;
+ return REPORT(METHOD);
+ }
+
+ /* If followed by a bareword, see if it looks like indir obj. */
+
+ if ( key == 1
+ && !orig_keyword
+ && (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF) || *s == '$')
+ && (key = intuit_method(s, c.lex ? NULL : c.sv, c.cv)))
+ {
+ method:
+ if (c.lex && !c.off) {
+ assert(cSVOPx(pl_yylval.opval)->op_sv == c.sv);
+ SvREADONLY_off(c.sv);
+ sv_setpvn(c.sv, PL_tokenbuf, len);
+ if (UTF && !IN_BYTES
+ && is_utf8_string((U8*)PL_tokenbuf, len))
+ SvUTF8_on(c.sv);
+ else SvUTF8_off(c.sv);
+ }
+ op_free(c.rv2cv_op);
+ if (key == METHOD && !PL_lex_allbrackets
+ && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
+ {
+ PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
+ }
+ return REPORT(key);
+ }
+
+ /* Not a method, so call it a subroutine (if defined) */
+
+ if (c.cv) {
+ /* Check for a constant sub */
+ c.sv = cv_const_sv_or_av(c.cv);
+ return yyl_constant_op(aTHX_ s, c.sv, c.cv, c.rv2cv_op, c.off);
+ }
+
+ /* Call it a bare word */
+
+ if (PL_hints & HINT_STRICT_SUBS)
+ pl_yylval.opval->op_private |= OPpCONST_STRICT;
+ else
+ yyl_strictwarn_bareword(aTHX_ lastchar);
+
+ op_free(c.rv2cv_op);
+
+ return yyl_safe_bareword(aTHX_ s, lastchar);
+}
+
+static int
+yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct code c)
+{
+ switch (key) {
+ default: /* not a keyword */
+ return yyl_just_a_word(aTHX_ s, len, orig_keyword, c);
+
+ case KEY___FILE__:
+ FUN0OP( newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0)) );
+
+ case KEY___LINE__:
+ FUN0OP(
+ newSVOP(OP_CONST, 0,
+ Perl_newSVpvf(aTHX_ "%" IVdf, (IV)CopLINE(PL_curcop)))
+ );
+
+ case KEY___PACKAGE__:
+ FUN0OP(
+ newSVOP(OP_CONST, 0, (PL_curstash
+ ? newSVhek(HvNAME_HEK(PL_curstash))
+ : &PL_sv_undef))
+ );
+
+ case KEY___DATA__:
+ case KEY___END__:
+ if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D'))
+ yyl_data_handle(aTHX);
+ return yyl_fake_eof(aTHX_ LEX_FAKE_EOF, FALSE, s);
+
+ case KEY___SUB__:
+ FUN0OP(CvCLONE(PL_compcv)
+ ? newOP(OP_RUNCV, 0)
+ : newPVOP(OP_RUNCV,0,NULL));
+
+ case KEY_AUTOLOAD:
+ case KEY_DESTROY:
+ case KEY_BEGIN:
+ case KEY_UNITCHECK:
+ case KEY_CHECK:
+ case KEY_INIT:
+ case KEY_END:
+ if (PL_expect == XSTATE)
+ return yyl_sub(aTHX_ PL_bufptr, key);
+ return yyl_just_a_word(aTHX_ s, len, orig_keyword, c);
+
+ case KEY_abs:
+ UNI(OP_ABS);
+
+ case KEY_alarm:
+ UNI(OP_ALARM);
+
+ case KEY_accept:
+ LOP(OP_ACCEPT,XTERM);
+
+ case KEY_and:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
+ return REPORT(0);
+ OPERATOR(ANDOP);
+
+ case KEY_atan2:
+ LOP(OP_ATAN2,XTERM);
+
+ case KEY_bind:
+ LOP(OP_BIND,XTERM);
+
+ case KEY_binmode:
+ LOP(OP_BINMODE,XTERM);
+
+ case KEY_bless:
+ LOP(OP_BLESS,XTERM);
+
+ case KEY_break:
+ FUN0(OP_BREAK);
+
+ case KEY_chop:
+ UNI(OP_CHOP);
+
+ case KEY_continue:
+ /* We have to disambiguate the two senses of
+ "continue". If the next token is a '{' then
+ treat it as the start of a continue block;
+ otherwise treat it as a control operator.
+ */
+ s = skipspace(s);
+ if (*s == '{')
+ PREBLOCK(CONTINUE);
+ else
+ FUN0(OP_CONTINUE);
+
+ case KEY_chdir:
+ /* may use HOME */
+ (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
+ UNI(OP_CHDIR);
+
+ case KEY_close:
+ UNI(OP_CLOSE);
+
+ case KEY_closedir:
+ UNI(OP_CLOSEDIR);
+
+ case KEY_cmp:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ NCEop(OP_SCMP);
+
+ case KEY_caller:
+ UNI(OP_CALLER);
+
+ case KEY_crypt:
+
+ LOP(OP_CRYPT,XTERM);
+
+ case KEY_chmod:
+ LOP(OP_CHMOD,XTERM);
+
+ case KEY_chown:
+ LOP(OP_CHOWN,XTERM);
+
+ case KEY_connect:
+ LOP(OP_CONNECT,XTERM);
+
+ case KEY_chr:
+ UNI(OP_CHR);
+
+ case KEY_cos:
+ UNI(OP_COS);
+
+ case KEY_chroot:
+ UNI(OP_CHROOT);
+
+ case KEY_default:
+ PREBLOCK(DEFAULT);
+
+ case KEY_do:
+ return yyl_do(aTHX_ s, orig_keyword);
+
+ case KEY_die:
+ PL_hints |= HINT_BLOCK_SCOPE;
+ LOP(OP_DIE,XTERM);
+
+ case KEY_defined:
+ UNI(OP_DEFINED);
+
+ case KEY_delete:
+ UNI(OP_DELETE);
+
+ case KEY_dbmopen:
+ Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
+ STR_WITH_LEN("NDBM_File::"),
+ STR_WITH_LEN("DB_File::"),
+ STR_WITH_LEN("GDBM_File::"),
+ STR_WITH_LEN("SDBM_File::"),
+ STR_WITH_LEN("ODBM_File::"),
+ NULL);
+ LOP(OP_DBMOPEN,XTERM);
+
+ case KEY_dbmclose:
+ UNI(OP_DBMCLOSE);
+
+ case KEY_dump:
+ LOOPX(OP_DUMP);
+
+ case KEY_else:
+ PREBLOCK(ELSE);
+
+ case KEY_elsif:
+ pl_yylval.ival = CopLINE(PL_curcop);
+ OPERATOR(ELSIF);
+
+ case KEY_eq:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChEop(OP_SEQ);
+
+ case KEY_exists:
+ UNI(OP_EXISTS);
+
+ case KEY_exit:
+ UNI(OP_EXIT);
+
+ case KEY_eval:
+ s = skipspace(s);
+ if (*s == '{') { /* block eval */
+ PL_expect = XTERMBLOCK;
+ UNIBRACK(OP_ENTERTRY);
+ }
+ else { /* string eval */
+ PL_expect = XTERM;
+ UNIBRACK(OP_ENTEREVAL);
}
- else {
- /* Disable warning on "study /blah/" */
- if ( PL_oldoldbufptr == PL_last_uni
- && ( *PL_last_uni != 's' || s - PL_last_uni < 5
- || memNE(PL_last_uni, "study", 5)
- || isWORDCHAR_lazy_if_safe(PL_last_uni+5, PL_bufend, UTF)
- ))
- check_uni();
- s = scan_pat(s,OP_MATCH);
- TERM(sublex_start());
- }
- case '?': /* conditional */
- s++;
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
- {
- s--;
- TOKEN(0);
- }
- PL_lex_allbrackets++;
- OPERATOR('?');
+ case KEY_evalbytes:
+ PL_expect = XTERM;
+ UNIBRACK(-OP_ENTEREVAL);
- case '.':
- if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
-#ifdef PERL_STRICT_CR
- && s[1] == '\n'
-#else
- && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
-#endif
- && (s == PL_linestart || s[-1] == '\n') )
- {
- PL_expect = XSTATE;
- formbrack = 2; /* dot seen where arguments expected */
- goto rightbracket;
- }
- if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
- s += 3;
- OPERATOR(YADAYADA);
- }
- if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
- char tmp = *s++;
- if (*s == tmp) {
- if (!PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_RANGE)
- {
- s--;
- TOKEN(0);
- }
- s++;
- if (*s == tmp) {
- s++;
- pl_yylval.ival = OPf_SPECIAL;
- }
- else
- pl_yylval.ival = 0;
- OPERATOR(DOTDOT);
- }
- if (*s == '=' && !PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
- {
- s--;
- TOKEN(0);
- }
- Aop(OP_CONCAT);
- }
- /* FALLTHROUGH */
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- s = scan_num(s, &pl_yylval);
- DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
- if (PL_expect == XOPERATOR)
- no_op("Number",s);
- TERM(THING);
+ case KEY_eof:
+ UNI(OP_EOF);
- case '\'':
- s = scan_str(s,FALSE,FALSE,FALSE,NULL);
- if (!s)
- missingterm(NULL, 0);
- COPLINE_SET_FROM_MULTI_END;
- DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
- if (PL_expect == XOPERATOR) {
- no_op("String",s);
- }
- pl_yylval.ival = OP_CONST;
- TERM(sublex_start());
+ case KEY_exp:
+ UNI(OP_EXP);
- case '"':
- s = scan_str(s,FALSE,FALSE,FALSE,NULL);
- DEBUG_T( {
- if (s)
- printbuf("### Saw string before %s\n", s);
- else
- PerlIO_printf(Perl_debug_log,
- "### Saw unterminated string\n");
- } );
- if (PL_expect == XOPERATOR) {
- no_op("String",s);
- }
- if (!s)
- missingterm(NULL, 0);
- pl_yylval.ival = OP_CONST;
- /* FIXME. I think that this can be const if char *d is replaced by
- more localised variables. */
- for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
- if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
- pl_yylval.ival = OP_STRINGIFY;
- break;
- }
- }
- if (pl_yylval.ival == OP_CONST)
- COPLINE_SET_FROM_MULTI_END;
- TERM(sublex_start());
+ case KEY_each:
+ UNI(OP_EACH);
- case '`':
- s = scan_str(s,FALSE,FALSE,FALSE,NULL);
- DEBUG_T( {
- if (s)
- printbuf("### Saw backtick string before %s\n", s);
- else
- PerlIO_printf(Perl_debug_log,
- "### Saw unterminated backtick string\n");
- } );
- if (PL_expect == XOPERATOR)
- no_op("Backticks",s);
- if (!s)
- missingterm(NULL, 0);
- pl_yylval.ival = OP_BACKTICK;
- TERM(sublex_start());
+ case KEY_exec:
+ LOP(OP_EXEC,XREF);
- case '\\':
- s++;
- if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
- && isDIGIT(*s))
- Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
- *s, *s);
- if (PL_expect == XOPERATOR)
- no_op("Backslash",s);
- OPERATOR(REFGEN);
+ case KEY_endhostent:
+ FUN0(OP_EHOSTENT);
- case 'v':
- if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
- char *start = s + 2;
- while (isDIGIT(*start) || *start == '_')
- start++;
- if (*start == '.' && isDIGIT(start[1])) {
- s = scan_num(s, &pl_yylval);
- TERM(THING);
- }
- else if ((*start == ':' && start[1] == ':')
- || (PL_expect == XSTATE && *start == ':'))
- goto keylookup;
- else if (PL_expect == XSTATE) {
- d = start;
- while (d < PL_bufend && isSPACE(*d)) d++;
- if (*d == ':') goto keylookup;
- }
- /* avoid v123abc() or $h{v1}, allow C<print v10;> */
- if (!isALPHA(*start) && (PL_expect == XTERM
- || PL_expect == XREF || PL_expect == XSTATE
- || PL_expect == XTERMORDORDOR)) {
- GV *const gv = gv_fetchpvn_flags(s, start - s,
- UTF ? SVf_UTF8 : 0, SVt_PVCV);
- if (!gv) {
- s = scan_num(s, &pl_yylval);
- TERM(THING);
- }
- }
- }
- goto keylookup;
- case 'x':
- if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
- s++;
- Mop(OP_REPEAT);
- }
- goto keylookup;
+ case KEY_endnetent:
+ FUN0(OP_ENETENT);
- case '_':
- case 'a': case 'A':
- case 'b': case 'B':
- case 'c': case 'C':
- case 'd': case 'D':
- case 'e': case 'E':
- case 'f': case 'F':
- case 'g': case 'G':
- case 'h': case 'H':
- case 'i': case 'I':
- case 'j': case 'J':
- case 'k': case 'K':
- case 'l': case 'L':
- case 'm': case 'M':
- case 'n': case 'N':
- case 'o': case 'O':
- case 'p': case 'P':
- case 'q': case 'Q':
- case 'r': case 'R':
- case 's': case 'S':
- case 't': case 'T':
- case 'u': case 'U':
- case 'V':
- case 'w': case 'W':
- case 'X':
- case 'y': case 'Y':
- case 'z': case 'Z':
+ case KEY_endservent:
+ FUN0(OP_ESERVENT);
- keylookup: {
- bool anydelim;
- bool lex;
- I32 tmp;
- SV *sv;
- CV *cv;
- PADOFFSET off;
- OP *rv2cv_op;
-
- lex = FALSE;
- orig_keyword = 0;
- off = 0;
- sv = NULL;
- cv = NULL;
- gv = NULL;
- gvp = NULL;
- rv2cv_op = NULL;
+ case KEY_endprotoent:
+ FUN0(OP_EPROTOENT);
- PL_bufptr = s;
- s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
+ case KEY_endpwent:
+ FUN0(OP_EPWENT);
- /* Some keywords can be followed by any delimiter, including ':' */
- anydelim = word_takes_any_delimiter(PL_tokenbuf, len);
+ case KEY_endgrent:
+ FUN0(OP_EGRENT);
- /* x::* is just a word, unless x is "CORE" */
- if (!anydelim && *s == ':' && s[1] == ':') {
- if (memEQs(PL_tokenbuf, len, "CORE")) goto case_KEY_CORE;
- goto just_a_word;
- }
+ case KEY_for:
+ case KEY_foreach:
+ return yyl_foreach(aTHX_ s);
- d = s;
- while (d < PL_bufend && isSPACE(*d))
- d++; /* no comments skipped here, or s### is misparsed */
+ case KEY_formline:
+ LOP(OP_FORMLINE,XTERM);
- /* Is this a word before a => operator? */
- if (*d == '=' && d[1] == '>') {
- fat_arrow:
- CLINE;
- pl_yylval.opval
- = newSVOP(OP_CONST, 0,
- S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
- pl_yylval.opval->op_private = OPpCONST_BARE;
- TERM(BAREWORD);
- }
+ case KEY_fork:
+ FUN0(OP_FORK);
- /* Check for plugged-in keyword */
- {
- OP *o;
- int result;
- char *saved_bufptr = PL_bufptr;
- PL_bufptr = s;
- result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
- s = PL_bufptr;
- if (result == KEYWORD_PLUGIN_DECLINE) {
- /* not a plugged-in keyword */
- PL_bufptr = saved_bufptr;
- } else if (result == KEYWORD_PLUGIN_STMT) {
- pl_yylval.opval = o;
- CLINE;
- if (!PL_nexttoke) PL_expect = XSTATE;
- return REPORT(PLUGSTMT);
- } else if (result == KEYWORD_PLUGIN_EXPR) {
- pl_yylval.opval = o;
- CLINE;
- if (!PL_nexttoke) PL_expect = XOPERATOR;
- return REPORT(PLUGEXPR);
- } else {
- Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
- PL_tokenbuf);
- }
- }
+ case KEY_fc:
+ UNI(OP_FC);
- /* 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_fcntl:
+ LOP(OP_FCNTL,XTERM);
- /* Get the rest if it looks like a package qualifier */
+ case KEY_fileno:
+ UNI(OP_FILENO);
- 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_flock:
+ LOP(OP_FLOCK,XTERM);
- if (no_op_error)
- no_op("Bareword",s);
+ case KEY_gt:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChRop(OP_SGT);
- /* See if the name is "Foo::",
- in which case Foo is a bareword
- (and a package name). */
+ case KEY_ge:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChRop(OP_SGE);
- 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_grep:
+ LOP(OP_GREPSTART, XREF);
- /* if we saw a global override before, get the right name */
+ case KEY_goto:
+ LOOPX(OP_GOTO);
- 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_gmtime:
+ UNI(OP_GMTIME);
+ case KEY_getc:
+ UNIDOR(OP_GETC);
- /* 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_getppid:
+ FUN0(OP_GETPPID);
- /* And if "Foo::", then that's what it certainly is. */
- if (safebw)
- goto safe_bareword;
+ case KEY_getpgrp:
+ UNI(OP_GETPGRP);
- 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_getpriority:
+ LOP(OP_GETPRIORITY,XTERM);
- /* Use this var to track whether intuit_method has been
- called. intuit_method returns 0 or > 255. */
- tmp = 1;
+ case KEY_getprotobyname:
+ UNI(OP_GPBYNAME);
- /* See if it's the indirect object for a list operator. */
+ case KEY_getprotobynumber:
+ LOP(OP_GPBYNUMBER,XTERM);
- 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_getprotoent:
+ FUN0(OP_GPROTOENT);
- 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_getpwent:
+ FUN0(OP_GPWENT);
- /* 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_getpwnam:
+ UNI(OP_GPWNAM);
- /* If followed by var or block, call it a method (unless sub) */
+ case KEY_getpwuid:
+ UNI(OP_GPWUID);
- 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_getpeername:
+ UNI(OP_GETPEERNAME);
- /* If followed by a bareword, see if it looks like indir obj. */
+ case KEY_gethostbyname:
+ UNI(OP_GHBYNAME);
- 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_gethostbyaddr:
+ LOP(OP_GHBYADDR,XTERM);
- /* 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_gethostent:
+ FUN0(OP_GHOSTENT);
- 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_getnetbyname:
+ UNI(OP_GNBYNAME);
- 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_getnetbyaddr:
+ LOP(OP_GNBYADDR,XTERM);
- /* Call it a bare word */
+ case KEY_getnetent:
+ FUN0(OP_GNETENT);
- 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_getservbyname:
+ LOP(OP_GSBYNAME,XTERM);
- case KEY___FILE__:
- FUN0OP(
- newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
- );
-
- case KEY___LINE__:
- FUN0OP(
- newSVOP(OP_CONST, 0,
- Perl_newSVpvf(aTHX_ "%" IVdf, (IV)CopLINE(PL_curcop)))
- );
-
- case KEY___PACKAGE__:
- FUN0OP(
- newSVOP(OP_CONST, 0,
- (PL_curstash
- ? newSVhek(HvNAME_HEK(PL_curstash))
- : &PL_sv_undef))
- );
-
- case KEY___DATA__:
- case KEY___END__: {
- GV *gv;
- if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
- HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
- ? PL_curstash
- : PL_defstash;
- gv = (GV *)*hv_fetchs(stash, "DATA", 1);
- if (!isGV(gv))
- gv_init(gv,stash,"DATA",4,0);
- GvMULTI_on(gv);
- if (!GvIO(gv))
- GvIOp(gv) = newIO();
- IoIFP(GvIOp(gv)) = PL_rsfp;
- /* Mark this internal pseudo-handle as clean */
- IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
- if ((PerlIO*)PL_rsfp == PerlIO_stdin())
- IoTYPE(GvIOp(gv)) = IoTYPE_STD;
- else
- IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
-#if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
- /* if the script was opened in binmode, we need to revert
- * it to text mode for compatibility; but only iff it has CRs
- * XXX this is a questionable hack at best. */
- if (PL_bufend-PL_bufptr > 2
- && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
- {
- Off_t loc = 0;
- if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
- loc = PerlIO_tell(PL_rsfp);
- (void)PerlIO_seek(PL_rsfp, 0L, 0);
- }
- if (PerlLIO_setmode(RSFP_FILENO, O_TEXT) != -1) {
- if (loc > 0)
- PerlIO_seek(PL_rsfp, loc, 0);
- }
- }
-#endif
-#ifdef PERLIO_LAYERS
- if (!IN_BYTES) {
- if (UTF)
- PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
- }
-#endif
- PL_rsfp = NULL;
- }
- 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_getservbyport:
+ LOP(OP_GSBYPORT,XTERM);
- 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_getservent:
+ FUN0(OP_GSERVENT);
- case KEY_abs:
- UNI(OP_ABS);
+ case KEY_getsockname:
+ UNI(OP_GETSOCKNAME);
- case KEY_alarm:
- UNI(OP_ALARM);
+ case KEY_getsockopt:
+ LOP(OP_GSOCKOPT,XTERM);
- case KEY_accept:
- LOP(OP_ACCEPT,XTERM);
+ case KEY_getgrent:
+ FUN0(OP_GGRENT);
- case KEY_and:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
- return REPORT(0);
- OPERATOR(ANDOP);
+ case KEY_getgrnam:
+ UNI(OP_GGRNAM);
- case KEY_atan2:
- LOP(OP_ATAN2,XTERM);
+ case KEY_getgrgid:
+ UNI(OP_GGRGID);
- case KEY_bind:
- LOP(OP_BIND,XTERM);
+ case KEY_getlogin:
+ FUN0(OP_GETLOGIN);
- case KEY_binmode:
- LOP(OP_BINMODE,XTERM);
+ 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_bless:
- LOP(OP_BLESS,XTERM);
+ case KEY_glob:
+ LOP( orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB, XTERM );
- case KEY_break:
- FUN0(OP_BREAK);
+ case KEY_hex:
+ UNI(OP_HEX);
- case KEY_chop:
- UNI(OP_CHOP);
+ 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_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_index:
+ LOP(OP_INDEX,XTERM);
- case KEY_chdir:
- /* may use HOME */
- (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
- UNI(OP_CHDIR);
+ case KEY_int:
+ UNI(OP_INT);
- case KEY_close:
- UNI(OP_CLOSE);
+ case KEY_ioctl:
+ LOP(OP_IOCTL,XTERM);
- case KEY_closedir:
- UNI(OP_CLOSEDIR);
+ case KEY_isa:
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__ISA), "isa is experimental");
+ NCRop(OP_ISA);
- case KEY_cmp:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Eop(OP_SCMP);
+ case KEY_join:
+ LOP(OP_JOIN,XTERM);
- case KEY_caller:
- UNI(OP_CALLER);
+ case KEY_keys:
+ UNI(OP_KEYS);
- case KEY_crypt:
-#ifdef FCRYPT
- if (!PL_cryptseen) {
- PL_cryptseen = TRUE;
- init_des();
- }
-#endif
- LOP(OP_CRYPT,XTERM);
+ case KEY_kill:
+ LOP(OP_KILL,XTERM);
- case KEY_chmod:
- LOP(OP_CHMOD,XTERM);
+ case KEY_last:
+ LOOPX(OP_LAST);
- case KEY_chown:
- LOP(OP_CHOWN,XTERM);
+ case KEY_lc:
+ UNI(OP_LC);
- case KEY_connect:
- LOP(OP_CONNECT,XTERM);
+ case KEY_lcfirst:
+ UNI(OP_LCFIRST);
- case KEY_chr:
- UNI(OP_CHR);
+ case KEY_local:
+ OPERATOR(LOCAL);
- case KEY_cos:
- UNI(OP_COS);
+ case KEY_length:
+ UNI(OP_LENGTH);
- case KEY_chroot:
- UNI(OP_CHROOT);
+ case KEY_lt:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChRop(OP_SLT);
- case KEY_default:
- PREBLOCK(DEFAULT);
+ case KEY_le:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ return REPORT(0);
+ ChRop(OP_SLE);
- case KEY_do:
- s = skipspace(s);
- if (*s == '{')
- PRETERMBLOCK(DO);
- if (*s != '\'') {
- *PL_tokenbuf = '&';
- d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
- 1, &len);
- if (len && memNEs(PL_tokenbuf+1, len, "CORE")
- && !keyword(PL_tokenbuf + 1, len, 0)) {
- SSize_t off = s-SvPVX(PL_linestr);
- d = skipspace(d);
- s = SvPVX(PL_linestr)+off;
- if (*d == '(') {
- force_ident_maybe_lex('&');
- s = d;
- }
- }
- }
- if (orig_keyword == KEY_do) {
- orig_keyword = 0;
- pl_yylval.ival = 1;
- }
- else
- pl_yylval.ival = 0;
- OPERATOR(DO);
+ case KEY_localtime:
+ UNI(OP_LOCALTIME);
- case KEY_die:
- PL_hints |= HINT_BLOCK_SCOPE;
- LOP(OP_DIE,XTERM);
+ case KEY_log:
+ UNI(OP_LOG);
- case KEY_defined:
- UNI(OP_DEFINED);
+ case KEY_link:
+ LOP(OP_LINK,XTERM);
- case KEY_delete:
- UNI(OP_DELETE);
+ case KEY_listen:
+ LOP(OP_LISTEN,XTERM);
- 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_lock:
+ UNI(OP_LOCK);
- case KEY_dbmclose:
- UNI(OP_DBMCLOSE);
+ case KEY_lstat:
+ UNI(OP_LSTAT);
- case KEY_dump:
- LOOPX(OP_DUMP);
+ case KEY_m:
+ s = scan_pat(s,OP_MATCH);
+ TERM(sublex_start());
- case KEY_else:
- PREBLOCK(ELSE);
+ case KEY_map:
+ LOP(OP_MAPSTART, XREF);
- case KEY_elsif:
- pl_yylval.ival = CopLINE(PL_curcop);
- OPERATOR(ELSIF);
+ case KEY_mkdir:
+ LOP(OP_MKDIR,XTERM);
- case KEY_eq:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Eop(OP_SEQ);
+ case KEY_msgctl:
+ LOP(OP_MSGCTL,XTERM);
- case KEY_exists:
- UNI(OP_EXISTS);
+ case KEY_msgget:
+ LOP(OP_MSGGET,XTERM);
- case KEY_exit:
- UNI(OP_EXIT);
+ case KEY_msgrcv:
+ LOP(OP_MSGRCV,XTERM);
- case KEY_eval:
- s = skipspace(s);
- if (*s == '{') { /* block eval */
- PL_expect = XTERMBLOCK;
- UNIBRACK(OP_ENTERTRY);
- }
- else { /* string eval */
- PL_expect = XTERM;
- UNIBRACK(OP_ENTEREVAL);
- }
+ case KEY_msgsnd:
+ LOP(OP_MSGSND,XTERM);
- case KEY_evalbytes:
- PL_expect = XTERM;
- UNIBRACK(-OP_ENTEREVAL);
+ 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_eof:
- UNI(OP_EOF);
+ case KEY_no:
+ s = tokenize_use(0, s);
+ TOKEN(USE);
- case KEY_exp:
- UNI(OP_EXP);
+ 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_each:
- UNI(OP_EACH);
+ 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_exec:
- LOP(OP_EXEC,XREF);
+ 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_endhostent:
- FUN0(OP_EHOSTENT);
+ case KEY_ord:
+ UNI(OP_ORD);
- case KEY_endnetent:
- FUN0(OP_ENETENT);
+ case KEY_oct:
+ UNI(OP_OCT);
- case KEY_endservent:
- FUN0(OP_ESERVENT);
+ case KEY_opendir:
+ LOP(OP_OPEN_DIR,XTERM);
- case KEY_endprotoent:
- FUN0(OP_EPROTOENT);
+ case KEY_print:
+ checkcomma(s,PL_tokenbuf,"filehandle");
+ LOP(OP_PRINT,XREF);
- case KEY_endpwent:
- FUN0(OP_EPWENT);
+ case KEY_printf:
+ checkcomma(s,PL_tokenbuf,"filehandle");
+ LOP(OP_PRTF,XREF);
- case KEY_endgrent:
- FUN0(OP_EGRENT);
+ case KEY_prototype:
+ UNI(OP_PROTOTYPE);
- case KEY_for:
- case KEY_foreach:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
- return REPORT(0);
- pl_yylval.ival = CopLINE(PL_curcop);
- s = skipspace(s);
- if ( PL_expect == XSTATE
- && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
- {
- char *p = s;
- SSize_t s_off = s - SvPVX(PL_linestr);
+ case KEY_push:
+ LOP(OP_PUSH,XTERM);
- if ( memBEGINPs(p, (STRLEN) (PL_bufend - p), "my")
- && isSPACE(*(p + 2)))
- {
- p += 2;
- }
- else if ( memBEGINPs(p, (STRLEN) (PL_bufend - p), "our")
- && isSPACE(*(p + 3)))
- {
- p += 3;
- }
+ case KEY_pop:
+ UNIDOR(OP_POP);
- p = skipspace(p);
- /* skip optional package name, as in "for my abc $x (..)" */
- if (isIDFIRST_lazy_if_safe(p, PL_bufend, UTF)) {
- p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
- p = skipspace(p);
- }
- if (*p != '$' && *p != '\\')
- Perl_croak(aTHX_ "Missing $ on loop variable");
+ case KEY_pos:
+ UNIDOR(OP_POS);
- /* The buffer may have been reallocated, update s */
- s = SvPVX(PL_linestr) + s_off;
- }
- OPERATOR(FOR);
+ case KEY_pack:
+ LOP(OP_PACK,XTERM);
- case KEY_formline:
- LOP(OP_FORMLINE,XTERM);
+ case KEY_package:
+ s = force_word(s,BAREWORD,FALSE,TRUE);
+ s = skipspace(s);
+ s = force_strict_version(s);
+ PREBLOCK(PACKAGE);
- case KEY_fork:
- FUN0(OP_FORK);
+ case KEY_pipe:
+ LOP(OP_PIPE_OP,XTERM);
- case KEY_fc:
- UNI(OP_FC);
+ 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_fcntl:
- LOP(OP_FCNTL,XTERM);
+ case KEY_quotemeta:
+ UNI(OP_QUOTEMETA);
- case KEY_fileno:
- UNI(OP_FILENO);
+ case KEY_qw:
+ return yyl_qw(aTHX_ s, len);
- case KEY_flock:
- LOP(OP_FLOCK,XTERM);
+ case KEY_qq:
+ s = scan_str(s,FALSE,FALSE,FALSE,NULL);
+ if (!s)
+ missingterm(NULL, 0);
+ pl_yylval.ival = OP_STRINGIFY;
+ if (SvIVX(PL_lex_stuff) == '\'')
+ SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
+ TERM(sublex_start());
- case KEY_gt:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Rop(OP_SGT);
+ case KEY_qr:
+ s = scan_pat(s,OP_QR);
+ TERM(sublex_start());
- case KEY_ge:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Rop(OP_SGE);
+ 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_grep:
- LOP(OP_GREPSTART, XREF);
+ case KEY_return:
+ OLDLOP(OP_RETURN);
- case KEY_goto:
- LOOPX(OP_GOTO);
+ case KEY_require:
+ return yyl_require(aTHX_ s, orig_keyword);
- case KEY_gmtime:
- UNI(OP_GMTIME);
+ case KEY_reset:
+ UNI(OP_RESET);
- case KEY_getc:
- UNIDOR(OP_GETC);
+ case KEY_redo:
+ LOOPX(OP_REDO);
- case KEY_getppid:
- FUN0(OP_GETPPID);
+ case KEY_rename:
+ LOP(OP_RENAME,XTERM);
- case KEY_getpgrp:
- UNI(OP_GETPGRP);
+ case KEY_rand:
+ UNI(OP_RAND);
- case KEY_getpriority:
- LOP(OP_GETPRIORITY,XTERM);
+ case KEY_rmdir:
+ UNI(OP_RMDIR);
- case KEY_getprotobyname:
- UNI(OP_GPBYNAME);
+ case KEY_rindex:
+ LOP(OP_RINDEX,XTERM);
- case KEY_getprotobynumber:
- LOP(OP_GPBYNUMBER,XTERM);
+ case KEY_read:
+ LOP(OP_READ,XTERM);
- case KEY_getprotoent:
- FUN0(OP_GPROTOENT);
+ case KEY_readdir:
+ UNI(OP_READDIR);
- case KEY_getpwent:
- FUN0(OP_GPWENT);
+ case KEY_readline:
+ UNIDOR(OP_READLINE);
- case KEY_getpwnam:
- UNI(OP_GPWNAM);
+ case KEY_readpipe:
+ UNIDOR(OP_BACKTICK);
- case KEY_getpwuid:
- UNI(OP_GPWUID);
+ case KEY_rewinddir:
+ UNI(OP_REWINDDIR);
- case KEY_getpeername:
- UNI(OP_GETPEERNAME);
+ case KEY_recv:
+ LOP(OP_RECV,XTERM);
- case KEY_gethostbyname:
- UNI(OP_GHBYNAME);
+ case KEY_reverse:
+ LOP(OP_REVERSE,XTERM);
- case KEY_gethostbyaddr:
- LOP(OP_GHBYADDR,XTERM);
+ case KEY_readlink:
+ UNIDOR(OP_READLINK);
- case KEY_gethostent:
- FUN0(OP_GHOSTENT);
+ case KEY_ref:
+ UNI(OP_REF);
- case KEY_getnetbyname:
- UNI(OP_GNBYNAME);
+ case KEY_s:
+ s = scan_subst(s);
+ if (pl_yylval.opval)
+ TERM(sublex_start());
+ else
+ TOKEN(1); /* force error */
- case KEY_getnetbyaddr:
- LOP(OP_GNBYADDR,XTERM);
+ case KEY_say:
+ checkcomma(s,PL_tokenbuf,"filehandle");
+ LOP(OP_SAY,XREF);
- case KEY_getnetent:
- FUN0(OP_GNETENT);
+ case KEY_chomp:
+ UNI(OP_CHOMP);
- case KEY_getservbyname:
- LOP(OP_GSBYNAME,XTERM);
+ case KEY_scalar:
+ UNI(OP_SCALAR);
- case KEY_getservbyport:
- LOP(OP_GSBYPORT,XTERM);
+ case KEY_select:
+ LOP(OP_SELECT,XTERM);
- case KEY_getservent:
- FUN0(OP_GSERVENT);
+ case KEY_seek:
+ LOP(OP_SEEK,XTERM);
- case KEY_getsockname:
- UNI(OP_GETSOCKNAME);
+ case KEY_semctl:
+ LOP(OP_SEMCTL,XTERM);
- case KEY_getsockopt:
- LOP(OP_GSOCKOPT,XTERM);
+ case KEY_semget:
+ LOP(OP_SEMGET,XTERM);
- case KEY_getgrent:
- FUN0(OP_GGRENT);
+ case KEY_semop:
+ LOP(OP_SEMOP,XTERM);
- case KEY_getgrnam:
- UNI(OP_GGRNAM);
+ case KEY_send:
+ LOP(OP_SEND,XTERM);
- case KEY_getgrgid:
- UNI(OP_GGRGID);
+ case KEY_setpgrp:
+ LOP(OP_SETPGRP,XTERM);
- case KEY_getlogin:
- FUN0(OP_GETLOGIN);
+ case KEY_setpriority:
+ LOP(OP_SETPRIORITY,XTERM);
- 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_sethostent:
+ UNI(OP_SHOSTENT);
- case KEY_glob:
- LOP(
- orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
- XTERM
- );
+ case KEY_setnetent:
+ UNI(OP_SNETENT);
- case KEY_hex:
- UNI(OP_HEX);
+ case KEY_setservent:
+ UNI(OP_SSERVENT);
- 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_setprotoent:
+ UNI(OP_SPROTOENT);
- case KEY_index:
- LOP(OP_INDEX,XTERM);
+ case KEY_setpwent:
+ FUN0(OP_SPWENT);
- case KEY_int:
- UNI(OP_INT);
+ case KEY_setgrent:
+ FUN0(OP_SGRENT);
- case KEY_ioctl:
- LOP(OP_IOCTL,XTERM);
+ case KEY_seekdir:
+ LOP(OP_SEEKDIR,XTERM);
- case KEY_join:
- LOP(OP_JOIN,XTERM);
+ case KEY_setsockopt:
+ LOP(OP_SSOCKOPT,XTERM);
- case KEY_keys:
- UNI(OP_KEYS);
+ case KEY_shift:
+ UNIDOR(OP_SHIFT);
- case KEY_kill:
- LOP(OP_KILL,XTERM);
+ case KEY_shmctl:
+ LOP(OP_SHMCTL,XTERM);
- case KEY_last:
- LOOPX(OP_LAST);
+ case KEY_shmget:
+ LOP(OP_SHMGET,XTERM);
- case KEY_lc:
- UNI(OP_LC);
+ case KEY_shmread:
+ LOP(OP_SHMREAD,XTERM);
- case KEY_lcfirst:
- UNI(OP_LCFIRST);
+ case KEY_shmwrite:
+ LOP(OP_SHMWRITE,XTERM);
- case KEY_local:
- OPERATOR(LOCAL);
+ case KEY_shutdown:
+ LOP(OP_SHUTDOWN,XTERM);
- case KEY_length:
- UNI(OP_LENGTH);
+ case KEY_sin:
+ UNI(OP_SIN);
- case KEY_lt:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Rop(OP_SLT);
+ case KEY_sleep:
+ UNI(OP_SLEEP);
- case KEY_le:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Rop(OP_SLE);
+ case KEY_socket:
+ LOP(OP_SOCKET,XTERM);
- case KEY_localtime:
- UNI(OP_LOCALTIME);
+ case KEY_socketpair:
+ LOP(OP_SOCKPAIR,XTERM);
- case KEY_log:
- UNI(OP_LOG);
+ 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_link:
- LOP(OP_LINK,XTERM);
+ case KEY_split:
+ LOP(OP_SPLIT,XTERM);
- case KEY_listen:
- LOP(OP_LISTEN,XTERM);
+ case KEY_sprintf:
+ LOP(OP_SPRINTF,XTERM);
- case KEY_lock:
- UNI(OP_LOCK);
+ case KEY_splice:
+ LOP(OP_SPLICE,XTERM);
- case KEY_lstat:
- UNI(OP_LSTAT);
+ case KEY_sqrt:
+ UNI(OP_SQRT);
- case KEY_m:
- s = scan_pat(s,OP_MATCH);
- TERM(sublex_start());
+ case KEY_srand:
+ UNI(OP_SRAND);
- case KEY_map:
- LOP(OP_MAPSTART, XREF);
+ case KEY_stat:
+ UNI(OP_STAT);
- case KEY_mkdir:
- LOP(OP_MKDIR,XTERM);
+ case KEY_study:
+ UNI(OP_STUDY);
- case KEY_msgctl:
- LOP(OP_MSGCTL,XTERM);
+ case KEY_substr:
+ LOP(OP_SUBSTR,XTERM);
- case KEY_msgget:
- LOP(OP_MSGGET,XTERM);
+ case KEY_format:
+ case KEY_sub:
+ return yyl_sub(aTHX_ s, key);
- case KEY_msgrcv:
- LOP(OP_MSGRCV,XTERM);
+ case KEY_system:
+ LOP(OP_SYSTEM,XREF);
- case KEY_msgsnd:
- LOP(OP_MSGSND,XTERM);
+ case KEY_symlink:
+ LOP(OP_SYMLINK,XTERM);
- case KEY_our:
- case KEY_my:
- case KEY_state:
- if (PL_in_my) {
- PL_bufptr = s;
- yyerror(Perl_form(aTHX_
- "Can't redeclare \"%s\" in \"%s\"",
- tmp == KEY_my ? "my" :
- tmp == KEY_state ? "state" : "our",
- PL_in_my == KEY_my ? "my" :
- PL_in_my == KEY_state ? "state" : "our"));
- }
- PL_in_my = (U16)tmp;
- s = skipspace(s);
- if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
- s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
- if (memEQs(PL_tokenbuf, len, "sub"))
- goto really_sub;
- PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
- if (!PL_in_my_stash) {
- char tmpbuf[1024];
- int len;
- PL_bufptr = s;
- len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
- PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
- yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
- }
- }
- else if (*s == '\\') {
- if (!FEATURE_MYREF_IS_ENABLED)
- Perl_croak(aTHX_ "The experimental declared_refs "
- "feature is not enabled");
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
- "Declaring references is experimental");
- }
- OPERATOR(MY);
+ case KEY_syscall:
+ LOP(OP_SYSCALL,XTERM);
- case KEY_next:
- LOOPX(OP_NEXT);
+ case KEY_sysopen:
+ LOP(OP_SYSOPEN,XTERM);
- case KEY_ne:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
- return REPORT(0);
- Eop(OP_SNE);
+ case KEY_sysseek:
+ LOP(OP_SYSSEEK,XTERM);
- case KEY_no:
- s = tokenize_use(0, s);
- TOKEN(USE);
+ case KEY_sysread:
+ LOP(OP_SYSREAD,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_syswrite:
+ LOP(OP_SYSWRITE,XTERM);
- 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_tr:
+ case KEY_y:
+ s = scan_trans(s);
+ TERM(sublex_start());
- 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_tell:
+ UNI(OP_TELL);
- case KEY_ord:
- UNI(OP_ORD);
+ case KEY_telldir:
+ UNI(OP_TELLDIR);
- case KEY_oct:
- UNI(OP_OCT);
+ case KEY_tie:
+ LOP(OP_TIE,XTERM);
- case KEY_opendir:
- LOP(OP_OPEN_DIR,XTERM);
+ case KEY_tied:
+ UNI(OP_TIED);
- case KEY_print:
- checkcomma(s,PL_tokenbuf,"filehandle");
- LOP(OP_PRINT,XREF);
+ case KEY_time:
+ FUN0(OP_TIME);
- case KEY_printf:
- checkcomma(s,PL_tokenbuf,"filehandle");
- LOP(OP_PRTF,XREF);
+ case KEY_times:
+ FUN0(OP_TMS);
- case KEY_prototype:
- UNI(OP_PROTOTYPE);
+ case KEY_truncate:
+ LOP(OP_TRUNCATE,XTERM);
- case KEY_push:
- LOP(OP_PUSH,XTERM);
+ case KEY_uc:
+ UNI(OP_UC);
- case KEY_pop:
- UNIDOR(OP_POP);
+ case KEY_ucfirst:
+ UNI(OP_UCFIRST);
- case KEY_pos:
- UNIDOR(OP_POS);
+ case KEY_untie:
+ UNI(OP_UNTIE);
- case KEY_pack:
- LOP(OP_PACK,XTERM);
+ 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_package:
- s = force_word(s,BAREWORD,FALSE,TRUE);
- s = skipspace(s);
- s = force_strict_version(s);
- PREBLOCK(PACKAGE);
+ 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_pipe:
- LOP(OP_PIPE_OP,XTERM);
+ case KEY_unlink:
+ LOP(OP_UNLINK,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_undef:
+ UNIDOR(OP_UNDEF);
- case KEY_quotemeta:
- UNI(OP_QUOTEMETA);
+ case KEY_unpack:
+ LOP(OP_UNPACK,XTERM);
- case KEY_qw:
- return yyl_qw(aTHX_ s, len);
+ case KEY_utime:
+ LOP(OP_UTIME,XTERM);
- case KEY_qq:
- s = scan_str(s,FALSE,FALSE,FALSE,NULL);
- if (!s)
- missingterm(NULL, 0);
- pl_yylval.ival = OP_STRINGIFY;
- if (SvIVX(PL_lex_stuff) == '\'')
- SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
- TERM(sublex_start());
-
- case KEY_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_umask:
+ UNIDOR(OP_UMASK);
- case KEY_return:
- OLDLOP(OP_RETURN);
+ case KEY_unshift:
+ LOP(OP_UNSHIFT,XTERM);
- case KEY_require:
- s = skipspace(s);
- if (isDIGIT(*s)) {
- s = force_version(s, FALSE);
- }
- else if (*s != 'v' || !isDIGIT(s[1])
- || (s = force_version(s, TRUE), *s == 'v'))
- {
- *PL_tokenbuf = '\0';
- s = force_word(s,BAREWORD,TRUE,TRUE);
- if (isIDFIRST_lazy_if_safe(PL_tokenbuf,
- PL_tokenbuf + sizeof(PL_tokenbuf),
- UTF))
- {
- gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
- GV_ADD | (UTF ? SVf_UTF8 : 0));
- }
- else if (*s == '<')
- yyerror("<> at require-statement should be quotes");
- }
- if (orig_keyword == KEY_require) {
- orig_keyword = 0;
- pl_yylval.ival = 1;
- }
- else
- pl_yylval.ival = 0;
- PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
- PL_bufptr = s;
- PL_last_uni = PL_oldbufptr;
- PL_last_lop_op = OP_REQUIRE;
- s = skipspace(s);
- return REPORT( (int)REQUIRE );
+ case KEY_use:
+ s = tokenize_use(1, s);
+ TOKEN(USE);
- case KEY_reset:
- UNI(OP_RESET);
+ case KEY_values:
+ UNI(OP_VALUES);
- case KEY_redo:
- LOOPX(OP_REDO);
+ case KEY_vec:
+ LOP(OP_VEC,XTERM);
- case KEY_rename:
- LOP(OP_RENAME,XTERM);
+ case KEY_when:
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ return REPORT(0);
+ pl_yylval.ival = CopLINE(PL_curcop);
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
+ "when is experimental");
+ OPERATOR(WHEN);
- case KEY_rand:
- UNI(OP_RAND);
+ 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_rmdir:
- UNI(OP_RMDIR);
+ case KEY_warn:
+ PL_hints |= HINT_BLOCK_SCOPE;
+ LOP(OP_WARN,XTERM);
- case KEY_rindex:
- LOP(OP_RINDEX,XTERM);
+ case KEY_wait:
+ FUN0(OP_WAIT);
- case KEY_read:
- LOP(OP_READ,XTERM);
+ case KEY_waitpid:
+ LOP(OP_WAITPID,XTERM);
- case KEY_readdir:
- UNI(OP_READDIR);
+ case KEY_wantarray:
+ FUN0(OP_WANTARRAY);
- case KEY_readline:
- UNIDOR(OP_READLINE);
+ 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_readpipe:
- UNIDOR(OP_BACKTICK);
+ 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_rewinddir:
- UNI(OP_REWINDDIR);
+ 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_recv:
- LOP(OP_RECV,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_reverse:
- LOP(OP_REVERSE,XTERM);
+ /* Known to be a reserved word at this point */
+ return yyl_word_or_keyword(aTHX_ s, len, key, orig_keyword, c);
+}
- case KEY_readlink:
- UNIDOR(OP_READLINK);
+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_ref:
- UNI(OP_REF);
+ c.gv = gv;
- case KEY_s:
- s = scan_subst(s);
- if (pl_yylval.opval)
- TERM(sublex_start());
- else
- TOKEN(1); /* force error */
+ PL_bufptr = s;
+ s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
- case KEY_say:
- checkcomma(s,PL_tokenbuf,"filehandle");
- LOP(OP_SAY,XREF);
+ /* Some keywords can be followed by any delimiter, including ':' */
+ anydelim = word_takes_any_delimiter(PL_tokenbuf, len);
- case KEY_chomp:
- UNI(OP_CHOMP);
+ /* 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);
+ }
+
+ d = s;
+ while (d < PL_bufend && isSPACE(*d))
+ d++; /* no comments skipped here, or s### is misparsed */
- case KEY_scalar:
- UNI(OP_SCALAR);
+ /* Is this a word before a => operator? */
+ if (*d == '=' && d[1] == '>') {
+ return yyl_fatcomma(aTHX_ s, len);
+ }
- case KEY_select:
- LOP(OP_SELECT,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_seek:
- LOP(OP_SEEK,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_semctl:
- LOP(OP_SEMCTL,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_semget:
- LOP(OP_SEMGET,XTERM);
+ /* Check for built-in keyword */
+ key = keyword(PL_tokenbuf, len, 0);
- case KEY_semop:
- LOP(OP_SEMOP,XTERM);
+ if (key < 0)
+ key = yyl_secondclass_keyword(aTHX_ s, len, key, &orig_keyword, &c.gv, &c.gvp);
- case KEY_send:
- LOP(OP_SEND,XTERM);
+ if (key && key != KEY___DATA__ && key != KEY___END__
+ && (!anydelim || *s != '#')) {
+ /* no override, and not s### either; skipspace is safe here
+ * check for => on following line */
+ bool arrow;
+ STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
+ STRLEN soff = s - SvPVX(PL_linestr);
+ s = peekspace(s);
+ arrow = *s == '=' && s[1] == '>';
+ PL_bufptr = SvPVX(PL_linestr) + bufoff;
+ s = SvPVX(PL_linestr) + soff;
+ if (arrow)
+ return yyl_fatcomma(aTHX_ s, len);
+ }
- case KEY_setpgrp:
- LOP(OP_SETPGRP,XTERM);
+ return yyl_word_or_keyword(aTHX_ s, len, key, orig_keyword, c);
+}
- case KEY_setpriority:
- LOP(OP_SETPRIORITY,XTERM);
+static int
+yyl_try(pTHX_ char *s)
+{
+ char *d;
+ GV *gv = NULL;
+ int tok;
- case KEY_sethostent:
- UNI(OP_SHOSTENT);
+ 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_setnetent:
- UNI(OP_SNETENT);
+ 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_setservent:
- UNI(OP_SSERVENT);
+ 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_setprotoent:
- UNI(OP_SPROTOENT);
+ const char * const pdb = PerlEnv_getenv("PERL5DB");
- case KEY_setpwent:
- FUN0(OP_SPWENT);
+ 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_setgrent:
- FUN0(OP_SGRENT);
+ 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_seekdir:
- LOP(OP_SEEKDIR,XTERM);
+ case '#':
+ case '\n': {
+ const bool needs_semicolon = yyl_eol_needs_semicolon(aTHX_ &s);
+ if (needs_semicolon)
+ TOKEN(';');
+ else
+ goto retry;
+ }
- case KEY_setsockopt:
- LOP(OP_SSOCKOPT,XTERM);
+ case '-':
+ return yyl_hyphen(aTHX_ s);
- case KEY_shift:
- UNIDOR(OP_SHIFT);
+ case '+':
+ return yyl_plus(aTHX_ s);
- case KEY_shmctl:
- LOP(OP_SHMCTL,XTERM);
+ case '*':
+ return yyl_star(aTHX_ s);
- case KEY_shmget:
- LOP(OP_SHMGET,XTERM);
+ case '%':
+ return yyl_percent(aTHX_ s);
- case KEY_shmread:
- LOP(OP_SHMREAD,XTERM);
+ case '^':
+ return yyl_caret(aTHX_ s);
- case KEY_shmwrite:
- LOP(OP_SHMWRITE,XTERM);
+ case '[':
+ return yyl_leftsquare(aTHX_ s);
- case KEY_shutdown:
- LOP(OP_SHUTDOWN,XTERM);
+ case '~':
+ return yyl_tilde(aTHX_ s);
- case KEY_sin:
- UNI(OP_SIN);
+ case ',':
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
+ TOKEN(0);
+ s++;
+ OPERATOR(',');
+ case ':':
+ if (s[1] == ':')
+ return yyl_just_a_word(aTHX_ s, 0, 0, no_code);
+ return yyl_colon(aTHX_ s + 1);
- case KEY_sleep:
- UNI(OP_SLEEP);
+ case '(':
+ return yyl_leftparen(aTHX_ s + 1);
- case KEY_socket:
- LOP(OP_SOCKET,XTERM);
+ case ';':
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
+ TOKEN(0);
+ CLINE;
+ s++;
+ PL_expect = XSTATE;
+ TOKEN(';');
- case KEY_socketpair:
- LOP(OP_SOCKPAIR,XTERM);
+ case ')':
+ return yyl_rightparen(aTHX_ s);
- case KEY_sort:
- checkcomma(s,PL_tokenbuf,"subroutine name");
- s = skipspace(s);
- PL_expect = XTERM;
- s = force_word(s,BAREWORD,TRUE,TRUE);
- LOP(OP_SORT,XREF);
+ case ']':
+ return yyl_rightsquare(aTHX_ s);
- case KEY_split:
- LOP(OP_SPLIT,XTERM);
+ case '{':
+ return yyl_leftcurly(aTHX_ s + 1, 0);
- case KEY_sprintf:
- LOP(OP_SPRINTF,XTERM);
+ case '}':
+ if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
+ TOKEN(0);
+ return yyl_rightcurly(aTHX_ s, 0);
- case KEY_splice:
- LOP(OP_SPLICE,XTERM);
+ case '&':
+ return yyl_ampersand(aTHX_ s);
- case KEY_sqrt:
- UNI(OP_SQRT);
+ case '|':
+ return yyl_verticalbar(aTHX_ s);
- case KEY_srand:
- UNI(OP_SRAND);
+ 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_stat:
- UNI(OP_STAT);
+ s++;
+ {
+ const char tmp = *s++;
+ if (tmp == '=') {
+ if (!PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
+ {
+ s -= 2;
+ TOKEN(0);
+ }
+ ChEop(OP_EQ);
+ }
+ if (tmp == '>') {
+ if (!PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
+ {
+ s -= 2;
+ TOKEN(0);
+ }
+ OPERATOR(',');
+ }
+ if (tmp == '~')
+ PMop(OP_MATCH);
+ if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
+ && memCHRs("+-*/%.^&|<",tmp))
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Reversed %c= operator",(int)tmp);
+ s--;
+ if (PL_expect == XSTATE
+ && isALPHA(tmp)
+ && (s == PL_linestart+1 || s[-2] == '\n') )
+ {
+ if ( (PL_in_eval && !PL_rsfp && !PL_parser->filtered)
+ || PL_lex_state != LEX_NORMAL)
+ {
+ d = PL_bufend;
+ while (s < d) {
+ if (*s++ == '\n') {
+ incline(s, PL_bufend);
+ if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=cut"))
+ {
+ s = (char *) memchr(s,'\n', d - s);
+ if (s)
+ s++;
+ else
+ s = d;
+ incline(s, PL_bufend);
+ goto retry;
+ }
+ }
+ }
+ goto retry;
+ }
+ s = PL_bufend;
+ PL_parser->in_pod = 1;
+ goto retry;
+ }
+ }
+ if (PL_expect == XBLOCK) {
+ const char *t = s;
+#ifdef PERL_STRICT_CR
+ while (SPACE_OR_TAB(*t))
+#else
+ while (SPACE_OR_TAB(*t) || *t == '\r')
+#endif
+ t++;
+ if (*t == '\n' || *t == '#') {
+ ENTER_with_name("lex_format");
+ SAVEI8(PL_parser->form_lex_state);
+ SAVEI32(PL_lex_formbrack);
+ PL_parser->form_lex_state = PL_lex_state;
+ PL_lex_formbrack = PL_lex_brackets + 1;
+ PL_parser->sub_error_count = PL_error_count;
+ return yyl_leftcurly(aTHX_ s, 1);
+ }
+ }
+ if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
+ s--;
+ TOKEN(0);
+ }
+ pl_yylval.ival = 0;
+ OPERATOR(ASSIGNOP);
- case KEY_study:
- UNI(OP_STUDY);
+ case '!':
+ return yyl_bang(aTHX_ s + 1);
- case KEY_substr:
- LOP(OP_SUBSTR,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_format:
- case KEY_sub:
- really_sub:
- return yyl_sub(aTHX_ s, tmp);
+ 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_system:
- LOP(OP_SYSTEM,XREF);
+ case '$':
+ return yyl_dollar(aTHX_ s);
- case KEY_symlink:
- LOP(OP_SYMLINK,XTERM);
+ case '@':
+ return yyl_snail(aTHX_ s);
- case KEY_syscall:
- LOP(OP_SYSCALL,XTERM);
+ case '/': /* may be division, defined-or, or pattern */
+ return yyl_slash(aTHX_ s);
- case KEY_sysopen:
- LOP(OP_SYSOPEN,XTERM);
+ case '?': /* conditional */
+ s++;
+ if (!PL_lex_allbrackets
+ && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
+ {
+ s--;
+ TOKEN(0);
+ }
+ PL_lex_allbrackets++;
+ OPERATOR('?');
- case KEY_sysseek:
- LOP(OP_SYSSEEK,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_sysread:
- LOP(OP_SYSREAD,XTERM);
+ case '\'':
+ return yyl_sglquote(aTHX_ s);
- case KEY_syswrite:
- LOP(OP_SYSWRITE,XTERM);
+ case '"':
+ return yyl_dblquote(aTHX_ s);
- case KEY_tr:
- case KEY_y:
- s = scan_trans(s);
- TERM(sublex_start());
+ case '`':
+ return yyl_backtick(aTHX_ s);
- case KEY_tell:
- UNI(OP_TELL);
+ case '\\':
+ return yyl_backslash(aTHX_ s + 1);
- case KEY_telldir:
- UNI(OP_TELLDIR);
+ case 'v':
+ if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
+ char *start = s + 2;
+ while (isDIGIT(*start) || *start == '_')
+ start++;
+ if (*start == '.' && isDIGIT(start[1])) {
+ s = scan_num(s, &pl_yylval);
+ TERM(THING);
+ }
+ else if ((*start == ':' && start[1] == ':')
+ || (PL_expect == XSTATE && *start == ':')) {
+ if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
+ }
+ else if (PL_expect == XSTATE) {
+ d = start;
+ while (d < PL_bufend && isSPACE(*d)) d++;
+ if (*d == ':') {
+ if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
+ }
+ }
+ /* avoid v123abc() or $h{v1}, allow C<print v10;> */
+ if (!isALPHA(*start) && (PL_expect == XTERM
+ || PL_expect == XREF || PL_expect == XSTATE
+ || PL_expect == XTERMORDORDOR)) {
+ GV *const gv = gv_fetchpvn_flags(s, start - s,
+ UTF ? SVf_UTF8 : 0, SVt_PVCV);
+ if (!gv) {
+ s = scan_num(s, &pl_yylval);
+ TERM(THING);
+ }
+ }
+ }
+ if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
- case KEY_tie:
- LOP(OP_TIE,XTERM);
+ case 'x':
+ if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
+ s++;
+ Mop(OP_REPEAT);
+ }
+ if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
- case KEY_tied:
- UNI(OP_TIED);
+ case '_':
+ case 'a': case 'A':
+ case 'b': case 'B':
+ case 'c': case 'C':
+ case 'd': case 'D':
+ case 'e': case 'E':
+ case 'f': case 'F':
+ case 'g': case 'G':
+ case 'h': case 'H':
+ case 'i': case 'I':
+ case 'j': case 'J':
+ case 'k': case 'K':
+ case 'l': case 'L':
+ case 'm': case 'M':
+ case 'n': case 'N':
+ case 'o': case 'O':
+ case 'p': case 'P':
+ case 'q': case 'Q':
+ case 'r': case 'R':
+ case 's': case 'S':
+ case 't': case 'T':
+ case 'u': case 'U':
+ case 'V':
+ case 'w': case 'W':
+ case 'X':
+ case 'y': case 'Y':
+ case 'z': case 'Z':
+ if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
+ }
+}
- case KEY_time:
- FUN0(OP_TIME);
- case KEY_times:
- FUN0(OP_TMS);
+/*
+ yylex
- case KEY_truncate:
- LOP(OP_TRUNCATE,XTERM);
+ Works out what to call the token just pulled out of the input
+ stream. The yacc parser takes care of taking the ops we return and
+ stitching them into a tree.
- case KEY_uc:
- UNI(OP_UC);
+ Returns:
+ The type of the next token
- case KEY_ucfirst:
- UNI(OP_UCFIRST);
+ Structure:
+ Check if we have already built the token; if so, use it.
+ Switch based on the current state:
+ - if we have a case modifier in a string, deal with that
+ - handle other cases of interpolation inside a string
+ - scan the next line if we are inside a format
+ In the normal state, switch on the next character:
+ - default:
+ if alphabetic, go to key lookup
+ unrecognized character - croak
+ - 0/4/26: handle end-of-line or EOF
+ - cases for whitespace
+ - \n and #: handle comments and line numbers
+ - various operators, brackets and sigils
+ - numbers
+ - quotes
+ - 'v': vstrings (or go to key lookup)
+ - 'x' repetition operator (or go to key lookup)
+ - other ASCII alphanumerics (key lookup begins here):
+ word before => ?
+ keyword plugin
+ scan built-in keyword (but do nothing with it yet)
+ check for statement label
+ check for lexical subs
+ return yyl_just_a_word if there is one
+ see whether built-in keyword is overridden
+ switch on keyword number:
+ - default: return yyl_just_a_word:
+ not a built-in keyword; handle bareword lookup
+ disambiguate between method and sub call
+ fall back to bareword
+ - cases for built-in keywords
+*/
- case KEY_untie:
- UNI(OP_UNTIE);
+#ifdef NETWARE
+#define RSFP_FILENO (PL_rsfp)
+#else
+#define RSFP_FILENO (PerlIO_fileno(PL_rsfp))
+#endif
- case KEY_until:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
- return REPORT(0);
- pl_yylval.ival = CopLINE(PL_curcop);
- OPERATOR(UNTIL);
- case KEY_unless:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
- return REPORT(0);
- pl_yylval.ival = CopLINE(PL_curcop);
- OPERATOR(UNLESS);
+int
+Perl_yylex(pTHX)
+{
+ char *s = PL_bufptr;
- case KEY_unlink:
- LOP(OP_UNLINK,XTERM);
+ if (UNLIKELY(PL_parser->recheck_utf8_validity)) {
+ const U8* first_bad_char_loc;
+ if (UTF && UNLIKELY(! is_utf8_string_loc((U8 *) PL_bufptr,
+ PL_bufend - PL_bufptr,
+ &first_bad_char_loc)))
+ {
+ _force_out_malformed_utf8_message(first_bad_char_loc,
+ (U8 *) PL_bufend,
+ 0,
+ 1 /* 1 means die */ );
+ NOT_REACHED; /* NOTREACHED */
+ }
+ PL_parser->recheck_utf8_validity = FALSE;
+ }
+ DEBUG_T( {
+ SV* tmp = newSVpvs("");
+ PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n",
+ (IV)CopLINE(PL_curcop),
+ lex_state_names[PL_lex_state],
+ exp_name[PL_expect],
+ pv_display(tmp, s, strlen(s), 0, 60));
+ SvREFCNT_dec(tmp);
+ } );
- case KEY_undef:
- UNIDOR(OP_UNDEF);
+ /* when we've already built the next token, just pull it out of the queue */
+ if (PL_nexttoke) {
+ PL_nexttoke--;
+ pl_yylval = PL_nextval[PL_nexttoke];
+ {
+ I32 next_type;
+ next_type = PL_nexttype[PL_nexttoke];
+ if (next_type & (7<<24)) {
+ if (next_type & (1<<24)) {
+ if (PL_lex_brackets > 100)
+ Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
+ PL_lex_brackstack[PL_lex_brackets++] =
+ (char) ((next_type >> 16) & 0xff);
+ }
+ if (next_type & (2<<24))
+ PL_lex_allbrackets++;
+ if (next_type & (4<<24))
+ PL_lex_allbrackets--;
+ next_type &= 0xffff;
+ }
+ return REPORT(next_type == 'p' ? pending_ident() : next_type);
+ }
+ }
- case KEY_unpack:
- LOP(OP_UNPACK,XTERM);
+ switch (PL_lex_state) {
+ case LEX_NORMAL:
+ case LEX_INTERPNORMAL:
+ break;
- case KEY_utime:
- LOP(OP_UTIME,XTERM);
+ /* interpolated case modifiers like \L \U, including \Q and \E.
+ when we get here, PL_bufptr is at the \
+ */
+ case LEX_INTERPCASEMOD:
+ /* handle \E or end of string */
+ return yyl_interpcasemod(aTHX_ s);
- case KEY_umask:
- UNIDOR(OP_UMASK);
+ case LEX_INTERPPUSH:
+ return REPORT(sublex_push());
- case KEY_unshift:
- LOP(OP_UNSHIFT,XTERM);
+ case LEX_INTERPSTART:
+ if (PL_bufptr == PL_bufend)
+ return REPORT(sublex_done());
+ DEBUG_T({
+ if(*PL_bufptr != '(')
+ PerlIO_printf(Perl_debug_log, "### Interpolated variable\n");
+ });
+ PL_expect = XTERM;
+ /* for /@a/, we leave the joining for the regex engine to do
+ * (unless we're within \Q etc) */
+ PL_lex_dojoin = (*PL_bufptr == '@'
+ && (!PL_lex_inpat || PL_lex_casemods));
+ PL_lex_state = LEX_INTERPNORMAL;
+ if (PL_lex_dojoin) {
+ NEXTVAL_NEXTTOKE.ival = 0;
+ force_next(',');
+ force_ident("\"", '$');
+ NEXTVAL_NEXTTOKE.ival = 0;
+ force_next('$');
+ NEXTVAL_NEXTTOKE.ival = 0;
+ force_next((2<<24)|'(');
+ NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
+ force_next(FUNC);
+ }
+ /* Convert (?{...}) and friends to 'do {...}' */
+ if (PL_lex_inpat && *PL_bufptr == '(') {
+ PL_parser->lex_shared->re_eval_start = PL_bufptr;
+ PL_bufptr += 2;
+ if (*PL_bufptr != '{')
+ PL_bufptr++;
+ PL_expect = XTERMBLOCK;
+ force_next(DO);
+ }
- case KEY_use:
- s = tokenize_use(1, s);
- TOKEN(USE);
+ if (PL_lex_starts++) {
+ s = PL_bufptr;
+ /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
+ if (!PL_lex_casemods && PL_lex_inpat)
+ TOKEN(',');
+ else
+ AopNOASSIGN(OP_CONCAT);
+ }
+ return yylex();
- case KEY_values:
- UNI(OP_VALUES);
+ case LEX_INTERPENDMAYBE:
+ if (intuit_more(PL_bufptr, PL_bufend)) {
+ PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
+ break;
+ }
+ /* FALLTHROUGH */
- case KEY_vec:
- LOP(OP_VEC,XTERM);
+ case LEX_INTERPEND:
+ if (PL_lex_dojoin) {
+ const U8 dojoin_was = PL_lex_dojoin;
+ PL_lex_dojoin = FALSE;
+ PL_lex_state = LEX_INTERPCONCAT;
+ PL_lex_allbrackets--;
+ return REPORT(dojoin_was == 1 ? (int)')' : (int)POSTJOIN);
+ }
+ if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
+ && SvEVALED(PL_lex_repl))
+ {
+ if (PL_bufptr != PL_bufend)
+ Perl_croak(aTHX_ "Bad evalled substitution pattern");
+ PL_lex_repl = NULL;
+ }
+ /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
+ re_eval_str. If the here-doc body’s length equals the previous
+ value of re_eval_start, re_eval_start will now be null. So
+ check re_eval_str as well. */
+ if (PL_parser->lex_shared->re_eval_start
+ || PL_parser->lex_shared->re_eval_str) {
+ SV *sv;
+ if (*PL_bufptr != ')')
+ Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
+ PL_bufptr++;
+ /* having compiled a (?{..}) expression, return the original
+ * text too, as a const */
+ if (PL_parser->lex_shared->re_eval_str) {
+ sv = PL_parser->lex_shared->re_eval_str;
+ PL_parser->lex_shared->re_eval_str = NULL;
+ SvCUR_set(sv,
+ PL_bufptr - PL_parser->lex_shared->re_eval_start);
+ SvPV_shrink_to_cur(sv);
+ }
+ else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
+ PL_bufptr - PL_parser->lex_shared->re_eval_start);
+ NEXTVAL_NEXTTOKE.opval =
+ newSVOP(OP_CONST, 0,
+ sv);
+ force_next(THING);
+ PL_parser->lex_shared->re_eval_start = NULL;
+ PL_expect = XTERM;
+ return REPORT(',');
+ }
- case KEY_when:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
- return REPORT(0);
- pl_yylval.ival = CopLINE(PL_curcop);
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
- "when is experimental");
- OPERATOR(WHEN);
+ /* FALLTHROUGH */
+ case LEX_INTERPCONCAT:
+#ifdef DEBUGGING
+ if (PL_lex_brackets)
+ Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
+ (long) PL_lex_brackets);
+#endif
+ if (PL_bufptr == PL_bufend)
+ return REPORT(sublex_done());
- case KEY_while:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
- return REPORT(0);
- pl_yylval.ival = CopLINE(PL_curcop);
- OPERATOR(WHILE);
+ /* m'foo' still needs to be parsed for possible (?{...}) */
+ if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
+ SV *sv = newSVsv(PL_linestr);
+ sv = tokeq(sv);
+ pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
+ s = PL_bufend;
+ }
+ else {
+ int save_error_count = PL_error_count;
- case KEY_warn:
- PL_hints |= HINT_BLOCK_SCOPE;
- LOP(OP_WARN,XTERM);
+ s = scan_const(PL_bufptr);
- case KEY_wait:
- FUN0(OP_WAIT);
+ /* Set flag if this was a pattern and there were errors. op.c will
+ * refuse to compile a pattern with this flag set. Otherwise, we
+ * could get segfaults, etc. */
+ if (PL_lex_inpat && PL_error_count > save_error_count) {
+ ((PMOP*)PL_lex_inpat)->op_pmflags |= PMf_HAS_ERROR;
+ }
+ if (*s == '\\')
+ PL_lex_state = LEX_INTERPCASEMOD;
+ else
+ PL_lex_state = LEX_INTERPSTART;
+ }
- case KEY_waitpid:
- LOP(OP_WAITPID,XTERM);
+ if (s != PL_bufptr) {
+ NEXTVAL_NEXTTOKE = pl_yylval;
+ PL_expect = XTERM;
+ force_next(THING);
+ if (PL_lex_starts++) {
+ /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
+ if (!PL_lex_casemods && PL_lex_inpat)
+ TOKEN(',');
+ else
+ AopNOASSIGN(OP_CONCAT);
+ }
+ else {
+ PL_bufptr = s;
+ return yylex();
+ }
+ }
- case KEY_wantarray:
- FUN0(OP_WANTARRAY);
+ return yylex();
+ case LEX_FORMLINE:
+ if (PL_parser->sub_error_count != PL_error_count) {
+ /* There was an error parsing a formline, which tends to
+ mess up the parser.
+ Unlike interpolated sub-parsing, we can't treat any of
+ these as recoverable, so no need to check sub_no_recover.
+ */
+ yyquit();
+ }
+ assert(PL_lex_formbrack);
+ s = scan_formline(PL_bufptr);
+ if (!PL_lex_formbrack)
+ return yyl_rightcurly(aTHX_ s, 1);
+ PL_bufptr = s;
+ return yylex();
+ }
- case KEY_write:
- /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
- * we use the same number on EBCDIC */
- gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
- UNI(OP_ENTERWRITE);
+ /* We really do *not* want PL_linestr ever becoming a COW. */
+ assert (!SvIsCOW(PL_linestr));
+ s = PL_bufptr;
+ PL_oldoldbufptr = PL_oldbufptr;
+ PL_oldbufptr = s;
- case KEY_x:
- if (PL_expect == XOPERATOR) {
- if (*s == '=' && !PL_lex_allbrackets
- && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
- {
- return REPORT(0);
- }
- Mop(OP_REPEAT);
- }
- check_uni();
- goto just_a_word;
+ if (PL_in_my == KEY_sigvar) {
+ PL_parser->saw_infix_sigil = 0;
+ return yyl_sigvar(aTHX_ s);
+ }
- case KEY_xor:
- if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
- return REPORT(0);
- pl_yylval.ival = OP_XOR;
- OPERATOR(OROP);
- }
- }}
+ {
+ /* yyl_try() and its callees might consult PL_parser->saw_infix_sigil.
+ On its return, we then need to set it to indicate whether the token
+ we just encountered was an infix operator that (if we hadn't been
+ expecting an operator) have been a sigil.
+ */
+ bool expected_operator = (PL_expect == XOPERATOR);
+ int ret = yyl_try(aTHX_ s);
+ switch (pl_yylval.ival) {
+ case OP_BIT_AND:
+ case OP_MODULO:
+ case OP_MULTIPLY:
+ case OP_NBIT_AND:
+ if (expected_operator) {
+ PL_parser->saw_infix_sigil = 1;
+ break;
+ }
+ /* FALLTHROUGH */
+ default:
+ PL_parser->saw_infix_sigil = 0;
+ }
+ return ret;
+ }
}
+
/*
S_pending_ident
/* diag_listed_as: No package name allowed for variable %s
in "our" */
yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
- "%se %s in \"our\"",
- *PL_tokenbuf=='&' ?"subroutin":"variabl",
+ "%s %s in \"our\"",
+ *PL_tokenbuf=='&' ? "subroutine" : "variable",
PL_tokenbuf), UTF ? SVf_UTF8 : 0);
tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
}
GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
PL_in_my == KEY_my ? "my" : "state",
- *PL_tokenbuf == '&' ? "subroutin" : "variabl",
+ *PL_tokenbuf == '&' ? "subroutine" : "variable",
PL_tokenbuf),
UTF ? SVf_UTF8 : 0);
GCC_DIAG_RESTORE_STMT;
* block / parens, boolean operators (&&, ||, //) and branch
* constructs (or, and, if, until, unless, while, err, for).
* Not a very solid hack... */
- if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
+ if (!*w || !memCHRs(";&/|})]oaiuwef!=", *w))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"%s (...) interpreted as function",name);
}
SV **cvp;
SV *cv, *typesv;
const char *why1 = "", *why2 = "", *why3 = "";
+ const char * optional_colon = ":"; /* Only some messages have a colon */
+ char *msg;
PERL_ARGS_ASSERT_NEW_CONSTANT;
/* We assume that this is true: */
- if (*key == 'c') { assert (strEQ(key, "charnames")); }
assert(type || s);
sv_2mortal(sv); /* Parent created it permanently */
- if (!table
- || ! (PL_hints & HINT_LOCALIZE_HH)
- || ! (cvp = hv_fetch(table, key, keylen, FALSE))
- || ! SvOK(*cvp))
+
+ if ( ! table
+ || ! (PL_hints & HINT_LOCALIZE_HH))
{
- char *msg;
-
- /* Here haven't found what we're looking for. If it is charnames,
- * perhaps it needs to be loaded. Try doing that before giving up */
- if (*key == 'c') {
- Perl_load_module(aTHX_
- 0,
- newSVpvs("_charnames"),
- /* version parameter; no need to specify it, as if
- * we get too early a version, will fail anyway,
- * not being able to find '_charnames' */
- NULL,
- newSVpvs(":full"),
- newSVpvs(":short"),
- NULL);
- assert(sp == PL_stack_sp);
- table = GvHV(PL_hintgv);
- if (table
- && (PL_hints & HINT_LOCALIZE_HH)
- && (cvp = hv_fetch(table, key, keylen, FALSE))
- && SvOK(*cvp))
- {
- goto now_ok;
- }
- }
- if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
- msg = Perl_form(aTHX_
- "Constant(%.*s) unknown",
- (int)(type ? typelen : len),
- (type ? type: s));
- }
- else {
- why1 = "$^H{";
- why2 = key;
- why3 = "} is not defined";
- report:
- if (*key == 'c') {
- msg = Perl_form(aTHX_
- /* The +3 is for '\N{'; -4 for that, plus '}' */
- "Unknown charname '%.*s'", (int)typelen - 4, type + 3
- );
- }
- else {
- msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
- (int)(type ? typelen : len),
- (type ? type: s), why1, why2, why3);
- }
- }
- if (error_msg) {
- *error_msg = msg;
- }
- else {
- yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
- }
- return SvREFCNT_inc_simple_NN(sv);
+ why1 = "unknown";
+ optional_colon = "";
+ goto report;
+ }
+
+ 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
/* read exponent part, if present */
if ((isALPHA_FOLD_EQ(*s, 'e')
|| UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
- && strchr("+-0123456789_", s[1]))
+ && memCHRs("+-0123456789_", s[1]))
{
int exp_digits = 0;
const char *save_s = s;
while (1) {
STRLEN chars;
STRLEN have;
- I32 newlen;
+ Size_t newlen;
U8 *end;
/* First, look in our buffer of existing UTF-8 data: */
char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
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