File Coverage

blib/lib/Markdent/Parser/SpanParser.pm
Criterion Covered Total %
statement 422 443 95.2
branch 112 130 86.1
condition 22 26 84.6
subroutine 67 67 100.0
pod 2 2 100.0
total 625 668 93.5


line stmt bran cond sub pod time code
1             package Markdent::Parser::SpanParser;
2              
3 35     35   271 use strict;
  35         83  
  35         1247  
4 35     35   324 use warnings;
  35         76  
  35         1158  
5 35     35   189 use namespace::autoclean;
  35         74  
  35         409  
6              
7 35     35   3305 use re 'eval';
  35         93  
  35         2044  
8              
9             our $VERSION = '0.39';
10              
11 35     35   234 use List::AllUtils qw( uniq );
  35         77  
  35         2246  
12 35     35   15003 use Markdent::Event::AutoLink;
  35         141  
  35         1681  
13 35     35   19944 use Markdent::Event::EndCode;
  35         159  
  35         1557  
14 35     35   19554 use Markdent::Event::EndEmphasis;
  35         194  
  35         1642  
15 35     35   20564 use Markdent::Event::EndHTMLTag;
  35         193  
  35         1527  
16 35     35   20546 use Markdent::Event::EndLink;
  35         148  
  35         1501  
17 35     35   19913 use Markdent::Event::EndStrong;
  35         155  
  35         1512  
18 35     35   22852 use Markdent::Event::HTMLComment;
  35         160  
  35         1583  
19 35     35   23028 use Markdent::Event::HTMLEntity;
  35         151  
  35         1525  
20 35     35   20386 use Markdent::Event::HTMLTag;
  35         156  
  35         1525  
21 35     35   18952 use Markdent::Event::Image;
  35         156  
  35         1784  
22 35     35   22630 use Markdent::Event::LineBreak;
  35         146  
  35         1408  
23 35     35   19585 use Markdent::Event::StartCode;
  35         155  
  35         1633  
24 35     35   20663 use Markdent::Event::StartEmphasis;
  35         164  
  35         1945  
25 35     35   21104 use Markdent::Event::StartHTMLTag;
  35         157  
  35         1525  
26 35     35   20284 use Markdent::Event::StartLink;
  35         178  
  35         1592  
27 35     35   20154 use Markdent::Event::StartStrong;
  35         157  
  35         1648  
28 35     35   20572 use Markdent::Event::Text;
  35         167  
  35         1687  
29 35     35   316 use Markdent::Regexes qw( $HorizontalWS $HTMLComment );
  35         84  
  35         4773  
30 35     35   264 use Markdent::Types;
  35         73  
  35         315  
31              
32 35     35   851557 use Moose;
  35         105  
  35         366  
33 35     35   244533 use MooseX::SemiAffordanceAccessor;
  35         95  
  35         407  
34 35     35   125202 use MooseX::StrictConstructor;
  35         90  
  35         294  
35              
36             with 'Markdent::Role::SpanParser';
37              
38             has __pending_events => (
39             traits => ['Array'],
40             is => 'rw',
41             isa => t( 'ArrayRef', of => t('EventObject') ),
42             default => sub { [] },
43             init_arg => undef,
44             handles => {
45             _pending_events => 'elements',
46             _add_pending_event => 'push',
47             _clear_pending_events => 'clear',
48             },
49             );
50              
51             has _span_text_buffer => (
52             traits => ['String'],
53             is => 'ro',
54             isa => t('Str'),
55             default => q{},
56             init_arg => undef,
57             handles => {
58             _save_span_text => 'append',
59             _has_span_text_buffer => 'length',
60             _clear_span_text_buffer => 'clear',
61             },
62             );
63              
64             has _links_by_id => (
65             traits => ['Hash'],
66             is => 'ro',
67             isa => t( 'HashRef', of => t('ArrayRef') ),
68             default => sub { {} },
69             init_arg => undef,
70             handles => {
71             _add_link_by_id => 'set',
72             _get_link_by_id => 'get',
73             },
74             );
75              
76             has _emphasis_start_delimiter_re => (
77             is => 'ro',
78             isa => t('RegexpRef'),
79             lazy => 1,
80             builder => '_build_emphasis_start_delimiter_re',
81             init_arg => undef,
82             );
83              
84             has _escape_re => (
85             is => 'ro',
86             isa => t('RegexpRef'),
87             lazy => 1,
88             builder => '_build_escape_re',
89             init_arg => undef,
90             );
91              
92             has _line_break_re => (
93             is => 'ro',
94             isa => t('RegexpRef'),
95             lazy => 1,
96             builder => '_build_line_break_re',
97             init_arg => undef,
98             );
99              
100             has _escapable_chars => (
101             is => 'ro',
102             isa => t( 'ArrayRef', of => t('Str') ),
103             lazy => 1,
104             builder => '_build_escapable_chars',
105             );
106              
107             sub extract_link_ids {
108 178     178 1 366 my $self = shift;
109 178         339 my $text = shift;
110              
111 178         319 ${$text} =~ s/ ^
  178         982  
112             \p{SpaceSeparator}{0,3}
113             \[ ([^]]+) \]
114             :
115             \p{SpaceSeparator}*
116             \n?
117             \p{SpaceSeparator}*
118             (.+)
119             \n
120             /
121 25         93 $self->_process_id_for_link( $1, $2 );
122             /egxm;
123             }
124              
125             sub _process_id_for_link {
126 25     25   40 my $self = shift;
127 25         54 my $id = shift;
128 25         51 my $id_text = shift;
129              
130 25         91 $id_text =~ s/\s+$//;
131              
132 25         71 my ( $uri, $title ) = $self->_parse_uri_and_title($id_text);
133              
134 25         940 $self->_add_link_by_id( $id => [ $uri, $title ] );
135              
136 25         506 return q{};
137             }
138              
139             sub _parse_uri_and_title {
140 39     39   61 my $self = shift;
141 39         63 my $text = shift;
142              
143 39         194 $text =~ s/^\s+|\s+$//g;
144              
145 39         343 my ( $uri, $title ) = split /$HorizontalWS+/, $text, 2;
146              
147 39 100       598 $uri = q{}
148             unless defined $uri;
149              
150 39         148 $uri =~ s/^<|>$//g;
151 39 100       154 $title =~ s/^"|"$//g
152             if defined $title;
153              
154 39         125 return ( $uri, $title );
155             }
156              
157             sub parse_block {
158 1098     1098 1 1946 my $self = shift;
159 1098         2330 my $text = shift;
160              
161 1098 50       27374 $self->_print_debug("Parsing text for span-level markup\n\n$text\n")
162             if $self->debug;
163              
164             # Note that we have to pass a _reference_ to text in order to make sure
165             # that we are matching the same variable with /g regexes each time.
166 1098         4047 $self->_parse_text( \$text );
167              
168             # This catches any bad start events that were found after the last end
169             # event, or if there were _no_ end events at all.
170 1098         3594 $self->_convert_invalid_start_events_to_text('is done');
171              
172 1098         3467 $self->_debug_pending_events('before text merging');
173              
174 1098         3483 $self->_merge_consecutive_text_events;
175              
176 1098         2539 $self->_debug_pending_events('after text merging');
177              
178 1098         36898 $self->handler->handle_event($_) for $self->_pending_events;
179              
180 1098         156111 $self->_clear_pending_events;
181              
182 1098         4541 return;
183             }
184              
185             sub _parse_text {
186 1130     1130   1894 my $self = shift;
187 1130         1712 my $text = shift;
188              
189             PARSE:
190 1130         1689 while (1) {
191 3089 50 33     74707 if ( $self->debug && pos ${$text} ) {
  0         0  
192             $self->_print_debug( "Remaining text:\n[\n"
193 0         0 . substr( ${$text}, pos ${$text} )
  0         0  
  0         0  
194             . "\n]\n" );
195             }
196              
197 3089 100       4923 if ( ${$text} =~ /\G\z/gc ) {
  3089         9603  
198 1130         3233 $self->_event_for_text_buffer;
199 1130         2622 last;
200             }
201              
202 1959         5187 my @look_for = $self->_possible_span_matches;
203              
204 1959         7230 $self->_debug_look_for(@look_for);
205              
206 1959         4291 for my $span (@look_for) {
207 17500 100       225115 my ( $markup, @args ) = ref $span ? @{$span} : $span;
  358         964  
208              
209 17500         29192 my $meth = '_match_' . $markup;
210              
211 17500 100       46477 $self->$meth( $text, @args )
212             and next PARSE;
213             }
214              
215 1560         9599 $self->_match_plain_text($text);
216             }
217             }
218              
219             sub _possible_span_matches {
220 1959     1959   3115 my $self = shift;
221              
222 1959         4940 my %open = $self->_open_start_events_for_span( 'code', 'link' );
223 1959 100       5206 if ( my $event = $open{code} ) {
224 199         5446 return [ 'code_end', $event->delimiter ];
225             }
226              
227 1760         3619 my @look_for = 'escape';
228              
229 1760         4168 push @look_for, $self->_look_for_strong_and_emphasis;
230              
231 1760         3375 push @look_for, 'code_start';
232              
233 1760 100       4099 unless ( $open{link} ) {
234 1717         3339 push @look_for, qw( auto_link link image );
235             }
236              
237 1760         3253 push @look_for, 'html_comment', 'html_tag', 'html_entity', 'line_break';
238              
239 1760         6179 return @look_for;
240             }
241              
242             sub _look_for_strong_and_emphasis {
243 1760     1760   2671 my $self = shift;
244              
245 1760         3276 my %open = $self->_open_start_events_for_span( 'strong', 'emphasis' );
246              
247             # If we are in both, we need to try to end the most recent one first.
248 1760 100 100     7697 if ( $open{strong} && $open{emphasis} ) {
    100          
    100          
249 18         33 my $last_saw;
250 18         547 for my $event ( $self->_pending_events ) {
251 86         157 my $event_name = $event->event_name;
252 86 100       166 if ( $event_name eq 'start_strong' ) {
    100          
253 20         30 $last_saw = 'strong';
254             }
255             elsif ( $event_name eq 'start_emphasis' ) {
256 22         42 $last_saw = 'emphasis';
257             }
258             }
259              
260             my @order
261 18 50       50 = $last_saw eq 'strong'
262             ? qw( strong emphasis )
263             : qw( emphasis strong );
264              
265 18         34 return map { [ $_ . '_end', $open{$_}->delimiter ] } @order;
  36         886  
266             }
267             elsif ( $open{emphasis} ) {
268             return (
269             'strong_start',
270 82         2390 [ 'emphasis_end', $open{emphasis}->delimiter ]
271             );
272             }
273             elsif ( $open{strong} ) {
274             return (
275 45         1247 [ 'strong_end', $open{strong}->delimiter ],
276             'emphasis_start'
277             );
278             }
279              
280             # We look for strong first since it's a longer version of emphasis (we
281             # need to try to match ** before *).
282 1615         4069 return ( 'strong_start', 'emphasis_start' );
283             }
284              
285             sub _open_start_events_for_span {
286 3857     3857   5152 my $self = shift;
287 3857         6530 my %wanted_start = map { 'start_' . $_ => $_ } @_;
  7645         22523  
288 3857         7377 my %wanted_end = map { 'end_' . $_ => $_ } @_;
  7645         18846  
289              
290 3857         6164 my %open;
291 3857         133280 for my $event ( $self->_pending_events ) {
292 7570         15663 my $event_name = $event->event_name;
293             $open{ $wanted_start{$event_name} } = $event
294 7570 100       14249 if $wanted_start{$event_name};
295              
296             delete $open{ $wanted_end{$event_name} }
297 7570 100       14386 if $wanted_end{$event_name};
298             }
299              
300 3857         12132 return %open;
301             }
302              
303             sub _build_emphasis_start_delimiter_re {
304 144     144   290 my $self = shift;
305              
306 144         4391 return qr/(?:\*|_)/;
307             }
308              
309             sub _build_escapable_chars {
310 163     163   4245 return [ qw( \ ` * _ { } [ ] ( ) + - . ! < > ~ ), '#' ];
311             }
312              
313             sub _build_escape_re {
314 163     163   316 my $self = shift;
315              
316 163         302 my $chars = join q{}, uniq( @{ $self->_escapable_chars } );
  163         4684  
317              
318 163         6244 return qr/\\([\Q$chars\E])/;
319             }
320              
321             sub _build_line_break_re {
322 163     163   339 my $self = shift;
323              
324 163         4585 return qr/\p{SpaceSeparator}{2}\n/;
325             }
326              
327             ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
328             sub _match_escape {
329 1760     1760   2821 my $self = shift;
330 1760         2476 my $text = shift;
331              
332 1760         45187 my $escape_re = $self->_escape_re;
333              
334 1760 100       2744 return unless ${$text} =~ / \G
  1760         12651  
335             ($escape_re)
336             /xgc;
337              
338 13 50       315 $self->_print_debug("Interpreting as escaped character\n\n[$1]\n")
339             if $self->debug;
340              
341 13         414 $self->_save_span_text($2);
342              
343 13         52 return 1;
344             }
345              
346             sub _match_strong_start {
347 1684     1684   2949 my $self = shift;
348 1684         2359 my $text = shift;
349              
350 1684 100       6847 my ($delim) = $self->_match_delimiter_start( $text, qr/(?:\*\*|__)/ )
351             or return;
352              
353 18         114 my $event = $self->_make_event( StartStrong => delimiter => $delim );
354              
355 18         92 $self->_markup_event($event);
356              
357 18         109 return 1;
358             }
359              
360             sub _match_strong_end {
361 57     57   94 my $self = shift;
362 57         86 my $text = shift;
363 57         81 my $delim = shift;
364              
365 57 100       400 $self->_match_delimiter_end( $text, qr/\Q$delim\E/ )
366             or return;
367              
368 12         81 my $event = $self->_make_event( EndStrong => delimiter => $delim );
369              
370 12         62 $self->_markup_event($event);
371              
372 12         107 return 1;
373             }
374              
375             sub _match_emphasis_start {
376 1617     1617   2757 my $self = shift;
377 1617         2506 my $text = shift;
378              
379 1617 100       49954 my ($delim) = $self->_match_delimiter_start(
380             $text,
381             $self->_emphasis_start_delimiter_re,
382             ) or return;
383              
384 50         245 my $event = $self->_make_event( StartEmphasis => delimiter => $delim );
385              
386 50         218 $self->_markup_event($event);
387              
388 50         302 return 1;
389             }
390              
391             sub _match_emphasis_end {
392 100     100   180 my $self = shift;
393 100         174 my $text = shift;
394 100         171 my $delim = shift;
395              
396 100 100       295 $self->_match_delimiter_end(
397             $text,
398             $self->_emphasis_end_delimiter_re($delim),
399             ) or return;
400              
401 46         235 my $event = $self->_make_event( EndEmphasis => delimiter => $delim );
402              
403 46         234 $self->_markup_event($event);
404              
405 46         312 return 1;
406             }
407             ## use critic
408              
409             sub _emphasis_end_delimiter_re {
410 90     90   138 my $self = shift;
411 90         153 my $delim = shift;
412              
413 90         610 return qr/\Q$delim\E/;
414             }
415              
416             ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
417             sub _match_code_start {
418 1621     1621   2519 my $self = shift;
419 1621         2326 my $text = shift;
420              
421 1621 100       5626 my ($delim)
422             = $self->_match_delimiter_start( $text, qr/\`+\p{SpaceSeparator}*/ )
423             or return;
424              
425 92         690 $delim =~ s/\p{SpaceSeparator}*$//;
426              
427 92         500 my $event = $self->_make_event( StartCode => delimiter => $delim );
428              
429 92         382 $self->_markup_event($event);
430              
431 92         585 return 1;
432             }
433              
434             sub _match_code_end {
435 199     199   352 my $self = shift;
436 199         331 my $text = shift;
437 199         367 my $delim = shift;
438              
439 199 100       1296 $self->_match_delimiter_end( $text, qr/\p{SpaceSeparator}*\Q$delim/ )
440             or return;
441              
442 90         428 my $event = $self->_make_event( EndCode => delimiter => $delim );
443              
444 90         310 $self->_markup_event($event);
445              
446 90         620 return 1;
447             }
448              
449             sub _match_delimiter_start {
450 4979     4979   7512 my $self = shift;
451 4979         6015 my $text = shift;
452 4979         6220 my $delim = shift;
453              
454 4979 100       6107 return unless ${$text} =~ / \G ($delim)/xgc;
  4979         116519  
455              
456 161         11095 return $1;
457             }
458              
459             sub _match_delimiter_end {
460 358     358   1880 my $self = shift;
461 358         568 my $text = shift;
462 358         567 my $delim = shift;
463              
464 358 100       603 return unless ${$text} =~ /\G $delim /xgc;
  358         3839  
465              
466 149         518 return 1;
467             }
468              
469             sub _match_auto_link {
470 1492     1492   2473 my $self = shift;
471 1492         2324 my $text = shift;
472              
473 1492 100       2115 return unless ${$text} =~ /\G <( (?:https?|mailto|ftp): [^>]+ ) >/xgc;
  1492         5627  
474              
475 1         5 my $link = $self->_make_event( AutoLink => uri => $1 );
476              
477 1         4 $self->_markup_event($link);
478              
479 1         5 return 1;
480             }
481              
482             # Stolen from Text::Markdown
483             my $nested_brackets;
484             $nested_brackets = qr{
485             (?> # Atomic matching
486             [^\[\]]+ # Anything other than brackets
487             |
488             \[
489             (??{ $nested_brackets }) # Recursive set of nested brackets
490             \]
491             )*
492             }x;
493              
494             # Also stolen from Text::Markdown
495             my $nested_parens;
496             $nested_parens = qr{
497             (?> # Atomic matching
498             [^()]+ # Anything other than parens
499             |
500             \(
501             (??{ $nested_parens }) # Recursive set of nested parens
502             \)
503             )*
504             }x;
505              
506             sub _match_link {
507 1491     1491   2615 my $self = shift;
508 1491         2283 my $text = shift;
509              
510 1491   100     2020 my $pos = pos ${$text} || 0;
511              
512             # For some inexplicable reason, this regex needs to be recreated each time
513             # the method is called or $nested_brackets && $nested_parens are
514             # undef. Presumably this has something to do with using it in a
515             # subroutine's lexical scope (resetting the stack on each invocation?)
516             return
517 1491 100       2430 unless ${$text} =~ / \G
  1491         76020  
518             \[ ($nested_brackets) \] # link or alt text
519             (?:
520             \( ($nested_parens) \)
521             |
522             \s*
523             \[ ( [^]]* ) \] # an id (can be empty)
524             )? # with no id or explicit uri, use text as id
525             /xgc;
526              
527 38         186 my ( $link_text, $attr ) = $self->_link_match_results( $1, $2, $3 );
528              
529 38 100       127 unless ( defined $attr->{uri} ) {
530 6 50       15 pos ${$text} = $pos
  6         19  
531             if defined $pos;
532              
533 6         34 return;
534             }
535              
536 32         59 my $start = $self->_make_event( StartLink => %{$attr} );
  32         172  
537              
538 32         142 $self->_markup_event($start);
539              
540 32         139 $self->_parse_text( \$link_text );
541              
542 32         112 my $end = $self->_make_event('EndLink');
543              
544 32         130 $self->_markup_event($end);
545              
546 32         258 return 1;
547             }
548              
549             sub _match_image {
550 1459     1459   2487 my $self = shift;
551 1459         2037 my $text = shift;
552              
553 1459   100     2103 my $pos = pos ${$text} || 0;
554              
555             return
556 1459 100       2245 unless ${$text} =~ / \G
  1459         61562  
557             !
558             \[ ($nested_brackets) \] # link or alt text
559             (?:
560             \( ($nested_parens) \)
561             |
562             \s*
563             \[ ( [^]]* ) \] # an id (can be empty)
564             )? # with no id or explicit uri, use text as id
565             /xgc;
566              
567 9         36 my ( $alt_text, $attr ) = $self->_link_match_results( $1, $2, $3 );
568              
569 9 100       31 unless ( defined $attr->{uri} ) {
570 1 50       4 pos ${$text} = $pos
  1         3  
571             if defined $pos;
572              
573 1         5 return;
574             }
575              
576 8         16 $attr->{alt_text} = $alt_text;
577              
578 8         13 my $image = $self->_make_event( Image => %{$attr} );
  8         37  
579              
580 8         28 $self->_markup_event($image);
581              
582 8         43 return 1;
583             }
584             ## use critic
585              
586             sub _link_match_results {
587 47     47   86 my $self = shift;
588 47         113 my $text = shift;
589 47         89 my $uri_and_title = shift;
590 47         77 my $id = shift;
591              
592 47         73 my %attr;
593 47 100       117 if ( defined $uri_and_title ) {
594 14         45 my ( $uri, $title ) = $self->_parse_uri_and_title($uri_and_title);
595              
596 14         41 $attr{uri} = $uri;
597 14 100       31 $attr{title} = $title
598             if defined $title;
599             }
600             else {
601 33 100 100     213 unless ( defined $id && length $id ) {
602 11         20 $id = $text;
603 11         29 $attr{is_implicit_id} = 1;
604             }
605              
606 33         153 $id =~ s/\s+/ /g;
607              
608 33   100     1321 my $link = $self->_get_link_by_id($id) || [];
609              
610 33         115 $attr{uri} = $link->[0];
611 33 100       122 $attr{title} = $link->[1]
612             if defined $link->[1];
613 33         101 $attr{id} = $id;
614             }
615              
616 47         162 return ( $text, \%attr );
617             }
618              
619             ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
620             sub _match_html_comment {
621 1488     1488   2487 my $self = shift;
622 1488         2422 my $text = shift;
623              
624 1488 100       2106 return unless ${$text} =~ / \G
  1488         9567  
625             $HTMLComment
626             /xgcs;
627              
628 1         4 my $comment = $1;
629              
630 1         7 $self->_detab_text( \$comment );
631              
632 1         5 my $event = $self->_make_event( HTMLComment => text => $comment );
633              
634 1         5 $self->_markup_event($event);
635              
636 1         6 return 1;
637             }
638              
639             my %InlineTags = map { $_ => 1 }
640             qw( area base basefont br col frame hr iframe img input link meta param );
641              
642             sub _match_html_tag {
643 1487     1487   2537 my $self = shift;
644 1487         2162 my $text = shift;
645              
646 1487 100       2074 return unless ${$text} =~ m{\G (< [^>]+ >)}xgc;
  1487         5721  
647              
648 19         77 my $tag = $1;
649              
650 19         40 my $event;
651 19 100       128 if ( $tag =~ m{^</(\w+)>$} ) {
652 8         46 $event = $self->_make_event( EndHTMLTag => tag => $1 );
653             }
654             else {
655 11         99 $tag =~ s{^<|/?>$}{}g;
656              
657 11         67 my ( $tag_name, $attr_text ) = split /\s+/, $tag, 2;
658              
659 11         48 my $attr = $self->_parse_attributes($attr_text);
660              
661 11 100       63 if ( $InlineTags{$tag_name} ) {
662 3         16 $event = $self->_make_event(
663             HTMLTag => (
664             tag => $tag_name,
665             attributes => $attr,
666             ),
667             );
668             }
669             else {
670 8         44 $event = $self->_make_event(
671             StartHTMLTag => (
672             tag => $tag_name,
673             attributes => $attr,
674             ),
675             );
676             }
677             }
678              
679 19         79 $self->_markup_event($event);
680              
681 19         109 return 1;
682             }
683              
684             # This parsing code is copied from HTML::Parser::Simple::Attributes by Ron
685             # Savage with some modifications & additions.
686             my @quote = (
687             qr{\G([a-zA-Z0-9_-]+)\s*=\s*["]([^"]+)["](?:\s+|\z)}s, # Double quotes.
688             qr{\G([a-zA-Z0-9_-]+)\s*=\s*[']([^']+)['](?:\s+|\z)}s, # Single quotes.
689             qr{\G([a-zA-Z0-9_-]+)\s*=\s*([^\s'"]+)(?:\s+|\z)}s, # Unquoted.
690             qr{\G([a-zA-Z0-9_-]+)(?:\s+|\z)}, # Empty attribute (name w/ no value).
691             );
692              
693             sub _parse_attributes {
694 11     11   26 my $self = shift;
695 11         21 my $text = shift;
696              
697             # If the tag had no attributes there's nothing to parse.
698 11 100 66     87 return {} unless defined $text && length $text;
699              
700 7         14 my %attrs;
701             OUTER:
702 7   100     49 while ( ( ( pos $text ) || 0 ) < length $text ) {
703 12         27 for my $q (@quote) {
704 18 100       101 if ( $text =~ /$q/cg ) {
705 12         47 $attrs{$1} = $2;
706 12         49 next OUTER;
707             }
708             }
709              
710 0         0 die "Can't parse $text - not a properly formed attribute string\n";
711             }
712              
713 7         23 return \%attrs;
714             }
715              
716             sub _match_html_entity {
717 1468     1468   2354 my $self = shift;
718 1468         2171 my $text = shift;
719              
720 1468 100       2179 return unless ${$text} =~ / \G
  1468         4873  
721             &(\S+?);
722             /xgcs;
723              
724 7         30 my $event = $self->_make_event( HTMLEntity => entity => $1 );
725              
726 7         20 $self->_markup_event($event);
727              
728 7         31 return 1;
729             }
730              
731             sub _match_line_break {
732 1461     1461   2392 my $self = shift;
733 1461         2138 my $text = shift;
734              
735 1461         47234 my $line_break_re = $self->_line_break_re;
736              
737 1461 100       2356 return unless ${$text} =~ /\G$line_break_re/gcs;
  1461         8755  
738              
739 3         13 my $event = $self->_make_event('LineBreak');
740              
741 3         14 $self->_markup_event($event);
742              
743 3         17 return 1;
744             }
745              
746             sub _match_plain_text {
747 1560     1560   2552 my $self = shift;
748 1560         2421 my $text = shift;
749              
750             my $end_of_text_re = join '|',
751 1560         3837 grep {defined} (
  3224         8584  
752             $self->_text_end_res,
753             );
754              
755             # Note that we're careful not to consume any of the characters marking the
756             # (possible) end of the plain text. If those things turn out to _not_ be
757             # markup, we'll get them on the next pass, because we always match at
758             # least one character, so we should never get stuck in a loop.
759             return
760 1560 50       2913 unless ${$text} =~ /\G
  1560         26719  
761             ( .+? ) # at least one character followed by ...
762             (?=
763             $end_of_text_re
764             |
765             \* # possible span markup - bold or italics
766             |
767             _ # possible span markup - bold or italics
768             |
769             \p{SpaceSeparator}* \`
770             |
771             !?\[ # possible image or link
772             |
773             < [^>]+ > # an HTML tag
774             |
775             &\S+; # an HTML entity
776             |
777             \z # or the end of the string
778             )
779             /xgcs;
780              
781 1560 50       46994 $self->_print_debug("Interpreting as plain text\n\n[$1]\n")
782             if $self->debug;
783              
784 1560         53279 $self->_save_span_text($1);
785              
786 1560         4789 return 1;
787             }
788             ## use critic
789              
790             sub _text_end_res {
791 1560     1560   2320 my $self = shift;
792              
793             return (
794 1560         40573 $self->_escape_re,
795             $self->_line_break_re,
796             );
797             }
798              
799             sub _markup_event {
800 418     418   743 my $self = shift;
801 418         813 my $event = shift;
802              
803 418         1306 $self->_event_for_text_buffer;
804              
805 418 50       10917 if ( $self->debug ) {
806 0         0 my $msg = 'Found markup: ' . $event->event_name;
807              
808 0 0       0 if ( $event->can('delimiter') ) {
809 0         0 $msg .= ' - delimiter: [' . $event->delimiter . ']';
810             }
811              
812 0         0 $msg .= "\n";
813              
814 0         0 $self->_print_debug($msg);
815             }
816              
817 418         14802 $self->_add_pending_event($event);
818              
819 418 100       2172 $self->_convert_invalid_start_events_to_text
820             if $event->is_end;
821             }
822              
823             sub _event_for_text_buffer {
824 1548     1548   2605 my $self = shift;
825              
826 1548 100       54798 return unless $self->_has_span_text_buffer;
827              
828 1478         38938 my $text = $self->_span_text_buffer;
829              
830 1478         6129 $self->_detab_text( \$text );
831              
832 1478         4144 my $event = $self->_make_event( Text => text => $text );
833              
834 1478         54511 $self->_add_pending_event($event);
835              
836 1478         52350 $self->_clear_span_text_buffer;
837             }
838              
839             sub _convert_invalid_start_events_to_text {
840 1287     1287   2249 my $self = shift;
841 1287         2343 my $is_done = shift;
842              
843             # We want to operate directly on the reference so we can convert
844             # individual events in place
845 1287         34379 my $events = $self->__pending_events;
846              
847 1287         2238 my @starts;
848             EVENT:
849 1287         2081 for my $i ( 0 .. $#{$events} ) {
  1287         4239  
850 3345         51891 my $event = $events->[$i];
851              
852 3345 100       8151 next unless $event->does('Markdent::Role::BalancedEvent');
853              
854 1099 100       43573 if ( $event->is_start ) {
    50          
855 562         1751 push @starts, [ $i, $event ];
856             }
857             elsif ( $event->is_end ) {
858 537         1520 while ( my $start = pop @starts ) {
859             next EVENT
860 537 50       2090 if $event->balances_event( $start->[1] );
861              
862 0         0 $events->[ $start->[0] ]
863             = $self->_convert_start_event_to_text( $start->[1] );
864             }
865             }
866             }
867              
868 1287 100       52237 return unless $is_done;
869              
870 1098         2646 for my $start (@starts) {
871 12         48 $events->[ $start->[0] ]
872             = $self->_convert_start_event_to_text( $start->[1] );
873             }
874             }
875              
876             sub _convert_start_event_to_text {
877 12     12   22 my $self = shift;
878 12         19 my $event = shift;
879              
880 12 50       314 if ( $self->debug ) {
881 0         0 my $msg = 'Found bad start event for ' . $event->name;
882              
883 0 0       0 if ( $event->can('delimiter') ) {
884 0         0 $msg .= q{ with "} . $event->delimiter . q{" as the delimiter};
885             }
886              
887 0         0 $msg .= "\n";
888              
889 0         0 $self->_print_debug($msg);
890             }
891              
892 12         57 return $self->_make_event(
893             Text => (
894             text => $event->as_text,
895             _converted_from => $event->event_name,
896             )
897             );
898             }
899              
900             sub _merge_consecutive_text_events {
901 1098     1098   1786 my $self = shift;
902              
903 1098         27401 my $events = $self->__pending_events;
904              
905 1098         2105 my $merge_start;
906              
907             my @to_merge;
908 1098         1657 for my $i ( 0 .. $#{$events} ) {
  1098         2922  
909 1896         2865 my $event = $events->[$i];
910              
911 1896 100       5556 if ( $event->event_name eq 'text' ) {
912 1490 100       4091 $merge_start = $i
913             unless defined $merge_start;
914             }
915             else {
916 406 100 100     1443 push @to_merge, [ $merge_start, $i - 1 ]
917             if defined $merge_start && $i - 1 > $merge_start;
918              
919 406         761 undef $merge_start;
920             }
921             }
922              
923             # If $merge_start is still defined, then the last event was a text event
924             # which may need to be merged.
925 6         14 push @to_merge, [ $merge_start, $#{$events} ]
926 1098 100 66     3210 if defined $merge_start && $#{$events} > $merge_start;
  1098         3975  
927              
928 1098         2042 my $already_merged = 0;
929 1098         2325 for my $pair (@to_merge) {
930 11         22 $pair->[0] -= $already_merged;
931 11         16 $pair->[1] -= $already_merged;
932              
933             $self->_splice_merged_text_event(
934             $events,
935 11         23 @{$pair},
  11         45  
936             );
937              
938 11         235 $already_merged += $pair->[1] - $pair->[0];
939             }
940             }
941              
942             sub _splice_merged_text_event {
943 11     11   17 my $self = shift;
944 11         20 my $events = shift;
945 11         23 my $start = shift;
946 11         18 my $end = shift;
947              
948 11         23 my @to_merge = map { $_->text } @{$events}[ $start .. $end ];
  27         583  
  11         24  
949              
950             $self->_print_debug(
951             "Merging consecutive text events ($start-$end) for: \n"
952 11 50       262 . ( join q{}, map {" - [$_]\n"} @to_merge ) )
  0         0  
953             if $self->debug;
954              
955 11         38 my $merged_text = join q{}, @to_merge;
956              
957 11         38 my $event = $self->_make_event(
958             Text => (
959             text => $merged_text,
960             _merged_from => \@to_merge,
961             ),
962             );
963              
964 11         36 splice @{$events}, $start, ( $end - $start ) + 1, $event;
  11         313  
965             }
966              
967             sub _debug_pending_events {
968 2196     2196   3167 my $self = shift;
969 2196         3019 my $desc = shift;
970              
971 2196 50       57329 return unless $self->debug;
972              
973 0           my $msg = "Pending event stream $desc:\n";
974              
975 0           for my $event ( $self->_pending_events ) {
976 0           $msg .= $event->debug_dump . "\n";
977             }
978              
979 0           $self->_print_debug($msg);
980             }
981              
982             __PACKAGE__->meta->make_immutable;
983              
984             1;
985              
986             # ABSTRACT: Span parser for standard Markdown
987              
988             __END__
989              
990             =pod
991              
992             =encoding UTF-8
993              
994             =head1 NAME
995              
996             Markdent::Parser::SpanParser - Span parser for standard Markdown
997              
998             =head1 VERSION
999              
1000             version 0.39
1001              
1002             =head1 DESCRIPTION
1003              
1004             This class parses spans for the standard Markdown dialect (as defined by
1005             Daring Fireball and mdtest).
1006              
1007             =head1 METHODS
1008              
1009             This class provides the following methods:
1010              
1011             =head2 Markdent::Parser::SpanParser->new( handler => $handler )
1012              
1013             Creates a new span parser object. You must provide a span parser object.
1014              
1015             =head2 $span_parser->extract_link_ids(\$markdown)
1016              
1017             This method takes a reference to a markdown string and parses it for link
1018             ids. These are removed from the document and stored in the span parser for
1019             later use.
1020              
1021             =head2 $span_parser->parse_block(\$block)
1022              
1023             Parses a block for span-level markup.
1024              
1025             =head1 ROLES
1026              
1027             This class does the L<Markdent::Role::SpanParser>,
1028             L<Markdent::Role::AnyParser>, and L<Markdent::Role::DebugPrinter> roles.
1029              
1030             =head1 BUGS
1031              
1032             See L<Markdent> for bug reporting details.
1033              
1034             Bugs may be submitted at L<https://github.com/houseabsolute/Markdent/issues>.
1035              
1036             I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.
1037              
1038             =head1 SOURCE
1039              
1040             The source code repository for Markdent can be found at L<https://github.com/houseabsolute/Markdent>.
1041              
1042             =head1 AUTHOR
1043              
1044             Dave Rolsky <autarch@urth.org>
1045              
1046             =head1 COPYRIGHT AND LICENSE
1047              
1048             This software is copyright (c) 2021 by Dave Rolsky.
1049              
1050             This is free software; you can redistribute it and/or modify it under
1051             the same terms as the Perl 5 programming language system itself.
1052              
1053             The full text of the license can be found in the
1054             F<LICENSE> file included with this distribution.
1055              
1056             =cut