File Coverage

blib/lib/Markdent/Parser/SpanParser.pm
Criterion Covered Total %
statement 427 448 95.3
branch 114 132 86.3
condition 22 26 84.6
subroutine 67 67 100.0
pod 2 2 100.0
total 632 675 93.6


line stmt bran cond sub pod time code
1             package Markdent::Parser::SpanParser;
2              
3 35     35   290 use strict;
  35         94  
  35         1357  
4 35     35   364 use warnings;
  35         86  
  35         1198  
5 35     35   211 use namespace::autoclean;
  35         84  
  35         440  
6              
7 35     35   3037 use re 'eval';
  35         91  
  35         2218  
8              
9             our $VERSION = '0.40';
10              
11 35     35   232 use List::AllUtils qw( uniq );
  35         86  
  35         2275  
12 35     35   16407 use Markdent::Event::AutoLink;
  35         138  
  35         1502  
13 35     35   21197 use Markdent::Event::EndCode;
  35         163  
  35         1668  
14 35     35   20535 use Markdent::Event::EndEmphasis;
  35         165  
  35         1727  
15 35     35   22321 use Markdent::Event::EndHTMLTag;
  35         167  
  35         1600  
16 35     35   21793 use Markdent::Event::EndLink;
  35         153  
  35         1525  
17 35     35   20250 use Markdent::Event::EndStrong;
  35         158  
  35         3825  
18 35     35   21735 use Markdent::Event::HTMLComment;
  35         161  
  35         1549  
19 35     35   23289 use Markdent::Event::HTMLEntity;
  35         148  
  35         1548  
20 35     35   20842 use Markdent::Event::HTMLTag;
  35         201  
  35         1556  
21 35     35   19835 use Markdent::Event::Image;
  35         160  
  35         1767  
22 35     35   24045 use Markdent::Event::LineBreak;
  35         161  
  35         1440  
23 35     35   19533 use Markdent::Event::StartCode;
  35         159  
  35         1587  
24 35     35   22444 use Markdent::Event::StartEmphasis;
  35         164  
  35         1647  
25 35     35   21999 use Markdent::Event::StartHTMLTag;
  35         169  
  35         1635  
26 35     35   21498 use Markdent::Event::StartLink;
  35         187  
  35         1724  
27 35     35   21762 use Markdent::Event::StartStrong;
  35         180  
  35         1767  
28 35     35   21674 use Markdent::Event::Text;
  35         168  
  35         1862  
29 35     35   330 use Markdent::Regexes qw( $HorizontalWS $HTMLComment );
  35         92  
  35         4966  
30 35     35   275 use Markdent::Types;
  35         105  
  35         326  
31              
32 35     35   912734 use Moose;
  35         137  
  35         372  
33 35     35   258828 use MooseX::SemiAffordanceAccessor;
  35         105  
  35         442  
34 35     35   136251 use MooseX::StrictConstructor;
  35         147  
  35         334  
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 180     180 1 439 my $self = shift;
109 180         359 my $text = shift;
110              
111 180         305 ${$text} =~ s/ ^
  180         1003  
112             \p{SpaceSeparator}{0,3}
113             \[ ([^]]+) \]
114             :
115             \p{SpaceSeparator}*
116             \n?
117             \p{SpaceSeparator}*
118             (.+)
119             \n
120             /
121 25         96 $self->_process_id_for_link( $1, $2 );
122             /egxm;
123             }
124              
125             sub _process_id_for_link {
126 25     25   39 my $self = shift;
127 25         62 my $id = shift;
128 25         56 my $id_text = shift;
129              
130 25         107 $id_text =~ s/\s+$//;
131              
132 25         68 my ( $uri, $title ) = $self->_parse_uri_and_title($id_text);
133              
134 25         1049 $self->_add_link_by_id( $id => [ $uri, $title ] );
135              
136 25         533 return q{};
137             }
138              
139             sub _parse_uri_and_title {
140 39     39   67 my $self = shift;
141 39         69 my $text = shift;
142              
143 39         224 $text =~ s/^\s+|\s+$//g;
144              
145 39         379 my ( $uri, $title ) = split /$HorizontalWS+/, $text, 2;
146              
147 39 100       701 $uri = q{}
148             unless defined $uri;
149              
150 39         170 $uri =~ s/^<|>$//g;
151 39 100       179 $title =~ s/^"|"$//g
152             if defined $title;
153              
154 39         143 return ( $uri, $title );
155             }
156              
157             sub parse_block {
158 1100     1100 1 2009 my $self = shift;
159 1100         2523 my $text = shift;
160              
161 1100 50       30551 $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 1100         3990 $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 1100         3512 $self->_convert_invalid_start_events_to_text('is done');
171              
172 1100         3325 $self->_debug_pending_events('before text merging');
173              
174 1100         3427 $self->_merge_consecutive_text_events;
175              
176 1100         2707 $self->_debug_pending_events('after text merging');
177              
178 1100         41300 $self->handler->handle_event($_) for $self->_pending_events;
179              
180 1100         173270 $self->_clear_pending_events;
181              
182 1100         4568 return;
183             }
184              
185             sub _parse_text {
186 1132     1132   1915 my $self = shift;
187 1132         1653 my $text = shift;
188              
189             PARSE:
190 1132         1822 while (1) {
191 3097 50 33     84485 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 3097 100       5265 if ( ${$text} =~ /\G\z/gc ) {
  3097         10118  
198 1132         3220 $self->_event_for_text_buffer;
199 1132         2689 last;
200             }
201              
202 1965         5002 my @look_for = $self->_possible_span_matches;
203              
204 1965         7638 $self->_debug_look_for(@look_for);
205              
206 1965         4563 for my $span (@look_for) {
207 17554 100       229150 my ( $markup, @args ) = ref $span ? @{$span} : $span;
  358         1035  
208              
209 17554         31643 my $meth = '_match_' . $markup;
210              
211 17554 100       47671 $self->$meth( $text, @args )
212             and next PARSE;
213             }
214              
215 1564         10143 $self->_match_plain_text($text);
216             }
217             }
218              
219             sub _possible_span_matches {
220 1965     1965   3137 my $self = shift;
221              
222 1965         4737 my %open = $self->_open_start_events_for_span( 'code', 'link' );
223 1965 100       4945 if ( my $event = $open{code} ) {
224 199         5879 return [ 'code_end', $event->delimiter ];
225             }
226              
227 1766         3671 my @look_for = 'escape';
228              
229 1766         3922 push @look_for, $self->_look_for_strong_and_emphasis;
230              
231 1766         3453 push @look_for, 'code_start';
232              
233 1766 100       3880 unless ( $open{link} ) {
234 1723         3360 push @look_for, qw( auto_link link image );
235             }
236              
237 1766         3438 push @look_for, 'html_comment', 'html_tag', 'html_entity', 'line_break';
238              
239 1766         6511 return @look_for;
240             }
241              
242             sub _look_for_strong_and_emphasis {
243 1766     1766   2739 my $self = shift;
244              
245 1766         3471 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 1766 100 100     7276 if ( $open{strong} && $open{emphasis} ) {
    100          
    100          
249 18         55 my $last_saw;
250 18         723 for my $event ( $self->_pending_events ) {
251 86         192 my $event_name = $event->event_name;
252 86 100       236 if ( $event_name eq 'start_strong' ) {
    100          
253 20         49 $last_saw = 'strong';
254             }
255             elsif ( $event_name eq 'start_emphasis' ) {
256 22         50 $last_saw = 'emphasis';
257             }
258             }
259              
260             my @order
261 18 50       80 = $last_saw eq 'strong'
262             ? qw( strong emphasis )
263             : qw( emphasis strong );
264              
265 18         44 return map { [ $_ . '_end', $open{$_}->delimiter ] } @order;
  36         1068  
266             }
267             elsif ( $open{emphasis} ) {
268             return (
269             'strong_start',
270 82         2525 [ 'emphasis_end', $open{emphasis}->delimiter ]
271             );
272             }
273             elsif ( $open{strong} ) {
274             return (
275 45         1356 [ '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 1621         3941 return ( 'strong_start', 'emphasis_start' );
283             }
284              
285             sub _open_start_events_for_span {
286 3869     3869   5403 my $self = shift;
287 3869         7229 my %wanted_start = map { 'start_' . $_ => $_ } @_;
  7669         24431  
288 3869         8014 my %wanted_end = map { 'end_' . $_ => $_ } @_;
  7669         19529  
289              
290 3869         6648 my %open;
291 3869         150063 for my $event ( $self->_pending_events ) {
292 7578         16449 my $event_name = $event->event_name;
293             $open{ $wanted_start{$event_name} } = $event
294 7578 100       15385 if $wanted_start{$event_name};
295              
296             delete $open{ $wanted_end{$event_name} }
297 7578 100       15274 if $wanted_end{$event_name};
298             }
299              
300 3869         12751 return %open;
301             }
302              
303             sub _build_emphasis_start_delimiter_re {
304 146     146   314 my $self = shift;
305              
306 146         4786 return qr/(?:\*|_)/;
307             }
308              
309             sub _build_escapable_chars {
310 165     165   4717 return [ qw( \ ` * _ { } [ ] ( ) + - . ! < > ~ ), '#' ];
311             }
312              
313             sub _build_escape_re {
314 165     165   349 my $self = shift;
315              
316 165         345 my $chars = join q{}, uniq( @{ $self->_escapable_chars } );
  165         5209  
317              
318 165         6832 return qr/\\([\Q$chars\E])/;
319             }
320              
321             sub _build_line_break_re {
322 165     165   354 my $self = shift;
323              
324 165         5009 return qr/\p{SpaceSeparator}{2}\n/;
325             }
326              
327             ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
328             sub _match_escape {
329 1766     1766   3060 my $self = shift;
330 1766         2487 my $text = shift;
331              
332 1766         50586 my $escape_re = $self->_escape_re;
333              
334 1766 100       2860 return unless ${$text} =~ / \G
  1766         13333  
335             ($escape_re)
336             /xgc;
337              
338 13 50       364 $self->_print_debug("Interpreting as escaped character\n\n[$1]\n")
339             if $self->debug;
340              
341 13         489 $self->_save_span_text($2);
342              
343 13         59 return 1;
344             }
345              
346             sub _match_strong_start {
347 1690     1690   2934 my $self = shift;
348 1690         2345 my $text = shift;
349              
350 1690 100       6600 my ($delim) = $self->_match_delimiter_start( $text, qr/(?:\*\*|__)/ )
351             or return;
352              
353 18         121 my $event = $self->_make_event( StartStrong => delimiter => $delim );
354              
355 18         110 $self->_markup_event($event);
356              
357 18         111 return 1;
358             }
359              
360             sub _match_strong_end {
361 57     57   108 my $self = shift;
362 57         108 my $text = shift;
363 57         135 my $delim = shift;
364              
365 57 100       480 $self->_match_delimiter_end( $text, qr/\Q$delim\E/ )
366             or return;
367              
368 12         72 my $event = $self->_make_event( EndStrong => delimiter => $delim );
369              
370 12         56 $self->_markup_event($event);
371              
372 12         69 return 1;
373             }
374              
375             sub _match_emphasis_start {
376 1623     1623   2784 my $self = shift;
377 1623         2483 my $text = shift;
378              
379 1623 100       56539 my ($delim) = $self->_match_delimiter_start(
380             $text,
381             $self->_emphasis_start_delimiter_re,
382             ) or return;
383              
384 50         262 my $event = $self->_make_event( StartEmphasis => delimiter => $delim );
385              
386 50         231 $self->_markup_event($event);
387              
388 50         297 return 1;
389             }
390              
391             sub _match_emphasis_end {
392 100     100   194 my $self = shift;
393 100         163 my $text = shift;
394 100         180 my $delim = shift;
395              
396 100 100       364 $self->_match_delimiter_end(
397             $text,
398             $self->_emphasis_end_delimiter_re($delim),
399             ) or return;
400              
401 46         239 my $event = $self->_make_event( EndEmphasis => delimiter => $delim );
402              
403 46         197 $self->_markup_event($event);
404              
405 46         273 return 1;
406             }
407             ## use critic
408              
409             sub _emphasis_end_delimiter_re {
410 90     90   176 my $self = shift;
411 90         147 my $delim = shift;
412              
413 90         642 return qr/\Q$delim\E/;
414             }
415              
416             ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
417             sub _match_code_start {
418 1627     1627   2867 my $self = shift;
419 1627         2398 my $text = shift;
420              
421 1627 100       5758 my ($delim)
422             = $self->_match_delimiter_start( $text, qr/\`+\p{SpaceSeparator}*/ )
423             or return;
424              
425 92         673 $delim =~ s/\p{SpaceSeparator}*$//;
426              
427 92         448 my $event = $self->_make_event( StartCode => delimiter => $delim );
428              
429 92         352 $self->_markup_event($event);
430              
431 92         507 return 1;
432             }
433              
434             sub _match_code_end {
435 199     199   364 my $self = shift;
436 199         310 my $text = shift;
437 199         335 my $delim = shift;
438              
439 199 100       1426 $self->_match_delimiter_end( $text, qr/\p{SpaceSeparator}*\Q$delim/ )
440             or return;
441              
442 90         371 my $event = $self->_make_event( EndCode => delimiter => $delim );
443              
444 90         312 $self->_markup_event($event);
445              
446 90         463 return 1;
447             }
448              
449             sub _match_delimiter_start {
450 4997     4997   7946 my $self = shift;
451 4997         6783 my $text = shift;
452 4997         6704 my $delim = shift;
453              
454 4997 100       6723 return unless ${$text} =~ / \G ($delim)/xgc;
  4997         119064  
455              
456 161         11196 return $1;
457             }
458              
459             sub _match_delimiter_end {
460 358     358   2147 my $self = shift;
461 358         526 my $text = shift;
462 358         544 my $delim = shift;
463              
464 358 100       548 return unless ${$text} =~ /\G $delim /xgc;
  358         4071  
465              
466 149         491 return 1;
467             }
468              
469             sub _match_auto_link {
470 1498     1498   2607 my $self = shift;
471 1498         2385 my $text = shift;
472              
473 1498         2290 my $uri;
474              
475 1498 100       2264 if ( ${$text} =~ /\G <( (?:https?|mailto|ftp): [^>]+ ) >/xgc ) {
  1498 100       4263  
476 2         8 $uri = $1;
477             }
478 1496         3540 elsif ( ${$text} =~ /\G <( [^>]+ \@ [^>]+ ) >/xgc ) {
479 1         5 $uri = "mailto:$1";
480             }
481             else {
482 1495         4437 return;
483             }
484              
485 3         15 my $link = $self->_make_event( AutoLink => uri => $uri );
486              
487 3         15 $self->_markup_event($link);
488              
489 3         18 return 1;
490             }
491              
492             # Stolen from Text::Markdown
493             my $nested_brackets;
494             $nested_brackets = qr{
495             (?> # Atomic matching
496             [^\[\]]+ # Anything other than brackets
497             |
498             \[
499             (??{ $nested_brackets }) # Recursive set of nested brackets
500             \]
501             )*
502             }x;
503              
504             # Also stolen from Text::Markdown
505             my $nested_parens;
506             $nested_parens = qr{
507             (?> # Atomic matching
508             [^()]+ # Anything other than parens
509             |
510             \(
511             (??{ $nested_parens }) # Recursive set of nested parens
512             \)
513             )*
514             }x;
515              
516             sub _match_link {
517 1495     1495   2360 my $self = shift;
518 1495         2305 my $text = shift;
519              
520 1495   100     2072 my $pos = pos ${$text} || 0;
521              
522             # For some inexplicable reason, this regex needs to be recreated each time
523             # the method is called or $nested_brackets && $nested_parens are
524             # undef. Presumably this has something to do with using it in a
525             # subroutine's lexical scope (resetting the stack on each invocation?)
526             return
527 1495 100       2387 unless ${$text} =~ / \G
  1495         82805  
528             \[ ($nested_brackets) \] # link or alt text
529             (?:
530             \( ($nested_parens) \)
531             |
532             \s*
533             \[ ( [^]]* ) \] # an id (can be empty)
534             )? # with no id or explicit uri, use text as id
535             /xgc;
536              
537 38         214 my ( $link_text, $attr ) = $self->_link_match_results( $1, $2, $3 );
538              
539 38 100       132 unless ( defined $attr->{uri} ) {
540 6 50       17 pos ${$text} = $pos
  6         24  
541             if defined $pos;
542              
543 6         34 return;
544             }
545              
546 32         64 my $start = $self->_make_event( StartLink => %{$attr} );
  32         191  
547              
548 32         154 $self->_markup_event($start);
549              
550 32         145 $self->_parse_text( \$link_text );
551              
552 32         122 my $end = $self->_make_event('EndLink');
553              
554 32         121 $self->_markup_event($end);
555              
556 32         242 return 1;
557             }
558              
559             sub _match_image {
560 1463     1463   2910 my $self = shift;
561 1463         2244 my $text = shift;
562              
563 1463   100     2157 my $pos = pos ${$text} || 0;
564              
565             return
566 1463 100       2418 unless ${$text} =~ / \G
  1463         68042  
567             !
568             \[ ($nested_brackets) \] # link or alt text
569             (?:
570             \( ($nested_parens) \)
571             |
572             \s*
573             \[ ( [^]]* ) \] # an id (can be empty)
574             )? # with no id or explicit uri, use text as id
575             /xgc;
576              
577 9         41 my ( $alt_text, $attr ) = $self->_link_match_results( $1, $2, $3 );
578              
579 9 100       26 unless ( defined $attr->{uri} ) {
580 1 50       5 pos ${$text} = $pos
  1         5  
581             if defined $pos;
582              
583 1         6 return;
584             }
585              
586 8         15 $attr->{alt_text} = $alt_text;
587              
588 8         17 my $image = $self->_make_event( Image => %{$attr} );
  8         42  
589              
590 8         32 $self->_markup_event($image);
591              
592 8         54 return 1;
593             }
594             ## use critic
595              
596             sub _link_match_results {
597 47     47   111 my $self = shift;
598 47         126 my $text = shift;
599 47         100 my $uri_and_title = shift;
600 47         104 my $id = shift;
601              
602 47         79 my %attr;
603 47 100       136 if ( defined $uri_and_title ) {
604 14         50 my ( $uri, $title ) = $self->_parse_uri_and_title($uri_and_title);
605              
606 14         47 $attr{uri} = $uri;
607 14 100       47 $attr{title} = $title
608             if defined $title;
609             }
610             else {
611 33 100 100     212 unless ( defined $id && length $id ) {
612 11         24 $id = $text;
613 11         52 $attr{is_implicit_id} = 1;
614             }
615              
616 33         202 $id =~ s/\s+/ /g;
617              
618 33   100     1465 my $link = $self->_get_link_by_id($id) || [];
619              
620 33         120 $attr{uri} = $link->[0];
621 33 100       109 $attr{title} = $link->[1]
622             if defined $link->[1];
623 33         86 $attr{id} = $id;
624             }
625              
626 47         197 return ( $text, \%attr );
627             }
628              
629             ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
630             sub _match_html_comment {
631 1492     1492   2474 my $self = shift;
632 1492         2559 my $text = shift;
633              
634 1492 100       2081 return unless ${$text} =~ / \G
  1492         9579  
635             $HTMLComment
636             /xgcs;
637              
638 1         4 my $comment = $1;
639              
640 1         6 $self->_detab_text( \$comment );
641              
642 1         4 my $event = $self->_make_event( HTMLComment => text => $comment );
643              
644 1         5 $self->_markup_event($event);
645              
646 1         6 return 1;
647             }
648              
649             my %InlineTags = map { $_ => 1 }
650             qw( area base basefont br col frame hr iframe img input link meta param );
651              
652             sub _match_html_tag {
653 1491     1491   2547 my $self = shift;
654 1491         2142 my $text = shift;
655              
656 1491 100       2155 return unless ${$text} =~ m{\G (< [^>]+ >)}xgc;
  1491         5882  
657              
658 19         88 my $tag = $1;
659              
660 19         89 my $event;
661 19 100       86 if ( $tag =~ m{^</(\w+)>$} ) {
662 8         52 $event = $self->_make_event( EndHTMLTag => tag => $1 );
663             }
664             else {
665 11         120 $tag =~ s{^<|/?>$}{}g;
666              
667 11         78 my ( $tag_name, $attr_text ) = split /\s+/, $tag, 2;
668              
669 11         64 my $attr = $self->_parse_attributes($attr_text);
670              
671 11 100       70 if ( $InlineTags{$tag_name} ) {
672 3         14 $event = $self->_make_event(
673             HTMLTag => (
674             tag => $tag_name,
675             attributes => $attr,
676             ),
677             );
678             }
679             else {
680 8         53 $event = $self->_make_event(
681             StartHTMLTag => (
682             tag => $tag_name,
683             attributes => $attr,
684             ),
685             );
686             }
687             }
688              
689 19         82 $self->_markup_event($event);
690              
691 19         116 return 1;
692             }
693              
694             # This parsing code is copied from HTML::Parser::Simple::Attributes by Ron
695             # Savage with some modifications & additions.
696             my @quote = (
697             qr{\G([a-zA-Z0-9_-]+)\s*=\s*["]([^"]+)["](?:\s+|\z)}s, # Double quotes.
698             qr{\G([a-zA-Z0-9_-]+)\s*=\s*[']([^']+)['](?:\s+|\z)}s, # Single quotes.
699             qr{\G([a-zA-Z0-9_-]+)\s*=\s*([^\s'"]+)(?:\s+|\z)}s, # Unquoted.
700             qr{\G([a-zA-Z0-9_-]+)(?:\s+|\z)}, # Empty attribute (name w/ no value).
701             );
702              
703             sub _parse_attributes {
704 11     11   25 my $self = shift;
705 11         24 my $text = shift;
706              
707             # If the tag had no attributes there's nothing to parse.
708 11 100 66     111 return {} unless defined $text && length $text;
709              
710 7         18 my %attrs;
711             OUTER:
712 7   100     50 while ( ( ( pos $text ) || 0 ) < length $text ) {
713 12         29 for my $q (@quote) {
714 18 100       118 if ( $text =~ /$q/cg ) {
715 12         53 $attrs{$1} = $2;
716 12         50 next OUTER;
717             }
718             }
719              
720 0         0 die "Can't parse $text - not a properly formed attribute string\n";
721             }
722              
723 7         39 return \%attrs;
724             }
725              
726             sub _match_html_entity {
727 1472     1472   2263 my $self = shift;
728 1472         2185 my $text = shift;
729              
730 1472 100       2162 return unless ${$text} =~ / \G
  1472         5281  
731             &(\S+?);
732             /xgcs;
733              
734 7         31 my $event = $self->_make_event( HTMLEntity => entity => $1 );
735              
736 7         26 $self->_markup_event($event);
737              
738 7         71 return 1;
739             }
740              
741             sub _match_line_break {
742 1465     1465   2367 my $self = shift;
743 1465         2188 my $text = shift;
744              
745 1465         52119 my $line_break_re = $self->_line_break_re;
746              
747 1465 100       2544 return unless ${$text} =~ /\G$line_break_re/gcs;
  1465         9119  
748              
749 3         15 my $event = $self->_make_event('LineBreak');
750              
751 3         14 $self->_markup_event($event);
752              
753 3         16 return 1;
754             }
755              
756             sub _match_plain_text {
757 1564     1564   2635 my $self = shift;
758 1564         2359 my $text = shift;
759              
760             my $end_of_text_re = join '|',
761 1564         3476 grep {defined} (
  3232         9241  
762             $self->_text_end_res,
763             );
764              
765             # Note that we're careful not to consume any of the characters marking the
766             # (possible) end of the plain text. If those things turn out to _not_ be
767             # markup, we'll get them on the next pass, because we always match at
768             # least one character, so we should never get stuck in a loop.
769             return
770 1564 50       2859 unless ${$text} =~ /\G
  1564         27673  
771             ( .+? ) # at least one character followed by ...
772             (?=
773             $end_of_text_re
774             |
775             \* # possible span markup - bold or italics
776             |
777             _ # possible span markup - bold or italics
778             |
779             \p{SpaceSeparator}* \`
780             |
781             !?\[ # possible image or link
782             |
783             < [^>]+ > # an HTML tag
784             |
785             &\S+; # an HTML entity
786             |
787             \z # or the end of the string
788             )
789             /xgcs;
790              
791 1564 50       52815 $self->_print_debug("Interpreting as plain text\n\n[$1]\n")
792             if $self->debug;
793              
794 1564         59478 $self->_save_span_text($1);
795              
796 1564         4965 return 1;
797             }
798             ## use critic
799              
800             sub _text_end_res {
801 1564     1564   2282 my $self = shift;
802              
803             return (
804 1564         45438 $self->_escape_re,
805             $self->_line_break_re,
806             );
807             }
808              
809             sub _markup_event {
810 420     420   824 my $self = shift;
811 420         674 my $event = shift;
812              
813 420         1282 $self->_event_for_text_buffer;
814              
815 420 50       12141 if ( $self->debug ) {
816 0         0 my $msg = 'Found markup: ' . $event->event_name;
817              
818 0 0       0 if ( $event->can('delimiter') ) {
819 0         0 $msg .= ' - delimiter: [' . $event->delimiter . ']';
820             }
821              
822 0         0 $msg .= "\n";
823              
824 0         0 $self->_print_debug($msg);
825             }
826              
827 420         15793 $self->_add_pending_event($event);
828              
829 420 100       1981 $self->_convert_invalid_start_events_to_text
830             if $event->is_end;
831             }
832              
833             sub _event_for_text_buffer {
834 1552     1552   2525 my $self = shift;
835              
836 1552 100       61287 return unless $self->_has_span_text_buffer;
837              
838 1482         42929 my $text = $self->_span_text_buffer;
839              
840 1482         6124 $self->_detab_text( \$text );
841              
842 1482         3881 my $event = $self->_make_event( Text => text => $text );
843              
844 1482         61102 $self->_add_pending_event($event);
845              
846 1482         58226 $self->_clear_span_text_buffer;
847             }
848              
849             sub _convert_invalid_start_events_to_text {
850 1289     1289   2140 my $self = shift;
851 1289         2040 my $is_done = shift;
852              
853             # We want to operate directly on the reference so we can convert
854             # individual events in place
855 1289         37613 my $events = $self->__pending_events;
856              
857 1289         2192 my @starts;
858             EVENT:
859 1289         1949 for my $i ( 0 .. $#{$events} ) {
  1289         4236  
860 3351         56470 my $event = $events->[$i];
861              
862 3351 100       8705 next unless $event->does('Markdent::Role::BalancedEvent');
863              
864 1099 100       46158 if ( $event->is_start ) {
    50          
865 562         1916 push @starts, [ $i, $event ];
866             }
867             elsif ( $event->is_end ) {
868 537         1475 while ( my $start = pop @starts ) {
869             next EVENT
870 537 50       1860 if $event->balances_event( $start->[1] );
871              
872 0         0 $events->[ $start->[0] ]
873             = $self->_convert_start_event_to_text( $start->[1] );
874             }
875             }
876             }
877              
878 1289 100       58314 return unless $is_done;
879              
880 1100         2715 for my $start (@starts) {
881 12         55 $events->[ $start->[0] ]
882             = $self->_convert_start_event_to_text( $start->[1] );
883             }
884             }
885              
886             sub _convert_start_event_to_text {
887 12     12   28 my $self = shift;
888 12         20 my $event = shift;
889              
890 12 50       480 if ( $self->debug ) {
891 0         0 my $msg = 'Found bad start event for ' . $event->name;
892              
893 0 0       0 if ( $event->can('delimiter') ) {
894 0         0 $msg .= q{ with "} . $event->delimiter . q{" as the delimiter};
895             }
896              
897 0         0 $msg .= "\n";
898              
899 0         0 $self->_print_debug($msg);
900             }
901              
902 12         74 return $self->_make_event(
903             Text => (
904             text => $event->as_text,
905             _converted_from => $event->event_name,
906             )
907             );
908             }
909              
910             sub _merge_consecutive_text_events {
911 1100     1100   1708 my $self = shift;
912              
913 1100         31036 my $events = $self->__pending_events;
914              
915 1100         2120 my $merge_start;
916              
917             my @to_merge;
918 1100         1750 for my $i ( 0 .. $#{$events} ) {
  1100         3007  
919 1902         3044 my $event = $events->[$i];
920              
921 1902 100       5491 if ( $event->event_name eq 'text' ) {
922 1494 100       4336 $merge_start = $i
923             unless defined $merge_start;
924             }
925             else {
926 408 100 100     1630 push @to_merge, [ $merge_start, $i - 1 ]
927             if defined $merge_start && $i - 1 > $merge_start;
928              
929 408         804 undef $merge_start;
930             }
931             }
932              
933             # If $merge_start is still defined, then the last event was a text event
934             # which may need to be merged.
935 6         28 push @to_merge, [ $merge_start, $#{$events} ]
936 1100 100 66     3036 if defined $merge_start && $#{$events} > $merge_start;
  1100         3638  
937              
938 1100         1898 my $already_merged = 0;
939 1100         2506 for my $pair (@to_merge) {
940 11         34 $pair->[0] -= $already_merged;
941 11         28 $pair->[1] -= $already_merged;
942              
943             $self->_splice_merged_text_event(
944             $events,
945 11         24 @{$pair},
  11         53  
946             );
947              
948 11         290 $already_merged += $pair->[1] - $pair->[0];
949             }
950             }
951              
952             sub _splice_merged_text_event {
953 11     11   26 my $self = shift;
954 11         23 my $events = shift;
955 11         20 my $start = shift;
956 11         23 my $end = shift;
957              
958 11         30 my @to_merge = map { $_->text } @{$events}[ $start .. $end ];
  27         684  
  11         33  
959              
960             $self->_print_debug(
961             "Merging consecutive text events ($start-$end) for: \n"
962 11 50       300 . ( join q{}, map {" - [$_]\n"} @to_merge ) )
  0         0  
963             if $self->debug;
964              
965 11         54 my $merged_text = join q{}, @to_merge;
966              
967 11         55 my $event = $self->_make_event(
968             Text => (
969             text => $merged_text,
970             _merged_from => \@to_merge,
971             ),
972             );
973              
974 11         27 splice @{$events}, $start, ( $end - $start ) + 1, $event;
  11         398  
975             }
976              
977             sub _debug_pending_events {
978 2200     2200   3367 my $self = shift;
979 2200         3173 my $desc = shift;
980              
981 2200 50       65293 return unless $self->debug;
982              
983 0           my $msg = "Pending event stream $desc:\n";
984              
985 0           for my $event ( $self->_pending_events ) {
986 0           $msg .= $event->debug_dump . "\n";
987             }
988              
989 0           $self->_print_debug($msg);
990             }
991              
992             __PACKAGE__->meta->make_immutable;
993              
994             1;
995              
996             # ABSTRACT: Span parser for standard Markdown
997              
998             __END__
999              
1000             =pod
1001              
1002             =encoding UTF-8
1003              
1004             =head1 NAME
1005              
1006             Markdent::Parser::SpanParser - Span parser for standard Markdown
1007              
1008             =head1 VERSION
1009              
1010             version 0.40
1011              
1012             =head1 DESCRIPTION
1013              
1014             This class parses spans for the standard Markdown dialect (as defined by Daring
1015             Fireball and mdtest).
1016              
1017             =head1 METHODS
1018              
1019             This class provides the following methods:
1020              
1021             =head2 Markdent::Parser::SpanParser->new( handler => $handler )
1022              
1023             Creates a new span parser object. You must provide a span parser object.
1024              
1025             =head2 $span_parser->extract_link_ids(\$markdown)
1026              
1027             This method takes a reference to a markdown string and parses it for link ids.
1028             These are removed from the document and stored in the span parser for later
1029             use.
1030              
1031             =head2 $span_parser->parse_block(\$block)
1032              
1033             Parses a block for span-level markup.
1034              
1035             =head1 ROLES
1036              
1037             This class does the L<Markdent::Role::SpanParser>,
1038             L<Markdent::Role::AnyParser>, and L<Markdent::Role::DebugPrinter> roles.
1039              
1040             =head1 BUGS
1041              
1042             See L<Markdent> for bug reporting details.
1043              
1044             Bugs may be submitted at L<https://github.com/houseabsolute/Markdent/issues>.
1045              
1046             I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.
1047              
1048             =head1 SOURCE
1049              
1050             The source code repository for Markdent can be found at L<https://github.com/houseabsolute/Markdent>.
1051              
1052             =head1 AUTHOR
1053              
1054             Dave Rolsky <autarch@urth.org>
1055              
1056             =head1 COPYRIGHT AND LICENSE
1057              
1058             This software is copyright (c) 2021 by Dave Rolsky.
1059              
1060             This is free software; you can redistribute it and/or modify it under
1061             the same terms as the Perl 5 programming language system itself.
1062              
1063             The full text of the license can be found in the
1064             F<LICENSE> file included with this distribution.
1065              
1066             =cut