#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]
#define LEX_INTERPCONST 2 /* NOT USED */
#define LEX_FORMLINE 1 /* expecting a format line */
+/* returned to yyl_try() to request it to retry the parse loop, expected to only
+ be returned directly by yyl_fake_eof(), but functions that call yyl_fake_eof()
+ can also return it.
+
+ yylex (aka Perl_yylex) returns 0 on EOF rather than returning -1,
+ other token values are 258 or higher (see perly.h), so -1 should be
+ a safe value here.
+*/
+#define YYL_RETRY (-1)
#ifdef DEBUGGING
static const char* const lex_state_names[] = {
* Aop : addition-level operator
* AopNOASSIGN : addition-level operator that is never part of .=
* Mop : multiplication-level operator
- * Eop : equality-testing operator
- * Rop : relational operator <= != gt
+ * ChEop : chaining equality-testing operator
+ * NCEop : non-chaining comparison operator at equality precedence
+ * ChRop : chaining relational operator <= != gt
+ * NCRop : non-chaining relational operator isa
*
* Also see LOP and lop() below.
*/
#define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
#define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
#define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \
- REPORT('~')
+ REPORT(PERLY_TILDE)
#define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
#define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP))
#define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
#define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
#define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
#define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
-#define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
-#define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
+#define ChEop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)CHEQOP))
+#define NCEop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)NCEQOP))
+#define ChRop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)CHRELOP))
+#define NCRop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)NCRELOP))
/* This bit of chicanery makes a unary function followed by
* a parenthesis into a function with one argument, highest precedence.
static const struct code no_code = { NULL, NULL, NULL, NULL, NULL, 0, FALSE };
-
#ifdef DEBUGGING
/* how to interpret the pl_yylval associated with the token */
TOKENTYPE_OPVAL
};
+#define DEBUG_TOKEN(Type, Name) \
+ { Name, TOKENTYPE_##Type, #Name }
+
static struct debug_tokens {
const int token;
enum token_type type;
{ ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
{ BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
{ BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
+ { CHEQOP, TOKENTYPE_OPNUM, "CHEQOP" },
+ { CHRELOP, TOKENTYPE_OPNUM, "CHRELOP" },
{ COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
{ CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
{ DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
{ DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
{ ELSE, TOKENTYPE_NONE, "ELSE" },
{ ELSIF, TOKENTYPE_IVAL, "ELSIF" },
- { EQOP, TOKENTYPE_OPNUM, "EQOP" },
{ FOR, TOKENTYPE_IVAL, "FOR" },
{ FORMAT, TOKENTYPE_NONE, "FORMAT" },
{ FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
{ METHOD, TOKENTYPE_OPVAL, "METHOD" },
{ MULOP, TOKENTYPE_OPNUM, "MULOP" },
{ MY, TOKENTYPE_IVAL, "MY" },
+ { NCEQOP, TOKENTYPE_OPNUM, "NCEQOP" },
+ { NCRELOP, TOKENTYPE_OPNUM, "NCRELOP" },
{ NOAMP, TOKENTYPE_NONE, "NOAMP" },
{ NOTOP, TOKENTYPE_NONE, "NOTOP" },
{ OROP, TOKENTYPE_IVAL, "OROP" },
{ OROR, TOKENTYPE_NONE, "OROR" },
{ PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
+ DEBUG_TOKEN (IVAL, PERLY_AMPERSAND),
+ DEBUG_TOKEN (IVAL, PERLY_BRACE_CLOSE),
+ DEBUG_TOKEN (IVAL, PERLY_BRACE_OPEN),
+ DEBUG_TOKEN (IVAL, PERLY_BRACKET_CLOSE),
+ DEBUG_TOKEN (IVAL, PERLY_BRACKET_OPEN),
+ DEBUG_TOKEN (IVAL, PERLY_COLON),
+ DEBUG_TOKEN (IVAL, PERLY_COMMA),
+ DEBUG_TOKEN (IVAL, PERLY_DOT),
+ DEBUG_TOKEN (IVAL, PERLY_EQUAL_SIGN),
+ DEBUG_TOKEN (IVAL, PERLY_EXCLAMATION_MARK),
+ DEBUG_TOKEN (IVAL, PERLY_MINUS),
+ DEBUG_TOKEN (IVAL, PERLY_PAREN_OPEN),
+ DEBUG_TOKEN (IVAL, PERLY_PERCENT_SIGN),
+ DEBUG_TOKEN (IVAL, PERLY_PLUS),
+ DEBUG_TOKEN (IVAL, PERLY_QUESTION_MARK),
+ DEBUG_TOKEN (IVAL, PERLY_SEMICOLON),
+ DEBUG_TOKEN (IVAL, PERLY_SNAIL),
+ DEBUG_TOKEN (IVAL, PERLY_TILDE),
{ PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
{ PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
{ PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
{ PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
{ QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
{ REFGEN, TOKENTYPE_NONE, "REFGEN" },
- { RELOP, TOKENTYPE_OPNUM, "RELOP" },
{ REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
{ SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
{ SIGSUB, TOKENTYPE_NONE, "SIGSUB" },
{ 0, TOKENTYPE_NONE, NULL }
};
+#undef DEBUG_TOKEN
+
/* dump the returned token in rv, plus any optional arg in pl_yylval */
STATIC int
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))
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");
static int
S_postderef(pTHX_ int const funny, char const next)
{
- assert(funny == DOLSHARP || memCHRs("$@%&*", funny));
+ assert(funny == DOLSHARP
+ || memCHRs("$@%&*", funny)
+ || funny == PERLY_SNAIL
+ || funny == PERLY_PERCENT_SIGN
+ || funny == PERLY_AMPERSAND
+ );
if (next == '*') {
PL_expect = XOPERATOR;
if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
- assert('@' == funny || '$' == funny || DOLSHARP == funny);
+ assert(PERLY_SNAIL == funny || '$' == funny || DOLSHARP == funny);
PL_lex_state = LEX_INTERPEND;
- if ('@' == funny)
+ if (PERLY_SNAIL == funny)
force_next(POSTJOIN);
}
force_next(next);
PL_bufptr+=2;
}
else {
- if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
+ if (PERLY_SNAIL == funny && PL_lex_state == LEX_INTERPNORMAL
&& !PL_lex_brackets)
PL_lex_dojoin = 2;
PL_expect = XOPERATOR;
if (yyc != YYEMPTY) {
if (yyc) {
NEXTVAL_NEXTTOKE = PL_parser->yylval;
- if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
+ if (yyc == PERLY_BRACE_OPEN || yyc == HASHBRACK || yyc == PERLY_BRACKET_OPEN) {
PL_lex_allbrackets--;
PL_lex_brackets--;
yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
- } else if (yyc == '('/*)*/) {
+ } else if (yyc == PERLY_PAREN_OPEN) {
PL_lex_allbrackets--;
yyc |= (2<<24);
}
(PL_in_eval ? GV_ADDMULTI
: GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
kind == '$' ? SVt_PV :
- kind == '@' ? SVt_PVAV :
- kind == '%' ? SVt_PVHV :
+ kind == PERLY_SNAIL ? SVt_PVAV :
+ kind == PERLY_PERCENT_SIGN ? SVt_PVHV :
SVt_PVGV
);
}
}
}
+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))
*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;
}
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;
}
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
} else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
type = "q";
typelen = 1;
- } else {
+ } else {
type = "qq";
typelen = 2;
}
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)) {
break;
}
- TOKEN(sigil);
+ switch (sigil) {
+ case ',': TOKEN (PERLY_COMMA);
+ case '@': TOKEN (PERLY_SNAIL);
+ case '%': TOKEN (PERLY_PERCENT_SIGN);
+ default: TOKEN (sigil);
+ }
}
static int
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++;
PL_lex_casestack[PL_lex_casemods] = '\0';
PL_lex_state = LEX_INTERPCONCAT;
NEXTVAL_NEXTTOKE.ival = 0;
- force_next((2<<24)|'(');
+ force_next((2<<24)|PERLY_PAREN_OPEN);
if (*s == 'l')
NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
else if (*s == 'u')
PL_lex_starts = 0;
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (PL_lex_casemods == 1 && PL_lex_inpat)
- TOKEN(',');
+ TOKEN(PERLY_COMMA);
else
AopNOASSIGN(OP_CONCAT);
}
if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=>")) {
s = force_word(PL_bufptr,BAREWORD,FALSE,FALSE);
DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
- OPERATOR('-'); /* unary minus */
+ OPERATOR(PERLY_MINUS); /* unary minus */
}
switch (tmp) {
case 'r': ftst = OP_FTEREAD; break;
else {
if (isSPACE(*s) || !isSPACE(*PL_bufptr))
check_uni();
- OPERATOR('-'); /* unary minus */
+ OPERATOR(PERLY_MINUS); /* unary minus */
}
}
}
else {
if (isSPACE(*s) || !isSPACE(*PL_bufptr))
check_uni();
- OPERATOR('+');
+ OPERATOR(PERLY_PLUS);
}
}
Mop(OP_MODULO);
}
else if (PL_expect == XPOSTDEREF)
- POSTDEREF('%');
+ POSTDEREF(PERLY_PERCENT_SIGN);
PL_tokenbuf[0] = '%';
s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
pl_yylval.ival = 0;
if (!PL_tokenbuf[1]) {
- PREREF('%');
+ PREREF(PERLY_PERCENT_SIGN);
}
if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
&& intuit_more(s, PL_bufend)) {
}
PL_expect = XOPERATOR;
force_ident_maybe_lex('%');
- TERM('%');
+ TERM(PERLY_PERCENT_SIGN);
}
static int
: "Unterminated attribute list" ) );
if (attrs)
op_free(attrs);
- OPERATOR(':');
+ OPERATOR(PERLY_COLON);
}
got_attrs:
}
PL_lex_allbrackets--;
- OPERATOR(':');
+ OPERATOR(PERLY_COLON);
}
static int
const char minus = (PL_tokenbuf[0] == '-');
s = force_word(s + minus, BAREWORD, FALSE, TRUE);
if (minus)
- force_next('-');
+ force_next(PERLY_MINUS);
}
}
/* FALLTHROUGH */
pl_yylval.ival = CopLINE(PL_curcop);
PL_copline = NOLINE; /* invalidate current command line number */
- TOKEN(formbrack ? '=' : '{');
+ TOKEN(formbrack ? PERLY_EQUAL_SIGN : PERLY_BRACE_OPEN);
}
static int
return yylex(); /* ignore fake brackets */
}
- force_next(formbrack ? '.' : '}');
+ force_next(formbrack ? PERLY_DOT : PERLY_BRACE_CLOSE);
if (formbrack) LEAVE_with_name("lex_format");
if (formbrack == 2) { /* means . where arguments were expected */
- force_next(';');
+ force_next(PERLY_SEMICOLON);
TOKEN(FORMRBRACK);
}
- TOKEN(';');
+ TOKEN(PERLY_SEMICOLON);
}
static int
yyl_ampersand(pTHX_ char *s)
{
if (PL_expect == XPOSTDEREF)
- POSTDEREF('&');
+ POSTDEREF(PERLY_AMPERSAND);
s++;
if (*s++ == '&') {
if (PL_tokenbuf[1])
force_ident_maybe_lex('&');
else
- PREREF('&');
+ PREREF(PERLY_AMPERSAND);
- TERM('&');
+ TERM(PERLY_AMPERSAND);
}
static int
TOKEN(0);
}
- Eop(OP_NE);
+ ChEop(OP_NE);
}
if (tmp == '~')
PMop(OP_NOT);
s--;
- OPERATOR('!');
+ OPERATOR(PERLY_EXCLAMATION_MARK);
}
static int
yyl_snail(pTHX_ char *s)
{
if (PL_expect == XPOSTDEREF)
- POSTDEREF('@');
+ POSTDEREF(PERLY_SNAIL);
PL_tokenbuf[0] = '@';
s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
if (PL_expect == XOPERATOR) {
}
pl_yylval.ival = 0;
if (!PL_tokenbuf[1]) {
- PREREF('@');
+ PREREF(PERLY_SNAIL);
}
if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
s = skipspace(s);
}
PL_expect = XOPERATOR;
force_ident_maybe_lex('@');
- TERM('@');
+ TERM(PERLY_SNAIL);
}
static int
static int
yyl_leftsquare(pTHX_ char *s)
{
- char tmp;
-
if (PL_lex_brackets > 100)
Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
PL_lex_brackstack[PL_lex_brackets++] = 0;
PL_lex_allbrackets++;
- tmp = *s++;
- OPERATOR(tmp);
+ s++;
+ OPERATOR(PERLY_BRACKET_OPEN);
}
static int
PL_lex_state = LEX_INTERPEND;
}
}
- TERM(']');
+ TERM(PERLY_BRACKET_CLOSE);
}
static int
Perl_ck_warner_d(aTHX_
packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
"Smartmatch is experimental");
- Eop(OP_SMARTMATCH);
+ NCEop(OP_SMARTMATCH);
}
s++;
if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
PL_expect = XTERM;
s = skipspace(s);
PL_lex_allbrackets++;
- TOKEN('(');
+ TOKEN(PERLY_PAREN_OPEN);
}
static int
s -= 3;
TOKEN(0);
}
- Eop(OP_NCMP);
+ NCEop(OP_NCMP);
}
s--;
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
s -= 2;
TOKEN(0);
}
- Rop(OP_LE);
+ ChRop(OP_LE);
}
s--;
TOKEN(0);
}
- Rop(OP_LT);
+ ChRop(OP_LT);
}
static int
s -= 2;
TOKEN(0);
}
- Rop(OP_GE);
+ ChRop(OP_GE);
}
s--;
TOKEN(0);
}
- Rop(OP_GT);
+ ChRop(OP_GT);
}
static int
}
static int
-yyl_dblquote(pTHX_ char *s, STRLEN len)
+yyl_dblquote(pTHX_ char *s)
{
char *d;
+ STRLEN len;
s = scan_str(s,FALSE,FALSE,FALSE,NULL);
DEBUG_T( {
if (s)
OPERATOR(MY);
}
-static int yyl_try(pTHX_ char*, STRLEN);
+static int yyl_try(pTHX_ char*);
static bool
yyl_eol_needs_semicolon(pTHX_ char **ps)
}
static int
-yyl_fake_eof(pTHX_ U32 fake_eof, bool bof, char *s, STRLEN len)
+yyl_fake_eof(pTHX_ U32 fake_eof, bool bof, char *s)
{
char *d;
if (!lex_next_chunk(fake_eof)) {
CopLINE_dec(PL_curcop);
s = PL_bufptr;
- TOKEN(';'); /* not infinite loop because rsfp is NULL now */
+ TOKEN(PERLY_SEMICOLON); /* not infinite loop because rsfp is NULL now */
}
CopLINE_dec(PL_curcop);
s = PL_bufptr;
&& !instr(s,"indir")
&& instr(PL_origargv[0],"perl"))
{
- dVAR;
char **newargv;
*ipathend = '\0';
we must not do it again */
{
SvPVCLEAR(PL_linestr);
- PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(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_try(aTHX_ s, len);
+ return YYL_RETRY;
}
}
}
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
PL_lex_state = LEX_FORMLINE;
force_next(FORMRBRACK);
- TOKEN(';');
+ TOKEN(PERLY_SEMICOLON);
}
- return yyl_try(aTHX_ s, len);
+ PL_bufptr = s;
+ return YYL_RETRY;
}
static int
op_free(pl_yylval.opval), force_next(PRIVATEREF);
else op_free(c.rv2cv_op), force_next(BAREWORD);
pl_yylval.ival = 0;
- TOKEN('&');
+ TOKEN(PERLY_AMPERSAND);
}
/* If followed by var or block, call it a method (unless sub) */
- if ((*s == '$' || *s == '{') && !c.cv) {
+ 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;
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, len);
+ return yyl_fake_eof(aTHX_ LEX_FAKE_EOF, FALSE, s);
case KEY___SUB__:
FUN0OP(CvCLONE(PL_compcv)
case KEY_cmp:
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
return REPORT(0);
- Eop(OP_SCMP);
+ NCEop(OP_SCMP);
case KEY_caller:
UNI(OP_CALLER);
case KEY_crypt:
-#ifdef FCRYPT
- if (!PL_cryptseen) {
- PL_cryptseen = TRUE;
- init_des();
- }
-#endif
+
LOP(OP_CRYPT,XTERM);
case KEY_chmod:
case KEY_eq:
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
return REPORT(0);
- Eop(OP_SEQ);
+ ChEop(OP_SEQ);
case KEY_exists:
UNI(OP_EXISTS);
case KEY_gt:
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
return REPORT(0);
- Rop(OP_SGT);
+ ChRop(OP_SGT);
case KEY_ge:
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
return REPORT(0);
- Rop(OP_SGE);
+ ChRop(OP_SGE);
case KEY_grep:
LOP(OP_GREPSTART, XREF);
case KEY_isa:
Perl_ck_warner_d(aTHX_
packWARN(WARN_EXPERIMENTAL__ISA), "isa is experimental");
- Rop(OP_ISA);
+ NCRop(OP_ISA);
case KEY_join:
LOP(OP_JOIN,XTERM);
case KEY_lt:
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
return REPORT(0);
- Rop(OP_SLT);
+ ChRop(OP_SLT);
case KEY_le:
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
return REPORT(0);
- Rop(OP_SLE);
+ ChRop(OP_SLE);
case KEY_localtime:
UNI(OP_LOCALTIME);
case KEY_ne:
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
return REPORT(0);
- Eop(OP_SNE);
+ ChEop(OP_SNE);
case KEY_no:
s = tokenize_use(0, s);
static int
yyl_keylookup(pTHX_ char *s, GV *gv)
{
- dVAR;
STRLEN len;
bool anydelim;
I32 key;
}
static int
-yyl_try(pTHX_ char *s, STRLEN len)
+yyl_try(pTHX_ char *s)
{
char *d;
GV *gv = NULL;
+ int tok;
retry:
switch (*s) {
default:
- if (UTF ? isIDFIRST_utf8_safe(s, PL_bufend) : isALNUMC(*s))
- return yyl_keylookup(aTHX_ s, gv);
+ 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 4:
case 26:
/* emulate EOF on ^D or ^Z */
- return yyl_fake_eof(aTHX_ LEX_FAKE_EOF, FALSE, s, len);
+ if ((tok = yyl_fake_eof(aTHX_ LEX_FAKE_EOF, FALSE, s)) != YYL_RETRY)
+ return tok;
+ retry_bufptr:
+ s = PL_bufptr;
+ goto retry;
case 0:
if ((!PL_rsfp || PL_lex_inwhat)
}
if (PL_minus_E)
sv_catpvs(PL_linestr,
- "use feature ':5." STRINGIFY(PERL_VERSION) "';");
+ "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)
update_debugger_info(PL_linestr, NULL, 0);
goto retry;
}
- return yyl_fake_eof(aTHX_ 0, cBOOL(PL_rsfp), s, len);
+ if ((tok = yyl_fake_eof(aTHX_ 0, cBOOL(PL_rsfp), s)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
case '\r':
#ifdef PERL_STRICT_CR
case '\n': {
const bool needs_semicolon = yyl_eol_needs_semicolon(aTHX_ &s);
if (needs_semicolon)
- TOKEN(';');
+ TOKEN(PERLY_SEMICOLON);
else
goto retry;
}
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
TOKEN(0);
s++;
- OPERATOR(',');
+ OPERATOR(PERLY_COMMA);
case ':':
if (s[1] == ':')
return yyl_just_a_word(aTHX_ s, 0, 0, no_code);
CLINE;
s++;
PL_expect = XSTATE;
- TOKEN(';');
+ TOKEN(PERLY_SEMICOLON);
case ')':
return yyl_rightparen(aTHX_ s);
case '=':
if (s[1] == '=' && (s == PL_linestart || s[-1] == '\n')
- && memBEGINs(s + 2, (STRLEN) (PL_bufend - s + 2), "====="))
+ && memBEGINs(s + 2, (STRLEN) (PL_bufend - (s + 2)), "====="))
{
s = vcs_conflict_marker(s + 7);
goto retry;
s -= 2;
TOKEN(0);
}
- Eop(OP_EQ);
+ ChEop(OP_EQ);
}
if (tmp == '>') {
if (!PL_lex_allbrackets
s -= 2;
TOKEN(0);
}
- OPERATOR(',');
+ OPERATOR(PERLY_COMMA);
}
if (tmp == '~')
PMop(OP_MATCH);
pl_yylval.ival = 0;
OPERATOR(ASSIGNOP);
- case '!':
+ case '!':
return yyl_bang(aTHX_ s + 1);
case '<':
if (s[1] == '<' && (s == PL_linestart || s[-1] == '\n')
- && memBEGINs(s+2, (STRLEN) (PL_bufend - (s+2)), "<<<<<"))
+ && memBEGINs(s + 2, (STRLEN) (PL_bufend - (s + 2)), "<<<<<"))
{
s = vcs_conflict_marker(s + 7);
goto retry;
case '>':
if (s[1] == '>' && (s == PL_linestart || s[-1] == '\n')
- && memBEGINs(s + 2, (STRLEN) (PL_bufend - s + 2), ">>>>>"))
+ && memBEGINs(s + 2, (STRLEN) (PL_bufend - (s + 2)), ">>>>>"))
{
s = vcs_conflict_marker(s + 7);
goto retry;
TOKEN(0);
}
PL_lex_allbrackets++;
- OPERATOR('?');
+ OPERATOR(PERLY_QUESTION_MARK);
case '.':
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
return yyl_sglquote(aTHX_ s);
case '"':
- return yyl_dblquote(aTHX_ s, len);
+ return yyl_dblquote(aTHX_ s);
case '`':
return yyl_backtick(aTHX_ s);
TERM(THING);
}
else if ((*start == ':' && start[1] == ':')
- || (PL_expect == XSTATE && *start == ':'))
- return yyl_keylookup(aTHX_ s, gv);
+ || (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 == ':')
- return yyl_keylookup(aTHX_ s, gv);
+ 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
}
}
}
- return yyl_keylookup(aTHX_ s, gv);
+ if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
case 'x':
if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
s++;
Mop(OP_REPEAT);
}
- return yyl_keylookup(aTHX_ s, gv);
+ if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
case '_':
case 'a': case 'A':
case 'X':
case 'y': case 'Y':
case 'z': case 'Z':
- return yyl_keylookup(aTHX_ s, gv);
+ if ((tok = yyl_keylookup(aTHX_ s, gv)) != YYL_RETRY)
+ return tok;
+ goto retry_bufptr;
}
}
int
Perl_yylex(pTHX)
{
- dVAR;
char *s = PL_bufptr;
if (UNLIKELY(PL_parser->recheck_utf8_validity)) {
PL_lex_state = LEX_INTERPNORMAL;
if (PL_lex_dojoin) {
NEXTVAL_NEXTTOKE.ival = 0;
- force_next(',');
+ force_next(PERLY_COMMA);
force_ident("\"", '$');
NEXTVAL_NEXTTOKE.ival = 0;
force_next('$');
NEXTVAL_NEXTTOKE.ival = 0;
- force_next((2<<24)|'(');
+ force_next((2<<24)|PERLY_PAREN_OPEN);
NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
force_next(FUNC);
}
s = PL_bufptr;
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (!PL_lex_casemods && PL_lex_inpat)
- TOKEN(',');
+ TOKEN(PERLY_COMMA);
else
AopNOASSIGN(OP_CONCAT);
}
force_next(THING);
PL_parser->lex_shared->re_eval_start = NULL;
PL_expect = XTERM;
- return REPORT(',');
+ return REPORT(PERLY_COMMA);
}
/* FALLTHROUGH */
if (PL_lex_starts++) {
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (!PL_lex_casemods && PL_lex_inpat)
- TOKEN(',');
+ TOKEN(PERLY_COMMA);
else
AopNOASSIGN(OP_CONCAT);
}
expecting an operator) have been a sigil.
*/
bool expected_operator = (PL_expect == XOPERATOR);
- int ret = yyl_try(aTHX_ s, 0);
+ int ret = yyl_try(aTHX_ s);
switch (pl_yylval.ival) {
case OP_BIT_AND:
case OP_MODULO:
SV **cvp;
SV *cv, *typesv;
const char *why1 = "", *why2 = "", *why3 = "";
+ const char * optional_colon = ":"; /* Only some messages have a colon */
+ char *msg;
PERL_ARGS_ASSERT_NEW_CONSTANT;
/* We assume that this is true: */
- if (*key == 'c') { assert (strEQ(key, "charnames")); }
assert(type || s);
sv_2mortal(sv); /* Parent created it permanently */
- if (!table
- || ! (PL_hints & HINT_LOCALIZE_HH)
- || ! (cvp = hv_fetch(table, key, keylen, FALSE))
- || ! SvOK(*cvp))
+
+ if ( ! table
+ || ! (PL_hints & HINT_LOCALIZE_HH))
{
- char *msg;
-
- /* Here haven't found what we're looking for. If it is charnames,
- * perhaps it needs to be loaded. Try doing that before giving up */
- if (*key == 'c') {
- Perl_load_module(aTHX_
- 0,
- newSVpvs("_charnames"),
- /* version parameter; no need to specify it, as if
- * we get too early a version, will fail anyway,
- * not being able to find '_charnames' */
- NULL,
- newSVpvs(":full"),
- newSVpvs(":short"),
- NULL);
- assert(sp == PL_stack_sp);
- table = GvHV(PL_hintgv);
- if (table
- && (PL_hints & HINT_LOCALIZE_HH)
- && (cvp = hv_fetch(table, key, keylen, FALSE))
- && SvOK(*cvp))
- {
- goto now_ok;
- }
- }
- if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
- msg = Perl_form(aTHX_
- "Constant(%.*s) unknown",
- (int)(type ? typelen : len),
- (type ? type: s));
- }
- else {
- why1 = "$^H{";
- why2 = key;
- why3 = "} is not defined";
- report:
- if (*key == 'c') {
- msg = Perl_form(aTHX_
- /* The +3 is for '\N{'; -4 for that, plus '}' */
- "Unknown charname '%.*s'", (int)typelen - 4, type + 3
- );
- }
- else {
- msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
- (int)(type ? typelen : len),
- (type ? type: s), why1, why2, why3);
- }
- }
- if (error_msg) {
- *error_msg = msg;
- }
- else {
- yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
- }
- return SvREFCNT_inc_simple_NN(sv);
+ why1 = "unknown";
+ optional_colon = "";
+ goto report;
}
- now_ok:
+
+ cvp = hv_fetch(table, key, keylen, FALSE);
+ if (!cvp || !SvOK(*cvp)) {
+ why1 = "$^H{";
+ why2 = key;
+ why3 = "} is not defined";
+ goto report;
+ }
+
cv = *cvp;
if (!pv && s)
pv = newSVpvn_flags(s, len, SVs_TEMP);
LEAVE ;
POPSTACK;
- if (!SvOK(res)) {
- why1 = "Call to &{$^H{";
- why2 = key;
- why3 = "}} did not return a defined value";
- sv = res;
- (void)sv_2mortal(sv);
- goto report;
+ if (SvOK(res)) {
+ return res;
}
- return res;
+ sv = res;
+ (void)sv_2mortal(sv);
+
+ why1 = "Call to &{$^H{";
+ why2 = key;
+ why3 = "}} did not return a defined value";
+
+ report:
+
+ msg = Perl_form(aTHX_ "Constant(%.*s)%s %s%s%s",
+ (int)(type ? typelen : len),
+ (type ? type: s),
+ optional_colon,
+ why1, why2, why3);
+ if (error_msg) {
+ *error_msg = msg;
+ }
+ else {
+ yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
+ }
+ return SvREFCNT_inc_simple_NN(sv);
}
PERL_STATIC_INLINE void
if (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';
}
}
/* if we allocated too much space, give some back */
if (SvCUR(sv) + 5 < SvLEN(sv)) {
SvLEN_set(sv, SvCUR(sv) + 1);
- SvPV_renew(sv, SvLEN(sv));
+ SvPV_shrink_to_cur(sv);
}
/* decide whether this is the first or second quoted string we've read
\d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
\.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
0b[01](_?[01])* binary integers
- 0[0-7](_?[0-7])* octal integers
+ 0o?[0-7](_?[0-7])* octal integers
0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
NV hexfp_mult = 1.0;
UV high_non_zero = 0; /* highest digit */
int non_zero_integer_digits = 0;
+ bool new_octal = FALSE; /* octal with "0o" prefix */
PERL_ARGS_ASSERT_SCAN_NUM;
"",
"037777777777",
"0xffffffff" };
- const char *base, *Base, *max;
/* check for hex */
if (isALPHA_FOLD_EQ(s[1], 'x')) {
else {
shift = 3;
s++;
+ if (isALPHA_FOLD_EQ(*s, 'o')) {
+ s++;
+ just_zero = FALSE;
+ new_octal = TRUE;
+ }
}
if (*s == '_') {
lastub = s++;
}
- base = bases[shift];
- Base = Bases[shift];
- max = maxima[shift];
-
/* read the rest of the number */
for (;;) {
/* x is used in the overflow test,
n = (NV) u;
Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
"Integer overflow in %s number",
- base);
+ bases[shift]);
} else
u = x | b; /* add the digit to the end */
}
}
}
- if (shift != 3 && !has_digs) {
- /* 0x or 0b with no digits, treat it as an error.
+ if (!just_zero && !has_digs) {
+ /* 0x, 0o or 0b with no digits, treat it as an error.
Originally this backed up the parse before the b or
x, but that has the potential for silent changes in
behaviour, like for: "0x.3" and "0x+$foo".
if (*d) ++d; /* so the user sees the bad non-digit */
PL_bufptr = (char *)d; /* so yyerror reports the context */
yyerror(Perl_form(aTHX_ "No digits found for %s literal",
- shift == 4 ? "hexadecimal" : "binary"));
+ bases[shift]));
PL_bufptr = oldbp;
}
if (n > 4294967295.0)
Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
"%s number > %s non-portable",
- Base, max);
+ Bases[shift],
+ new_octal ? "0o37777777777" : maxima[shift]);
sv = newSVnv(n);
}
else {
if (u > 0xffffffff)
Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
"%s number > %s non-portable",
- Base, max);
+ Bases[shift],
+ new_octal ? "0o37777777777" : maxima[shift]);
#endif
sv = newSVuv(u);
}
s = start + 2;
break;
case 3:
+ if (new_octal) {
+ *d++ = 'o';
+ s = start + 2;
+ break;
+ }
s = start + 1;
break;
case 1:
* processing unconditionally */
if (s != NULL) {
- if (!yychar || (yychar == ';' && !PL_rsfp))
+ if (!yychar || (yychar == PERLY_SEMICOLON && !PL_rsfp))
sv_catpvs(where_sv, "at EOF");
else if ( PL_oldoldbufptr
&& PL_bufptr > PL_oldoldbufptr
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;
https://perl5.git.perl.org / perl5.git / blobdiff