1package Text::FormatTable;
2
3use Carp;
4use strict;
5use warnings;
6use vars qw($VERSION);
7
8$VERSION = '1.03';
9
10=head1 NAME
11
12Text::FormatTable - Format text tables
13
14=head1 SYNOPSIS
15
16 my $table = Text::FormatTable->new('r|l');
17 $table->head('a', 'b');
18 $table->rule('=');
19 $table->row('c', 'd');
20 print $table->render(20);
21
22=head1 DESCRIPTION
23
24Text::FormatTable renders simple tables as text. You pass to the constructor
25(I<new>) a table format specification similar to LaTeX (e.g. C<r|l|5l|R|20L>) and you
26call methods to fill the table data and insert rules. After the data is filled,
27you call the I<render> method and the table gets formatted as text.
28
29Methods:
30
31=over 4
32
33=cut
34
35# Remove ANSI color sequences when calculating length
36sub _uncolorized_length($)
37{
38    my $str = shift;
39    $str =~ s/\e \[ [^m]* m//xmsg;
40    return length $str;
41}
42
43# minimal width of $1 if word-wrapped
44sub _min_width($)
45{
46    my $str = shift;
47    my $min;
48    for my $s (split(/\s+/,$str)) {
49        my $l = _uncolorized_length $s;
50        $min = $l if not defined $min or $l > $min;
51    }
52    return $min ? $min : 1;
53}
54
55# width of $1 if not word-wrapped
56sub _max_width($)
57{
58    my $str = shift;
59    my $len = _uncolorized_length $str;
60    return $len ? $len : 1;
61}
62
63sub _max($$)
64{
65    my ($a,$b) = @_;
66    return $a if defined $a and (not defined $b or $a >= $b);
67    return $b;
68}
69
70# word-wrap multi-line $2 with width $1
71sub _wrap($$)
72{
73    my ($width, $text) = @_;
74    my @lines = split(/\n/, $text);
75    my @w = ();
76    for my $l (@lines) {
77        push @w, @{_wrap_line($width, $l)};
78    }
79    return \@w;
80}
81
82sub _wrap_line($$)
83{
84    my ($width, $text) = @_;
85    my $width_m1 = $width-1;
86    my @t = ($text);
87    while(1) {
88        my $t = pop @t;
89        my $l = _uncolorized_length $t;
90        if($l <= $width){
91            # last line is ok => done
92            push @t, $t;
93            return \@t;
94        }
95        elsif($t =~ /^(.{0,$width_m1}\S)\s+(\S.*?)$/) {
96            # farest space < width
97            push @t, $1;
98            push @t, $2;
99        }
100        elsif($t =~ /(.{$width,}?\S)\s+(\S.*?)$/) {
101            # nearest space > width
102            if ( _uncolorized_length $1 > $width_m1  )
103            {
104                # hard hyphanation
105                my $left = substr($1,0,$width);
106                my $right= substr($1,$width);
107
108                push @t, $left;
109                push @t, $right;
110                push @t, $2;
111            }
112            else
113            {
114                push @t, $1;
115                push @t, $2;
116            }
117        }
118        else {
119            # hard hyphanation
120            my $left = substr($t,0,$width);
121            my $right= substr($t,$width);
122
123            push @t, $left;
124            push @t, $right;
125            return \@t;
126        }
127    }
128    return \@t;
129}
130
131# render left-box $2 with width $1
132sub _l_box($$)
133{
134    my ($width, $text) = @_;
135    my $lines = _wrap($width, $text);
136    map { $_ .= ' 'x($width-_uncolorized_length($_)) } @$lines;
137    return $lines;
138}
139
140# render right-box $2 with width $1
141sub _r_box($$)
142{
143    my ($width, $text) = @_;
144    my $lines = _wrap($width, $text);
145    map { $_ = (' 'x($width-_uncolorized_length($_)).$_) } @$lines;
146    return $lines;
147}
148
149# Algorithm of:
150# http://ei5nazha.yz.yamagata-u.ac.jp/~aito/w3m/eng/STORY.html
151
152sub _distribution_f($)
153{
154    my $max_width = shift;
155    return log($max_width);
156}
157
158sub _calculate_widths($$)
159{
160    my ($self, $width) = @_;
161    my @widths = ();
162    # calculate min and max widths for each column
163    for my $r (@{$self->{data}})
164    {
165        $r->[0] eq 'data' or $r->[0] eq 'head' or next;
166        my $cn=0;
167        my ($max, $min) = (0,0);
168
169        for my $c (@{$r->[1]}) {
170
171            if ( $self->{fixed_widths}[$cn] )
172            {
173               # fixed width
174               $widths[$cn][0] = $self->{fixed_widths}[$cn];
175               $widths[$cn][1] = $self->{fixed_widths}[$cn];
176            }
177            else
178            {
179                $widths[$cn][0] = _max($widths[$cn][0], _min_width $c);
180                $widths[$cn][1] = _max($widths[$cn][1], _max_width $c);
181            }
182            $cn++;
183        }
184    }
185
186    # calculate total min and max width
187    my ($total_min, $total_max) = (0,0);
188    for my $c (@widths) {
189        $total_min += $c->[0];
190        $total_max += $c->[1];
191    }
192    # extra space
193    my $extra_width += scalar grep {$_->[0] eq '|' or $_->[0] eq ' '}
194        (@{$self->{format}});
195    $total_min += $extra_width;
196    $total_max += $extra_width;
197
198    # if total_max <= screen width => use max as width
199    if($total_max <= $width) {
200        my $cn = 0;
201        for my $c (@widths) {
202            $self->{widths}[$cn]=$c->[1];
203            $cn++;
204        }
205        $self->{total_width} = $total_max;
206    }
207    else {
208        my @dist_width;
209        ITERATION: while(1) {
210            my $total_f = 0.0;
211            my $fixed_width = 0;
212            my $remaining=0;
213            for my $c (@widths) {
214                if(defined $c->[2]) {
215                    $fixed_width += $c->[2];
216                }
217                else {
218                    $total_f += _distribution_f($c->[1]);
219                    $remaining++;
220                }
221            }
222            my $available_width = $width-$extra_width-$fixed_width;
223            # enlarge width if it isn't enough
224            if($available_width < $remaining*5) {
225                $available_width = $remaining*5;
226                $width = $extra_width+$fixed_width+$available_width;
227            }
228            my $cn=-1;
229            COLUMN: for my $c (@widths) {
230                $cn++;
231                next COLUMN if defined $c->[2]; # skip fixed-widths
232                my $w = _distribution_f($c->[1]) * $available_width / $total_f;
233                if($c->[0] > $w) {
234                    $c->[2] = $c->[0];
235                    next ITERATION;
236                }
237                if($c->[1] < $w) {
238                    $c->[2] = $c->[1];
239                    next ITERATION;
240                }
241                $dist_width[$cn] = int($w);
242            }
243            last;
244        }
245        my $cn = 0;
246        for my $c (@widths) {
247            $self->{widths}[$cn]=defined $c->[2] ? $c->[2] : $dist_width[$cn];
248            $cn++;
249        }
250    }
251}
252
253sub _render_rule($$)
254{
255    my ($self, $char) = @_;
256    my $out = '';
257    my ($col,$data_col) = (0,0);
258    for my $c (@{$self->{format}}) {
259        if($c->[0] eq '|') {
260            if   ($char eq '-') { $out .= '+' }
261            elsif($char eq ' ') { $out .= '|' }
262            else                { $out .= $char }
263        }
264        elsif($c->[0] eq ' ') {
265            $out .= $char;
266        }
267        elsif( $c->[0] eq 'l'
268            or $c->[0] eq 'L'
269            or $c->[0] eq 'r'
270            or $c->[0] eq 'R'
271            ) {
272            $out .= ($char)x($self->{widths}[$data_col]);
273            $data_col++;
274        }
275        $col++;
276    }
277    return $out."\n";
278}
279
280sub _render_data($$)
281{
282    my ($self,$data) = @_;
283
284    my @rdata; # rendered data
285
286    # render every column and find out number of lines
287    my ($col, $data_col) = (0,0);
288    my $lines=0;
289    my @rows_in_column;
290    for my $c (@{$self->{format}}) {
291        if( ($c->[0] eq 'l') or ($c->[0] eq 'L') ) {
292            my $lb = _l_box($self->{widths}[$data_col], $data->[$data_col]);
293            $rdata[$data_col] = $lb;
294            my $l = scalar @$lb ;
295            $lines = $l if $lines < $l;
296            $rows_in_column[$data_col] = $l;
297            $data_col++;
298        }
299        elsif( ($c->[0] eq 'r') or ($c->[0] eq 'R' ) ) {
300            my $rb = _r_box($self->{widths}[$data_col], $data->[$data_col]);
301            $rdata[$data_col] = $rb;
302            my $l = scalar @$rb ;
303            $lines = $l if $lines < $l;
304            $rows_in_column[$data_col] = $l ;
305            $data_col++;
306        }
307        $col++;
308    }
309
310    # render each line
311    my $out = '';
312    for my $l (0..($lines-1)) {
313        my ($col, $data_col) = (0,0);
314        for my $c (@{$self->{format}}) {
315            if($c->[0] eq '|') {
316                $out .= '|';
317            }
318            elsif($c->[0] eq ' ') {
319                $out .= ' ';
320            }
321            elsif( $c->[0] eq 'L' or $c->[0] eq 'R')
322            {
323                # bottom align
324                my $start_print = $lines - $rows_in_column[$data_col];
325
326                if ( defined $rdata[$data_col][$l-$start_print]
327                     and $l >= $start_print
328                    )
329                {
330                    $out .= $rdata[$data_col][$l-$start_print];
331                }
332                else
333                {
334                    $out .= ' 'x($self->{widths}[$data_col]);
335                }
336                $data_col++;
337            }
338            elsif($c->[0] eq 'l' or $c->[0] eq 'r') {
339                # top align
340                if(defined $rdata[$data_col][$l]) {
341                    $out .= $rdata[$data_col][$l];
342                }
343                else {
344                    $out .= ' 'x($self->{widths}[$data_col]);
345                }
346                $data_col++;
347            }
348            $col++;
349        }
350        $out .= "\n";
351    }
352    return $out;
353}
354
355sub _parse_format($$)
356{
357    my ($self, $format) = @_;
358    my @f = split(//, $format);
359    my @format = ();
360    my @width  = ();
361
362    my ($col,$data_col) = (0,0);
363    my $wid;
364    for my $f (@f) {
365        if ( $f =~ /(\d+)/)
366        {
367           $wid .= $f;
368           next;
369        }
370        if($f eq 'l' or $f eq 'L' or $f eq 'r' or $f eq 'R') {
371            $format[$col] = [$f, $data_col];
372            $width[$data_col] = $wid;
373            $wid = undef;
374            $data_col++;
375        }
376        elsif($f eq '|' or $f eq ' ') {
377            $format[$col] = [$f];
378        }
379        else {
380            croak "unknown column format: $f";
381        }
382        $col++;
383    }
384    $self->{format}=\@format;
385    $self->{fixed_widths}=\@width;
386    $self->{col}=$col;
387    $self->{data_col}=$data_col;
388}
389
390=item B<new>(I<$format>)
391
392Create a Text::FormatTable object, the format of each column is specified as a
393character of the $format string. The following formats are defined:
394
395=over 4
396
397=item l
398
399Left-justified top aligned word-wrapped text.
400
401=item L
402
403Left-justified bottom aligned word-wrapped text.
404
405=item r
406
407Right-justified top aligned word-wrapped text.
408
409=item R
410
411Right-justified bottom aligned word-wrapped text.
412
413=item 10R, 20r, 15L, 12l,
414
415Number is fixed width of the column.
416Justified and aligned word-wrapped text (see above).
417
418=item ' '
419
420A space.
421
422=item |
423
424Column separator.
425
426=back
427
428=cut
429
430sub new($$)
431{
432    my ($class, $format) = @_;
433    croak "new() requires one argument: format" unless defined $format;
434    my $self = { col => '0', row => '0', data => [] };
435    bless $self, $class;
436    $self->_parse_format($format);
437    return $self;
438}
439
440# remove head and trail space
441sub _preprocess_row_data($$)
442{
443    my ($self,$data) = @_;
444    my $cn = 0;
445    for my $c (0..($#$data)) {
446        $data->[$c] =~ s/^\s+//m;
447        $data->[$c] =~ s/\s+$//m;
448    }
449}
450
451=item B<head>(I<$col1>, I<$col2>, ...)
452
453Add a header row using $col1, $col2, etc. as cell contents. Note that, at the
454moment, header rows are treated like normal rows.
455
456=cut
457
458sub head($@)
459{
460    my ($self, @data) = @_;
461    scalar @data == $self->{data_col} or
462        croak "number of columns must be $self->{data_col}";
463    $self->_preprocess_row_data(\@data);
464    $self->{data}[$self->{row}++] = ['head', \@data];
465}
466
467=item B<row>(I<$col1>, I<$col2>, ...)
468
469Add a row with $col1, $col2, etc. as cell contents.
470
471=cut
472
473sub row($@)
474{
475    my ($self, @data) = @_;
476    scalar @data == $self->{data_col} or
477        croak "number of columns must be $self->{data_col}";
478
479    $self->_preprocess_row_data(\@data);
480    $self->{data}[$self->{row}++] = ['data', \@data];
481}
482
483=item B<rule>([I<$char>])
484
485Add an horizontal rule. If $char is specified it will be used as character to
486draw the rule, otherwise '-' will be used.
487
488=cut
489
490sub rule($$)
491{
492    my ($self, $char) = @_;
493    $char = '-' unless defined $char;
494    $self->{data}[$self->{row}++] = ['rule', $char];
495}
496
497=item B<render>([I<$screen_width>])
498
499Return the rendered table formatted with $screen_width or 79 if it is not
500specified.
501
502=cut
503
504sub render($$)
505{
506    my ($self, $width) = @_;
507
508    $width = 79 unless defined $width;
509    $self->_calculate_widths($width);
510
511    my $out = '';
512    for my $r (@{$self->{data}}) {
513        if($r->[0] eq 'rule') {
514            $out .= $self->_render_rule($r->[1]);
515        }
516        elsif($r->[0] eq 'head') {
517            $out .= $self->_render_data($r->[1]);
518        }
519        elsif($r->[0] eq 'data') {
520            $out .= $self->_render_data($r->[1]);
521        }
522    }
523    return $out;
524}
525
5261;
527
528=back
529
530=head1 SEE ALSO
531
532Text::ASCIITable
533
534=head1 COPYRIGHT
535
536Copyright (c) 2001-2004 Swiss Federal Institute of Technology, Zurich.
537          (c) 2009 Trey Harris
538All Rights Reserved.
539
540This module is free software; you can redistribute it and/or
541modify it under the same terms as Perl itself.
542
543=head1 CODE REPOSITORY
544
545Git - http://github.com/treyharris/Text-FormatTable/tree/master
546
547=head1 AUTHOR
548
549S<David Schweikert <dws@ee.ethz.ch>>
550
551Maintained by S<Trey Harris <treyharris@gmail.com>>
552
553Fixed column width and bottom alignment written by
554S<Veselin Slavov <vslavov@creditreform.bg>>
555
556=cut
557
558# vi: et sw=4
559