File Coverage

blib/lib/Text/Amuse/Preprocessor/Parser.pm
Criterion Covered Total %
statement 40 40 100.0
branch 7 8 87.5
condition n/a
subroutine 5 5 100.0
pod 1 1 100.0
total 53 54 98.1


line stmt bran cond sub pod time code
1             package Text::Amuse::Preprocessor::Parser;
2              
3 9     9   79009 use utf8;
  9         31  
  9         62  
4 9     9   308 use strict;
  9         22  
  9         179  
5 9     9   46 use warnings;
  9         18  
  9         2339  
6              
7             =head1 NAME
8              
9             Text::Amuse::Preprocessor::Parser - Stripped down Muse parser for Text::Amuse::Preprocessor
10              
11             =head2 FUNCTIONS
12              
13             =over 4
14              
15             =item parse_text($body)
16              
17             Parse the string provided as argument and return a list of hashrefs
18             with this structure:
19              
20             {
21             type => "markup" || "text",
22             string => $chunk
23             }
24              
25             the concatenation of the C values is equal to the original
26             body (without carriage returns and null bytes, tabs normalized and
27             final newline appended if missing).
28              
29             =back
30              
31             =cut
32              
33             sub parse_text {
34 109     109 1 3778 my $string = shift;
35 109         2073 $string =~ s/[\r\0]//g;
36 109         784 $string =~ s/\t/ /g;
37 109 100       618 if ($string !~ m/\n\z/s) {
38 10         31 $string .= "\n";
39             }
40             # remove trailing space
41 109         2072 $string =~ s/ +$//gm;
42 109         190 my @list;
43 109         199 my $last_position = 0;
44 109         842 pos($string) = $last_position;
45 109         1697 while ($string =~ m{\G # last match
46             (?.*?) # something not greedy, even nothing
47             (?
48             (?^\{\{\{ \x{20}*?\n .*? \n\}\}\}\n) |
49             (?^\\x{20}*?\n .*? \n\\n) |
50             (? \n\n+?) |
51             (? \ .*? \<\/verbatim\> ) |
52             (? \ .*? \<\/code\> ) |
53             (? (?
54             )}gcxms) {
55 9     9   4690 my %captures = %+;
  9         4031  
  9         2516  
  2336         23876  
56 2336 100       8798 if (length($captures{text})) {
57 2188         7398 my @lines = split(/(\n)/, $captures{text});
58 2188         4149 push @list, map { +{ type => 'text', string => $_ } } grep { length($_) } @lines;
  4932         15572  
  5016         9390  
59             }
60             push @list, {
61             type => 'markup',
62             string => $captures{markup},
63 2336         6719 };
64 2336         38143 $last_position = pos($string);
65             }
66 109         376 my $last_chunk = substr $string, $last_position;
67 109 100       318 if (length($last_chunk)) {
68 96         527 my @lines = split(/(\n)/, $last_chunk);
69 96         219 push @list, map { +{ type => 'text', string => $_ } } grep { length($_) } @lines;
  400         1147  
  446         819  
70             }
71 109         303 my $full = join('', map { $_->{string} } @list);
  7668         14035  
72 109 50       640 die "Chunks lost during processing <$string> vs. <$full>" unless $string eq $full;
73 109         888 return @list;
74             }
75              
76             1;