File Coverage

blib/lib/Text/APL/Parser.pm
Criterion Covered Total %
statement 64 64 100.0
branch 28 28 100.0
condition 11 15 73.3
subroutine 9 9 100.0
pod 1 1 100.0
total 113 117 96.5


line stmt bran cond sub pod time code
1             package Text::APL::Parser;
2              
3 3     3   51672 use strict;
  3         11  
  3         84  
4 3     3   15 use warnings;
  3         11  
  3         79  
5              
6 3     3   16 use base 'Text::APL::Base';
  3         4  
  3         1786  
7              
8             sub _BUILD {
9 37     37   42 my $self = shift;
10              
11 37   50     135 $self->{start_token} ||= '<%';
12 37   50     114 $self->{end_token} ||= '%>';
13              
14 37   50     119 $self->{line_token} ||= '%';
15              
16 37         52 $self->{leftover_token} = $self->_build_leftover_pattern;
17              
18 37         65 return $self;
19             }
20              
21             sub parse {
22 63     63 1 105 my $self = shift;
23 63         85 my ($input) = @_;
24              
25 63         203 my $TOKEN_START = qr/$self->{start_token}/;
26 63         156 my $TOKEN_END = qr/$self->{end_token}/;
27 63         223 my $TOKEN = qr/$TOKEN_START(==?)? [ ] (.*?) \s* $TOKEN_END/xms;
28              
29 63         178 my $LINE_TOKEN_START = qr/^ \s* $self->{line_token} /xms;
30 63         202 my $LINE_TOKEN = qr/$LINE_TOKEN_START(==?)? \s* ([^\n]*)/xms;
31              
32 63         94 my $LEFTOVER_TOKEN = $self->{leftover_token};
33              
34 63 100       107 if (!defined $input) {
35 24 100       68 return [] unless defined $self->{buffer};
36              
37 12         20 my $buffer = delete $self->{buffer};
38 12 100       82 return [$buffer =~ m/$LINE_TOKEN/xms
39             ? $self->_build_line_token($1, $2)
40             : $self->_build_text($buffer)
41             ];
42             }
43              
44 39 100       73 if (defined $self->{buffer}) {
45 2         4 $input = delete($self->{buffer}) . $input;
46             }
47              
48 39         51 my $tape = [];
49              
50 39         88 pos $input = 0;
51 39         95 while (pos $input < length $input) {
52 62 100       584 if ($input =~ m/\G $TOKEN/gcxms) {
    100          
    100          
53 16         36 push @$tape, $self->_build_token($1, $2);
54             }
55             elsif ($input =~ m/\G $LINE_TOKEN \n/gcxms) {
56 14         29 push @$tape, $self->_build_line_token($1, $2);
57             }
58             elsif ($input =~ m/\G (.+?) (?=$TOKEN_START | $LINE_TOKEN_START)/gcxms) {
59 11         21 push @$tape, $self->_build_text($1);
60             }
61             else {
62 21 100       144 if ($input =~ m/( (?:$TOKEN_START | $LINE_TOKEN_START) .* )/gcxms) {
    100          
63 13         32 $self->{buffer} = $1;
64             }
65             elsif ($input =~ m/( $LEFTOVER_TOKEN ) $/gcxms) {
66 1         3 $self->{buffer} = $1;
67             }
68              
69 21         37 my $value = substr($input, pos($input));
70              
71 21 100 66     65 if (defined $value && $value ne '') {
72 7         16 push @$tape, $self->_build_text($value);
73             }
74              
75 21         41 last;
76             }
77             }
78              
79 39         221 $tape;
80             }
81              
82             sub _build_token {
83 16     16   19 my $self = shift;
84 16         40 my ($modifier, $value) = @_;
85              
86 16 100       48 my $token = {type => defined $modifier ? 'expr' : 'exec', value => $value};
87 16 100 100     60 $token->{as_is} = 1 if defined $modifier && length $modifier == 2;
88              
89 16         66 return $token;
90             }
91              
92             sub _build_line_token {
93 23     23   52 my $self = shift;
94 23         55 my ($modifier, $value) = @_;
95              
96 23 100       69 my $token = {type => defined $modifier ? 'expr' : 'exec', value => $value, line => 1};
97 23 100 100     61 $token->{as_is} = 1 if defined $modifier && length $modifier == 2;
98              
99 23         71 return $token;
100             }
101              
102             sub _build_text {
103 21     21   24 my $self =shift;
104 21         41 my ($value) = @_;
105              
106 21         77 return {type => 'text', value => $value};
107             }
108              
109             sub _build_leftover_pattern {
110 37     37   41 my $self = shift;
111              
112 37         91 my @token = split //, $self->{start_token};
113              
114 37         45 my $pattern = '';
115 37         99 $pattern .= '(?:' . $_ for @token;
116 37         56 $pattern .= ')?' for @token;
117 37         178 $pattern =~ s{\?$}{};
118              
119 37         164 return qr/$pattern/;
120             }
121              
122             1;
123             __END__