File Coverage

blib/lib/Module/Format/Module.pm

Criterion	Covered	Total	%
statement	78	85	91.7
branch	12	18	66.6
condition	2	2	100.0
subroutine	21	21	100.0
pod	7	7	100.0
total	120	133	90.2

package Module::Format::Module;
$Module::Format::Module::VERSION = '0.4.0';
use warnings;
use strict;


sub _new
{
    my $class = shift;
    my $self  = bless {}, $class;
    $self->_init(@_);
    return $self;
}

sub _components
{
    my $self = shift;

    if (@_)
    {
        $self->{_components} = shift;
    }
    return $self->{_components};
}

sub _init
{
    my ( $self, $args ) = @_;

    $self->_components( [ @{ $args->{_components} } ] );

    return;
}


sub from_components
{
    my ( $class, $args ) = @_;

    return $class->_new( { _components => [ @{ $args->{components} } ] } );
}


my $dash_re      = qr{(?:\w+-)*\w+};
my $colon_re     = qr{(?:\w+::)*\w+};
my $METACPAN_REL = 'https://metacpan.org/release/';

sub _gen_dash_format
{
    my ($args) = @_;

    my $prefix = $args->{prefix};
    my $name   = $args->{name};

    return +{
        name  => $name,
        regex => qr{\A\Q$prefix\E$dash_re\z},
        input => sub {
            my ( $class, $value ) = @_;

            if ( $value !~ s{\A\Q$prefix\E}{} )
            {
                die "$name value does not start with the '$prefix' prefix.";
            }

            return $class->_calc_components_from_string(
                { format => 'dash', value => $value } );
        },
        format => sub {
            my ($self) = @_;

            return $prefix . $self->format_as('dash');
        },
    };
}

sub _gen_colon_format
{
    my ($args) = @_;

    my $prefix = $args->{prefix};
    my $suffix = $args->{suffix};
    my $name   = $args->{name};

    return +{
        name  => $name,
        regex => qr{\A\Q$prefix\E$colon_re\Q$suffix\E\z},
        input => sub {
            my ( $class, $value ) = @_;

            if ( $value !~ m{\A\Q$prefix\E((?:\w+::)*\w+)\Q$suffix\E\z} )
            {
                die "Improper value for $name";
            }

            return $class->_calc_components_from_string(
                { format => 'colon', value => $1 } );
        },
        format => sub {
            my ($self) = @_;

            return $prefix . $self->format_as('colon') . $suffix;
        },
    };
}

my @formats_by_priority = (
    _gen_dash_format(
        {
            name   => 'rpm_dash',
            prefix => 'perl-',
        }
    ),
    _gen_colon_format(
        {
            name   => 'rpm_colon',
            prefix => 'perl(',
            suffix => ')',
        }
    ),
    {
        name  => 'colon',
        regex => qr{\A$colon_re\z},
        input => sub {
            my ( $class, $value ) = @_;
            return [ split( /::/, $value, -1 ) ];
        },
        format => sub {
            my ($self) = @_;

            return join( '::', @{ $self->_components() } );
        },
    },
    {
        name  => 'dash',
        regex => qr{\A$dash_re\z},
        input => sub {
            my ( $class, $value ) = @_;
            return [ split( /-/, $value, -1 ) ];
        },
        format => sub {
            my ($self) = @_;

            return join( '-', @{ $self->_components() } );
        },
    },
    {
        name  => 'unix',
        regex => qr{\A(?:\w+/)*\w+\.pm\z},
        input => sub {
            my ( $class, $value ) = @_;

            if ( $value !~ s{\.pm\z}{} )
            {
                die "Cannot find a .pm suffix in the 'unix' format.";
            }

            return [ split( m{/}, $value, -1 ) ];
        },
        format => sub {
            my ($self) = @_;

            return join( '/', @{ $self->_components() } ) . '.pm';
        },
    },
    _gen_dash_format(
        {
            name   => 'metacpan_rel',
            prefix => $METACPAN_REL,
        }
    ),
    _gen_colon_format(
        {
            name   => 'metacpan_pod',
            prefix => 'https://metacpan.org/pod/',
            suffix => '',
        }
    ),
    {
        name   => 'debian',
        format => sub {
            my ($self) = @_;

            return 'lib' . lc( $self->format_as('dash') ) . '-perl';
        },
    },
    _gen_dash_format(
        {
            name   => 'freebsd_dash',
            prefix => 'p5-',
        }
    ),
);

my %formats = ( map { $_->{name} => $_ } @formats_by_priority );

sub _calc_components_from_string
{
    my ( $class, $args ) = @_;

    my $format = $args->{format};
    my $value  = $args->{value};

    if ( exists( $formats{$format} ) )
    {
        if ( my $handler = $formats{$format}->{'input'} )
        {
            return $class->$handler($value);
        }
        else
        {
            die "Format $format is output-only!";
        }
    }
    else
    {
        die "Unknown format '$format'!";
    }
}

sub from
{
    my ( $class, $args ) = @_;

    my $format = $args->{format};
    my $value  = $args->{value};

    return $class->_new(
        {
            _components => $class->_calc_components_from_string($args)
        }
    );
}


sub get_components_list
{
    my $self = shift;

    return [ @{ $self->_components() } ];
}


sub format_as
{
    my ( $self, $format ) = @_;

    if ( exists( $formats{$format} ) )
    {
        my $handler = $formats{$format}->{'format'};
        return $self->$handler();
    }
    else
    {
        die "Unknown format '$format';";
    }

    return;
}


sub clone
{
    my $self = shift;

    return
        ref($self)
        ->from_components( { components => $self->get_components_list() } );
}


sub _all
{
    my ( $cb, $l ) = @_;

    foreach (@$l)
    {
        if ( not $cb->($_) )
        {
            return;
        }
    }

    return 1;
}

sub is_sane
{
    my $self = shift;

    return _all( sub { m{\A\w+\z}; }, $self->_components() );
}


sub from_guess
{
    my ( $class, $args ) = @_;

    my $dummy_format_string;

    my $string         = $args->{value};
    my $out_format_ref = ( $args->{format_ref} || ( \$dummy_format_string ) );

    # TODO : After the previous line the indentation in vim is reset to the
    # first column.

    foreach my $format_record (@formats_by_priority)
    {
        if ( my $regex = $format_record->{regex} )
        {
            if ( $string =~ $regex )
            {
                my $format_id = $format_record->{name};

                ${$out_format_ref} = $format_id;

                return $class->from(
                    { value => $string, format => $format_id, } );
            }
        }
    }

    die "Could not guess the format of the value '$string'!";
}


1;    # End of Module::Format::Module

__END__