}
-#include "toke_on_crack.c.inc"
-
-
static void free_defspec(pTHX_ void *vp) {
DefaultParamSpec *dp = vp;
op_free(dp->init);
MY_ATTR_SPECIAL = 0x04
};
+static void my_sv_cat_c(pTHX_ SV *sv, U32 c) {
+ char ds[UTF8_MAXBYTES + 1], *d;
+ d = uvchr_to_utf8(ds, c);
+ if (d - ds > 1) {
+ sv_utf8_upgrade(sv);
+ }
+ sv_catpvn(sv, ds, d - ds);
+}
+
+static bool my_is_uni_xidfirst(pTHX_ UV c) {
+ U8 tmpbuf[UTF8_MAXBYTES + 1];
+ uvchr_to_utf8(tmpbuf, c);
+ return is_utf8_xidfirst(tmpbuf);
+}
+
+static bool my_is_uni_xidcont(pTHX_ UV c) {
+ U8 tmpbuf[UTF8_MAXBYTES + 1];
+ uvchr_to_utf8(tmpbuf, c);
+ return is_utf8_xidcont(tmpbuf);
+}
+
+static SV *my_scan_word(pTHX_ bool allow_package) {
+ bool at_start, at_substart;
+ I32 c;
+ SV *sv = sv_2mortal(newSVpvs(""));
+ if (lex_bufutf8()) {
+ SvUTF8_on(sv);
+ }
+
+ at_start = at_substart = TRUE;
+ c = lex_peek_unichar(0);
+
+ while (c != -1) {
+ if (at_substart ? my_is_uni_xidfirst(aTHX_ c) : my_is_uni_xidcont(aTHX_ c)) {
+ lex_read_unichar(0);
+ my_sv_cat_c(aTHX_ sv, c);
+ at_substart = FALSE;
+ c = lex_peek_unichar(0);
+ } else if (allow_package && !at_substart && c == '\'') {
+ lex_read_unichar(0);
+ c = lex_peek_unichar(0);
+ if (!my_is_uni_xidfirst(aTHX_ c)) {
+ lex_stuff_pvs("'", 0);
+ break;
+ }
+ sv_catpvs(sv, "'");
+ at_substart = TRUE;
+ } else if (allow_package && (at_start || !at_substart) && c == ':') {
+ lex_read_unichar(0);
+ if (lex_peek_unichar(0) != ':') {
+ lex_stuff_pvs(":", 0);
+ break;
+ }
+ lex_read_unichar(0);
+ c = lex_peek_unichar(0);
+ if (!my_is_uni_xidfirst(aTHX_ c)) {
+ lex_stuff_pvs("::", 0);
+ break;
+ }
+ sv_catpvs(sv, "::");
+ at_substart = TRUE;
+ } else {
+ break;
+ }
+ at_start = FALSE;
+ }
+
+ return SvCUR(sv) ? sv : NULL;
+}
+
+static SV *my_scan_parens_tail(pTHX_ bool keep_backslash) {
+ I32 c, nesting;
+ SV *sv;
+ line_t start;
+
+ start = CopLINE(PL_curcop);
+
+ sv = sv_2mortal(newSVpvs(""));
+ if (lex_bufutf8()) {
+ SvUTF8_on(sv);
+ }
+
+ nesting = 0;
+ for (;;) {
+ c = lex_read_unichar(0);
+ if (c == EOF) {
+ CopLINE_set(PL_curcop, start);
+ return NULL;
+ }
+
+ if (c == '\\') {
+ c = lex_read_unichar(0);
+ if (c == EOF) {
+ CopLINE_set(PL_curcop, start);
+ return NULL;
+ }
+ if (keep_backslash || (c != '(' && c != ')')) {
+ sv_catpvs(sv, "\\");
+ }
+ } else if (c == '(') {
+ nesting++;
+ } else if (c == ')') {
+ if (!nesting) {
+ break;
+ }
+ nesting--;
+ }
+
+ my_sv_cat_c(aTHX_ sv, c);
+ }
+
+ return sv;
+}
+
+static void my_check_prototype(pTHX_ const SV *declarator, SV *proto) {
+ char *start, *r, *w, *end;
+ STRLEN len;
+
+ /* strip spaces */
+ start = SvPV(proto, len);
+ end = start + len;
+
+ for (w = r = start; r < end; r++) {
+ if (!isSPACE(*r)) {
+ *w++ = *r;
+ }
+ }
+ *w = '\0';
+ SvCUR_set(proto, w - start);
+ end = w;
+ len = end - start;
+
+ if (!ckWARN(WARN_ILLEGALPROTO)) {
+ return;
+ }
+
+ /* check for bad characters */
+ if (strspn(start, "$@%*;[]&\\_+") != len) {
+ SV *dsv = newSVpvs_flags("", SVs_TEMP);
+ warner(
+ packWARN(WARN_ILLEGALPROTO),
+ "Illegal character in prototype for %"SVf" : %s",
+ SVfARG(declarator),
+ SvUTF8(proto)
+ ? sv_uni_display(
+ dsv,
+ proto,
+ len,
+ UNI_DISPLAY_ISPRINT
+ )
+ : pv_pretty(dsv, start, len, 60, NULL, NULL,
+ PERL_PV_ESCAPE_NONASCII
+ )
+ );
+ return;
+ }
+
+ for (r = start; r < end; r++) {
+ switch (*r) {
+ default:
+ warner(
+ packWARN(WARN_ILLEGALPROTO),
+ "Illegal character in prototype for %"SVf" : %s",
+ SVfARG(declarator), r
+ );
+ return;
+
+ case '_':
+ if (r[1] && !strchr(";@%", *r)) {
+ warner(
+ packWARN(WARN_ILLEGALPROTO),
+ "Illegal character after '_' in prototype for %"SVf" : %s",
+ SVfARG(declarator), r
+ );
+ return;
+ }
+ break;
+
+ case '@':
+ case '%':
+ if (r[1]) {
+ warner(
+ packWARN(WARN_ILLEGALPROTO),
+ "prototype after '%c' for %"SVf": %s",
+ *r, SVfARG(declarator), r + 1
+ );
+ return;
+ }
+ break;
+
+ case '\\':
+ r++;
+ if (strchr("$@%&*", *r)) {
+ break;
+ }
+ if (*r == '[') {
+ r++;
+ for (; r < end && *r != ']'; r++) {
+ if (!strchr("$@%&*", *r)) {
+ break;
+ }
+ }
+ if (*r == ']' && r[-1] != '[') {
+ break;
+ }
+ }
+ warner(
+ packWARN(WARN_ILLEGALPROTO),
+ "Illegal character after '\\' in prototype for %"SVf" : %s",
+ SVfARG(declarator), r
+ );
+ return;
+
+ case '$':
+ case '*':
+ case '&':
+ case ';':
+ case '+':
+ break;
+ }
+ }
+}
+
static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const KWSpec *spec) {
SV *declarator;
I32 floor_ix;
OP **attrs_sentinel, *body;
unsigned builtin_attrs;
STRLEN len;
- char *s;
I32 c;
declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len));
/* function name */
saw_name = NULL;
- s = PL_parser->bufptr;
- if ((spec->flags & FLAG_NAME_OK) && (len = S_scan_word(aTHX_ s, TRUE))) {
- saw_name = sv_2mortal(newSVpvn_flags(s, len, PARSING_UTF ? SVf_UTF8 : 0));
+ if ((spec->flags & FLAG_NAME_OK) && (saw_name = my_scan_word(aTHX_ TRUE))) {
if (PL_parser->expect != XSTATE) {
/* bail out early so we don't predeclare $saw_name */
builtin_attrs |= MY_ATTR_SPECIAL;
}
- lex_read_to(s + len);
lex_read_space(0);
} else if (!(spec->flags & FLAG_ANON_OK)) {
- croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s);
+ croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - PL_parser->bufptr), PL_parser->bufptr);
} else {
sv_catpvs(declarator, " (anon)");
}
lex_read_unichar(0);
lex_read_space(0);
- s = PL_parser->bufptr;
- if (!(len = S_scan_word(aTHX_ s, FALSE))) {
+ if (!(param = my_scan_word(aTHX_ FALSE))) {
croak("In %"SVf": missing identifier", SVfARG(declarator));
}
- param = sv_2mortal(newSVpvf("%c%.*s", sigil, (int)len, s));
+ sv_insert(param, 0, 0, &sigil, 1);
if (saw_slurpy) {
croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_slurpy), SVfARG(param));
}
saw_slurpy = param;
}
av_push(params, SvREFCNT_inc_simple_NN(param));
- lex_read_to(s + len);
lex_read_space(0);
c = lex_peek_unichar(0);
lex_stuff_pvs(":", 0);
c = ':';
} else {
- proto = sv_2mortal(newSVpvs(""));
- if (!S_scan_str(aTHX_ proto, FALSE, FALSE)) {
+ lex_read_unichar(0);
+ if (!(proto = my_scan_parens_tail(aTHX_ FALSE))) {
croak("In %"SVf": prototype not terminated", SVfARG(declarator));
}
- S_check_prototype(aTHX_ declarator, proto);
+ my_check_prototype(aTHX_ declarator, proto);
lex_read_space(0);
c = lex_peek_unichar(0);
}
for (;;) {
SV *attr;
- s = PL_parser->bufptr;
- if (!(len = S_scan_word(aTHX_ s, FALSE))) {
+ if (!(attr = my_scan_word(aTHX_ FALSE))) {
break;
}
- attr = sv_2mortal(newSVpvn_flags(s, len, PARSING_UTF ? SVf_UTF8 : 0));
-
- lex_read_to(s + len);
lex_read_space(0);
c = lex_peek_unichar(0);
attr = NULL;
}
} else {
- SV *sv = sv_2mortal(newSVpvs(""));
- if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) {
+ SV *sv;
+ lex_read_unichar(0);
+ if (!(sv = my_scan_parens_tail(aTHX_ TRUE))) {
croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator));
}
+ sv_catpvs(attr, "(");
sv_catsv(attr, sv);
+ sv_catpvs(attr, ")");
lex_read_space(0);
c = lex_peek_unichar(0);
+++ /dev/null
-/*
- * This code was copied from perl/toke.c and subsequently butchered
- * by Lukas Mai (2012).
- */
-/* vi: set ft=c: */
-
-/* vvvvvvvvvvvvvvvvvvvvv I HAVE NO IDEA WHAT I'M DOING vvvvvvvvvvvvvvvvvvvv */
-#define PL_linestr (PL_parser->linestr)
-#define PL_copline (PL_parser->copline)
-#define PL_bufptr (PL_parser->bufptr)
-#define PL_bufend (PL_parser->bufend)
-#define PL_multi_start (PL_parser->multi_start)
-#define PL_multi_open (PL_parser->multi_open)
-#define PL_multi_close (PL_parser->multi_close)
-#define PL_multi_end (PL_parser->multi_end)
-#define PL_rsfp (PL_parser->rsfp)
-
-#define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
-
-#ifdef USE_UTF8_SCRIPTS
-# define PARSING_UTF (!IN_BYTES)
-#else
-# define PARSING_UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
-#endif
-
-static STRLEN S_scan_word(pTHX_ const char *start, int allow_package) {
- const char *s = start;
- for (;;) {
- if (isALNUM(*s) || (!PARSING_UTF && isALNUMC_L1(*s))) { /* UTF handled below */
- s++;
- } else if (allow_package && s > start && *s == '\'' && isIDFIRST_lazy_if(s+1, PARSING_UTF)) {
- s++;
- } else if (allow_package && s[0] == ':' && s[1] == ':' && isIDFIRST_lazy_if(s+2, PARSING_UTF)) {
- s += 2;
- } else if (PARSING_UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
- do {
- s += UTF8SKIP(s);
- } while (UTF8_IS_CONTINUED(*s) && is_utf8_mark((U8*)s));
- } else {
- return s - start;
- }
- }
-}
-
-static char *S_scan_str(pTHX_ SV *sv, int keep_quoted, int keep_delims) {
- dVAR;
- char *start = PL_bufptr;
- const char *tmps; /* temp string, used for delimiter matching */
- char *s = start; /* current position in the buffer */
- char term; /* terminating character */
- char *to; /* current position in the sv's data */
- I32 brackets = 1; /* bracket nesting level */
- bool has_utf8 = FALSE; /* is there any utf8 content? */
- I32 termcode; /* terminating char. code */
- U8 termstr[UTF8_MAXBYTES]; /* terminating string */
- STRLEN termlen; /* length of terminating string */
- int last_off = 0; /* last position for nesting bracket */
-
- /* XXX ATTENTION: we don't skip whitespace! */
-
- /* mark where we are, in case we need to report errors */
- CLINE;
-
- /* after skipping whitespace, the next character is the terminator */
- term = *s;
- if (!PARSING_UTF) {
- termcode = termstr[0] = term;
- termlen = 1;
- }
- else {
- termcode = IF_HAVE_PERL_5_16(
- utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen),
- utf8_to_uvchr((U8*)s, &termlen)
- );
- Copy(s, termstr, termlen, U8);
- if (!UTF8_IS_INVARIANT(term))
- has_utf8 = TRUE;
- }
-
- /* mark where we are */
- PL_multi_start = CopLINE(PL_curcop);
- PL_multi_open = term;
-
- /* find corresponding closing delimiter */
- if (term && (tmps = strchr("([{< )]}> )]}>",term)))
- termcode = termstr[0] = term = tmps[5];
-
- PL_multi_close = term;
-
- {
- STRLEN dummy;
- SvPV_force(sv, dummy);
- sv_setpvs(sv, "");
- SvGROW(sv, 80);
- }
-
- /* move past delimiter and try to read a complete string */
- if (keep_delims)
- sv_catpvn(sv, s, termlen);
- s += termlen;
- for (;;) {
- if (PL_encoding && !PARSING_UTF) {
- bool cont = TRUE;
-
- while (cont) {
- int offset = s - SvPVX_const(PL_linestr);
- const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
- &offset, (char*)termstr, termlen);
- const char * const ns = SvPVX_const(PL_linestr) + offset;
- char * const svlast = SvEND(sv) - 1;
-
- for (; s < ns; s++) {
- if (*s == '\n' && !PL_rsfp &&
- IF_HAVE_PERL_5_16(
- !PL_parser->filtered,
- TRUE
- )
- )
- CopLINE_inc(PL_curcop);
- }
- if (!found)
- goto read_more_line;
- else {
- /* handle quoted delimiters */
- if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
- const char *t;
- for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
- t--;
- if ((svlast-1 - t) % 2) {
- if (!keep_quoted) {
- *(svlast-1) = term;
- *svlast = '\0';
- SvCUR_set(sv, SvCUR(sv) - 1);
- }
- continue;
- }
- }
- if (PL_multi_open == PL_multi_close) {
- cont = FALSE;
- }
- else {
- const char *t;
- char *w;
- for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
- /* At here, all closes are "was quoted" one,
- so we don't check PL_multi_close. */
- if (*t == '\\') {
- if (!keep_quoted && *(t+1) == PL_multi_open)
- t++;
- else
- *w++ = *t++;
- }
- else if (*t == PL_multi_open)
- brackets++;
-
- *w = *t;
- }
- if (w < t) {
- *w++ = term;
- *w = '\0';
- SvCUR_set(sv, w - SvPVX_const(sv));
- }
- last_off = w - SvPVX(sv);
- if (--brackets <= 0)
- cont = FALSE;
- }
- }
- }
- if (!keep_delims) {
- SvCUR_set(sv, SvCUR(sv) - 1);
- *SvEND(sv) = '\0';
- }
- break;
- }
-
- /* extend sv if need be */
- SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
- /* set 'to' to the next character in the sv's string */
- to = SvPVX(sv)+SvCUR(sv);
-
- /* if open delimiter is the close delimiter read unbridle */
- if (PL_multi_open == PL_multi_close) {
- for (; s < PL_bufend; s++,to++) {
- /* embedded newlines increment the current line number */
- if (*s == '\n' && !PL_rsfp &&
- IF_HAVE_PERL_5_16(
- !PL_parser->filtered,
- 1
- )
- )
- CopLINE_inc(PL_curcop);
- /* handle quoted delimiters */
- if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
- if (!keep_quoted && s[1] == term)
- s++;
- /* any other quotes are simply copied straight through */
- else
- *to++ = *s++;
- }
- /* terminate when run out of buffer (the for() condition), or
- have found the terminator */
- else if (*s == term) {
- if (termlen == 1)
- break;
- if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
- break;
- }
- else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && PARSING_UTF)
- has_utf8 = TRUE;
- *to = *s;
- }
- }
-
- /* if the terminator isn't the same as the start character (e.g.,
- matched brackets), we have to allow more in the quoting, and
- be prepared for nested brackets.
- */
- else {
- /* read until we run out of string, or we find the terminator */
- for (; s < PL_bufend; s++,to++) {
- /* embedded newlines increment the line count */
- if (*s == '\n' && !PL_rsfp &&
- IF_HAVE_PERL_5_16(
- !PL_parser->filtered,
- 1
- )
- )
- CopLINE_inc(PL_curcop);
- /* backslashes can escape the open or closing characters */
- if (*s == '\\' && s+1 < PL_bufend) {
- if (!keep_quoted &&
- ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
- s++;
- else
- *to++ = *s++;
- }
- /* allow nested opens and closes */
- else if (*s == PL_multi_close && --brackets <= 0)
- break;
- else if (*s == PL_multi_open)
- brackets++;
- else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && PARSING_UTF)
- has_utf8 = TRUE;
- *to = *s;
- }
- }
- /* terminate the copied string and update the sv's end-of-string */
- *to = '\0';
- SvCUR_set(sv, to - SvPVX_const(sv));
-
- /*
- * this next chunk reads more into the buffer if we're not done yet
- */
-
- if (s < PL_bufend)
- break; /* handle case where we are done yet :-) */
-
-#ifndef PERL_STRICT_CR
- if (to - SvPVX_const(sv) >= 2) {
- if ((to[-2] == '\r' && to[-1] == '\n') ||
- (to[-2] == '\n' && to[-1] == '\r'))
- {
- to[-2] = '\n';
- to--;
- SvCUR_set(sv, to - SvPVX_const(sv));
- }
- else if (to[-1] == '\r')
- to[-1] = '\n';
- }
- else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
- to[-1] = '\n';
-#endif
-
- read_more_line:
- /* if we're out of file, or a read fails, bail and reset the current
- line marker so we can report where the unterminated string began
- */
- CopLINE_inc(PL_curcop);
- PL_bufptr = PL_bufend;
- if (!lex_next_chunk(0)) {
- CopLINE_set(PL_curcop, (line_t)PL_multi_start);
- return NULL;
- }
- s = PL_bufptr;
- }
-
- /* at this point, we have successfully read the delimited string */
-
- if (!PL_encoding || PARSING_UTF) {
- if (keep_delims)
- sv_catpvn(sv, s, termlen);
- s += termlen;
- }
- if (has_utf8 || PL_encoding)
- SvUTF8_on(sv);
-
- PL_multi_end = CopLINE(PL_curcop);
-
- /* 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));
- }
-
- PL_bufptr = s;
- return s;
-}
-
-static void S_check_prototype(pTHX_ const SV *declarator, SV *proto) {
- bool bad_proto = FALSE;
- bool in_brackets = FALSE;
- char greedy_proto = ' ';
- bool proto_after_greedy_proto = FALSE;
- bool must_be_last = FALSE;
- bool underscore = FALSE;
- bool seen_underscore = FALSE;
- const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
- char *d, *p;
- STRLEN tmp, tmplen;
-
- /* strip spaces and check for bad characters */
- d = SvPV(proto, tmplen);
- tmp = 0;
- for (p = d; tmplen; tmplen--, ++p) {
- if (!isSPACE(*p)) {
- d[tmp++] = *p;
-
- if (warnillegalproto) {
- if (must_be_last) {
- proto_after_greedy_proto = TRUE;
- }
- if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
- bad_proto = TRUE;
- } else {
- if (underscore) {
- if (!strchr(";@%", *p)) {
- bad_proto = TRUE;
- }
- underscore = FALSE;
- }
- if (*p == '[') {
- in_brackets = TRUE;
- } else if (*p == ']') {
- in_brackets = FALSE;
- } else if (
- (*p == '@' || *p == '%') &&
- (tmp < 2 || d[tmp - 2] != '\\') &&
- !in_brackets
- ) {
- must_be_last = TRUE;
- greedy_proto = *p;
- } else if (*p == '_') {
- underscore = seen_underscore = TRUE;
- }
- }
- }
- }
- }
- d[tmp] = '\0';
- SvCUR_set(proto, tmp);
- if (proto_after_greedy_proto) {
- Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
- "In %"SVf": prototype after '%c': %s",
- SVfARG(declarator), greedy_proto, d
- );
- }
- if (bad_proto) {
- SV *dsv = newSVpvs_flags("", SVs_TEMP);
- Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
- "In %"SVf": illegal character %sin prototype: %s",
- SVfARG(declarator),
- seen_underscore ? "after '_' " : "",
- SvUTF8(proto)
- ? sv_uni_display(dsv,
- newSVpvn_flags(d, tmp, SVs_TEMP | SVf_UTF8),
- tmp,
- UNI_DISPLAY_ISPRINT
- )
- : pv_pretty(dsv, d, tmp, 60, NULL, NULL,
- PERL_PV_ESCAPE_NONASCII
- )
- );
- }
- SvCUR_set(proto, tmp);
-}
-
-#undef CLINE
-/* ^^^^^^^^^^^^^^^^^^^^^ I HAVE NO IDEA WHAT I'M DOING ^^^^^^^^^^^^^^^^^^^^ */
projects / p5sagit/Function-Parameters.git / commitdiff