File Coverage

blib/lib/Gentoo/PerlMod/Version.pm

Criterion	Covered	Total	%
statement	109	115	94.7
branch	34	40	85.0
condition	2	2	100.0
subroutine	18	18	100.0
pod	1	1	100.0
total	164	176	93.1

use 5.006;
use strict;
use warnings;

package Gentoo::PerlMod::Version;

our $VERSION = 'v0.8.1';

# ABSTRACT: Convert arbitrary Perl Modules' versions into normalized Gentoo versions.

our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY

use Sub::Exporter::Progressive -setup => { exports => [qw( gentooize_version )] };
use version 0.77;

sub gentooize_version {
  my ( $perlver, $config ) = @_;
  $config ||= {};
  if ( not defined $perlver ) {
    return _err_perlver_undefined($config);
  }
  $config->{lax} = 0 unless defined $config->{lax};
  if ( _env_hasopt('always_lax') ) {
    $config->{lax} = _env_getopt('always_lax');
  }

  if ( $perlver =~ /\Av?[\d.]+\z/msx ) {
    return _lax_cleaning_0($perlver);
  }

  if ( $perlver =~ /\Av?[\d._]+(-TRIAL)?\z/msx ) {
    if ( $config->{lax} > 0 ) {
      return _lax_cleaning_1($perlver);
    }
    return _err_matches_trial_regex_nonlax( $perlver, $config );
  }

  if ( 2 == $config->{lax} ) {
    return _lax_cleaning_2($perlver);
  }
  return _err_not_decimal_or_trial( $perlver, $config );
}

###
#
# character to code translation
#
###

## no critic ( ProhibitMagicNumbers )
my $char_map = {
  ( map { $_ => $_ } 0 .. 9 ),    # 0..9
  ( map { chr( $_ + 65 ) => $_ + 10 } 0 .. 25 ),    # A-Z
  ( map { chr( $_ + 97 ) => $_ + 10 } 0 .. 25 ),    # a-z
};

# _code_for('z') -> $number
#

sub _code_for {
  my $char = shift;
  if ( not exists $char_map->{$char} ) {
    my $char_ord = ord $char;
    return _err_bad_char( $char, $char_ord );
  }
  return $char_map->{$char};
}

###
#
# Pair to number transformation.
#
#   _enc_pair( 'x','y' ) ->  $number
#
##

sub _enc_pair {
  my (@tokens) = @_;
  if ( not @tokens ) {
    return q{};
  }
  if ( @tokens < 2 ) {
    return _code_for( shift @tokens );
  }
  return ( _code_for( $tokens[0] ) * 36 ) + ( _code_for( $tokens[1] ) );
}

###
#
#  String to dotted-decimal conversion
#
# $dotstring = _ascii_to_int("HELLOWORLD");
#
###
sub _ascii_to_int {
  my $string = shift;
  my @chars = split //msx, $string;
  my @output;

  while (@chars) {
    push @output, _enc_pair( splice @chars, 0, 2, () );
  }

  return join q{.}, @output;
}

#
# Handler for gentooize_version( ... { lax => 0 } )
#
sub _lax_cleaning_0 {
  my $version = shift;
  return _expand_numeric($version);
}

#
# Handler for gentooize_version( ... { lax => 1 } )
#

sub _lax_cleaning_1 {
  my $version       = shift;
  my $isdev         = 0;
  my $prereleasever = undef;

  if ( $version =~ s/-TRIAL\z//msx ) {
    $isdev = 1;
  }
  if ( $version =~ s/_(.*)\z/$1/msx ) {
    $prereleasever = "$1";
    $isdev         = 1;
    if ( $prereleasever =~ /_/msx ) {
      return _err_lax_multi_underscore($version);
    }
  }
  $version = _expand_numeric($version);
  if ($isdev) {
    $version .= '_rc';
  }
  return $version;
}

#
# Handler for gentooize_version( ... { lax => 2 } )
#

sub _lax_cleaning_2 {
  my $version = shift;
  my $istrial = 0;

  my $has_v = 0;

  if ( $version =~ s/-TRIAL\z//msx ) {
    $istrial = 1;
  }
  if ( $version =~ s/\Av//msx ) {
    $has_v = 1;
  }

  my @parts = split /([._])/msx, $version;
  my @out;
  for (@parts) {
    if (/\A[_.]\z/msx) {
      push @out, $_;
      next;
    }
    if (/\A\d\z/msx) {
      push @out, $_;
      next;
    }
    push @out, _ascii_to_int($_);
  }

  my $version_out = join q{}, @out;
  if ($istrial) {
    $version_out .= '-TRIAL';
  }
  if ($has_v) {
    $version_out = 'v' . $version_out;
  }
  return _lax_cleaning_1($version_out);
}

#
# Expands dotted decimal to a float, and then chunks the float.
#
# my $clean = _expand_numeric( $dirty );
#
sub _expand_numeric {
  my $perlver = shift;

  my $ver = version->parse($perlver)->normal;

  $ver =~ s/\Av//msx;    # strip leading v

  my @tokens = split /[.]/msx, $ver;
  my @out;

  for (@tokens) {
    s/\A0+([1-9])/$1/msx;    # strip leading 0's
    push @out, $_;
  }

  return join q{.}, @out;
}

BEGIN {
  for my $err (qw( perlver_undefined matches_trial_regex_nonlax not_decimal_or_trial bad_char lax_multi_underscore )) {
    my $code = sub {
      require Gentoo::PerlMod::Version::Error;
      my $sub = Gentoo::PerlMod::Version::Error->can($err);
      goto $sub;
    };
    ## no critic ( ProhibitNoStrict )
    no strict 'refs';
    *{ __PACKAGE__ . '::_err_' . $err } = $code;
  }
  for my $env (qw( opts hasopt getopt )) {
    my $code = sub {
      require Gentoo::PerlMod::Version::Env;
      my $sub = Gentoo::PerlMod::Version::Env->can($env);
      goto $sub;
    };
    ## no critic ( ProhibitNoStrict )

    no strict 'refs';
    *{ __PACKAGE__ . '::_env_' . $env } = $code;
  }

}

1;

__END__