File Coverage

blib/lib/Versioning/Scheme/Semantic.pm

Criterion	Covered	Total	%
statement	47	47	100.0
branch	33	34	97.0
condition	26	30	86.6
subroutine	10	10	100.0
pod	5	5	100.0
total	121	126	96.0

package Versioning::Scheme::Semantic;

our $DATE = '2019-04-14'; # DATE
our $VERSION = '0.009'; # VERSION

use 5.010001;
use strict;
use warnings;

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

our $re = qr/
                \A
                ([0-9]|[1-9][0-9]*)\.                            # 1=major
                ([0-9]|[1-9][0-9]*)\.                            # 2=minor
                ([0-9]|[1-9][0-9]*)                              # 3=major
                (?:-([0-9]|[1-9][0-9]*|[A-Za-z-][0-9A-Za-z-]*))? # 4=pre-release identifier
                (?:\+([0-9A-Za-z-]+))?                           # 5=metadata
                \z
            /x;

sub is_valid_version {
    my ($self, $v) = @_;
    $v =~ $re ? 1:0;
}

sub parse_version {
    my ($self, $v) = @_;
    $v =~ $re or return undef;
    return {
        major => $1,
        minor => $2,
        patch => $3,
        prerelease => $4,
        metadata => $5,
    };
}

sub normalize_version {
    my ($self, $v, $opts) = @_;
    $opts //= {};

    die "Invalid version '$v'" unless $self->is_valid_version($v);
    $v;
}

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

    die "Invalid version '$v1'" unless my ($x1, $y1, $z1, $pre1) = $v1 =~ $re;
    die "Invalid version '$v2'" unless my ($x2, $y2, $z2, $pre2) = $v2 =~ $re;

    ($x1 <=> $x2) || ($y1 <=> $y2) || ($z1 <=> $z2) ||
        ((defined($pre1) ? 0:1) <=> (defined($pre2) ? 0:1)) ||
        (($pre1//'') cmp ($pre2//''));
}

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

    die "Invalid version '$v'" unless my ($x, $y, $z, $pre, $meta) = $v =~ $re;
    die "Invalid 'num', must be non-zero" unless $opts->{num} != 0;
    my @parts = ($x, $y, $z);
    die "Invalid 'part', must not be larger than ".$#parts
        if $opts->{part} > $#parts;
    die "Invalid 'part', must not be smaller than -".@parts
        if $opts->{part} < -@parts;

    my $idx = $opts->{part};
    $parts[$idx] //= 0;
    die "Cannot decrease version, would result in a negative number part"
        if $parts[$idx] + $opts->{num} < 0;
    $parts[$idx] = $parts[$idx]+$opts->{num};
    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);
        }
    }
    join("",
         $parts[0], ".", $parts[1], ".", $parts[2],
         (defined $pre ? "-$pre" : ""),
         (defined $meta ? "+$meta" : ""),
     );
}

1;
# ABSTRACT: Semantic versioning

__END__