File Coverage

blib/lib/Text/Shorten.pm
Criterion Covered Total %
statement 15 186 8.0
branch 0 104 0.0
condition 0 116 0.0
subroutine 5 8 62.5
pod 3 3 100.0
total 23 417 5.5


line stmt bran cond sub pod time code
1             package Text::Shorten;
2              
3 16     16   76 use warnings;
  16         23  
  16         364  
4 16     16   52 use strict;
  16         25  
  16         207  
5 16     16   51 use Hash::SafeKeys;
  16         26  
  16         626  
6 16     16   65 use Exporter;
  16         20  
  16         4392  
7             our @ISA = qw(Exporter);
8             our @EXPORT = qw();
9             our @EXPORT_OK = qw(shorten_scalar shorten_array shorten_hash);
10             our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);
11             our $VERSION = '0.08';
12              
13             our $DOTDOTDOT = '...';
14             our $DOTDOTDOT_LENGTH = length($DOTDOTDOT);
15             our $DEFAULT_ARRAY_ELEM_SEPARATOR_LENGTH = 1;
16             our $DEFAULT_HASH_ELEM_SEPARATOR_LENGTH = 1;
17             our $DEFAULT_HASH_KEYVALUE_SEPARATOR_LENGTH = 2;
18             our $HASHREPR_SORTKEYS;
19              
20             sub shorten_scalar {
21 0     0 1   my ($scalar, $maxlen) = @_;
22              
23 0 0         return $scalar if length($scalar) < $maxlen;
24              
25 0 0 0       if ($scalar =~ /^['"]./ # "']/
26             && substr($scalar,0,1) eq substr($scalar,-1)) {
27              
28 0           return substr($scalar,0,$maxlen-$DOTDOTDOT_LENGTH-1)
29             . $DOTDOTDOT . substr($scalar,-1);
30              
31             }
32              
33 0           my ($sign,$d1,$d,$d2,$e,$exp) =
34             $scalar =~ /^\s* ([+-]?)
35             (\d*)
36             (\.?)
37             (\d*)
38             ([Ee]?)
39             ([+-]?\d+)? \s*$/x;
40              
41             {
42 16     16   96 no warnings 'uninitialized';
  16         23  
  16         20378  
  0            
43 0 0         if ("$d1$d2" eq "") {
44             # not a number.
45              
46 0           return substr($scalar, 0, $maxlen-$DOTDOTDOT_LENGTH) . $DOTDOTDOT;
47             }
48             }
49              
50             # the rest of this function is strategies for making a number shorter.
51             # We may lose precision but we won't need to use $DOTDOTDOT
52              
53 0   0       $sign ||= '';
54 0   0       $d1 ||= '0';
55 0 0         $d2 = '' if not defined $d2;
56 0   0       $e ||= '';
57 0 0         $exp = '' if not defined $exp;
58 0   0       my $E = $e || 'e';
59              
60 0 0         $exp =~ s/^\+// if length("$sign$d1$d$d2$e$exp") > $maxlen;
61 0 0         $d1 =~ s/^0+(.)/$1/ if length("$sign$d1$d$d2$e$exp") > $maxlen;
62 0 0         $d2 =~ s/(.)0+$/$1/ if length("$sign$d1$d2$e$exp") > $maxlen;
63 0 0         $exp =~ s/^(\-?)0+(.)/$1$2/ if length("$sign$d1$d$d2$exp") > $maxlen;
64 0 0         $sign =~ s/^\+// if length("$sign$d1$d$d2$e$exp") > $maxlen;
65              
66 0           my $lastc = 0;
67 0           while (length("$sign$d1$d$d2$e$exp") > $maxlen) {
68              
69 0 0 0       if ($d && $d2 eq '') { # 1.E23 => 1E23
70 0           $d = '';
71 0   0       $d1 ||= '0';
72 0           next;
73             }
74              
75 0 0 0       if ($e && ($exp eq '' || $exp==0)) { # 4.567E0 => 4.567
      0        
76 0           $e = $exp = '';
77 0           next;
78             }
79              
80 0 0 0       if (($d1 eq '' || $d1 == 0) && $d2 ne '') {
      0        
81 0           $d1=0;
82 0   0       while ($d1 == 0 && $d2 ne '') { # 0.123 => 1.23,
83             # 0.0004E-5 => 0.004E-6
84 0           $d1 = substr($d2,0,1);
85 0           $d2 = substr($d2,1);
86 0   0       $e ||= $E;
87 0           $exp--;
88             }
89 0           next;
90             }
91              
92 0 0 0       if ($e eq '' && $d2 ne '') {
93             # start truncating digits
94 0           my $c = chop $d2;
95 0 0 0       if ($c > 5 || ($c == 5 && $lastc)) {
      0        
96 0           my $new_d2 = $d2;
97 0           $lastc = 0;
98 0 0         if (length($new_d2) > length($d2)) {
99 0           $d1++;
100 0           $d2 = substr($new_d2,1);
101             }
102             } else {
103 0           $lastc = 1;
104             }
105 0           next;
106             }
107              
108 0 0 0       if ($d eq '' && $d2 eq '') {
109             # start truncating digits and increment exp
110 0           my $c = chop $d1;
111 0 0 0       if ($c > 5 || ($c==5 && $lastc)) {
      0        
112 0           $lastc = 0;
113 0           $d1++;
114             } else {
115 0           $lastc = 1;
116             }
117 0   0       $e ||= $E;
118 0           $exp++;
119 0           next;
120             }
121              
122 0 0         if ($d2 ne '') {
123             # start truncating digits
124 0           my $c = chop $d2;
125 0 0 0       if ($c > 5 || ($c == 5 && $lastc)) {
      0        
126 0           my $new_d2 = $d2;
127 0           $lastc = 0;
128 0 0         if (length($new_d2) > length($d2)) {
129 0           $d1++;
130 0           $d2 = substr($new_d2,1);
131             }
132             } else {
133 0           $lastc = 1;
134             }
135 0           next;
136             }
137             }
138              
139 0 0         $d = '' if $d2 eq '';
140 0   0       while ($e && $d && $d1 ne '' && $d1 > 9) { # 98.7E6 => 9.87E7
      0        
      0        
141 0           $d2 = chop($d1) . $d2;
142 0           $d = '.';
143 0           $exp++;
144             }
145 0 0         $d = '' if $d2 eq '';
146 0           return "$sign$d1$d$d2$e$exp";
147             }
148              
149             # XXX - do we want to make it configurable whether shorten_array
150             # always returns at least one full element?
151              
152             sub shorten_array {
153 0     0 1   my ($array, $maxlen, $seplen, @key) = @_;
154 0 0         if (!defined($seplen)) {
    0          
155 0           $seplen = $DEFAULT_ARRAY_ELEM_SEPARATOR_LENGTH;
156             } elsif ($seplen =~ /\D/) {
157 0           $seplen = length($seplen);
158             }
159 0           my $dotslen = $seplen + $DOTDOTDOT_LENGTH;
160              
161 0           my $n = $#{$array} + 1;
  0            
162 0 0         @key = (0) if @key == 0;
163 0 0         @key = sort {$a <=> $b} grep { $_ >= 0 && $_ < $n } @key;
  0            
  0            
164 0           my @inc = (0) x $n;
165              
166 0 0         my $len = $n > 0 ? $dotslen - 1 : 0;
167 0 0 0       if (@key > 1 || (@key == 1 && $key[0] != 0)) {
      0        
168              
169 0           my @prio = (0) x $n;
170             # "prioritize" elements for display, giving preference to
171             # key items
172             # items between key items
173             # the first item
174             # the last item
175 0 0         if ($n > 0) {
176 0           $prio[$_] = 8 for @key;
177 0           $prio[$_] += 4 for $key[0]..$key[-1];
178             }
179 0           $prio[0] += 2;
180              
181 0           my $insert_fails = 0;
182 0 0         for my $i ( sort { $prio[$b] <=> $prio[$a] || $a <=> $b } 0..$n-1) {
  0            
183 0 0 0       last if $prio[$i] < 8 && $len > $maxlen;
184              
185             # what are the consequences of including $array->[$i] in the output?
186             #
187             # if none of $array->[$i]'s neighbors are excluded:
188             # then we lose $dotslen and add length of $array->[$i]
189             # [ a , ... , c ] ==> [ a , b , c ]
190             #
191             # if one of $array->[$i]'s neighbors are excluded:
192             # then we add $array->[$i]
193             # [ a , ... ] => [ a , b , ... ]
194             # [ ... , c ] => [ ... , b , c ]
195             # [ edge ... ] => [ edge a , ... ]
196             #
197             # if two of $array->[$i]'s neighbors are excluded
198             # then we gain $dotslen + $array->[$i]
199             # [ ... ] => [ ... , a , ... ]
200              
201 0   0       my $excl = ($i>0 && !$inc[$i-1]) + ($i<$n-1 && !$inc[$i+1]) + 0;
      0        
202 0   0       my $dlen = defined($array->[$i])&&length($array->[$i])
203             + $seplen + $dotslen * ($excl - 1);
204 0 0 0       if ($prio[$i] >= 8 || $len + $dlen <= $maxlen) {
205 0           $inc[$i] = 1;
206 0           $len += $dlen;
207 0           $insert_fails = 0;
208             } else {
209              
210             # for very large arrays, don't keep trying to squeeze
211             # that last element in when there is a low probability
212             # that it will work ...
213              
214 0 0         last if ++$insert_fails > 20;
215             }
216             }
217              
218             } else {
219              
220             # don't need to sort, don't need to check $prio[$i]
221 0           my $insert_fails = 0;
222 0           for my $i (0 .. $n-1) {
223 0 0         last if $len > $maxlen;
224 0   0       my $excl = ($i>0 && !$inc[$i-1]) + ($i<$n-1 && !$inc[$i+1]) + 0;
      0        
225 0   0       my $dlen = defined($array->[$i]) && length($array->[$i])
226             + $seplen + $dotslen * ($excl - 1);
227 0 0         if ($len + $dlen <= $maxlen) {
228 0           $inc[$i] = 1;
229 0           $len += $dlen;
230             } else {
231 0 0         last if ++$insert_fails > 100;
232             }
233             }
234             }
235              
236             # construct array, including elements in @inc
237 0           my @result = ();
238 0           my @explicit = grep $inc[$_], 0..$#inc;
239 0           my $i = 0;
240 0           while (@explicit) {
241 0 0         if ($i < $explicit[0]) {
242 0           push @result, $DOTDOTDOT;
243             }
244 0           $i = shift @explicit;
245 0           push @result, $array->[$i];
246 0           $i++;
247             }
248 0 0         if ($i < $n) {
249 0           push @result, $DOTDOTDOT;
250             }
251 0           return @result;
252             }
253              
254             sub shorten_hash {
255 0     0 1   my ($hash, $maxlen, $sep1, $sep2, @key) = @_;
256              
257 0 0         if (!defined($sep1)) {
    0          
258 0           $sep1 = $DEFAULT_HASH_ELEM_SEPARATOR_LENGTH;
259             } elsif ($sep1 =~ /\D/) {
260 0           $sep1 = length($sep1);
261             }
262 0 0         if (!defined($sep2)) {
    0          
263 0           $sep2 = $DEFAULT_HASH_KEYVALUE_SEPARATOR_LENGTH;
264             } elsif ($sep2 =~ /\D/) {
265 0           $sep2 = length($sep2);
266             }
267              
268             # save iterator in case we are already inside each %$hash
269 0           my $it = Hash::SafeKeys::save_iterator_state($hash);
270              
271             # performance is greatly improved in v0.07 as we avoid calling
272             # keys %$hash in list context on a possibly large hash
273              
274 0           my $total_len = -$sep1 + ($sep1+$sep2) * keys %$hash;
275 0           while (my ($k,$v) = each %$hash) {
276 0           $total_len += length($k) + length($v);
277 0 0         last if $total_len > $maxlen;
278             }
279 0 0         if ($total_len <= $maxlen) {
280             # ok to include all elements
281 0           my @all_elements = map { [ $_ , $hash->{$_} ] } keys %$hash;
  0            
282 0           Hash::SafeKeys::restore_iterator_state($hash,$it);
283 0           return @all_elements;
284             }
285              
286 0           my @hashkeys = ();
287 0           my $hk1 = {};
288 0           my $hk1_skip_key = 0;
289 0           my %key;
290 0 0 0       if (@key > 0) {
    0          
291 0           %key = map { $_ => 1 } @key;
  0            
292 0 0         if (100 > keys %$hash) {
293             @hashkeys = sort {
294 0 0 0       ($key{$b}||0) <=> ($key{$a}||0) || $a cmp $b
  0   0        
295             } keys %$hash;
296             } else {
297 0           @hashkeys = grep { defined $key{$_} } @key;
  0            
298 0           $hk1 = $hash;
299 0           $hk1_skip_key = 1;
300             }
301             } elsif (100 > keys %$hash || $HASHREPR_SORTKEYS) {
302 0           @hashkeys = sort keys %$hash;
303             } else {
304 0           $hk1 = $hash;
305             }
306              
307 0           my $len = 3;
308 0           my @r;
309 0           foreach my $key (@hashkeys) {
310 0           my $dlen = $sep1 + $sep2 + length($key) + length($hash->{$key});
311 0 0 0       last if @r > 0 && $len + $dlen > $maxlen;
312 0           push @r, [ $key, $hash->{$key} ];
313 0           $len += $dlen;
314             }
315 0           while (my ($key,$val) = each %$hk1) {
316 0 0 0       next if $hk1_skip_key && defined($key{$key});
317 0           my $dlen = $sep1 + $sep2 + length($key) + length($val);
318 0 0 0       last if @r > 0 && $len + $dlen > $maxlen;
319 0           push @r, [ $key, $val ];
320 0           $len += $dlen;
321             }
322 0           Hash::SafeKeys::restore_iterator_state($hash, $it);
323 0           return @r, [ $DOTDOTDOT ];
324             }
325              
326             1;
327              
328             __END__