File Coverage

lib/SemVer.pm

Criterion	Covered	Total	%
statement	95	100	95.0
branch	47	50	94.0
condition	18	21	85.7
subroutine	18	18	100.0
pod	9	9	100.0
total	187	198	94.4

package SemVer;

use 5.008001;
use strict;
use version 0.82;
use Scalar::Util ();

use overload (
    '""'   => 'stringify',
    '<=>'  => 'vcmp',
    'cmp'  => 'vcmp',
    'bool' => 'vbool',
);

our @ISA = qw(version);
our $VERSION = '0.10.0'; # For Module::Build

sub _die { require Carp; Carp::croak(@_) }

# Prevent version.pm from mucking with our internals.
sub import {}

sub new {
    my ($class, $ival) = @_;

    # Handle vstring.
    return $class->SUPER::new($ival) if Scalar::Util::isvstring($ival);

    # Let version handle cloning.
    if (eval { $ival->isa('version') }) {
        my $self = $class->SUPER::new($ival);
        $self->{extra} = $ival->{extra};
        $self->{patch} = $ival->{patch};
        $self->{prerelease} = $ival->{prerelease};
        return $self;
    }

    # Regex taken from https://semver.org/#is-there-a-suggested-regular-expression-regex-to-check-a-semver-string.
    my ($major, $minor, $patch, $prerelease, $meta) = (
        $ival =~ /^v?(0|[1-9]\d*)\.(0|[1-9]\d*)\.(0|[1-9]\d*)(?:-((?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*)(?:\.(?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*))*))?(?:\+([0-9a-zA-Z-]+(?:\.[0-9a-zA-Z-]+)*))?$/
    );
    _die qq{Invalid semantic version string format: "$ival"}
        unless defined $major;

    return _init($class->SUPER::new("$major.$minor.$patch"), $prerelease, $meta);
}

sub _init {
    my ($self, $pre, $meta) = @_;
    if (defined $pre) {
        $self->{extra} = "-$pre";
        @{$self->{prerelease}} = split /[.]/, $pre;
    }
    if (defined $meta) {
        $self->{extra} .= "+$meta";
        @{$self->{patch}} = split /[.]/, $meta;
    }

    return $self;
}

$VERSION = __PACKAGE__->new($VERSION); # For ourselves.

sub _lenient {
    my ($class, $ctor, $ival) = @_;
    return $class->new($ival) if Scalar::Util::isvstring($ival)
        or eval { $ival->isa('version') };

    # Use official regex for prerelease and meta, use more lenient version num matching and whitespace.
    my ($v, $prerelease, $meta) = (
        $ival =~ /^[[:space:]]*
            v?([\d_]+(?:\.[\d_]+(?:\.[\d_]+)?)?)
            (?:-((?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*)(?:\.(?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*))*))?(?:\+([0-9a-zA-Z-]+(?:\.[0-9a-zA-Z-]+)*))?
        [[:space:]]*$/x
    );

    _die qq{Invalid semantic version string format: "$ival"}
        unless defined $v;

    $v += 0 if $v && $v =~ s/_//g; # ignore underscores.
    my $code = $class->can("SUPER::$ctor");
    return _init($code->($class, $v), $prerelease, $meta);
}

sub declare {
    shift->_lenient('declare', @_);
}

sub parse {
    shift->_lenient('parse', @_);
}

sub stringify {
    my $self = shift;
    my $str = $self->SUPER::stringify;
    # This is purely for SemVers constructed from version objects.
    $str += 0 if $str =~ s/_//g; # ignore underscores.
    return $str . ($self->{dash} || '') . ($self->{extra} || '');
}

sub normal   {
    my $self = shift;
    (my $norm = $self->SUPER::normal) =~ s/^v//;
    $norm =~ s/_/./g;
    return $norm . ($self->{extra} || '');
}

sub numify   { _die 'Semantic versions cannot be numified'; }
sub is_alpha { !!shift->{extra} }
sub vbool {
    my $self = shift;
    return version::vcmp($self, $self->new("0.0.0"), 1);
}

# Sort Ordering:
# Precedence refers to how versions are compared to each other when ordered. Precedence MUST be calculated by
# separating the version into major, minor, patch and pre-release identifiers in that order (Build metadata does not figure into precedence).
# Precedence is determined by the first difference when comparing each of these identifiers from left to right as follows:
# 1. Major, minor, and patch versions are always compared numerically. Example: 1.0.0 < 2.0.0 < 2.1.0 < 2.1.1.
# 2. When major, minor, and patch are equal, a pre-release version has lower precedence than a normal version.
#    Example: 1.0.0-alpha < 1.0.0.
# 3. Precedence for two pre-release versions with the same major, minor, and patch version MUST be determined by
#    comparing each dot separated identifier from left to right until a difference is found as follows:
#    3.a. identifiers consisting of only digits are compared numerically and identifiers with letters or hyphens are
#         compared lexically in ASCII sort order.
#    3.b. Numeric identifiers always have lower precedence than non-numeric identifiers.
#    3.c. A larger set of pre-release fields has a higher precedence than a smaller set, if all of the preceding identifiers are equal.
#    Example: 1.0.0-alpha < 1.0.0-alpha.1 < 1.0.0-alpha.beta < 1.0.0-beta < 1.0.0-beta.2 < 1.0.0-beta.11 < 1.0.0-rc.1 < 1.0.0.
sub vcmp {
    my $left  = shift;
    my $right = ref($left)->declare(shift);

    # Reverse?
    ($left, $right) = shift() ? ($right, $left): ($left, $right);

    # Major and minor win. - case 1.
    if (my $ret = $left->SUPER::vcmp($right, 0)) {
        return $ret;
    } else { #cases 2, 3
    	my $lenLeft = 0;
    	my $lenRight = 0;
    	if (defined $left->{prerelease}) {
        	$lenLeft = scalar(@{$left->{prerelease}});
        }
        if (defined $right->{prerelease}) {
        	$lenRight = scalar(@{$right->{prerelease}});
        }
        my $lenMin =  ($lenLeft, $lenRight)[$lenLeft > $lenRight];
        if ( $lenLeft == 0) {
            if ($lenRight == 0) {
                return 0; # Neither LEFT nor RIGHT have prerelease identifiers - versions are equal
            } else {
                # Case 2: When major, minor, and patch are equal, a pre-release version has lower precedence than a normal version.
                return 1; # Only RIGHT has prelease - not LEFT -> LEFT wins
            }
        } else {
            if ($lenRight == 0) {
                # Case 2: When major, minor, and patch are equal, a pre-release version has lower precedence than a normal version.
                return -1; # Only LEFT has prelease identifiers - not RIGHT -> RIGHT wins
            } else {
                # LEFT and RIGHT have prelease identifiers - compare each part separately
                for (my $i = 0; $i < $lenMin; $i++) {
                    my $isNumLeft = Scalar::Util::looks_like_number($left->{prerelease}->[$i]);
                    my $isNumRight = Scalar::Util::looks_like_number($right->{prerelease}->[$i]);
                    # Case 3.b: Numeric identifiers always have lower precedence than non-numeric identifiers
                    if (!$isNumLeft && $isNumRight) {
                        return 1; # LEFT identifier is Non-numeric - RIGHT identifier is numeric -> LEFT wins
										} elsif ($isNumLeft && !$isNumRight) {
                        return -1; # LEFT identifier is numeric - RIGHT identifier is non-numeric -> RIGHT wins
                    } elsif ($isNumLeft && $isNumRight) {
                        # Case 3.a.1: identifiers consisting of only digits are compared numerically
                        if ($left->{prerelease}->[$i] == $right->{prerelease}->[$i] ) {
                            next;  # LEFT identifier and RIGHT identifier are equal - step to next part
												} elsif ($left->{prerelease}->[$i] > $right->{prerelease}->[$i] ) {
                            return 1; # LEFT identifier is bigger than RIGHT identifier -> LEFT wins
                        } else {
                            return -1; return 1; # LEFT identifier is smaller than RIGHT identifier -> RIGHT wins
                        }
                    } else {
                        # Case 3.a.2: identifiers with letters or hyphens are compared lexically in ASCII sort order.
                        if (lc $left->{prerelease}->[$i] eq lc $right->{prerelease}->[$i] ) {
                            next;  # LEFT identifier and RIGHT identifier are equal - step to next part
												} elsif (lc $left->{prerelease}->[$i] gt  lc $right->{prerelease}->[$i] ) {
                            return 1; # LEFT identifier is bigger than RIGHT identifier -> LEFT wins
                        } else {
                            return -1; return 1; # LEFT identifier is smaller than RIGHT identifier -> RIGHT wins
                        }
                    }
                }
                # Case 3.c: A larger set of pre-release fields has a higher precedence than a smaller set, if all of the preceding identifiers are equal
                if ($lenLeft > $lenRight) {
                    return 1; # All existing identifiers are equal, but LEFT has more identifiers -> LEFT wins
								} elsif ($lenLeft < $lenRight) {
                    return -1; # All existing identifiers are equal, but RIGHT has more identifiers -> RIGHT wins
                }
                # All identifiers are equal
                return 0;
            }
        }
    }
}

1;
__END__