view release on metacpan or  search on metacpan

lib/DMS/Parser.pm  view on Meta::CPAN

      unless ($warned++) {
          Carp::carp(
              'DMS::Parser::parse_document() is deprecated; use decode_document() instead. '
            . 'SPEC v0.14 renamed parse_document() to decode_document().');
      }
      goto &decode_document;
  }
}

# SPEC §"UTF-8 only": reject any non-strict UTF-8 byte sequence —
# overlongs, lone continuation bytes, 5/6-byte forms, codepoints above
# U+10FFFF, and surrogates encoded as 3-byte UTF-8. Perl's built-in
# `utf8::decode` is too lax (it accepts the legacy "extended UTF-8"
# encoding for code points up to 2^31), so we walk the bytes ourselves
# before any decoding.
sub _validate_strict_utf8 {
    my ($s) = @_;
    # Fast path: pure-ASCII source has no UTF-8 work to do. A single
    # regex hit returns immediately on flat-ASCII data — saves ~150ms.
    return if $s !~ /[\x80-\xFF]/;
    my $n = length($s);
    my $i = 0;
    while ($i < $n) {
        my $b0 = ord(substr($s, $i, 1));
        if ($b0 < 0x80) { $i++; next; }
        my ($expect, $cp_lo, $cp_hi);
        if (($b0 & 0xE0) == 0xC0) {
            return _utf8_die($s, $i) if $b0 < 0xC2;   # overlong
            $expect = 2; $cp_lo = 0x80; $cp_hi = 0x7FF;
        } elsif (($b0 & 0xF0) == 0xE0) {
            $expect = 3; $cp_lo = 0x800; $cp_hi = 0xFFFF;
        } elsif (($b0 & 0xF8) == 0xF0) {
            return _utf8_die($s, $i) if $b0 > 0xF4;   # > U+10FFFF
            $expect = 4; $cp_lo = 0x10000; $cp_hi = 0x10FFFF;
        } else {
            return _utf8_die($s, $i);                 # bare cont / 5-6 byte
        }
        return _utf8_die($s, $i) if $i + $expect > $n;
        my $cp = ($b0 & ((1 << (7 - $expect)) - 1));
        for (my $k = 1; $k < $expect; $k++) {
            my $bk = ord(substr($s, $i + $k, 1));
            return _utf8_die($s, $i) if ($bk & 0xC0) != 0x80;
            $cp = ($cp << 6) | ($bk & 0x3F);
        }
        return _utf8_die($s, $i) if $cp < $cp_lo || $cp > $cp_hi;
        return _utf8_die($s, $i) if $cp >= 0xD800 && $cp <= 0xDFFF;
        $i += $expect;
    }
}

sub _utf8_die {
    my ($s, $i) = @_;
    my $prefix = substr($s, 0, $i);
    my $line = 1 + ($prefix =~ tr/\n//);
    my $last_nl = rindex($prefix, "\n");
    my $col = $i - ($last_nl + 1) + 1;
    die "$line:$col: input is not valid UTF-8\n";
}

# Shared input-normalization for every public decode entry point.
# SPEC §"UTF-8 only, NFC-normalized": reject BOM at offset 0, reject
# malformed UTF-8 bytes (5/6-byte forms, > U+10FFFF, lone continuation
# bytes, overlongs, surrogates), reject U+0000 anywhere, then NFC the
# source. Returns the (possibly NFC'd) Perl-internal-encoded string.
sub _normalize_source {
    my ($src) = @_;
    # SPEC §"UTF-8 only, NFC-normalized": DMS source is plain UTF-8 with
    # no byte-order mark. A leading U+FEFF is not silently consumed —
    # reject it explicitly so encoding mistakes surface loudly. (BOMs
    # *inside* string/heredoc bodies are fine; this only fires at offset 0.)
    # We check for the raw UTF-8 BOM bytes (EF BB BF) before any decoding,
    # so the rejection is independent of how the caller passed `$src`.
    if (!utf8::is_utf8($src) && length($src) >= 3
        && substr($src, 0, 3) eq "\xEF\xBB\xBF") {
        die "1:1: BOM (U+FEFF) at file start is not allowed; DMS source is plain UTF-8\n";
    }
    # SPEC §"UTF-8 only": reject malformed UTF-8 bytes (codepoints
    # > U+10FFFF, lone continuation bytes, overlongs, surrogates encoded
    # as bytes). Perl's `utf8::decode` is permissive about 5/6-byte
    # forms and codepoints above U+10FFFF, so we additionally walk the
    # raw bytes to confirm strict UTF-8 conformance.
    if (!utf8::is_utf8($src)) {
        _validate_strict_utf8($src);
        my $copy = $src;
        if (!utf8::decode($copy)) {
            die "1:1: input is not valid UTF-8\n";
        }
        $src = $copy;
    }
    if (length($src) >= 1 && substr($src, 0, 1) eq "\x{FEFF}") {
        die "1:1: BOM (U+FEFF) at file start is not allowed; DMS source is plain UTF-8\n";
    }
    # U+0000 is not allowed anywhere in DMS source (see SPEC §Strings).
    if ((my $nul = index($src, "\0")) >= 0) {
        my $prefix = substr($src, 0, $nul);
        my $line = 1 + ($prefix =~ tr/\n//);
        my $last_nl = rindex($prefix, "\n");
        my $col = $nul - ($last_nl + 1) + 1;
        die "$line:$col: U+0000 (NUL) is not allowed in DMS source\n";
    }
    # SPEC §Unicode normalization: NFC the source before tokenization.
    # Fast path: pure-ASCII source is already in NFC; skip the (linear,
    # codepoint-walking) NFC pass entirely. The check itself is a single
    # regex that finds the first non-ASCII byte if any.
    $src = _NFC($src) if $src =~ /[^\x00-\x7F]/;
    return $src;
}

# SPEC §Front-matter-only decode. Decodes the leading `+++ ... +++`
# block (if any) and returns it as a hashref, then stops without
# tokenizing the body. Returns undef when the document has no front
# matter at all (no opening `+++` after trivia). An empty front matter
# (`+++\n+++\n`) returns a defined-but-empty hashref, distinguishable
# from undef.
#
# Operates in lite mode (no comment AST, no original_forms recorded
# inside the FM). Diagnostics inside the `+++ ... +++` block are
# byte-identical to a full decode.
sub decode_front_matter {
    my ($src) = @_;
    $src = _normalize_source($src);
    my $self = bless {
        src => $src,
        len => length($src),
        pos => 0,
        line => 1,
        line_start => 0,
        pending_leading => [],
        path => [],
        comments => [],
        original_forms => [],
        record_forms => 1,
        # SPEC §Front-matter-only decode: "Mode: front-matter-only
        # decode runs in lite mode."
        lite => 1,
        # FM is always ordered (SPEC §"Unordered tables"); ignore_order
        # only affects body tables, which we never reach.
        ignore_order => 0,
    }, __PACKAGE__;
    return $self->parse_front_matter;
}

sub _parse_document_with_mode {
    my ($src, $lite, $ignore_order) = @_;
    $ignore_order = 0 unless $ignore_order;
    $src = _normalize_source($src);
    my $self = bless {
        src => $src,
        len => length($src),
        pos => 0,
        line => 1,