diff options
| -rw-r--r-- | fpm/src/fpm/manifest/package.f90 | 11 | ||||
| -rw-r--r-- | fpm/src/fpm/versioning.f90 | 394 | ||||
| -rw-r--r-- | fpm/test/fpm_test/main.f90 | 4 | ||||
| -rw-r--r-- | fpm/test/fpm_test/test_versioning.f90 | 405 |
4 files changed, 813 insertions, 1 deletions
diff --git a/fpm/src/fpm/manifest/package.f90 b/fpm/src/fpm/manifest/package.f90 index 946972e..fc04aa8 100644 --- a/fpm/src/fpm/manifest/package.f90 +++ b/fpm/src/fpm/manifest/package.f90 @@ -36,6 +36,7 @@ module fpm_manifest_package use fpm_error, only : error_t, fatal_error, syntax_error use fpm_toml, only : toml_table, toml_array, toml_key, toml_stat, get_value, & & len + use fpm_versioning, only : version_t, new_version implicit none private @@ -51,6 +52,9 @@ module fpm_manifest_package !> Build configuration data type(build_config_t) :: build_config + !> Package version + type(version_t) :: version + !> Library meta data type(library_t), allocatable :: library @@ -91,6 +95,7 @@ contains type(toml_table), pointer :: child, node type(toml_array), pointer :: children + character(len=:), allocatable :: version integer :: ii, nn, stat call check(table, error) @@ -108,6 +113,12 @@ contains return end if call new_build_config(self%build_config, child, error) + + if (allocated(error)) return + + call get_value(table, "version", version, "0") + call new_version(self%version, version, error) + if (allocated(error)) return call get_value(table, "dependencies", child, requested=.false.) diff --git a/fpm/src/fpm/versioning.f90 b/fpm/src/fpm/versioning.f90 new file mode 100644 index 0000000..145427e --- /dev/null +++ b/fpm/src/fpm/versioning.f90 @@ -0,0 +1,394 @@ +!> Implementation of versioning data for comparing packages +module fpm_versioning + use fpm_error, only : error_t, syntax_error + implicit none + private + + public :: version_t, new_version + + + type :: version_t + private + + !> Version numbers found + integer, allocatable :: num(:) + + contains + + generic :: operator(==) => equals + procedure, private :: equals + + generic :: operator(/=) => not_equals + procedure, private :: not_equals + + generic :: operator(>) => greater + procedure, private :: greater + + generic :: operator(<) => less + procedure, private :: less + + generic :: operator(>=) => greater_equals + procedure, private :: greater_equals + + generic :: operator(<=) => less_equals + procedure, private :: less_equals + + !> Compare a version against a version constraint (x.x.0 <= v < x.x.HUGE) + generic :: operator(.match.) => match + procedure, private :: match + + !> Create a printable string from a version data type + procedure :: to_string + + end type version_t + + + !> Arbitrary internal limit of the version parser + integer, parameter :: max_limit = 3 + + + interface new_version + module procedure :: new_version_from_string + module procedure :: new_version_from_int + end interface new_version + + +contains + + + !> Create a new version from a string + subroutine new_version_from_int(self, num) + + !> Instance of the versioning data + type(version_t), intent(out) :: self + + !> Subversion numbers to define version data + integer, intent(in) :: num(:) + + self%num = num + + end subroutine new_version_from_int + + + !> Create a new version from a string + subroutine new_version_from_string(self, string, error) + + !> Instance of the versioning data + type(version_t), intent(out) :: self + + !> String describing the version information + character(len=*), intent(in) :: string + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character :: tok + integer :: ii, istart, iend, stat, nn + integer :: num(max_limit) + logical :: is_number + + nn = 0 + iend = 0 + istart = 0 + is_number = .false. + + do while(iend < len(string)) + call next(string, istart, iend, is_number, error) + if (allocated(error)) exit + if (is_number) then + if (nn >= max_limit) then + call token_error(error, string, istart, iend, & + & "Too many subversions found") + exit + end if + nn = nn + 1 + read(string(istart:iend), *, iostat=stat) num(nn) + if (stat /= 0) then + call token_error(error, string, istart, iend, & + & "Failed to parse version number") + exit + end if + end if + end do + if (allocated(error)) return + if (.not.is_number) then + call token_error(error, string, istart, iend, & + & "Expected version number, but no characters are left") + return + end if + + call new_version(self, num(:nn)) + + end subroutine new_version_from_string + + + !> Tokenize a version string + subroutine next(string, istart, iend, is_number, error) + + !> String describing the version information + character(len=*), intent(in) :: string + + !> Start of last token, start of next token on exit + integer, intent(inout) :: istart + + !> End of last token on entry, end of next token on exit + integer, intent(inout) :: iend + + !> Token produced is a number + logical, intent(inout) :: is_number + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ii, nn + logical :: was_number + character :: tok, last + + was_number = is_number + nn = len(string) + + if (iend >= nn) then + istart = nn + iend = nn + return + end if + + ii = min(iend + 1, nn) + tok = string(ii:ii) + + is_number = tok /= '.' + if (is_number .eqv. was_number) then + call token_error(error, string, istart, ii, & + & "Unexpected token found") + return + end if + + if (.not.is_number) then + is_number = .false. + istart = ii + iend = ii + return + end if + + istart = ii + do ii = min(iend + 1, nn), nn + tok = string(ii:ii) + select case(tok) + case default + call token_error(error, string, istart, ii, & + & "Invalid character in version number") + exit + case('.') + exit + case('0', '1', '2', '3', '4', '5', '6', '7', '8', '9') + iend = ii + cycle + end select + end do + + end subroutine next + + + !> Create an error on an invalid token, provide some visual context as well + subroutine token_error(error, string, istart, iend, message) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> String describing the version information + character(len=*), intent(in) :: string + + !> Start of last token, start of next token on exit + integer, intent(in) :: istart + + !> End of last token on entry, end of next token on exit + integer, intent(in) :: iend + + !> Error message + character(len=*), intent(in) :: message + + character(len=*), parameter :: nl = new_line('a') + + allocate(error) + error%message = message // nl // " | " // string // nl // & + & " |" // repeat('-', istart) // repeat('^', iend - istart + 1) + + end subroutine token_error + + + subroutine to_string(self, string) + + !> Version number + class(version_t), intent(in) :: self + + !> Character representation of the version + character(len=:), allocatable, intent(out) :: string + + integer, parameter :: buffersize = 64 + character(len=buffersize) :: buffer + integer :: ii + + do ii = 1, size(self%num) + if (allocated(string)) then + write(buffer, '(".", i0)') self%num(ii) + string = string // trim(buffer) + else + write(buffer, '(i0)') self%num(ii) + string = trim(buffer) + end if + end do + + if (.not.allocated(string)) then + string = '0' + end if + + end subroutine to_string + + + !> Check to version numbers for equality + elemental function equals(lhs, rhs) result(is_equal) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> Version match + logical :: is_equal + + is_equal = .not.(lhs > rhs) + if (is_equal) then + is_equal = .not.(rhs > lhs) + end if + + end function equals + + + !> Check two versions for inequality + elemental function not_equals(lhs, rhs) result(not_equal) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> Version mismatch + logical :: not_equal + + not_equal = lhs > rhs + if (.not.not_equal) then + not_equal = rhs > lhs + end if + + end function not_equals + + + !> Relative comparison of two versions + elemental function greater(lhs, rhs) result(is_greater) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> First version is greater + logical :: is_greater + + integer :: ii + + do ii = 1, min(size(lhs%num), size(rhs%num)) + is_greater = lhs%num(ii) > rhs%num(ii) + if (is_greater) exit + end do + if (is_greater) return + + is_greater = size(lhs%num) > size(rhs%num) + if (is_greater) then + do ii = size(rhs%num) + 1, size(lhs%num) + is_greater = lhs%num(ii) > 0 + if (is_greater) exit + end do + end if + + end function greater + + + !> Relative comparison of two versions + elemental function less(lhs, rhs) result(is_less) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> First version is less + logical :: is_less + + is_less = rhs > lhs + + end function less + + + !> Relative comparison of two versions + elemental function greater_equals(lhs, rhs) result(is_greater_equal) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> First version is greater or equal + logical :: is_greater_equal + + is_greater_equal = .not. (rhs > lhs) + + end function greater_equals + + + !> Relative comparison of two versions + elemental function less_equals(lhs, rhs) result(is_less_equal) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> First version is less or equal + logical :: is_less_equal + + is_less_equal = .not. (lhs > rhs) + + end function less_equals + + + !> Try to match first version against second version + elemental function match(lhs, rhs) + + !> First version number + class(version_t), intent(in) :: lhs + + !> Second version number + class(version_t), intent(in) :: rhs + + !> Version match following semantic versioning rules + logical :: match + + type(version_t) :: tmp + + match = .not.(rhs > lhs) + if (match) then + tmp%num = rhs%num + tmp%num(size(tmp%num)) = tmp%num(size(tmp%num)) + 1 + match = tmp > lhs + end if + + end function match + + +end module fpm_versioning diff --git a/fpm/test/fpm_test/main.f90 b/fpm/test/fpm_test/main.f90 index eac38a8..eb08a94 100644 --- a/fpm/test/fpm_test/main.f90 +++ b/fpm/test/fpm_test/main.f90 @@ -7,6 +7,7 @@ program fpm_testing use test_manifest, only : collect_manifest use test_source_parsing, only : collect_source_parsing use test_module_dependencies, only : collect_module_dependencies + use test_versioning, only : collect_versioning implicit none integer :: stat, is character(len=:), allocatable :: suite_name, test_name @@ -19,7 +20,8 @@ program fpm_testing & new_testsuite("fpm_toml", collect_toml), & & new_testsuite("fpm_manifest", collect_manifest), & & new_testsuite("fpm_source_parsing", collect_source_parsing), & - & new_testsuite("fpm_module_dependencies", collect_module_dependencies) & + & new_testsuite("fpm_module_dependencies", collect_module_dependencies), & + & new_testsuite("fpm_versioning", collect_versioning) & & ] call get_argument(1, suite_name) diff --git a/fpm/test/fpm_test/test_versioning.f90 b/fpm/test/fpm_test/test_versioning.f90 new file mode 100644 index 0000000..f6dcb57 --- /dev/null +++ b/fpm/test/fpm_test/test_versioning.f90 @@ -0,0 +1,405 @@ +!> Test implementation of version data type +module test_versioning + use testsuite, only : new_unittest, unittest_t, error_t, test_failed + use fpm_versioning + implicit none + private + + public :: collect_versioning + + +contains + + + !> Collect all exported unit tests + subroutine collect_versioning(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("valid-version", test_valid_version), & + & new_unittest("valid-equals", test_valid_equals), & + & new_unittest("valid-notequals", test_valid_notequals), & + & new_unittest("valid-compare", test_valid_compare), & + & new_unittest("valid-match", test_valid_match), & + & new_unittest("valid-string", test_valid_string), & + & new_unittest("invalid-empty", test_invalid_empty, should_fail=.true.), & + & new_unittest("invalid-version1", test_invalid_version1, should_fail=.true.), & + & new_unittest("invalid-version2", test_invalid_version2, should_fail=.true.), & + & new_unittest("invalid-version3", test_invalid_version3, should_fail=.true.), & + & new_unittest("invalid-overflow", test_invalid_overflow, should_fail=.true.)] + + end subroutine collect_versioning + + + !> Read valid version strings + subroutine test_valid_version(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: version + + call new_version(version, "8.9.0", error) + if (allocated(error)) return + + call new_version(version, "2020.10.003", error) + + end subroutine test_valid_version + + + !> Compare versions for equality + subroutine test_valid_equals(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: v1, v2 + type(version_t) :: varray(4) + + call new_version(v1, [1, 2, 0]) + call new_version(v2, [1, 2]) + + if (.not. v1 == v2) then + call test_failed(error, "Version comparison failed") + return + end if + + if (.not. v2 == v1) then + call test_failed(error, "Version comparison failed") + return + end if + + call new_version(v1, [0, 9, 0]) + call new_version(v2, [0, 9]) + + if (.not. v1.eq.v2) then + call test_failed(error, "Version comparison failed") + return + end if + + if (.not. v2.eq.v1) then + call test_failed(error, "Version comparison failed") + return + end if + + call new_version(v1, [2020]) + call new_version(v2, [2020, 0]) + + if (.not. v1 == v2) then + call test_failed(error, "Version comparison failed") + return + end if + + if (.not. v2 == v1) then + call test_failed(error, "Version comparison failed") + return + end if + + call new_version(v1, [20, 1]) + call new_version(varray(1), [19]) + call new_version(varray(2), [18, 2]) + call new_version(varray(3), [20, 1]) + call new_version(varray(4), [1, 3, 1]) + + if (.not. any(v1 == varray)) then + call test_failed(error, "Version comparison failed") + return + end if + + end subroutine test_valid_equals + + + !> Compare versions for mismatch + subroutine test_valid_notequals(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: v1, v2 + type(version_t) :: varray(4) + + call new_version(v1, [2020, 3, 1]) + call new_version(v2, [2020, 3]) + + if (.not. v1 /= v2) then + call test_failed(error, "Version comparison failed") + return + end if + + if (.not. v2 /= v1) then + call test_failed(error, "Version comparison failed") + return + end if + + call new_version(v1, [0, 9, 1]) + call new_version(v2, [0, 9]) + + if (.not. v1.ne.v2) then + call test_failed(error, "Version comparison failed") + return + end if + + if (.not. v2.ne.v1) then + call test_failed(error, "Version comparison failed") + return + end if + + call new_version(v1, [2020]) + call new_version(v2, [0, 2020]) + + if (.not. v2 /= v1) then + call test_failed(error, "Version comparison failed") + return + end if + + if (.not. v1 /= v2) then + call test_failed(error, "Version comparison failed") + return + end if + + call new_version(v1, [20, 1]) + call new_version(varray(1), [19]) + call new_version(varray(2), [18, 2]) + call new_version(varray(3), [18, 1]) + call new_version(varray(4), [1, 3, 1]) + + if (.not. any(v1 /= varray)) then + call test_failed(error, "Version comparison failed") + return + end if + + end subroutine test_valid_notequals + + + !> Relative comparison of versions + subroutine test_valid_compare(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: v1, v2 + type(version_t) :: varray(4) + + call new_version(v1, [10]) + call new_version(v2, [1]) + + if (.not. v1 > v2) then + call test_failed(error, "Version comparison failed (gt)") + return + end if + + if (.not. v1 >= v2) then + call test_failed(error, "Version comparison failed (ge)") + return + end if + + if (.not. v2 < v1) then + call test_failed(error, "Version comparison failed (lt)") + return + end if + + if (.not. v2 <= v1) then + call test_failed(error, "Version comparison failed (le)") + return + end if + + call new_version(v1, [1, 0, 8]) + call new_version(v2, [1, 0]) + + if (.not. v1 .gt. v2) then + call test_failed(error, "Version comparison failed (gt)") + return + end if + + if (.not. v1 .ge. v2) then + call test_failed(error, "Version comparison failed (ge)") + return + end if + + if (.not. v2 .lt. v1) then + call test_failed(error, "Version comparison failed (lt)") + return + end if + + if (.not. v2 .le. v1) then + call test_failed(error, "Version comparison failed (le)") + return + end if + + call new_version(v1, [1, 2]) + call new_version(v2, [1, 2, 0]) + + if (v1 > v2) then + call test_failed(error, "Version comparison failed (gt)") + return + end if + + if (.not. v1 >= v2) then + call test_failed(error, "Version comparison failed (ge)") + return + end if + + if (v2 < v1) then + call test_failed(error, "Version comparison failed (lt)") + return + end if + + if (.not. v2 <= v1) then + call test_failed(error, "Version comparison failed (le)") + return + end if + + call new_version(v1, [20, 1]) + call new_version(varray(1), [19]) + call new_version(varray(2), [18, 2]) + call new_version(varray(3), [18, 1]) + call new_version(varray(4), [1, 3, 1]) + + if (.not. all(v1 > varray)) then + call test_failed(error, "Version comparison failed (gt)") + return + end if + + end subroutine test_valid_compare + + + !> Semantic version matching + subroutine test_valid_match(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: v1, v2 + type(version_t) :: varray(4) + + call new_version(v1, [1, 1, 0]) + call new_version(v2, [1]) + + if (.not. (v1 .match. v2)) then + call test_failed(error, "Version comparison failed (match)") + return + end if + + if (v2 .match. v1) then + call test_failed(error, "Version comparison failed (match)") + return + end if + + call new_version(v1, [0, 5, 8]) + call new_version(v2, [0, 5]) + + if (.not. (v1 .match. v2)) then + call test_failed(error, "Version comparison failed (match)") + return + end if + + if (v2 .match. v1) then + call test_failed(error, "Version comparison failed (match)") + return + end if + + call new_version(v1, [1, 2]) + call new_version(v2, [1, 2, 0]) + + if (.not. (v1 .match. v2)) then + call test_failed(error, "Version comparison failed (match)") + return + end if + + if (.not. (v2 .match. v1)) then + call test_failed(error, "Version comparison failed (match)") + return + end if + + end subroutine test_valid_match + + + !> Test if version string is preserved + subroutine test_valid_string(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=*), parameter :: str_in = "20.1.100" + character(len=:), allocatable :: str_out + type(version_t) :: version + + call new_version(version, str_in, error) + if (allocated(error)) return + call version%to_string(str_out) + + if (str_in /= str_out) then + call test_failed(error, "Expected "//str_in//" but got "//str_out) + end if + + end subroutine test_valid_string + + + !> Empty string does not represent a version + subroutine test_invalid_empty(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: version + + call new_version(version, "", error) + + end subroutine test_invalid_empty + + + !> Version is invalid with trailing dots + subroutine test_invalid_version1(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: version + + call new_version(version, "1.", error) + + end subroutine test_invalid_version1 + + + !> Version is invalid with multiple dots + subroutine test_invalid_version2(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: version + + call new_version(version, "1..1", error) + + end subroutine test_invalid_version2 + + + !> Version is invalid if it is not a version + subroutine test_invalid_version3(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: version + + call new_version(version, "one", error) + + end subroutine test_invalid_version3 + + + !> Check if overflows of the internal size constraint are handled gracefully + subroutine test_invalid_overflow(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(version_t) :: version + + call new_version(version, "0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0", error) + + end subroutine test_invalid_overflow + + +end module test_versioning |