}
/*
-=for apidoc Amx|void|lex_stuff_pvn|char *pv|STRLEN len|U32 flags
+=for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
*/
void
-Perl_lex_stuff_pvn(pTHX_ char *pv, STRLEN len, U32 flags)
+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))
goto plain_copy;
} else {
STRLEN highhalf = 0;
- char *p, *e = pv+len;
+ const char *p, *e = pv+len;
for (p = pv; p != e; p++)
highhalf += !!(((U8)*p) & 0x80);
if (!highhalf)
lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
bufptr = PL_parser->bufptr;
Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
+ SvCUR_set(PL_parser->linestr,
+ SvCUR(PL_parser->linestr) + len+highhalf);
PL_parser->bufend += len+highhalf;
for (p = pv; p != e; p++) {
U8 c = (U8)*p;
} else {
if (flags & LEX_STUFF_UTF8) {
STRLEN highhalf = 0;
- char *p, *e = pv+len;
+ const char *p, *e = pv+len;
for (p = pv; p != e; p++) {
U8 c = (U8)*p;
if (c >= 0xc4) {
lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
bufptr = PL_parser->bufptr;
Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
+ SvCUR_set(PL_parser->linestr,
+ SvCUR(PL_parser->linestr) + len-highhalf);
PL_parser->bufend += len-highhalf;
for (p = pv; p != e; p++) {
U8 c = (U8)*p;
lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
bufptr = PL_parser->bufptr;
Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
+ SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
PL_parser->bufend += len;
Copy(pv, bufptr, len, char);
}
Normally it is not necessarily to do this directly, because it suffices to
use the implicit discarding behaviour of L</lex_next_chunk> and things
based on it. However, if a token stretches across multiple lines,
-and the lexing code has kept multiple lines of text in the buffer fof
+and the lexing code has kept multiple lines of text in the buffer for
that purpose, then after completion of the token it would be wise to
explicitly discard the now-unneeded earlier lines, to avoid future
multi-line tokens growing the buffer without bound.
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");
d += len;
}
SvREFCNT_dec(res);
- }
+
+ /* Deprecate non-approved name syntax */
+ if (ckWARN_d(WARN_DEPRECATED)) {
+ bool problematic = FALSE;
+ char* i = s;
+
+ /* For non-ut8 input, look to see that the first
+ * character is an alpha, then loop through the rest
+ * checking that each is a continuation */
+ if (! this_utf8) {
+ if (! isALPHAU(*i)) problematic = TRUE;
+ else for (i = s + 1; i < e; i++) {
+ if (isCHARNAME_CONT(*i)) continue;
+ problematic = TRUE;
+ break;
+ }
+ }
+ else {
+ /* Similarly for utf8. For invariants can check
+ * directly. We accept anything above the latin1
+ * range because it is immaterial to Perl if it is
+ * correct or not, and is expensive to check. But
+ * it is fairly easy in the latin1 range to convert
+ * the variants into a single character and check
+ * those */
+ if (UTF8_IS_INVARIANT(*i)) {
+ if (! isALPHAU(*i)) problematic = TRUE;
+ } else if (UTF8_IS_DOWNGRADEABLE_START(*i)) {
+ if (! isALPHAU(UNI_TO_NATIVE(UTF8_ACCUMULATE(*i,
+ *(i+1)))))
+ {
+ problematic = TRUE;
+ }
+ }
+ if (! problematic) for (i = s + UTF8SKIP(s);
+ i < e;
+ i+= UTF8SKIP(i))
+ {
+ if (UTF8_IS_INVARIANT(*i)) {
+ if (isCHARNAME_CONT(*i)) continue;
+ } else if (! UTF8_IS_DOWNGRADEABLE_START(*i)) {
+ continue;
+ } else if (isCHARNAME_CONT(
+ UNI_TO_NATIVE(
+ UTF8_ACCUMULATE(*i, *(i+1)))))
+ {
+ continue;
+ }
+ problematic = TRUE;
+ break;
+ }
+ }
+ if (problematic) {
+ /* The e-i passed to the final %.*s makes sure that
+ * should the trailing NUL be missing that this
+ * print won't run off the end of the string */
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ "Deprecated character in \\N{...}; marked by <-- HERE in \\N{%.*s<-- HERE %.*s", i - s + 1, s, e - i, i + 1);
+ }
+ }
+ } /* End \N{NAME} */
#ifdef EBCDIC
if (!dorange)
native_range = FALSE; /* \N{} is defined to be Unicode */
case 'c':
s++;
if (s < send) {
- U8 c = *s++;
-#ifdef EBCDIC
- if (isLOWER(c))
- c = toUPPER(c);
-#endif
- *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
+ *d++ = grok_bslash_c(*s++, 1);
}
else {
yyerror("Missing control char name in \\c");
}
}
- if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
+ if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
PL_tokenbuf[0] = '@';
s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
sizeof PL_tokenbuf - 1, FALSE);
/* Is this a label? */
if (!anydelim && PL_expect == XSTATE
&& d < PL_bufend && *d == ':' && *(d + 1) != ':') {
- if (tmp)
- Perl_croak(aTHX_ "Can't use keyword '%s' as a label", PL_tokenbuf);
s = d + 1;
pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
CLINE;
}
/* charnames doesn't work well if there have been errors found */
- if (PL_error_count > 0 && strEQ(key,"charnames")) return res;
+ if (PL_error_count > 0 && strEQ(key,"charnames"))
+ return &PL_sv_undef;
cvp = hv_fetch(table, key, keylen, FALSE);
if (!cvp || !SvOK(*cvp)) {
return pmfl;
}
-void
-Perl_pmflag(pTHX_ U32* pmfl, int ch)
-{
- PERL_ARGS_ASSERT_PMFLAG;
-
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Perl_pmflag() is deprecated, and will be removed from the XS API");
-
- if (ch<256) {
- *pmfl = S_pmflag(*pmfl, (char)ch);
- }
-}
-
STATIC char *
S_scan_pat(pTHX_ char *start, I32 type)
{
SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
SV *const utf8_buffer = filter;
IV status = IoPAGE(filter);
- const bool reverse = (bool) IoLINES(filter);
+ const bool reverse = cBOOL(IoLINES(filter));
I32 retval;
/* As we're automatically added, at the lowest level, and hence only called
projects / p5sagit/p5-mst-13.2.git / blobdiff