File Coverage

blib/lib/DTL/Fast/Entity.pm
Criterion Covered Total %
statement 57 57 100.0
branch 6 8 75.0
condition 11 22 50.0
subroutine 11 11 100.0
pod 0 6 0.0
total 85 104 81.7


line stmt bran cond sub pod time code
1             package DTL::Fast::Entity;
2 98     98   59638 use strict; use utf8; use warnings FATAL => 'all';
  98     98   178  
  98     98   4570  
  98         1589  
  98         1276  
  98         1583  
  98         2488  
  98         1240  
  98         8354  
3             # prototype for template entity. Handling current line and current template references
4              
5 98     98   1639 use Scalar::Util qw(weaken);
  98         1275  
  98         11520  
6 98     98   2731 use Carp qw(confess);
  98         202  
  98         102121  
7              
8             sub new
9             {
10 8071     8071 0 25354 my( $proto, %kwargs ) = @_;
11              
12 8071   33     27934 $proto = ref $proto || $proto;
13            
14 8071   66     88847 $DTL::Fast::Template::CURRENT_TEMPLATE->{'modules'}->{$proto} = $proto->VERSION // DTL::Fast->VERSION;
15            
16 8071         42306 my $self = bless {%kwargs}, $proto;
17              
18 8071         23172 $self->remember_template;
19              
20 8071         32758 return $self;
21             }
22              
23             sub remember_template
24             {
25 7109     7109 0 10149 my ($self) = @_;
26            
27 7109         14165 $self->{'_template'} = $DTL::Fast::Template::CURRENT_TEMPLATE;
28 7109         11238 $self->{'_template_line'} = $DTL::Fast::Template::CURRENT_TEMPLATE_LINE;
29 7109         16246 weaken $self->{'_template'};
30              
31 7109         10489 return $self;
32             }
33              
34             sub get_parse_error
35             {
36 18     18 0 51 my ($self, $message, @messages) = @_;
37            
38             return $self->compile_error_message(
39             'Parsing error' => $message // 'undef'
40 18   50     145 , 'Template' => $DTL::Fast::Template::CURRENT_TEMPLATE->{'file_path'}
41             , 'Line' => $DTL::Fast::Template::CURRENT_TEMPLATE_LINE
42             , @messages
43             );
44             }
45              
46             sub get_parse_warning
47             {
48 12     12 0 89 my ($self, $message, @messages) = @_;
49            
50             return $self->compile_error_message(
51             'Parsing warning' => $message // 'undef'
52 12   50     157 , 'Template' => $DTL::Fast::Template::CURRENT_TEMPLATE->{'file_path'}
53             , 'Line' => $DTL::Fast::Template::CURRENT_TEMPLATE_LINE
54             , @messages
55             );
56             }
57              
58             sub get_render_error
59             {
60 12     12 0 29 my ($self, $context, $message, @messages) = @_;
61            
62             my @params = (
63             'Rendering error' => $message // 'undef'
64             , 'Template' => $self->{'_template'}->{'file_path'}
65 12   50     65 , 'Line' => $self->{'_template_line'}
66             , @messages
67             );
68            
69 12 50       45 confess "No context passed for rendering error generator." unless $context;
70            
71 12 100 33     89 if (
      66        
72             exists $context->{'ns'}->[-1]->{'_dtl_include_path'}
73             and ref $context->{'ns'}->[-1]->{'_dtl_include_path'} eq 'ARRAY'
74 12         55 and scalar @{$context->{'ns'}->[-1]->{'_dtl_include_path'}} > 1
75             ) # has inclusions, appending stack trace
76             {
77 2         3 push @params, 'Stack trace' => join( "\n", reverse @{$context->{'ns'}->[-1]->{'_dtl_include_path'}});
  2         8  
78             }
79            
80 12         48 return $self->compile_error_message( @params );
81             }
82              
83             # format error message from key=>val pair
84             sub compile_error_message
85             {
86 42     42 0 130 my ($self, @messages) = @_;
87            
88 42 50       143 die 'Odd parameters in messages array'
89             if scalar(@messages) % 2;
90            
91             # calculating max padding
92 42         74 my $padding = 0;
93 42         138 for( my $i = 0; $i < scalar @messages; $i += 2 )
94             {
95 151         217 my $length = length $messages[$i];
96 151 100       572 $padding = $length if $length > $padding;
97             }
98            
99 42         71 my $result = '';
100 42         159 while ( scalar @messages )
101             {
102 151   50     407 my $key = shift @messages // 'undef';
103 151   50     384 my $value = shift @messages // 'undef';
104              
105 151         243 chomp($value);
106            
107 151         194 my $key_length = length $key;
108            
109 151         542 $result .= sprintf
110             '%s%s: '
111             , ' ' x ($padding - $key_length)
112             , $key;
113            
114 151         427 my @value = split /\n+/, $value;
115 151         283 $result .= shift @value;
116 151         241 $result .= "\n";
117            
118 151         496 foreach my $value (@value)
119             {
120 38         134 $result .= (' ' x ($padding + 2)).$value."\n";
121             }
122             }
123 42         1032 return $result;
124             }
125              
126             1;