Lingua::Abbreviate::Hierarchy - Shorten verbose namespaces

  use Lingua::Abbreviate::Hierarchy;
  my $abr = Lingua::Abbreviate::Hierarchy->new( keep => 1 );

  $abr->add_namespace(qw(
    comp.lang.perl.misc
    comp.lang.perl.advocacy
  ));

  # gets 'c.l.p.misc'
  my $clpm = $abr->ab('comp.lang.perl.misc');

  # abbreviate an array
  my @ab = $abr->ab(qw(
    comp.lang.perl.misc
    comp.lang.perl.advocacy
  ));

  comp.lang.perl.misc     -> c.l.p.misc
  comp.lang.perl.advocacy -> c.l.p.advocacy

  use Lingua::Ab::H;   # use abbreviated name

  my $abr = Lingua::Ab::H->new( keep => 1 );

  $abr->add_namespace(qw(
    comp.lang.perl.misc
    comp.lang.perl.advocacy
  ));

  # gets 'c.l.p.misc'
  my $clpm = $abr->ab('comp.lang.perl.misc');

  # abbreviate an array
  my @ab = $abr->ab(qw(
    comp.lang.perl.misc
    comp.lang.perl.advocacy
  ));

  my $abr = Lingua::Ab::H->new(
    keep => 1,
    sep => '::'
  );

  $abr->add_namespace( 'foo.com', 'bar.com' );

  my $short = $abr->ab( 'this.is.a.long.name' );

  my @short = $abr->ab( @long );

  my @ab = $abr->ab( @terms );      # Abbreviate terms...
  my @ex = $abr->ex( @ab );         # ...and get them back

package Lingua::Abbreviate::Hierarchy;

use warnings;
use strict;

use Carp qw( croak );
use List::Util qw( min max );

our $VERSION = '0.04';

{
  my %DEFAULT = (
    sep   => '.',
    only  => undef,
    keep  => undef,
    max   => undef,
    trunc => undef,
    flip  => 0,
  );

  sub new {
    my ( $class, %options ) = @_;

    my $ns = delete $options{ns};
    my @unk = grep { !exists $DEFAULT{$_} } keys %options;
    croak "Unknown option(s): ", join ', ', sort @unk if @unk;
    my $self = bless { %DEFAULT, %options, ns => {} }, $class;
    @{$self}{ 'flipa', 'flips' }
     = $self->{flip}
     ? ( sub { reverse @_ }, sub { $_[0] } )
     : ( sub { @_ }, sub { scalar reverse $_[0] } );
    $self->add_namespace( $ns ) if defined $ns;
    return $self;
  }
}

sub add_namespace {
  my $self = shift;
  croak "Can't add to namespace after calling ab()"
   if $self->{cache};
  my $sepp = quotemeta $self->{sep};
  for my $term ( map { 'ARRAY' eq ref $_ ? @$_ : $_ } @_ ) {
    my @path = $self->{flipa}( split /$sepp/o, $term );
    $self->{ns} = $self->_add_node( $self->{ns}, @path );
  }
}

sub _add_node {
  my ( $self, $nd, $wd, @path ) = @_;
  $nd ||= {};
  $nd->{$wd} ||= {};
  if ( @path ) {
    $nd->{$wd}{k} = $self->_add_node( $nd->{$wd}{k}, @path );
  }
  else {
    $nd->{$wd}{t} = 1;
  }
  return $nd;
}

sub ab {
  my $self = shift;
  $self->_init unless $self->{cache};
  my @ab = map { $self->{cache}{$_} ||= $self->_abb( $_ ) } @_;
  return wantarray ? @ab : $ab[0];
}

sub _abb {
  my ( $self, $term ) = @_;

  my $sepp = quotemeta $self->{sep};
  my @path = $self->{flipa}( split /$sepp/, $term );
  my $join = $self->_join;
  my $abc  = sub {
    my ( $cnt, @path ) = @_;
    join $join,
     $self->{flipa}( $self->_ab( $self->{ns}, $cnt, @path ) );
  };

  if ( defined( my $max = $self->{max} ) ) {
    my $from = $self->{only} || 0;
    my $to = scalar( @path ) - ( $self->{keep} || 0 );
    my $ab = $term;
    for my $cnt ( $from .. $to ) {
      $ab = $abc->( $cnt, @path );
      return $ab if length $ab <= $max;
    }
    if ( defined( my $trunc = $self->{trunc} ) ) {
      my $flp = $self->{flips};
      my $trc = sub {
        my ( $tr, $a ) = @_;
        return substr $tr, 0, $max if length $tr > $max;
        return substr( $a, 0, $max - length $tr ) . $tr;
      };
      return $flp->( $trc->( $flp->( $trunc ), $flp->( $ab ) ) );
    }
    return $ab;
  }
  else {
    my $lt = scalar @path;
    $lt = max( $lt - $self->{keep}, 0 ) if defined $self->{keep};
    $lt = min( $lt, $self->{only} ) if defined $self->{only};
    return $abc->( $lt, @path );
  }
}

sub _ab {
  my ( $self, $nd, $limit, $word, @path ) = @_;
  return $word, @path if $limit-- <= 0;
  return $word, @path unless $nd && $nd->{$word};
  return ( $nd->{$word}{a},
    @path ? $self->_ab( $nd->{$word}{k}, $limit, @path ) : () );
}

sub ex {
  my $self = shift;
  $self->_init_rev unless $self->{rev};
  my @ex = map { $self->{rcache}{$_} ||= $self->_exx( $_ ) } @_;
  return wantarray ? @ex : $ex[0];
}

sub _join {
  my $self = shift;
  return defined $self->{join} ? $self->{join} : $self->{sep};
}

sub _exx {
  my ( $self, $term ) = @_;
  my $sepp = quotemeta $self->_join;
  my @path = $self->{flipa}( split /$sepp/, $term );
  return join $self->{sep},
   $self->{flipa}( $self->_ab( $self->{rev}, scalar @path, @path ) );
}

sub _rev {
  my ( $self, $nd ) = @_;
  my $ond = {};
  while ( my ( $k, $v ) = each %$nd ) {
    my $nnd = { %$v, a => $k };
    $nnd->{k} = $self->_rev( $nnd->{k} ) if $nnd->{k};
    $ond->{ $v->{a} } = $nnd;
  }
  return $ond;
}

sub _init_rev {
  my $self = shift;
  $self->_init unless $self->{cache};
  $self->{rev} = $self->_rev( $self->{ns} );
}

sub _init {
  my $self = shift;
  $self->_make_ab( $self->{ns} );
  $self->{cache} = {};
}

# Given a list of unique terms return a hash mapping each term onto an
# equally unique abbreviation.
sub _ab_list {
  my ( $self, @w ) = @_;

  my %a   = ();
  my $len = 1;
  my @bad = @w;

  while () {
    $a{$_} = $len < length $_ ? substr $_, 0, $len : $_ for @bad;
    $len++;
    my %cc = ();
    $cc{ $a{$_} }++ for keys %a;
    @bad = grep { $cc{ $a{$_} } > 1 } keys %a;
    return \%a unless @bad;
  }
}

# Traverse the namespace tree making abbreviations for each node.
sub _make_ab {
  my ( $self, $nd ) = @_;
  my @kk = keys %$nd;
  my $ab = $self->_ab_list( @kk );
  for my $k ( @kk ) {
    $nd->{$k}{a} = $ab->{$k};
    $self->_make_ab( $nd->{$k}{k} ) if $nd->{$k}{k};
  }

}

"Ceci n'est pas 'Modern Perl'";

__END__