package Bnm;
use warnings;
use strict;
use integer;

# Notice that the Bnm::cmp_prefixless($$) function defined here uses
# neither @relem nor @gelem; it uses only @prefix.  If from this module
# you will be using only Bnm::cmp_prefixless(), then you need not worry
# about the @relem and @gelem lists.

our $active = 1; # set to 0 if the element lists below are not ready.
our @prefix = qw( lib );
our @relem  = qw( perl python );
our @gelem  = qw(
    dev doc common issue patch base data bin client tools dbg server
    source utils mod ssl headers html image modules manpages plugins
    text dict examples ldap ttf misc book clients slang test lib extra
    sound utf docs en user howto info pop runtime src altdev pic core
    demo manual pdf simple util conf contrib crypto debug imap lite libs
    script servers beta config extras fonts help intro plain progs ps
    static tiny tutorial agent crypt daemon driver faq icons mmx prof
    proxy scripts session sse suid system template users devguide
    example ref books spoilers usersguide
);

my %prefix = map { $_ => 1 } @prefix;
my %relem  = map { $_ => 1 } @relem ;
my %gelem  = map { $_ => 1 } @gelem ;

# Compare two possibly prefixed names as prefixless.
sub cmp_prefixless ($$) {
    $active or return( $_[0] cmp $_[1] );
    my @unprefixed = @_;
    my @i_prefix   = ( -1, -1 );
    my $i = 0;
    while ( $i <= $#prefix ) {
        my $prefix    = $prefix[$i];
        my $prefix_qm = quotemeta $prefix;
        my $last = 0;
        for my $j ( 0, 1 ) {
            my $u = $_[$j];
            if ( $u =~ s/^$prefix_qm(?=[a-z])// ) {
                $unprefixed[$j] = $u;
                $i_prefix  [$j] = $i;
                $last = 1;
            }
        }
        last if $last;
        ++$i;
    }
    return(
           $unprefixed[0] cmp $unprefixed[1]
        || $i_prefix  [0] cmp $i_prefix  [1]
    );
}

# Reduce a package name to its basename -- that is, its name without
# version numbers, generic following elements like -dev or -doc, or a
# preceding prefix (probably `lib').  In array context, also return the
# name's elements.  (This function was written some time ago.  Since
# then, experience has not shown the function to be very useful in
# practice.  Nevertheless it remains here if you want it.)
sub bnm (;$) {

    local $_ = @_ ? shift() : $_;
    s/^\d*//;
    /^[a-z]/ or return wantarray ? () : undef;

    # Break the name's elements out.
    my @e = split /[-+]/;
    s/[^a-z].*//s for @e;
    @e = grep { length } @e;
    @e or die "$0: name $_ has no elements " .
        "(this error message should have been unreachable)\n";

    # Deprefix the first element.
    my $e0_nopre = do {
        my $e0 = $e[0];
        for ( @prefix ) {
            my $prefix = quotemeta;
            last if $e0 =~ s/^$prefix(?=[a-z])//;
        }
        $e0;
    };

    # Remove generic elements.
    my @e_nogen = ( $e0_nopre );
    {
        my $s = 1; # state variable
        for ( @e[ 1 .. $#e ] ) {
            if    ( $s         ) {
                if ( $gelem{$_} ) {
                    $s = 0;
                }
                else {
                    push @e_nogen, $_;
                }
            }
            elsif ( $relem{$_} ) {
                push @e_nogen, $_;
                $s = 1;
            }
        }
    }

    # Render the basename.
    my $bnm = join '-', @e_nogen;

    return wantarray ? ( $bnm, $e[0], @e_nogen ) : $bnm;

}

1;

