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

# Text::Aligner - Align text in columns
package Text::Aligner;
$Text::Aligner::VERSION = '0.16';
use strict;
use warnings;

use 5.008;

BEGIN    {
    use Exporter ();
    use vars qw (@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
    @ISA         = qw (Exporter);
    @EXPORT      = qw ();
    @EXPORT_OK   = qw ( align);
    %EXPORT_TAGS = ();
}

# this is a non-method, and currently the only user interface
sub align ($@) {
    my $ali = Text::Aligner->new( shift);
    $ali->_alloc( map ref eq 'SCALAR' ? $$_ : $_, @_);
    if ( defined wantarray ) {
        my @just = map $ali->_justify( ref eq 'SCALAR' ? $$_ : $_), @_;
        return @just if wantarray;
        return join "\n", @just, '';
    } else {
        for ( @_ ) {
            $_ = $ali->_justify( $_) for ref eq 'SCALAR' ? $$_ : $_; # one-shot
        }
    }
}

### class Text::Aligner

sub _new { # internal constructor
    my $class = shift;
    my ( $width, $pos) = @_; # both method-or-coderef (this is very general)
    bless {
        width => $width,
        pos => $pos,
        left => Text::Aligner::MaxKeeper->new,
        right => Text::Aligner::MaxKeeper->new,
    }, $class;
}

# Construct an aligner
sub new {
    my ( $class, $spec) = @_;
    $spec ||= 0; # left alignment is default
    my $al;
    if ( !ref( $spec) and $spec =~ s/^auto/num/ ) {
        $al = Text::Aligner::Auto->_new( $spec);
    } else {
        $al = $class->_new( _compile_alispec( $spec));
    }
    $al;
}

# return left and right field widths for an object
sub _measure0 {
    my $al = shift;
    my $obj = shift;
    $obj = '' unless defined $obj;
    my ( $w, $p);
    if ( ref $obj ) {
        ( $w, $p) = ( $obj->$al->{ width}->(), $obj->$al->{ pos}->() );
    } else {
        ( $w, $p) = ( $al->{ width}->( $obj), $al->{ pos}->( $obj) );
    }
    $_ ||= 0 for $w, $p;
    ( $p, $w - $p);
}

use Term::ANSIColor 2.02;

# return left and right field widths for an object
sub _measure {
    my $al = shift;
    my $obj = shift;
    $obj = '' unless defined $obj;
    my ( $wmeth, $pmeth) = @{ $al}{ qw( width pos)};

    # support colorized strings
    $obj = Term::ANSIColor::colorstrip($obj) unless ref $obj;

    my $w = ref $wmeth ? $wmeth->( $obj) : $obj->$wmeth;
    my $p = ref $pmeth ? $pmeth->( $obj) : $obj->$pmeth;
    $_ ||= 0 for $w, $p;
    ( $p, $w - $p);
}

# Return left and right maxima, or nothing if the aligner is empty
sub _status {
    my @lr = ( $_[ 0]->{ left}->max, $_[ 0]->{ right}->max);
    # $l and $r should be both defined or undefined, unless the
    # MaxKeeper memory is corrupted by forgetting unremembered things.
    return unless defined( $lr[ 0]) and defined( $lr[ 1]);
    @lr;
}

# remember alignment requirements
sub _alloc {
    my $al = shift;
    for ( @_ ) {
#       $_ ||= ''; print "allocing '$_'\n";
        my ( $l, $r) = $al->_measure( $_);
        $al->{ left}->remember( $l); # space needed left of pos
        $al->{ right}->remember( $r); # ...and right of pos
    }
    $al;
}

# release alignment requirement.  it disturbs an aligner deeply to forget
# things it hasn't remembered.  the effects may be delayed.
sub _forget {
    my $al = shift;
    for ( map defined() ? $_ : '', @_ ) {
#       print "forgetting '$_'\n";
        my ( $l, $r) = $al->_measure( $_);
        $al->{ left}->forget( $l);
        $al->{ right}->forget( $r);
    }
    $al;
}

sub _spaces {
    my ($repeat_count) = @_;
    return (($repeat_count > 0) ? (' ' x $repeat_count) : '');
}

# justify a string.  a string is aligned within the aligner's field, and
# filled with blanks or cut to size, as appropriate.  a string that has
# been allocated will never be trimmed (that is the point of allocation).
# if the aligner is empty it returns the string unaltered.
sub _justify {
    my $al = shift;
    my $str  = shift;
#   print "justifying '$str'\n";
    $str .= ''; # stringify (objects, numbers, undef)
    my ( $l_pad, $r_pad) = $al->_padding( $str);
    substr( $str, 0, -$l_pad) = '' if $l_pad < 0; # trim if negative
    substr( $str, $r_pad) = '' if $r_pad < 0; # ... both ends
    return _spaces($l_pad) . $str . _spaces($r_pad); # pad if positive
}

# return two numbers that indicate how many blanks are needed on each side
# of a string to justify it.  Negative values mean trim that many characters.
# an empty aligner returns ( 0, 0), so doesn't change anything.
sub _padding {
    my $al = shift;
    my $str = shift;
    my ( $this_l, $this_r) = $al->_measure( $str);
    my ( $l_pad, $r_pad) = ( 0, 0);
    if ( $al->_status ) {
        ( $l_pad, $r_pad) = $al->_status;
        $l_pad -= $this_l;
        $r_pad -= $this_r;
    }
    ( $l_pad, $r_pad);
}

# _compile_alispec() returns positioners according to specification.  In
# effect, it is the interpreter for alignment specifications.

sub _compile_alispec { # it's a dirty job...
    my $width = sub { length shift }; # this is always so for string aligners
    my $pos; # the positioner we actually compile
    local $_ = shift || ''; # alignment specification
    if ( ref() eq 'Regexp' ) {
        my $regex = $_; # lexical copy!
        $pos = sub {
            local $_ = shift;
            return m/$regex/ ? $-[ 0] : length; # assume match after string
        };
    } else {
        s/^left/0/;
        s/^center/0.5/;
        s/^right/1/;
        if ( _is_number( $_) ) {
            my $proportion = $_; # use lexical copy
            $pos = sub { int( $proportion*length shift) };
        } elsif ( $_ =~ /^(?:num|point)(?:\((.*))?/ ) {
            my $point = defined $1 ? $1 : '';
            $point =~ s/\)$//; # ignore trailing paren, if present
            length $point or $point = '.';
            $pos = sub { index( shift() . $point, $point) }
        } else {
            $pos = sub { 0 };
        }
    }
    ( $width, $pos);
}

# decide if a string is a number. (see perlfaq4).
sub _is_number {
    my ($x) = @_;
    return 0 unless defined $x;
    return 0 if $x !~ /\d/;
    return 1 if $x =~ /^-?\d+\.?\d*$/;
    $x = Term::ANSIColor::colorstrip($x);
    $x =~ /^-?\d+\.?\d*$/
}

package Text::Aligner::Auto;
# Combined numeric and left alignment.  Numbers are aligned numerically,
# other strings are left-aligned.  The resulting columns are interleaved
# flush left and filled on the right if necessary.
$Text::Aligner::Auto::VERSION = '0.16';
sub _new { # only called by Text::Aligner->new()
    my $class = shift;
    my $numspec = shift; # currently ignored
    bless {
        num => Text::Aligner->new( 'num'),    # align numbers among themselves
        other => Text::Aligner->new,          # left-align anything else
    }, $class;
}

sub _alloc {
    my $aa = shift;
    my @num = grep _is_number( $_), @_;
    my @other = grep !_is_number( $_), @_;
    $aa->{ num}->_alloc( @num);
    $aa->{ other}->_alloc( @other);
    $aa;
}

sub _forget {
    my $aa = shift;
    $aa->{ num}->_forget( grep _is_number( $_), @_);
    $aa->{ other}->_forget( grep !_is_number( $_), @_);
    $aa;
}

# Justify as required
sub _justify {
    my ( $aa, $str) = @_;
    # align according to type
    $str = $aa->{ _is_number( $str) ? 'num' : 'other'}->_justify( $str);
    my $combi = Text::Aligner->new; # left-justify pre-aligned string
    # initialise to size of partial aligners.  (don't initialise from
    # empty aligner)
    $combi->_alloc( $aa->{ num}->_justify( '')) if $aa->{ num}->_status;
    $combi->_alloc( $aa->{ other}->_justify( '')) if $aa->{ other}->_status;
    $combi->_justify( $str);
}

# for convenience
BEGIN { # import _is_number()
    *_is_number = \ &Text::Aligner::_is_number;
}

package Text::Aligner::MaxKeeper;
# Keep the maximum of a dynamic set of numbers.  Optimized for the case of
# a relatively small range of numbers that may occur repeatedly.
$Text::Aligner::MaxKeeper::VERSION = '0.16';
sub new {
    bless {
        max => undef,
        seen => {},
    }, shift;
}

sub max { $_[ 0]->{ max} }

sub remember {
    my ( $mk, $val) = @_;
    _to_max( $mk->{ max}, $val);
    $mk->{ seen}->{ $val}++;
    $mk;
}

sub forget {
    my ( $mk, $val) = @_;
    if ( exists $mk->{ seen}->{ $val} ) {
        my $seen = $mk->{ seen};
        unless ( --$seen->{ $val} ) {
            delete $seen->{ $val};
            if ( $mk->{ max} == $val ) {
                # lost the maximum, recalculate
                undef $mk->{ max};
                _to_max( $mk->{ max}, keys %$seen);
            }
        }
    }
    $mk;
}

sub _to_max {
    my $var = \ shift;
    defined $_ and ( not defined $$var or $$var < $_) and $$var = $_ for @_;
    $$var;
}

1; #this line is important and will help the module return a true value

__END__