File Coverage

blib/lib/Markdown/Perl/InlineTree.pm
Criterion Covered Total %
statement 291 311 93.5
branch 135 164 82.3
condition 83 99 83.8
subroutine 46 47 97.8
pod 23 28 82.1
total 578 649 89.0


line stmt bran cond sub pod time code
1             # A tree data structure to represent the content of an inline text of a block
2             # element.
3              
4             package Markdown::Perl::InlineTree;
5              
6 32     32   6033 use strict;
  32         52  
  32         1182  
7 32     32   136 use warnings;
  32         44  
  32         1277  
8 32     32   146 use utf8;
  32         68  
  32         146  
9 32     32   887 use feature ':5.24';
  32         60  
  32         4171  
10              
11 32     32   178 use Carp;
  32         61  
  32         2129  
12 32     32   726 use English;
  32         2924  
  32         143  
13 32     32   11512 use Exporter 'import';
  32         61  
  32         979  
14 32     32   823 use Hash::Util ();
  32         3879  
  32         834  
15 32     32   160 use Scalar::Util 'blessed';
  32         49  
  32         7407  
16              
17             our $VERSION = 0.01;
18              
19             our @EXPORT_OK =
20             qw(new_text new_code new_link new_html new_style new_literal is_node is_tree UNESCAPE_LITERAL);
21             our %EXPORT_TAGS = (all => \@EXPORT_OK);
22              
23             =pod
24              
25             =encoding utf8
26              
27             =head1 NAME
28              
29             Markdown::Perl::InlineTree
30              
31             =head1 SYNOPSIS
32              
33             A tree structure meant to represent the inline elements of a Markdown paragraph.
34              
35             This package is internal to the implementation of L and its
36             documentation should be useful only if you are trying to modify the library.
37              
38             Otherwise please refer to the L and L documentation.
39              
40             =head1 DESCRIPTION
41              
42             =head2 new
43              
44             my $tree = Markdown::Perl::InlineTree->new();
45              
46             The constructor currently does not support any options.
47              
48             =cut
49              
50             sub new {
51 327938     327938 1 863745 my ($class) = @_;
52              
53 327938         684648 return bless {children => []}, $class;
54             }
55              
56             package Markdown::Perl::InlineNode { ## no critic (ProhibitMultiplePackages)
57 32     32   199 use Carp;
  32         43  
  32         2298  
58 32     32   1042 use Markdown::Perl::HTML 'decode_entities', 'html_escape', 'http_escape';
  32         70  
  32         198637  
59              
60             sub hashpush (\%%) {
61 303282     303282   491107 my ($hash, %args) = @_;
62 303282         623322 while (my ($k, $v) = each %args) {
63 303282         704819 $hash->{$k} = $v;
64             }
65 303282         447618 return;
66             }
67              
68             sub new {
69 268992     268992   574372 my ($class, $type, $content, %options) = @_;
70              
71 268992         522783 my $this = {type => $type, escaped => 0};
72 268992 100       421319 $this->{debug} = delete $options{debug} if exists $options{debug};
73 268992         334303 my $content_ref = ref $content;
74 268992 100 66     567481 if (Scalar::Util::blessed($content)
    50          
75             && $content->isa('Markdown::Perl::InlineTree')) {
76 12452         13523 hashpush %{$this}, subtree => $content;
  12452         25038  
77             } elsif (!ref($content)) {
78 256540         258287 hashpush %{$this}, content => $content;
  256540         369187  
79             } else {
80 0         0 confess "Unexpected content for inline ${type} node: ".ref($content);
81             }
82             # There is one more node type, not created here, that looks like a text
83             # node but that is a 'delimiter' node. These nodes are created manually
84             # inside the Inlines module.
85 268992 100 100     632819 if ($type eq 'text' || $type eq 'code' || $type eq 'literal' || $type eq 'html') {
    100 100        
    50 100        
86 246734 50       352353 confess "Unexpected content for inline ${type} node: ${content_ref}" if $content_ref;
87 246734 50       349429 confess "Unexpected parameters for inline ${type} node: ".join(', ', %options)
88             if %options;
89             } elsif ($type eq 'link') {
90 11939 50       24382 confess 'Missing required option "type" for inline link node' unless exists $options{type};
91 11939         12832 hashpush %{$this}, linktype => delete $options{type};
  11939         24541  
92             confess 'Missing required option "target" for inline link node'
93 11939 50       23153 unless exists $options{target};
94 11939         15191 hashpush %{$this}, target => delete $options{target};
  11939         21289  
95 11939 100       18508 hashpush %{$this}, title => delete $options{title} if exists $options{title};
  92         266  
96 11939 100       20300 hashpush %{$this}, content => delete $options{content} if exists $options{content};
  1         4  
97 11939 50       20477 confess 'Unexpected parameters for inline link node: '.join(', ', %options) if keys %options;
98             } elsif ($type eq 'style') {
99             confess 'Unexpected parameters for inline style node: '.join(', ', %options)
100 10319 50 33     28158 if keys %options > 1 || !exists $options{tag};
101 10319 50       15112 confess 'The content of a style node must be an InlineTree' unless $content_ref;
102 10319         12086 hashpush %{$this}, tag => $options{tag};
  10319         19903  
103             } else {
104 0         0 confess "Unexpected type for an InlineNode: ${type}";
105             }
106 268992         317237 bless $this, $class;
107              
108 268992         259702 Hash::Util::lock_keys %{$this};
  268992         537764  
109 268992         2241054 return $this;
110             }
111              
112             sub clone {
113 117321     117321   131005 my ($this) = @_;
114              
115 117321         123021 return bless {%{$this}}, ref($this);
  117321         478784  
116             }
117              
118             sub has_subtree {
119 424329     424329   468850 my ($this) = @_;
120              
121 424329         708658 return exists $this->{subtree};
122             }
123              
124             sub escape_content {
125 181230     181230   241702 my ($this, $char_class_to_escape, $char_class_to_escape_in_code) = @_;
126              
127 181230 50       252514 confess 'Node should not already be escaped when calling to_text' if $this->{escaped};
128 181230         191400 $this->{escaped} = 1;
129              
130 181230 100 66     342942 if ($this->{type} eq 'text') {
    100          
    100          
    100          
    50          
131 109221         223161 decode_entities($this->{content});
132 109221         180125 html_escape($this->{content}, $char_class_to_escape);
133             } elsif ($this->{type} eq 'literal') {
134 21429         34002 html_escape($this->{content}, $char_class_to_escape);
135             } elsif ($this->{type} eq 'code') {
136             # New lines are treated like spaces in code.
137 3638         11052 $this->{content} =~ s/\n/ /g;
138             # If the content is not just whitespace and it has one space at the
139             # beginning and one at the end, then we remove them.
140 3638         8317 $this->{content} =~ s/^ (.*[^ ].*) $/$1/g;
141 3638         7153 html_escape($this->{content}, $char_class_to_escape_in_code);
142             } elsif ($this->{type} eq 'link') {
143 11939 100 66     23405 if ($this->{linktype} eq 'autolink') {
    50          
144             # For autolinks we don’t decode entities as these are treated like html
145             # construct.
146 9806         22619 html_escape($this->{content}, $char_class_to_escape);
147 9806         22079 http_escape($this->{target});
148 9806         14857 html_escape($this->{target}, $char_class_to_escape);
149             } elsif ($this->{linktype} eq 'link' || $this->{linktype} eq 'img') {
150             # This is a real MD link definition (or image). The target and title
151             # have been generated through the to_source_text() method, so they need
152             # to be decoded and html_escaped
153 2133 100       3853 if (exists $this->{title}) {
154 92         299 decode_entities($this->{title});
155 92         248 html_escape($this->{title}, $char_class_to_escape);
156             }
157 2133         4938 decode_entities($this->{target});
158 2133         4695 http_escape($this->{target});
159 2133         3886 html_escape($this->{target}, $char_class_to_escape);
160             } else {
161 0         0 confess 'Unexpected link type in render_node_html: '.$this->{linktype};
162             }
163             } elsif ($this->{type} eq 'html' || $this->{type} eq 'style') {
164             # Nothing here on purpose
165             } else {
166 0         0 confess 'Unexpected node type in render_node_html: '.$this->{type};
167             }
168 181230         208228 return;
169             }
170             } # package Markdown::Perl::InlineNode
171              
172             =pod
173              
174             =head2 new_text, new_code, new_link, new_literal
175              
176             my $text_node = new_text('text content');
177             my $code_node = new_code('code content');
178             my $link_node = new_link('text content', type=> 'type', target => 'the target'[, title => 'the title']);
179             my $link_node = new_link($subtree_content, type=> 'type', target => 'the target'[, title => 'the title'][, content => 'override content']);
180             my $html_node = new_html('');
181             my $style_node = new_literal($subtree_content, 'html_tag');
182             my $literal_node = new_literal('literal content');
183              
184             These methods return a text node that can be inserted in an C.
185              
186             =cut
187              
188 218247     218247 1 355949 sub new_text { return Markdown::Perl::InlineNode->new(text => @_) }
189 3639     3639 1 9091 sub new_code { return Markdown::Perl::InlineNode->new(code => @_) }
190 11939     11939 1 24000 sub new_link { return Markdown::Perl::InlineNode->new(link => @_) }
191 24691     24691 0 42263 sub new_html { return Markdown::Perl::InlineNode->new(html => @_) }
192 10319     10319 0 21126 sub new_style { return Markdown::Perl::InlineNode->new(style => @_) }
193 157     157 1 311 sub new_literal { return Markdown::Perl::InlineNode->new(literal => @_) }
194              
195             =pod
196              
197             =head2 is_node, is_tree
198              
199             These two methods returns whether a given object is a node that can be inserted
200             in an C and whether it’s an C object.
201              
202             =cut
203              
204             sub is_node {
205 697343     697343 1 740416 my ($obj) = @_;
206 697343   66     2087269 return blessed($obj) && $obj->isa('Markdown::Perl::InlineNode');
207             }
208              
209             sub is_tree {
210 66720     66720 1 76468 my ($obj) = @_;
211 66720   33     174614 return blessed($obj) && $obj->isa('Markdown::Perl::InlineTree');
212             }
213              
214             =pod
215              
216             =head2 push
217              
218             $tree->push(@nodes_or_trees);
219              
220             Push a list of nodes at the end of the top-level nodes of the current tree.
221              
222             If passed C objects, then the nodes of these trees are pushed (not
223             the tree itself).
224              
225             =cut
226              
227             sub push { ## no critic (ProhibitBuiltinHomonyms)
228 495510     495510 1 642268 my ($this, @nodes_or_trees) = @_;
229              
230 495510         559370 for my $node_or_tree (@nodes_or_trees) {
231 494419 100       573124 if (is_node($node_or_tree)) {
    50          
232 427699         420349 push @{$this->{children}}, $node_or_tree;
  427699         722100  
233             } elsif (is_tree($node_or_tree)) {
234 66720         74664 push @{$this->{children}}, @{$node_or_tree->{children}};
  66720         81351  
  66720         113459  
235             } else {
236 0         0 confess 'Invalid argument type for InlineTree::push: '.ref($node_or_tree);
237             }
238             }
239              
240 495510         837267 return;
241             }
242              
243             =pod
244              
245             =head2 replace
246              
247             $tree->replace($index, @nodes);
248              
249             Remove the existing node at the given index and replace it by the given list of
250             nodes (or, if passed C objects, their own nodes).
251              
252             =cut
253              
254             sub replace {
255 78385     78385 1 122115 my ($this, $child_index, @new_nodes) = @_;
256 78385         129281 splice @{$this->{children}}, $child_index, 1,
257 78385 50       74254 map { is_node($_) ? $_ : @{$_->{children}} } @new_nodes;
  139239         168443  
  0         0  
258 78385         137366 return;
259             }
260              
261             =pod
262              
263             =head2 insert
264              
265             $tree->insert($index, @new_nodes);
266              
267             Inserts the given nodes (or, if passed C objects, their own nodes)
268             at the given index. After the operation, the first inserted node will have that
269             index.
270              
271             =cut
272              
273             sub insert {
274 53499     53499 1 78225 my ($this, $index, @new_nodes) = @_;
275 53499 100       55552 splice @{$this->{children}}, $index, 0, map { is_node($_) ? $_ : @{$_->{children}} } @new_nodes;
  53499         73540  
  63685         75154  
  41179         88906  
276 53499         76516 return;
277             }
278              
279             =pod
280              
281             =head2 extract
282              
283             $tree->extract($start_child, $start_offset, $end_child, $end_offset);
284              
285             Extract the content of the given tree, starting at the child with the given
286             index (which must be a B node) and at the given offset in the child’s
287             text, and ending at the given node and offset (which must also be a B
288             node).
289              
290             That content is removed from the input tree and returned as a new C
291             object. Returns a pair with the new tree and the index of the first child after
292             the removed content in the input tree. Usually it will be C<$start_child + 1>,
293             but it can be C<$start_child> if C<$start_offset> was 0.
294              
295             In scalar context, returns only the extracted tree.
296              
297             =cut
298              
299             sub extract {
300 81732     81732 1 133042 my ($this, $child_start, $text_start, $child_end, $text_end) = @_;
301              
302             # In this method, we should not read $sn and $en when they are not split (that
303             # is if text_start or text_end are 0), so that the method works at the
304             # boundary of non-text nodes.
305              
306 81732         98139 my $sn = $this->{children}[$child_start];
307             confess 'Start node in an extract operation is not of type text: '.$sn->{type}
308 81732 50 66     139222 unless $sn->{type} eq 'text' || $text_start == 0;
309              
310             ## I don’t think that this block is useful (I should add tests for this case
311             ## to check if this is needed).
312             ## The code after this block will be invalid if we extract an empty span, but
313             ## I don’t think that this can happen in practice.
314             # if ($child_start == $child_end && $text_start == $text_end) {
315             # my $offset = 0;
316             # if ($text_start != 0) {
317             # if ($text_start != length($sn->{content})) {
318             # my $nn = new_text(substr $sn->{content}, $text_start, length($sn->{content}), '');
319             # $this->insert($child_start + 1, $nn);
320             # }
321             # $offset = 1;
322             # }
323             # return (Markdown::Perl::InlineTree->new(), $child_start + $offset) if wantarray;
324             # return Markdown::Perl::InlineTree->new();
325             # }
326              
327 81732         87010 my $en = $this->{children}[$child_end];
328             confess 'End node in an extract operation is not of type text: '.$en->{type}
329 81732 50 66     193885 unless $text_end == 0 || $en->{type} eq 'text';
330 81732 50       111011 confess 'Start offset is less than 0 in an extract operation' if $text_start < 0;
331             confess 'End offset is past the end of the text in an extract operation'
332 81732 50 66     216272 if $text_end != 0 && $text_end > length($en->{content});
333              
334 81732         86516 my $empty_last = 0;
335 81732 100       114819 if ($text_end == 0) {
336 241         351 $empty_last = 1;
337 241         286 $child_end--;
338             }
339              
340             # Clone will not recurse into sub-trees. But the start and end nodes can’t
341             # have sub-trees, and the middle ones don’t matter because they are not shared
342             # with the initial tree.
343             my @nodes =
344 81732         107886 map { $_->clone() } @{$this->{children}}[$child_start .. $child_end];
  86859         127277  
  81732         119735  
345             ## no critic (ProhibitLvalueSubstr)
346 81732 100       206924 substr($nodes[-1]{content}, $text_end) = '' unless $empty_last; ## We have already removed the empty last node.
347 81732         120673 substr($nodes[0]{content}, 0, $text_start) = ''; # We must do this after text_end in case they are the same node.
348 81732 100       128045 shift @nodes if length($nodes[0]{content}) == 0;
349 81732 50 100     276067 pop @nodes if !$empty_last && @nodes && length($nodes[-1]{content}) == 0;
      66        
350 81732         122899 my $new_tree = Markdown::Perl::InlineTree->new();
351 81732         154374 $new_tree->push(@nodes);
352              
353 81732 100       109902 if ($child_start != $child_end) {
354 3347 100       4932 if ($text_start == 0) {
355 480         843 $child_start--;
356             } else {
357 2867         4649 substr($sn->{content}, $text_start) = '';
358             }
359 3347 100 100     9136 if ($empty_last || $text_end == length($en->{content})) {
360 2358         2987 $child_end++;
361             } else {
362 989         1848 substr($en->{content}, 0, $text_end) = '';
363             }
364 3347         3739 splice @{$this->{children}}, $child_start + 1, $child_end - $child_start - 1;
  3347         7344  
365             } else {
366 78385         94614 my @new_nodes;
367 78385 100       107098 if ($text_start > 0) {
368 72756         144078 CORE::push @new_nodes, new_text(substr $sn->{content}, 0, $text_start);
369             }
370 78385 100 100     228791 if (!$empty_last && $text_end < length($sn->{content})) {
371 66483         120736 CORE::push @new_nodes, new_text(substr $sn->{content}, $text_end);
372             }
373 78385         180106 $this->replace($child_start, @new_nodes);
374 78385 100       124072 $child_start-- if $text_start == 0;
375             }
376             ## use critic (ProhibitLvalueSubstr)
377              
378 81732 100       221793 return ($new_tree, $child_start + 1) if wantarray;
379 38420         98359 return $new_tree;
380             }
381              
382             =pod
383              
384             =head2 map_shallow
385              
386             $tree->map_shallow($sub);
387              
388             Apply the given sub to each direct child of the tree. The sub can return a node
389             or a tree and that returned content is concatenated to form a new tree.
390              
391             Only the top-level nodes of the tree are visited.
392              
393             In void context, update the tree in-place. Otherwise, the new tree is returned.
394              
395             In all cases, C<$sub> must return new nodes or trees, it can’t modify the input
396             object. The argument to C<$sub> are passed in the usual way in C<@_>, not in
397             C<$_>.
398              
399             =cut
400              
401             sub map_shallow {
402 0     0 1 0 my ($this, $sub) = @_;
403              
404 0         0 my $new_tree = Markdown::Perl::InlineTree->new();
405              
406 0         0 for (@{$this->{children}}) {
  0         0  
407 0         0 $new_tree->push($sub->());
408             }
409              
410 0 0       0 return $new_tree if defined wantarray;
411 0         0 %{$this} = %{$new_tree};
  0         0  
  0         0  
412 0         0 return;
413             }
414              
415             =pod
416              
417             =head2 map
418              
419             $tree->map($sub);
420              
421             Same as C, but the tree is visited recursively. The subtree of
422             individual nodes are visited and their content replaced before the node itself
423             are visited.
424              
425             =cut
426              
427             sub map { ## no critic (ProhibitBuiltinHomonyms)
428 124287     124287 1 183121 my ($this, $sub, $start, $stop) = @_;
429             # $start and $stop are not documented for this function, they are used by
430             # clone().
431              
432 124287         196046 my $new_tree = Markdown::Perl::InlineTree->new();
433              
434 124287   100     342779 for (@{$this->{children}}[$start // 0 .. $stop // $#{$this->{children}}]) {
  124287   100     235645  
  95979         185134  
435 243099 100       338060 if ($_->has_subtree()) {
436 2114 100       3192 if (defined wantarray) {
437 36         59 my $new_node = $_->clone();
438 36         99 $new_node->{subtree}->map($sub);
439 36         85 local *_ = \$new_node;
440 36         70 $new_tree->push($sub->());
441             } else {
442             # Is there a risk that this modifies $_ before the call to $sub?
443 2078         4681 $_->{subtree}->map($sub);
444 2078         3416 $new_tree->push($sub->());
445             }
446             } else {
447 240985 100       307016 if (defined wantarray) {
448 30426         45367 my $new_node = $_->clone();
449 30426         53142 local *_ = \$new_node;
450 30426         40558 $new_tree->push($sub->());
451             } else {
452 210559         313024 $new_tree->push($sub->());
453             }
454             }
455             }
456              
457 124287 100       212717 return $new_tree if defined wantarray;
458 95979         104611 %{$this} = %{$new_tree};
  95979         179350  
  95979         147031  
459 95979         200528 return;
460             }
461              
462             =pod
463              
464             =head2 apply
465              
466             $tree->apply($sub);
467              
468             Apply the given C<$sub> to all nodes of the tree. The sub receives the current
469             node in C<$_> and can modify it. The return value of the sub is ignored.
470              
471             =cut
472              
473             sub apply {
474 57329     57329 1 81053 my ($this, $sub) = @_;
475              
476 57329         67644 for (@{$this->{children}}) {
  57329         92046  
477 181230         286076 $sub->();
478 181230 100       254978 $_->{subtree}->apply($sub) if $_->has_subtree();
479             }
480              
481 57329         81951 return;
482             }
483              
484             =pod
485              
486             =head2 clone
487              
488             my $new_tree = $tree->clone([$child_start, $child_end]);
489              
490             Clone (deep copy) the entire tree or a portion of it.
491              
492             =cut
493              
494             sub clone {
495 28308     28308 1 41308 my ($this, $start, $stop) = @_;
496 28308     30497   90137 return $this->map(sub { $_ }, $start, $stop);
  30497         51527  
497             }
498              
499             =head2 fold
500              
501             $tree->fold($sub, $init);
502              
503             Iterates over the top-level nodes of the tree, calling C<$sub> for each of them.
504             It receives two arguments, the current node and the result of the previous call.
505             The first call receives C<$init> as its second argument.
506              
507             Returns the result of the last call of C<$sub>.
508              
509             =cut
510              
511             # TODO: maybe have a "cat" methods that expects each node to return a string and
512             # concatenate them, so that we can concatenate them all together at once, which
513             # might be more efficient.
514             sub fold {
515 87628     87628 1 128282 my ($this, $sub, $init) = @_;
516              
517 87628         102087 my $out = $init;
518              
519 87628         86197 for (@{$this->{children}}) {
  87628         141307  
520 204791         253673 $out = $sub->($_, $out);
521             }
522              
523 87628         393296 return $out;
524             }
525              
526             =pod
527              
528             =head2 find_in_text
529              
530             $tree->find_in_text($regex, $start_child, $start_offset, [$end_child, $end_offset]);
531              
532             Find the first match of the given regex in the tree, starting at the given
533             offset in the node. This only considers top-level nodes of the tree and skip
534             over non B node (including the first one).
535              
536             If C<$end_child> and C<$end_offset> are given, then does not look for anything
537             starting at or after that bound.
538              
539             Does not match the regex across multiple nodes.
540              
541             Returns C<$child_number, $match_start_offset, $match_end_offset> (or just a
542             I value in scalar context) or C.
543              
544             =cut
545              
546             sub find_in_text {
547 92724     92724 1 175446 my ($this, $re, $child_start, $text_start, $child_bound, $text_bound) = @_;
548             # qr/^\b$/ is a regex that can’t match anything.
549 92724         199464 return $this->find_balanced_in_text(qr/^\b$/, $re, $child_start, $text_start, $child_bound,
550             $text_bound);
551             }
552              
553             =pod
554              
555             =head2 find_balanced_in_text
556              
557             $tree->find_balanced_in_text(
558             $open_re, $close_re, $start_child, $start_offset, $child_bound, $text_bound);
559              
560             Same as C except that this method searches for both C<$open_re> and
561             C<$close_re> and, each time C<$open_re> is found, it needs to find C<$close_re>
562             one more time before we it returns. The method assumes that C<$open_re> has
563             already been seen once before the given C<$start_child> and C<$start_offset>.
564              
565             =cut
566              
567             sub find_balanced_in_text {
568 92788     92788 1 165704 my ($this, $open_re, $close_re, $child_start, $text_start, $child_bound, $text_bound) = @_;
569              
570 92788         97299 my $open = 1;
571              
572 92788   100     161883 for my $i ($child_start .. ($child_bound // $#{$this->{children}})) {
  88992         248619  
573 160039 100       290061 next unless $this->{children}[$i]{type} eq 'text';
574 119537 100 100     253506 if ($i == $child_start && $text_start != 0) {
575 4597         10583 pos($this->{children}[$i]{content}) = $text_start;
576             } else {
577 114940         272391 pos($this->{children}[$i]{content}) = 0;
578             }
579              
580             # When the code in this regex is executed, we are sure that the engine
581             # won’t backtrack (as we are at the end of the regex).
582 119537         1505568 while (
583 24         110 $this->{children}[$i]{content} =~ m/ ${open_re}(?{$open++}) | ${close_re}(?{$open--}) /gx)
  42151         140460  
584             {
585 42175 100 100     126277 return if $i == ($child_bound // -1) && $LAST_MATCH_START[0] >= $text_bound;
      100        
586 41823 100       58031 if ($open == 0) {
587 41788 100       254591 return ($i, $LAST_MATCH_START[0], $LAST_MATCH_END[0]) if wantarray;
588 61         204 return 1;
589             }
590             }
591             }
592              
593 50648         192620 return;
594             }
595              
596             =pod
597              
598             =head2 find_in_text_with_balanced_content
599              
600             $tree->find_in_text_with_balanced_content(
601             $open_re, $close_re, $end_re, $start_child, $start_offset,
602             $child_bound, $text_bound);
603              
604             Similar to C except that this method ends when C<$end_re>
605             is seen, after the C<$open_re> and C<$close_re> regex have been seen a balanced
606             number of time. If the closing one is seen more than the opening one, the search
607             succeeds too. The method does B assumes that C<$open_re> has already been
608             seen before the given C<$start_child> and C<$start_offset> (as opposed to
609             C).
610              
611             =cut
612              
613             sub find_in_text_with_balanced_content {
614 3611     3611 1 8043 my ($this, $open_re, $close_re, $end_re, $child_start, $text_start, $child_bound, $text_bound) =
615             @_;
616              
617 3611         4167 my $open = 0;
618              
619 3611   66     7325 for my $i ($child_start .. ($child_bound // $#{$this->{children}})) {
  3611         11244  
620 4086 100       8980 next unless $this->{children}[$i]{type} eq 'text';
621 3837 100 100     11098 if ($i == $child_start && $text_start != 0) {
622 3609         7339 pos($this->{children}[$i]{content}) = $text_start;
623             } else {
624 228         570 pos($this->{children}[$i]{content}) = 0;
625             }
626              
627             # When the code in this regex is executed, we are sure that the engine
628             # won’t backtrack (as we are at the end of the regex).
629              
630 3837         5076 my $done = 0;
631 3837         32528 while ($this->{children}[$i]{content} =~
632 1406         4214 m/ ${end_re}(?{$done = 1}) | ${open_re}(?{$open++}) | ${close_re}(?{$open--}) /gx) {
  362         1281  
  2153         6684  
633 3921 50 50     11940 return if $i == ($child_bound // -1) && $LAST_MATCH_START[0] >= $text_bound;
      33        
634 3921 100 100     26507 return ($i, $LAST_MATCH_START[0], $LAST_MATCH_END[0]) if ($open == 0 && $done) || $open < 0;
      100        
635 993         4063 $done = 0;
636             }
637             }
638              
639 683         2218 return;
640             }
641              
642             =pod
643              
644             =head2 render_html
645              
646             $tree->render_html();
647              
648             Returns the HTML representation of that C.
649              
650             =cut
651              
652             sub render_html {
653 56393     56393 1 67459 my ($tree) = @_;
654 56393         111800 return $tree->fold(\&render_node_html, '');
655             }
656              
657             sub render_node_html {
658 179294     179294 0 216143 my ($n, $acc) = @_;
659              
660 179294 50       238487 confess 'Node should already be escaped when calling render_html' unless $n->{escaped};
661              
662 179294 100 100     418587 if ($n->{type} eq 'text' || $n->{type} eq 'literal' || $n->{type} eq 'html') {
    100 100        
    100          
    50          
663 153614         298408 return $acc.$n->{content};
664             } elsif ($n->{type} eq 'code') {
665 3615         10265 return $acc.''.$n->{content}.'';
666             } elsif ($n->{type} eq 'link') {
667 11855         16149 my $title = '';
668 11855 100       19273 if (exists $n->{title}) {
669 92         179 $title = " title=\"$n->{title}\"";
670             }
671 11855 100 100     32782 if ($n->{linktype} eq 'link' || $n->{linktype} eq 'autolink') {
    50          
672             # $n->{content} can only be set in the case of autolink or through the
673             # resolve_link_ref hook (in which case it takes precedence over whatever
674             # was in the link definition).
675 11061 100       22564 my $content = exists $n->{content} ? $n->{content} : $n->{subtree}->render_html();
676 11061         32209 return $acc."{target}\"${title}>${content}";
677             } elsif ($n->{linktype} eq 'img') {
678 794         2131 my $content = $n->{subtree}->to_text();
679 794         2852 return $acc."{target}\" alt=\"${content}\"${title} />";
680             } else {
681 0         0 confess 'Unexpected link type in render_node_html: '.$n->{linktype};
682             }
683             } elsif ($n->{type} eq 'style') {
684 10210         19189 my $content = $n->{subtree}->render_html();
685 10210 100       23010 if ($n->{tag} =~ m/^\.(.*)$/) {
686 1         3 my $class = $1;
687 1         4 return $acc."${content}";
688             } else {
689 10209         12892 my $tag = $n->{tag};
690 10209         26699 return $acc."<${tag}>${content}";
691             }
692             } else {
693 0         0 confess 'Unexpected node type in render_node_html: '.$n->{type};
694             }
695             }
696              
697             =pod
698              
699             =head2 to_text
700              
701             $tree->to_text();
702              
703             Returns the text content of this C discarding all HTML formatting.
704             This is used mainly to produce the C text of image nodes (which can contain
705             any Markdown construct in the source).
706              
707             =cut
708              
709             sub to_text {
710 935     935 1 1486 my ($tree) = @_;
711 935         2054 return $tree->fold(\&node_to_text, '');
712             }
713              
714             sub node_to_text {
715 1935     1935 0 2789 my ($n, $acc) = @_;
716 1935 50       3377 confess 'Node should already be escaped when calling to_text' unless $n->{escaped};
717 1935 100 100     4803 if ($n->{type} eq 'text') {
    100          
    100          
    100          
    50          
718 1274         2807 return $acc.$n->{content};
719             } elsif ($n->{type} eq 'style') {
720 109         362 return $acc.$n->{subtree}->to_text();
721             } elsif ($n->{type} eq 'literal' || $n->{type} eq 'html') {
722             # This is not the exact same behavior as cmark because we will escape
723             # literals here, while cmark would not escape them. The cmark behavior is
724             # probably faulty here (and is not tested by the test suite).
725 445         1256 return $acc.$n->{content};
726             } elsif ($n->{type} eq 'link') {
727 84 100       231 if ($n->{linktype} ne 'autolink') {
728 32         115 return $acc.$n->{subtree}->to_text();
729             } else {
730 52         137 return $acc.$n->{content};
731             }
732             } elsif ($n->{type} eq 'code') {
733 23         80 return $acc.''.$n->{content}.'';
734             } else {
735 0         0 confess 'Unsupported node type for to_text: '.$n->{type};
736             }
737             }
738              
739             =pod
740              
741             =head2 to_source_text
742              
743             $tree->to_source_text($unescape_literal);
744              
745             Returns the original Markdown source corresponding to this C. This
746             is used to produce the reference label, target and title of link elements and so
747             can support only node types that have a higher priority than links (nodes that
748             may have been built already when this is called).
749              
750             The source is returned as-is, the HTML entities are neither decoded nor escaped.
751              
752             If C<$unescape_literal> is true, then literal values that were escaped in the
753             source are unescaped (e.g. C<\;> will appear again as C<\;>). Otherwise they
754             will just appear as their literal value (e.g. C<;>).
755              
756             As a readability facility, the C symbol can be used to pass
757             this option (with a value of C<1>).
758              
759             =cut
760              
761             # It’s a feature that this does not interpolate.
762 32     32   317 use constant UNESCAPE_LITERAL => 1; ## no critic (ProhibitConstantPragma)
  32         66  
  32         21852  
763              
764             sub to_source_text {
765 30296     30296 1 40747 my ($tree, $unescape_literal) = @_;
766 30296         48111 return $tree->fold(node_to_source_text($unescape_literal), '');
767             }
768              
769             sub node_to_source_text {
770 30296     30296 0 35021 my ($unescape_literal) = @_;
771             # TODO: ideally all this should be replaced by the fact that the nodes should
772             # store the span of text that they represent, to be able to extract the actual
773             # source text.
774             # This probably requires that the inlines processing should be rewritten to do
775             # the link at the same time as the auto-links and inline HTML so that this
776             # operates on text.
777             return sub {
778 23553     23553   33155 my ($n, $acc) = @_;
779 23553 50       36002 confess 'Node should not already be escaped when calling to_source_text' if $n->{escaped};
780 23553 100 100     38628 if ($n->{type} eq 'text') {
    100 100        
    100          
    100          
    50          
781 22428         67054 return $acc.$n->{content};
782             } elsif ($n->{type} eq 'literal' && $unescape_literal) {
783 8         30 return $acc.'\\'.$n->{content};
784             } elsif ($n->{type} eq 'literal' || $n->{type} eq 'html') {
785 652         1563 return $acc.$n->{content};
786             } elsif ($n->{type} eq 'code') {
787             # TODO: This also need to be the source string with the right delimiters.
788 110         337 return $acc.''.$n->{content}.'';
789             } elsif ($n->{type} eq 'link') {
790 355 100       523 if ($n->{linktype} eq 'autolink') {
791 319         931 return $acc.'<'.$n->{content}.'>';
792             } else {
793             # 'img' can appear inside other links and links can appear inside images
794             # and, as-such, we may try to treat them as link reference label, so we
795             # need this case.
796             # Because their structure is complex, we return a dummy value.
797             # BUG: we can’t have a link reference using a label that looks like an
798             # image.
799 36         82 return $acc.'dummy_text_hopefully_this_does_not_collide_with_anything';
800             }
801             } else {
802 0         0 confess 'Unsupported node type for to_source_text: '.$n->{type};
803             }
804 30296         190206 };
805             }
806              
807             =head2 span_to_source_text
808              
809             $tree->span_to_source_text($child_start, $text_start, $child_end, $text_end[, $unescape_literal]);
810              
811             Same as C but only renders the specified span of the
812             C.
813              
814             =cut
815              
816             sub span_to_source_text {
817 28308     28308 1 46666 my ($tree, $child_start, $text_start, $child_end, $text_end, $unescape_literal) = @_;
818 28308         46931 my $copy = $tree->clone($child_start, $child_end);
819 28308         85257 my $extract = $copy->extract(0, $text_start, $child_end - $child_start, $text_end);
820 28308         54437 return $extract->to_source_text($unescape_literal);
821             }
822              
823             1;