DMS-Parser
view release on metacpan or search on metacpan
lib/DMS/Parser.pm view on Meta::CPAN
# subset. Returns a Document hashref { meta, body, comments,
# original_forms } on success, or undef on any pattern the fast path
# can't handle (front matter, heredocs, list items, escaped strings,
# block comments, complex-key flow forms, non-ASCII strings).
# Caller's $src isn't modified; we do a pos() scan via a scalar ref.
sub _parse_lite_document_fast {
my ($src_ref) = @_;
my $len = length($$src_ref);
# Pre-flight rejection: a single regex over the whole src checks
# for any opener of a construct the fast path doesn't handle. If
# any are present, return undef immediately so the slow parser
# gets the (correct) full-spec implementation. This costs one
# linear scan but it's bounded by the C regex engine and faster
# than discovering mid-parse that we can't handle something. The
# negative lookaheads for `(?!##)` exclude `### LABEL` block
# comment openers. We deliberately allow `\u`/`\U` Unicode escapes
# but reject other backslash escapes (would need decoding).
return undef if $$src_ref =~ /"""|'''/; # heredocs
return undef if $$src_ref =~ /^[ \t]*\+/m; # list items / front matter
return undef if $$src_ref =~ /^[ \t]*###/m; # block comment opener
# Note: we don't pre-reject `/*` because real configs sometimes
# have it inside string literals (e.g., `path: "/etc/foo/*.tmpl"`).
# The mega-regex handles strings as a unit so `/*` is consumed
# inside the string capture; the inner loop will only fail on a
# `/*` that appears at line-start as an actual block comment, in
# which case it correctly bails to the slow parser.
# Backslash escapes ARE handled in the string regex below — the
# decode pass after match handles \", \\, \n, \r, \t, \b, \f, \uXXXX,
# \UXXXXXXXX. Anything else with `\` is still rejected.
# Quoted keys, inline tables/lists with content, dates, hex/oct/bin
# numbers — all opt out by being matched as "didn't match the
# mega-regex" inside the loop; the loop returns undef on the
# first non-match.
# Manual stack of containers, with the indent at which their
# children live. The root has child_indent 0. When a header
# (`key:\n`) arrives, we push the new child table with
# child_indent=undef ("TBD — set by first child"). The pop rule
# is "while top's child_indent > current indent, pop"; this
# closes nested blocks as the indent decreases.
my $root = { $ORDER_KEY => [] };
my @stack = ({ c => $root, ci => 0 });
pos($$src_ref) = 0;
LINE: while (pos($$src_ref) < $len) {
# Blank line — most common after kvpairs.
if ($$src_ref =~ /\G[ \t]*\r?\n/gc) { next LINE; }
# Single-line `#` or `//` comment (block forms `###` / `/*`
# already pre-rejected).
if ($$src_ref =~ /\G[ \t]*(?:#|\/\/)[^\n\r]*\r?\n/gc) { next LINE; }
# Mega-match: kvpair with simple value OR nested-block header.
# Group layout (capturing only — non-capturing alternations
# don't shift indices):
# $1 = indent (spaces)
# $2 = bareword key
# $3 = positive integer
# $4 = negative integer
# $5 = bool ('true'/'false')
# $6 = basic-string content (escapes allowed; decoded after)
# $7 = empty list / empty table literal ('[]' or '{}')
# $8 = decimal float (no exponent)
# $9 = flow-list-of-simple-values content (between [ and ],
# no nested brackets, no embedded newlines)
# $10 = flow-table-of-simple-kvpairs content
# $11 = trailing '\r?\n' for the no-value (header) form
if ($$src_ref =~ /\G([ ]*)([A-Za-z_][A-Za-z0-9_-]*):(?:[ ](?:(0|[1-9][0-9]{0,17})|(-[1-9][0-9]{0,17})|(true|false)|"((?:[\x20\x21\x23-\x5b\x5d-\x7e]|\\(?:["\\nrtbf]|u[0-9A-Fa-f]{4}|U[0-9A-Fa-f]{8}))*)"|(\[\]|\{\})|(-?(?:0|[1-9][0-9]*)\.[0-9]+...
my $ind = length($1);
my $key = $2;
# Pop closed levels (top's children no longer reachable).
while (@stack > 1 && defined($stack[-1]{ci}) && $stack[-1]{ci} > $ind) {
pop @stack;
}
# First child of a header? Its indent fixes the parent's
# child_indent.
if (!defined $stack[-1]{ci}) {
# The new indent must be strictly greater than the
# header's parent's child_indent (i.e., we descended).
if (@stack >= 2 && $stack[-2]{ci} >= $ind) { return undef; }
$stack[-1]{ci} = $ind;
}
# Indent must match the current container's expected level.
return undef if $stack[-1]{ci} != $ind;
my $container = $stack[-1]{c};
return undef if exists $container->{$key}; # duplicate key
if (defined $11) {
# Nested-block header: child is a table (the fast path
# doesn't handle child-as-list; pre-flight rejects any
# `+` so this is safe).
my $child = { $ORDER_KEY => [] };
push @{$container->{$ORDER_KEY}}, $key;
$container->{$key} = $child;
push @stack, { c => $child, ci => undef };
} else {
my $val;
if (defined $3) { my $iv = 0+$3; $val = bless \$iv, 'DMS::Parser::Integer'; }
elsif (defined $4) { my $iv = 0+$4; $val = bless \$iv, 'DMS::Parser::Integer'; }
elsif (defined $5) { my $bv = $5 eq 'true' ? 1 : 0; $val = bless \$bv, 'DMS::Parser::Bool'; }
elsif (defined $6) {
$val = $6;
# Decode escapes only if any backslash present (the
# common case is clean ASCII strings — skip the
# substitution then).
if (index($val, '\\') >= 0) {
$val =~ s{\\(["\\nrtbf])}{
$1 eq 'n' ? "\n"
: $1 eq 't' ? "\t"
: $1 eq 'r' ? "\r"
: $1 eq 'b' ? "\b"
: $1 eq 'f' ? "\f"
: $1
}ge;
$val =~ s{\\u([0-9A-Fa-f]{4})}{chr(hex($1))}ge;
$val =~ s{\\U([0-9A-Fa-f]{8})}{chr(hex($1))}ge;
}
}
elsif (defined $7) { $val = $7 eq '[]' ? [] : { $ORDER_KEY => [] }; }
elsif (defined $8) { my $fv = 0+$8; $val = bless \$fv, 'DMS::Parser::Float'; }
elsif (defined $9) {
lib/DMS/Parser.pm view on Meta::CPAN
}
}
sub _read_hex_codepoint {
my ($self, $n) = @_;
my $rest = substr($self->{src}, $self->{pos});
$self->_die("expected $n hex digits in unicode escape") if length($rest) < $n;
my $hex = substr($rest, 0, $n);
$self->_die("invalid hex in unicode escape: $hex") if $hex !~ /^[0-9a-fA-F]+$/;
my $v = hex($hex);
# SPEC: U+0000 is forbidden anywhere in DMS source, including via
# escape decoding. ` ` / `\U00000000` must not slip through.
if ($v == 0) {
$self->_die("\\u0000 escape forbidden");
}
if ($v >= 0xD800 && $v <= 0xDFFF) {
$self->_die(sprintf("surrogate codepoint U+%04X in escape", $v));
}
if ($v > 0x10FFFF) {
$self->_die("unicode escape is not a scalar value");
}
$self->{pos} += $n;
return chr($v);
}
# Heredocs
sub parse_heredoc_basic {
my $self = shift;
$self->{pos} += 3;
my $label = $self->_parse_heredoc_label;
my $mods = $self->_parse_heredoc_modifiers;
$self->_skip_inline_ws;
if (!($self->_consume_eol || $self->_eof)) {
$self->_die("heredoc opener must be followed by end of line");
}
my $terminator = length($label) ? $label : '"""';
my $body = $self->_collect_heredoc_body($terminator);
# SPEC §basic-string escapes: surrogate codepoints (U+D800..U+DFFF)
# and U+0000 are not valid in `\uXXXX` / `\UXXXXXXXX` escapes.
# Basic-heredoc bodies are kept raw, so we validate the rules by
# scanning the body for offending escape sequences.
_validate_heredoc_basic_escapes($body);
my $stripped = _strip_indent_and_continuations($body, 1);
my $out;
eval { $out = _apply_modifiers($stripped, $mods); };
if ($@) { my $msg = $@; chomp $msg; $self->_die($msg); }
$self->_record_form({
string_form => {
kind => 'heredoc',
flavor => 'basic_triple',
label => (length($label) ? $label : undef),
modifiers => [ map { { name => $_->{name}, args => $_->{args} } } @$mods ],
},
});
# SPEC §Unicode normalization: re-NFC after escape decoding.
return $out !~ /[^\x00-\x7F]/ ? $out : _NFC($out);
}
# SPEC §basic-string escapes: a `\uXXXX` / `\UXXXXXXXX` escape whose
# decoded value falls in the surrogate range U+D800..U+DFFF is not a
# Unicode scalar and is a parse error. Likewise U+0000 is forbidden.
# Basic-heredoc body lines are collected raw, so we validate the same
# rules by scanning the body for offending escape sequences.
sub _validate_heredoc_basic_escapes {
my ($body) = @_;
for my $ln (@{$body->{lines}}) {
my $text = $ln->{text};
my $len = length($text);
my $i = 0;
while ($i < $len) {
if (substr($text, $i, 1) eq '\\') {
# find run of consecutive backslashes
my $j = $i;
while ($j < $len && substr($text, $j, 1) eq '\\') { $j++; }
my $run = $j - $i;
if ($run % 2 == 1 && $j < $len) {
my $intro = substr($text, $j, 1);
my $n = ($intro eq 'u') ? 4 : ($intro eq 'U') ? 8 : 0;
if ($n > 0 && $j + 1 + $n <= $len) {
my $hex = substr($text, $j + 1, $n);
if ($hex =~ /^[0-9a-fA-F]+$/) {
my $cp = hex($hex);
my $esc_off = $j - 1;
if ($cp == 0) {
die sprintf("%d:%d: \\u0000 escape forbidden\n",
$ln->{line}, $esc_off + 1);
}
if ($cp >= 0xD800 && $cp <= 0xDFFF) {
die sprintf("%d:%d: surrogate codepoint U+%04X in escape\n",
$ln->{line}, $esc_off + 1, $cp);
}
}
}
}
$i = $j;
} else {
$i++;
}
}
}
}
sub parse_heredoc_literal {
my $self = shift;
$self->{pos} += 3;
my $label = $self->_parse_heredoc_label;
my $mods = $self->_parse_heredoc_modifiers;
$self->_skip_inline_ws;
if (!($self->_consume_eol || $self->_eof)) {
$self->_die("heredoc opener must be followed by end of line");
}
my $terminator = length($label) ? $label : "'''";
my $body = $self->_collect_heredoc_body($terminator);
my $stripped = _strip_indent_and_continuations($body, 0);
my $out;
eval { $out = _apply_modifiers($stripped, $mods); };
if ($@) { my $msg = $@; chomp $msg; $self->_die($msg); }
$self->_record_form({
string_form => {
kind => 'heredoc',
( run in 0.945 second using v1.01-cache-2.11-cpan-600a1bdf6e4 )