our $VERSION = 0.01;
sub render {
my ($that, $linkrefs, @lines) = @_;
my $text = join("\n", @lines);
my $tree = find_code_and_tag_runs($that, $text);
$tree->map(sub { process_char_escaping($that, $_) });
process_links($that, $linkrefs, $tree);
process_whitespaces($that, $tree);
if ($that->get_use_extended_autolinks) {
$tree->map(sub { create_extended_autolinks($that, $_) });
$tree->map(sub { create_extended_email_autolinks($that, $_) });
}
process_styles($that, $tree);
$tree->apply(
sub {
$_->escape_content($that->get_html_escaped_characters,
$that->get_html_escaped_code_characters);
});
my $out = $tree->render_html();
return $out;
}
my $html_tag_name_re = qr/[a-zA-Z][-a-zA-Z0-9]*/;
my $html_attribute_name_re = qr/[a-zA-Z_:][-a-zA-Z0-9_.:]*/;
my $html_space_re = qr/\n[ \t]*|[ \t][ \t]*\n?[ \t]*/;
my $opt_html_space_re = qr/[ \t]*\n?[ \t]*/;
my $html_attribute_value_re = qr/ [^ \t\n"'=<>`]+ | '[^']*' | "[^"]*" /x;
my $html_attribute_re =
qr/ ${html_space_re} ${html_attribute_name_re} (?: ${opt_html_space_re} = ${opt_html_space_re} ${html_attribute_value_re} )? /x;
my $html_open_tag_re = qr/ ${html_tag_name_re} ${html_attribute_re}* ${opt_html_space_re} \/? /x;
my $html_close_tag_re = qr/ \/ ${html_tag_name_re} ${opt_html_space_re} /x;
my $html_comment_re = qr/!--|!---|!--.*?--/s;
my $html_proc_re = qr/\?.*?\?/s;
my $html_decl_re = qr/![a-zA-Z].*?/s;
my $html_cdata_re = qr/!\[CDATA\[.*?\]\]/s;
my $html_tag_re =
qr/ ${html_open_tag_re} | ${html_close_tag_re} | ${html_comment_re} | ${html_proc_re} | ${html_decl_re} | ${html_cdata_re}/x;
sub find_code_and_tag_runs {
my ($that, $text) = @_;
my $tree = Markdown::Perl::InlineTree->new();
while ($text =~ m/(?<! \\) (?<backslashes> (?:\\\\)*) (?: (?<code>\`+) | < )/gx) {
my ($start_before, $start_after) =
($LAST_MATCH_START[0] + length($+{backslashes}), $LAST_MATCH_END[0]);
if ($+{code}) {
my $fence = $+{code};
if ($text =~ m/(?<!\`)${fence}(?!\`)/gc) {
my ($end_before, $end_after) = ($LAST_MATCH_START[0], $LAST_MATCH_END[0]);
$tree->push(new_text(substr($text, 0, $start_before)))
if $start_before > 0;
$tree->push(new_code(substr($text, $start_after, ($end_before - $start_after))));
substr $text, 0, $end_after, '';
}
} else {
my $re = $that->get_autolinks_regex;
my $email_re = $that->get_autolinks_email_regex;
if ($text =~ m/\G(?<link>${re})>/) {
$tree->push(new_text(substr($text, 0, $start_before)))
if $start_before > 0;
$tree->push(new_link($+{link}, type => 'autolink', target => $+{link}));
substr $text, 0, $+[0], '';
} elsif ($text =~ m/\G(?<link>${email_re})>/) {
$tree->push(new_text(substr($text, 0, $start_before)))
if $start_before > 0;
$tree->push(new_link($+{link}, type => 'autolink', target => 'mailto:'.$+{link}));
substr $text, 0, $+[0], '';
} elsif ($text =~ m/\G(?:${html_tag_re})>/) {
$tree->push(new_text(substr($text, 0, $start_before, '')))
if $start_before > 0;
my $html = substr($text, 0, $LAST_MATCH_END[0] - $start_before, '');
remove_disallowed_tags($html, $that->get_disallowed_html_tags);
$tree->push(new_html($html));
}
}
}
$tree->push(new_text($text)) if $text;
return $tree;
}
sub process_char_escaping {
my ($that, $node) = @_;
if ($node->{type} eq 'code' || $node->{type} eq 'link') {
return $node;
} elsif ($node->{type} eq 'text') {
my $new_tree = Markdown::Perl::InlineTree->new();
while ($node->{content} =~ m/\\(\p{PosixPunct})/g) {
$new_tree->push(new_text(substr $node->{content}, 0, $LAST_MATCH_START[0]))
if $LAST_MATCH_START[0] > 0;
$new_tree->push(new_literal($1));
substr $node->{content}, 0, $LAST_MATCH_END[0], '';
}
$new_tree->push($node) if $node->{content};
return $new_tree;
} elsif ($node->{type} eq 'html') {
return $node;
} else {
confess 'Unexpected node type in process_char_escaping: '.$node->{type};
}
}
sub process_links {
my ($that, $linkrefs, $tree) = @_;
my @open_link;
for (my $i = 0; $i < @{$tree->{children}}; $i++) {
my $n = $tree->{children}[$i];
next if $n->{type} ne 'text';
while ($n->{content} =~ m/(?<open>!?\[)|\]/g) {
my @pos = ($i, $LAST_MATCH_START[0], $LAST_MATCH_END[0]);
if ($+{open}) {
my $type = $pos[2] - $pos[1] > 1 ? 'img' : 'link';
push @open_link, {type => $type, active => 1, pos => \@pos};
} else {
next unless @open_link;
my %open = %{pop @open_link};
next unless $open{active};
my @text_span = ($open{pos}[0], $open{pos}[2], $pos[0], $pos[1]);
my $cur_pos = pos($n->{content});
my %target =
find_link_destination_and_title($that, $linkrefs, $tree, $pos[0], $pos[2], @text_span);
pos($n->{content}) = $cur_pos;
next unless %target;
my $text_tree = $tree->extract(@text_span);
my (undef, $dest_node_index) =
$tree->extract($open{pos}[0], $open{pos}[1], $open{pos}[0] + 1, 1);
my $link = new_link($text_tree, type => $open{type}, %target);
$tree->insert($dest_node_index, $link);
if ($open{type} eq 'link') {
for (@open_link) {
$_->{active} = 0 if $_->{type} eq 'link';
}
}
$i = $dest_node_index;
last;
}
}
}
return;
}
sub find_link_destination_and_title {
my ($that, $linkrefs, $tree, $child_start, $text_start, @text_span) = @_;
my $cur_child = $child_start;
my $n = $tree->{children}[$cur_child];
confess 'Unexpected link destination search in a non-text element: '.$n->{type}
unless $n->{type} eq 'text';
pos($n->{content}) = $text_start;
$n->{content} =~ m/ \G (?<space> [ \t\n]+ )? (?: (?<inline> \( ) | (?<reference> \[\]? ) )? /x;
my @start = ($child_start, $text_start, $child_start, $LAST_MATCH_END[0]);
my $has_space = exists $+{space};
my $type;
if (exists $+{inline}) {
$type = 'inline';
} elsif (exists $+{reference}) {
if ($+{reference} eq '[') {
$type = 'reference';
} else {
$type = 'collapsed';
}
} else {
$type = 'shortcut';
}
my $mode = $that->get_allow_spaces_in_links;
if ($has_space) {
if ( $mode eq 'reference'
&& ($type eq 'reference' || $type eq 'collapsed')
&& $+{space} =~ m/^ ?(?:\n[ \t]*)?$/) {
} else {
$type = 'shortcut';
}
}
if ($type eq 'inline') {
my @target = parse_inline_link($tree, @start);
return @target if @target;
} elsif ($type eq 'reference') {
my %target = parse_reference_link($that, $linkrefs, $tree, @start);
return %target if exists $target{target};
return if %target;
}
my $ref = $tree->span_to_source_text(@text_span, UNESCAPE_LITERAL);
$ref = normalize_label($ref) if $ref;
if (my $l = get_linkref($that, $linkrefs, $ref)) {
$tree->extract(@start) if $type eq 'collapsed';
return %{$l};
}
return;
}
sub parse_inline_link {
my ($tree, @start) = @_;
my $cur_child = $start[0];
my $n = $tree->{children}[$cur_child];
pos($n->{content}) = $start[3];
$n->{content} =~ m/\G[ \t]*\n?[ \t]*/;
my $search_start = $LAST_MATCH_END[0];
my @target;
my $ok_to_have_title = 1;
my $has_bracket =
$tree->find_in_text(qr/</, $cur_child, $search_start, $cur_child, $search_start + 1);
my $target = '';
if ($has_bracket) {
if (my @end_target = $tree->find_in_text(qr/>/, $cur_child, $search_start + 1)) {
@target = ($cur_child, $search_start + 1, $end_target[0], $end_target[1]);
return if $tree->find_in_text(qr/<|\n/, @target);
}
} elsif (
length($n->{content}) <= $search_start
&& @{$tree->{children}} > $cur_child + 1
&& ( $tree->{children}[$cur_child + 1]{type} eq 'html'
|| $tree->{children}[$cur_child + 1]{type} eq 'link')
) {
return if @{$tree->{children}} <= $cur_child + 2;
@target = ($cur_child + 1, 0, $cur_child + 2, 0);
my $link_node = $tree->{children}[$cur_child + 1];
if ($link_node->{type} eq 'html') {
$target = $link_node->{content};
$target =~ s/^<|>$//g;
} else {
$target = $link_node->{target};
}
return if $target =~ m/\n/;
} elsif (
my @end_target = $tree->find_in_text_with_balanced_content(
qr/\(/, qr/\)/, qr/[ [:cntrl:]]/,
$cur_child, $search_start)
) {
@target = ($cur_child, $search_start, $end_target[0], $end_target[1]);
}
if (@target) {
$cur_child = $target[2];
$n = $tree->{children}[$cur_child];
pos($n->{content}) = $target[3] + ($has_bracket ? 1 : 0);
$n->{content} =~ m/\G[ \t]*\n?[ \t]*/;
$search_start = $LAST_MATCH_END[0];
$ok_to_have_title = $LAST_MATCH_END[0] != $LAST_MATCH_START[0];
}
pos($n->{content}) = $search_start;
my @end_title;
if ($n->{content} =~ m/\G"/gc) {
@end_title = $tree->find_in_text(qr/"/, $cur_child, $search_start + 1);
} elsif ($n->{content} =~ m/\G'/gc) {
@end_title = $tree->find_in_text(qr/'/, $cur_child, $search_start + 1);
} elsif ($n->{content} =~ m/\G\(/gc) {
@end_title = $tree->find_balanced_in_text(qr/\(/, qr/\)/, $cur_child, $search_start + 1);
}
my @title;
if (@end_title) {
return unless $ok_to_have_title;
@title = ($cur_child, $search_start + 1, $end_title[0], $end_title[1]);
$cur_child = $end_title[0];
$n = $tree->{children}[$cur_child];
pos($n->{content}) = $end_title[2];
$n->{content} =~ m/\G[ \t]*\n?[ \t]*/;
$search_start = $LAST_MATCH_END[0];
}
pos($n->{content}) = $search_start;
return unless $n->{content} =~ m/\G\)/;
{
my @last_item = (@title, @target, @start);
$tree->extract($last_item[2], $last_item[3], $cur_child, $search_start + 1);
}
my $title;
if (@title) {
my $title_tree = $tree->extract(@title);
$title = $title_tree->to_source_text();
my @last_item = (@target, @start);
$tree->extract($last_item[2], $last_item[3], $title[0], $title[1]);
}
if (@target) {
my $target_tree = $tree->extract(@target);
$target = $target_tree->to_source_text() unless $target;
$tree->extract($start[2], $start[3], $target[0], $target[1]);
}
$tree->extract(@start);
return (target => $target, ($title ? (title => $title) : ()));
}
sub parse_reference_link {
my ($that, $linkrefs, $tree, @start) = @_;
my $cur_child = $start[0];
my $n = $tree->{children}[$cur_child];
my $ref_start = $start[3];
if (my @end_ref = $tree->find_in_text(qr/]/, $cur_child, $start[3])) {
my $ref =
normalize_label($tree->span_to_source_text(@start[2, 3], @end_ref[0, 1], UNESCAPE_LITERAL));
if (my $l = get_linkref($that, $linkrefs, $ref)) {
$tree->extract(@start[0, 1], @end_ref[0, 2]);
return %{$l};
} else {
return (ignored_valid_value => 1);
}
}
return;
}
sub get_linkref {
my ($that, $linkrefs, $ref) = @_;
if (exists $linkrefs->{$ref}) {
return $linkrefs->{$ref};
} elsif (exists $that->{hooks}{resolve_link_ref}) {
return $that->{hooks}{resolve_link_ref}->($ref);
}
return;
}
sub process_whitespaces {
my ($that, $tree, $not_root) = @_;
for (my $i = 0; $i < @{$tree->{children}}; $i++) {
my $n = $tree->{children}[$i];
process_whitespaces($that, $n->{subtree}, 1) if exists $n->{subtree};
next unless $n->{type} eq 'text';
my $re;
if ($that->get_two_spaces_hard_line_breaks) {
$re = qr/(?: {2,}|\\)\n(?=.) */s;
} else {
$re = qr/\\\n(?=.) */s;
}
my @hard_breaks = split($re, $n->{content}, -1);
for (my $j = 0; $j < @hard_breaks; $j++) {
$hard_breaks[$j] =~ s/^ +// if !$not_root && $i == 0 && $j == 0;
$hard_breaks[$j] =~ s/(\n|\r) +/$1/g;
$hard_breaks[$j] =~ s/ +$//gm
if !$not_root && $i == $
if ($j == 0) {
$n->{content} = $hard_breaks[0];
} else {
$tree->insert($i + 1, new_html('<br />'), new_text("\n".$hard_breaks[$j]));
$i += 2;
}
}
}
return;
}
sub process_styles {
my ($that, $tree) = @_;
for my $c (@{$tree->{children}}) {
process_styles($that, $c->{subtree}) if exists $c->{subtree};
}
my $current_child = 0;
my @delimiters;
my $delim = delim_characters($that);
my %max_delim_run_length = %{$that->get_inline_delimiters_max_run_length};
while (my @match = $tree->find_in_text(qr/([${delim}])\1*/, $current_child, 0)) {
my ($delim_tree, $index) = $tree->extract($match[0], $match[1], $match[0], $match[2]);
$delim_tree->{children}[0]{type} = 'literal';
$tree->insert($index, $delim_tree);
my $d = classify_delimiter($that, $tree, $index);
if (!exists $max_delim_run_length{$d->{delim}}
|| $d->{len} <= $max_delim_run_length{$d->{delim}}) {
push @delimiters, $d;
}
$current_child = $index + 1;
}
match_delimiters($that, $tree, @delimiters);
return;
}
sub classify_delimiter {
my ($that, $tree, $index) = @_;
my $pred_type = classify_flank($that, $tree, $index, 'left');
my $succ_type = classify_flank($that, $tree, $index, 'right');
my $is_left = $succ_type ne 'space' && ($succ_type ne 'punct' || $pred_type ne 'none');
my $is_right = $pred_type ne 'space' && ($pred_type ne 'punct' || $succ_type ne 'none');
my $len = length($tree->{children}[$index]{content});
my $delim = substr $tree->{children}[$index]{content}, 0, 1;
my $can_open = 0;
my $can_close = 0;
if ($delim eq '_') {
$can_open = $is_left && (!$is_right || $pred_type eq 'punct');
$can_close = $is_right && (!$is_left || $succ_type eq 'punct');
} else {
$can_open = $is_left;
$can_close = $is_right;
}
return {
index => $index,
can_open => $can_open,
can_close => $can_close,
len => $len,
delim => $delim,
orig_len => $len
};
}
sub classify_flank {
my ($that, $tree, $index, $side) = @_;
return 'space' if $index == 0 && $side eq 'left';
return 'space' if $index == $
my $node = $tree->{children}[$index + ($side eq 'left' ? -1 : 1)];
return 'punct' if $node->{type} ne 'text' && $node->{type} ne 'literal';
my $space_re = $side eq 'left' ? qr/\s$/u : qr/^\s/u;
return 'space' if $node->{content} =~ m/${space_re}/;
my $punct_re = $side eq 'left' ? qr/[\p{Punct}\p{Symbol}]$/u : qr/^[\p{Punct}\p{Symbol}]/u;
return 'punct' if $node->{content} =~ m/${punct_re}/;
return 'none';
}
sub match_delimiters {
my ($that, $tree, @delimiters) = @_;
for (my $close_index = 1; $close_index < @delimiters; $close_index++) {
my %c = %{$delimiters[$close_index]};
next if !$c{can_close};
my $open_index =
last_index { $_->{can_open} && $_->{delim} eq $c{delim} && valid_rules_9_10($_, \%c) }
@delimiters[0 .. $close_index - 1];
next if $open_index == -1;
$close_index = apply_delimiters($that, $tree, \@delimiters, $open_index, $close_index);
}
return;
}
sub apply_delimiters {
my ($that, $tree, $delimiters, $open_index, $close_index) = @_;
my %o = %{$delimiters->[$open_index]};
my %c = %{$delimiters->[$close_index]};
my @styled_subnodes = splice @{$tree->{children}}, $o{index} + 1, $c{index} - $o{index} - 1;
my $styled_tree = Markdown::Perl::InlineTree->new();
$styled_tree->push(@styled_subnodes);
splice @{$delimiters}, $open_index + 1, $close_index - $open_index - 1;
my $len = min($o{len}, $c{len}, max_delim_length($that, $o{delim}));
my $styled_node = new_style($styled_tree, tag => delim_to_html_tag($that, $o{delim} x $len));
my $style_start = $o{index};
my $style_length = 2;
$close_index = $open_index + 1;
if ($len < $o{len}) {
substr($tree->{children}[$o{index}]{content}, $o{len} - $len) = '';
$delimiters->[$open_index]{len} -= $len;
$style_start++;
$style_length--;
} else {
splice @{$delimiters}, $open_index, 1;
$close_index--;
}
if ($len < $c{len}) {
substr($tree->{children}[$o{index} + 1]{content}, $c{len} - $len) = '';
$delimiters->[$close_index]{len} -= $len;
$style_length--;
} else {
splice @{$delimiters}, $close_index, 1;
}
splice @{$tree->{children}}, $style_start, $style_length, $styled_node;
for my $i ($close_index .. $
$delimiters->[$i]{index} -= $c{index} - $o{index} - 2 + $style_length;
}
return $open_index - ($len < $o{len} ? 0 : 1);
}
sub valid_rules_9_10 {
my ($o, $c) = @_;
return
(!$o->{can_close} && !$c->{can_open})
|| (($o->{orig_len} + $c->{orig_len}) % 3 != 0)
|| ($o->{orig_len} % 3 == 0 && $c->{orig_len} % 3 == 0);
}
sub delim_to_html_tag {
my ($that, $delim) = @_;
return $that->get_inline_delimiters()->{$delim};
}
sub delim_characters {
my ($that) = @_;
my @c = map { substr $_, 0, 1 } keys %{$that->get_inline_delimiters()};
return join('', uniq @c);
}
sub max_delim_length {
my ($that, $delim) = @_;
return exists $that->get_inline_delimiters()->{$delim x 2} ? 2 : 1;
}
sub create_extended_autolinks {
my ($that, $n) = @_;
if ($n->{type} ne 'text') {
return $n;
}
my @nodes;
while (
$n->{content} =~ m/
(?<prefix> ^ | [ \t\n*_~\(] )
(?<url>
(?: (?<scheme>https?:\/\/) | www\. )
[-_a-zA-Z0-9]+ (?: \. [-_a-zA-Z0-9]+ )*
(?: \/ [^ \t\n<]*? )?
)
[?!.,:*_~]* (?: [ \t\n<] | $)
/x
) {
my $url = $+{url};
my $match_start = $LAST_MATCH_START[0] + length($LAST_PAREN_MATCH{prefix});
my $match_end = $match_start + length($url);
my $has_scheme = exists $LAST_PAREN_MATCH{scheme};
if ($url =~ m/\)+$/) {
my $nb_final_closing_parens = $LAST_MATCH_END[0] - $LAST_MATCH_START[0];
my $open = 0;
() = $url =~ m/ \( (?{$open++}) | \) (?{$open--}) /gx;
my $remove = min($nb_final_closing_parens, -$open);
if ($remove > 0) {
$match_end -= $remove;
substr $url, -$remove, $remove, '';
}
}
if ($url =~ m/\&[a-zA-Z0-9]+;$/) {
my $len = $LAST_MATCH_END[0] - $LAST_MATCH_START[0];
$match_end -= $len;
substr $url, -$len, $len, '';
}
if ($match_start > 0) {
push @nodes, new_text(substr $n->{content}, 0, $match_start);
}
my $scheme = $has_scheme ? '' : $that->get_default_extended_autolinks_scheme.'://';
push @nodes,
new_link($url, type => 'autolink', target => $scheme.$url, debug => 'extended autolink');
$n = new_text(substr $n->{content}, $match_end);
}
push @nodes, $n if length($n->{content}) > 0;
return @nodes;
}
sub create_extended_email_autolinks {
my ($that, $n) = @_;
if ($n->{type} ne 'text') {
return $n;
}
my @nodes;
while (
$n->{content} =~ m/
(?<prefix> ^ | [ \t\n*_~\(] )
(?<email>
(?<scheme> mailto:\/\/ )?
[-_.+a-zA-Z0-9]+ @ [-_a-zA-Z0-9]+ (?: \. [-_a-zA-Z0-9]+ )+ (?<= [a-zA-Z0-9] )
)
(?: [ \t\n.<] | $ )
/x
) {
my $email = $+{email};
my $match_start = $LAST_MATCH_START[0] + length($LAST_PAREN_MATCH{prefix});
my $match_end = $match_start + length($email);
my $has_scheme = exists $LAST_PAREN_MATCH{scheme};
if ($match_start > 0) {
push @nodes, new_text(substr $n->{content}, 0, $match_start);
}
my $scheme = $has_scheme ? '' : 'mailto:';
push @nodes,
new_link(
$email,
type => 'autolink',
target => $scheme.$email,
debug => 'extended autolink');
$n = new_text(substr $n->{content}, $match_end);
}
push @nodes, $n if length($n->{content}) > 0;
return @nodes;
}
1;