File Coverage

blib/lib/Versioning/Scheme/Perl.pm

Criterion	Covered	Total	%
statement	76	76	100.0
branch	23	26	88.4
condition	15	16	93.7
subroutine	11	11	100.0
pod	5	5	100.0
total	130	134	97.0

package Versioning::Scheme::Perl;

our $DATE = '2020-10-01'; # DATE
our $VERSION = '0.011'; # VERSION

use 5.010001;
use strict;
use warnings;

use Role::Tiny;
use Role::Tiny::With;
with 'Role::Versioning::Scheme';
use version;

sub is_valid_version {
    my ($self, $v) = @_;
    eval { version->parse($v) };
    $@ ? 0:1;
}

sub parse_version {
    my ($self, $v) = @_;

    my $vp;
    eval { $vp = version->parse($v) };
    return undef if $@;
    $vp =~ s/\Av//;
    {parts => [split /\./, $vp]};
}

sub normalize_version {
    my ($self, $v) = @_;
    version->parse($v)->normal;
}

sub cmp_version {
    my ($self, $v1, $v2) = @_;

    version->parse($v1) <=> version->parse($v2);
}

sub bump_version {
    my ($self, $v, $opts) = @_;
    $opts //= {};
    $opts->{num} //= 1;
    $opts->{part} //= -1;
    $opts->{reset_smaller} //= 1;

    die "Invalid 'num', must be non-zero" unless $opts->{num} != 0;

    if ($opts->{part} eq 'dev') {
        version->parse($v);
        my $dev1;
        if ($v =~ /_([0-9]+)\z/) { $dev1 = $1 } else { $v .= "_000"; $dev1 = "000" }
        my $dev2 = $dev1 + $opts->{num};
        die "Cannot decrease version, would result in a negative dev part"
            if $dev2 < 0;
        $v =~ s/_([0-9]+)\z/sprintf("_%0".length($dev1)."d", $dev2)/e;
        return $v;
    }

    my $vn = version->parse($v)->normal; $vn =~ s/\Av//;
    my @parts = split /\./, $vn;
    die "Invalid 'part', must not be smaller than -".@parts
        if $opts->{part} < -@parts;
    die "Invalid 'part', must not be larger than ".$#parts
        if $opts->{part} > $#parts;

    my $idx = $opts->{part}; $idx = @parts + $idx if $idx < 0;
    # for now, we do not allow decreasing that overflow to the next more
    # significant part
    die "Cannot decrease version, would result in a negative part"
        if $parts[$idx] + $opts->{num} < 0;
    my $i = $idx;
    my $left = $opts->{num};
    while (1) {
        if ($i == 0 || $parts[$i]+$left < 1000) {
            $parts[$i] += $left;
            $left = 0;
            last;
        } else {
            my $tmp = $parts[$i] + $left;
            $parts[$i] = $tmp % 1000;
            $left = int($tmp / 1000);
            $i--;
            next;
        }
    }
    if ($opts->{reset_smaller} && $opts->{num} > 0) {
        $idx = @parts + $idx if $idx < 0;
        for my $i ($idx+1 .. $#parts) {
            $parts[$i] //= 0;
            $parts[$i] = sprintf("%0".length($parts[$i])."d", 0);
        }
    }
    version->parse(join(".", @parts))->normal;
}

1;
# ABSTRACT: Perl (version.pm) version numbering

__END__