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