File Coverage

blib/lib/Text/Aligner.pm
Criterion Covered Total %
statement 150 159 94.3
branch 56 66 84.8
condition 17 23 73.9
subroutine 34 35 97.1
pod 2 2 100.0
total 259 285 90.8


line stmt bran cond sub pod time code
1             # Text::Aligner - Align text in columns
2             package Text::Aligner;
3              
4 2     2   69955 use strict;
  2         57  
  2         55  
5 2     2   10 use warnings;
  2         3  
  2         47  
6              
7 2     2   44 use 5.008;
  2         6  
8              
9             our $VERSION = '0.13';
10              
11             BEGIN {
12 2     2   11 use Exporter ();
  2         3  
  2         63  
13 2     2   11 use vars qw (@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  2         3  
  2         228  
14 2     2   33 @ISA = qw (Exporter);
15 2         5 @EXPORT = qw ();
16 2         5 @EXPORT_OK = qw ( align);
17 2         930 %EXPORT_TAGS = ();
18             }
19              
20             # this is a non-method, and currently the only user interface
21             sub align ($@) {
22 7     7 1 6969 my $ali = Text::Aligner->new( shift);
23 7 100       49 $ali->_alloc( map ref eq 'SCALAR' ? $$_ : $_, @_);
24 7 100       36 if ( defined wantarray ) {
25 4 50       25 my @just = map $ali->_justify( ref eq 'SCALAR' ? $$_ : $_), @_;
26 4 100       34 return @just if wantarray;
27 1         11 return join "\n", @just, '';
28             } else {
29 3         7 for ( @_ ) {
30 8 100       31 $_ = $ali->_justify( $_) for ref eq 'SCALAR' ? $$_ : $_; # one-shot
31             }
32             }
33             }
34              
35             ### class Text::Aligner
36              
37             sub _new { # internal constructor
38 68     68   116 my $class = shift;
39 68         115 my ( $width, $pos) = @_; # both method-or-coderef (this is very general)
40 68         144 bless {
41             width => $width,
42             pos => $pos,
43             left => Text::Aligner::MaxKeeper->new,
44             right => Text::Aligner::MaxKeeper->new,
45             }, $class;
46             }
47              
48             # Construct an aligner
49             sub new {
50 71     71 1 774 my ( $class, $spec) = @_;
51 71   100     251 $spec ||= 0; # left alignment is default
52 71         95 my $al;
53 71 100 66     254 if ( !ref( $spec) and $spec =~ s/^auto/num/ ) {
54 3         15 $al = Text::Aligner::Auto->_new( $spec);
55             } else {
56 68         133 $al = $class->_new( _compile_alispec( $spec));
57             }
58 71         142 $al;
59             }
60              
61             # return left and right field widths for an object
62             sub _measure0 {
63 0     0   0 my $al = shift;
64 0         0 my $obj = shift;
65 0 0       0 $obj = '' unless defined $obj;
66 0         0 my ( $w, $p);
67 0 0       0 if ( ref $obj ) {
68 0         0 ( $w, $p) = ( $obj->$al->{ width}->(), $obj->$al->{ pos}->() );
69             } else {
70 0         0 ( $w, $p) = ( $al->{ width}->( $obj), $al->{ pos}->( $obj) );
71             }
72 0   0     0 $_ ||= 0 for $w, $p;
73 0         0 ( $p, $w - $p);
74             }
75              
76 2     2   1241 use Term::ANSIColor 2.02;
  2         16868  
  2         3036  
77              
78             # return left and right field widths for an object
79             sub _measure {
80 482     482   667 my $al = shift;
81 482         659 my $obj = shift;
82 482 100       942 $obj = '' unless defined $obj;
83 482         661 my ( $wmeth, $pmeth) = @{ $al}{ qw( width pos)};
  482         972  
84              
85             # support colorized strings
86 482 50       1317 $obj = Term::ANSIColor::colorstrip($obj) unless ref $obj;
87              
88 482 50       4909 my $w = ref $wmeth ? $wmeth->( $obj) : $obj->$wmeth;
89 482 50       1002 my $p = ref $pmeth ? $pmeth->( $obj) : $obj->$pmeth;
90 482   100     1843 $_ ||= 0 for $w, $p;
91 482         1165 ( $p, $w - $p);
92             }
93              
94             # Return left and right maxima, or nothing if the aligner is empty
95             sub _status {
96 734     734   1249 my @lr = ( $_[ 0]->{ left}->max, $_[ 0]->{ right}->max);
97             # $l and $r should be both defined or undefined, unless the
98             # MaxKeeper memory is corrupted by forgetting unremembered things.
99 734 100 66     2183 return unless defined( $lr[ 0]) and defined( $lr[ 1]);
100 632         1350 @lr;
101             }
102              
103             # remember alignment requirements
104             sub _alloc {
105 101     101   2278 my $al = shift;
106 101         179 for ( @_ ) {
107             # $_ ||= ''; print "allocing '$_'\n";
108 110         180 my ( $l, $r) = $al->_measure( $_);
109 110         280 $al->{ left}->remember( $l); # space needed left of pos
110 110         205 $al->{ right}->remember( $r); # ...and right of pos
111             }
112 101         155 $al;
113             }
114              
115             # release alignment requirement. it disturbs an aligner deeply to forget
116             # things it hasn't remembered. the effects may be delayed.
117             sub _forget {
118 36     36   24609 my $al = shift;
119 36 50       165 for ( map defined() ? $_ : '', @_ ) {
120             # print "forgetting '$_'\n";
121 30         72 my ( $l, $r) = $al->_measure( $_);
122 30         105 $al->{ left}->forget( $l);
123 30         56 $al->{ right}->forget( $r);
124             }
125 36         79 $al;
126             }
127              
128             sub _spaces {
129 684     684   1012 my ($repeat_count) = @_;
130 684 100       2214 return (($repeat_count > 0) ? (' ' x $repeat_count) : '');
131             }
132              
133             # justify a string. a string is aligned within the aligner's field, and
134             # filled with blanks or cut to size, as appropriate. a string that has
135             # been allocated will never be trimmed (that is the point of allocation).
136             # if the aligner is empty it returns the string unaltered.
137             sub _justify {
138 342     342   134034 my $al = shift;
139 342         492 my $str = shift;
140             # print "justifying '$str'\n";
141 342         522 $str .= ''; # stringify (objects, numbers, undef)
142 342         688 my ( $l_pad, $r_pad) = $al->_padding( $str);
143 342 100       731 substr( $str, 0, -$l_pad) = '' if $l_pad < 0; # trim if negative
144 342 100       621 substr( $str, $r_pad) = '' if $r_pad < 0; # ... both ends
145 342         542 return _spaces($l_pad) . $str . _spaces($r_pad); # pad if positive
146             }
147              
148             # return two numbers that indicate how many blanks are needed on each side
149             # of a string to justify it. Negative values mean trim that many characters.
150             # an empty aligner returns ( 0, 0), so doesn't change anything.
151             sub _padding {
152 342     342   441 my $al = shift;
153 342         486 my $str = shift;
154 342         634 my ( $this_l, $this_r) = $al->_measure( $str);
155 342         583 my ( $l_pad, $r_pad) = ( 0, 0);
156 342 100       614 if ( $al->_status ) {
157 288         515 ( $l_pad, $r_pad) = $al->_status;
158 288         447 $l_pad -= $this_l;
159 288         384 $r_pad -= $this_r;
160             }
161 342         735 ( $l_pad, $r_pad);
162             }
163              
164             # _compile_alispec() returns positioners according to specification. In
165             # effect, it is the interpreter for alignment specifications.
166              
167             sub _compile_alispec { # it's a dirty job...
168 482     482   746 my $width = sub { length shift }; # this is always so for string aligners
  82     82   7113  
169 82         122 my $pos; # the positioner we actually compile
170 82   100     257 local $_ = shift || ''; # alignment specification
171 82 100       178 if ( ref() eq 'Regexp' ) {
172 2         5 my $regex = $_; # lexical copy!
173             $pos = sub {
174 24     24   11340 local $_ = shift;
175 24 100       472 return m/$regex/ ? $-[ 0] : length; # assume match after string
176 2         7 };
177             } else {
178 80         149 s/^left/0/;
179 80         119 s/^center/0.5/;
180 80         120 s/^right/1/;
181 80 100       157 if ( _is_number( $_) ) {
    100          
182 11         24 my $proportion = $_; # use lexical copy
183 11     204   42 $pos = sub { int( $proportion*length shift) };
  204         17223  
184             } elsif ( $_ =~ /^(?:num|point)(?:\((.*))?/ ) {
185 8 100       31 my $point = defined $1 ? $1 : '';
186 8         19 $point =~ s/\)$//; # ignore trailing paren, if present
187 8 100       24 length $point or $point = '.';
188 141     141   11528 $pos = sub { index( shift() . $point, $point) }
189 8         28 } else {
190 61     197   152 $pos = sub { 0 };
  197         279  
191             }
192             }
193 82         244 ( $width, $pos);
194             }
195              
196             # decide if a string is a number. (see perlfaq4).
197             sub _is_number {
198 179     179   3630 my ($x) = @_;
199 179 100       368 return 0 unless defined $x;
200 170 100       657 return 0 if $x !~ /\d/;
201 65 100       335 return 1 if $x =~ /^-?\d+\.?\d*$/;
202 14         31 $x = Term::ANSIColor::colorstrip($x);
203 14         188 $x =~ /^-?\d+\.?\d*$/
204             }
205              
206             package Text::Aligner::Auto;
207             # Combined numeric and left alignment. Numbers are aligned numerically,
208             # other strings are left-aligned. The resulting columns are interleaved
209             # flush left and filled on the right if necessary.
210              
211             sub _new { # only called by Text::Aligner->new()
212 3     3   8 my $class = shift;
213 3         6 my $numspec = shift; # currently ignored
214 3         11 bless {
215             num => Text::Aligner->new( 'num'), # align numbers among themselves
216             other => Text::Aligner->new, # left-align anything else
217             }, $class;
218             }
219              
220             sub _alloc {
221 8     8   530 my $aa = shift;
222 8         18 my @num = grep _is_number( $_), @_;
223 8         18 my @other = grep !_is_number( $_), @_;
224 8         25 $aa->{ num}->_alloc( @num);
225 8         21 $aa->{ other}->_alloc( @other);
226 8         15 $aa;
227             }
228              
229             sub _forget {
230 6     6   6218 my $aa = shift;
231 6         27 $aa->{ num}->_forget( grep _is_number( $_), @_);
232 6         17 $aa->{ other}->_forget( grep !_is_number( $_), @_);
233 6         17 $aa;
234             }
235              
236             # Justify as required
237             sub _justify {
238 52     52   34414 my ( $aa, $str) = @_;
239             # align according to type
240 52 100       124 $str = $aa->{ _is_number( $str) ? 'num' : 'other'}->_justify( $str);
241 52         128 my $combi = Text::Aligner->new; # left-justify pre-aligned string
242             # initialise to size of partial aligners. (don't initialise from
243             # empty aligner)
244 52 100       108 $combi->_alloc( $aa->{ num}->_justify( '')) if $aa->{ num}->_status;
245 52 100       97 $combi->_alloc( $aa->{ other}->_justify( '')) if $aa->{ other}->_status;
246 52         94 $combi->_justify( $str);
247             }
248              
249             # for convenience
250             BEGIN { # import _is_number()
251 2     2   548 *_is_number = \ &Text::Aligner::_is_number;
252             }
253              
254             package Text::Aligner::MaxKeeper;
255             # Keep the maximum of a dynamic set of numbers. Optimized for the case of
256             # a relatively small range of numbers that may occur repeatedly.
257              
258             sub new {
259 137     137   646 bless {
260             max => undef,
261             seen => {},
262             }, shift;
263             }
264              
265 1475     1475   2489 sub max { $_[ 0]->{ max} }
266              
267             sub remember {
268 228     228   366 my ( $mk, $val) = @_;
269 228         482 _to_max( $mk->{ max}, $val);
270 228         468 $mk->{ seen}->{ $val}++;
271 228         330 $mk;
272             }
273              
274             sub forget {
275 65     65   122 my ( $mk, $val) = @_;
276 65 50       169 if ( exists $mk->{ seen}->{ $val} ) {
277 65         102 my $seen = $mk->{ seen};
278 65 100       130 unless ( --$seen->{ $val} ) {
279 63         104 delete $seen->{ $val};
280 63 100       132 if ( $mk->{ max} == $val ) {
281             # lost the maximum, recalculate
282 62         92 undef $mk->{ max};
283 62         134 _to_max( $mk->{ max}, keys %$seen);
284             }
285             }
286             }
287 65         97 $mk;
288             }
289              
290             sub _to_max {
291 290     290   401 my $var = \ shift;
292 290   100     1072 defined $_ and ( not defined $$var or $$var < $_) and $$var = $_ for @_;
      66        
      66        
293 290         436 $$var;
294             }
295              
296             1; #this line is important and will help the module return a true value
297              
298             __END__