File Coverage

blib/lib/DTL/Fast.pm
Criterion Covered Total %
statement 116 117 99.1
branch 21 38 55.2
condition 26 64 40.6
subroutine 17 17 100.0
pod 8 9 88.8
total 188 245 76.7


line stmt bran cond sub pod time code
1             package DTL::Fast;
2 98     98   2043837 use strict; use warnings FATAL => 'all';
  98     98   236  
  98         2921  
  98         501  
  98         186  
  98         4113  
3 98     98   498 use Exporter 'import';
  98         179  
  98         3724  
4 98     98   495 use Digest::MD5 qw(md5_hex);
  98         243  
  98         5960  
5              
6 98     98   2137 use 5.010;
  98         332  
7             our $VERSION = '1.622'; # ==> ALSO update the version in the pod text below!
8              
9             # loaded modules
10             our %TAG_HANDLERS;
11             our %FILTER_HANDLERS;
12             our %OPS_HANDLERS;
13              
14             # known but not loaded modules
15             our %KNOWN_TAGS; # plain map tag => module
16             our %KNOWN_SLUGS; # reversed module => tag
17             our %KNOWN_FILTERS; # plain map filter => module
18             our %KNOWN_OPS; # complex map priority => operator => module
19             our %KNOWN_OPS_PLAIN; # plain map operator => module
20             our @OPS_RE = ();
21              
22             # modules hash to avoid duplicating on deserializing
23             our %LOADED_MODULES;
24              
25             require XSLoader;
26             XSLoader::load('DTL::Fast', $VERSION);
27              
28             our $RUNTIME_CACHE;
29              
30             our @EXPORT_OK = qw(
31             count_lines
32             get_template
33             select_template
34             register_tag
35             preload_operators
36             register_operator
37             preload_tags
38             register_filter
39             preload_filters
40             );
41              
42             sub get_template
43             {
44 92     92 1 18983 my( $template_name, %kwargs ) = @_;
45            
46 92 50       221 die "Template name was not specified"
47             if not $template_name;
48              
49             die "Template directories array was not specified"
50             if
51             not defined $kwargs{'dirs'}
52             or ref $kwargs{'dirs'} ne 'ARRAY'
53 92 50 33     574 or not scalar @{$kwargs{'dirs'}}
  92   33     447  
54             ;
55              
56 92         268 my $cache_key = _get_cache_key( $template_name, %kwargs );
57              
58 92         175 my $template;
59              
60 92   66     289 $RUNTIME_CACHE //= DTL::Fast::Cache::Runtime->new();
61              
62 92 100 66     462 if(
63             $kwargs{'no_cache'}
64             or not defined ( $template = $RUNTIME_CACHE->get($cache_key))
65             )
66             {
67 68         174 $template = read_template($template_name, %kwargs );
68            
69 55 100       130 if( defined $template )
70             {
71 53         362 $RUNTIME_CACHE->put($cache_key, $template);
72             }
73             else
74             {
75 2         6 die sprintf( <<'_EOT_', $template_name, join("\n", @{$kwargs{'dirs'}}));
  2         26  
76             Unable to find template %s in directories:
77             %s
78             _EOT_
79             }
80             }
81            
82 77         287 return $template;
83             }
84              
85             sub _get_cache_key
86             {
87 160     160   328 my( $template_name, %kwargs ) = @_;
88            
89             return md5_hex(
90             sprintf( '%s:%s:%s:%s'
91             , __PACKAGE__
92             , $template_name
93 160         357 , join( ',', @{$kwargs{'dirs'}} )
94 160   100     232 , join( ',', @{$kwargs{'ssi_dirs'}//[]})
  160         1454  
95             # shouldn't we pass uri_handler here?
96             )
97             )
98             ;
99             }
100              
101             sub read_template
102             {
103 68     68 0 162 my( $template_name, %kwargs ) = @_;
104            
105 68         88 my $template = undef;
106 68         79 my $template_path = undef;
107              
108             die "Template directories array was not specified"
109             if not defined $kwargs{'dirs'}
110             or not ref $kwargs{'dirs'}
111 68 50 33     380 or not scalar @{$kwargs{'dirs'}}
  68   33     200  
112             ;
113            
114 68         162 my $cache_key = _get_cache_key( $template_name, %kwargs );
115              
116 68 0 33     437 if(
      33        
      33        
      0        
117             $kwargs{'no_cache'}
118             or not exists $kwargs{'cache'}
119             or not $kwargs{'cache'}
120             or not $kwargs{'cache'}->isa('DTL::Fast::Cache')
121             or not defined ($template = $kwargs{'cache'}->get($cache_key))
122             )
123             {
124 68         167 ($template, $template_path) = _read_file($template_name, $kwargs{'dirs'});
125            
126 68 100       202 if( defined $template )
127             {
128 66         137 $kwargs{'file_path'} = $template_path;
129 66         470 $template = DTL::Fast::Template->new( $template, %kwargs);
130            
131             $kwargs{'cache'}->put( $cache_key, $template )
132             if
133             defined $template
134             and exists $kwargs{'cache'}
135             and $kwargs{'cache'}
136 53 0 33     335 and $kwargs{'cache'}->isa('DTL::Fast::Cache')
      33        
      0        
137             ;
138             }
139             }
140            
141 55 100       132 if( defined $template )
142             {
143 53 50       131 $template->{'cache'} = $kwargs{'cache'} if $kwargs{'cache'};
144 53 50       201 $template->{'url_source'} = $kwargs{'url_source'} if $kwargs{'url_source'};
145             }
146            
147 55         179 return $template;
148             }
149              
150             sub _read_file
151             {
152 68     68   108 my $template_name = shift;
153 68         89 my $dirs = shift;
154 68         92 my $template;
155             my $template_path;
156            
157 68         134 foreach my $dir (@$dirs)
158             {
159 73         253 $dir =~ s/[\/\\]+$//xgsi;
160 73         198 $template_path = sprintf '%s/%s', $dir, $template_name;
161 73 50 66     3121 if(
      66        
162             -e $template_path
163             and -f $template_path
164             and -r $template_path
165             )
166             {
167 66         157 $template = __read_file( $template_path );
168 66         140 last;
169             }
170             }
171            
172 68         191 return ($template, $template_path);
173             }
174              
175              
176             sub __read_file
177             {
178 68     68   114 my( $file_name ) = @_;
179 68         84 my $result;
180            
181 68 50       2189 if( open my $IF, '<', $file_name )
182             {
183 68         269 local $/ = undef;
184 68         1646 $result = <$IF>;
185 68         740 close $IF;
186             }
187             else
188             {
189 0         0 die sprintf(
190             'Error opening file %s, %s'
191             , $file_name
192             , $!
193             );
194             }
195 68         289 return $result;
196             }
197              
198             # result should be cached with full list of params
199             sub select_template
200             {
201 2     2 1 8 my( $template_names, %kwargs ) = @_;
202            
203 2 50 33     24 die "First parameter must be a template names array reference"
      33        
204             if(
205             not ref $template_names
206             or ref $template_names ne 'ARRAY'
207             or not scalar @$template_names
208             );
209              
210 2         4 my $result = undef;
211            
212 2         5 foreach my $template_name (@$template_names)
213             {
214 2 50       8 if( ref ( $result = get_template( $template_name, %kwargs )) eq 'DTL::Fast::Template' )
215             {
216 2         4 last;
217             }
218             }
219            
220 2         7 return $result;
221             }
222              
223             # registering tag as known
224             sub register_tag
225             {
226 196     196 1 2443 my( %tags ) = @_;
227            
228 196         1020 while( my( $slug, $module) = each %tags )
229             {
230 2940         5405 $DTL::Fast::KNOWN_TAGS{lc($slug)} = $module;
231 2940         10912 $DTL::Fast::KNOWN_SLUGS{$module} = $slug;
232             }
233            
234 196         856 return;
235             }
236              
237             # registering tag as known
238             sub preload_tags
239             {
240 1     1 1 918 require Module::Load;
241            
242 1         1143 while( my( $keyword, $module) = each %KNOWN_TAGS )
243             {
244 30         90 Module::Load::load($module);
245 30         387 $LOADED_MODULES{$module} = time;
246 30 50 33     288 delete $TAG_HANDLERS{$keyword} if exists $TAG_HANDLERS{$keyword} and $TAG_HANDLERS{$keyword} ne $module;
247             }
248            
249 1         7 return 1;
250             }
251              
252              
253             # registering filter as known
254             sub register_filter
255             {
256 196     196 1 4397 my( %filters ) = @_;
257            
258 196         941 while( my( $slug, $module) = each %filters )
259             {
260 5880         9152 $DTL::Fast::KNOWN_FILTERS{$slug} = $module;
261 5880 50 33     22845 delete $FILTER_HANDLERS{$slug} if exists $FILTER_HANDLERS{$slug} and $FILTER_HANDLERS{$slug} ne $module;
262             }
263            
264 196         1085 return;
265             }
266              
267             sub preload_filters
268             {
269 1     1 1 7 require Module::Load;
270            
271 1         9 while( my( undef, $module) = each %KNOWN_FILTERS )
272             {
273 60         175 Module::Load::load($module);
274 60         1132 $LOADED_MODULES{$module} = time;
275             }
276            
277 1         7 return 1;
278             }
279              
280             # invoke with parameters:
281             #
282             # '=' => [ priority, module ]
283             #
284             sub register_operator
285             {
286 98     98 1 1468 my %ops = @_;
287            
288 98         273 my %recompile = ();
289 98         599 foreach my $operator (keys %ops)
290             {
291 2058         2327 my($priority, $module) = @{$ops{$operator}};
  2058         3724  
292            
293 2058 50       6948 die "Operator priority must be a number from 0 to 8"
294             if $priority !~ /^[012345678]$/;
295            
296 2058   100     6524 $KNOWN_OPS{$priority} //= {};
297 2058         3832 $KNOWN_OPS{$priority}->{$operator} = $module;
298 2058         3178 $recompile{$priority} = 1;
299 2058         3401 $KNOWN_OPS_PLAIN{$operator} = $module;
300 2058 50 33     6055 delete $OPS_HANDLERS{$operator} if exists $OPS_HANDLERS{$operator} and $OPS_HANDLERS{$operator} ne $module;
301             }
302            
303 98         622 foreach my $priority (keys(%recompile))
304             {
305 882         1115 my @ops = sort{ length $b <=> length $a } keys(%{$KNOWN_OPS{$priority}});
  2009         3341  
  882         3266  
306 882         1529 my $ops = join '|', map{ "\Q$_\E" } @ops;
  2058         4717  
307 882         3064 $OPS_RE[$priority] = $ops;
308             }
309             }
310              
311              
312             sub preload_operators
313             {
314 1     1 1 7 require Module::Load;
315            
316 1         9 while( my( undef, $module) = each %KNOWN_OPS_PLAIN )
317             {
318 21         64 Module::Load::load($module);
319 21         543 $LOADED_MODULES{$module} = time;
320             }
321            
322 1         8 return 1;
323             }
324              
325              
326             require DTL::Fast::Template;
327             require DTL::Fast::Cache::Runtime;
328              
329             1;
330              
331             __END__