File Coverage

blib/lib/String/Elide/Parts.pm

Criterion	Covered	Total	%
statement	87	87	100.0
branch	39	44	88.6
condition	20	29	68.9
subroutine	6	6	100.0
pod	1	1	100.0
total	153	167	91.6

package String::Elide::Parts;

our $DATE = '2017-01-29'; # DATE
our $VERSION = '0.07'; # VERSION

use 5.010001;
use strict;
use warnings;

use Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(elide);

sub _elide_part {
    my ($str, $len, $marker, $truncate) = @_;

    my $len_marker = length($marker);
    if ($len <= $len_marker) {
        return substr($marker, 0, $len);
    }

    if ($truncate eq 'left') {
        return $marker . substr($str, length($str) - $len+$len_marker);
    } elsif ($truncate eq 'middle') {
        my $left  = substr($str, 0,
                           ($len-$len_marker)/2);
        my $right = substr($str,
                           length($str) - ($len-$len_marker-length($left)));
        return $left . $marker . $right;
    } elsif ($truncate eq 'ends') {
        if ($len <= 2*$len_marker) {
            return substr($marker . $marker, 0, $len);
        }
        return $marker . substr($str, (length($str)-$len)/2 + $len_marker,
                                $len-2*$len_marker) . $marker;
    } else { # right
        return substr($str, 0, $len-$len_marker) . $marker;
    }
}

sub elide {
    my ($str, $len, $opts) = @_;

    $opts //= {};
    my $truncate  = $opts->{truncate} // 'right';
    my $marker = $opts->{marker} // '..';
    my $default_prio = $opts->{default_prio} // 1;

    # split into parts by priority
    my @parts;
    my @parts_attrs;
    while ($str =~ m#]*)>(.*?)|(.*?)(?=
        if (defined $1) {
            next unless length $2;
            push @parts, $2;
            push @parts_attrs, $1;
        } elsif (defined $3) {
            next unless length $3;
            push @parts, $3;
            push @parts_attrs, undef;
        } elsif (defined $4) {
            next unless length $4;
            push @parts, $4;
            push @parts_attrs, undef;
        }
    }
    return "" unless @parts && $len > 0;
    for my $i (0..@parts-1) {
        if (defined $parts_attrs[$i]) {
            my $attrs = {};
            $attrs->{truncate} = $1 // $2
                if $parts_attrs[$i] =~ /\btruncate=(?:"([^"]*)"|(\S+))/;
            $attrs->{marker} = $1 // $2
                if $parts_attrs[$i] =~ /\bmarker=(?:"([^"]*)"|(\S+))/;
            $attrs->{prio} = $1 // $2
                if $parts_attrs[$i] =~ /\bprio(?:rity)?=(?:"([^"]*)"|(\S+))/;
            $parts_attrs[$i] = $attrs;
        } else {
            $parts_attrs[$i] = {prio=>$default_prio};
        }
    }

    #use DD; dd \@parts; dd \@parts_attrs;

    # elide and truncate prio by prio until str is short enough
  PRIO:
    while (1) {
        # (re)calculate total len of all parts
        my $all_parts_len = 0;
        $all_parts_len += length($_) for @parts;

        # total len of all parts is short enough, we're done
        if ($all_parts_len <= $len) {
            return join("", @parts);
        }

        # we still need to elide some parts. first collect part indexes that
        # have the current largest priority.
        my $highest_prio;
        for (@parts_attrs) {
            $highest_prio = $_->{prio} if !defined($highest_prio) ||
                $highest_prio < $_->{prio};
        }
        my @high_indexes;
        my $high_parts_len = 0;
        for my $i (0..$#parts_attrs) {
            if ($parts_attrs[$i]{prio} == $highest_prio) {
                $high_parts_len += length $parts[$i];
                push @high_indexes, $i;
            }
        }

        if ($all_parts_len - $high_parts_len >= $len) {
            # we need to fully eliminate all the highest parts part then search
            # for another set of parts
            for (reverse @high_indexes) {
                splice @parts, $_, 1;
                splice @parts_attrs, $_, 1;
                next PRIO;
            }
        }

        # elide all to-be-elided parts equally

        # after this position, must elide a total of this number of characters
        # after this position
        my @must_elide_total_len_after_this;
        my $tot_to_elide = $all_parts_len - $len;
        for my $i (0..$#high_indexes) {
            $must_elide_total_len_after_this[$i] =
                int( ($i+1)/@high_indexes * $tot_to_elide );
        }
        #use DD; dd \@must_elide_total_len_after_this;

        # calculate how many characters to truncate for each part
        my $tot_already_elided = 0;
        my $tot_still_to_elide = 0;
        for my $i (reverse 0..$#high_indexes) {
            my $idx = $high_indexes[$i];
            my $part_len = length $parts[$idx];
            my $to_elide = $must_elide_total_len_after_this[$#high_indexes - $i] -
                $tot_already_elided;
            #say "D:[", ($i+1), "/", ~~@high_indexes, "] must_elide_total_len_after_this=", $must_elide_total_len_after_this[$#high_indexes-$i], " to_elide=$to_elide";
            if ($to_elide <= 0) {
                # leave this part alone
                #say "D:  leave alone <$parts[$idx]>";
            } elsif ($part_len <= $to_elide) {
                # we need to eliminate this part
                #say "D:  eliminate <$parts[$idx]>";
                splice @parts, $idx, 1;
                splice @parts_attrs, $idx, 1;
                $tot_already_elided += $part_len;
                $tot_still_to_elide += ($to_elide - $part_len);
                #say "D:  tot_already_elided=$tot_already_elided, tot_still_to_elide=$tot_still_to_elide";
            } else {
                #say "D:  elide <$parts[$idx]>";
                $parts[$idx] = _elide_part(
                    $parts[$idx],
                    $part_len - $to_elide,
                    $parts_attrs[$idx]{marker} // $marker,
                    $parts_attrs[$idx]{truncate} // $truncate,
                );
                #say "D:  elide result <$parts[$idx]>";
                $tot_already_elided += $to_elide;
                $tot_still_to_elide = 0;
                #say "D:  tot_already_elided=$tot_already_elided, tot_still_to_elide=$tot_still_to_elide";
            }
        }

    } # while 1
}

1;
# ABSTRACT: Elide a string with multiple parts of different priorities

__END__