#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.
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" },
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;
char * min_ptr;
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 */
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] == '{'))
)
{
}
term = *t;
open = term;
- if (term && (tmps = strchr("([{< )]}> )]}>",term)))
+ if (term && (tmps = memCHRs("([{< )]}> )]}>",term)))
term = tmps[5];
close = term;
if (open == close)
TOKEN(0);
}
- Eop(OP_NE);
+ ChEop(OP_NE);
}
if (tmp == '~')
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 == '.') {
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 (d && *s != '#') {
const char *c = ipath;
- while (*c && !strchr("; \t\r\n\f\v#", *c))
+ while (*c && !memCHRs("; \t\r\n\f\v#", *c))
c++;
if (c < d)
d = NULL; /* "perl" not in first word; ignore */
&& !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;
}
}
}
TOKEN(';');
}
- return yyl_try(aTHX_ s, len);
+ PL_bufptr = s;
+ return YYL_RETRY;
}
static int
/* 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_ioctl:
LOP(OP_IOCTL,XTERM);
+ case KEY_isa:
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__ISA), "isa is experimental");
+ 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);
char *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)
+ if ( *t && memCHRs("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
/* [perl #16184] */
&& !(t[0] == '=' && t[1] == '>')
&& !(t[0] == ':' && t[1] == ':')
}
static int
-yyl_key_core(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct code c)
+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;
|| (!(key = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
{
Copy(PL_bufptr, PL_tokenbuf, olen, char);
- return yyl_just_a_word(aTHX_ d, olen, orig_keyword, c);
+ return yyl_just_a_word(aTHX_ d, olen, 0, c);
}
if (!key)
Perl_croak(aTHX_ "CORE::%" UTF8f " is not a keyword",
/* 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, 0, 0, c);
+ return yyl_key_core(aTHX_ s, len, c);
return yyl_just_a_word(aTHX_ s, len, 0, c);
}
}
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 '=':
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
if (tmp == '~')
PMop(OP_MATCH);
if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
- && strchr("+-*/%.^&|<",tmp))
+ && memCHRs("+-*/%.^&|<",tmp))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Reversed %c= operator",(int)tmp);
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;
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;
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)) {
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:
* block / parens, boolean operators (&&, ||, //) and branch
* constructs (or, and, if, until, unless, while, err, for).
* Not a very solid hack... */
- if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
+ if (!*w || !memCHRs(";&/|})]oaiuwef!=", *w))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"%s (...) interpreted as function",name);
}
SV **cvp;
SV *cv, *typesv;
const char *why1 = "", *why2 = "", *why3 = "";
+ const char * optional_colon = ":"; /* Only some messages have a colon */
+ char *msg;
PERL_ARGS_ASSERT_NEW_CONSTANT;
/* We assume that this is true: */
- if (*key == 'c') { assert (strEQ(key, "charnames")); }
assert(type || s);
sv_2mortal(sv); /* Parent created it permanently */
- if (!table
- || ! (PL_hints & HINT_LOCALIZE_HH)
- || ! (cvp = hv_fetch(table, key, keylen, FALSE))
- || ! SvOK(*cvp))
+
+ if ( ! table
+ || ! (PL_hints & HINT_LOCALIZE_HH))
{
- char *msg;
-
- /* Here haven't found what we're looking for. If it is charnames,
- * perhaps it needs to be loaded. Try doing that before giving up */
- if (*key == 'c') {
- Perl_load_module(aTHX_
- 0,
- newSVpvs("_charnames"),
- /* version parameter; no need to specify it, as if
- * we get too early a version, will fail anyway,
- * not being able to find '_charnames' */
- NULL,
- newSVpvs(":full"),
- newSVpvs(":short"),
- NULL);
- assert(sp == PL_stack_sp);
- table = GvHV(PL_hintgv);
- if (table
- && (PL_hints & HINT_LOCALIZE_HH)
- && (cvp = hv_fetch(table, key, keylen, FALSE))
- && SvOK(*cvp))
- {
- goto now_ok;
- }
- }
- if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
- msg = Perl_form(aTHX_
- "Constant(%.*s) unknown",
- (int)(type ? typelen : len),
- (type ? type: s));
- }
- else {
- why1 = "$^H{";
- why2 = key;
- why3 = "} is not defined";
- report:
- if (*key == 'c') {
- msg = Perl_form(aTHX_
- /* The +3 is for '\N{'; -4 for that, plus '}' */
- "Unknown charname '%.*s'", (int)typelen - 4, type + 3
- );
- }
- else {
- msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
- (int)(type ? typelen : len),
- (type ? type: s), why1, why2, why3);
- }
- }
- if (error_msg) {
- *error_msg = msg;
- }
- else {
- yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
- }
- return SvREFCNT_inc_simple_NN(sv);
+ why1 = "unknown";
+ optional_colon = "";
+ goto report;
}
- now_ok:
+
+ cvp = hv_fetch(table, key, keylen, FALSE);
+ if (!cvp || !SvOK(*cvp)) {
+ why1 = "$^H{";
+ why2 = key;
+ why3 = "} is not defined";
+ goto report;
+ }
+
cv = *cvp;
if (!pv && s)
pv = newSVpvn_flags(s, len, SVs_TEMP);
LEAVE ;
POPSTACK;
- if (!SvOK(res)) {
- why1 = "Call to &{$^H{";
- why2 = key;
- why3 = "}} did not return a defined value";
- sv = res;
- (void)sv_2mortal(sv);
- goto report;
+ if (SvOK(res)) {
+ return res;
}
- return res;
+ sv = res;
+ (void)sv_2mortal(sv);
+
+ why1 = "Call to &{$^H{";
+ why2 = key;
+ why3 = "}} did not return a defined value";
+
+ report:
+
+ msg = Perl_form(aTHX_ "Constant(%.*s)%s %s%s%s",
+ (int)(type ? typelen : len),
+ (type ? type: s),
+ optional_colon,
+ why1, why2, why3);
+ if (error_msg) {
+ *error_msg = msg;
+ }
+ else {
+ yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
+ }
+ return SvREFCNT_inc_simple_NN(sv);
}
PERL_STATIC_INLINE void
}
if (UNLIKELY(tick_warn && saw_tick && PL_lex_state == LEX_INTERPNORMAL
&& !PL_lex_brackets && ckWARN(WARN_SYNTAX))) {
- char *d;
+ char *this_d;
char *d2;
- Newx(d, *s - olds + saw_tick + 2, char); /* +2 for $# */
- d2 = d;
- SAVEFREEPV(d);
+ Newx(this_d, *s - olds + saw_tick + 2, char); /* +2 for $# */
+ d2 = this_d;
+ SAVEFREEPV(this_d);
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Old package separator used in string");
if (olds[-1] == '#')
}
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"\t(Did you mean \"%" UTF8f "\" instead?)\n",
- UTF8fARG(is_utf8, d2-d, d));
+ UTF8fARG(is_utf8, d2-this_d, this_d));
}
return;
}
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