File Coverage

lib/Package/Abbreviate.pm

Criterion	Covered	Total	%
statement	50	51	98.0
branch	26	30	86.6
condition	1	3	33.3
subroutine	7	7	100.0
pod	2	2	100.0
total	86	93	92.4

package Package::Abbreviate;

use strict;
use warnings;
use Carp;

our $VERSION = '0.01';

sub new {
  my ($class, $max, $opts) = @_;

  croak "requires max length of abbreviation" unless $max && $max =~ /^\d+$/;

  bless {%{$opts || {}}, max => $max}, $class;
}

sub abbr {
  my ($self, @packages) = @_;

  return $self->_abbr($packages[0]) if @packages == 1;

  my @abbreviation = map { $self->_abbr($_) } @packages;

  # validation: everything should be unique
  # (as long as packages are unique)
  my (%seen, $num_of_dupes);
  for (@abbreviation) {
    $num_of_dupes++ if $seen{$_}++;
  }
  if ($num_of_dupes) {
    %seen = ();
    for (@packages) {
      $num_of_dupes-- if $seen{$_}++;
    }
    $self->_error("Max length ($self->{max}) was too small and found duplicated abbreviations") if $num_of_dupes;
  }
  return @abbreviation;
}

sub _abbr {
  my ($self, $package) = @_;
  my $max = $self->{max};
  my $excess = length($package) - $max;
  return $package unless $excess > 0;

  my $abbreviation = $package;
  while($abbreviation =~ /(?:^|::)([A-Z]+[^A-Z][^:]+::)/) {
    my $part = $1;
    $excess -= (my $abbr = ucfirst $part) =~ s/[^A-Z:]//g;
    $abbr = lcfirst $abbr if $part =~ /^[a-z]/;
    $abbreviation =~ s/$part/$abbr/;
    return $abbreviation unless $excess > 0;
  }
  if ($self->{eager}) {
    my @parts = split /::/, $abbreviation;
    my $n = int(($excess + 1) / 2);
    if ($n < @parts - 1) {
      $abbreviation = join '::', join('', @parts[0..$n]), @parts[$n+1..@parts-1];
    } else {
      $excess -= $parts[-1] =~ s/[^A-Z]//g;
      if ($excess > 0) {
        $abbreviation = join '', @parts;
      } else {
        $abbreviation = join '::', @parts;
      }
    }
  }

  $self->_error("Max length ($self->{max}) was too small to abbreviate $package") if length($abbreviation) > $max;

  return $abbreviation;
}

sub _error {
  my ($self, $message) = @_;
  croak $message if $self->{croak};
  carp $message;
}

1;

__END__