diff --git a/fpm/app/main.f90 b/fpm/app/main.f90 index 28258ad4b4..b422965ae8 100644 --- a/fpm/app/main.f90 +++ b/fpm/app/main.f90 @@ -5,10 +5,12 @@ program main fpm_build_settings, & fpm_run_settings, & fpm_test_settings, & + fpm_update_settings, & fpm_install_settings, & get_command_line_settings use fpm, only: cmd_build, cmd_install, cmd_run use fpm_cmd_new, only: cmd_new +use fpm_cmd_update, only: cmd_update implicit none @@ -25,6 +27,8 @@ program main call cmd_run(settings,test=.false.) type is (fpm_test_settings) call cmd_run(settings,test=.true.) +type is (fpm_update_settings) + call cmd_update(settings) type is (fpm_install_settings) call cmd_install(settings) end select diff --git a/fpm/src/fpm.f90 b/fpm/src/fpm.f90 index 5e190c84bb..41621d7bd4 100644 --- a/fpm/src/fpm.f90 +++ b/fpm/src/fpm.f90 @@ -10,6 +10,7 @@ module fpm FPM_SCOPE_DEP, FPM_SCOPE_APP, FPM_SCOPE_TEST, & FPM_TARGET_EXECUTABLE +use fpm_dependency, only : update_dep_lock, dependency_walker_t use fpm_sources, only: add_executable_sources, add_sources_from_dir use fpm_targets, only: targets_from_sources, resolve_module_dependencies use fpm_manifest, only : get_package_data, package_config_t diff --git a/fpm/src/fpm/cmd/update.f90 b/fpm/src/fpm/cmd/update.f90 new file mode 100644 index 0000000000..b7079d9a3e --- /dev/null +++ b/fpm/src/fpm/cmd/update.f90 @@ -0,0 +1,109 @@ +!> Implementation of the fpm-update command. +module fpm_cmd_update + use, intrinsic :: iso_fortran_env, only : output_unit + use fpm_command_line, only : fpm_update_settings + use fpm_constants, only : fpm_manifest_file, fpm_build_dir, fpm_dependency_dir + use fpm_error, only : error_t, fatal_error + use fpm_filesystem, only : join_path, exists, mkdir + use fpm_git, only : git_target_t + use fpm_manifest, only : get_package_data, package_config_t, & + executable_config_t, dependency_config_t + use fpm_toml, only : toml_table, toml_parse, toml_serializer, toml_error, & + toml_key, add_table, set_value, get_value + use fpm_dependency, only : update_dep_lock, dependency_walker_t, & + new_dependency_walker, check_update_deps + implicit none + private + public :: cmd_update + + +contains + + !> Entry point for the fpm-update command + subroutine cmd_update(settings) + !> Representation of the command line options for this command + type(fpm_update_settings), intent(in) :: settings + + type(toml_table), allocatable :: table + type(package_config_t) :: package + type(dependency_walker_t) :: config + type(error_t), allocatable :: error + integer :: ii + + call get_package_data(package, fpm_manifest_file, error, apply_defaults=.true.) + call handle_error(error) + + if (.not.exists(fpm_build_dir)) then + call mkdir(fpm_build_dir) + end if + + if (settings%fetch_only) then + config = new_dependency_walker(& + prefix=join_path(fpm_build_dir, fpm_dependency_dir), & + verbosity=merge(2, 1, settings%verbose)) + else + config = new_dependency_walker(& + prefix=join_path(fpm_build_dir, fpm_dependency_dir), & + update=settings%name, & + update_all=size(settings%name) == 0, & + verbosity=merge(2, 1, settings%verbose)) + end if + + call update_dep_lock(config, table, package, error) + call handle_error(error) + + call check_update_deps(config, table, error) + call handle_error(error) + + call report_dependencies(config, table) + + end subroutine cmd_update + + subroutine report_dependencies(config, table) + !> Instance of the dependency handler + class(dependency_walker_t), intent(in) :: config + !> Table to collect all dependencies + type(toml_table), intent(inout) :: table + + integer :: ii, unused + character(len=:), allocatable :: version, path + type(toml_key), allocatable :: list(:) + type(toml_table), pointer :: dep + logical :: required + + call table%get_keys(list) + + unused = 0 + do ii = 1, size(list) + call get_value(table, list(ii)%key, dep) + call get_value(dep, "required", required, .false.) + call get_value(dep, "version", version) + call get_value(dep, "path", path) + if (.not.required) unused = unused + 1 + if (config%verbosity > 1) then + write(config%unit, '("#", *(1x, a:))', advance='no') & + list(ii)%key, "version", version, "at", path + if (.not.required) then + write(config%unit, '(*(1x, a:))', advance='no') "(unused)" + end if + write(config%unit, '(a))') + end if + end do + if (unused > 0 .and. config%verbosity > 0) then + write(config%unit, '("#", 1x, i0, *(1x, a:))') & + unused, "unused dependencies present" + end if + + end subroutine report_dependencies + + !> Error handling for this command + subroutine handle_error(error) + !> Potential error + type(error_t), intent(in), optional :: error + if (present(error)) then + print '(a)', error%message + error stop 1 + end if + end subroutine handle_error + +end module fpm_cmd_update diff --git a/fpm/src/fpm/constants.f90 b/fpm/src/fpm/constants.f90 new file mode 100644 index 0000000000..ef66eb1bef --- /dev/null +++ b/fpm/src/fpm/constants.f90 @@ -0,0 +1,17 @@ +module fpm_constants + implicit none + public + + !> Name of the project's manifest file + character(len=*), parameter :: fpm_manifest_file = "fpm.toml" + + !> Name of the build directory + character(len=*), parameter :: fpm_build_dir = "build" + + !> Name of the dependency subdirectory + character(len=*), parameter :: fpm_dependency_dir = "dependencies" + + !> Name of the dependency lock file + character(len=*), parameter :: fpm_lock_file = "cache.toml" + +end module fpm_constants diff --git a/fpm/src/fpm/dependency.f90 b/fpm/src/fpm/dependency.f90 new file mode 100644 index 0000000000..0b2c559c3f --- /dev/null +++ b/fpm/src/fpm/dependency.f90 @@ -0,0 +1,549 @@ +!> # Dependency management +!> +!> ## Fetching dependencies and creating a dependency tree +!> +!> Dependencies on the top-level can be specified from: +!> +!> - `package%dependencies` +!> - `package%dev_dependencies` +!> - `package%executable(:)%dependencies` +!> - `package%test(:)%dependencies` +!> +!> Each dependency is fetched in some way and provides a path to its package +!> manifest. +!> The `package%dependencies` of the dependencies are resolved recursively. +!> +!> To initialize the dependency tree all dependencies are recursively fetched +!> and stored in a flat data structure to avoid retrieving a package twice. +!> The data structure used to store this information should describe the current +!> status of the dependency tree. Important information are: +!> +!> - name of the package +!> - version of the package +!> - path to the package root +!> +!> Additionally, for version controlled dependencies the following should be +!> stored along with the package: +!> +!> - the upstream url +!> - the current checked out revision +!> +!> Fetching a remote (version controlled) dependency turns it for our purpose +!> into a local path dependency which is handled by the same means. +!> +!> ## Updating dependencies +!> +!> For a given dependency tree all top-level dependencies can be updated. +!> We have two cases to consider, a remote dependency and a local dependency, +!> again, remote dependencies turn into local dependencies by fetching. +!> Therefore we will update remote dependencies by simply refetching them. +!> +!> For remote dependencies we have to refetch if the information in the manifest +!> changes like: +!> +!> - different upstream URL +!> - changed revision +!> +!> or the upstream HEAD has changed (works similar for branches _and_ tags). +!> +!> @Note For our purpose a tag is just a fancy branch name. Tags can be delete and +!> modified afterwards, therefore they do not differ too much from branches +!> from our perspective. +!> +!> For the latter case we only know if we actually fetch from the upstream URL. +!> +!> In case of local (and fetched remote) dependencies we have to read the package +!> manifest and compare its dependencies against our dependency tree, any change +!> requires updating the respective dependencies as well. +!> +!> ## Handling dependency compatibilties +!> +!> Currenly ignored. First come, first serve. +module fpm_dependency + use, intrinsic :: iso_fortran_env, only : output_unit + use fpm_constants, only : fpm_manifest_file, fpm_build_dir, fpm_lock_file + use fpm_error, only : error_t, fatal_error + use fpm_filesystem, only : join_path, exists, mkdir + use fpm_git, only : git_target_t, git_revision + use fpm_manifest, only : get_package_data, package_config_t, & + executable_config_t, dependency_config_t + use fpm_toml, only : toml_table, toml_parse, toml_serializer, toml_error, & + toml_key, add_table, set_value, get_value + use fpm_versioning, only : version_t, char + implicit none + private + public :: update_dep_lock, check_update_deps + public :: dependency_walker_t, new_dependency_walker + + type :: enum_policy + integer :: fetch = 1 + integer :: update = 2 + integer :: force_update = 3 + end type enum_policy + type(enum_policy), parameter :: update_policy = enum_policy() + + type :: update_name + character(len=:), allocatable :: dep + end type update_name + + !> Common information for walking the dependency tree + type :: dependency_walker_t + !> Prefix for saving dependencies in + character(len=:), allocatable :: prefix + !> Update policy + integer :: policy = update_policy%fetch + !> Rerender all dependencies + logical :: clean = .false. + !> Output unit for diagnostics + integer :: unit = output_unit + !> Print level while walking the dependency tree + integer :: verbosity = 1 + !> Dependencies to update + type(update_name), allocatable :: update(:) + contains + !> Determine whether or not a refetch is required + procedure :: require_refetch + end type dependency_walker_t + +contains + + !> Constructor for dependency walker + pure function new_dependency_walker(prefix, update, update_all, clean, & + verbosity) result(self) + !> Prefix for storing dependencies + character(len=*), intent(in) :: prefix + !> Dependencies to update + character(len=*), intent(in), optional :: update(:) + !> Update all existing packages + logical, intent(in), optional :: update_all + !> Rerender all dependencies + logical, intent(in), optional :: clean + !> Print level while walking the dependency tree + integer, intent(in), optional :: verbosity + !> Instance of the dependency handler + type(dependency_walker_t) :: self + + integer :: ii + + self%prefix = prefix + if (present(update)) then + allocate(self%update(size(update))) + do ii = 1, size(update) + self%update(ii)%dep = trim(update(ii)) + end do + else + allocate(self%update(0)) + end if + self%policy = merge(update_policy%update, update_policy%fetch, present(update)) + if (present(update_all)) then + if (update_all) self%policy = update_policy%force_update + end if + if (present(clean)) then + self%clean = clean + end if + if (present(verbosity)) then + self%verbosity = verbosity + end if + + end function new_dependency_walker + + !> Update all dependencies in the current project + subroutine update_dep_lock(config, table, package, error) + !> Instance of the dependency handler + class(dependency_walker_t), intent(in) :: config + !> Cached dependency tree + type(toml_table), allocatable, intent(out) :: table + !> Package configuration data + type(package_config_t), intent(in) :: package + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_serializer) :: ser + character(len=:), allocatable :: root, lock + integer :: unit + + lock = join_path(fpm_build_dir, fpm_lock_file) + root = "." + + if (.not.config%clean .and. exists(lock)) then + open(file=lock, newunit=unit) + call get_dependency_lock(table, unit) + if (.not.allocated(table)) then + close(unit, status="delete") + else + close(unit) + end if + end if + + if (.not.allocated(table)) then + table = toml_table() + end if + + call get_project_deps(config, table, package, root, error) + if (allocated(error)) return + + open(file=lock, newunit=unit) + write(unit, '(a)') "# Dependency lock file generated by fpm" + ser = toml_serializer(unit) + call table%accept(ser) + close(unit) + + end subroutine update_dep_lock + + subroutine check_update_deps(config, table, error) + !> Instance of the dependency handler + class(dependency_walker_t), intent(in) :: config + !> Table to collect all dependencies + type(toml_table), intent(inout) :: table + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ii + + do ii = 1, size(config%update) + if (.not.table%has_key(config%update(ii)%dep)) then + call fatal_error(error, "Dependency '"//config%update(ii)%dep//& + "' is not a dependency of this project and cannot be updated") + exit + end if + end do + + end subroutine check_update_deps + + !> Update dependencies for root project + subroutine get_project_deps(config, table, package, root, error) + !> Instance of the dependency handler + class(dependency_walker_t), intent(in) :: config + !> Table to collect all dependencies + type(toml_table), intent(inout) :: table + !> Root package configuration data + type(package_config_t), intent(in) :: package + !> Current project root directory + character(len=*), intent(in) :: root + !> Error handling + type(error_t), allocatable, intent(out) :: error + + if (allocated(package%dependency)) then + call get_deps(config, table, package%dependency, root, error) + if (allocated(error)) return + end if + + if (allocated(package%dev_dependency)) then + call get_deps(config, table, package%dev_dependency, root, error) + if (allocated(error)) return + end if + + if (allocated(package%executable)) then + call get_executable_deps(config, table, package%executable, root, error) + if (allocated(error)) return + end if + + if (allocated(package%test)) then + call get_executable_deps(config, table, package%test, root, error) + if (allocated(error)) return + end if + end subroutine get_project_deps + + !> Handle dependencies within a list of executables + subroutine get_executable_deps(config, table, executable, root, error) + !> Table to collect all dependencies + type(toml_table), intent(inout) :: table + !> Array of executables with local dependencies + class(executable_config_t), intent(in) :: executable(:) + !> Current project root directory + character(len=*), intent(in) :: root + !> Instance of the dependency handler + class(dependency_walker_t), intent(in) :: config + !> Error handling + type(error_t), allocatable, intent(out) :: error + integer :: ii + + do ii = 1, size(executable) + if (allocated(executable(ii)%dependency)) then + call get_deps(config, table, executable(ii)%dependency, root, error) + if (allocated(error)) exit + end if + end do + if (allocated(error)) return + + end subroutine get_executable_deps + + !> Handle a list of dependencies + recursive subroutine get_deps(config, table, dependency, root, error) + !> Table to collect all dependencies + type(toml_table), intent(inout) :: table + !> Array of all dependencies + type(dependency_config_t), intent(in) :: dependency(:) + !> Current project root directory + character(len=*), intent(in) :: root + !> Instance of the dependency handler + class(dependency_walker_t), intent(in) :: config + !> Error handling + type(error_t), allocatable, intent(out) :: error + integer :: ii + + do ii = 1, size(dependency) + call get_dep(config, table, dependency(ii), root, error) + if (allocated(error)) exit + end do + if (allocated(error)) return + + end subroutine get_deps + + !> Fetch a dependency and create its package manifest + recursive subroutine get_dep(config, table, dependency, root, error) + !> Instance of the dependency handler + class(dependency_walker_t), intent(in) :: config + !> Error handling + !> Table to collect all dependencies + type(toml_table), intent(inout) :: table + !> Instance of the dependency data + type(dependency_config_t), intent(in) :: dependency + !> Current project root directory + character(len=*), intent(in) :: root + type(error_t), allocatable, intent(out) :: error + + type(package_config_t) :: package + character(len=:), allocatable :: manifest, project_dir + logical :: done, fetch + + if (allocated(dependency%git)) then + project_dir = join_path(config%prefix, dependency%name) + manifest = join_path(project_dir, fpm_manifest_file) + fetch = .not.exists(manifest) + if (check_require_refetch(config%policy)) then + fetch = fetch .or. config%require_refetch(table, dependency) + end if + if (fetch) then + call dependency%git%checkout(project_dir, error) + if (allocated(error)) return + end if + else if (allocated(dependency%path)) then + project_dir = join_path(root, dependency%path) + manifest = join_path(project_dir, fpm_manifest_file) + end if + + if (allocated(manifest)) then + call get_package_data(package, manifest, error) + if (allocated(error)) return + deallocate(manifest) + else + call fatal_error(error, "Dependency resolution failed for "//dependency%name) + return + end if + + call record_dep(config, table, package, project_dir, dependency%git, & + done, error) + if (allocated(error)) return + if (done) return + + if (allocated(package%dependency)) then + call get_deps(config, table, package%dependency, project_dir, error) + end if + + end subroutine get_dep + + !> Policy check for refetching remote dependencies + elemental function check_require_refetch(policy) result(check) + !> Current update policy + integer, intent(in) :: policy + !> Perform check for refetching remote + logical :: check + + check = policy == update_policy%update & + .or. policy == update_policy%force_update + + end function check_require_refetch + + !> Register a new package in the dependency lock + subroutine record_dep(config, table, package, root, git, done, error) + !> Instance of the dependency handler + class(dependency_walker_t), intent(in) :: config + !> Table to collect all dependencies + type(toml_table), intent(inout) :: table + !> Package configuration data + type(package_config_t), intent(in) :: package + !> Current project root directory + character(len=*), intent(in) :: root + !> Git repository information + type(git_target_t), intent(in), optional :: git + !> Dependency already recorded + logical, intent(out) :: done + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), pointer :: dep + character(len=:), allocatable :: version, rev + + done = table%has_key(package%name) + if (done) then + call get_value(table, package%name, dep) + call get_value(dep, "required", done, .false.) + call set_value(dep, "required", .true.) + else + call add_table(table, package%name, dep) + end if + call set_value(dep, "version", package%version, error) + if (allocated(error)) return + call set_value(dep, "path", root) + if (present(git)) then + call set_value(dep, "git-url", git%url) + call git_revision(root, rev, error) + if (allocated(error)) return + call set_value(dep, "git-obj", rev) + end if + + end subroutine record_dep + + !> Check if we have to fetch a version controlled dependency. + function require_refetch(config, table, dependency) result(fetch) + !> Instance of the dependency handler + class(dependency_walker_t), intent(in) :: config + !> Table to collect all dependencies + type(toml_table), intent(inout) :: table + !> Instance of the dependency data + type(dependency_config_t), intent(in) :: dependency + !> Refetch a remote dependency + logical :: fetch + + type(toml_table), pointer :: ptr + character(len=:), allocatable :: url, obj + + if (config%policy /= update_policy%force_update) then + if (.not.is_selected_dep(config%update, dependency)) then + fetch = .false. + return + end if + end if + + ! If the dependency is not registered yet, we have to fetch it + fetch = .not.table%has_key(dependency%name) + if (fetch .and. config%verbosity > 1) then + write(config%unit, '("#", *(1x, a))') & + "Fetch:", dependency%name, "(uncached)" + end if + if (fetch) return + + call get_value(table, dependency%name, ptr) + + ! Actual dependency is a git dependency + if (allocated(dependency%git)) then + ! In case no specific version is pinned, we always refetch + fetch = .not.allocated(dependency%git%object) + if (fetch .and. config%verbosity > 1) then + write(config%unit, '("#", *(1x, a))') & + "Fetch:", dependency%name, "revision", "HEAD" + end if + if (fetch) return + call get_value(ptr, "git-obj", obj) + if (allocated(obj)) then + ! In case the object specs don't match, we will refetch, + ! this will always refetch branches *and* tags (see explanation above), + ! also partial commit hashs will not pass this test for now. + fetch = obj /= dependency%git%object + if (fetch .and. config%verbosity > 1) then + write(config%unit, '("#", *(1x, a))') & + "Fetch:", dependency%name, "revision", obj, & + "->", dependency%git%object + end if + if (fetch) return + end if + end if + + call get_value(ptr, "git-url", url) + ! Cached dependency is a git dependency + if (allocated(url)) then + ! Actual dependency is a git dependency as well + if (allocated(dependency%git)) then + ! Always update if remote URL changed + fetch = url /= dependency%git%url + if (fetch .and. config%verbosity > 1) then + write(config%unit, '("#", *(1x, a))') & + "Fetch:", dependency%name, "url", url, & + "->", dependency%git%url + end if + if (fetch) return + end if + else + ! Cached dependency is not a git dependency, but the actual dependency is + fetch = allocated(dependency%git) + if (fetch .and. config%verbosity > 1) then + write(config%unit, '("#", *(1x, a))') & + "Fetch:", dependency%name, "from", dependency%git%url + end if + if (fetch) return + end if + + end function require_refetch + + !> Check if a dependency is selected for updating + pure function is_selected_dep(update, dependency) result(selected) + !> Names of all selected dependencies + type(update_name), intent(in) :: update(:) + !> Current dependency + type(dependency_config_t), intent(in) :: dependency + !> Check dependency for updates + logical :: selected + + integer :: ii + + selected = .false. + do ii = 1, size(update) + selected = selected .or. dependency%name == update(ii)%dep + if (selected) exit + end do + + end function is_selected_dep + + !> Try to retrieve the dependency lock, invalid lock files are dropped + subroutine get_dependency_lock(table, unit) + !> TOML data structure + type(toml_table), allocatable, intent(out) :: table + !> Formatted unit connected to dependency lock file + integer, intent(in) :: unit + + type(toml_table), pointer :: ptr + type(toml_error), allocatable :: parse_error + type(toml_key), allocatable :: list(:) + integer :: ii + logical :: done + + call toml_parse(table, unit, parse_error) + + if (allocated(parse_error)) then + if (allocated(table)) then + call table%destroy + deallocate(table) + end if + end if + + if (allocated(table)) then + call table%get_keys(list) + + do ii = 1, size(list) + call get_value(table, list(ii)%key, ptr) + call set_value(ptr, "required", .false.) + end do + end if + + end subroutine get_dependency_lock + + !> Update all locked dependencies + subroutine update_lock(table, error) + !> Table containing all dependencies + type(toml_table), intent(inout) :: table + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ii + type(toml_key), allocatable :: list(:) + + call table%get_keys(list) + + do ii = 1, size(list) + print'(a)', list(ii)%key + end do + + end subroutine update_lock + +end module fpm_dependency diff --git a/fpm/src/fpm/git.f90 b/fpm/src/fpm/git.f90 index 187b5514e7..bf7ca5ab25 100644 --- a/fpm/src/fpm/git.f90 +++ b/fpm/src/fpm/git.f90 @@ -1,11 +1,13 @@ !> Implementation for interacting with git repositories. module fpm_git use fpm_error, only: error_t, fatal_error + use fpm_filesystem, only : get_temp_filename, getline implicit none public :: git_target_t public :: git_target_default, git_target_branch, git_target_tag, & & git_target_revision + public :: git_revision !> Possible git target @@ -31,10 +33,9 @@ module fpm_git !> Description of an git target type :: git_target_t - private !> Kind of the git target - integer :: descriptor = git_descriptor%default + integer, private :: descriptor = git_descriptor%default !> Target URL of the git repository character(len=:), allocatable :: url @@ -128,7 +129,7 @@ function git_target_tag(url, tag) result(self) end function git_target_tag - subroutine checkout(self,local_path, error) + subroutine checkout(self, local_path, error) !> Instance of the git target class(git_target_t), intent(in) :: self @@ -138,12 +139,9 @@ subroutine checkout(self,local_path, error) !> Error type(error_t), allocatable, intent(out) :: error - - !> git object ref - character(:), allocatable :: object - !> Stat for execute_command_line integer :: stat + character(len=:), allocatable :: object if (allocated(self%object)) then object = self%object @@ -173,7 +171,50 @@ subroutine checkout(self,local_path, error) return end if - end subroutine checkout + end subroutine checkout + + + subroutine git_revision(local_path, object, error) + + !> Local path to checkout in + character(*), intent(in) :: local_path + + !> Git object reference + character(len=:), allocatable, intent(out) :: object + + !> Error + type(error_t), allocatable, intent(out) :: error + + integer :: stat, unit, istart, iend + character(len=:), allocatable :: temp_file, line, iomsg + character(len=*), parameter :: hexdigits = '0123456789abcdef' + + allocate(temp_file, source=get_temp_filename()) + line = "git -C "//local_path//" log -n 1 > "//temp_file + call execute_command_line(line, exitstat=stat) + + if (stat /= 0) then + call fatal_error(error, "Error while retrieving commit information") + return + end if + + open(file=temp_file, newunit=unit) + call getline(unit, line, stat, iomsg) + + if (stat /= 0) then + call fatal_error(error, iomsg) + return + end if + close(unit, status="delete") + + ! Tokenize: + ! commit 0123456789abcdef (HEAD, ...) + istart = scan(line, ' ') + 1 + iend = verify(line(istart:), hexdigits) + istart - 1 + if (iend < istart) iend = len(line) + object = line(istart:iend) + + end subroutine git_revision !> Show information on git target diff --git a/fpm/src/fpm/manifest.f90 b/fpm/src/fpm/manifest.f90 index 362ac69486..ddae97ecdf 100644 --- a/fpm/src/fpm/manifest.f90 +++ b/fpm/src/fpm/manifest.f90 @@ -8,6 +8,7 @@ !> to hide the actual implementation details. module fpm_manifest use fpm_manifest_build, only: build_config_t + use fpm_manifest_dependency, only : dependency_config_t use fpm_manifest_executable, only : executable_config_t use fpm_manifest_library, only : library_config_t use fpm_manifest_package, only : package_config_t, new_package @@ -20,6 +21,7 @@ module fpm_manifest public :: get_package_data, default_executable, default_library, default_test public :: package_config_t + public :: executable_config_t, dependency_config_t contains diff --git a/fpm/src/fpm/toml.f90 b/fpm/src/fpm/toml.f90 index 34f7c581e6..5f96e7b3b8 100644 --- a/fpm/src/fpm/toml.f90 +++ b/fpm/src/fpm/toml.f90 @@ -14,20 +14,28 @@ module fpm_toml use fpm_error, only : error_t, fatal_error, file_not_found_error use fpm_strings, only : string_t + use fpm_versioning, only : version_t, new_version use tomlf, only : toml_table, toml_array, toml_key, toml_stat, get_value, & - & set_value, toml_parse, toml_error, new_table, add_table, add_array, len + & set_value, toml_parse, toml_error, toml_serializer, new_table, & + & add_table, add_array, len implicit none private public :: read_package_file public :: toml_table, toml_array, toml_key, toml_stat, get_value, set_value public :: new_table, add_table, add_array, len + public :: toml_serializer, toml_parse, toml_error interface get_value module procedure :: get_child_value_string_list + module procedure :: get_child_value_version end interface get_value + interface set_value + module procedure :: set_child_value_version + end interface set_value + contains @@ -114,4 +122,60 @@ subroutine get_child_value_string_list(table, key, list, error) end subroutine get_child_value_string_list + !> Retrieve a TOML value as version data + subroutine get_child_value_version(table, key, version, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Key to read from + character(len=*), intent(in) :: key + + !> Version number + type(version_t), intent(out) :: version + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: str + integer :: stat + + call get_value(table, key, str) + if (allocated(str)) then + call new_version(version, str, error) + else + call fatal_error(error, "Wrong type for "//key//", string value required") + end if + + end subroutine get_child_value_version + + + !> Store version data as TOML string + subroutine set_child_value_version(table, key, version, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Key to read from + character(len=*), intent(in) :: key + + !> Version number + type(version_t), intent(in) :: version + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: str + integer :: stat + + call version%to_string(str) + call set_value(table, key, str, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Cannot set "//key//" value to version "//str) + return + end if + + end subroutine set_child_value_version + + end module fpm_toml diff --git a/fpm/src/fpm/versioning.f90 b/fpm/src/fpm/versioning.f90 index 145427eab7..b24fc3cf54 100644 --- a/fpm/src/fpm/versioning.f90 +++ b/fpm/src/fpm/versioning.f90 @@ -4,7 +4,7 @@ module fpm_versioning implicit none private - public :: version_t, new_version + public :: version_t, new_version, char type :: version_t @@ -47,6 +47,11 @@ module fpm_versioning integer, parameter :: max_limit = 3 + interface char + module procedure :: as_string + end interface char + + interface new_version module procedure :: new_version_from_string module procedure :: new_version_from_int @@ -245,6 +250,19 @@ subroutine to_string(self, string) end subroutine to_string + function as_string(self) result(string) + + !> Version number + class(version_t), intent(in) :: self + + !> Character representation of the version + character(len=:), allocatable :: string + + call self%to_string(string) + + end function as_string + + !> Check to version numbers for equality elemental function equals(lhs, rhs) result(is_equal) diff --git a/fpm/src/fpm_command_line.f90 b/fpm/src/fpm_command_line.f90 index 50a7d25059..8454a4e2d5 100644 --- a/fpm/src/fpm_command_line.f90 +++ b/fpm/src/fpm_command_line.f90 @@ -17,6 +17,7 @@ module fpm_command_line fpm_new_settings, & fpm_run_settings, & fpm_test_settings, & + fpm_update_settings, & get_command_line_settings type, abstract :: fpm_cmd_settings @@ -48,6 +49,13 @@ module fpm_command_line type, extends(fpm_cmd_settings) :: fpm_install_settings end type +!> Settings for interacting and updating with project dependencies +type, extends(fpm_cmd_settings) :: fpm_update_settings + character(len=ibug),allocatable :: name(:) + logical :: fetch_only + logical :: verbose +end type + character(len=:),allocatable :: name character(len=:),allocatable :: os_type character(len=ibug),allocatable :: names(:) @@ -55,11 +63,11 @@ module fpm_command_line character(len=:), allocatable :: version_text(:) character(len=:), allocatable :: help_new(:), help_fpm(:), help_run(:), & & help_test(:), help_build(:), help_usage(:), help_runner(:), & - & help_text(:), help_install(:), help_help(:), & + & help_text(:), help_install(:), help_help(:), help_update(:), & & help_list(:), help_list_dash(:), help_list_nodash(:) character(len=20),parameter :: manual(*)=[ character(len=20) ::& & ' ', 'fpm', 'new', 'build', 'run', & -& 'test', 'runner', 'list', 'help', 'version' ] +& 'test', 'runner', 'update','list', 'help', 'version' ] character(len=:), allocatable :: charbug contains @@ -196,6 +204,8 @@ subroutine get_command_line_settings(cmd_settings) help_text=[character(len=widest) :: help_text, help_runner] case('list ' ) help_text=[character(len=widest) :: help_text, help_list] + case('update ' ) + help_text=[character(len=widest) :: help_text, help_update] case('help ' ) help_text=[character(len=widest) :: help_text, help_help] case('version' ) @@ -232,6 +242,20 @@ subroutine get_command_line_settings(cmd_settings) cmd_settings=fpm_test_settings( name=names, list=lget('list'), & & release=lget('release'), args=remaining ,runner=charbug ) + case('update') + call set_args('--fetch-only F --verbose F', & + help_update, version_text) + + if( size(unnamed) .gt. 1 )then + names=unnamed(2:) + else + names=[character(len=len(names)) :: ] + endif + + allocate(fpm_update_settings :: cmd_settings) + cmd_settings=fpm_update_settings(& + name=names, fetch_only=lget('fetch-only'), verbose=lget('verbose')) + case default call set_args(' --list F', help_fpm, version_text) @@ -685,6 +709,24 @@ subroutine set_help() ' ', & ' fpm test tst1 tst2 --release # production version of two tests ', & '' ] + help_update=[character(len=80) :: & + 'NAME', & + ' update(1) - manage project dependencies', & + '', & + 'SYNOPSIS', & + ' fpm update [--fetch-only] [--list] [NAME(s)]', & + '', & + 'DESCRIPTION', & + ' Manage and update project dependencies. If no dependency names are', & + ' provided all the dependencies are updated automatically.', & + '', & + 'OPTIONS', & + ' --fetch-only Only fetch dependencies, do not update existing projects', & + ' --verbose Show additional printout', & + '', & + 'SEE ALSO', & + ' The fpm(1) home page at https://github.com/fortran-lang/fpm', & + '' ] help_install=[character(len=80) :: & ' fpm(1) subcommand "install" ', & ' ', & diff --git a/fpm/src/fpm_filesystem.f90 b/fpm/src/fpm_filesystem.f90 index 4c123149ce..5cf9ed9a42 100644 --- a/fpm/src/fpm_filesystem.f90 +++ b/fpm/src/fpm_filesystem.f90 @@ -6,7 +6,7 @@ module fpm_filesystem implicit none private public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, read_lines, list_files,& - mkdir, exists, get_temp_filename, windows_path + mkdir, exists, get_temp_filename, windows_path, getline integer, parameter :: LINE_BUFFER_LEN = 1000 @@ -382,4 +382,46 @@ function unix_path(path) result(nixpath) end function unix_path + +subroutine getline(unit, line, iostat, iomsg) + + !> Formatted IO unit + integer, intent(in) :: unit + + !> Line to read + character(len=:), allocatable, intent(out) :: line + + !> Status of operation + integer, intent(out) :: iostat + + !> Error message + character(len=:), allocatable, optional :: iomsg + + character(len=LINE_BUFFER_LEN) :: buffer + character(len=LINE_BUFFER_LEN) :: msg + integer :: size + integer :: stat + + allocate(character(len=0) :: line) + do + read(unit, '(a)', advance='no', iostat=stat, iomsg=msg, size=size) & + & buffer + if (stat > 0) exit + line = line // buffer(:size) + if (stat < 0) then + if (is_iostat_eor(stat)) then + stat = 0 + end if + exit + end if + end do + + if (stat /= 0) then + if (present(iomsg)) iomsg = trim(msg) + end if + iostat = stat + +end subroutine getline + + end module fpm_filesystem diff --git a/fpm/test/fpm_test/main.f90 b/fpm/test/fpm_test/main.f90 index eb08a94db8..34e474bfb9 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_package_dependencies, only : collect_package_dependencies use test_versioning, only : collect_versioning implicit none integer :: stat, is @@ -21,6 +22,7 @@ program fpm_testing & 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_package_dependencies", collect_package_dependencies), & & new_testsuite("fpm_versioning", collect_versioning) & & ] diff --git a/fpm/test/fpm_test/test_package_dependencies.f90 b/fpm/test/fpm_test/test_package_dependencies.f90 new file mode 100644 index 0000000000..d5cdafb0ed --- /dev/null +++ b/fpm/test/fpm_test/test_package_dependencies.f90 @@ -0,0 +1,268 @@ +module test_package_dependencies + use testsuite, only : new_unittest, unittest_t, error_t, test_failed, check + use fpm_dependency + use fpm_toml + use fpm_manifest_dependency + use fpm_git + implicit none + private + + public :: collect_package_dependencies + + + character(len=*), parameter :: dep1 = "toml-f" + character(len=*), parameter :: url1 = "https://github.com/toml-f/toml-f" + character(len=*), parameter :: url2 = "https://github.com/awvwgk/toml-f" + character(len=*), parameter :: rev1 = "c0ffee" + character(len=*), parameter :: rev2 = "abcdef" + + +contains + + + subroutine collect_package_dependencies(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("refetch-uncached", test_refetch_uncached), & + & new_unittest("refetch-git-head", test_refetch_git_head), & + & new_unittest("refetch-git-url", test_refetch_git_url), & + & new_unittest("refetch-git-rev", test_refetch_git_rev), & + & new_unittest("refetch-git-broken", test_refetch_git_broken), & + & new_unittest("refetch-policy", test_refetch_policy), & + & new_unittest("nofetch-policy", test_nofetch_policy), & + & new_unittest("nofetch-git-rev", test_nofetch_git_rev), & + & new_unittest("check-update-cache", test_check_update_deps), & + & new_unittest("check-missing-cache", test_check_missing_deps, should_fail=.true.) & + & ] + + end subroutine collect_package_dependencies + + + subroutine test_refetch_uncached(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_config_t) :: dependency + type(dependency_walker_t) :: config + + table = toml_table() + config = new_dependency_walker(prefix="build", update=[dep1]) + dependency%name = dep1 + dependency%git = git_target_default(url1) + + call check(error, config%require_refetch(table, dependency), .true., & + "Un-cached dependencies must always be refetched") + + end subroutine test_refetch_uncached + + + subroutine test_refetch_git_head(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(dependency_config_t) :: dependency + type(dependency_walker_t) :: config + + table = toml_table() + call add_table(table, dep1, ptr) + call set_value(ptr, "git-url", url1) + call set_value(ptr, "git-obj", rev1) + config = new_dependency_walker(prefix="build", update=[dep1]) + dependency%name = dep1 + dependency%git = git_target_default(url1) + + call check(error, config%require_refetch(table, dependency), .true., & + "Un-pinned dependencies most always be refetched") + + end subroutine test_refetch_git_head + + + !> Could also count as identical references and not refetch + subroutine test_refetch_git_url(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(dependency_config_t) :: dependency + type(dependency_walker_t) :: config + + table = toml_table() + call add_table(table, dep1, ptr) + call set_value(ptr, "git-url", url1) + call set_value(ptr, "git-obj", rev1) + config = new_dependency_walker(prefix="build", update=[dep1]) + dependency%name = dep1 + dependency%git = git_target_revision(url2, rev1) + + call check(error, config%require_refetch(table, dependency), .true., & + "URL change requires dependency refetch") + + end subroutine test_refetch_git_url + + + subroutine test_refetch_git_rev(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(dependency_config_t) :: dependency + type(dependency_walker_t) :: config + + table = toml_table() + call add_table(table, dep1, ptr) + call set_value(ptr, "git-url", url1) + call set_value(ptr, "git-obj", rev1) + config = new_dependency_walker(prefix="build", update=[dep1]) + dependency%name = dep1 + dependency%git = git_target_revision(url1, rev2) + + call check(error, config%require_refetch(table, dependency), .true., & + "Revision change requires dependency refetch") + + end subroutine test_refetch_git_rev + + + !> Can only happen for broken cache files, in this case we should still refetch + subroutine test_refetch_git_broken(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(dependency_config_t) :: dependency + type(dependency_walker_t) :: config + + table = toml_table() + call add_table(table, dep1, ptr) + call set_value(ptr, "git-obj", rev1) + config = new_dependency_walker(prefix="build", update=[dep1]) + dependency%name = dep1 + dependency%git = git_target_revision(url1, rev1) + + call check(error, config%require_refetch(table, dependency), .true., & + "Broken cache file, should better trigger a refetch") + + end subroutine test_refetch_git_broken + + + subroutine test_refetch_policy(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(dependency_config_t) :: dependency + type(dependency_walker_t) :: config + + table = toml_table() + call add_table(table, dep1, ptr) + call set_value(ptr, "git-url", url1) + call set_value(ptr, "git-obj", rev1) + config = new_dependency_walker(prefix="build", update_all=.true.) + dependency%name = dep1 + dependency%git = git_target_default(url1) + + call check(error, config%require_refetch(table, dependency), .true., & + "Don't refetch for fetch-only policy") + + end subroutine test_refetch_policy + + + subroutine test_nofetch_policy(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(dependency_config_t) :: dependency + type(dependency_walker_t) :: config + + table = toml_table() + call add_table(table, dep1, ptr) + call set_value(ptr, "git-url", url1) + call set_value(ptr, "git-obj", rev1) + config = new_dependency_walker(prefix="build") + dependency%name = dep1 + dependency%git = git_target_default(url1) + + call check(error, config%require_refetch(table, dependency), .false., & + "Don't refetch for fetch-only policy") + + end subroutine test_nofetch_policy + + + subroutine test_nofetch_git_rev(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(dependency_config_t) :: dependency + type(dependency_walker_t) :: config + + table = toml_table() + call add_table(table, dep1, ptr) + call set_value(ptr, "git-url", url1) + call set_value(ptr, "git-obj", rev1) + config = new_dependency_walker(prefix="build", update=[dep1]) + dependency%name = dep1 + dependency%git = git_target_revision(url1, rev1) + + call check(error, config%require_refetch(table, dependency), .false., & + "Matching revision are not updated") + + end subroutine test_nofetch_git_rev + + + subroutine test_check_update_deps(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(dependency_config_t) :: dependency + type(dependency_walker_t) :: config + + table = toml_table() + call add_table(table, dep1, ptr) + config = new_dependency_walker(prefix="build", update=[dep1]) + call check_update_deps(config, table, error) + + end subroutine test_check_update_deps + + + subroutine test_check_missing_deps(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(dependency_config_t) :: dependency + type(dependency_walker_t) :: config + + table = toml_table() + config = new_dependency_walker(prefix="build", update=[dep1]) + call check_update_deps(config, table, error) + + end subroutine test_check_missing_deps + + +end module test_package_dependencies diff --git a/fpm/test/fpm_test/testsuite.f90 b/fpm/test/fpm_test/testsuite.f90 index 124d19a5b4..49b9f15606 100644 --- a/fpm/test/fpm_test/testsuite.f90 +++ b/fpm/test/fpm_test/testsuite.f90 @@ -1,15 +1,42 @@ !> Define some procedures to automate collecting and launching of tests module testsuite - use fpm_error, only : error_t, test_failed => fatal_error + use fpm_error, only : error_t, fatal_error implicit none private + !> Single precision real numbers + integer, parameter :: sp = selected_real_kind(6) + !> Double precision real numbers + integer, parameter :: dp = selected_real_kind(15) + !> Char length for integers + integer, parameter :: i1 = selected_int_kind(2) + !> Short length for integers + integer, parameter :: i2 = selected_int_kind(4) + !> Length of default integers + integer, parameter :: i4 = selected_int_kind(9) + !> Long length for integers + integer, parameter :: i8 = selected_int_kind(18) + public :: run_testsuite, run_selected, new_unittest, new_testsuite, test_failed public :: select_test, select_suite - public :: check_string + public :: check, check_string public :: unittest_t, testsuite_t, error_t + interface check + module procedure :: check_stat + module procedure :: check_logical + module procedure :: check_float_sp + module procedure :: check_float_dp + module procedure :: check_int_i1 + module procedure :: check_int_i2 + module procedure :: check_int_i4 + module procedure :: check_int_i8 + module procedure :: check_bool + module procedure :: check_string + end interface check + + abstract interface !> Entry point for tests subroutine test_interface(error) @@ -255,32 +282,363 @@ function new_testsuite(name, collect) result(self) end function new_testsuite - !> Check a deferred length character variable against a reference value - subroutine check_string(error, actual, expected, name) + subroutine check_stat(error, stat, message, more) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Status of operation + integer, intent(in) :: stat + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (stat /= 0) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Non-zero exit code encountered", more) + end if + end if + + end subroutine check_stat + + + subroutine check_logical(error, expression, message, more) !> Error handling type(error_t), allocatable, intent(out) :: error - !> Actual string value + !> Result of logical operator + logical, intent(in) :: expression + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (.not.expression) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Condition not fullfilled", more) + end if + end if + + end subroutine check_logical + + + subroutine check_float_dp(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Found floating point value + real(dp), intent(in) :: actual + + !> Expected floating point value + real(dp), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(dp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + logical :: relative + real(dp) :: diff, threshold + + if (present(thr)) then + threshold = thr + else + threshold = epsilon(expected) + end if + + if (present(rel)) then + relative = rel + else + relative = .false. + end if + + if (relative) then + diff = abs(actual - expected) / expected + else + diff = abs(actual - expected) + end if + + if (diff > threshold) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Floating point value missmatch", more) + end if + end if + + end subroutine check_float_dp + + + subroutine check_float_sp(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Found floating point value + real(sp), intent(in) :: actual + + !> Expected floating point value + real(sp), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(sp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + logical :: relative + real(sp) :: diff, threshold + + if (present(thr)) then + threshold = thr + else + threshold = epsilon(expected) + end if + + if (present(rel)) then + relative = rel + else + relative = .false. + end if + + if (relative) then + diff = abs(actual - expected) / expected + else + diff = abs(actual - expected) + end if + + if (diff > threshold) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Floating point value missmatch", more) + end if + end if + + end subroutine check_float_sp + + + subroutine check_int_i1(error, actual, expected, message, more) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Found integer value + integer(i1), intent(in) :: actual + + !> Expected integer value + integer(i1), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (expected /= actual) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Integer value missmatch", more) + end if + end if + + end subroutine check_int_i1 + + + subroutine check_int_i2(error, actual, expected, message, more) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Found integer value + integer(i2), intent(in) :: actual + + !> Expected integer value + integer(i2), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (expected /= actual) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Integer value missmatch", more) + end if + end if + + end subroutine check_int_i2 + + + subroutine check_int_i4(error, actual, expected, message, more) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Found integer value + integer(i4), intent(in) :: actual + + !> Expected integer value + integer(i4), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (expected /= actual) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Integer value missmatch", more) + end if + end if + + end subroutine check_int_i4 + + + subroutine check_int_i8(error, actual, expected, message, more) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Found integer value + integer(i8), intent(in) :: actual + + !> Expected integer value + integer(i8), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (expected /= actual) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Integer value missmatch", more) + end if + end if + + end subroutine check_int_i8 + + + subroutine check_bool(error, actual, expected, message, more) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Found boolean value + logical, intent(in) :: actual + + !> Expected boolean value + logical, intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (expected .neqv. actual) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Logical value missmatch", more) + end if + end if + + end subroutine check_bool + + + subroutine check_string(error, actual, expected, message, more) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Found boolean value character(len=:), allocatable, intent(in) :: actual - !> Expected string value + !> Expected boolean value character(len=*), intent(in) :: expected - !> Name of the string to check - character(len=*), intent(in) :: name + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more if (.not.allocated(actual)) then - call test_failed(error, name//" is not set correctly") + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Character variable not allocated", more) + end if return end if - if (actual /= expected) then - call test_failed(error, name//" is "//actual// & - & " but should be "//expected) + if (expected /= actual) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Character value missmatch", more) + end if end if end subroutine check_string + subroutine test_failed(error, message, more) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> A detailed message describing the error + character(len=*), intent(in) :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + allocate(error) + + if (present(more)) then + error%message = message // new_line('a') // more + else + error%message = message + end if + + end subroutine test_failed + + end module testsuite