File Coverage

blib/lib/Text/Shorten.pm

Criterion	Covered	Total	%
statement	166	179	92.7
branch	81	102	79.4
condition	81	107	75.7
subroutine	8	8	100.0
pod	3	3	100.0
total	339	399	84.9

package Text::Shorten;

use warnings;
use strict;
use Hash::SafeKeys;
use Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw();
our @EXPORT_OK = qw(shorten_scalar shorten_array shorten_hash);
our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);
our $VERSION = '0.06';

our $DOTDOTDOT = '...';
our $DOTDOTDOT_LENGTH = length($DOTDOTDOT);
our $DEFAULT_ARRAY_ELEM_SEPARATOR_LENGTH = 1;
our $DEFAULT_HASH_ELEM_SEPARATOR_LENGTH = 1;
our $DEFAULT_HASH_KEYVALUE_SEPARATOR_LENGTH = 2;
our $HASHREPR_SORTKEYS;

sub shorten_scalar {
    my ($scalar, $maxlen) = @_;

    return $scalar if length($scalar) < $maxlen;

    if ($scalar =~ /^['"]./                         # "']/
	&& substr($scalar,0,1) eq substr($scalar,-1)) {

	return substr($scalar,0,$maxlen-$DOTDOTDOT_LENGTH-1)
	    . $DOTDOTDOT . substr($scalar,-1);

    }

    my ($sign,$d1,$d,$d2,$e,$exp) =
	$scalar =~ /^\s* ([+-]?)
                     (\d*)
		     (\.?)
		     (\d*)
		     ([Ee]?)
		     ([+-]?\d+)? \s*$/x;

    {
	no warnings 'uninitialized';
	if ("$d1$d2" eq "") {
	    # not a number.

	    return substr($scalar, 0, $maxlen-$DOTDOTDOT_LENGTH) . $DOTDOTDOT;
	}
    }

    # the rest of this function is strategies for making a number shorter.
    # We may lose precision but we won't need to use $DOTDOTDOT

    $sign ||= '';
    $d1 ||= '0';
    $d2 = '' if not defined $d2;
    $e ||= '';
    $exp = '' if not defined $exp;
    my $E = $e || 'e';

    $exp  =~ s/^\+//             if length("$sign$d1$d$d2$e$exp") > $maxlen;
    $d1   =~ s/^0+(.)/$1/        if length("$sign$d1$d$d2$e$exp") > $maxlen;
    $d2   =~ s/(.)0+$/$1/        if length("$sign$d1$d2$e$exp") > $maxlen;
    $exp  =~ s/^(\-?)0+(.)/$1$2/ if length("$sign$d1$d$d2$exp") > $maxlen;
    $sign =~ s/^\+//             if length("$sign$d1$d$d2$e$exp") > $maxlen;

    my $lastc = 0;
    while (length("$sign$d1$d$d2$e$exp") > $maxlen) {

	if ($d && $d2 eq '') {       # 1.E23 => 1E23
	    $d = '';
	    $d1 ||= '0';
	    next;
	}

	if ($e && ($exp eq '' || $exp==0)) {         # 4.567E0 => 4.567
	    $e = $exp = '';
	    next;
	}

	if (($d1 eq '' || $d1 == 0) && $d2 ne '') {
	    $d1=0;
	    while ($d1 == 0 && $d2 ne '') {        # 0.123 => 1.23,
		                                   # 0.0004E-5 => 0.004E-6
		$d1 = substr($d2,0,1);
		$d2 = substr($d2,1);
		$e ||= $E;
		$exp--;
	    }
	    next;
	}

	if ($e eq '' && $d2 ne '') {
	    # start truncating digits
	    my $c = chop $d2;
	    if ($c > 5 || ($c == 5 && $lastc)) {
		my $new_d2 = $d2;
		$lastc = 0;
		if (length($new_d2) > length($d2)) {
		    $d1++;
		    $d2 = substr($new_d2,1);
		}
	    } else {
		$lastc = 1;
	    }
	    next;
	}

	if ($d eq '' && $d2 eq '') {
	    # start truncating digits and increment exp
	    my $c = chop $d1;
	    if ($c > 5 || ($c==5 && $lastc)) {
		$lastc = 0;
		$d1++;
	    } else {
		$lastc = 1;
	    }
	    $e ||= $E;
	    $exp++;
	    next;
	}

	if ($d2 ne '') {
	    # start truncating digits
	    my $c = chop $d2;
	    if ($c > 5 || ($c == 5 && $lastc)) {
		my $new_d2 = $d2;
		$lastc = 0;
		if (length($new_d2) > length($d2)) {
		    $d1++;
		    $d2 = substr($new_d2,1);
		}
	    } else {
		$lastc = 1;
	    }
	    next;
	}
    }

    $d = '' if $d2 eq '';
    while ($e && $d && $d1 ne '' && $d1 > 9) {        # 98.7E6 => 9.87E7
	$d2 = chop($d1) . $d2;
	$d = '.';
	$exp++;
    }
    $d = '' if $d2 eq '';
    return "$sign$d1$d$d2$e$exp";
}

# XXX - do we want to make it configurable whether shorten_array
#       always returns at least one full element?

sub shorten_array {
    my ($array, $maxlen, $seplen, @key) = @_;
    if (!defined($seplen)) {
	$seplen = $DEFAULT_ARRAY_ELEM_SEPARATOR_LENGTH;
    } elsif ($seplen =~ /\D/) {
	$seplen = length($seplen);
    }
    my $dotslen = $seplen + $DOTDOTDOT_LENGTH;

    my $n = $#{$array} + 1;
    @key = (0) if @key == 0;
    @key = sort {$a <=> $b} grep { $_ >= 0 && $_ < $n } @key;
    my @inc = (0) x $n;

    my $len = $n > 0 ? $dotslen - 1 : 0;
    if (@key > 1 || (@key == 1 && $key[0] != 0)) {

	my @prio = (0) x $n;
	# "prioritize" elements for display, giving preference to
	#     key items
	#     items between key items
	#     the first item
	#     the last item
	if ($n > 0) {
	    $prio[$_]  = 8 for @key;
	    $prio[$_] += 4 for $key[0]..$key[-1];
	}
	$prio[0] += 2;

	my $insert_fails = 0;
	for my $i ( sort { $prio[$b] <=> $prio[$a] || $a <=> $b } 0..$n-1) {
	    last if $prio[$i] < 8 && $len > $maxlen;

	    # what are the consequences of including $array->[$i] in the output?
	    #
	    # if none of $array->[$i]'s neighbors are excluded:
	    #      then we lose $dotslen and add length of $array->[$i]
	    #      [   a , ... , c ] ==> [ a , b , c ]
	    #
	    # if one of $array->[$i]'s neighbors are excluded:
	    #      then we add $array->[$i]
	    #      [   a , ... ] => [ a , b , ... ]
	    #      [   ... , c ] => [ ... , b , c ]
	    #      [  edge ... ] => [ edge a , ... ]
	    #
	    # if two of $array->[$i]'s neighbors are excluded
	    #      then we gain $dotslen + $array->[$i]
	    #      [ ... ] => [ ... , a , ... ]

	    my $excl = ($i>0 && !$inc[$i-1]) + ($i<$n-1 && !$inc[$i+1]) + 0;
	    my $dlen = defined($array->[$i])&&length($array->[$i])
		+ $seplen + $dotslen * ($excl - 1);
	    if ($prio[$i] >= 8 || $len + $dlen <= $maxlen) {
		$inc[$i] = 1;
		$len += $dlen;
		$insert_fails = 0;
	    } else {

		# for very large arrays, don't keep trying to squeeze
		# that last element in when there is a low probability
		# that it will work ...

		last if ++$insert_fails > 100;
	    }
	}

    } else {

	# don't need to sort, don't need to check $prio[$i]
	my $insert_fails = 0;
	for my $i (0 .. $n-1) {
	    last if $len > $maxlen;
	    my $excl = ($i>0 && !$inc[$i-1]) + ($i<$n-1 && !$inc[$i+1]) + 0;
	    my $dlen = defined($array->[$i])&&length($array->[$i])
		+ $seplen + $dotslen * ($excl - 1);
	    if ($len + $dlen <= $maxlen) {
		$inc[$i] = 1;
		$len += $dlen;
	    } else {
		last if ++$insert_fails > 100;
	    }
	}
    }

    # construct array, including elements in @inc
    my @result = ();
    my @explicit = grep $inc[$_], 0..$#inc;
    my $i = 0;
    while (@explicit) {
	if ($i < $explicit[0]) {
	    push @result, $DOTDOTDOT;
	}
	$i = shift @explicit;
	push @result, $array->[$i];
	$i++;
    }
    if ($i < $n) {
	push @result, $DOTDOTDOT;
    }
    return @result;
}

sub shorten_hash {
    my ($hash, $maxlen, $sep1, $sep2, @key) = @_;

    if (!defined($sep1)) {
	$sep1 = $DEFAULT_HASH_ELEM_SEPARATOR_LENGTH;
    } elsif ($sep1 =~ /\D/) {
	$sep1 = length($sep1);
    }
    if (!defined($sep2)) {
	$sep2 = $DEFAULT_HASH_KEYVALUE_SEPARATOR_LENGTH;
    } elsif ($sep2 =~ /\D/) {
	$sep2 = length($sep2);
    }

    my $total_len = -$sep1;
    my @safekeys = safekeys %$hash;
    for my $k (@safekeys) {
	$total_len += length($k) + length($hash->{$k}) + $sep1 + $sep2;
	last if $total_len > $maxlen;
    }
    if ($total_len <= $maxlen) {
	# ok to include all elements
	return map { [ $_ , $hash->{$_} ] } @safekeys;
    }

    my @r = ();
    my @hashkeys = ();
    my $hashkey = {};

    if (@key > 0) {
	my %key = map { $_ => 1 } @key;
	if (100 > @safekeys) {
	    @hashkeys = sort {
		($key{$b}||0) <=> ($key{$a}||0)
		    || $a cmp $b
	    } @safekeys;
	} else {
	    @hashkeys = @key = grep { defined $key{$_} } @key;
	    push @hashkeys, grep { !defined $key{$_} } @safekeys;
	}
    } else {
	if (100 > @safekeys) {
	    @hashkeys = sort @safekeys;
	} else {
	    $hashkey = $hash;
	}
    }

    my $len = 3;
    my @sk = safekeys %$hashkey;
    if ($HASHREPR_SORTKEYS) {
	@sk = sort @sk;
    }

    foreach my $key (@hashkeys, @sk) {
	my $dlen = $sep1 + $sep2 + length($key) + length($hash->{$key});
	last if $len + $dlen > $maxlen
	    && @r > 0;      # always include at least one key-value pair
	push @r, [ $key, $hash->{$key} ];
	$len += $dlen;
    }
    return @r, [ $DOTDOTDOT ];
}

1;

__END__