fix(perl): update grammar for format declarations

Refresh the complete generated Perl grammar bundle from upstream v1.2.1 at c3e17b31179bf8f658c9f37c7a3ea6a202212d5a, raising it from ABI 14 to supported ABI 15. Preserve the existing license and record the source and per-file provenance.

Add deterministic coverage for a valid format followed by a named sub, while retaining a malformed-source control.

Signed-off-by: Martin Vogel <martin.vogel.tech@gmail.com>
This commit is contained in:
Martin Vogel
2026-08-30 16:48:41 +02:00
parent ec08f76e12
commit 17b5a43263
13 changed files with 763043 additions and 470138 deletions
+16 -2
View File
@@ -10,11 +10,25 @@ The grammars were originally vendored as bare `parser.c`+`scanner.c` with **no r
## Summary
- Grammars: **162** — vendored-from-upstream: **143**, first-party/self-maintained: **14**, registry-disagreement: **5** (nim removed 2026-06-12; objectscript_udl + objectscript_routine added 2026-06-24; mojo added 2026-07-01; arkts added 2026-08-26; plsql added 2026-08-27; chialisp added 2026-08-28 — see notes below)
- ABI distribution: **9×** ABI-13 **80×** ABI-14 **73×** ABI-15 (runtime ceiling is ABI 15; never vendor ABI 16 without a runtime upgrade)
- ABI distribution: **9×** ABI-13 **79×** ABI-14 **74×** ABI-15 (runtime ceiling is ABI 15; never vendor ABI 16 without a runtime upgrade)
— recounted from the tree 2026-08-30 after the perl v1.2.1 refresh moved `perl` from ABI 14 to ABI 15 (was `9×/80×/73×`). Neither side of the rebase had this right: main's line was correct for main, and this branch still carried the pre-2026-08-28 `7×/84×/65×`. Regenerate, never increment.
— recounted from the tree 2026-08-28. This line had drifted: it read `7×/86×/65×`, which sums to 158 against 161 vendored grammars, so it was wrong before Chialisp was added and incrementing it would have carried the error forward. Regenerate with:
`grep -h '#define LANGUAGE_VERSION' internal/cbm/vendored/grammars/*/parser.c | sort | uniq -c`
- Vendored copies missing LICENSE: **0** — all upstream LICENSE files restored 2026-06-11 (first-party grammars carry the project MIT license; `move` uses the Helix-listed upstream tzakian/tree-sitter-move MIT text, `zsh` uses georgeharker/tree-sitter-zsh MIT)
- `verdict`: VERIFIED-BOTH = our source matches *both* registries; VERIFIED-NVIM/HELIX = matches one; registry-disagreement = registries name a different repo (listed separately); `vendor-maintained` = the language vendor's own grammar, not in nvim/Helix; `community-niche` = an individual/community-maintained grammar for a niche language, not in nvim/Helix — provenance hand-verified against the upstream repository instead of a registry.
- **perl** (refreshed 2026-08-27): byte-for-byte generated bundle from
[tree-sitter-perl/tree-sitter-perl](https://github.com/tree-sitter-perl/tree-sitter-perl)
tag `v1.2.1`, full commit `c3e17b31179bf8f658c9f37c7a3ea6a202212d5a` (ABI 15).
The upstream GitHub source asset SHA-256 is
`95c5fa0966dd431eb2f96b941c37b413ae7e9083729433f4d3d41fbc2a4f14a6`; the
screened ordered source-manifest SHA-256 is
`4e7bf02e8bd14b410309ce12bab80edb730826db79e1139434c1459a3117b900`.
The existing MIT `LICENSE` was preserved byte-for-byte at SHA-256
`68a9a526ae357ed5a2f8ca5dabb14131b283554b69639bb04816088d4b1f2fa0`.
Exact per-file SHA-256 values are pinned in `scripts/vendored-checksums.txt`.
The table uses `UPSTREAM-RELEASE` because this refresh verified the tagged
upstream release itself but did not independently verify a current registry
pin; it intentionally does not claim `VERIFIED-NVIM` or `VERIFIED-BOTH`.
- **objectscript_udl / objectscript_routine** (added 2026-06-24): vendored from [intersystems/tree-sitter-objectscript](https://github.com/intersystems/tree-sitter-objectscript) @ `a7ffcdf` — MIT, the InterSystems-official grammars (a niche vendor language, hence `vendor-maintained`, not in nvim-treesitter/Helix). **Re-vendor note:** each `scanner.c`'s upstream `#include "../../common/scanner.h"` is repointed to a per-directory `objectscript_common.h` (a verbatim copy of upstream `common/scanner.h`), because this repo's shared `vendored/common/scanner.h` belongs to the cfml/fsharp grammars and differs. The generated `parser.c`/`scanner.c` are otherwise byte-for-byte upstream — on re-vendor, re-apply only that single include rename. **Local modification (2026-07-16):** in `objectscript_common.h`, two loop counters `uint8_t i` were widened to `int i` (the `reverse_marker` scan and the `html_marker_buffer` reversal) to clear CodeQL `cpp/comparison-with-wider-type` — a false positive in practice (both lengths are hard-bounded by `MARKER_BUFFER_MAX_LEN = 30`, so `uint8_t` could never wrap), fixed for cleanliness. On re-vendor, re-apply this widening too (or upstream it at intersystems/tree-sitter-objectscript).
- **mojo** (added 2026-07-01): vendored from [lsh/tree-sitter-mojo](https://github.com/lsh/tree-sitter-mojo) @ `33193a99afe6` — MIT, ABI 15. Helix tracks `lsh/tree-sitter-mojo` as its Mojo grammar source, but the Helix-pinned commit (`3d7c53b8038f`) no longer resolves in the upstream repository after a force-push, so this vendor uses current upstream `main` rather than the stale registry SHA. Security review covered only the vendored C surface (`parser.c`, `scanner.c`, `tree_sitter/*.h`) plus upstream license/provenance metadata; no package manager hooks, workflow files, prompt/agent instruction files, or generated lockfiles were vendored.
- **arkts** (added 2026-08-26): **first-party derivative** — a fork of [tree-sitter/tree-sitter-typescript](https://github.com/tree-sitter/tree-sitter-typescript)'s `typescript` dialect pinned @ `75b3874edb2d` (v0.23.2, the same commit our vendored typescript/tsx come from), on the tree-sitter-javascript base @ `3a837b6f3658` (v0.23.1, the version upstream's own package-lock pins), extended with ArkTS/ArkUI syntax (`@Component struct` declarations, UI-DSL trailing-closure calls with post-block attribute chains, decorated function declarations, `import lazy`, `@Extend`/`@Styles` leading-dot attribute chains, anonymous `stateStyles` style blocks). Grammar source + corpus tests live in `tools/tree-sitter-arkts/`; regenerate with `npx tree-sitter-cli@0.25.10 generate` (ABI 15). **External scanner:** `scanner.c` is a symbol-rename trampoline; `_common_scanner.h` is byte-identical (same SHA-256) to the reviewed `typescript/_common_scanner.h` already shipped. **LICENSE:** tree-sitter-typescript's MIT text **verbatim and byte-identical** (© 2017 Max Brunsfeld) — which is what MIT requires of a derivative work, and what lets the provenance audit byte-verify it against upstream rather than take a note on trust. The fork is registered in the audit's `FORKS` map. Our own copyright for the ArkTS additions, and the tree-sitter-javascript attribution (© 2014 Max Brunsfeld), live with the SOURCE in `tools/tree-sitter-arkts/grammar.js` and in `THIRD_PARTY.md`, which is what ships in the release archives.
@@ -163,7 +177,7 @@ Re-vendoring from upstream must re-apply these.
| ocaml | 14 | tree-sitter/tree-sitter-ocaml | `5a979b3ec7f1` | VERIFIED-BOTH | ✅ |
| odin | 14 | tree-sitter-grammars/tree-sitter-odin | `d2ca8efb4487` | VERIFIED-BOTH | ✅ |
| pascal | 14 | Isopod/tree-sitter-pascal | `042119eca2e1` | VERIFIED-BOTH | ✅ |
| perl | 14 | tree-sitter-perl/tree-sitter-perl | `ea9667dc65a8` | VERIFIED-BOTH | ✅ |
| perl | 15 | tree-sitter-perl/tree-sitter-perl | `c3e17b31179b` | UPSTREAM-RELEASE | ✅ |
| php | 15 | tree-sitter/tree-sitter-php | `3f2465c217d0` | VERIFIED-BOTH | ✅ |
| pkl | 15 | apple/tree-sitter-pkl | `f5beed1da8e5` | VERIFIED-BOTH | ✅ |
| plsql | 14 | AndreasMaierDe/tree-sitter-plsql | `28aebef209be` | community-niche | ✅ |
@@ -69,7 +69,7 @@ is respectively less than, matching, or greater than the array member.
* have to make lim 3, then halve, obtaining 1, so that we will only
* look at item 3.
*/
void *bsearch(const void *key, const void *base0, size_t nmemb, size_t size,
static void *tsp_bsearch(const void *key, const void *base0, size_t nmemb, size_t size,
int (*compar)(const void *, const void *)) {
const char *base = (const char *)base0;
int lim, cmp;
+760516 -469989
View File
File diff suppressed because it is too large Load Diff
+687 -55
View File
@@ -1,6 +1,9 @@
#include "tree_sitter/array.h"
#include "tree_sitter/parser.h"
#include "tsp_unicode.h"
#include "tsp_keywords.h"
#include "tsp_intuit_more.h"
#include "tsp_intuit_readline.h"
// grumble grumble no stdlib
static char *tsp_strchr(register const char *s, int c) {
@@ -49,6 +52,8 @@ enum TokenType {
TOKEN_ESCAPE_SEQUENCE,
TOKEN_ESCAPED_DELIMITER,
TOKEN_DOLLAR_IN_REGEXP,
TOKEN_REGEXP_OPEN_BRACKET,
TOKEN_REGEXP_OPEN_BRACE,
TOKEN_POD,
TOKEN_GOBBLED_CONTENT,
TOKEN_ATTRIBUTE_VALUE_BEGIN,
@@ -61,6 +66,7 @@ enum TokenType {
TOKEN_HEREDOC_MIDDLE,
TOKEN_HEREDOC_END,
TOKEN_FAT_COMMA_AUTOQUOTED,
TOKEN_FAT_COMMA_AUTOQUOTED_AHEAD,
TOKEN_FILETEST,
TOKEN_BRACE_AUTOQUOTED,
/* zero-width lookahead tokens */
@@ -69,6 +75,24 @@ enum TokenType {
TOKEN_NO_INTERP_WHITESPACE_ZW,
/* zero-width high priority token */
TOKEN_NONASSOC,
/* synthetic tokens for error recovery */
TOKEN_RECOVER_PAREN_CLOSE,
TOKEN_RECOVER_BRACKET_CLOSE,
TOKEN_RECOVER_BRACE_CLOSE,
TOKEN_RECOVER_ARROW,
TOKEN_RECOVER_BLOCK_CLOSE,
/* opaque body of a `format NAME = ... .` declaration: everything from the
* line after `=` up to and including the lone-`.` terminator line */
TOKEN_FORMAT_CONTENT,
/* `x` repetition operator glued to its count (`"ab"x3`) */
TOKEN_X_OP,
/* `class`/`role`/`method` emitted only in declaration position */
TOKEN_KW_CLASS,
TOKEN_KW_ROLE,
TOKEN_KW_METHOD,
/* `async`/`try` contextual keywords, emitted only in keyword position */
TOKEN_KW_ASYNC,
TOKEN_KW_TRY,
/* error condition is always last */
TOKEN_ERROR
};
@@ -115,18 +139,47 @@ static int32_t close_for_open(int32_t c) {
typedef struct {
int32_t open, close, count;
/* Recognises a pattern-LEADING '['/'{' -- the quote's own opening delimiter
* appearing (after optional whitespace) as the literal first element of the
* body (m{{...}}, qr{ {...} }, s{{...}}, m[[...]]) -- where the S_intuit_more
* subscript heuristic (tsp_intuit_more) has no preceding variable to weigh and
* so must not be consulted.
*
* Decided ONCE by a bounded lookahead at the opening delimiter (see the open
* handler), where the lexer sits exactly at the body start: if the first
* non-space body char is the delimiter again, the body leads with a literal
* group. Looking at the actual first char sidesteps both problems of the
* earlier column+flag scheme -- columns repeat across lines, and the scanner
* can't see grammar-lexed interpolation -- because we never have to ask "has
* content been seen?": we just check what the first char *is*.
*
* Set at the opener, consumed (cleared) by that first bracket. */
bool body_leads_with_delim;
} TSPQuote;
static TSPQuote tspquote_new() { return (TSPQuote){0, 0, 0}; }
static TSPQuote tspquote_new() { return (TSPQuote){0, 0, 0, false}; }
enum HeredocState { HEREDOC_NONE, HEREDOC_START, HEREDOC_UNKNOWN, HEREDOC_CONTINUE, HEREDOC_END };
/* Perl allows multiple heredocs queued on a single line, consumed FIFO after
* the newline. We hold up to HEREDOC_QUEUE_MAX pending heredocs; each one
* carries its own delimiter and interpolate/indent flags. The consume-FSM
* state (heredoc_state) applies to the FRONT of the queue (the one currently
* being consumed); when it finishes we dequeue and advance to the next. */
#define HEREDOC_QUEUE_MAX 8
typedef struct {
TSPString delim;
bool interpolates, indents;
} HeredocEntry;
typedef struct {
Array(TSPQuote) quotes;
/* heredoc - we need to track if we should start the heredoc, if it's
* interpolating, how many chars the delimiter is and what the delimiter is */
bool heredoc_interpolates, heredoc_indents;
/* FIFO queue of pending heredocs (front = index 0). heredoc_count is how
* many entries are live; heredoc_state is the consume state of the front. */
HeredocEntry heredoc_queue[HEREDOC_QUEUE_MAX];
uint8_t heredoc_count;
enum HeredocState heredoc_state;
TSPString heredoc_delim;
bool recovery_emitted;
} LexerState;
static void lexerstate_push_quote(LexerState *state, int32_t opener) {
@@ -192,6 +245,20 @@ static bool lexerstate_is_paired_delimiter(LexerState *state) {
return !!q->open;
}
/* Is `c` the innermost quote's pattern-leading bracket -- the delimiter-matching
* '['/'{' the open-handler lookahead flagged as the body's first literal element?
* One-shot: clears the flag so a later same-delimiter bracket is treated as
* ordinary (subscript/class) content. */
static bool lexerstate_take_body_lead(LexerState *state, int32_t c) {
if (!state->quotes.size) return false;
TSPQuote *q = array_back(&state->quotes);
if (q->body_leads_with_delim && c == q->open) {
q->body_leads_with_delim = false;
return true;
}
return false;
}
// in order to emulate a sublex, we basically need to have a new escape type character
// that can pop up anywhere so long as there's an active string, to escape the string
// char
@@ -210,16 +277,48 @@ static bool lexerstate_is_paired_delimiter(LexerState *state) {
// we can match perl's behavior if we are intentionally destructive here and find our match
static void lexerstate_add_heredoc(LexerState *state, TSPString *delim, bool interp, bool indent) {
state->heredoc_delim = *delim;
state->heredoc_interpolates = interp;
state->heredoc_indents = indent;
state->heredoc_state = HEREDOC_START;
/* The front of the queue is the heredoc currently being consumed. */
static HeredocEntry *lexerstate_front_heredoc(LexerState *state) {
return &state->heredoc_queue[0];
}
/* ENQUEUE a pending heredoc to the back of the FIFO. When this is the first
* pending heredoc, prime the consume FSM at HEREDOC_START.
*
* Overflow handling: if the queue is already full we OVERWRITE THE LAST SLOT
* with the new entry rather than dropping it. The last slot then always
* tracks the FINAL heredoc's terminator, so the scanner stays in heredoc-mode
* and greedily consumes all overflow content up to that final terminator —
* absorbing the excess into the last body instead of leaking it into the code
* stream. For >MAX heredocs on a line this means the first MAX-1 bodies parse
* correctly, the last body greedily swallows the remaining overflow (wrong but
* BOUNDED), and code after the heredoc block is unaffected (no desync). This
* is graceful degradation for a pathological input. */
static void lexerstate_add_heredoc(LexerState *state, TSPString *delim, bool interp, bool indent) {
HeredocEntry *e;
if (state->heredoc_count >= HEREDOC_QUEUE_MAX)
e = &state->heredoc_queue[HEREDOC_QUEUE_MAX - 1];
else
e = &state->heredoc_queue[state->heredoc_count++];
e->delim = *delim;
e->interpolates = interp;
e->indents = indent;
if (state->heredoc_count == 1) state->heredoc_state = HEREDOC_START;
}
/* DEQUEUE the finished front heredoc and advance to the next pending one.
* Each heredoc body is wrapped in its own `heredoc_content` grammar node which
* begins with a fresh `_heredoc_start` zero-width token; that token only fires
* in HEREDOC_START. So when another heredoc remains queued we re-arm the FSM
* to HEREDOC_START, exactly as if its delimiter had just been declared. */
static void lexerstate_finish_heredoc(LexerState *state) {
state->heredoc_delim.length = 0;
state->heredoc_state = HEREDOC_NONE;
if (state->heredoc_count > 0) {
state->heredoc_count--;
for (int i = 0; i < state->heredoc_count; i++)
state->heredoc_queue[i] = state->heredoc_queue[i + 1];
}
state->heredoc_queue[state->heredoc_count] = (HeredocEntry){0};
state->heredoc_state = state->heredoc_count > 0 ? HEREDOC_START : HEREDOC_NONE;
}
#define ADVANCE_C \
@@ -247,6 +346,16 @@ static void lexerstate_finish_heredoc(LexerState *state) {
DEBUG("marking end of token\n", 0); \
} while (0)
// Try each recovery token in priority order. Uses a macro because
// TOKEN() contains `return true`. brace_ok: skip brace recovery at '}'
// (that's the real closer); ';' is safe (only valid in subscript context).
#define EMIT_RECOVERY_TOKENS(brace_ok) do { \
if (valid_symbols[TOKEN_RECOVER_ARROW]) { state->recovery_emitted = true; TOKEN(TOKEN_RECOVER_ARROW); } \
if (valid_symbols[TOKEN_RECOVER_PAREN_CLOSE]) { state->recovery_emitted = true; TOKEN(TOKEN_RECOVER_PAREN_CLOSE); } \
if (valid_symbols[TOKEN_RECOVER_BRACKET_CLOSE]) { state->recovery_emitted = true; TOKEN(TOKEN_RECOVER_BRACKET_CLOSE); } \
if ((brace_ok) && valid_symbols[TOKEN_RECOVER_BRACE_CLOSE]) { state->recovery_emitted = true; TOKEN(TOKEN_RECOVER_BRACE_CLOSE); } \
} while(0)
static void skip_whitespace(TSLexer *lexer) {
while (1) {
int32_t c = lexer->lookahead;
@@ -258,19 +367,130 @@ static void skip_whitespace(TSLexer *lexer) {
}
}
static void skip_ws_to_eol(TSLexer *lexer) {
static bool skip_ws_to_eol(TSLexer *lexer) {
while (1) {
int32_t c = lexer->lookahead;
if (!c) return;
if (!c) return false;
if (is_tsp_whitespace(c)) {
lexer->advance(lexer, true);
// return after eating the newline
if (c == '\n') return;
if (c == '\n') return true;
} else
return;
return false;
}
}
// Forward declarations (defined after _skip_chars)
static bool isidfirst(int32_t c);
static bool isidcont(int32_t c);
enum PeekResult {
PEEK_NO_MATCH, // first char not a keyword starter — lexer untouched
PEEK_KEYWORD, // statement keyword (not followed by =>)
PEEK_FAT_COMMA, // keyword followed by => — caller MARK_ENDs then goto fat_comma_check
PEEK_AUTOQUOTE_KEY, // non-keyword word followed by => — peek already marked the
// word boundary; caller goes straight to fat_comma_check
PEEK_NOT_KEYWORD, // word read but not a keyword — caller MUST return false
};
// How a word read by the keyword peek classifies (set by KEYWORD_MATCH).
enum KwKind {
KW_NONE, // not a statement keyword
KW_ALWAYS, // always a statement keyword (package/use/no/class/role)
KW_NEEDS_NAME, // declaration only if followed by a name (sub/method)
};
static enum PeekResult peek_is_statement_keyword(TSLexer *lexer, bool *is_structural) {
int32_t la = lexer->lookahead;
*is_structural = false;
if (KEYWORD_FIRST_CHAR_FILTER(la))
return PEEK_NO_MATCH;
// Read the word (character set derived from keyword list)
char word[16];
int len = 0;
while (KEYWORD_WORD_CHAR(la)) {
if (len < 15) word[len++] = (char)la;
lexer->advance(lexer, false);
la = lexer->lookahead;
}
word[len] = '\0';
// Classify *before* consuming any identifier tail: a statement keyword must
// end exactly at the keyword charset boundary. A longer identifier (e.g.
// "service", "naming") read only partway by the loop above is never a
// keyword — but it can still be a fat-comma autoquote key, so we don't bail.
enum KwKind kind = KW_NONE;
if (!isidcont(la))
KEYWORD_MATCH(word, kind);
if (kind == KW_NONE) {
// Not a statement keyword. It may still be a fat-comma autoquote key
// (`name => 1` on a continuation line inside an open list, where the
// recovery gate fires and would otherwise lex it as a plain bareword).
// Consume the rest of the identifier, mark the token end at the word
// boundary, then look past whitespace for '='. The whole word must be
// covered, so skip with advance(false): advance(true) would reset the
// token start past the word and emit a zero-width key. mark_end fixes the
// end at the word, so trailing whitespace stays out of the token anyway.
while (isidcont(la)) {
lexer->advance(lexer, false);
la = lexer->lookahead;
}
lexer->mark_end(lexer);
while (is_tsp_whitespace(la)) {
lexer->advance(lexer, false);
la = lexer->lookahead;
}
if (la == '=') return PEEK_AUTOQUOTE_KEY;
return PEEK_NOT_KEYWORD;
}
// A statement keyword. Structural OO keywords (method/class/role) never
// legitimately nest inside a sub/method body, so they alone trigger body
// block-close recovery. use/no/sub/package commonly DO appear in a body
// (e.g. `no strict 'refs';`) and must not trigger it.
//
// `sub` is the tempting one: a bare nested `sub foo {...}` is almost always a
// "won't stay shared" bug, not intent — so closing the enclosing body at it
// would often be the *helpful* read. We deliberately don't. It is valid Perl
// and it is genuinely out there (~140 nested bare subs across a 92k-file
// corpus: perl's own regen/Porting codegen scripts, some CPAN, real app code),
// so the parser tree-s it faithfully; diagnosing the footgun belongs to the
// layer above (linter/LSP), not the grammar. Lexical `my sub` (which *does*
// truly nest, and is legit) is a separate story and is excluded for free
// anyway: it starts with `my`, takes the KW_NONE path above, and never reaches
// here. (`kind` was already classified above; don't re-run KEYWORD_MATCH.)
*is_structural = (strcmp(word, "method") == 0 ||
strcmp(word, "class") == 0 ||
strcmp(word, "role") == 0);
// The caller already marked a zero-width position at the keyword start for
// recovery-token emission; leave that mark alone (don't mark_end here) and
// skip trailing whitespace with advance(true) — the recovery-safe behavior.
// A word-end mark here would make the recovery token swallow the keyword
// (and breaks the keyword-boundary tests).
while (is_tsp_whitespace(la)) {
lexer->advance(lexer, true);
la = lexer->lookahead;
}
// Fat comma => means even a keyword is a hash key, not a statement
// (`package => 1`). We can't mark the word boundary here without clobbering
// the recovery mark, so the caller emits a zero-width _fat_comma_autoquoted
// _ahead marker and tree-sitter re-lexes the word through the normal
// autoquote path with a correct span. (Plain words and non-keyword builtins
// — sort/map/ref/state/… — take the KW_NONE path above and autoquote in a
// single pass.)
if (la == '=') return PEEK_FAT_COMMA;
// For sub/method: only a declaration if followed by an identifier (name)
if (kind == KW_NEEDS_NAME && !isidfirst(la))
return PEEK_NOT_KEYWORD; // anonymous sub/method
return PEEK_KEYWORD;
}
static void _skip_chars(TSLexer *lexer, int maxlen, const char *allow) {
int32_t c = lexer->lookahead;
@@ -306,14 +526,37 @@ static bool isidcont(int32_t c) { return c == '_' || is_tsp_id_continue(c); }
// there's a matching rule in the grammar to catch when it doesn't match a rule
static bool is_interpolation_escape(int32_t c) { return c < 256 && tsp_strchr("$@-[{\\", c); }
/* The runtime hands serialize() a FIXED buffer of TREE_SITTER_SERIALIZATION_BUFFER_SIZE
* (1024) bytes — `self->lexer.debug_buffer`, a member embedded in the Lexer/TSParser
* struct. Writing past it is intra-object memory corruption (ASAN doesn't flag it),
* and returning a length > the buffer trips the runtime's `assert(length <= 1024)`
* (or, in NDEBUG builds, silently clobbers adjacent parser fields). So we must bound
* the serialized size to the buffer, NOT to UINT8_MAX.
*
* Budget: everything except the quotes is fixed-size — the two count bytes, the
* recovery flag, and the whole heredoc FIFO at its worst case (HEREDOC_QUEUE_MAX
* full entries). Whatever room is left holds quotes. A deeply nested (or, in a
* mid-edit buffer, deeply *unclosed*) interpolation like `qq{ ${\ qq{ ... }} }`
* stacks one quote per level and can blow past this; we cap it. Truncating the
* stack degrades parsing of pathologically-nested input (>~59 levels) but keeps it
* BOUNDED — the same graceful-degradation contract the heredoc overflow already uses.
*/
#define SER_FIXED_OVERHEAD \
(1 /* quote_count */ + \
1 /* heredoc_state */ + 1 /* heredoc_count */ + \
HEREDOC_QUEUE_MAX * (1 /* interpolates */ + 1 /* indents */ + (int)sizeof(TSPString)) + \
1 /* recovery_emitted */)
#define MAX_SERIALIZED_QUOTES \
((TREE_SITTER_SERIALIZATION_BUFFER_SIZE - SER_FIXED_OVERHEAD) / (int)sizeof(TSPQuote))
unsigned int tree_sitter_perl_external_scanner_serialize(void *payload, char *buffer) {
LexerState *state = payload;
size_t size = 0;
// Serialize the quotes array
// Serialize the quotes array, capped to what fits in the fixed buffer (see above).
size_t quote_count = state->quotes.size;
if (quote_count > UINT8_MAX) {
quote_count = UINT8_MAX;
if (quote_count > MAX_SERIALIZED_QUOTES) {
quote_count = MAX_SERIALIZED_QUOTES;
}
buffer[size++] = (char)quote_count;
@@ -322,12 +565,18 @@ unsigned int tree_sitter_perl_external_scanner_serialize(void *payload, char *bu
}
size += quote_count * sizeof(TSPQuote);
// Serialize the heredoc state and delimiter
buffer[size++] = (char)state->heredoc_interpolates;
buffer[size++] = (char)state->heredoc_indents;
// Serialize the heredoc consume state, then the whole pending FIFO queue:
// a count byte followed by each entry's flags + delimiter.
buffer[size++] = (char)state->heredoc_state;
memcpy(&buffer[size], &state->heredoc_delim, sizeof(TSPString));
size += sizeof(TSPString);
buffer[size++] = (char)state->heredoc_count;
for (uint8_t i = 0; i < state->heredoc_count; i++) {
HeredocEntry *e = &state->heredoc_queue[i];
buffer[size++] = (char)e->interpolates;
buffer[size++] = (char)e->indents;
memcpy(&buffer[size], &e->delim, sizeof(TSPString));
size += sizeof(TSPString);
}
buffer[size++] = (char)state->recovery_emitted;
return size;
}
@@ -340,6 +589,9 @@ void tree_sitter_perl_external_scanner_deserialize(void *payload, const char *bu
if (length > 0) {
// Deserialize the quotes array
size_t quote_count = (uint8_t)buffer[size++];
// Defensive: a well-formed buffer never exceeds this (serialize caps it), but
// clamp anyway so a malformed/old buffer can't drive an oversized memcpy.
if (quote_count > MAX_SERIALIZED_QUOTES) quote_count = MAX_SERIALIZED_QUOTES;
if (quote_count > 0) {
array_reserve(&state->quotes, quote_count);
state->quotes.size = quote_count;
@@ -347,13 +599,21 @@ void tree_sitter_perl_external_scanner_deserialize(void *payload, const char *bu
size += quote_count * sizeof(TSPQuote);
}
// Deserialize the heredoc state and delimiter
state->heredoc_interpolates = (bool)buffer[size++];
state->heredoc_indents = (bool)buffer[size++];
// Deserialize the heredoc consume state and the pending FIFO queue.
state->heredoc_state = (enum HeredocState)buffer[size++];
memcpy(&state->heredoc_delim, &buffer[size], sizeof(TSPString));
size += sizeof(TSPString);
state->heredoc_count = (uint8_t)buffer[size++];
if (state->heredoc_count > HEREDOC_QUEUE_MAX) state->heredoc_count = HEREDOC_QUEUE_MAX;
for (uint8_t i = 0; i < state->heredoc_count; i++) {
HeredocEntry *e = &state->heredoc_queue[i];
e->interpolates = (bool)buffer[size++];
e->indents = (bool)buffer[size++];
memcpy(&e->delim, &buffer[size], sizeof(TSPString));
size += sizeof(TSPString);
}
state->recovery_emitted = (bool)buffer[size++];
} else {
state->heredoc_count = 0;
state->heredoc_state = HEREDOC_NONE;
}
}
@@ -363,6 +623,9 @@ bool tree_sitter_perl_external_scanner_scan(void *payload, TSLexer *lexer,
bool is_ERROR = valid_symbols[TOKEN_ERROR];
bool skipped_whitespace = false;
bool crossed_newline = false;
bool recovery_emitted = state->recovery_emitted;
state->recovery_emitted = false;
int32_t c = lexer->lookahead;
@@ -372,16 +635,60 @@ bool tree_sitter_perl_external_scanner_scan(void *payload, TSLexer *lexer,
TOKEN(TOKEN_GOBBLED_CONTENT);
}
/* `format NAME = <newline> BODY .` — the body (line after `=` up to and
* including a lone `.` line) is opaque content the LR grammar can't parse, read
* as one TOKEN_FORMAT_CONTENT. Lives before whitespace handling so the body's
* leading newline isn't skipped separately. */
if (!is_ERROR && valid_symbols[TOKEN_FORMAT_CONTENT]) {
/* swallow the remainder of the `format ... =` line, then its newline */
while (c != '\n' && !lexer->eof(lexer)) ADVANCE_C;
if (c == '\n') ADVANCE_C;
/* now read body lines; stop after a line consisting solely of `.`
* (perl: a lone `.`, trailing whitespace tolerated) */
while (!lexer->eof(lexer)) {
/* peek whether this whole line is just `.` */
bool only_dot = false;
if (c == '.') {
ADVANCE_C;
only_dot = true;
while (c == ' ' || c == '\t' || c == '\r') ADVANCE_C;
if (c != '\n' && !lexer->eof(lexer)) only_dot = false;
}
if (only_dot) {
if (c == '\n') ADVANCE_C; /* include the terminator's newline */
break;
}
/* not the terminator: consume to end of this line */
while (c != '\n' && !lexer->eof(lexer)) ADVANCE_C;
if (c == '\n') ADVANCE_C;
}
MARK_END;
TOKEN(TOKEN_FORMAT_CONTENT);
}
/* we use this to force tree-sitter to stay on the error branch of a nonassoc
* operator */
if (!is_ERROR && valid_symbols[TOKEN_NONASSOC]) TOKEN(TOKEN_NONASSOC);
/* The `x` repetition operator glued to its count (`"ab"x3`, `("")x4`). The
* internal lexer would greedily take `x3` as one identifier, so when the
* grammar offers the operator here (an operator is expected — perl's
* XOPERATOR state, which `valid_symbols` encodes) and `x` is glued to a digit,
* we emit it explicitly, consuming just the `x`. Anything else (`xor`, an
* identifier, a space-delimited `x`) falls through to the normal lexer. */
if (!is_ERROR && valid_symbols[TOKEN_X_OP] && c == 'x') {
ADVANCE_C;
if (c >= '0' && c <= '9') { MARK_END; TOKEN(TOKEN_X_OP); }
return false;
}
// this is whitespace sensitive, so it must go before any whitespace is
// skipped
if (valid_symbols[TOKEN_HEREDOC_MIDDLE] && !is_ERROR) {
if (valid_symbols[TOKEN_HEREDOC_MIDDLE] && !is_ERROR && state->heredoc_count > 0) {
HeredocEntry *front = lexerstate_front_heredoc(state);
DEBUG("Beginning heredoc contents\n", 0);
if (state->heredoc_state != HEREDOC_CONTINUE) {
TSPString line;
TSPString line = {0};
// read as many lines as we can
while (!lexer->eof(lexer)) {
tspstring_reset(&line);
@@ -391,7 +698,7 @@ bool tree_sitter_perl_external_scanner_scan(void *payload, TSLexer *lexer,
state->heredoc_state == HEREDOC_END || lexer->get_column(lexer) == 0;
bool saw_escape = false;
DEBUG("Starting loop at col %d\n", lexer->get_column(lexer));
if (is_valid_start_pos && state->heredoc_indents) {
if (is_valid_start_pos && front->indents) {
DEBUG("Skipping initial whitespace in heredoc\n", 0);
skip_whitespace(lexer);
c = lexer->lookahead;
@@ -411,8 +718,8 @@ bool tree_sitter_perl_external_scanner_scan(void *payload, TSLexer *lexer,
if (c == '$' || c == '@' || c == '\\') saw_escape = true;
ADVANCE_C;
}
DEBUG("got length %d, want length %d\n", line.length, state->heredoc_delim.length);
if (is_valid_start_pos && tspstring_eq(&line, &state->heredoc_delim)) {
DEBUG("got length %d, want length %d\n", line.length, front->delim.length);
if (is_valid_start_pos && tspstring_eq(&line, &front->delim)) {
// if we've read already, we return everything up until now
if (state->heredoc_state != HEREDOC_END) {
state->heredoc_state = HEREDOC_END;
@@ -422,7 +729,7 @@ bool tree_sitter_perl_external_scanner_scan(void *payload, TSLexer *lexer,
lexerstate_finish_heredoc(state);
TOKEN(TOKEN_HEREDOC_END);
}
if (saw_escape && state->heredoc_interpolates) {
if (saw_escape && front->interpolates) {
// we'll repeat this line in continue mode where we'll pause midline
state->heredoc_state = HEREDOC_CONTINUE;
TOKEN(TOKEN_HEREDOC_MIDDLE);
@@ -452,10 +759,10 @@ bool tree_sitter_perl_external_scanner_scan(void *payload, TSLexer *lexer,
}
}
if (iswspace(c) && valid_symbols[TOKEN_NO_INTERP_WHITESPACE_ZW]) {
if (!is_ERROR && iswspace(c) && valid_symbols[TOKEN_NO_INTERP_WHITESPACE_ZW]) {
TOKEN(TOKEN_NO_INTERP_WHITESPACE_ZW);
}
skip_ws_to_eol(lexer);
crossed_newline = skip_ws_to_eol(lexer);
/* heredocs override everything, so they must be here before */
if (valid_symbols[TOKEN_HEREDOC_START]) {
if (state->heredoc_state == HEREDOC_START && lexer->get_column(lexer) == 0) {
@@ -506,39 +813,256 @@ bool tree_sitter_perl_external_scanner_scan(void *payload, TSLexer *lexer,
// CTRL-Z must be here, b/c it cares about whitespace
if (c == 26 && valid_symbols[TOKEN_CTRL_Z]) TOKEN(TOKEN_CTRL_Z);
bool any_recovery_valid =
valid_symbols[TOKEN_RECOVER_ARROW] ||
valid_symbols[TOKEN_RECOVER_PAREN_CLOSE] ||
valid_symbols[TOKEN_RECOVER_BRACKET_CLOSE] ||
valid_symbols[TOKEN_RECOVER_BRACE_CLOSE] ||
valid_symbols[TOKEN_RECOVER_BLOCK_CLOSE] ||
valid_symbols[PERLY_SEMICOLON];
// Contextual keywords: class/role/method are declarations only when a name (or
// a block, for method) follows; otherwise they're ordinary barewords
// (`class($cv)`, `role { … }`, `-role`). Decide here, before emitting, so
// there's no keyword-vs-call ambiguity. The OO keywords are deferred while
// recovery is pending because they trigger the structural body block-close,
// which must fire first; async/try don't, so they're classified unconditionally.
bool oo_kw_valid = valid_symbols[TOKEN_KW_CLASS] || valid_symbols[TOKEN_KW_ROLE] || valid_symbols[TOKEN_KW_METHOD];
bool asynctry_valid = valid_symbols[TOKEN_KW_ASYNC] || valid_symbols[TOKEN_KW_TRY];
bool recovery_pending = any_recovery_valid && (crossed_newline || recovery_emitted);
bool enter_oo = oo_kw_valid && !recovery_pending && (c == 'c' || c == 'r' || c == 'm');
bool enter_asynctry = asynctry_valid && (c == 'a' || c == 't');
if (!is_ERROR && (enter_oo || enter_asynctry)) {
char word[8];
int wlen = 0;
while (isidcont(c)) { // consume the whole identifier (store first 7 chars)
if (wlen < 7) word[wlen++] = (char)c;
lexer->advance(lexer, false);
c = lexer->lookahead;
}
word[wlen] = '\0';
MARK_END; // the token covers exactly the word (lookahead past here is free)
while (is_tsp_whitespace(c)) { // peek past whitespace at the next token
lexer->advance(lexer, false);
c = lexer->lookahead;
}
bool is_class = !recovery_pending && valid_symbols[TOKEN_KW_CLASS] && strcmp(word, "class") == 0;
bool is_role = !recovery_pending && valid_symbols[TOKEN_KW_ROLE] && strcmp(word, "role") == 0;
bool is_method = !recovery_pending && valid_symbols[TOKEN_KW_METHOD] && strcmp(word, "method") == 0;
bool is_async = valid_symbols[TOKEN_KW_ASYNC] && strcmp(word, "async") == 0;
bool is_try = valid_symbols[TOKEN_KW_TRY] && strcmp(word, "try") == 0;
// `try` is the try/catch keyword only before a block `{`; `try(...)`/`try =>`
// /`try;` are bareword calls. (`catch` is never over-reserved.)
if (is_try) {
if (c == '{') TOKEN(TOKEN_KW_TRY);
}
// `async` is a keyword before a block (`async { … }` — threads::async, a bare
// block run as an anon sub; F::AA itself has only `async sub`) or before a
// sub/method/extended declaration. Else it's a bareword/call.
if (is_async) {
if (c == '{') TOKEN(TOKEN_KW_ASYNC);
if (c == 's' || c == 'm' || c == 'e') { // peek for sub/method/extended
char nword[9];
int nlen = 0;
while (isidcont(c)) {
if (nlen < 8) nword[nlen++] = (char)c;
lexer->advance(lexer, false);
c = lexer->lookahead;
}
nword[nlen] = '\0';
if (strcmp(nword, "sub") == 0 || strcmp(nword, "method") == 0 ||
strcmp(nword, "extended") == 0)
TOKEN(TOKEN_KW_ASYNC);
// Not a decl: `async` is a bareword/call. Must `return false` (re-lex),
// NOT `goto kw_autoquote` like the path below — we consumed past `async`
// into the next word, so the handler would read *that* word's `=>` as
// async's own fat comma and wrongly autoquote `async` (`async send=>1`).
return false;
}
}
// `class NAME` / `role NAME` — a name following => declaration; else bareword.
if ((is_class || is_role) && isidfirst(c))
TOKEN(is_class ? TOKEN_KW_CLASS : TOKEN_KW_ROLE);
// `method NAME { … }` / `method { … }` are declarations (named/anonymous);
// `method NAME => sub { … }` (MooseX) is a call — peek past the name for `=>`.
if (is_method) {
if (c == '{' || c == '(') TOKEN(TOKEN_KW_METHOD); // anonymous method
if (isidfirst(c)) {
while (isidcont(c)) { lexer->advance(lexer, false); c = lexer->lookahead; } // skip the name
while (is_tsp_whitespace(c)) { lexer->advance(lexer, false); c = lexer->lookahead; }
if (c != '=') TOKEN(TOKEN_KW_METHOD); // `{`/`(`/`:`/`;` => decl; `=>` => call
return false; // method NAME => … : re-lex as a call (the name autoquotes)
}
}
// Bareword/call, or an autoquoted key (`class => 1`, `$h{m}`). Can't just
// `return false` — a quote-op word (`m`/`s`/`y`) would re-lex as a match — so
// fall through to the canonical autoquote handler; MARK_END already fixed the
// token at the word, and it emits the autoquote or returns false on no match.
goto kw_autoquote;
}
// === Error recovery: close unclosed delimiters and insert semicolons ===
//
// When the scanner sees '}', ';', EOF, or a statement keyword on a new
// line, it emits recovery tokens to unwind open delimiters. Each call
// peels one layer — the parser keeps calling until everything is closed.
//
// Syntactic boundary: '}', ';', or EOF
if (!is_ERROR) {
if (c == '}' || c == ';' || lexer->eof(lexer)) {
EMIT_RECOVERY_TOKENS(c != '}');
}
}
if (valid_symbols[PERLY_SEMICOLON]) {
if (c == '}' || lexer->eof(lexer)) {
// do a PERLY_SEMICOLON unless we're in brace autoquoting
if (is_ERROR || !valid_symbols[TOKEN_BRACE_END_ZW]) {
DEBUG("Fake PERLY_SEMICOLON at end-of-scope\n", 0);
// no advance
TOKEN(PERLY_SEMICOLON);
}
}
}
if (lexer->eof(lexer)) return false;
// Statement keyword boundary: a statement keyword on a new line means
// the previous expression is done. Also fires when a recovery token
// was just emitted (recovery_emitted flag) since the newline was already
// consumed by the previous call.
// Gate on the first-char filter so we don't call MARK_END (and freeze
// the token end at the keyword-start position) when the lookahead can't
// possibly start a keyword. Without this, a later TOKEN() emission
// (e.g. TOKEN_APOSTROPHE/TOKEN_DOUBLE_QUOTE which do ADVANCE_C+TOKEN
// and never re-mark) inherits the stale mark and reports a zero-width
// open-quote, which derails the string body.
if ((crossed_newline || recovery_emitted) && !is_ERROR && any_recovery_valid &&
!KEYWORD_FIRST_CHAR_FILTER(c)) {
MARK_END; // zero-width position for recovery tokens
bool is_structural = false;
enum PeekResult peek = peek_is_statement_keyword(lexer, &is_structural);
if (peek == PEEK_KEYWORD) {
DEBUG("keyword boundary\n", 0);
EMIT_RECOVERY_TOKENS(true);
// Body block-close: only a structural OO keyword (method/class/role)
// closes a half-typed sub/method body. Fires after any inner paren/
// bracket closers above; the enclosing class block can't accept this
// token, so the cascade stops at one body (no over-closing).
if (is_structural && valid_symbols[TOKEN_RECOVER_BLOCK_CLOSE]) {
DEBUG("body block recovery at structural keyword\n", 0);
// Re-arm the cascade so the next scan re-enters and can close the NEXT
// enclosing recover-aware block (e.g. an unclosed `if`/loop body inside
// the method: close the if-block, then the method body).
state->recovery_emitted = true;
TOKEN(TOKEN_RECOVER_BLOCK_CLOSE);
}
// A statement terminator may need to fire BEFORE the body block-close:
// after an inner closer (e.g. `my @x = [` -> `]`) completes an expression,
// the statement still needs `;` before the enclosing body can reduce and
// close. Re-arm the recovery cascade (recovery_emitted) so the next scan
// re-enters here and can emit the block-close. Harmless when nothing
// follows: the re-entry finds no further valid recovery token.
if (valid_symbols[PERLY_SEMICOLON]) {
state->recovery_emitted = true;
TOKEN(PERLY_SEMICOLON);
}
}
if (peek == PEEK_FAT_COMMA) {
// A statement keyword used as a fat-comma key (`package => 1`). We can't
// mark the word boundary here (peek preserved the caller's zero-width
// recovery mark for the keyword path, and re-marking would consume the
// keyword). Instead emit a zero-width "autoquote ahead" marker at the
// word start: tree-sitter re-lexes the word via the normal autoquote
// path, which marks the word boundary correctly. The recovery gate
// won't re-fire on re-entry (no newline precedes the word that scan), so
// there's no loop. Falls back to the old (zero-width-span) emission if
// the marker isn't accepted in this state.
if (valid_symbols[TOKEN_FAT_COMMA_AUTOQUOTED_AHEAD])
TOKEN(TOKEN_FAT_COMMA_AUTOQUOTED_AHEAD);
MARK_END;
c = lexer->lookahead;
goto fat_comma_check;
}
if (peek == PEEK_AUTOQUOTE_KEY) {
// A non-keyword bareword used as a fat-comma key (`name => 1`) on a
// continuation line where the recovery gate fired. Peek already marked
// the token end at the word boundary (covering exactly the word), so do
// NOT MARK_END again — that would re-mark at '=' and emit a zero-width
// key. Resume at the autoquote handler's => check.
c = lexer->lookahead;
goto fat_comma_check;
}
if (peek == PEEK_NOT_KEYWORD)
return false;
}
if (valid_symbols[TOKEN_OPEN_FILEGLOB_BRACKET] || valid_symbols[TOKEN_OPEN_READLINE_BRACKET] || valid_symbols[PERLY_HEREDOC]) {
if (c == '<') {
ADVANCE_C;
MARK_END;
// ah, we have a heredoc; let's just go down to that section then
if (c == '<') goto heredoc_token_handling;
if (c == '$') ADVANCE_C;
// Gather the `<...>` body as we go, starting right after `<`, so the
// fileglob content heuristic below sees the WHOLE body -- including
// the `$ident` prefix the readline probe consumes here (otherwise a
// `<$sner >` glob would reach the heuristic with content " ").
char content[256];
size_t clen = 0;
if (c == '$') { content[clen++] = '$'; ADVANCE_C; }
// we now zoooom as many ident chars as we can
while (isidcont(c)) ADVANCE_C;
while (isidcont(c)) {
if (clen < sizeof(content)) content[clen++] = (c < 0x80) ? (char)c : (char)0x7f;
ADVANCE_C;
}
// if ident chars took us until the closing `>` then we're readline FILEHANDLE
if (c == '>') TOKEN(TOKEN_OPEN_READLINE_BRACKET);
// otherwise we're a fileglob operator, and we set up our string parse + be excellent
lexerstate_push_quote(state, '<');
TOKEN(TOKEN_OPEN_FILEGLOB_BRACKET);
// Otherwise `<...>` is either a fileglob (`<*.c>`) or the relational
// `<` operator (`CONST < 0`); both are live after an ambiguous
// bareword. Gather the body and the bytes after the `>` (pure
// lookahead past MARK_END, so the token stays the one-char `<`;
// non-ASCII -> 0x7f), then let tsp_is_fileglob() decide -- see
// tsp_intuit_readline.h.
if (valid_symbols[TOKEN_OPEN_FILEGLOB_BRACKET]) {
// `content`/`clen` already hold the `$ident` prefix from above.
// Stop at a statement boundary so we don't chase a `>` onto the
// next line.
while (c != '>' && c != '<' && c != ';' && c != '\n' &&
!lexer->eof(lexer)) {
if (clen < sizeof(content))
content[clen++] = (c < 0x80) ? (char)c : (char)0x7f;
ADVANCE_C;
}
if (c == '>') {
ADVANCE_C; // step past the closing `>` (still pure lookahead)
char after[256];
size_t alen = 0;
while (alen < sizeof(after) && c != '\n' && !lexer->eof(lexer)) {
after[alen++] = (c < 0x80) ? (char)c : (char)0x7f;
ADVANCE_C;
}
if (tsp_is_fileglob(content, clen, after, alen)) {
lexerstate_push_quote(state, '<');
TOKEN(TOKEN_OPEN_FILEGLOB_BRACKET);
}
}
}
// not a readline, not a fileglob — let `<` fall through to the
// grammar as the relational operator.
return false;
}
}
if (valid_symbols[TOKEN_DOLLAR_IDENT_ZW]) {
// false on word chars, another dollar or {
if (!isidcont(c) && !tsp_strchr("${", c)) {
if (!is_ERROR && valid_symbols[TOKEN_DOLLAR_IDENT_ZW]) {
// false on word chars, another dollar or { -- but if whitespace intervened
// the `$` can't begin a glued deref ($$foo needs the name glued on), so a
// following word char is a separate token: `$$ eq …`, `$$ and …` are the
// PID var `$$`, not `${$eq}`. Treat skipped whitespace as a hard boundary.
if (!tsp_strchr("${", c) && (skipped_whitespace || !isidcont(c))) {
if (c == ':') {
// NOTE - it's a syntax error to do $$:, so that's why we return
// dollar_ident_zw in that case
@@ -601,6 +1125,64 @@ bool tree_sitter_perl_external_scanner_scan(void *payload, TSLexer *lexer,
return false;
}
/* A '[' or '{' in a pattern is ambiguous: it can begin a subscript on the
* preceding variable (/$foo[0]/, /$foo{k}/) or a character class /
* quantifier (/[abc]/, /a{2,3}/). We replicate perl's S_intuit_more
* heuristic (tsp_intuit_more) to decide. When it's a class/quantifier we
* emit a literal opener (aliased back to '[' / '{' in the grammar); when
* it's a subscript we decline so the grammar's token.immediate('[' / '{')
* takes over. */
if ((valid_symbols[TOKEN_REGEXP_OPEN_BRACKET] && c == '[') ||
(valid_symbols[TOKEN_REGEXP_OPEN_BRACE] && c == '{')) {
/* A pattern-LEADING '['/'{' that is the quote's own opening delimiter is a
* balanced nested delimiter (m{{...}}, qr{ {...} }, s{{...}}, m[[...]]),
* NOT a subscript: there is no preceding variable for intuit_more to weigh,
* and its subscript verdict here would be meaningless. Fall through to the
* Q/QQ content scanner, which consumes the opener while tracking the nesting
* count so the matching inner close doesn't terminate the quote early.
* Anything beyond the leading position is genuinely ambiguous again, so the
* heuristic below applies as before. */
bool leading = lexerstate_take_body_lead(state, c);
if (leading) {
/* leave the opener for the content scanner below */
} else {
int32_t open = c;
int32_t close = (open == '[') ? ']' : '}';
char buf[256];
int n = 0;
buf[n++] = (char)open;
ADVANCE_C; /* consume the opener... */
MARK_END; /* ...the emitted token is exactly that one char */
/* Read ahead to gather the construct for the heuristic, stopping once we
* have buffered the matching close (so intuit_more can find it) or we run
* out of room / input. These advances past MARK_END are pure lookahead;
* the token stays one char wide. Non-ASCII collapses to a placeholder
* since the heuristic is ASCII-only by design (a best-effort gap). */
while (n < (int)sizeof(buf) && c != 0 && !lexer->eof(lexer)) {
buf[n++] = (c < 0x80) ? (char)c : (char)0x7f;
if (c == close) break;
ADVANCE_C;
}
if (!tsp_intuit_more(buf, n)) {
/* If this class/quantifier opener is also the quote's own delimiter
* (`m{ \d{2} }`, `m[ [abc] ]`), it opens a nested level — bump the count
* so the matching inner close doesn't terminate the quote early. The
* content scanner does this when it consumes `{`/`[` inline; we must do
* the same here, since we only reach this branch when the opener leads a
* scan (e.g. right after an escape) and the content scanner is bypassed. */
int32_t qi = lexerstate_is_quote_opener(state, open);
if (qi) lexerstate_saw_opener(state, qi);
TOKEN(open == '[' ? TOKEN_REGEXP_OPEN_BRACKET : TOKEN_REGEXP_OPEN_BRACE);
}
/* subscript: let the grammar's immediate '[' / '{' win */
return false;
}
}
if (valid_symbols[TOKEN_POD]) {
int column = lexer->get_column(lexer);
if (column == 0 && c == '=') {
@@ -648,7 +1230,7 @@ bool tree_sitter_perl_external_scanner_scan(void *payload, TSLexer *lexer,
bool should_indent = false;
bool should_interpolate = true;
TSPString delim;
TSPString delim = {0};
tspstring_reset(&delim);
if (!skipped_whitespace) {
if (c == '~') {
@@ -694,7 +1276,13 @@ bool tree_sitter_perl_external_scanner_scan(void *payload, TSLexer *lexer,
ADVANCE_C;
}
}
if (delim.length > 0) {
// We stop the loop above either at the closing quote or at EOF. Only
// commit a heredoc if we actually found the closer; an EMPTY delimiter
// (`<<''` / `<<""`) is legal — perl terminates its body at the next blank
// line, which the body matcher already handles (an empty delim compares
// equal to an empty line). Keying off the closer rather than a non-empty
// delim is also more correct: it won't mis-fire on EOF-without-closer.
if (c == delim_open) {
// gotta eat that delimiter
ADVANCE_C;
// gotta null terminate up in here
@@ -724,10 +1312,28 @@ bool tree_sitter_perl_external_scanner_scan(void *payload, TSLexer *lexer,
}
MARK_END;
// In a paired multi-part quote (s{}{}, tr[][], ...), the replacement pair
// opens a fresh quote whose delimiter may differ from the pattern's. The
// pattern's quote is still on top of the stack (middle_close consumes its
// closer but doesn't pop it), so its closer would wrongly stay active while
// we scan the replacement. Now that the second pair is opening, retire it.
// MIDDLE_SKIP being a valid symbol here means we're at the middle choice
// point (between pattern and replacement) rather than an initial begin.
if (valid_symbols[TOKEN_QUOTELIKE_MIDDLE_SKIP] && state->quotes.size) {
lexerstate_pop_quote(state, state->quotes.size);
}
lexerstate_push_quote(state, delim);
// TODO - fill in this debug print here?
// DEBUG("Generic QSTRING open='%c' close='%c'\n", state->delim_open,
// state->delim_close);
/* Pattern-leading bracket lookahead (see TSPQuote.body_leads_with_delim):
* for a paired delimiter, peek past any leading whitespace -- if the body's
* first real char is the delimiter again (m{{...}}, qr{ {...} }, m[[...]]),
* it's a literal leading group, not a subscript. This is pure lookahead:
* MARK_END already covers just the opener, so these advances don't extend
* the emitted token and the body is re-scanned from the opener's end. */
if (close_for_open(delim)) {
while (is_tsp_whitespace(c)) ADVANCE_C;
if (c == delim) array_back(&state->quotes)->body_leads_with_delim = true;
}
TOKEN(TOKEN_QUOTELIKE_BEGIN);
}
@@ -885,6 +1491,23 @@ bool tree_sitter_perl_external_scanner_scan(void *payload, TSLexer *lexer,
}
return false;
}
// A lone non-identifier punctuation variable inside ${...} — ${@}, ${!},
// ${%}, ${$}, ${"} … — names the punctuation variable $@/$!/…, NOT a
// sigil/operator. The main lexer would otherwise pick the sigil/operator token
// (and for @ / % that token swallows the closing brace, decapitating the rest
// of the file). Recognize it here with the same '}'-lookahead the bareword
// path uses: one var char immediately followed (modulo whitespace) by '}' is
// the autoquoted name. Identifiers, digits and ^carets are handled by the
// grammar's other varname alternatives; '{' would begin a block, '#' a comment.
if (valid_symbols[TOKEN_BRACE_AUTOQUOTED] && !isidfirst(c) &&
c > ' ' && c != '}' && c != '{' && c != '^' && c != '#' &&
!(c >= '0' && c <= '9')) {
ADVANCE_C;
MARK_END;
while (is_tsp_whitespace(c)) ADVANCE_C;
if (c == '}') TOKEN(TOKEN_BRACE_AUTOQUOTED);
return false;
}
if (isidfirst(c) &&
(valid_symbols[TOKEN_FAT_COMMA_AUTOQUOTED] || valid_symbols[TOKEN_BRACE_AUTOQUOTED])) {
// we zip until the end of the identifier; then we do a lookeahed to see if it's autoquoted
@@ -898,17 +1521,26 @@ bool tree_sitter_perl_external_scanner_scan(void *payload, TSLexer *lexer,
// NOTE - TS is annoying about skipping chars after you've hit done
// mark_end, so we have to do the regular advance so our token actually shows up
// The contextual-keyword block jumps here (after reading its word + MARK_END)
// to reuse this comment-skip + fat_comma_check instead of duplicating them.
kw_autoquote:
while (is_tsp_whitespace(c) || c == '#') {
while (is_tsp_whitespace(c)) ADVANCE_C;
// now we need to skip comments - we get in a funny way if we have a quotelike
// operator followed by a comment as the quote char
if (c == '#') {
ADVANCE_C;
while (lexer->get_column(lexer)) ADVANCE_C;
while (lexer->get_column(lexer) && !lexer->eof(lexer)) ADVANCE_C;
}
if (lexer->eof(lexer)) return false;
// TODO - in theory there could be POD here that we needa skip over (EYES ROLL)
}
// The keyword peek's fat comma detection gotos here when it finds a
// statement keyword followed by '=' on a new line. The peek has already
// consumed the word + whitespace; lexer is at '='. MARK_END was set by
// the peek's caller (covers the word). Same goto pattern as heredoc vs
// diamond operator disambiguation.
fat_comma_check:
c1 = lexer->lookahead;
ADVANCE_C;
if (valid_symbols[TOKEN_FAT_COMMA_AUTOQUOTED]) {
@@ -52,67 +52,96 @@ extern "C" {
/// Reserve `new_capacity` elements of space in the array. If `new_capacity` is
/// less than the array's current capacity, this function has no effect.
#define array_reserve(self, new_capacity) \
_array__reserve((Array *)(self), array_elem_size(self), new_capacity)
#define array_reserve(self, new_capacity) \
((self)->contents = _array__reserve( \
(void *)(self)->contents, &(self)->capacity, \
array_elem_size(self), new_capacity) \
)
/// Free any memory allocated for this array. Note that this does not free any
/// memory allocated for the array's contents.
#define array_delete(self) _array__delete((Array *)(self))
#define array_delete(self) \
do { \
if ((self)->contents) ts_free((self)->contents); \
(self)->contents = NULL; \
(self)->size = 0; \
(self)->capacity = 0; \
} while (0)
/// Push a new `element` onto the end of the array.
#define array_push(self, element) \
(_array__grow((Array *)(self), 1, array_elem_size(self)), \
(self)->contents[(self)->size++] = (element))
#define array_push(self, element) \
do { \
(self)->contents = _array__grow( \
(void *)(self)->contents, (self)->size, &(self)->capacity, \
1, array_elem_size(self) \
); \
(self)->contents[(self)->size++] = (element); \
} while(0)
/// Increase the array's size by `count` elements.
/// New elements are zero-initialized.
#define array_grow_by(self, count) \
do { \
if ((count) == 0) break; \
_array__grow((Array *)(self), count, array_elem_size(self)); \
#define array_grow_by(self, count) \
do { \
if ((count) == 0) break; \
(self)->contents = _array__grow( \
(self)->contents, (self)->size, &(self)->capacity, \
count, array_elem_size(self) \
); \
memset((self)->contents + (self)->size, 0, (count) * array_elem_size(self)); \
(self)->size += (count); \
(self)->size += (count); \
} while (0)
/// Append all elements from one array to the end of another.
#define array_push_all(self, other) \
#define array_push_all(self, other) \
array_extend((self), (other)->size, (other)->contents)
/// Append `count` elements to the end of the array, reading their values from the
/// `contents` pointer.
#define array_extend(self, count, contents) \
_array__splice( \
(Array *)(self), array_elem_size(self), (self)->size, \
0, count, contents \
#define array_extend(self, count, other_contents) \
(self)->contents = _array__splice( \
(void*)(self)->contents, &(self)->size, &(self)->capacity, \
array_elem_size(self), (self)->size, 0, count, other_contents \
)
/// Remove `old_count` elements from the array starting at the given `index`. At
/// the same index, insert `new_count` new elements, reading their values from the
/// `new_contents` pointer.
#define array_splice(self, _index, old_count, new_count, new_contents) \
_array__splice( \
(Array *)(self), array_elem_size(self), _index, \
old_count, new_count, new_contents \
#define array_splice(self, _index, old_count, new_count, new_contents) \
(self)->contents = _array__splice( \
(void *)(self)->contents, &(self)->size, &(self)->capacity, \
array_elem_size(self), _index, old_count, new_count, new_contents \
)
/// Insert one `element` into the array at the given `index`.
#define array_insert(self, _index, element) \
_array__splice((Array *)(self), array_elem_size(self), _index, 0, 1, &(element))
#define array_insert(self, _index, element) \
(self)->contents = _array__splice( \
(void *)(self)->contents, &(self)->size, &(self)->capacity, \
array_elem_size(self), _index, 0, 1, &(element) \
)
/// Remove one element from the array at the given `index`.
#define array_erase(self, _index) \
_array__erase((Array *)(self), array_elem_size(self), _index)
_array__erase((void *)(self)->contents, &(self)->size, array_elem_size(self), _index)
/// Pop the last element off the array, returning the element by value.
#define array_pop(self) ((self)->contents[--(self)->size])
/// Assign the contents of one array to another, reallocating if necessary.
#define array_assign(self, other) \
_array__assign((Array *)(self), (const Array *)(other), array_elem_size(self))
#define array_assign(self, other) \
(self)->contents = _array__assign( \
(void *)(self)->contents, &(self)->size, &(self)->capacity, \
(const void *)(other)->contents, (other)->size, array_elem_size(self) \
)
/// Swap one array with another
#define array_swap(self, other) \
_array__swap((Array *)(self), (Array *)(other))
#define array_swap(self, other) \
do { \
void *_array_swap_tmp = (void *)(self)->contents; \
(self)->contents = (other)->contents; \
(other)->contents = _array_swap_tmp; \
_array__swap(&(self)->size, &(self)->capacity, \
&(other)->size, &(other)->capacity); \
} while (0)
/// Get the size of the array contents
#define array_elem_size(self) (sizeof *(self)->contents)
@@ -157,82 +186,90 @@ extern "C" {
// Private
typedef Array(void) Array;
/// This is not what you're looking for, see `array_delete`.
static inline void _array__delete(Array *self) {
if (self->contents) {
ts_free(self->contents);
self->contents = NULL;
self->size = 0;
self->capacity = 0;
}
}
// Pointers to individual `Array` fields (rather than the entire `Array` itself)
// are passed to the various `_array__*` functions below to address strict aliasing
// violations that arises when the _entire_ `Array` struct is passed as `Array(void)*`.
//
// The `Array` type itself was not altered as a solution in order to avoid breakage
// with existing consumers (in particular, parsers with external scanners).
/// This is not what you're looking for, see `array_erase`.
static inline void _array__erase(Array *self, size_t element_size,
uint32_t index) {
assert(index < self->size);
char *contents = (char *)self->contents;
static inline void _array__erase(void* self_contents, uint32_t *size,
size_t element_size, uint32_t index) {
assert(index < *size);
char *contents = (char *)self_contents;
memmove(contents + index * element_size, contents + (index + 1) * element_size,
(self->size - index - 1) * element_size);
self->size--;
(*size - index - 1) * element_size);
(*size)--;
}
/// This is not what you're looking for, see `array_reserve`.
static inline void _array__reserve(Array *self, size_t element_size, uint32_t new_capacity) {
if (new_capacity > self->capacity) {
if (self->contents) {
self->contents = ts_realloc(self->contents, new_capacity * element_size);
static inline void *_array__reserve(void *contents, uint32_t *capacity,
size_t element_size, uint32_t new_capacity) {
void *new_contents = contents;
if (new_capacity > *capacity) {
if (contents) {
new_contents = ts_realloc(contents, new_capacity * element_size);
} else {
self->contents = ts_malloc(new_capacity * element_size);
new_contents = ts_malloc(new_capacity * element_size);
}
self->capacity = new_capacity;
*capacity = new_capacity;
}
return new_contents;
}
/// This is not what you're looking for, see `array_assign`.
static inline void _array__assign(Array *self, const Array *other, size_t element_size) {
_array__reserve(self, element_size, other->size);
self->size = other->size;
memcpy(self->contents, other->contents, self->size * element_size);
static inline void *_array__assign(void* self_contents, uint32_t *self_size, uint32_t *self_capacity,
const void *other_contents, uint32_t other_size, size_t element_size) {
void *new_contents = _array__reserve(self_contents, self_capacity, element_size, other_size);
*self_size = other_size;
memcpy(new_contents, other_contents, *self_size * element_size);
return new_contents;
}
/// This is not what you're looking for, see `array_swap`.
static inline void _array__swap(Array *self, Array *other) {
Array swap = *other;
*other = *self;
*self = swap;
static inline void _array__swap(uint32_t *self_size, uint32_t *self_capacity,
uint32_t *other_size, uint32_t *other_capacity) {
uint32_t tmp_size = *self_size;
uint32_t tmp_capacity = *self_capacity;
*self_size = *other_size;
*self_capacity = *other_capacity;
*other_size = tmp_size;
*other_capacity = tmp_capacity;
}
/// This is not what you're looking for, see `array_push` or `array_grow_by`.
static inline void _array__grow(Array *self, uint32_t count, size_t element_size) {
uint32_t new_size = self->size + count;
if (new_size > self->capacity) {
uint32_t new_capacity = self->capacity * 2;
static inline void *_array__grow(void *contents, uint32_t size, uint32_t *capacity,
uint32_t count, size_t element_size) {
void *new_contents = contents;
uint32_t new_size = size + count;
if (new_size > *capacity) {
uint32_t new_capacity = *capacity * 2;
if (new_capacity < 8) new_capacity = 8;
if (new_capacity < new_size) new_capacity = new_size;
_array__reserve(self, element_size, new_capacity);
new_contents = _array__reserve(contents, capacity, element_size, new_capacity);
}
return new_contents;
}
/// This is not what you're looking for, see `array_splice`.
static inline void _array__splice(Array *self, size_t element_size,
static inline void *_array__splice(void *self_contents, uint32_t *size, uint32_t *capacity,
size_t element_size,
uint32_t index, uint32_t old_count,
uint32_t new_count, const void *elements) {
uint32_t new_size = self->size + new_count - old_count;
uint32_t new_size = *size + new_count - old_count;
uint32_t old_end = index + old_count;
uint32_t new_end = index + new_count;
assert(old_end <= self->size);
assert(old_end <= *size);
_array__reserve(self, element_size, new_size);
void *new_contents = _array__reserve(self_contents, capacity, element_size, new_size);
char *contents = (char *)self->contents;
if (self->size > old_end) {
char *contents = (char *)new_contents;
if (*size > old_end) {
memmove(
contents + new_end * element_size,
contents + old_end * element_size,
(self->size - old_end) * element_size
(*size - old_end) * element_size
);
}
if (new_count > 0) {
@@ -250,7 +287,9 @@ static inline void _array__splice(Array *self, size_t element_size,
);
}
}
self->size += new_count - old_count;
*size += new_count - old_count;
return new_contents;
}
/// A binary search routine, based on Rust's `std::slice::binary_search_by`.
@@ -18,6 +18,11 @@ typedef uint16_t TSStateId;
typedef uint16_t TSSymbol;
typedef uint16_t TSFieldId;
typedef struct TSLanguage TSLanguage;
typedef struct TSLanguageMetadata {
uint8_t major_version;
uint8_t minor_version;
uint8_t patch_version;
} TSLanguageMetadata;
#endif
typedef struct {
@@ -26,10 +31,11 @@ typedef struct {
bool inherited;
} TSFieldMapEntry;
// Used to index the field and supertype maps.
typedef struct {
uint16_t index;
uint16_t length;
} TSFieldMapSlice;
} TSMapSlice;
typedef struct {
bool visible;
@@ -79,6 +85,12 @@ typedef struct {
uint16_t external_lex_state;
} TSLexMode;
typedef struct {
uint16_t lex_state;
uint16_t external_lex_state;
uint16_t reserved_word_set_id;
} TSLexerMode;
typedef union {
TSParseAction action;
struct {
@@ -93,7 +105,7 @@ typedef struct {
} TSCharacterRange;
struct TSLanguage {
uint32_t version;
uint32_t abi_version;
uint32_t symbol_count;
uint32_t alias_count;
uint32_t token_count;
@@ -109,13 +121,13 @@ struct TSLanguage {
const TSParseActionEntry *parse_actions;
const char * const *symbol_names;
const char * const *field_names;
const TSFieldMapSlice *field_map_slices;
const TSMapSlice *field_map_slices;
const TSFieldMapEntry *field_map_entries;
const TSSymbolMetadata *symbol_metadata;
const TSSymbol *public_symbol_map;
const uint16_t *alias_map;
const TSSymbol *alias_sequences;
const TSLexMode *lex_modes;
const TSLexerMode *lex_modes;
bool (*lex_fn)(TSLexer *, TSStateId);
bool (*keyword_lex_fn)(TSLexer *, TSStateId);
TSSymbol keyword_capture_token;
@@ -129,15 +141,23 @@ struct TSLanguage {
void (*deserialize)(void *, const char *, unsigned);
} external_scanner;
const TSStateId *primary_state_ids;
const char *name;
const TSSymbol *reserved_words;
uint16_t max_reserved_word_set_size;
uint32_t supertype_count;
const TSSymbol *supertype_symbols;
const TSMapSlice *supertype_map_slices;
const TSSymbol *supertype_map_entries;
TSLanguageMetadata metadata;
};
static inline bool set_contains(TSCharacterRange *ranges, uint32_t len, int32_t lookahead) {
static inline bool set_contains(const TSCharacterRange *ranges, uint32_t len, int32_t lookahead) {
uint32_t index = 0;
uint32_t size = len - index;
while (size > 1) {
uint32_t half_size = size / 2;
uint32_t mid_index = index + half_size;
TSCharacterRange *range = &ranges[mid_index];
const TSCharacterRange *range = &ranges[mid_index];
if (lookahead >= range->start && lookahead <= range->end) {
return true;
} else if (lookahead > range->end) {
@@ -145,7 +165,7 @@ static inline bool set_contains(TSCharacterRange *ranges, uint32_t len, int32_t
}
size -= half_size;
}
TSCharacterRange *range = &ranges[index];
const TSCharacterRange *range = &ranges[index];
return (lookahead >= range->start && lookahead <= range->end);
}
File diff suppressed because it is too large Load Diff
@@ -0,0 +1,210 @@
/* tsp_intuit_more.h
*
* A faithful, stateless port of perl's S_intuit_more() (toke.c) and
* S_regcurly() (regcomp.c) -- "the one truly awful dwimmer necessary to
* conflate C and sed".
*
* Inside a pattern, a `[` or `{` following a variable is ambiguous:
* /$foo[...]/ could be an array subscript OR a character class
* /$foo{...}/ could be a hash subscript OR a {n,m} quantifier
* Perl resolves this with a weighting heuristic. We reproduce it so the
* external scanner can decide whether to emit a literal regex `[` / `{`.
*
* tsp_intuit_more(s, len) returns TRUE => "there is more to the expression",
* i.e. it's a SUBSCRIPT; FALSE => it's a character class / quantifier. This
* matches perl's return-value convention exactly.
*
* The caller is the scanner; it has already established that we are inside a
* pattern and that s[0] is '[' or '{'. `s` points at that bracket and spans
* `len` buffered bytes, ideally through the matching close bracket (when one
* exists in range). The function never reads past s[len-1].
*
* Three branches of perl's heuristic depend on state a stateless lexer can't
* see; these are intentional best-effort gaps an LSP can refine:
* - PL_lex_brackets (parser-stack recursion) -> handled by the scanner
* - gv_fetchpvn_flags (runtime symbol table, -100) -> treated as the -10 case
* - keyword() (-150) -> backed by our own
* regenerated keyword trie (tsp_intuit_keywords.h)
*/
#ifndef TSP_INTUIT_MORE_H
#define TSP_INTUIT_MORE_H
#include <stdbool.h>
#include <stddef.h>
#include "tsp_intuit_keywords.h"
/* --- ASCII classification (perl's is* macros, ASCII subset) ----------------
* UTF-8 word characters beyond ASCII are a best-effort gap. */
static inline bool tsp_im_isdigit(int c) { return c >= '0' && c <= '9'; }
static inline bool tsp_im_isalpha(int c) {
return (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z');
}
static inline bool tsp_im_isword(int c) {
return tsp_im_isalpha(c) || tsp_im_isdigit(c) || c == '_';
}
static inline bool tsp_im_isblank(int c) { return c == ' ' || c == '\t'; }
/* strchr over a literal set, NUL-safe (a NUL `c` never matches). */
static inline bool tsp_im_in(const char *set, int c) {
if (c == 0) return false;
for (; *set; set++)
if ((unsigned char)*set == (unsigned char)c) return true;
return false;
}
/* --- S_regcurly: does s[0..len) begin a {m,n} quantifier? ------------------
* Mirrors regcomp.c. We only need the syntactic yes/no, so the result[]
* out-param is dropped. Accepts {m}, {m,}, {m,n}, and {,n}; rejects {} . */
static bool tsp_regcurly(const char *s, int len) {
const char *e = s + len;
bool min_present = false; /* perl's min_start: digit(s) before the comma */
bool max_present = false; /* perl's max_end: digit(s) after the comma */
if (s >= e || *s++ != '{') return false;
while (s < e && tsp_im_isblank(*s)) s++;
if (s < e && tsp_im_isdigit(*s)) {
min_present = true;
do { s++; } while (s < e && tsp_im_isdigit(*s));
}
while (s < e && tsp_im_isblank(*s)) s++;
if (s < e && *s == ',') {
s++;
while (s < e && tsp_im_isblank(*s)) s++;
if (s < e && tsp_im_isdigit(*s)) {
max_present = true;
do { s++; } while (s < e && tsp_im_isdigit(*s));
}
while (s < e && tsp_im_isblank(*s)) s++;
}
/* Mirrors regcomp.c: must close with '}' and have at least one number,
* before or after the comma ({3}, {3,}, {3,5}, {,5}); '{}' and '{,}' fail. */
if (s >= e || *s != '}' || (!min_present && !max_present)) return false;
return true;
}
/* --- S_intuit_more: subscript (TRUE) vs char-class/quantifier (FALSE) ------ */
static bool tsp_intuit_more(const char *s, int len) {
const char *e = s + len;
if (s >= e) return true; /* nothing buffered; be safe */
/* In a pattern, a leading '{' might be a {n,m} quantifier. */
if (s[0] == '{') {
return !tsp_regcurly(s, len);
}
if (s[0] != '[') return true; /* caller only sends '[' or '{' */
s++; /* step past '[' */
/* '^' implies a char class; empty '[]' isn't legal but means "no more". */
if (s >= e) return true; /* '[' with nothing after -> expr */
if (s[0] == ']' || s[0] == '^') return false;
/* Find the matching ']'. No ']' in range => has to be an expression. */
const char *send = NULL;
for (const char *p = s; p < e; p++) {
if (*p == ']') { send = p; break; }
}
if (!send) return true;
/* One or two digits only => subscript, e.g. [12]. */
if (tsp_im_isdigit(s[0]) && send - s <= 2 &&
(send - s == 1 || tsp_im_isdigit(s[1]))) {
return true;
}
/* The weighting machine. weight >= 0 => char class, < 0 => subscript. */
int weight = (s[0] == '$') ? -1 : 2; /* '$' leans slightly to subscript */
unsigned char seen[256] = {0};
unsigned char un_char = 0;
bool first_time = true;
for (; s < send; s++, first_time = false) {
unsigned char prev_un_char = un_char;
un_char = (unsigned char)s[0];
switch (s[0]) {
case '@':
case '&':
case '$':
weight -= seen[un_char] * 10;
/* A word char following one of these: perl would consult the symbol
* table for a -100; we lack it, so always take the -10 path (gap). */
if (s + 1 < e && tsp_im_isword((unsigned char)s[1])) {
weight -= 10;
}
else if (s[0] == '$' && s + 1 < e && s[1] &&
tsp_im_in("[#!%*<>()-=", (unsigned char)s[1])) {
/* Possible punctuation variable. */
char s2 = (s + 2 < e) ? s[2] : 0;
if (tsp_im_in("])} =", (unsigned char)s2)) weight -= 10;
else weight -= 1;
}
break;
case '\\':
if (s + 1 < e && s[1]) {
if (tsp_im_in("wds]", (unsigned char)s[1])) weight += 100;
else if (seen[(unsigned char)'\''] || seen[(unsigned char)'"']) weight += 1;
else if (tsp_im_in("abcfnrtvx", (unsigned char)s[1])) weight += 40;
else if (tsp_im_isdigit((unsigned char)s[1])) {
weight += 40;
while (s + 1 < send && tsp_im_isdigit((unsigned char)s[1])) s++;
}
}
else weight += 100; /* '\' at end strongly char class */
break;
case '-':
if (s + 1 < e && s[1] == '\\') weight += 50;
if (!first_time && tsp_im_in("aA01! ", prev_un_char)) weight += 30;
if (s + 1 < e && tsp_im_in("zZ79~", (unsigned char)s[1])) weight += 30;
if (first_time && s + 1 < e &&
(tsp_im_isdigit((unsigned char)s[1]) || s[1] == '$')) {
weight -= 5; /* negative subscript */
}
break;
default:
if ((first_time || (!tsp_im_isword(prev_un_char)
&& prev_un_char != '$'
&& prev_un_char != '@'
&& prev_un_char != '&'))
&& tsp_im_isalpha((unsigned char)s[0])
&& s + 1 < send && tsp_im_isalpha((unsigned char)s[1])) {
/* A run of >= 2 alphas at a boundary: if it spells a keyword it's
* almost certainly not a character class. (Mirrors perl's pointer
* walk: s lands on the first non-alpha, which the loop's s++ then
* skips -- intentional, matching toke.c.) */
const char *d = s;
while (s < send && tsp_im_isalpha((unsigned char)s[0])) s++;
if (tsp_is_perl_keyword(d, (int)(s - d))) weight -= 150;
}
/* Ascending runs like ...12... or ...ab... lean char class. */
if (!first_time && un_char == (unsigned char)(prev_un_char + 1)) {
weight += 5;
}
/* Repeats lean subscript (nobody writes [aba] as a class). */
weight -= seen[un_char];
break;
}
seen[un_char]++;
}
if (weight >= 0) return false; /* probably a character class */
return true; /* subscript */
}
#endif /* TSP_INTUIT_MORE_H */
@@ -0,0 +1,207 @@
/* tsp_intuit_readline.h
*
* Disambiguates `<...>` after an ambiguous bareword: fileglob/readline
* (`print <*.c>`) vs the relational `<` operator (`CONST < 7 > $x`). Real
* perl decides this by PL_expect (was a value or a list-op in front of `<`?),
* which the scanner can't see, so we hybridise two heuristics whose blind
* spots are disjoint:
*
* (a) glob-shape: a real target looks like a glob pattern (metachar `*?[]{}~`,
* path `/`, filename-dot `foo.c`) or a pure filehandle name; content that
* is neither (a number, a spaced scalar, an operand) is relational. This
* catches `CONST < $a > foo`, which (b) alone misreads.
* (b) orphan lookahead: a glob is a complete term, so a bare term right after
* its `>` would be orphaned -> `<` was the operator. This catches
* `CONST < $a/$b > $c` (glob-shaped content, but `$c` orphans), which (a)
* alone misreads.
*
* tsp_is_fileglob(content, clen, after, alen): TRUE => emit fileglob; FALSE =>
* bail to the `<` operator. See the decision body below. Best-effort and
* ASCII-only (an LSP with parser state can refine it); never reads past either
* buffer. `after` is a capped window; if it holds only whitespace we treat it
* as EOF and allow the glob.
*/
#ifndef TSP_INTUIT_READLINE_H
#define TSP_INTUIT_READLINE_H
#include <stdbool.h>
#include <stddef.h>
#include <string.h>
/* --- ASCII classification (mirrors the subset used elsewhere) -------------- */
static inline bool tsp_rl_isdigit(int c) { return c >= '0' && c <= '9'; }
static inline bool tsp_rl_isalpha(int c) {
return (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z');
}
static inline bool tsp_rl_isword(int c) {
return tsp_rl_isalpha(c) || tsp_rl_isdigit(c) || c == '_';
}
static inline bool tsp_rl_isspace(int c) {
return c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\f' ||
c == '\v';
}
/* The low-precedence operator / statement-modifier keywords that may legally
* FOLLOW a complete `bareword <glob>` term. Seeing one of these after the `>`
* means the glob is complete, not orphaning a term. */
static inline bool tsp_rl_is_trailing_keyword(const char *w, size_t n) {
static const char *const kw[] = {
"if", "unless", "while", "until", "for", "foreach", "and", "or", "xor",
"not", "cmp", "eq", "ne", "lt", "gt", "le", "ge", "x"};
for (size_t i = 0; i < sizeof(kw) / sizeof(kw[0]); i++) {
if (strlen(kw[i]) == n && memcmp(w, kw[i], n) == 0) return true;
}
return false;
}
/* The infix word-operators that, when appearing INSIDE the `<...>` content as a
* whitespace-delimited word, prove it is a relational expression rather than a
* glob pattern (a glob never contains a bare perl operator word). */
static inline bool tsp_rl_is_infix_word(const char *w, size_t n) {
static const char *const kw[] = {"and", "or", "xor", "not", "cmp", "eq",
"ne", "lt", "gt", "le", "ge", "x"};
for (size_t i = 0; i < sizeof(kw) / sizeof(kw[0]); i++) {
if (strlen(kw[i]) == n && memcmp(w, kw[i], n) == 0) return true;
}
return false;
}
/* Scan the `<...>` content for a whitespace-delimited infix operator word.
* Only alpha runs that start at a whitespace boundary (and are not glued to
* sigils/digits/punctuation) count; `$x` or `*.c` never qualify. */
static inline bool tsp_rl_content_has_infix_op(const char *s, size_t len) {
size_t i = 0;
while (i < len) {
/* skip leading whitespace */
while (i < len && tsp_rl_isspace((unsigned char)s[i])) i++;
size_t start = i;
bool clean = true; /* a clean bare word: only alphas */
while (i < len && !tsp_rl_isspace((unsigned char)s[i])) {
if (!tsp_rl_isalpha((unsigned char)s[i])) clean = false;
i++;
}
if (clean && i > start && tsp_rl_is_infix_word(s + start, i - start))
return true;
}
return false;
}
/* The glob metacharacters whose presence in the content is decisive evidence
* of a glob pattern (as opposed to a relational operand). */
static inline bool tsp_rl_is_glob_meta(int c) {
return c == '*' || c == '?' || c == '[' || c == ']' || c == '{' || c == '}' ||
c == '~';
}
/* Does the content POSITIVELY look like a glob pattern? True if it contains a
* glob metacharacter, a path separator `/`, or a filename-looking `.` (a dot
* flanked by word characters, e.g. `foo.c`). A bare number (`7`), a lone
* scalar (`$a`), or an operator expression has none of these. */
static inline bool tsp_rl_content_is_globshaped(const char *s, size_t len) {
for (size_t i = 0; i < len; i++) {
unsigned char c = (unsigned char)s[i];
if (tsp_rl_is_glob_meta(c) || c == '/') return true;
if (c == '.') {
bool prev_word = (i > 0) && tsp_rl_isword((unsigned char)s[i - 1]);
bool next_word = (i + 1 < len) && tsp_rl_isword((unsigned char)s[i + 1]);
if (prev_word && next_word) return true;
}
}
return false;
}
/* Is the content a pure filehandle / scalar NAME (no leading whitespace): an
* optional leading `$`, then word characters with `::` or `'` package
* separators (e.g. `$fh`, `STDIN`, `Foo::BAR`), tolerating only trailing
* whitespace? Such content is a readline target, not a relational operand.
* The leading-vs-trailing whitespace asymmetry is load-bearing: a glob target
* is written tight against `<` (`<$sner >`), whereas a relational `< EXPR`
* carries a separating space (`< $a > $b`). */
static inline bool tsp_rl_is_filehandle(const char *buf, size_t len) {
size_t i = 0;
if (i >= len || tsp_rl_isspace((unsigned char)buf[i])) return false;
if (buf[i] == '$') i++;
if (i >= len) return false; /* bare `$`: not a name */
bool last_was_word = false;
while (i < len) {
if (tsp_rl_isword((unsigned char)buf[i])) {
last_was_word = true;
i++;
} else if (buf[i] == ':') {
if (!last_was_word) return false;
if (i + 1 >= len || buf[i + 1] != ':') return false;
last_was_word = false;
i += 2;
} else if (buf[i] == '\'') {
if (!last_was_word) return false;
last_was_word = false;
i++;
} else if (tsp_rl_isspace((unsigned char)buf[i])) {
if (!last_was_word) return false;
for (i++; i < len; i++)
if (!tsp_rl_isspace((unsigned char)buf[i])) return false;
return true;
} else {
return false;
}
}
return last_was_word;
}
/* --- the decision ---------------------------------------------------------- */
static inline bool tsp_is_fileglob(const char *content, size_t clen,
const char *after, size_t alen) {
/* The empty diamond `<>` (rare here; usually handled before us). */
if (clen == 0) return true;
/* (1) operator-word inside the content => relational expression, not glob. */
if (tsp_rl_content_has_infix_op(content, clen)) return false;
/* (2) GLOB-SHAPE GATE. A real glob/readline target positively looks like a
* glob pattern (metachar / path / filename-dot) or a pure filehandle name.
* Content that is neither -- a bare number (`< 7 >`), a lone scalar with a
* separating space (`< $a > $b`), an arithmetic sub-expression -- is a
* relational operand, so bail. This is what keeps `CONST < $a > foo` and
* `CONST < 7 > $x` relational without any lookahead. */
if (!tsp_rl_content_is_globshaped(content, clen) &&
!tsp_rl_is_filehandle(content, clen))
return false;
/* (3) post-`>` orphan lookahead. The content looks glob-shaped, but a real
* glob is a COMPLETE term: if a bare term follows the `>` with no connecting
* operator it would be orphaned, which means `<` was the relational operator
* after all (e.g. `CONST < $a/$b > $c` -- glob-shaped content `$a/$b`, yet
* the trailing `$c` orphans). */
size_t i = 0;
while (i < alen && tsp_rl_isspace((unsigned char)after[i])) i++;
/* Window exhausted before any non-space byte: treat as EOF-like -> glob ok. */
if (i >= alen) return true;
unsigned char nc = (unsigned char)after[i];
/* An alphabetic word: keyword => complete term (glob ok); otherwise an
* ambiguous bareword, which we lean toward NOT treating as an orphan. */
if (tsp_rl_isalpha(nc)) {
size_t start = i;
while (i < alen && tsp_rl_isword((unsigned char)after[i])) i++;
if (tsp_rl_is_trailing_keyword(after + start, i - start)) return true;
/* Unknown bareword after the glob: lean toward glob (do not orphan). */
return true;
}
/* Bare-term openers with no connecting operator => orphan => bail. */
if (nc == '$' || nc == '@' || nc == '%' || nc == '"' || nc == '\'' ||
tsp_rl_isdigit(nc) || nc == '(' || nc == '[' || nc == '{') {
return false;
}
/* Everything else — operators (`+ - * / . < > ! ~ ? : | & ^`), `=`, `=>`,
* comma, `;`, closing brackets `) ] }` — terminates the term cleanly, so the
* glob is complete. */
return true;
}
#endif /* TSP_INTUIT_READLINE_H */
@@ -0,0 +1,33 @@
/* THIS FILE IS GENERATED BY generate_keywords.pl
*
* Statement keywords recognized by peek_is_statement_keyword().
* To add a keyword, edit the @keywords list in generate_keywords.pl
* and re-run: perl generate_keywords.pl
*
* Current keywords: class, method, no, package, role, sub, use
*/
// First-char filter: returns PEEK_NO_MATCH immediately if the
// lookahead can't start any statement keyword.
#define KEYWORD_FIRST_CHAR_FILTER(la) \
(!(la == 'c' || la == 'm' || la == 'n' || la == 'p' || la == 'r' || la == 's' || la == 'u'))
// Word-reading loop: characters that appear in any keyword.
#define KEYWORD_WORD_CHAR(la) \
(la == 'a' || la == 'b' || la == 'c' || la == 'd' || la == 'e' || la == 'g' || la == 'h' || la == 'k' || la == 'l' || la == 'm' || la == 'n' || la == 'o' || la == 'p' || la == 'r' || la == 's' || la == 't' || la == 'u')
// Keyword classification: sets `kind` to one of the KwKind values.
// KW_NONE — not a statement keyword (a plain bareword / autoquote key)
// KW_ALWAYS — always a statement keyword (package, use, no, class, role)
// KW_NEEDS_NAME — only a declaration if followed by a name (sub, method)
// Unlike a bare match this never returns: the caller decides what to do with a
// non-keyword, which may still be a fat-comma autoquote key.
#define KEYWORD_MATCH(word, kind) do { \
if (strcmp(word, "package") == 0 || strcmp(word, "use") == 0 || strcmp(word, "no") == 0 || strcmp(word, "class") == 0 || strcmp(word, "role") == 0) { \
(kind) = KW_ALWAYS; \
} else if (strcmp(word, "sub") == 0 || strcmp(word, "method") == 0) { \
(kind) = KW_NEEDS_NAME; \
} else { \
(kind) = KW_NONE; \
} \
} while(0)
@@ -541,8 +541,8 @@ static const struct TSPRange tsp_id_start[] = {
{ 201552, 205744 }
};
bool is_tsp_id_start (int32_t codepoint) {
return bsearch(&codepoint, tsp_id_start, sizeof(tsp_id_start) / sizeof(tsp_id_start[0]), sizeof(tsp_id_start[0]), tsprange_contains);
static bool is_tsp_id_start (int32_t codepoint) {
return tsp_bsearch(&codepoint, tsp_id_start, sizeof(tsp_id_start) / sizeof(tsp_id_start[0]), sizeof(tsp_id_start[0]), tsprange_contains);
}
static const struct TSPRange tsp_id_continue[] = {
@@ -1205,8 +1205,8 @@ static const struct TSPRange tsp_id_continue[] = {
{ 917760, 918000 }
};
bool is_tsp_id_continue (int32_t codepoint) {
return bsearch(&codepoint, tsp_id_continue, sizeof(tsp_id_continue) / sizeof(tsp_id_continue[0]), sizeof(tsp_id_continue[0]), tsprange_contains);
static bool is_tsp_id_continue (int32_t codepoint) {
return tsp_bsearch(&codepoint, tsp_id_continue, sizeof(tsp_id_continue) / sizeof(tsp_id_continue[0]), sizeof(tsp_id_continue[0]), tsprange_contains);
}
static const struct TSPRange tsp_whitespace[] = {
@@ -1221,6 +1221,6 @@ static const struct TSPRange tsp_whitespace[] = {
{ 8287, 8288 },
{ 12288, 12289 }
};
bool is_tsp_whitespace (int32_t codepoint) {
return bsearch(&codepoint, tsp_whitespace, sizeof(tsp_whitespace) / sizeof(tsp_whitespace[0]), sizeof(tsp_whitespace[0]), tsprange_contains);
static bool is_tsp_whitespace (int32_t codepoint) {
return tsp_bsearch(&codepoint, tsp_whitespace, sizeof(tsp_whitespace) / sizeof(tsp_whitespace[0]), sizeof(tsp_whitespace[0]), tsprange_contains);
}
+11 -7
View File
@@ -5,7 +5,7 @@ c5cfb43042b6b72045f4ba997834d0a7786d2793d91680868b5815b39f14fc78 internal/cbm/v
b29c1c9fb7cc82f58c84b376df1297d6e2737a1d655fd356db0859e3c29c2fea internal/cbm/vendored/common/tree_sitter/alloc.h
31e60a1bff6f715afacce03b5b70efe42b58371b4f9595dd4af52a577ff9608c internal/cbm/vendored/common/tree_sitter/array.h
180b893c8734778fd32f372dfbc27bd6ad1cd2221f26150b31256ff6716320d2 internal/cbm/vendored/common/tree_sitter/parser.h
73be629708008f0cb31e0f8d41dc71ae901626baba191c24efd41bf52220c913 internal/cbm/vendored/grammars/MANIFEST.md
e1233d81f21d868b8f2d9e8fca10e15f2ec3ae4db4a7ba0301161cc011deef65 internal/cbm/vendored/grammars/MANIFEST.md
ad8425038de519f8c4e3e9339feebf99dfad8a6002dcf79227d91402780a32cc internal/cbm/vendored/grammars/ada/LICENSE
02805ec13939b749c891567be36bf024b09034e04c80683a1ae667272458d549 internal/cbm/vendored/grammars/ada/parser.c
115a75d000bef9c70c4de7dfbb7f2a80b90cbb14ba265056dc7abb1ef3b9b6db internal/cbm/vendored/grammars/ada/tree_sitter/alloc.h
@@ -553,13 +553,17 @@ fafd2e286865aacc132e938c1640f51619ec9e7866cd2d8debff39540336c14a internal/cbm/v
6db3411bfeff9fea8e64a1436f13b4c3558c52df0c19ea038a6a22fecae1b6eb internal/cbm/vendored/grammars/pascal/parser.c
2db740ea1be6b71014d2be1385491f01bf2d15b607e61c5b30b4128535efe68a internal/cbm/vendored/grammars/pascal/tree_sitter/parser.h
68a9a526ae357ed5a2f8ca5dabb14131b283554b69639bb04816088d4b1f2fa0 internal/cbm/vendored/grammars/perl/LICENSE
cb08206e89750c1fab700b89fc9876afb5cc689827e514ef49a5569c54635b61 internal/cbm/vendored/grammars/perl/bsearch.h
25c014ab8ce027992a6cfd76ef7b88bf3a41f63fd6ad43f38a553e218a7a9ea8 internal/cbm/vendored/grammars/perl/parser.c
fe4dc0394501b3d6211dcc1e31e9731befae844fcd6db0130e3c16f992d85860 internal/cbm/vendored/grammars/perl/scanner.c
6f953a91955c72b1b6b063c34fa877c8b36f5b43c320083ad7361256e67b9484 internal/cbm/vendored/grammars/perl/bsearch.h
ab3f9bf80dda8a4b919ffc8b556bd6e6e44995974e71acf4f4c0d6ebf5653625 internal/cbm/vendored/grammars/perl/parser.c
117d53b68474bf11e0b207d3e63e359b05be6f98d91d2c31b6abcec3a960eb1b internal/cbm/vendored/grammars/perl/scanner.c
b29c1c9fb7cc82f58c84b376df1297d6e2737a1d655fd356db0859e3c29c2fea internal/cbm/vendored/grammars/perl/tree_sitter/alloc.h
5bdf6ed1a78e3409fd443e085ca967a64c188a5d082aaf7f819bccd53a471c94 internal/cbm/vendored/grammars/perl/tree_sitter/array.h
a1f6ef161fbaf48a0e10fca90ef5290a062462b307b3898aa562993853b9f80a internal/cbm/vendored/grammars/perl/tree_sitter/parser.h
9cbc0731f8c9bd52bd3de9644fd887f20cecea2d17634b20769db4940eadb566 internal/cbm/vendored/grammars/perl/tsp_unicode.h
31e60a1bff6f715afacce03b5b70efe42b58371b4f9595dd4af52a577ff9608c internal/cbm/vendored/grammars/perl/tree_sitter/array.h
180b893c8734778fd32f372dfbc27bd6ad1cd2221f26150b31256ff6716320d2 internal/cbm/vendored/grammars/perl/tree_sitter/parser.h
e65b7139547077b59ad62cb109efcf73d420311706c9dc7b6f9831cb246f2c61 internal/cbm/vendored/grammars/perl/tsp_intuit_keywords.h
45ada959185bb4b15f4fe702d52f0aeb5cd992b64cb129248aa843644e6026a2 internal/cbm/vendored/grammars/perl/tsp_intuit_more.h
9504b2ef7cce98bd3b22e2226ca05c1b63fd17b56ed3375bf72c4e429af42180 internal/cbm/vendored/grammars/perl/tsp_intuit_readline.h
2c86ede8eedbaf7854c2f9eef4b835ae55e563d7a85c05e47d8bfee502e5a78f internal/cbm/vendored/grammars/perl/tsp_keywords.h
1c81d6e72511578b6ebcafc3e9002427207f5167a7d916b92e34b5f1c36fa01c internal/cbm/vendored/grammars/perl/tsp_unicode.h
664764fabf40c0b318e06324a5a12379092a2df25b8cbf2415f71bc0bb352346 internal/cbm/vendored/grammars/php/LICENSE
de8eb36bc8f517ab9f3eaf82e3825d7b3e11b62e9471545f4c906100cfce0e07 internal/cbm/vendored/grammars/php/_common_scanner.h
bc796948b625f74e390cfd1254392136c86fafbd2dc0c9d93360ec20bc6b0dfb internal/cbm/vendored/grammars/php/parser.c
+54
View File
@@ -104,6 +104,22 @@ static const char *PY_CLEAN = "def ok():\n"
"def ok2():\n"
" return 2\n";
/* Perl formats have a line-oriented body terminated by a lone dot. The
* following named sub pins the important recovery boundary: a grammar must
* both accept the format and resume normal declaration parsing afterwards. */
static const char *PERL_FORMAT_WITH_FOLLOWING_SUB = "package Report;\n"
"format REPORT =\n"
"@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n"
"$headline\n"
".\n"
"sub after_format { return 1; }\n";
/* A grammar refresh must not hide real Perl syntax loss. */
static const char *PERL_MALFORMED = "package Broken;\n"
"sub before_error { return 1; }\n"
"} ] } ]\n"
"sub after_error { return 2; }\n";
/* ── Tests ────────────────────────────────────────────────────────────────── */
TEST(c_ifdef_split_brace_sets_parse_incomplete) {
@@ -418,6 +434,42 @@ TEST(width_bearing_error_at_eof_still_flagged_issue1610) {
PASS();
}
/* #1838: tree-sitter-perl v1.0.0 rejects a valid line-oriented format and
* reports the file as partial. The supported upstream v1.2.1 grammar accepts
* the format and preserves declaration extraction beyond its dot terminator. */
TEST(perl_format_followed_by_named_sub_is_complete_issue1838) {
CBMFileResult *r = do_extract(PERL_FORMAT_WITH_FOLLOWING_SUB, CBM_LANG_PERL, "report.pl");
ASSERT_NOT_NULL(r);
ASSERT_FALSE(r->has_error);
bool partial = r->parse_incomplete;
int error_regions = r->error_region_count;
bool has_error_ranges = r->error_ranges != NULL;
bool has_following_sub = has_def(r, "after_format");
if (partial || error_regions != 0 || has_error_ranges || !has_following_sub) {
fprintf(stderr,
" Perl format result: partial=%d regions=%d ranges=%s following_sub=%d\n",
partial,
error_regions,
r->error_ranges ? r->error_ranges : "(none)",
has_following_sub);
cbm_free_result(r);
FAIL("a valid Perl format and its following named sub must parse completely");
}
cbm_free_result(r);
PASS();
}
TEST(perl_malformed_source_remains_partial_issue1838) {
CBMFileResult *r = do_extract(PERL_MALFORMED, CBM_LANG_PERL, "broken.pl");
ASSERT_NOT_NULL(r);
ASSERT_FALSE(r->has_error);
ASSERT_TRUE(r->parse_incomplete);
ASSERT_GTE(r->error_region_count, 1);
ASSERT_NOT_NULL(r->error_ranges);
cbm_free_result(r);
PASS();
}
SUITE(parse_coverage) {
RUN_TEST(c_ifdef_split_brace_sets_parse_incomplete);
RUN_TEST(c_ifdef_split_brace_neighbors_still_extracted);
@@ -437,4 +489,6 @@ SUITE(parse_coverage) {
RUN_TEST(missing_final_newline_not_flagged_across_grammars_issue1610);
RUN_TEST(real_error_before_eof_still_flagged_without_final_newline_issue1610);
RUN_TEST(width_bearing_error_at_eof_still_flagged_issue1610);
RUN_TEST(perl_format_followed_by_named_sub_is_complete_issue1838);
RUN_TEST(perl_malformed_source_remains_partial_issue1838);
}