view release on metacpan or  search on metacpan

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

        }
        my $c = substr($src, $p, 1);
        if ($c eq '"') {
            $self->{pos} = $p + 1;
            # SPEC §Unicode normalization: re-NFC after escape decoding.
            return $out !~ /[^\x00-\x7F]/ ? $out : _NFC($out);
        }
        if ($c eq "\n" || $c eq "\r") {
            $self->{pos} = $p;
            $self->_die("strings cannot span lines");
        }
        # $c is '\\' — handle the escape, then resume the bulk scan.
        $p++;  # past the backslash
        if ($p >= $len) {
            $self->{pos} = $p;
            $self->_die("unterminated escape");
        }
        my $esc = substr($src, $p, 1);
        $p++;
        if    ($esc eq '"')  { $out .= '"'; }
        elsif ($esc eq '\\') { $out .= '\\'; }
        elsif ($esc eq 'n')  { $out .= "\n"; }
        elsif ($esc eq 't')  { $out .= "\t"; }
        elsif ($esc eq 'r')  { $out .= "\r"; }
        elsif ($esc eq 'b')  { $out .= "\b"; }
        elsif ($esc eq 'f')  { $out .= "\f"; }
        elsif ($esc eq 'u' || $esc eq 'U') {
            # _read_hex_codepoint reads from $self->{pos}; sync it first.
            $self->{pos} = $p;
            $out .= $self->_read_hex_codepoint($esc eq 'u' ? 4 : 8);
            $p = $self->{pos};
        }
        else {
            $self->{pos} = $p;
            $self->_die("invalid escape '\\$esc'");
        }
        pos($src) = $p;
    }
}

sub parse_literal_string_value {
    my $self = shift;
    my ($sl, $sls, $sp) = ($self->{line}, $self->{line_start}, $self->{pos});
    $self->{pos}++;
    my $out = '';
    while (1) {
        if ($self->_eof) {
            die $self->_err_at($sl, $sls, $sp, "unterminated string");
        }
        my $c = $self->_peek;
        $self->_die("strings cannot span lines") if $c eq "\n" || $c eq "\r";
        if ($c eq "'") { $self->{pos}++; return $out; }
        $self->{pos}++;
        $out .= $c;
    }
}

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) {