File Coverage

blib/lib/Markdown/Perl.pm

Criterion	Covered	Total	%
statement	179	183	97.8
branch	67	76	88.1
condition	21	24	87.5
subroutine	28	28	100.0
pod	5	5	100.0
total	300	316	94.9

package Markdown::Perl;

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

use Carp;
use English;
use Exporter 'import';
use Hash::Util 'lock_keys';
use List::Util 'none';
use List::MoreUtils 'pairwise';
use Markdown::Perl::BlockParser;
use Markdown::Perl::Inlines;
use Markdown::Perl::HTML 'html_escape', 'decode_entities', 'parse_attributes';
use Readonly;
use Scalar::Util 'blessed';

use parent 'Markdown::Perl::Options';

our $VERSION = '1.11';

our @EXPORT_OK = qw(convert set_options set_mode set_hooks);
our %EXPORT_TAGS = (all => \@EXPORT_OK);

sub new {
  my ($class, @options) = @_;

  my $this = $class->SUPER::new(
    mode => undef,
    options => {},
    local_options => {},
    hooks => {});
  $this->SUPER::set_options(options => @options);
  lock_keys(%{$this});

  return $this;
}

sub set_options {
  my ($this, @options) = &_get_this_and_args;  ## no critic (ProhibitAmpersandSigils)
  $this->SUPER::set_options(options => @options);
  return;
}

sub set_mode {
  my ($this, $mode) = &_get_this_and_args;  ## no critic (ProhibitAmpersandSigils)
  $this->SUPER::set_mode(options => $mode);
  return;
}

Readonly::Array my @VALID_HOOKS => qw(resolve_link_ref yaml_metadata);

sub set_hooks {
  my ($this, %hooks) = &_get_this_and_args;  ## no critic (ProhibitAmpersandSigils)
  while (my ($k, $v) = each %hooks) {
    if (none { $_ eq $k } @VALID_HOOKS) {
      croak "Invalid hook name: ${k}";
    } elsif (!defined $v) {
      delete $this->{hooks}{$k};
    } elsif (ref $v ne 'CODE') {
      carp 'Hook target must be a CODE reference';
    } else {
      $this->{hooks}{$k} = $v;
    }
  }
  return;
}

# Returns @_, unless the first argument is not blessed as a Markdown::Perl
# object, in which case it returns a default object.
my $default_this = Markdown::Perl->new();

sub _get_this_and_args {  ## no critic (RequireArgUnpacking)
  return unless @_;
  # We could use `$this isa Markdown::Perl` that does not require to test
  # blessedness first. However this requires 5.31.6 which is not in Debian
  # stable as of writing this.
  if (!blessed($_[0]) || !$_[0]->isa(__PACKAGE__)) {
    unshift @_, $default_this;
  }
  return @_ if defined wantarray;
  return;
}

# Takes a string and converts it to HTML. Can be called as a free function or as
# class method. In the latter case, provided options override those set in the
# class constructor.
# Both the input and output are unicode strings.
sub convert {  ## no critic (RequireArgUnpacking)
  &_get_this_and_args;  ## no critic (ProhibitAmpersandSigils)
  my $this = shift @_;
  my $md = \(shift @_);  # Taking a reference to avoid copying the input. is it useful?
  $this->SUPER::set_options(local_options => @_);

  # TODO: introduce an HtmlRenderer object that carries the $linkrefs states
  # around (instead of having to pass it in all the calls).
  my ($blocks, $linkrefs) = $this->_parse($md);
  my $out = $this->_emit_html(0, 'root', $linkrefs, @{$blocks});
  $this->{local_options} = {};
  return $out;
}

# This is an internal call for now because the structure of the parse tree is
# not defined.
# Note that while convert() takes care not to copy the md argument, this is not
# the case of this method, however, it can receive a scalar ref instead of a
# scalar, to avoid the copy.
# TODO: create a BlockTree class and document it, then make this be public.
sub _parse {
  my ($this, $md_or_ref) = &_get_this_and_args;  ## no critic (ProhibitAmpersandSigils)
  my $md = ref($md_or_ref) ? $md_or_ref : \$md_or_ref;

  my $parser = Markdown::Perl::BlockParser->new($this, $md);
  my ($linkrefs, $blocks) = $parser->process();
  return ($blocks, $linkrefs) if wantarray;
  return $blocks;
}

sub _render_inlines {
  my ($this, $linkrefs, @lines) = @_;
  return Markdown::Perl::Inlines::render($this, $linkrefs, @lines);
}

# TODO: move this to a separate package and split the method in smaller chunks.
sub _emit_html {  ## no critic (ProhibitExcessComplexity)
  my ($this, $tight_block, $parent_type, $linkrefs, @blocks) = @_;
  my $out = '';
  my $block_index = 0;
  for my $bl (@blocks) {
    $block_index++;
    if ($bl->{type} eq 'break') {
      $out .= "\n";
    } elsif ($bl->{type} eq 'heading') {
      my $l = $bl->{level};
      my $c = $bl->{content};
      $c = $this->_render_inlines($linkrefs, ref $c eq 'ARRAY' ? @{$c} : $c);
      $c =~ s/^[ \t]+|[ \t]+$//g;  # Only the setext headings spec asks for this, but this can’t hurt atx heading where this can’t change anything.
      $out .= "$c\n";
    } elsif ($bl->{type} eq 'code') {
      my $c = $bl->{content};
      html_escape($c, $this->get_html_escaped_code_characters);
      my $i = '';
      if ($this->get_code_blocks_info eq 'language' && $bl->{info}) {
        my $l = $bl->{info} =~ s/\s.*//r;  # The spec does not really cover this behavior so we’re using Perl notion of whitespace here.
        decode_entities($l);
        html_escape($l, $this->get_html_escaped_characters);
        $i = " class=\"language-${l}\"";
      }
      $out .= "$c\n";
    } elsif ($bl->{type} eq 'html') {
      $out .= $bl->{content};
    } elsif ($bl->{type} eq 'paragraph') {
      my $html = '';
      if ((
             $this->get_allow_task_list_markers eq 'list'
          && $parent_type eq 'list'
          && $block_index == 1)
        || $this->get_allow_task_list_markers eq 'always'
      ) {
        if ($bl->{content}[0] =~ m/ ^ \s* \[ (? [ xX] ) \] (? \s | $ ) /x) {
          $html =
               '
              .($LAST_PAREN_MATCH{marker} eq ' ' ? '' : 'checked="" ')
              .'disabled="" type="checkbox">'
              .($LAST_PAREN_MATCH{space} eq ' ' ? ' ' : "\n");
          substr $bl->{content}[0], 0, $LAST_MATCH_END[0], '';
        }
      }
      $html .= $this->_render_inlines($linkrefs, @{$bl->{content}});
      if ($tight_block) {
        $out .= $html;
      } elsif ($this->get_render_naked_paragraphs) {
        $out .= "${html}\n";
      } else {
        $out .= "${html}\n";
      }
    } elsif ($bl->{type} eq 'quotes') {
      my $c = $this->_emit_html(0, 'quotes', $linkrefs, @{$bl->{content}});
      $out .= "\n${c}\n";
    } elsif ($bl->{type} eq 'list') {
      my $type = $bl->{style};  # 'ol' or 'ul'
      my $start = '';
      my $num = $bl->{start_num};
      my $loose = $bl->{loose};
      $start = " start=\"${num}\"" if $type eq 'ol' && $num != 1;
      $out .= "<${type}${start}>\n"
          .join("\n",
        map { $this->_emit_html(!$loose, 'list', $linkrefs, @{$_->{content}}) } @{$bl->{items}})
          ."\n\n";
    } elsif ($bl->{type} eq 'table') {
      $out .= ''; '; '; '; " : '' } @align, @d); '; '; 




194




8




  
100
  




 





 





 





17



       my @align = map { $_ ? " align=\"${_}\"" : '' } @{$bl->{content}{align}}; 




 




15





 





 





 





 





84



   




 




8





 





 





 





 





32



   




195




8





 





 





 





 





16



       my @h = map { $this->_render_inlines($linkrefs, $_) } @{$bl->{content}{headers}}; 




 




15





 





 





 





 





62



   




 




8





 





 





 





 





24



   




196




8





 





 




  
15
  




 





221



       $out .= join('', pairwise { "${b}" } @align, @h); 




 




15





 





 





 





 





73



   




197




8





 





 





 





 





40



       $out .= '




198




8




  
100
  




 





 





 





17



       if (@{$bl->{content}{table}}) { 




 




8





 





 





 





 





43



   




199




6





 





 





 





 





14



         $out .= '




200




6





 





 





 





 





35



         my $ms = $this->get_table_blocks_have_cells_for_missing_data; 




201




6





 





 





 





 





12



         for my $l (@{$bl->{content}{table}}) { 




 




6





 





 





 





 





19



   




202




9





 





 





 





 





15



           $out .= '




203




9




  
 50
  




 





 





 





18



           my @d = map { defined ? $this->_render_inlines($linkrefs, $_) : $ms ? '' : undef } @{$l}; 




 




16




  
100
  




 





 





 





68



   




 




9





 





 





 





 





20



   




204




9




  
 50
  




 




  
16
  




 





118



           $out .= join('', pairwise { defined $b ? "${b}




 




16





 





 





 





 





90



   




205




9





 





 





 





 





72



           $out .= '




206




 





 





 





 





 





 



         } 




207




6





 





 





 





 





17



         $out .= '




208




 





 





 





 





 





 



       } 




209




8





 





 





 





 





43



       $out .= '';
      my @align = map { $_ ? " align=\"${_}\"" : '' } @{$bl->{content}{align}};
      my @h = map { $this->_render_inlines($linkrefs, $_) } @{$bl->{content}{headers}};
      $out .= join('', pairwise { "${b}" } @align, @h);
      $out .= '
      if (@{$bl->{content}{table}}) {
        $out .= '
        my $ms = $this->get_table_blocks_have_cells_for_missing_data;
        for my $l (@{$bl->{content}{table}}) {
          $out .= '
          my @d = map { defined ? $this->_render_inlines($linkrefs, $_) : $ms ? '' : undef } @{$l};
          $out .= join('', pairwise { defined $b ? "${b}
          $out .= '
        }
        $out .= '
      }
      $out .= '
    } elsif ($bl->{type} eq 'directive') {
      my $c = $this->_emit_html(0, 'directive', $linkrefs, @{$bl->{content}});
      my %attr = parse_attributes($bl->{attributes}) if defined $bl->{attributes};  ## no critic (ProhibitConditionalDeclaration)
      my @attr = ('div');
      push @attr, 'id="'.$attr{id}.'"' if exists $attr{id};
      unshift @{$attr{class}}, lc($bl->{name}) if defined $bl->{name};
      push @attr, 'class="'.join(' ', @{$attr{class}}).'"' if exists $attr{class};
      push @attr, map { sprintf 'data-%s="%s"', @{$_} } @{$attr{keys}} if exists $attr{keys};
      my $tag = join(' ', @attr);
      # TODO: the inline content is ignored for now
      # TODO we should add a hook to process the directive in custom cases.
      $out .= "<${tag}>\n${c}\n";
      if (defined $bl->{inline} && $this->get_warn_for_unused_input()) {
        carp 'Unused inline content in a directive block: '.$bl->{inline};
      }
      if (defined $attr{junk} && $this->get_warn_for_unused_input()) {
        carp 'Unused attribute content in a directive block: '.$attr{junk};
      }
    } else {
      confess 'Unexpected block type when rendering HTML output: '.$bl->{type};
    }
  }
  # Note: a final new line should always be appended to $out. This is not
  # guaranteed when the last element is HTML and the input file did not contain
  # a final new line, unless the option force_final_new_line is set.
  return $out;
}

1;

__END__