File Coverage

blib/lib/DTL/Fast/Filter/Slice.pm
Criterion Covered Total %
statement 62 66 93.9
branch 30 34 88.2
condition 8 13 61.5
subroutine 12 12 100.0
pod 0 7 0.0
total 112 132 84.8


line stmt bran cond sub pod time code
1             package DTL::Fast::Filter::Slice;
2 3     3   2038 use strict; use utf8; use warnings FATAL => 'all';
  3     3   6  
  3     3   132  
  3         15  
  3         5  
  3         19  
  3         81  
  3         6  
  3         107  
3 3     3   15 use parent 'DTL::Fast::Filter';
  3         5  
  3         16  
4              
5             $DTL::Fast::FILTER_HANDLERS{'slice'} = __PACKAGE__;
6              
7 3     3   234 use Scalar::Util qw(reftype);
  3         5  
  3         2914  
8              
9             #@Override
10             sub parse_parameters
11             {
12 24     24 0 39 my $self = shift;
13             die $self->get_parse_error("no slicing settings specified")
14 24 100       28 if not scalar @{$self->{'parameter'}};
  24         75  
15 23         46 $self->{'settings'} = $self->{'parameter'}->[0];
16 23         77 return $self;
17             }
18              
19             #@Override
20             sub filter
21             {
22 26     26 0 43 my ($self, $filter_manager, $value, $context) = @_;
23            
24 26         77 my $settings = $self->{'settings'}->render($context);
25              
26 26 100       63 die $self->get_render_error( $context, 'slicing format is not defined in current context')
27             if not defined $settings;
28            
29 25         62 my $value_type = reftype $value;
30            
31 25 100       78 if ( not defined $value_type )
    100          
    100          
    50          
32             {
33 12 100       29 if ( defined $value )
34             {
35 11         15 eval{
36 11         33 $value = $self->slice_scalar($value, $settings);
37             };
38 11 100       33 die $self->get_render_error($context, $@) if $@;
39             }
40             else
41             {
42 1         9 die $self->get_render_error( $context, 'unable to slice undef value');
43             }
44             }
45             elsif( $value_type eq 'ARRAY' )
46             {
47             eval
48 11         12 {
49 11         27 $value = $self->slice_array($value, $settings);
50             };
51 11 50       25 die $self->get_render_error($context, $@) if $@;
52             }
53             elsif( $value_type eq 'HASH' )
54             {
55 1         3 $value = $self->slice_hash($value, $settings);
56             }
57             elsif( $value_type eq 'SCALAR' )
58             {
59 0         0 $value = $self->slice_scalar($$value, $settings);
60             }
61             else
62             {
63 1   50     10 die $self->get_render_error(
64             $context
65             , sprintf(
66             "can slice only HASH, ARRAY or SCALAR values, not %s (%s)"
67             , $value_type
68             , ref $value || 'SCALAR'
69             )
70             );
71             }
72            
73 22         73 return $value;
74             }
75              
76             sub slice_scalar
77             {
78 11     11 0 18 my ($self, $scalar, $settings ) = @_;
79            
80 11         32 my ($start, $end) = $self->parse_indexes($settings, length($scalar) - 1 );
81            
82 10         37 return substr $scalar, $start, $end - $start + 1;
83             }
84              
85             sub slice_array
86             {
87 11     11 0 17 my ($self, $array, $settings ) = @_;
88            
89 11         26 my ($start, $end) = $self->parse_indexes($settings, $#$array);
90            
91 11         21 return [@{$array}[$start .. $end]];
  11         41  
92             }
93              
94              
95             sub slice_hash
96             {
97 1     1 0 3 my ($self, $hash, $settings) = @_;
98 1         5 return [@{$hash}{(split /\s*,\s*/, $settings)}];
  1         4  
99             }
100              
101             sub parse_indexes
102             {
103 22     22 0 41 my ($self, $settings, $last_index) = @_;
104            
105 22         27 my $start = 0;
106 22         24 my $end;
107            
108 22 100       120 if( $settings =~ /^([-\d]+)?\:([-\d]+)?$/ ) # python's format
    100          
109             {
110 12   66     31 $start = $self->python_index_map($1, $last_index) // $start;
111 12 100       35 $end = defined $2 ?
112             $self->python_index_map($2, $last_index) - 1
113             : $last_index;
114             }
115             elsif( $settings =~ /^([-\d]+)?\s*\.\.\s*([-\d]+)?$/ ) # perl's format
116             {
117 9   66     36 $start = $1 // $start;
118 9   66     34 $end = $2 // $last_index;
119             }
120             else
121             {
122 1   50     13 die sprintf(
123             "array slicing option may be specified in one of the following formats:\npython: [from_index]:[to_index+1]\n perl: [from_index]..[to_index]\ngot `%s` instead.\n"
124             , $settings // undef
125             );
126             }
127              
128 21 50       51 $start = $last_index if $start > $last_index;
129 21 100       46 $end = $last_index if $end > $last_index;
130            
131 21 50       36 if ( $start > $end ) {
132 0         0 my $var = $start;
133 0         0 $start = $end;
134 0         0 $end = $var;
135             }
136            
137 21         56 return ($start, $end);
138             }
139              
140             sub python_index_map
141             {
142 19     19 0 37 my( $self, $pyvalue, $lastindex ) = @_;
143            
144 19 100       55 return $pyvalue if not defined $pyvalue;
145              
146 14 100       57 return $pyvalue < 0 ?
147             $lastindex + $pyvalue + 1
148             : $pyvalue;
149             }
150              
151             1;