File Coverage

lib/Template/VMethods.pm
Criterion Covered Total %
statement 243 253 96.0
branch 83 114 72.8
condition 24 36 66.6
subroutine 70 72 97.2
pod 0 61 0.0
total 420 536 78.3


line stmt bran cond sub pod time code
1             #============================================================= -*-Perl-*-
2             #
3             # Template::VMethods
4             #
5             # DESCRIPTION
6             # Module defining virtual methods for the Template Toolkit
7             #
8             # AUTHOR
9             # Andy Wardley
10             #
11             # COPYRIGHT
12             # Copyright (C) 1996-2006 Andy Wardley. All Rights Reserved.
13             #
14             # This module is free software; you can redistribute it and/or
15             # modify it under the same terms as Perl itself.
16             #
17             # REVISION
18             # $Id$
19             #
20             #============================================================================
21              
22             package Template::VMethods;
23              
24 80     80   649 use strict;
  80         274  
  80         2742  
25 80     80   406 use warnings;
  80         163  
  80         2353  
26 80     80   451 use Scalar::Util qw( blessed looks_like_number );
  80         163  
  80         5460  
27 80     80   6875 use Template::Filters;
  80         166  
  80         58602  
28             require Template::Stash;
29              
30             our $VERSION = 2.16;
31             our $DEBUG = 0 unless defined $DEBUG;
32             our $PRIVATE = $Template::Stash::PRIVATE;
33              
34             our $ROOT_VMETHODS = {
35             inc => \&root_inc,
36             dec => \&root_dec,
37             };
38              
39             our $TEXT_VMETHODS = {
40             item => \&text_item,
41             list => \&text_list,
42             hash => \&text_hash,
43             length => \&text_length,
44             size => \&text_size,
45             defined => \&text_defined,
46             upper => \&text_upper,
47             lower => \&text_lower,
48             ucfirst => \&text_ucfirst,
49             lcfirst => \&text_lcfirst,
50             match => \&text_match,
51             search => \&text_search,
52             repeat => \&text_repeat,
53             replace => \&text_replace,
54             remove => \&text_remove,
55             split => \&text_split,
56             chunk => \&text_chunk,
57             substr => \&text_substr,
58             trim => \&text_trim,
59             collapse => \&text_collapse,
60             squote => \&text_squote,
61             dquote => \&text_dquote,
62             html => \&Template::Filters::html_filter,
63             xml => \&Template::Filters::xml_filter,
64             };
65              
66             our $HASH_VMETHODS = {
67             item => \&hash_item,
68             hash => \&hash_hash,
69             size => \&hash_size,
70             each => \&hash_each,
71             keys => \&hash_keys,
72             values => \&hash_values,
73             items => \&hash_items,
74             pairs => \&hash_pairs,
75             list => \&hash_list,
76             exists => \&hash_exists,
77             defined => \&hash_defined,
78             delete => \&hash_delete,
79             import => \&hash_import,
80             sort => \&hash_sort,
81             nsort => \&hash_nsort,
82             };
83              
84             our $LIST_VMETHODS = {
85             item => \&list_item,
86             list => \&list_list,
87             hash => \&list_hash,
88             push => \&list_push,
89             pop => \&list_pop,
90             unshift => \&list_unshift,
91             shift => \&list_shift,
92             max => \&list_max,
93             size => \&list_size,
94             defined => \&list_defined,
95             first => \&list_first,
96             last => \&list_last,
97             reverse => \&list_reverse,
98             grep => \&list_grep,
99             join => \&list_join,
100             sort => \&list_sort,
101             nsort => \&list_nsort,
102             unique => \&list_unique,
103             import => \&list_import,
104             merge => \&list_merge,
105             slice => \&list_slice,
106             splice => \&list_splice,
107             };
108              
109              
110             #========================================================================
111             # root virtual methods
112             #========================================================================
113              
114             sub root_inc {
115 80     80   598 no warnings;
  80         203  
  80         12345  
116 4     4 0 167 my $item = shift;
117 4         33 ++$item;
118             }
119              
120             sub root_dec {
121 80     80   449 no warnings;
  80         185  
  80         211675  
122 0     0 0 0 my $item = shift;
123 0         0 --$item;
124             }
125              
126              
127             #========================================================================
128             # text virtual methods
129             #========================================================================
130              
131             sub text_item {
132 6     6 0 63 $_[0];
133             }
134              
135             sub text_list {
136 5     5 0 116 [ $_[0] ];
137             }
138              
139             sub text_hash {
140 3     3 0 55 { value => $_[0] };
141             }
142              
143             sub text_length {
144 1     1 0 4 length $_[0];
145             }
146              
147             sub text_size {
148 1     1 0 5 return 1;
149             }
150              
151             sub text_defined {
152 4     4 0 11 return 1;
153             }
154              
155             sub text_upper {
156 1     1 0 6 return uc $_[0];
157             }
158              
159             sub text_lower {
160 2     2 0 10 return lc $_[0];
161             }
162              
163             sub text_ucfirst {
164 3     3 0 16 return ucfirst $_[0];
165             }
166              
167             sub text_lcfirst {
168 2     2 0 8 return lcfirst $_[0];
169             }
170              
171             sub text_trim {
172 1     1 0 4 for ($_[0]) {
173 1         6 s/^\s+//;
174 1         7 s/\s+$//;
175             }
176 1         5 return $_[0];
177             }
178              
179             sub text_collapse {
180 1     1 0 3 for ($_[0]) {
181 1         7 s/^\s+//;
182 1         7 s/\s+$//;
183 1         9 s/\s+/ /g
184             }
185 1         5 return $_[0];
186             }
187              
188             sub text_match {
189 10     10 0 23 my ($str, $search, $global) = @_;
190 10 50 33     86 return $str unless defined $str and defined $search;
191 10 100       248 my @matches = $global ? ($str =~ /$search/g)
192             : ($str =~ /$search/);
193 10 100       55 return @matches ? \@matches : '';
194             }
195              
196             sub text_search {
197 5     5 0 12 my ($str, $pattern) = @_;
198 5 50 33     33 return $str unless defined $str and defined $pattern;
199 5         111 return $str =~ /$pattern/;
200             }
201              
202             sub text_repeat {
203 2     2 0 7 my ($str, $count) = @_;
204 2 50       8 $str = '' unless defined $str;
205 2 50       9 return '' unless $count;
206 2   50     6 $count ||= 1;
207 2         11 return $str x $count;
208             }
209              
210             sub text_replace {
211 25     25 0 56 my ($text, $pattern, $replace, $global) = @_;
212 25 50       60 $text = '' unless defined $text;
213 25 50       64 $pattern = '' unless defined $pattern;
214 25 50       61 $replace = '' unless defined $replace;
215 25 50       64 $global = 1 unless defined $global;
216              
217 25 100       109 if ($replace =~ /\$\d+/) {
218             # replacement string may contain backrefs
219             my $expand = sub {
220 35     35   67 my ($chunk, $start, $end) = @_;
221 35         209 $chunk =~ s{ \\(\\|\$) | \$ (\d+) }{
222 66 100 100     814 $1 ? $1
    100          
223             : ($2 > $#$start || $2 == 0 || !defined $start->[$2]) ? ''
224             : substr($text, $start->[$2], $end->[$2] - $start->[$2]);
225             }exg;
226 35         201 $chunk;
227 17         96 };
228 17 50       48 if ($global) {
229 17         388 $text =~ s{$pattern}{ &$expand($replace, [@-], [@+]) }eg;
  35         298  
230             }
231             else {
232 0         0 $text =~ s{$pattern}{ &$expand($replace, [@-], [@+]) }e;
  0         0  
233             }
234             }
235             else {
236 8 50       22 if ($global) {
237 8         176 $text =~ s/$pattern/$replace/g;
238             }
239             else {
240 0         0 $text =~ s/$pattern/$replace/;
241             }
242             }
243 25         167 return $text;
244             }
245              
246             sub text_remove {
247 1     1 0 3 my ($str, $search) = @_;
248 1 50 33     10 return $str unless defined $str and defined $search;
249 1         23 $str =~ s/$search//g;
250 1         4 return $str;
251             }
252              
253             sub text_split {
254 11     11 0 128 my ($str, $split, $limit) = @_;
255 11 50       38 $str = '' unless defined $str;
256              
257             # For versions of Perl prior to 5.18 we have to be very careful about
258             # spelling out each possible combination of arguments because split()
259             # is very sensitive to them, for example C behaves
260             # differently to C<$space=' '; split($space, ...)>. Test 33 of
261             # vmethods/text.t depends on this behaviour.
262              
263 11 50       48 if ($] < 5.018) {
264 0 0       0 if (defined $limit) {
265 0 0       0 return [ defined $split
266             ? split($split, $str, $limit)
267             : split(' ', $str, $limit) ];
268             }
269             else {
270 0 0       0 return [ defined $split
271             ? split($split, $str)
272             : split(' ', $str) ];
273             }
274             }
275              
276             # split's behavior changed in Perl 5.18.0 making this:
277             # C<$space=' '; split($space, ...)>
278             # behave the same as this:
279             # C
280             # qr// behaves the same, so use that for user-defined split.
281              
282 11         20 my $split_re;
283 11 100       34 if (defined $split) {
284 8         14 eval {
285 8         116 $split_re = qr/$split/;
286             };
287             }
288 11 100       40 $split_re = ' ' unless defined $split_re;
289 11   100     63 $limit ||= 0;
290 11         228 return [split($split_re, $str, $limit)];
291             }
292              
293             sub text_chunk {
294 8     8 0 109 my ($string, $size) = @_;
295 8         13 my @list;
296 8   50     24 $size ||= 1;
297 8 100       28 if ($size < 0) {
298             # sexeger! It's faster to reverse the string, search
299             # it from the front and then reverse the output than to
300             # search it from the end, believe it nor not!
301 5         16 $string = reverse $string;
302 5         10 $size = -$size;
303 5         220 unshift(@list, scalar reverse $1)
304             while ($string =~ /((.{$size})|(.+))/g);
305             }
306             else {
307 3         159 push(@list, $1) while ($string =~ /((.{$size})|(.+))/g);
308             }
309 8         72 return \@list;
310             }
311              
312             sub text_substr {
313 11     11 0 28 my ($text, $offset, $length, $replacement) = @_;
314 11   100     47 $offset ||= 0;
315              
316 11 100       30 if(defined $length) {
317 9 100       24 if (defined $replacement) {
318 2         9 substr( $text, $offset, $length, $replacement );
319 2         8 return $text;
320             }
321             else {
322 7         90 return substr( $text, $offset, $length );
323             }
324             }
325             else {
326 2         14 return substr( $text, $offset );
327             }
328             }
329              
330             sub text_squote {
331 1     1 0 4 my $text = shift;
332 1         3 for ($text) {
333 1         319 s/(['\\])/\\$1/g;
334             }
335 1         7 return $text;
336             }
337              
338             sub text_dquote {
339 1     1 0 4 my $text = shift;
340 1         3 for ($text) {
341 1         11 s/(["\\])/\\$1/g;
342 1         5 s/\n/\\n/g;
343             }
344 1         5 return $text;
345             }
346              
347             #========================================================================
348             # hash virtual methods
349             #========================================================================
350              
351              
352             sub hash_item {
353 2     2 0 75 my ($hash, $item) = @_;
354 2 50       10 $item = '' unless defined $item;
355 2 50 33     11 return if $PRIVATE && $item =~ /$PRIVATE/;
356 2         12 $hash->{ $item };
357             }
358              
359             sub hash_hash {
360 0     0 0 0 $_[0];
361             }
362              
363             sub hash_size {
364 1     1 0 4 scalar keys %{$_[0]};
  1         5  
365             }
366              
367             sub hash_each {
368             # this will be changed in TT3 to do what hash_pairs() does
369 1     1 0 3 [ %{ $_[0] } ];
  1         8  
370             }
371              
372             sub hash_keys {
373 6     6 0 8 [ keys %{ $_[0] } ];
  6         35  
374             }
375              
376             sub hash_values {
377 1     1 0 3 [ values %{ $_[0] } ];
  1         6  
378             }
379              
380             sub hash_items {
381 7     7 0 101 [ %{ $_[0] } ];
  7         72  
382             }
383              
384             sub hash_pairs {
385 12         50 [ map {
386 4         32 { key => $_ , value => $_[0]->{ $_ } }
387             }
388 4     4 0 15 sort keys %{ $_[0] }
389             ];
390             }
391              
392             sub hash_list {
393 1     1 0 3 my ($hash, $what) = @_;
394 1   50     7 $what ||= '';
395 2         11 return ($what eq 'keys') ? [ keys %$hash ]
396             : ($what eq 'values') ? [ values %$hash ]
397             : ($what eq 'each') ? [ %$hash ]
398             : # for now we do what pairs does but this will be changed
399             # in TT3 to return [ $hash ] by default
400 1 50       13 [ map { { key => $_ , value => $hash->{ $_ } } }
    50          
    50          
401             sort keys %$hash
402             ];
403             }
404              
405             sub hash_exists {
406 2     2 0 8 exists $_[0]->{ $_[1] };
407             }
408              
409             sub hash_defined {
410             # return the item requested, or 1 if no argument
411             # to indicate that the hash itself is defined
412 5     5 0 7 my $hash = shift;
413 5 100       23 return @_ ? defined $hash->{ $_[0] } : 1;
414             }
415              
416             sub hash_delete {
417 2     2 0 31 my $hash = shift;
418 2         17 delete $hash->{ $_ } for @_;
419             }
420              
421             sub hash_import {
422 19     19 0 210 my ($hash, $imp) = @_;
423 19 100       94 $imp = {} unless ref $imp eq 'HASH';
424 19         77 @$hash{ keys %$imp } = values %$imp;
425 19         159 return '';
426             }
427              
428             sub hash_sort {
429 1     1 0 4 my ($hash) = @_;
430 1         9 [ sort { lc $hash->{$a} cmp lc $hash->{$b} } (keys %$hash) ];
  3         13  
431             }
432              
433             sub hash_nsort {
434 1     1 0 2 my ($hash) = @_;
435 1         11 [ sort { $hash->{$a} <=> $hash->{$b} } (keys %$hash) ];
  3         12  
436             }
437              
438              
439             #========================================================================
440             # list virtual methods
441             #========================================================================
442              
443              
444             sub list_item {
445 8   100 8 0 158 $_[0]->[ $_[1] || 0 ];
446             }
447              
448             sub list_list {
449 2     2 0 47 $_[0];
450             }
451              
452             sub list_hash {
453 5     5 0 39 my $list = shift;
454 5 100       21 if (@_) {
455 2   100     8 my $n = shift || 0;
456 2         4 return { map { ($n++, $_) } @$list };
  8         27  
457             }
458 80     80   660 no warnings;
  80         175  
  80         14046  
459 3         21 return { @$list };
460             }
461              
462             sub list_push {
463 13     13 0 281 my $list = shift;
464 13         45 push(@$list, @_);
465 13         227 return '';
466             }
467              
468             sub list_pop {
469 1     1 0 21 my $list = shift;
470 1         5 pop(@$list);
471             }
472              
473             sub list_unshift {
474 1     1 0 27 my $list = shift;
475 1         3 unshift(@$list, @_);
476 1         5 return '';
477             }
478              
479             sub list_shift {
480 2     2 0 89 my $list = shift;
481 2         9 shift(@$list);
482             }
483              
484             sub list_max {
485 80     80   470 no warnings;
  80         174  
  80         4551  
486 1     1 0 3 my $list = shift;
487 1         5 $#$list;
488             }
489              
490             sub list_size {
491 80     80   633 no warnings;
  80         174  
  80         100607  
492 4     4 0 10 my $list = shift;
493 4         15 $#$list + 1;
494             }
495              
496             sub list_defined {
497             # return the item requested, or 1 if no argument to
498             # indicate that the hash itself is defined
499 4     4 0 6 my $list = shift;
500 4 100       14 return 1 unless @_; # list.defined is always true
501 3 100       17 return unless looks_like_number $_[0]; # list.defined('bah') is always false
502 2         10 return defined $list->[$_[0]]; # list.defined(n)
503             }
504              
505             sub list_first {
506 24     24 0 324 my $list = shift;
507 24 100       158 return $list->[0] unless @_;
508 1         6 return [ @$list[0..$_[0]-1] ];
509             }
510              
511             sub list_last {
512 25     25 0 363 my $list = shift;
513 25 100       184 return $list->[-1] unless @_;
514 1         6 return [ @$list[-$_[0]..-1] ];
515             }
516              
517             sub list_reverse {
518 1     1 0 3 my $list = shift;
519 1         4 [ reverse @$list ];
520             }
521              
522             sub list_grep {
523 2     2 0 41 my ($list, $pattern) = @_;
524 2   50     5 $pattern ||= '';
525 2         61 return [ grep /$pattern/, @$list ];
526             }
527              
528             sub list_join {
529 57     57 0 103 my ($list, $joint) = @_;
530 248 50       679 join(defined $joint ? $joint : ' ',
531 57 100       233 map { defined $_ ? $_ : '' } @$list);
532             }
533              
534             sub _list_sort_make_key {
535 51     51   111 my ($item, $fields) = @_;
536 51         59 my @keys;
537              
538 51 100       158 if (ref($item) eq 'HASH') {
    50          
539 34         48 @keys = map { $item->{ $_ } } @$fields;
  34         117  
540             }
541             elsif (blessed $item) {
542 17 50       29 @keys = map { $item->can($_) ? $item->$_() : $item } @$fields;
  21         143  
543             }
544             else {
545 0         0 @keys = $item;
546             }
547              
548             # ugly hack to generate a single string using a delimiter that is
549             # unlikely (but not impossible) to be found in the wild.
550 51 50       181 return lc join('/*^UNLIKELY^*/', map { defined $_ ? $_ : '' } @keys);
  55         356  
551             }
552              
553             sub list_sort {
554 55     55 0 1210 my ($list, @fields) = @_;
555 55 100       200 return $list unless @$list > 1; # no need to sort 1 item lists
556             return [
557             @fields # Schwartzian Transform
558 46         125 ? map { $_->[0] } # for case insensitivity
  48         103  
559 46         141 sort { $a->[1] cmp $b->[1] }
560 135         512 map { [ $_, _list_sort_make_key($_, \@fields) ] }
561             @$list
562 158         376 : map { $_->[0] }
563 135         534 sort { $a->[1] cmp $b->[1] }
564 52 100       490 map { [ $_, lc $_ ] }
565             @$list,
566             ];
567             }
568              
569             sub list_nsort {
570 6     6 0 63 my ($list, @fields) = @_;
571 6 50       35 return $list unless @$list > 1; # no need to sort 1 item lists
572             return [
573             @fields # Schwartzian Transform
574 5         10 ? map { $_->[0] } # for case insensitivity
  8         16  
575 5         13 sort { $a->[1] <=> $b->[1] }
576 35         190 map { [ $_, _list_sort_make_key($_, \@fields) ] }
577             @$list
578 61         93 : map { $_->[0] }
579 35         147 sort { $a->[1] <=> $b->[1] }
580 6 100       25 map { [ $_, lc $_ ] }
581             @$list,
582             ];
583             }
584              
585             sub list_unique {
586 2     2 0 4 my %u;
587 2         4 [ grep { ++$u{$_} == 1 } @{$_[0]} ];
  20         42  
  2         5  
588             }
589              
590             sub list_import {
591 2     2 0 4 my $list = shift;
592 2 50       19 push(@$list, grep defined, map ref eq 'ARRAY' ? @$_ : undef, @_);
593 2         8 return $list;
594             }
595              
596             sub list_merge {
597 2     2 0 4 my $list = shift;
598 2 50       22 return [ @$list, grep defined, map ref eq 'ARRAY' ? @$_ : undef, @_ ];
599             }
600              
601             sub list_slice {
602 4     4 0 5 my ($list, $from, $to) = @_;
603 4   100     12 $from ||= 0;
604 4 100       10 $to = $#$list unless defined $to;
605 4 100       9 $from += @$list if $from < 0;
606 4 100       7 $to += @$list if $to < 0;
607 4         17 return [ @$list[$from..$to] ];
608             }
609              
610             sub list_splice {
611 7     7 0 16 my ($list, $offset, $length, @replace) = @_;
612 7 100       26 if (@replace) {
    100          
    100          
613             # @replace can contain a list of multiple replace items, or
614             # be a single reference to a list
615 4 100 100     18 @replace = @{ $replace[0] }
  2         5  
616             if @replace == 1 && ref $replace[0] eq 'ARRAY';
617 4         19 return [ splice @$list, $offset, $length, @replace ];
618             }
619             elsif (defined $length) {
620 1         5 return [ splice @$list, $offset, $length ];
621             }
622             elsif (defined $offset) {
623 1         8 return [ splice @$list, $offset ];
624             }
625             else {
626 1         6 return [ splice(@$list) ];
627             }
628             }
629              
630             1;
631              
632             __END__