if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
goto finish;
send = s + len;
- while (s < send && *s != '\\')
+ /* This is relying on the SV being "well formed" with a trailing '\0' */
+ while (s < send && !(*s == '\\' && s[1] == '\\'))
s++;
if (s == send)
goto finish;
CopLINE_set(PL_curcop, (line_t)PL_multi_start);
PL_lex_inwhat = PL_sublex_info.sub_inwhat;
+ if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
PL_lex_inpat = PL_sublex_info.sub_op;
else
}
/* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
+ assert(PL_lex_inwhat != OP_TRANSR);
if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
PL_linestr = PL_lex_repl;
PL_lex_inpat = 0;
PERL_ARGS_ASSERT_SCAN_CONST;
+ assert(PL_lex_inwhat != OP_TRANSR);
if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
/* If we are doing a trans and we know we want UTF8 set expectation */
has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
/* Convert first code point to hex, including the
* boiler plate before it */
- sprintf(hex_string, "\\N{U+%X", (unsigned int) uv);
- output_length = strlen(hex_string);
+ output_length =
+ my_snprintf(hex_string, sizeof(hex_string),
+ "\\N{U+%X", (unsigned int) uv);
/* Make sure there is enough space to hold it */
d = off + SvGROW(sv, off
uv = UNICODE_REPLACEMENT;
}
- sprintf(hex_string, ".%X", (unsigned int) uv);
- output_length = strlen(hex_string);
+ output_length =
+ my_snprintf(hex_string, sizeof(hex_string),
+ ".%X", (unsigned int) uv);
d = off + SvGROW(sv, off
+ output_length
};
#endif
+#define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
+STATIC bool
+S_word_takes_any_delimeter(char *p, STRLEN len)
+{
+ return (len == 1 && strchr("msyq", p[0])) ||
+ (len == 2 && (
+ (p[0] == 't' && p[1] == 'r') ||
+ (p[0] == 'q' && strchr("qwxr", p[1]))));
+}
+
/*
yylex
break;
PL_bufptr = s; /* update in case we back off */
if (*s == '=') {
- deprecate(":= for an empty attribute list");
+ Perl_croak(aTHX_
+ "Use of := for an empty attribute list is not allowed");
}
goto grabattrs;
case XATTRBLOCK:
|| isALNUM_lazy_if(PL_last_uni+5,UTF)
))
check_uni();
+ if (*s == '?')
+ deprecate("?PATTERN? without explicit operator");
s = scan_pat(s,OP_MATCH);
TERM(sublex_start());
}
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
/* Some keywords can be followed by any delimiter, including ':' */
- anydelim = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
- (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
- (PL_tokenbuf[0] == 'q' &&
- strchr("qwxr", PL_tokenbuf[1])))));
+ anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
/* x::* is just a word, unless x is "CORE" */
if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
pl_yylval.opval->op_private = 0;
+ pl_yylval.opval->op_flags |= OPf_SPECIAL;
TOKEN(WORD);
}
(
(
*proto == '$' || *proto == '_'
- || *proto == '*'
+ || *proto == '*' || *proto == '+'
)
&& proto[1] == '\0'
)
if (warnillegalproto) {
if (must_be_last)
proto_after_greedy_proto = TRUE;
- if (!strchr("$@%*;[]&\\_", *p)) {
+ if (!strchr("$@%*;[]&\\_+", *p)) {
bad_proto = TRUE;
}
else {
U8 squash;
U8 del;
U8 complement;
+ bool nondestruct = 0;
#ifdef PERL_MAD
char *modstart;
#endif
case 's':
squash = OPpTRANS_SQUASH;
break;
+ case 'r':
+ nondestruct = 1;
+ break;
default:
goto no_more;
}
no_more:
tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
- o = newPVOP(OP_TRANS, 0, (char*)tbl);
+ o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)tbl);
o->op_private &= ~OPpTRANS_ALL;
o->op_private |= del|squash|complement|
(DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
(DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
PL_lex_op = o;
- pl_yylval.ival = OP_TRANS;
+ pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
#ifdef PERL_MAD
if (PL_madskills) {
}
/*
+=for apidoc Amx|OP *|parse_barestmt|U32 flags
+
+Parse a single unadorned Perl statement. This may be a normal imperative
+statement or a declaration that has compile-time effect. It does not
+include any label or other affixture. It is up to the caller to ensure
+that the dynamic parser state (L</PL_parser> et al) is correctly set to
+reflect the source of the code to be parsed and the lexical context for
+the statement.
+
+The op tree representing the statement is returned. This may be a
+null pointer if the statement is null, for example if it was actually
+a subroutine definition (which has compile-time side effects). If not
+null, it will be ops directly implementing the statement, suitable to
+pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
+equivalent op (except for those embedded in a scope contained entirely
+within the statement).
+
+If an error occurs in parsing or compilation, in most cases a valid op
+tree (most likely null) is returned anyway. The error is reflected in
+the parser state, normally resulting in a single exception at the top
+level of parsing which covers all the compilation errors that occurred.
+Some compilation errors, however, will throw an exception immediately.
+
+The I<flags> parameter is reserved for future use, and must always
+be zero.
+
+=cut
+*/
+
+OP *
+Perl_parse_barestmt(pTHX_ U32 flags)
+{
+ if (flags)
+ Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
+ return parse_recdescent_for_op(GRAMBARESTMT);
+}
+
+/*
+=for apidoc Amx|SV *|parse_label|U32 flags
+
+Parse a single label, possibly optional, of the type that may prefix a
+Perl statement. It is up to the caller to ensure that the dynamic parser
+state (L</PL_parser> et al) is correctly set to reflect the source of
+the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
+label is optional, otherwise it is mandatory.
+
+The name of the label is returned in the form of a fresh scalar. If an
+optional label is absent, a null pointer is returned.
+
+If an error occurs in parsing, which can only occur if the label is
+mandatory, a valid label is returned anyway. The error is reflected in
+the parser state, normally resulting in a single exception at the top
+level of parsing which covers all the compilation errors that occurred.
+
+=cut
+*/
+
+SV *
+Perl_parse_label(pTHX_ U32 flags)
+{
+ if (flags & ~PARSE_OPTIONAL)
+ Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
+ if (PL_lex_state == LEX_KNOWNEXT) {
+ PL_parser->yychar = yylex();
+ if (PL_parser->yychar == LABEL) {
+ char *lpv = pl_yylval.pval;
+ STRLEN llen = strlen(lpv);
+ SV *lsv;
+ PL_parser->yychar = YYEMPTY;
+ lsv = newSV_type(SVt_PV);
+ SvPV_set(lsv, lpv);
+ SvCUR_set(lsv, llen);
+ SvLEN_set(lsv, llen+1);
+ SvPOK_on(lsv);
+ return lsv;
+ } else {
+ yyunlex();
+ goto no_label;
+ }
+ } else {
+ char *s, *t;
+ U8 c;
+ STRLEN wlen, bufptr_pos;
+ lex_read_space(0);
+ t = s = PL_bufptr;
+ c = (U8)*s;
+ if (!isIDFIRST_A(c))
+ goto no_label;
+ do {
+ c = (U8)*++t;
+ } while(isWORDCHAR_A(c));
+ wlen = t - s;
+ if (word_takes_any_delimeter(s, wlen))
+ goto no_label;
+ bufptr_pos = s - SvPVX(PL_linestr);
+ PL_bufptr = t;
+ lex_read_space(LEX_KEEP_PREVIOUS);
+ t = PL_bufptr;
+ s = SvPVX(PL_linestr) + bufptr_pos;
+ if (t[0] == ':' && t[1] != ':') {
+ PL_oldoldbufptr = PL_oldbufptr;
+ PL_oldbufptr = s;
+ PL_bufptr = t+1;
+ return newSVpvn(s, wlen);
+ } else {
+ PL_bufptr = s;
+ no_label:
+ if (flags & PARSE_OPTIONAL) {
+ return NULL;
+ } else {
+ qerror(Perl_mess(aTHX_ "Parse error"));
+ return newSVpvs("x");
+ }
+ }
+ }
+}
+
+/*
=for apidoc Amx|OP *|parse_fullstmt|U32 flags
Parse a single complete Perl statement. This may be a normal imperative
-statement, including optional label, or a declaration that has
-compile-time effect. It is up to the caller to ensure that the dynamic
+statement or a declaration that has compile-time effect, and may include
+an optional label. It is up to the caller to ensure that the dynamic
parser state (L</PL_parser> et al) is correctly set to reflect the source
of the code to be parsed and the lexical context for the statement.
https://perl5.git.perl.org / perl5.git / blobdiff