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 34     34   273 use strict;
  34         88  
  34         1224  
4 34     34   349 use warnings;
  34         82  
  34         1165  
5 34     34   221 use namespace::autoclean;
  34         76  
  34         418  
6              
7 34     34   2882 use re 'eval';
  34         92  
  34         2092  
8              
9             our $VERSION = '0.38';
10              
11 34     34   231 use List::AllUtils qw( uniq );
  34         112  
  34         2295  
12 34     34   14227 use Markdent::Event::AutoLink;
  34         141  
  34         1388  
13 34     34   19590 use Markdent::Event::EndCode;
  34         168  
  34         1570  
14 34     34   17060 use Markdent::Event::EndEmphasis;
  34         162  
  34         1526  
15 34     34   19515 use Markdent::Event::EndHTMLTag;
  34         149  
  34         1457  
16 34     34   18974 use Markdent::Event::EndLink;
  34         141  
  34         1477  
17 34     34   18419 use Markdent::Event::EndStrong;
  34         144  
  34         1486  
18 34     34   19627 use Markdent::Event::HTMLComment;
  34         165  
  34         1470  
19 34     34   18816 use Markdent::Event::HTMLEntity;
  34         152  
  34         1443  
20 34     34   20693 use Markdent::Event::HTMLTag;
  34         148  
  34         1441  
21 34     34   19116 use Markdent::Event::Image;
  34         164  
  34         1611  
22 34     34   19003 use Markdent::Event::LineBreak;
  34         138  
  34         1361  
23 34     34   20261 use Markdent::Event::StartCode;
  34         197  
  34         1504  
24 34     34   20096 use Markdent::Event::StartEmphasis;
  34         155  
  34         1522  
25 34     34   20543 use Markdent::Event::StartHTMLTag;
  34         159  
  34         1533  
26 34     34   19325 use Markdent::Event::StartLink;
  34         161  
  34         1568  
27 34     34   19619 use Markdent::Event::StartStrong;
  34         158  
  34         1630  
28 34     34   19683 use Markdent::Event::Text;
  34         199  
  34         1754  
29 34     34   330 use Markdent::Regexes qw( $HorizontalWS $HTMLComment );
  34         86  
  34         4684  
30 34     34   273 use Markdent::Types;
  34         85  
  34         301  
31              
32 34     34   865575 use Moose;
  34         106  
  34         367  
33 34     34   245920 use MooseX::SemiAffordanceAccessor;
  34         132  
  34         389  
34 34     34   124918 use MooseX::StrictConstructor;
  34         96  
  34         295  
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 175     175 1 365 my $self = shift;
109 175         335 my $text = shift;
110              
111 175         289 ${$text} =~ s/ ^
  175         982  
112             \p{SpaceSeparator}{0,3}
113             \[ ([^]]+) \]
114             :
115             \p{SpaceSeparator}*
116             \n?
117             \p{SpaceSeparator}*
118             (.+)
119             \n
120             /
121 25         97 $self->_process_id_for_link( $1, $2 );
122             /egxm;
123             }
124              
125             sub _process_id_for_link {
126 25     25   50 my $self = shift;
127 25         60 my $id = shift;
128 25         54 my $id_text = shift;
129              
130 25         107 $id_text =~ s/\s+$//;
131              
132 25         75 my ( $uri, $title ) = $self->_parse_uri_and_title($id_text);
133              
134 25         1404 $self->_add_link_by_id( $id => [ $uri, $title ] );
135              
136 25         488 return q{};
137             }
138              
139             sub _parse_uri_and_title {
140 39     39   69 my $self = shift;
141 39         71 my $text = shift;
142              
143 39         218 $text =~ s/^\s+|\s+$//g;
144              
145 39         368 my ( $uri, $title ) = split /$HorizontalWS+/, $text, 2;
146              
147 39 100       660 $uri = q{}
148             unless defined $uri;
149              
150 39         224 $uri =~ s/^<|>$//g;
151 39 100       173 $title =~ s/^"|"$//g
152             if defined $title;
153              
154 39         136 return ( $uri, $title );
155             }
156              
157             sub parse_block {
158 1095     1095 1 2173 my $self = shift;
159 1095         2350 my $text = shift;
160              
161 1095 50       29413 $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 1095         3599 $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 1095         3347 $self->_convert_invalid_start_events_to_text('is done');
171              
172 1095         3132 $self->_debug_pending_events('before text merging');
173              
174 1095         3432 $self->_merge_consecutive_text_events();
175              
176 1095         2744 $self->_debug_pending_events('after text merging');
177              
178 1095         40489 $self->handler()->handle_event($_) for $self->_pending_events();
179              
180 1095         167560 $self->_clear_pending_events();
181              
182 1095         4174 return;
183             }
184              
185             sub _parse_text {
186 1127     1127   1897 my $self = shift;
187 1127         1750 my $text = shift;
188              
189             PARSE:
190 1127         1753 while (1) {
191 3073 50 33     79742 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 3073 100       4842 if ( ${$text} =~ /\G\z/gc ) {
  3073         9306  
198 1127         3040 $self->_event_for_text_buffer();
199 1127         2483 last;
200             }
201              
202 1946         4752 my @look_for = $self->_possible_span_matches();
203              
204 1946         7248 $self->_debug_look_for(@look_for);
205              
206 1946         4310 for my $span (@look_for) {
207 17335 100       216718 my ( $markup, @args ) = ref $span ? @{$span} : $span;
  356         992  
208              
209 17335         30124 my $meth = '_match_' . $markup;
210              
211 17335 100       44856 $self->$meth( $text, @args )
212             and next PARSE;
213             }
214              
215 1553         9263 $self->_match_plain_text($text);
216             }
217             }
218              
219             sub _possible_span_matches {
220 2010     2010   3200 my $self = shift;
221              
222 2010         4489 my %open = $self->_open_start_events_for_span( 'code', 'link' );
223 2010 100       4741 if ( my $event = $open{code} ) {
224 199         5490 return [ 'code_end', $event->delimiter() ];
225             }
226              
227 1811         3513 my @look_for = 'escape';
228              
229 1811         3852 push @look_for, $self->_look_for_strong_and_emphasis();
230              
231 1811         3226 push @look_for, 'code_start';
232              
233 1811 100       3973 unless ( $open{link} ) {
234 1768         3296 push @look_for, qw( auto_link link image );
235             }
236              
237 1811         3318 push @look_for, 'html_comment', 'html_tag', 'html_entity', 'line_break';
238              
239 1811         6585 return @look_for;
240             }
241              
242             sub _look_for_strong_and_emphasis {
243 1811     1811   2819 my $self = shift;
244              
245 1811         3381 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 1811 100 100     7173 if ( $open{strong} && $open{emphasis} ) {
    100          
    100          
249 18         26 my $last_saw;
250 18         553 for my $event ( $self->_pending_events() ) {
251 86         145 my $event_name = $event->event_name;
252 86 100       165 if ( $event_name eq 'start_strong' ) {
    100          
253 20         27 $last_saw = 'strong';
254             }
255             elsif ( $event_name eq 'start_emphasis' ) {
256 22         30 $last_saw = 'emphasis';
257             }
258             }
259              
260             my @order
261 18 50       48 = $last_saw eq 'strong'
262             ? qw( strong emphasis )
263             : qw( emphasis strong );
264              
265 18         40 return map { [ $_ . '_end', $open{$_}->delimiter() ] } @order;
  36         950  
266             }
267             elsif ( $open{emphasis} ) {
268             return (
269             'strong_start',
270 92         2898 [ 'emphasis_end', $open{emphasis}->delimiter() ]
271             );
272             }
273             elsif ( $open{strong} ) {
274             return (
275 45         1213 [ '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 1656         3909 return ( 'strong_start', 'emphasis_start' );
283             }
284              
285             sub _open_start_events_for_span {
286 3885     3885   5445 my $self = shift;
287 3885         6863 my %wanted_start = map { 'start_' . $_ => $_ } @_;
  7770         23292  
288 3885         7879 my %wanted_end = map { 'end_' . $_ => $_ } @_;
  7770         19186  
289              
290 3885         6334 my %open;
291 3885         143492 for my $event ( $self->_pending_events() ) {
292 7588         15671 my $event_name = $event->event_name;
293             $open{ $wanted_start{$event_name} } = $event
294 7588 100       14314 if $wanted_start{$event_name};
295              
296             delete $open{ $wanted_end{$event_name} }
297 7588 100       14433 if $wanted_end{$event_name};
298             }
299              
300 3885         12265 return %open;
301             }
302              
303             sub _build_emphasis_start_delimiter_re {
304 142     142   284 my $self = shift;
305              
306 142         4343 return qr/(?:\*|_)/;
307             }
308              
309             sub _build_escapable_chars {
310 160     160   4353 return [ qw( \ ` * _ { } [ ] ( ) + - . ! < > ), '#' ];
311             }
312              
313             sub _build_escape_re {
314 160     160   352 my $self = shift;
315              
316 160         327 my $chars = join q{}, uniq( @{ $self->_escapable_chars() } );
  160         4684  
317              
318 160         6351 return qr/\\([\Q$chars\E])/;
319             }
320              
321             sub _build_line_break_re {
322 160     160   312 my $self = shift;
323              
324 160         4623 return qr/\p{SpaceSeparator}{2}\n/;
325             }
326              
327             ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
328             sub _match_escape {
329 1747     1747   2771 my $self = shift;
330 1747         2478 my $text = shift;
331              
332 1747         48550 my $escape_re = $self->_escape_re();
333              
334 1747 100       3020 return unless ${$text} =~ / \G
  1747         12376  
335             ($escape_re)
336             /xgc;
337              
338 9 50       250 $self->_print_debug("Interpreting as escaped character\n\n[$1]\n")
339             if $self->debug();
340              
341 9         337 $self->_save_span_text($2);
342              
343 9         38 return 1;
344             }
345              
346             sub _match_strong_start {
347 1675     1675   2545 my $self = shift;
348 1675         2444 my $text = shift;
349              
350 1675 100       6288 my ($delim) = $self->_match_delimiter_start( $text, qr/(?:\*\*|__)/ )
351             or return;
352              
353 18         98 my $event = $self->_make_event( StartStrong => delimiter => $delim );
354              
355 18         70 $self->_markup_event($event);
356              
357 18         89 return 1;
358             }
359              
360             sub _match_strong_end {
361 57     57   91 my $self = shift;
362 57         79 my $text = shift;
363 57         86 my $delim = shift;
364              
365 57 100       343 $self->_match_delimiter_end( $text, qr/\Q$delim\E/ )
366             or return;
367              
368 12         75 my $event = $self->_make_event( EndStrong => delimiter => $delim );
369              
370 12         58 $self->_markup_event($event);
371              
372 12         64 return 1;
373             }
374              
375             sub _match_emphasis_start {
376 1608     1608   2674 my $self = shift;
377 1608         2136 my $text = shift;
378              
379 1608 100       53082 my ($delim) = $self->_match_delimiter_start(
380             $text,
381             $self->_emphasis_start_delimiter_re(),
382             ) or return;
383              
384 50         236 my $event = $self->_make_event( StartEmphasis => delimiter => $delim );
385              
386 50         206 $self->_markup_event($event);
387              
388 50         257 return 1;
389             }
390              
391             sub _match_emphasis_end {
392 100     100   172 my $self = shift;
393 100         158 my $text = shift;
394 100         168 my $delim = shift;
395              
396 100 100       258 $self->_match_delimiter_end(
397             $text,
398             $self->_emphasis_end_delimiter_re($delim),
399             ) or return;
400              
401 46         213 my $event = $self->_make_event( EndEmphasis => delimiter => $delim );
402              
403 46         172 $self->_markup_event($event);
404              
405 46         234 return 1;
406             }
407             ## use critic
408              
409             sub _emphasis_end_delimiter_re {
410 90     90   132 my $self = shift;
411 90         128 my $delim = shift;
412              
413 90         529 return qr/\Q$delim\E/;
414             }
415              
416             ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
417             sub _match_code_start {
418 1612     1612   2650 my $self = shift;
419 1612         2320 my $text = shift;
420              
421 1612 100       5585 my ($delim)
422             = $self->_match_delimiter_start( $text, qr/\`+\p{SpaceSeparator}*/ )
423             or return;
424              
425 92         569 $delim =~ s/\p{SpaceSeparator}*$//;
426              
427 92         431 my $event = $self->_make_event( StartCode => delimiter => $delim );
428              
429 92         332 $self->_markup_event($event);
430              
431 92         477 return 1;
432             }
433              
434             sub _match_code_end {
435 199     199   320 my $self = shift;
436 199         293 my $text = shift;
437 199         306 my $delim = shift;
438              
439 199 100       1185 $self->_match_delimiter_end( $text, qr/\p{SpaceSeparator}*\Q$delim/ )
440             or return;
441              
442 90         345 my $event = $self->_make_event( EndCode => delimiter => $delim );
443              
444 90         342 $self->_markup_event($event);
445              
446 90         465 return 1;
447             }
448              
449             sub _match_delimiter_start {
450 4895     4895   7774 my $self = shift;
451 4895         6567 my $text = shift;
452 4895         6195 my $delim = shift;
453              
454 4895 100       6234 return unless ${$text} =~ / \G ($delim)/xgc;
  4895         111980  
455              
456 160         10349 return $1;
457             }
458              
459             sub _match_delimiter_end {
460 356     356   1757 my $self = shift;
461 356         506 my $text = shift;
462 356         893 my $delim = shift;
463              
464 356 100       452 return unless ${$text} =~ /\G $delim /xgc;
  356         3606  
465              
466 148         500 return 1;
467             }
468              
469             sub _match_auto_link {
470 1483     1483   2494 my $self = shift;
471 1483         2132 my $text = shift;
472              
473 1483 100       2106 return unless ${$text} =~ /\G <( (?:https?|mailto|ftp): [^>]+ ) >/xgc;
  1483         5772  
474              
475 1         6 my $link = $self->_make_event( AutoLink => uri => $1 );
476              
477 1         5 $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 1482     1482   2612 my $self = shift;
508 1482         2109 my $text = shift;
509              
510 1482   100     1942 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 1482 100       2298 unless ${$text} =~ / \G
  1482         79465  
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         227 my ( $link_text, $attr ) = $self->_link_match_results( $1, $2, $3 );
528              
529 38 100       136 unless ( defined $attr->{uri} ) {
530 6 50       19 pos ${$text} = $pos
  6         21  
531             if defined $pos;
532              
533 6         32 return;
534             }
535              
536 32         67 my $start = $self->_make_event( StartLink => %{$attr} );
  32         175  
537              
538 32         141 $self->_markup_event($start);
539              
540 32         153 $self->_parse_text( \$link_text );
541              
542 32         138 my $end = $self->_make_event('EndLink');
543              
544 32         111 $self->_markup_event($end);
545              
546 32         224 return 1;
547             }
548              
549             sub _match_image {
550 1450     1450   2352 my $self = shift;
551 1450         1983 my $text = shift;
552              
553 1450   100     2006 my $pos = pos ${$text} || 0;
554              
555             return
556 1450 100       2265 unless ${$text} =~ / \G
  1450         65012  
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         42 my ( $alt_text, $attr ) = $self->_link_match_results( $1, $2, $3 );
568              
569 9 100       29 unless ( defined $attr->{uri} ) {
570 1 50       4 pos ${$text} = $pos
  1         5  
571             if defined $pos;
572              
573 1         6 return;
574             }
575              
576 8         19 $attr->{alt_text} = $alt_text;
577              
578 8         18 my $image = $self->_make_event( Image => %{$attr} );
  8         43  
579              
580 8         33 $self->_markup_event($image);
581              
582 8         58 return 1;
583             }
584             ## use critic
585              
586             sub _link_match_results {
587 47     47   109 my $self = shift;
588 47         124 my $text = shift;
589 47         96 my $uri_and_title = shift;
590 47         141 my $id = shift;
591              
592 47         84 my %attr;
593 47 100       123 if ( defined $uri_and_title ) {
594 14         55 my ( $uri, $title ) = $self->_parse_uri_and_title($uri_and_title);
595              
596 14         58 $attr{uri} = $uri;
597 14 100       43 $attr{title} = $title
598             if defined $title;
599             }
600             else {
601 33 100 100     202 unless ( defined $id && length $id ) {
602 11         21 $id = $text;
603 11         39 $attr{is_implicit_id} = 1;
604             }
605              
606 33         162 $id =~ s/\s+/ /g;
607              
608 33   100     1362 my $link = $self->_get_link_by_id($id) || [];
609              
610 33         131 $attr{uri} = $link->[0];
611 33 100       110 $attr{title} = $link->[1]
612             if defined $link->[1];
613 33         101 $attr{id} = $id;
614             }
615              
616 47         183 return ( $text, \%attr );
617             }
618              
619             ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
620             sub _match_html_comment {
621 1479     1479   2361 my $self = shift;
622 1479         2230 my $text = shift;
623              
624 1479 100       1977 return unless ${$text} =~ / \G
  1479         9036  
625             $HTMLComment
626             /xgcs;
627              
628 1         5 my $comment = $1;
629              
630 1         6 $self->_detab_text( \$comment );
631              
632 1         4 my $event = $self->_make_event( HTMLComment => text => $comment );
633              
634 1         5 $self->_markup_event($event);
635              
636 1         7 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 1478     1478   2309 my $self = shift;
644 1478         2051 my $text = shift;
645              
646 1478 100       2182 return unless ${$text} =~ m{\G (< [^>]+ >)}xgc;
  1478         5440  
647              
648 19         69 my $tag = $1;
649              
650 19         33 my $event;
651 19 100       75 if ( $tag =~ m{^</(\w+)>$} ) {
652 8         42 $event = $self->_make_event( EndHTMLTag => tag => $1 );
653             }
654             else {
655 11         105 $tag =~ s{^<|/?>$}{}g;
656              
657 11         65 my ( $tag_name, $attr_text ) = split /\s+/, $tag, 2;
658              
659 11         50 my $attr = $self->_parse_attributes($attr_text);
660              
661 11 100       54 if ( $InlineTags{$tag_name} ) {
662 3         13 $event = $self->_make_event(
663             HTMLTag => (
664             tag => $tag_name,
665             attributes => $attr,
666             ),
667             );
668             }
669             else {
670 8         56 $event = $self->_make_event(
671             StartHTMLTag => (
672             tag => $tag_name,
673             attributes => $attr,
674             ),
675             );
676             }
677             }
678              
679 19         91 $self->_markup_event($event);
680              
681 19         92 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   22 my $self = shift;
695 11         22 my $text = shift;
696              
697             # If the tag had no attributes there's nothing to parse.
698 11 100 66     67 return {} unless defined $text && length $text;
699              
700 7         17 my %attrs;
701             OUTER:
702 7   100     58 while ( ( ( pos $text ) || 0 ) < length $text ) {
703 12         31 for my $q (@quote) {
704 18 100       110 if ( $text =~ /$q/cg ) {
705 12         49 $attrs{$1} = $2;
706 12         52 next OUTER;
707             }
708             }
709              
710 0         0 die "Can't parse $text - not a properly formed attribute string\n";
711             }
712              
713 7         22 return \%attrs;
714             }
715              
716             sub _match_html_entity {
717 1459     1459   2233 my $self = shift;
718 1459         2188 my $text = shift;
719              
720 1459 100       1915 return unless ${$text} =~ / \G
  1459         5127  
721             &(\S+?);
722             /xgcs;
723              
724 7         31 my $event = $self->_make_event( HTMLEntity => entity => $1 );
725              
726 7         24 $self->_markup_event($event);
727              
728 7         37 return 1;
729             }
730              
731             sub _match_line_break {
732 1452     1452   2180 my $self = shift;
733 1452         2063 my $text = shift;
734              
735 1452         49630 my $line_break_re = $self->_line_break_re();
736              
737 1452 100       2127 return unless ${$text} =~ /\G$line_break_re/gcs;
  1452         8504  
738              
739 3         14 my $event = $self->_make_event('LineBreak');
740              
741 3         11 $self->_markup_event($event);
742              
743 3         18 return 1;
744             }
745              
746             sub _match_plain_text {
747 1553     1553   2457 my $self = shift;
748 1553         2324 my $text = shift;
749              
750             my $end_of_text_re = join '|',
751 1553         3287 grep {defined} (
  3155         8551  
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 1553 50       2622 unless ${$text} =~ /\G
  1553         25959  
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 1553 50       50236 $self->_print_debug("Interpreting as plain text\n\n[$1]\n")
782             if $self->debug();
783              
784 1553         56871 $self->_save_span_text($1);
785              
786 1553         4607 return 1;
787             }
788             ## use critic
789              
790             sub _text_end_res {
791 1553     1553   2265 my $self = shift;
792              
793             return (
794 1553         43247 $self->_escape_re(),
795             $self->_line_break_re(),
796             );
797             }
798              
799             sub _markup_event {
800 416     416   685 my $self = shift;
801 416         600 my $event = shift;
802              
803 416         1100 $self->_event_for_text_buffer();
804              
805 416 50       10993 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 416         14937 $self->_add_pending_event($event);
818              
819 416 100       2011 $self->_convert_invalid_start_events_to_text()
820             if $event->is_end();
821             }
822              
823             sub _event_for_text_buffer {
824 1543     1543   2525 my $self = shift;
825              
826 1543 100       58440 return unless $self->_has_span_text_buffer();
827              
828 1473         41516 my $text = $self->_span_text_buffer();
829              
830 1473         5609 $self->_detab_text( \$text );
831              
832 1473         3566 my $event = $self->_make_event( Text => text => $text );
833              
834 1473         58841 $self->_add_pending_event($event);
835              
836 1473         55891 $self->_clear_span_text_buffer();
837             }
838              
839             sub _convert_invalid_start_events_to_text {
840 1283     1283   1966 my $self = shift;
841 1283         2142 my $is_done = shift;
842              
843             # We want to operate directly on the reference so we can convert
844             # individual events in place
845 1283         36158 my $events = $self->__pending_events();
846              
847 1283         2280 my @starts;
848             EVENT:
849 1283         1929 for my $i ( 0 .. $#{$events} ) {
  1283         4009  
850 3334         52708 my $event = $events->[$i];
851              
852 3334 100       7924 next unless $event->does('Markdent::Role::BalancedEvent');
853              
854 1095 100       43183 if ( $event->is_start() ) {
    50          
855 560         1511 push @starts, [ $i, $event ];
856             }
857             elsif ( $event->is_end() ) {
858 535         1358 while ( my $start = pop @starts ) {
859             next EVENT
860 535 50       1725 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 1283 100       56180 return unless $is_done;
869              
870 1095         2588 for my $start (@starts) {
871 12         37 $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   18 my $self = shift;
878 12         17 my $event = shift;
879              
880 12 50       316 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         56 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 1095     1095   1727 my $self = shift;
902              
903 1095         30449 my $events = $self->__pending_events();
904              
905 1095         1994 my $merge_start;
906              
907             my @to_merge;
908 1095         1611 for my $i ( 0 .. $#{$events} ) {
  1095         2989  
909 1889         2897 my $event = $events->[$i];
910              
911 1889 100       5038 if ( $event->event_name() eq 'text' ) {
912 1485 100       4077 $merge_start = $i
913             unless defined $merge_start;
914             }
915             else {
916 404 100 100     1431 push @to_merge, [ $merge_start, $i - 1 ]
917             if defined $merge_start && $i - 1 > $merge_start;
918              
919 404         765 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         18 push @to_merge, [ $merge_start, $#{$events} ]
926 1095 100 66     2780 if defined $merge_start && $#{$events} > $merge_start;
  1095         3483  
927              
928 1095         2004 my $already_merged = 0;
929 1095         2607 for my $pair (@to_merge) {
930 11         15 $pair->[0] -= $already_merged;
931 11         18 $pair->[1] -= $already_merged;
932              
933             $self->_splice_merged_text_event(
934             $events,
935 11         18 @{$pair},
  11         42  
936             );
937              
938 11         234 $already_merged += $pair->[1] - $pair->[0];
939             }
940             }
941              
942             sub _splice_merged_text_event {
943 11     11   15 my $self = shift;
944 11         16 my $events = shift;
945 11         15 my $start = shift;
946 11         15 my $end = shift;
947              
948 11         20 my @to_merge = map { $_->text() } @{$events}[ $start .. $end ];
  27         632  
  11         24  
949              
950             $self->_print_debug(
951             "Merging consecutive text events ($start-$end) for: \n"
952 11 50       292 . ( join q{}, map {" - [$_]\n"} @to_merge ) )
  0         0  
953             if $self->debug();
954              
955 11         48 my $merged_text = join q{}, @to_merge;
956              
957 11         39 my $event = $self->_make_event(
958             Text => (
959             text => $merged_text,
960             _merged_from => \@to_merge,
961             ),
962             );
963              
964 11         18 splice @{$events}, $start, ( $end - $start ) + 1, $event;
  11         298  
965             }
966              
967             sub _debug_pending_events {
968 2190     2190   3332 my $self = shift;
969 2190         3166 my $desc = shift;
970              
971 2190 50       62555 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.38
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) 2020 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