File Coverage

blib/lib/Markdown/Perl/HTML.pm

Criterion	Covered	Total	%
statement	60	62	96.7
branch	17	20	85.0
condition	7	10	70.0
subroutine	14	14	100.0
pod	0	7	0.0
total	98	113	86.7

package Markdown::Perl::HTML;

use strict;
use warnings;
use utf8;
use feature ':5.24';

use Carp 'cluck';
use English;
use Exporter 'import';

our @EXPORT_OK = qw(decode_entities html_escape http_escape remove_disallowed_tags
    parse_attributes);
our %EXPORT_TAGS = (all => \@EXPORT_OK);

our $VERSION = 0.01;

our %html_entities;

# Parse the __DATA__ section into the %html_entities hash.
# This is done lazily to reduce the loading time of the program if the table is
# not needed.
#
# TODO: add a :full_init import option to the main package, to force the early
# execution of this method.
sub parse_entities {
  return if %html_entities;
  local $INPUT_RECORD_SEPARATOR = undef;
  %html_entities = eval ;  ## no critic (ProhibitStringyEval);
  confess $EVAL_ERROR if $EVAL_ERROR;
  close DATA or cluck 'Can’t close DATA file handle in lazy parsing of HTML entities mapping';
  return;
}

# Decode HTML entities like & in the given string. Do it in-place if called
# in void-context otherwise returns a modified string.
# This is mostly equivalent to HTML::Entities::decode_entities but with our more
# complete list of entities, probably slower, and handling the replacement of
# 0x0 characters by 0xfffd.

# Currently, CounterClockwiseContourIntegral is the longest entity name, at 31
# char. We limit our search to 40 char to limit possible backtracking in case of
# failures (even if the spec does not say anything about it).
my $numeric_entity_re = qr/(?:\#(?: (? [0-9]{1,7} ) | [xX] (? [a-fA-F0-9]{1,6} ) ))/x;
my $entity_re = qr/& (?: ${numeric_entity_re} | (? [a-zA-Z0-9]{2,40} ) ) ; /x;

sub convert_entity {
  # the `|| 0xfffd` part is so that � is correctly replaced by the 0xfffd
  # "replacement" character (as is being done on the whole string at the
  # beginning of its processing).
  return
        exists $+{dec} ? chr($+{dec} || 0xfffd)
      : exists $+{hex} ? chr(hex($+{hex}) || 0xfffd)
      : (parse_entities(), $html_entities{$+{named}}) // "&$+{named};";
}

sub decode_entities {
  return $_[0] =~ s/${entity_re}/&convert_entity/egr if defined wantarray;
  $_[0] =~ s/${entity_re}/&convert_entity/eg;
  return;
}

# There are four characters that are escaped in the html output (although the
# spec never really says so because they claim that they care only about parsing).
my %char_to_html_entity = (
  '"' => '"',
  "'" => ''',
  '&' => '&',
  '<' => '<',
  '>' => '>'
);

# html_escape($str_to_escape, $character_class_to_use_for_escaping)
sub html_escape {
  # TODO: I believe that this is re-compiled at each call because of the local
  # variable. The regex should be built once in the Markdown::Perl object.
  $_[0] =~ s/([$_[1]])/$char_to_html_entity{$1}/eg;
  return;
}

sub http_escape {
  utf8::encode($_[0]);
  # TODO: there are more characters that need to be escaped here, but it’s not
  # extremely clear which ones (the spec does a show of pretending to care only
  # only about parsing, but the conformance test suite expect something quite
  # specific. See: https://spec.commonmark.org/0.31.2/#example-502
  $_[0] =~ s/([ \\\[\]\x80-\xff`""])/sprintf('%%%02X', ord($1))/ge;
  return;
}

# remove_disallowed_tags($html, \@tag_list)
# modify $html in place.
sub remove_disallowed_tags {
  # TODO: check if GitHub also deactivates closing tags or only opening ones.
  # Note: this is a dummy approach, based on the fact that this method is called
  # only in the context of HTML blocks or inline HTML and so, something looking
  # like an HTML tag is probably an HTML tag.
  for my $t (@{$_[1]}) {
    $_[0] =~ s/<(\Q$t\E)/<$1/gi;
  }
  return;
}

# This parses the attributes of the directive syntax. E.g. it receives the
# attribute part in the :name[content]{attributes} syntax, where each part can
# be missing.
sub parse_attributes {
  my ($attributes) = @_;
  my %out;
  my $id_re = qr/(?: \# (? \w+ ))/x;
  my $class_re = qr/(?: \. (? \w+ ))/x;
  my $key_value_re = qr/(?: (? \w+ ) \s* = \s* (? \w+ ))/x;
  pos($attributes) = 0;  # so that it’s set even if we don’t match once to avoid a warning later.
  while ($attributes =~ m/\G\s* (?: ${id_re} | ${class_re} | ${key_value_re} ) /gcx) {
    if (defined ($+{id}) && !exists($out{id})) {
      $out{id} = $+{id};
    } elsif (defined ($+{class})) {
      push(@{$out{class}}, $+{class});
    } elsif (defined ($+{key})) {
      push(@{$out{keys}}, [$+{key}, $+{value}]);
    } else {
      pos($attributes) = $LAST_MATCH_START[0];
      last;
    }
  }
  if ($attributes !~ m/\G \s* $/x) {
    $out{junk} = substr($attributes, pos($attributes));
  }

  return %out;
}

1;

__DATA__