File Coverage

blib/lib/String/Elide/Lines.pm

Criterion	Covered	Total	%
statement	98	101	97.0
branch	39	48	81.2
condition	13	27	48.1
subroutine	6	6	100.0
pod	1	1	100.0
total	157	183	85.7

package String::Elide::Lines;

our $DATE = '2017-01-28'; # DATE
our $VERSION = '0.001'; # VERSION

use 5.010001;
use strict;
use warnings;

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

sub _elide_lines {
    my ($lines, $len, $marker, $truncate) = @_;

    $marker = ["$marker\n"] unless ref $marker eq 'ARRAY';

    if (@$lines <= $len) {
        return $lines;
    }

    my $len_marker = @$marker;
    if ($len <= $len_marker) {
        return [ @{$marker}[0..$len-1] ];
    }

    if ($truncate eq 'top') {
        return [ @$marker, @{$lines}[(@$lines - $len + $len_marker) .. $#$lines] ];
    } elsif ($truncate eq 'middle') {
        my @top_lines  = @{$lines}[0 .. ($len-$len_marker)/2-1];
        my @bottom_lines = @{$lines}[(@$lines - ($len-$len_marker-@top_lines)) .. $#$lines];
        return [ @top_lines, @$marker, @bottom_lines ];
    } elsif ($truncate eq 'ends') {
        if ($len <= 2*$len_marker) {
            my @marker2 = (@$marker, @$marker);
            return [@marker2[0..$len-1]];
        }
        my $offset = (@$lines-$len)/2 + $len_marker;
        return [ @$marker, @{$lines}[$offset .. $offset + ($len-2*$len_marker)-1], @$marker ];
    } else { # bottom
        return [ @{$lines}[0 .. $len-$len_marker-1], @$marker ];
    }
}

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

    $opts //= {};
    my $truncate  = $opts->{truncate} // 'bottom';
    my $marker = $opts->{marker} // '..';

    # 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) {
        $parts[$i] = [split /^/, $parts[$i]];
        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=>1};
        }
    }

    #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 += @$_ for @parts;

        # total len of all parts is short enough, we're done
        if ($all_parts_len <= $len) {
            return join("", map { 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 += @{ $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 lines 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 );
        }
        # 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 = @{ $parts[$idx] };
            my $to_elide = $must_elide_total_len_after_this[$#high_indexes - $i] -
                $tot_already_elided + $tot_still_to_elide;
            if ($to_elide <= 0) {
                # leave this part alone
            } elsif ($part_len <= $to_elide) {
                # we need to eliminate this part
                splice @parts, $idx, 1;
                splice @parts_attrs, $idx, 1;
                $tot_already_elided += $part_len;
                $tot_still_to_elide += ($to_elide - $part_len);
            } else {
                $parts[$idx] = _elide_lines(
                    $parts[$idx],
                    $part_len - $to_elide,
                    $parts_attrs[$idx]{marker} // $marker,
                    $parts_attrs[$idx]{truncate} // $truncate,
                );
                $tot_already_elided += $to_elide;
                $tot_still_to_elide = 0;
            }
        }

    } # while 1
}

1;
# ABSTRACT: Elide lines from a string, with options

__END__