diff --git a/app/main.f90 b/app/main.f90 index c7091267fb..10f75b8318 100644 --- a/app/main.f90 +++ b/app/main.f90 @@ -99,20 +99,20 @@ function has_manifest(dir) has_manifest = exists(join_path(dir, "fpm.toml")) end function has_manifest - subroutine handle_error(error) - type(error_t), optional, intent(in) :: error - if (present(error)) then - write(error_unit, '("[Error]", 1x, a)') error%message + subroutine handle_error(error_) + type(error_t), optional, intent(in) :: error_ + if (present(error_)) then + write (error_unit, '("[Error]", 1x, a)') error_%message stop 1 end if end subroutine handle_error !> Save access to working directory in settings, in case setting have not been allocated - subroutine get_working_dir(settings, working_dir) + subroutine get_working_dir(settings, working_dir_) class(fpm_cmd_settings), optional, intent(in) :: settings - character(len=:), allocatable, intent(out) :: working_dir + character(len=:), allocatable, intent(out) :: working_dir_ if (present(settings)) then - working_dir = settings%working_dir + working_dir_ = settings%working_dir end if end subroutine get_working_dir diff --git a/fpm.toml b/fpm.toml index ec70e34043..413c21b817 100644 --- a/fpm.toml +++ b/fpm.toml @@ -10,6 +10,8 @@ toml-f.git = "https://github.com/toml-f/toml-f" toml-f.rev = "54686e45993f3a9a1d05d5c7419f39e7d5a4eb3f" M_CLI2.git = "https://github.com/urbanjost/M_CLI2.git" M_CLI2.rev = "7264878cdb1baff7323cc48596d829ccfe7751b8" +jonquil.git = "https://github.com/toml-f/jonquil" +jonquil.rev = "05d30818bb12fb877226ce284b9a3a41b971a889" [[test]] name = "cli-test" diff --git a/src/fpm.f90 b/src/fpm.f90 index 26d85c49f6..5247f9e58d 100644 --- a/src/fpm.f90 +++ b/src/fpm.f90 @@ -17,8 +17,7 @@ module fpm use fpm_sources, only: add_executable_sources, add_sources_from_dir -use fpm_targets, only: targets_from_sources, & - resolve_target_linking, build_target_t, build_target_ptr, & +use fpm_targets, only: targets_from_sources, build_target_t, build_target_ptr, & FPM_TARGET_EXECUTABLE, FPM_TARGET_ARCHIVE use fpm_manifest, only : get_package_data, package_config_t use fpm_error, only : error_t, fatal_error, fpm_stop @@ -33,10 +32,8 @@ module fpm contains - +!> Constructs a valid fpm model from command line settings and the toml manifest. subroutine build_model(model, settings, package, error) - ! Constructs a valid fpm model from command line settings and toml manifest - ! type(fpm_model_t), intent(out) :: model type(fpm_build_settings), intent(in) :: settings type(package_config_t), intent(in) :: package @@ -45,9 +42,7 @@ subroutine build_model(model, settings, package, error) integer :: i, j type(package_config_t) :: dependency character(len=:), allocatable :: manifest, lib_dir, flags, cflags, cxxflags, ldflags - character(len=:), allocatable :: version logical :: has_cpp - logical :: duplicates_found = .false. type(string_t) :: include_dir @@ -117,8 +112,7 @@ subroutine build_model(model, settings, package, error) features%implicit_external = dependency%fortran%implicit_external features%source_form = dependency%fortran%source_form end associate - call package%version%to_string(version) - model%packages(i)%version = version + model%packages(i)%version = package%version%s() if (allocated(dependency%preprocess)) then do j = 1, size(dependency%preprocess) @@ -239,7 +233,6 @@ subroutine build_model(model, settings, package, error) endif - if (settings%verbose) then write(*,*)' BUILD_NAME: ',model%build_prefix write(*,*)' COMPILER: ',model%compiler%fc @@ -402,6 +395,7 @@ end subroutine check_module_names subroutine cmd_build(settings) type(fpm_build_settings), intent(in) :: settings + type(package_config_t) :: package type(fpm_model_t) :: model type(build_target_ptr), allocatable :: targets(:) @@ -411,17 +405,17 @@ subroutine cmd_build(settings) call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) if (allocated(error)) then - call fpm_stop(1,'*cmd_build*:package error:'//error%message) + call fpm_stop(1,'*cmd_build* Package error: '//error%message) end if call build_model(model, settings, package, error) if (allocated(error)) then - call fpm_stop(1,'*cmd_build*:model error:'//error%message) + call fpm_stop(1,'*cmd_build* Model error: '//error%message) end if call targets_from_sources(targets, model, settings%prune, error) if (allocated(error)) then - call fpm_stop(1,'*cmd_build*:target error:'//error%message) + call fpm_stop(1,'*cmd_build* Target error: '//error%message) end if if(settings%list)then @@ -457,17 +451,17 @@ subroutine cmd_run(settings,test) call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) if (allocated(error)) then - call fpm_stop(1, '*cmd_run*:package error:'//error%message) + call fpm_stop(1, '*cmd_run* Package error: '//error%message) end if call build_model(model, settings%fpm_build_settings, package, error) if (allocated(error)) then - call fpm_stop(1, '*cmd_run*:model error:'//error%message) + call fpm_stop(1, '*cmd_run* Model error: '//error%message) end if call targets_from_sources(targets, model, settings%prune, error) if (allocated(error)) then - call fpm_stop(1, '*cmd_run*:targets error:'//error%message) + call fpm_stop(1, '*cmd_run* Targets error: '//error%message) end if if (test) then diff --git a/src/fpm/cmd/install.f90 b/src/fpm/cmd/install.f90 index f81b4dfc44..c260bfc4df 100644 --- a/src/fpm/cmd/install.f90 +++ b/src/fpm/cmd/install.f90 @@ -28,7 +28,6 @@ subroutine cmd_install(settings) type(fpm_model_t) :: model type(build_target_ptr), allocatable :: targets(:) type(installer_t) :: installer - character(len=:), allocatable :: lib, dir type(string_t), allocatable :: list(:) logical :: installable @@ -49,7 +48,7 @@ subroutine cmd_install(settings) end if if (settings%list) then - call install_info(output_unit, package, model, targets) + call install_info(output_unit, targets) return end if @@ -81,14 +80,11 @@ subroutine cmd_install(settings) end subroutine cmd_install - subroutine install_info(unit, package, model, targets) + subroutine install_info(unit, targets) integer, intent(in) :: unit - type(package_config_t), intent(in) :: package - type(fpm_model_t), intent(in) :: model type(build_target_ptr), intent(in) :: targets(:) integer :: ii, ntargets - character(len=:), allocatable :: lib type(string_t), allocatable :: install_target(:), temp(:) allocate(install_target(0)) diff --git a/src/fpm/cmd/new.f90 b/src/fpm/cmd/new.f90 index 4d715343cb..8c10e1fb8d 100644 --- a/src/fpm/cmd/new.f90 +++ b/src/fpm/cmd/new.f90 @@ -56,7 +56,7 @@ module fpm_cmd_new use fpm_command_line, only : fpm_new_settings use fpm_environment, only : OS_LINUX, OS_MACOS, OS_WINDOWS use fpm_filesystem, only : join_path, exists, basename, mkdir, is_dir -use fpm_filesystem, only : fileopen, fileclose, filewrite, warnwrite, which, run +use fpm_filesystem, only : fileopen, fileclose, warnwrite, which, run use fpm_strings, only : join, to_fortran_name use fpm_error, only : fpm_stop diff --git a/src/fpm/dependency.f90 b/src/fpm/dependency.f90 index a314485313..626b1d37a7 100644 --- a/src/fpm/dependency.f90 +++ b/src/fpm/dependency.f90 @@ -55,32 +55,32 @@ !> !> Currenly ignored. First come, first serve. module fpm_dependency - use, intrinsic :: iso_fortran_env, only : output_unit - use fpm_environment, only : get_os_type, OS_WINDOWS - use fpm_error, only : error_t, fatal_error - use fpm_filesystem, only : exists, join_path, mkdir, canon_path, windows_path - use fpm_git, only : git_target_revision, git_target_default, git_revision, operator(==) - use fpm_manifest, only : package_config_t, dependency_config_t, & - get_package_data + use, intrinsic :: iso_fortran_env, only: output_unit + use fpm_environment, only: get_os_type, OS_WINDOWS, os_is_unix + use fpm_error, only: error_t, fatal_error + use fpm_filesystem, only: exists, join_path, mkdir, canon_path, windows_path, list_files, is_dir, basename, os_delete_dir + use fpm_git, only: git_target_revision, git_target_default, git_revision, operator(==) + use fpm_manifest, only: package_config_t, dependency_config_t, get_package_data use fpm_manifest_dependency, only: manifest_has_changed - use fpm_strings, only : string_t, operator(.in.) - use fpm_toml, only : toml_table, toml_key, toml_error, toml_serialize, & - toml_load, get_value, set_value, add_table - use fpm_versioning, only : version_t, new_version, char + use fpm_strings, only: string_t, operator(.in.) + use fpm_toml, only: toml_table, toml_key, toml_error, toml_serialize, & + get_value, set_value, add_table, toml_load, toml_stat + use fpm_versioning, only: version_t, new_version + use fpm_settings, only: fpm_global_settings, get_global_settings, official_registry_base_url + use fpm_downloader, only: downloader_t + use jonquil, only: json_object + use fpm_strings, only: str implicit none private - public :: dependency_tree_t, new_dependency_tree - public :: dependency_node_t, new_dependency_node - public :: resize - + public :: dependency_tree_t, new_dependency_tree, dependency_node_t, new_dependency_node, resize, & + & check_and_read_pkg_data !> Overloaded reallocation interface interface resize module procedure :: resize_dependency_node end interface resize - !> Dependency node in the projects dependency tree type, extends(dependency_config_t) :: dependency_node_t !> Actual version of this dependency @@ -94,13 +94,15 @@ module fpm_dependency !> Dependency should be updated logical :: update = .false. contains - !> Update dependency from project manifest + !> Update dependency from project manifest. procedure :: register + !> Get dependency from the registry. + procedure :: get_from_registry + procedure, private :: get_from_local_registry !> Print information on this instance procedure :: info end type dependency_node_t - !> Respresentation of a projects dependencies !> !> The dependencies are stored in a simple array for now, this can be replaced @@ -136,12 +138,14 @@ module fpm_dependency generic :: resolve => resolve_dependencies, resolve_dependency !> Resolve dependencies procedure, private :: resolve_dependencies - !> Resolve dependencies + !> Resolve dependency procedure, private :: resolve_dependency + !> True if entity can be found + generic :: has => has_dependency + !> True if dependency is part of the tree + procedure, private :: has_dependency !> Find a dependency in the tree - generic :: find => find_dependency, find_name - !> Find a dependency from an dependency configuration - procedure, private :: find_dependency + generic :: find => find_name !> Find a dependency by its name procedure, private :: find_name !> Depedendncy resolution finished @@ -163,7 +167,7 @@ module fpm_dependency !> Write dependency tree to TOML data structure procedure, private :: dump_to_toml !> Update dependency tree - generic :: update => update_dependency,update_tree + generic :: update => update_dependency, update_tree !> Update a list of dependencies procedure, private :: update_dependency !> Update all dependencies in the tree @@ -198,7 +202,7 @@ subroutine new_dependency_tree(self, verbosity, cache) end subroutine new_dependency_tree !> Create a new dependency node from a configuration - subroutine new_dependency_node(self, dependency, version, proj_dir, update) + subroutine new_dependency_node(self, dependency, version, proj_dir, update) !> Instance of the dependency node type(dependency_node_t), intent(out) :: self !> Dependency configuration data @@ -239,33 +243,31 @@ subroutine info(self, unit, verbosity) integer, intent(in), optional :: verbosity integer :: pr - character(:), allocatable :: ver character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' if (present(verbosity)) then - pr = verbosity + pr = verbosity else - pr = 1 + pr = 1 end if !> Call base object info - call self%dependency_config_t%info(unit,pr) + call self%dependency_config_t%info(unit, pr) if (allocated(self%version)) then - call self%version%to_string(ver) - write(unit, fmt) "- version", ver + write (unit, fmt) "- version", self%version%s() end if if (allocated(self%proj_dir)) then - write(unit, fmt) "- dir", self%proj_dir + write (unit, fmt) "- dir", self%proj_dir end if if (allocated(self%revision)) then - write(unit, fmt) "- revision", self%revision + write (unit, fmt) "- revision", self%revision end if - write(unit, fmt) "- done", merge('YES','NO ',self%done) - write(unit, fmt) "- update", merge('YES','NO ',self%update) + write (unit, fmt) "- done", merge('YES', 'NO ', self%done) + write (unit, fmt) "- update", merge('YES', 'NO ', self%update) end subroutine info @@ -282,19 +284,17 @@ subroutine add_project(self, package, error) type(error_t), allocatable, intent(out) :: error type(dependency_config_t) :: dependency - character(len=:), allocatable :: root + character(len=*), parameter :: root = '.' if (allocated(self%cache)) then call self%load(self%cache, error) if (allocated(error)) return end if - if (.not.exists(self%dep_dir)) then + if (.not. exists(self%dep_dir)) then call mkdir(self%dep_dir) end if - root = "." - ! Create this project as the first dependency node (depth 0) dependency%name = package%name dependency%path = root @@ -310,9 +310,9 @@ subroutine add_project(self, package, error) if (allocated(error)) return ! Now decent into the dependency tree, level for level - do while(.not.self%finished()) - call self%resolve(root, error) - if (allocated(error)) exit + do while (.not. self%finished()) + call self%resolve(root, error) + if (allocated(error)) exit end do if (allocated(error)) return @@ -408,7 +408,7 @@ end subroutine add_dependencies !> Add a single dependency node to the dependency tree !> Dependency nodes contain additional information (version, git, revision) - subroutine add_dependency_node(self, dependency, error) + subroutine add_dependency_node(self, dependency, error) !> Instance of the dependency tree class(dependency_tree_t), intent(inout) :: self !> Dependency configuration to add @@ -417,36 +417,28 @@ subroutine add_dependency_node(self, dependency, error) type(error_t), allocatable, intent(out) :: error integer :: id - logical :: needs_update - - id = self%find(dependency) - - exists: if (id > 0) then - !> A dependency with this same name is already in the dependency tree. + if (self%has_dependency(dependency)) then + ! A dependency with this same name is already in the dependency tree. + ! Check if it needs to be updated + id = self%find(dependency%name) - !> check if it needs to be updated - needs_update = dependency_has_changed(self%dep(id), dependency) - - !> Ensure an update is requested whenever the dependency has changed - if (needs_update) then - write(self%unit, out_fmt) "Dependency change detected:", dependency%name - self%dep(id) = dependency - self%dep(id)%update = .true. - endif - - else exists - - !> New dependency: add from scratch + ! Ensure an update is requested whenever the dependency has changed + if (dependency_has_changed(self%dep(id), dependency)) then + write (self%unit, out_fmt) "Dependency change detected:", dependency%name + self%dep(id) = dependency + self%dep(id)%update = .true. + end if + else + ! New dependency: add from scratch self%ndep = self%ndep + 1 self%dep(self%ndep) = dependency - - end if exists + end if end subroutine add_dependency_node !> Add a single dependency to the dependency tree - subroutine add_dependency(self, dependency, error) + subroutine add_dependency(self, dependency, error) !> Instance of the dependency tree class(dependency_tree_t), intent(inout) :: self !> Dependency configuration to add @@ -481,12 +473,9 @@ subroutine update_dependency(self, name, error) return end if - associate(dep => self%dep(id)) + associate (dep => self%dep(id)) if (allocated(dep%git) .and. dep%update) then - if (self%verbosity > 1) then - write(self%unit, out_fmt) "Update:", dep%name - end if - write(self%unit, out_fmt) "Update:", dep%name + write (self%unit, out_fmt) "Update:", dep%name proj_dir = join_path(self%dep_dir, dep%name) call dep%git%checkout(proj_dir, error) if (allocated(error)) return @@ -496,7 +485,7 @@ subroutine update_dependency(self, name, error) dep%update = .false. ! Now decent into the dependency tree, level for level - do while(.not.self%finished()) + do while (.not. self%finished()) call self%resolve(root, error) if (allocated(error)) exit end do @@ -517,8 +506,8 @@ subroutine update_tree(self, error) ! Update dependencies where needed do i = 1, self%ndep - call self%update(self%dep(i)%name,error) - if (allocated(error)) return + call self%update(self%dep(i)%name, error) + if (allocated(error)) return end do end subroutine update_tree @@ -532,10 +521,14 @@ subroutine resolve_dependencies(self, root, error) !> Error handling type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings integer :: ii + call get_global_settings(global_settings, error) + if (allocated(error)) return + do ii = 1, self%ndep - call self%resolve(self%dep(ii), root, error) + call self%resolve(self%dep(ii), global_settings, root, error) if (allocated(error)) exit end do @@ -544,11 +537,13 @@ subroutine resolve_dependencies(self, root, error) end subroutine resolve_dependencies !> Resolve a single dependency node - subroutine resolve_dependency(self, dependency, root, error) + subroutine resolve_dependency(self, dependency, global_settings, root, error) !> Instance of the dependency tree class(dependency_tree_t), intent(inout) :: self !> Dependency configuration to add type(dependency_node_t), intent(inout) :: dependency + !> Global configuration settings. + type(fpm_global_settings), intent(in) :: global_settings !> Current installation prefix character(len=*), intent(in) :: root !> Error handling @@ -560,21 +555,20 @@ subroutine resolve_dependency(self, dependency, root, error) if (dependency%done) return - fetch = .false. if (allocated(dependency%proj_dir)) then proj_dir = dependency%proj_dir - else - if (allocated(dependency%path)) then - proj_dir = join_path(root, dependency%path) - else if (allocated(dependency%git)) then - proj_dir = join_path(self%dep_dir, dependency%name) - fetch = .not.exists(proj_dir) - if (fetch) then - call dependency%git%checkout(proj_dir, error) - if (allocated(error)) return - end if - + else if (allocated(dependency%path)) then + proj_dir = join_path(root, dependency%path) + else if (allocated(dependency%git)) then + proj_dir = join_path(self%dep_dir, dependency%name) + fetch = .not. exists(proj_dir) + if (fetch) then + call dependency%git%checkout(proj_dir, error) + if (allocated(error)) return end if + else + call dependency%get_from_registry(proj_dir, global_settings, error) + if (allocated(error)) return end if if (allocated(dependency%git)) then @@ -590,8 +584,8 @@ subroutine resolve_dependency(self, dependency, root, error) if (allocated(error)) return if (self%verbosity > 1) then - write(self%unit, out_fmt) & - "Dep:", dependency%name, "version", char(dependency%version), & + write (self%unit, out_fmt) & + "Dep:", dependency%name, "version", dependency%version%s(), & "at", dependency%proj_dir end if @@ -600,18 +594,276 @@ subroutine resolve_dependency(self, dependency, root, error) end subroutine resolve_dependency - !> Find a dependency in the dependency tree - pure function find_dependency(self, dependency) result(pos) + !> Get a dependency from the registry. Whether the dependency is fetched + !> from a local, a custom remote or the official registry is determined + !> by the global configuration settings. + subroutine get_from_registry(self, target_dir, global_settings, error, downloader_) + + !> Instance of the dependency configuration. + class(dependency_node_t), intent(in) :: self + + !> The target directory of the dependency. + character(:), allocatable, intent(out) :: target_dir + + !> Global configuration settings. + type(fpm_global_settings), intent(in) :: global_settings + + !> Error handling. + type(error_t), allocatable, intent(out) :: error + + !> Downloader instance. + class(downloader_t), optional, intent(in) :: downloader_ + + character(:), allocatable :: cache_path, target_url, tmp_pkg_path, tmp_pkg_file + type(version_t) :: version + integer :: stat, unit + type(json_object) :: json + class(downloader_t), allocatable :: downloader + + if (present(downloader_)) then + downloader = downloader_ + else + allocate (downloader) + end if + + ! Use local registry if it was specified in the global config file. + if (allocated(global_settings%registry_settings%path)) then + call self%get_from_local_registry(target_dir, global_settings%registry_settings%path, error); return + end if + + ! Include namespace and package name in the cache path. + cache_path = join_path(global_settings%registry_settings%cache_path, self%namespace, self%name) + + ! Check cache before downloading from the remote registry if a specific version was requested. When no specific + ! version was requested, do network request first to check which is the newest version. + if (allocated(self%requested_version)) then + if (exists(join_path(cache_path, self%requested_version%s(), 'fpm.toml'))) then + print *, "Using cached version of '", join_path(self%namespace, self%name, self%requested_version%s()), "'." + target_dir = join_path(cache_path, self%requested_version%s()); return + end if + end if + + ! Define location of the temporary folder and file. + tmp_pkg_path = join_path(global_settings%path_to_config_folder, 'tmp') + tmp_pkg_file = join_path(tmp_pkg_path, 'package_data.tmp') + if (.not. exists(tmp_pkg_path)) call mkdir(tmp_pkg_path) + open (newunit=unit, file=tmp_pkg_file, action='readwrite', iostat=stat) + if (stat /= 0) then + call fatal_error(error, "Error creating temporary file for downloading package '"//self%name//"'."); return + end if + + ! Include namespace and package name in the target url and download package data. + target_url = global_settings%registry_settings%url//'/packages/'//self%namespace//'/'//self%name + call downloader%get_pkg_data(target_url, self%requested_version, tmp_pkg_file, json, error) + close (unit, status='delete') + if (allocated(error)) return + + ! Verify package data and read relevant information. + call check_and_read_pkg_data(json, self, target_url, version, error) + if (allocated(error)) return + + ! Open new tmp file for downloading the actual package. + open (newunit=unit, file=tmp_pkg_file, action='readwrite', iostat=stat) + if (stat /= 0) then + call fatal_error(error, "Error creating temporary file for downloading package '"//self%name//"'."); return + end if + + ! Include version number in the cache path. If no cached version exists, download it. + cache_path = join_path(cache_path, version%s()) + if (.not. exists(join_path(cache_path, 'fpm.toml'))) then + if (is_dir(cache_path)) call os_delete_dir(os_is_unix(), cache_path) + call mkdir(cache_path) + + print *, "Downloading '"//join_path(self%namespace, self%name, version%s())//"' ..." + call downloader%get_file(target_url, tmp_pkg_file, error) + if (allocated(error)) then + close (unit, status='delete'); return + end if + + ! Unpack the downloaded package to the final location. + call downloader%unpack(tmp_pkg_file, cache_path, error) + close (unit, status='delete') + if (allocated(error)) return + end if + + target_dir = cache_path + + end subroutine get_from_registry + + subroutine check_and_read_pkg_data(json, node, download_url, version, error) + type(json_object), intent(inout) :: json + class(dependency_node_t), intent(in) :: node + character(:), allocatable, intent(out) :: download_url + type(version_t), intent(out) :: version + type(error_t), allocatable, intent(out) :: error + + integer :: code, stat + type(json_object), pointer :: p, q + character(:), allocatable :: version_key, version_str, error_message + + if (.not. json%has_key('code')) then + call fatal_error(error, "Failed to download '"//join_path(node%namespace, node%name)//"': No status code."); return + end if + + call get_value(json, 'code', code, stat=stat) + if (stat /= 0) then + call fatal_error(error, "Failed to download '"//join_path(node%namespace, node%name)//"': "// & + & "Failed to read status code."); return + end if + + if (code /= 200) then + if (.not. json%has_key('message')) then + call fatal_error(error, "Failed to download '"//join_path(node%namespace, node%name)//"': No error message."); return + end if + + call get_value(json, 'message', error_message, stat=stat) + if (stat /= 0) then + call fatal_error(error, "Failed to download '"//join_path(node%namespace, node%name)//"': "// & + & "Failed to read error message."); return + end if + + call fatal_error(error, "Failed to download '"//join_path(node%namespace, node%name)//"'. Status code: '"// & + & str(code)//"'. Error message: '"//error_message//"'."); return + end if + + if (.not. json%has_key('data')) then + call fatal_error(error, "Failed to download '"//join_path(node%namespace, node%name)//"': No data."); return + end if + + call get_value(json, 'data', p, stat=stat) + if (stat /= 0) then + call fatal_error(error, "Failed to read package data for '"//join_path(node%namespace, node%name)//"'."); return + end if + + if (allocated(node%requested_version)) then + version_key = 'version_data' + else + version_key = 'latest_version_data' + end if + + if (.not. p%has_key(version_key)) then + call fatal_error(error, "Failed to download '"//join_path(node%namespace, node%name)//"': No version data."); return + end if + + call get_value(p, version_key, q, stat=stat) + if (stat /= 0) then + call fatal_error(error, "Failed to retrieve version data for '"//join_path(node%namespace, node%name)//"'."); return + end if + + if (.not. q%has_key('download_url')) then + call fatal_error(error, "Failed to download '"//join_path(node%namespace, node%name)//"': No download url."); return + end if + + call get_value(q, 'download_url', download_url, stat=stat) + if (stat /= 0) then + call fatal_error(error, "Failed to read download url for '"//join_path(node%namespace, node%name)//"'."); return + end if + + download_url = official_registry_base_url//'/'//download_url + + if (.not. q%has_key('version')) then + call fatal_error(error, "Failed to download '"//join_path(node%namespace, node%name)//"': No version found."); return + end if + + call get_value(q, 'version', version_str, stat=stat) + if (stat /= 0) then + call fatal_error(error, "Failed to read version data for '"//join_path(node%namespace, node%name)//"'."); return + end if + + call new_version(version, version_str, error) + if (allocated(error)) then + call fatal_error(error, "'"//version_str//"' is not a valid version for '"// & + & join_path(node%namespace, node%name)//"'."); return + end if + end subroutine + + !> Get the dependency from a local registry. + subroutine get_from_local_registry(self, target_dir, registry_path, error) + + !> Instance of the dependency configuration. + class(dependency_node_t), intent(in) :: self + + !> The target directory to download the dependency to. + character(:), allocatable, intent(out) :: target_dir + + !> The path to the local registry. + character(*), intent(in) :: registry_path + + !> Error handling. + type(error_t), allocatable, intent(out) :: error + + character(:), allocatable :: path_to_name + type(string_t), allocatable :: files(:) + type(version_t), allocatable :: versions(:) + type(version_t) :: version + integer :: i + + path_to_name = join_path(registry_path, self%namespace, self%name) + + if (.not. exists(path_to_name)) then + call fatal_error(error, "Dependency resolution of '"//self%name// & + & "': Directory '"//path_to_name//"' doesn't exist."); return + end if + + call list_files(path_to_name, files) + if (size(files) == 0) then + call fatal_error(error, "No versions of '"//self%name//"' found in '"//path_to_name//"'."); return + end if + + ! Version requested, find it in the cache. + if (allocated(self%requested_version)) then + do i = 1, size(files) + ! Identify directory that matches the version number. + if (files(i)%s == join_path(path_to_name, self%requested_version%s()) .and. is_dir(files(i)%s)) then + if (.not. exists(join_path(files(i)%s, 'fpm.toml'))) then + call fatal_error(error, "'"//files(i)%s//"' is missing an 'fpm.toml' file."); return + end if + target_dir = files(i)%s; return + end if + end do + call fatal_error(error, "Version '"//self%requested_version%s()//"' not found in '"//path_to_name//"'") + return + end if + + ! No specific version requested, therefore collect available versions. + allocate (versions(0)) + do i = 1, size(files) + if (is_dir(files(i)%s)) then + call new_version(version, basename(files(i)%s), error) + if (allocated(error)) return + versions = [versions, version] + end if + end do + + if (size(versions) == 0) then + call fatal_error(error, "No versions found in '"//path_to_name//"'"); return + end if + + ! Find the latest version. + version = versions(1) + do i = 1, size(versions) + if (versions(i) > version) version = versions(i) + end do + + path_to_name = join_path(path_to_name, version%s()) + + if (.not. exists(join_path(path_to_name, 'fpm.toml'))) then + call fatal_error(error, "'"//path_to_name//"' is missing an 'fpm.toml' file."); return + end if + + target_dir = path_to_name + end subroutine get_from_local_registry + + !> True if dependency is part of the tree + pure logical function has_dependency(self, dependency) !> Instance of the dependency tree class(dependency_tree_t), intent(in) :: self - !> Dependency configuration to add - class(dependency_config_t), intent(in) :: dependency - !> Index of the dependency - integer :: pos + !> Dependency configuration to check + class(dependency_node_t), intent(in) :: dependency - pos = self%find(dependency%name) + has_dependency = self%find(dependency%name) /= 0 - end function find_dependency + end function has_dependency !> Find a dependency in the dependency tree pure function find_name(self, name) result(pos) @@ -671,12 +923,12 @@ subroutine register(self, package, root, fetch, revision, error) self%version = package%version self%proj_dir = root - if (allocated(self%git).and.present(revision)) then + if (allocated(self%git) .and. present(revision)) then self%revision = revision - if (.not.fetch) then + if (.not. fetch) then ! git object is HEAD always allows an update - update = .not.allocated(self%git%object) - if (.not.update) then + update = .not. allocated(self%git%object) + if (.not. update) then ! allow update in case the revision does not match the requested object update = revision /= self%git%object end if @@ -700,12 +952,12 @@ subroutine load_from_file(self, file, error) integer :: unit logical :: exist - inquire(file=file, exist=exist) - if (.not.exist) return + inquire (file=file, exist=exist) + if (.not. exist) return - open(file=file, newunit=unit) + open (file=file, newunit=unit) call self%load(unit, error) - close(unit) + close (unit) end subroutine load_from_file !> Read dependency tree from file @@ -723,7 +975,7 @@ subroutine load_from_unit(self, unit, error) call toml_load(table, unit, error=parse_error) if (allocated(parse_error)) then - allocate(error) + allocate (error) call move_alloc(parse_error%message, error%message) return end if @@ -764,9 +1016,9 @@ subroutine load_from_toml(self, table, error) call get_value(ptr, "git", url) call get_value(ptr, "obj", obj) call get_value(ptr, "rev", rev) - if (.not.allocated(proj_dir)) cycle + if (.not. allocated(proj_dir)) cycle self%ndep = self%ndep + 1 - associate(dep => self%dep(self%ndep)) + associate (dep => self%dep(self%ndep)) dep%name = list(ii)%key if (unix) then dep%proj_dir = proj_dir @@ -775,11 +1027,7 @@ subroutine load_from_toml(self, table, error) end if dep%done = .false. if (allocated(version)) then - if (.not.allocated(dep%version)) allocate(dep%version) - call new_version(dep%version, version, error) - if (allocated(error)) exit - end if - if (allocated(version)) then + if (.not. allocated(dep%version)) allocate (dep%version) call new_version(dep%version, version, error) if (allocated(error)) exit end if @@ -813,9 +1061,9 @@ subroutine dump_to_file(self, file, error) integer :: unit - open(file=file, newunit=unit) + open (file=file, newunit=unit) call self%dump(unit, error) - close(unit) + close (unit) if (allocated(error)) return end subroutine dump_to_file @@ -834,7 +1082,7 @@ subroutine dump_to_unit(self, unit, error) table = toml_table() call self%dump(table, error) - write(unit, '(a)') toml_serialize(table) + write (unit, '(a)') toml_serialize(table) end subroutine dump_to_unit @@ -852,14 +1100,14 @@ subroutine dump_to_toml(self, table, error) character(len=:), allocatable :: proj_dir do ii = 1, self%ndep - associate(dep => self%dep(ii)) + associate (dep => self%dep(ii)) call add_table(table, dep%name, ptr) - if (.not.associated(ptr)) then + if (.not. associated(ptr)) then call fatal_error(error, "Cannot create entry for "//dep%name) exit end if if (allocated(dep%version)) then - call set_value(ptr, "version", char(dep%version)) + call set_value(ptr, "version", dep%version%s()) end if proj_dir = canon_path(dep%proj_dir) call set_value(ptr, "proj-dir", proj_dir) @@ -902,41 +1150,41 @@ pure subroutine resize_dependency_node(var, n) new_size = this_size + this_size/2 + 1 end if - allocate(var(new_size)) + allocate (var(new_size)) if (allocated(tmp)) then this_size = min(size(tmp, 1), size(var, 1)) var(:this_size) = tmp(:this_size) - deallocate(tmp) + deallocate (tmp) end if end subroutine resize_dependency_node !> Check if a dependency node has changed - logical function dependency_has_changed(this,that) result(has_changed) - !> Two instances of the same dependency to be compared - type(dependency_node_t), intent(in) :: this,that - - has_changed = .true. - - !> All the following entities must be equal for the dependency to not have changed - if (manifest_has_changed(this, that)) return - - !> For now, only perform the following checks if both are available. A dependency in cache.toml - !> will always have this metadata; a dependency from fpm.toml which has not been fetched yet - !> may not have it - if (allocated(this%version) .and. allocated(that%version)) then - if (this%version/=that%version) return - endif - if (allocated(this%revision) .and. allocated(that%revision)) then - if (this%revision/=that%revision) return - endif - if (allocated(this%proj_dir) .and. allocated(that%proj_dir)) then - if (this%proj_dir/=that%proj_dir) return - endif - - !> All checks passed: the two dependencies have no differences - has_changed = .false. + logical function dependency_has_changed(this, that) result(has_changed) + !> Two instances of the same dependency to be compared + type(dependency_node_t), intent(in) :: this, that + + has_changed = .true. + + !> All the following entities must be equal for the dependency to not have changed + if (manifest_has_changed(this, that)) return + + !> For now, only perform the following checks if both are available. A dependency in cache.toml + !> will always have this metadata; a dependency from fpm.toml which has not been fetched yet + !> may not have it + if (allocated(this%version) .and. allocated(that%version)) then + if (this%version /= that%version) return + end if + if (allocated(this%revision) .and. allocated(that%revision)) then + if (this%revision /= that%revision) return + end if + if (allocated(this%proj_dir) .and. allocated(that%proj_dir)) then + if (this%proj_dir /= that%proj_dir) return + end if + + !> All checks passed: the two dependencies have no differences + has_changed = .false. end function dependency_has_changed diff --git a/src/fpm/downloader.f90 b/src/fpm/downloader.f90 new file mode 100644 index 0000000000..1f631ca0a0 --- /dev/null +++ b/src/fpm/downloader.f90 @@ -0,0 +1,95 @@ +module fpm_downloader + use fpm_error, only: error_t, fatal_error + use fpm_filesystem, only: which + use fpm_versioning, only: version_t + use jonquil, only: json_object, json_value, json_error, json_load, cast_to_object + + implicit none + private + + public :: downloader_t + + !> This type could be entirely avoided but it is quite practical because it can be mocked for testing. + type downloader_t + contains + procedure, nopass :: get_pkg_data, get_file, unpack + end type + +contains + + !> Perform an http get request and save output to file. + subroutine get_pkg_data(url, version, tmp_pkg_file, json, error) + character(*), intent(in) :: url + type(version_t), allocatable, intent(in) :: version + character(*), intent(in) :: tmp_pkg_file + type(json_object), intent(out) :: json + type(error_t), allocatable, intent(out) :: error + + class(json_value), allocatable :: j_value + type(json_object), pointer :: ptr + type(json_error), allocatable :: j_error + + if (allocated(version)) then + ! Request specific version. + call get_file(url//'/'//version%s(), tmp_pkg_file, error) + else + ! Request latest version. + call get_file(url, tmp_pkg_file, error) + end if + if (allocated(error)) return + + call json_load(j_value, tmp_pkg_file, error=j_error) + if (allocated(j_error)) then + allocate (error); call move_alloc(j_error%message, error%message); call json%destroy(); return + end if + + ptr => cast_to_object(j_value) + if (.not. associated(ptr)) then + call fatal_error(error, "Error parsing JSON from '"//url//"'."); return + end if + + json = ptr + end + + subroutine get_file(url, tmp_pkg_file, error) + character(*), intent(in) :: url + character(*), intent(in) :: tmp_pkg_file + type(error_t), allocatable, intent(out) :: error + + integer :: stat + + if (which('curl') /= '') then + print *, "Downloading package data from '"//url//"' ..." + call execute_command_line('curl '//url//' -s -o '//tmp_pkg_file, exitstat=stat) + else if (which('wget') /= '') then + print *, "Downloading package data from '"//url//"' ..." + call execute_command_line('wget '//url//' -q -O '//tmp_pkg_file, exitstat=stat) + else + call fatal_error(error, "Neither 'curl' nor 'wget' installed."); return + end if + + if (stat /= 0) then + call fatal_error(error, "Error downloading package from '"//url//"'."); return + end if + end + + !> Unpack a tarball to a destination. + subroutine unpack(tmp_pkg_file, destination, error) + character(*), intent(in) :: tmp_pkg_file + character(*), intent(in) :: destination + type(error_t), allocatable, intent(out) :: error + + integer :: stat + + if (which('tar') == '') then + call fatal_error(error, "'tar' not installed."); return + end if + + print *, "Unpacking '"//tmp_pkg_file//"' to '"//destination//"' ..." + call execute_command_line('tar -zxf '//tmp_pkg_file//' -C '//destination, exitstat=stat) + + if (stat /= 0) then + call fatal_error(error, "Error unpacking '"//tmp_pkg_file//"'."); return + end if + end +end diff --git a/src/fpm/installer.f90 b/src/fpm/installer.f90 index 4e138d10e3..ec5880fe51 100644 --- a/src/fpm/installer.f90 +++ b/src/fpm/installer.f90 @@ -7,14 +7,12 @@ module fpm_installer use, intrinsic :: iso_fortran_env, only : output_unit use fpm_environment, only : get_os_type, os_is_unix use fpm_error, only : error_t, fatal_error - use fpm_filesystem, only : join_path, mkdir, exists, unix_path, windows_path, & - env_variable + use fpm_filesystem, only : join_path, mkdir, exists, unix_path, windows_path, get_local_prefix + implicit none private - public :: installer_t, new_installer - !> Declaration of the installer type type :: installer_t !> Path to installation directory @@ -59,12 +57,6 @@ module fpm_installer !> Default name of the include subdirectory character(len=*), parameter :: default_includedir = "include" - !> Default name of the installation prefix on Unix platforms - character(len=*), parameter :: default_prefix_unix = "/usr/local" - - !> Default name of the installation prefix on Windows platforms - character(len=*), parameter :: default_prefix_win = "C:\" - !> Copy command on Unix platforms character(len=*), parameter :: default_copy_unix = "cp" @@ -77,7 +69,6 @@ module fpm_installer !> Move command on Windows platforms character(len=*), parameter :: default_move_win = "move" - contains !> Create a new instance of an installer @@ -131,7 +122,7 @@ subroutine new_installer(self, prefix, bindir, libdir, includedir, verbosity, & if (present(prefix)) then self%prefix = prefix else - call set_default_prefix(self%prefix, self%os) + self%prefix = get_local_prefix(self%os) end if if (present(bindir)) then @@ -154,33 +145,6 @@ subroutine new_installer(self, prefix, bindir, libdir, includedir, verbosity, & end subroutine new_installer - !> Set the default prefix for the installation - subroutine set_default_prefix(prefix, os) - !> Installation prefix - character(len=:), allocatable :: prefix - !> Platform identifier - integer, intent(in), optional :: os - - character(len=:), allocatable :: home - - if (os_is_unix(os)) then - call env_variable(home, "HOME") - if (allocated(home)) then - prefix = join_path(home, ".local") - else - prefix = default_prefix_unix - end if - else - call env_variable(home, "APPDATA") - if (allocated(home)) then - prefix = join_path(home, "local") - else - prefix = default_prefix_win - end if - end if - - end subroutine set_default_prefix - !> Install an executable in its correct subdirectory subroutine install_executable(self, executable, error) !> Instance of the installer diff --git a/src/fpm/manifest/dependency.f90 b/src/fpm/manifest/dependency.f90 index cf3c1a31d2..ec40dfdf74 100644 --- a/src/fpm/manifest/dependency.f90 +++ b/src/fpm/manifest/dependency.f90 @@ -23,18 +23,18 @@ !> Resolving a dependency will result in obtaining a new package configuration !> data for the respective project. module fpm_manifest_dependency - use fpm_error, only : error_t, syntax_error - use fpm_git, only : git_target_t, git_target_tag, git_target_branch, & + use fpm_error, only: error_t, syntax_error + use fpm_git, only: git_target_t, git_target_tag, git_target_branch, & & git_target_revision, git_target_default, operator(==) - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value + use fpm_toml, only: toml_table, toml_key, toml_stat, get_value, check_keys use fpm_filesystem, only: windows_path use fpm_environment, only: get_os_type, OS_WINDOWS + use fpm_versioning, only: version_t, new_version implicit none private public :: dependency_config_t, new_dependency, new_dependencies, manifest_has_changed - !> Configuration meta data for a dependency type :: dependency_config_t @@ -44,6 +44,15 @@ module fpm_manifest_dependency !> Local target character(len=:), allocatable :: path + !> Namespace which the dependency belongs to. + !> Enables multiple dependencies with the same name. + !> Required for dependencies that are obtained via the official registry. + character(len=:), allocatable :: namespace + + !> The requested version of the dependency. + !> The latest version is used if not specified. + type(version_t), allocatable :: requested_version + !> Git descriptor type(git_target_t), allocatable :: git @@ -54,10 +63,8 @@ module fpm_manifest_dependency end type dependency_config_t - contains - !> Construct a new dependency configuration from a TOML data structure subroutine new_dependency(self, table, root, error) @@ -73,49 +80,59 @@ subroutine new_dependency(self, table, root, error) !> Error handling type(error_t), allocatable, intent(out) :: error - character(len=:), allocatable :: url, obj + character(len=:), allocatable :: uri, value, requested_version call check(table, error) if (allocated(error)) return call table%get_key(self%name) + call get_value(table, "namespace", self%namespace) - call get_value(table, "path", url) - if (allocated(url)) then - if (get_os_type() == OS_WINDOWS) url = windows_path(url) - if (present(root)) url = root//url ! Relative to the fpm.toml it’s written in - call move_alloc(url, self%path) - else - call get_value(table, "git", url) + call get_value(table, "path", uri) + if (allocated(uri)) then + if (get_os_type() == OS_WINDOWS) uri = windows_path(uri) + if (present(root)) uri = root//uri ! Relative to the fpm.toml it’s written in + call move_alloc(uri, self%path) + return + end if - call get_value(table, "tag", obj) - if (allocated(obj)) then - self%git = git_target_tag(url, obj) + call get_value(table, "git", uri) + if (allocated(uri)) then + call get_value(table, "tag", value) + if (allocated(value)) then + self%git = git_target_tag(uri, value) end if - if (.not.allocated(self%git)) then - call get_value(table, "branch", obj) - if (allocated(obj)) then - self%git = git_target_branch(url, obj) + if (.not. allocated(self%git)) then + call get_value(table, "branch", value) + if (allocated(value)) then + self%git = git_target_branch(uri, value) end if end if - if (.not.allocated(self%git)) then - call get_value(table, "rev", obj) - if (allocated(obj)) then - self%git = git_target_revision(url, obj) + if (.not. allocated(self%git)) then + call get_value(table, "rev", value) + if (allocated(value)) then + self%git = git_target_revision(uri, value) end if end if - if (.not.allocated(self%git)) then - self%git = git_target_default(url) + if (.not. allocated(self%git)) then + self%git = git_target_default(uri) end if + return + end if + call get_value(table, "v", requested_version) + + if (allocated(requested_version)) then + if (.not. allocated(self%requested_version)) allocate (self%requested_version) + call new_version(self%requested_version, requested_version, error) + if (allocated(error)) return end if end subroutine new_dependency - !> Check local schema for allowed entries subroutine check(table, error) @@ -125,72 +142,63 @@ subroutine check(table, error) !> Error handling type(error_t), allocatable, intent(out) :: error - character(len=:), allocatable :: name, url + character(len=:), allocatable :: name type(toml_key), allocatable :: list(:) - logical :: url_present, git_target_present, has_path - integer :: ikey - has_path = .false. - url_present = .false. - git_target_present = .false. + !> List of valid keys for the dependency table. + character(*), dimension(*), parameter :: valid_keys = [character(24) :: & + & "namespace", & + "v", & + "path", & + "git", & + "tag", & + "branch", & + "rev" & + & ] call table%get_key(name) call table%get_keys(list) if (size(list) < 1) then - call syntax_error(error, "Dependency "//name//" does not provide sufficient entries") + call syntax_error(error, "Dependency '"//name//"' does not provide sufficient entries") return end if - do ikey = 1, size(list) - select case(list(ikey)%key) - case default - call syntax_error(error, "Key "//list(ikey)%key//" is not allowed in dependency "//name) - exit - - case("git") - if (url_present) then - call syntax_error(error, "Dependency "//name//" cannot have both git and path entries") - exit - end if - call get_value(table, "git", url) - if (.not.allocated(url)) then - call syntax_error(error, "Dependency "//name//" has invalid git source") - exit - end if - url_present = .true. + call check_keys(table, valid_keys, error) + if (allocated(error)) return - case("path") - if (url_present) then - call syntax_error(error, "Dependency "//name//" cannot have both git and path entries") - exit - end if - url_present = .true. - has_path = .true. + if (table%has_key("path") .and. table%has_key("git")) then + call syntax_error(error, "Dependency '"//name//"' cannot have both git and path entries") + return + end if - case("branch", "rev", "tag") - if (git_target_present) then - call syntax_error(error, "Dependency "//name//" can only have one of branch, rev or tag present") - exit - end if - git_target_present = .true. + if ((table%has_key("branch") .and. table%has_key("rev")) .or. & + (table%has_key("branch") .and. table%has_key("tag")) .or. & + (table%has_key("rev") .and. table%has_key("tag"))) then + call syntax_error(error, "Dependency '"//name//"' can only have one of branch, rev or tag present") + return + end if - end select - end do - if (allocated(error)) return + if ((table%has_key("branch") .or. table%has_key("tag") .or. table%has_key("rev")) & + .and. .not. table%has_key("git")) then + call syntax_error(error, "Dependency '"//name//"' has git identifier but no git url") + return + end if - if (.not.url_present) then - call syntax_error(error, "Dependency "//name//" does not provide a method to actually retrieve itself") + if (.not. table%has_key("path") .and. .not. table%has_key("git") & + .and. .not. table%has_key("namespace")) then + call syntax_error(error, "Please provide a 'namespace' for dependency '"//name// & + & "' if it is not a local path or git repository") return end if - if (has_path .and. git_target_present) then - call syntax_error(error, "Dependency "//name//" uses a local path, therefore no git identifiers are allowed") + if (table%has_key('v') .and. (table%has_key('path') .or. table%has_key('git'))) then + call syntax_error(error, "Dependency '"//name//"' cannot have both v and git/path entries") + return end if end subroutine check - !> Construct new dependency array from a TOML data structure subroutine new_dependencies(deps, table, root, error) @@ -214,7 +222,7 @@ subroutine new_dependencies(deps, table, root, error) ! An empty table is okay if (size(list) < 1) return - allocate(deps(size(list))) + allocate (deps(size(list))) do idep = 1, size(list) call get_value(table, list(idep)%key, node, stat=stat) if (stat /= toml_stat%success) then @@ -227,7 +235,6 @@ subroutine new_dependencies(deps, table, root, error) end subroutine new_dependencies - !> Write information on instance subroutine info(self, unit, verbosity) @@ -249,19 +256,19 @@ subroutine info(self, unit, verbosity) pr = 1 end if - write(unit, fmt) "Dependency" + write (unit, fmt) "Dependency" if (allocated(self%name)) then - write(unit, fmt) "- name", self%name + write (unit, fmt) "- name", self%name end if if (allocated(self%git)) then - write(unit, fmt) "- kind", "git" + write (unit, fmt) "- kind", "git" call self%git%info(unit, pr - 1) end if if (allocated(self%path)) then - write(unit, fmt) "- kind", "local" - write(unit, fmt) "- path", self%path + write (unit, fmt) "- kind", "local" + write (unit, fmt) "- path", self%path end if end subroutine info diff --git a/src/fpm/toml.f90 b/src/fpm/toml.f90 index 3c1dfaa175..f8d8ea2420 100644 --- a/src/fpm/toml.f90 +++ b/src/fpm/toml.f90 @@ -13,23 +13,20 @@ !> For more details on the library used see the !> [TOML-Fortran](https://toml-f.github.io/toml-f) developer pages. module fpm_toml - use fpm_error, only : error_t, fatal_error, file_not_found_error - use fpm_strings, only : string_t - use tomlf, only : toml_table, toml_array, toml_key, toml_stat, get_value, & - & set_value, toml_load, toml_error, new_table, add_table, add_array, & - & toml_serialize, len + use fpm_error, only: error_t, fatal_error, file_not_found_error + use fpm_strings, only: string_t + 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, & + & toml_serialize, len, toml_load implicit none private - public :: read_package_file - public :: toml_table, toml_array, toml_key, toml_stat, get_value, set_value, get_list - public :: new_table, add_table, add_array, len - public :: toml_error, toml_serialize, toml_load - + public :: read_package_file, toml_table, toml_array, toml_key, toml_stat, & + get_value, set_value, get_list, new_table, add_table, add_array, len, & + toml_error, toml_serialize, toml_load, check_keys contains - !> Process the configuration file to a TOML data structure subroutine read_package_file(table, manifest, error) @@ -46,9 +43,9 @@ subroutine read_package_file(table, manifest, error) integer :: unit logical :: exist - inquire(file=manifest, exist=exist) + inquire (file=manifest, exist=exist) - if (.not.exist) then + if (.not. exist) then call file_not_found_error(error, manifest) return end if @@ -58,14 +55,13 @@ subroutine read_package_file(table, manifest, error) close(unit) if (allocated(parse_error)) then - allocate(error) + allocate (error) call move_alloc(parse_error%message, error%message) return end if end subroutine read_package_file - subroutine get_list(table, key, list, error) !> Instance of the TOML data structure @@ -89,7 +85,7 @@ subroutine get_list(table, key, list, error) call get_value(table, key, children, requested=.false.) if (associated(children)) then nlist = len(children) - allocate(list(nlist)) + allocate (list(nlist)) do ilist = 1, nlist call get_value(children, ilist, str, stat=stat) if (stat /= toml_stat%success) then @@ -106,12 +102,56 @@ subroutine get_list(table, key, list, error) return end if if (allocated(str)) then - allocate(list(1)) + allocate (list(1)) call move_alloc(str, list(1)%s) end if end if end subroutine get_list + !> Check if table contains only keys that are part of the list. If a key is + !> found that is not part of the list, an error is allocated. + subroutine check_keys(table, valid_keys, error) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> List of keys to check. + character(len=*), intent(in) :: valid_keys(:) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: keys(:) + character(:), allocatable :: name, value, valid_keys_string + integer :: ikey, ivalid + + call table%get_key(name) + call table%get_keys(keys) + + do ikey = 1, size(keys) + if (.not. any(keys(ikey)%key == valid_keys)) then + ! Generate error message + valid_keys_string = new_line('a')//new_line('a') + do ivalid = 1, size(valid_keys) + valid_keys_string = valid_keys_string//trim(valid_keys(ivalid))//new_line('a') + end do + allocate (error) + error%message = "Key '"//keys(ikey)%key//"' not allowed in the '"// & + & name//"' table."//new_line('a')//new_line('a')//'Valid keys: '//valid_keys_string + return + end if + + ! Check if value can be mapped or else (wrong type) show error message with the error location. + ! Right now, it can only be mapped to a string, but this can be extended in the future. + call get_value(table, keys(ikey)%key, value) + if (.not. allocated(value)) then + allocate (error) + error%message = "'"//name//"' has an invalid '"//keys(ikey)%key//"' entry." + return + end if + end do + + end subroutine check_keys end module fpm_toml diff --git a/src/fpm/versioning.f90 b/src/fpm/versioning.f90 index da362eeee4..4c7c01712a 100644 --- a/src/fpm/versioning.f90 +++ b/src/fpm/versioning.f90 @@ -4,7 +4,7 @@ module fpm_versioning implicit none private - public :: version_t, new_version, char + public :: version_t, new_version type :: version_t @@ -38,7 +38,7 @@ module fpm_versioning procedure, private :: match !> Create a printable string from a version data type - procedure :: to_string + procedure :: s end type version_t @@ -47,11 +47,6 @@ 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 @@ -220,13 +215,13 @@ subroutine token_error(error, string, istart, iend, message) end subroutine token_error - subroutine to_string(self, string) + pure function s(self) result(string) !> Version number class(version_t), intent(in) :: self !> Character representation of the version - character(len=:), allocatable, intent(out) :: string + character(len=:), allocatable :: string integer, parameter :: buffersize = 64 character(len=buffersize) :: buffer @@ -246,20 +241,7 @@ subroutine to_string(self, string) string = '0' end if - 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 + end function s !> Check to version numbers for equality @@ -317,16 +299,17 @@ elemental function greater(lhs, rhs) result(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 + if (lhs%num(ii) /= rhs%num(ii)) then + is_greater = lhs%num(ii) > rhs%num(ii) + return + end if 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 + if (is_greater) return end do end if diff --git a/src/fpm_command_line.f90 b/src/fpm_command_line.f90 index 659acd1950..985d8892a2 100644 --- a/src/fpm_command_line.f90 +++ b/src/fpm_command_line.f90 @@ -52,10 +52,11 @@ module fpm_command_line type, abstract :: fpm_cmd_settings character(len=:), allocatable :: working_dir - logical :: verbose=.true. + logical :: verbose=.true. end type integer,parameter :: ibug=4096 + type, extends(fpm_cmd_settings) :: fpm_new_settings character(len=:),allocatable :: name logical :: with_executable=.false. diff --git a/src/fpm_compiler.F90 b/src/fpm_compiler.F90 index 68b9c4af96..0b70d3ca2f 100644 --- a/src/fpm_compiler.F90 +++ b/src/fpm_compiler.F90 @@ -232,7 +232,6 @@ subroutine get_release_compile_flags(id, flags) integer(compiler_enum), intent(in) :: id character(len=:), allocatable, intent(out) :: flags - select case(id) case default flags = "" diff --git a/src/fpm_filesystem.F90 b/src/fpm_filesystem.F90 index 36c4127089..3846654354 100644 --- a/src/fpm_filesystem.F90 +++ b/src/fpm_filesystem.F90 @@ -8,17 +8,13 @@ module fpm_filesystem use fpm_environment, only: separator, get_env, os_is_unix use fpm_strings, only: f_string, replace, string_t, split, notabs, str_begins_with_str use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer - use fpm_error, only : fpm_stop + use fpm_error, only : fpm_stop, error_t, fatal_error implicit none private - public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, list_files, env_variable, & - mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file - public :: fileopen, fileclose, filewrite, warnwrite, parent_dir - public :: is_hidden_file - public :: read_lines, read_lines_expanded - public :: which, run, LINE_BUFFER_LEN - public :: os_delete_dir - + public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, list_files, get_local_prefix, & + mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file, fileopen, fileclose, & + filewrite, warnwrite, parent_dir, is_hidden_file, read_lines, read_lines_expanded, which, run, & + LINE_BUFFER_LEN, os_delete_dir, is_absolute_path, env_variable, get_home integer, parameter :: LINE_BUFFER_LEN = 1000 #ifndef FPM_BOOTSTRAP @@ -944,4 +940,84 @@ subroutine os_delete_dir(unix, dir, echo) end subroutine os_delete_dir + !> Determine the path prefix to the local folder. Used for installation, registry etc. + function get_local_prefix(os) result(prefix) + !> Installation prefix + character(len=:), allocatable :: prefix + !> Platform identifier + integer, intent(in), optional :: os + + !> Default installation prefix on Unix platforms + character(len=*), parameter :: default_prefix_unix = "/usr/local" + !> Default installation prefix on Windows platforms + character(len=*), parameter :: default_prefix_win = "C:\" + + character(len=:), allocatable :: home + + if (os_is_unix(os)) then + call env_variable(home, "HOME") + if (allocated(home)) then + prefix = join_path(home, ".local") + else + prefix = default_prefix_unix + end if + else + call env_variable(home, "APPDATA") + if (allocated(home)) then + prefix = join_path(home, "local") + else + prefix = default_prefix_win + end if + end if + + end function get_local_prefix + + !> Returns .true. if provided path is absolute. + !> + !> `~` not treated as absolute. + logical function is_absolute_path(path, is_unix) + character(len=*), intent(in) :: path + logical, optional, intent(in):: is_unix + character(len=*), parameter :: letters = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + logical :: is_unix_os + + if (present(is_unix)) then + is_unix_os = is_unix + else + is_unix_os = os_is_unix() + end if + + if (is_unix_os) then + is_absolute_path = path(1:1) == '/' + else + if (len(path) < 2) then + is_absolute_path = .false. + return + end if + + is_absolute_path = index(letters, path(1:1)) /= 0 .and. path(2:2) == ':' + end if + + end function is_absolute_path + + !> Get the HOME directory on Unix and the %USERPROFILE% directory on Windows. + subroutine get_home(home, error) + character(len=:), allocatable, intent(out) :: home + type(error_t), allocatable, intent(out) :: error + + if (os_is_unix()) then + call env_variable(home, 'HOME') + if (.not. allocated(home)) then + call fatal_error(error, "Couldn't retrieve 'HOME' variable") + return + end if + else + call env_variable(home, 'USERPROFILE') + if (.not. allocated(home)) then + call fatal_error(error, "Couldn't retrieve '%USERPROFILE%' variable") + return + end if + end if + end subroutine get_home + end module fpm_filesystem diff --git a/src/fpm_os.F90 b/src/fpm_os.F90 index 71663fe17c..1acd9653ae 100644 --- a/src/fpm_os.F90 +++ b/src/fpm_os.F90 @@ -1,9 +1,13 @@ module fpm_os - use, intrinsic :: iso_c_binding, only : c_char, c_int, c_null_char, c_ptr, c_associated - use fpm_error, only : error_t, fatal_error + use, intrinsic :: iso_c_binding, only: c_char, c_int, c_null_char, c_ptr, c_associated + use fpm_filesystem, only: exists, join_path, get_home + use fpm_environment, only: os_is_unix + use fpm_error, only: error_t, fatal_error implicit none private - public :: change_directory, get_current_directory + public :: change_directory, get_current_directory, get_absolute_path, convert_to_absolute_path + + integer(c_int), parameter :: buffersize = 1000_c_int #ifndef _WIN32 character(len=*), parameter :: pwd_env = "PWD" @@ -12,28 +16,47 @@ module fpm_os #endif interface - function chdir(path) result(stat) & + function chdir_(path) result(stat) & #ifndef _WIN32 - bind(C, name="chdir") + bind(C, name="chdir") #else - bind(C, name="_chdir") + bind(C, name="_chdir") #endif import :: c_char, c_int character(kind=c_char, len=1), intent(in) :: path(*) integer(c_int) :: stat - end function chdir + end function chdir_ - function getcwd(buf, bufsize) result(path) & + function getcwd_(buf, bufsize) result(path) & #ifndef _WIN32 - bind(C, name="getcwd") + bind(C, name="getcwd") #else - bind(C, name="_getcwd") + bind(C, name="_getcwd") #endif import :: c_char, c_int, c_ptr character(kind=c_char, len=1), intent(in) :: buf(*) integer(c_int), value, intent(in) :: bufsize type(c_ptr) :: path - end function getcwd + end function getcwd_ + + !> Determine the absolute, canonicalized path for a given path. Unix-only. + function realpath(path, resolved_path) result(ptr) bind(C) + import :: c_ptr, c_char, c_int + character(kind=c_char, len=1), intent(in) :: path(*) + character(kind=c_char, len=1), intent(out) :: resolved_path(*) + type(c_ptr) :: ptr + end function realpath + + !> Determine the absolute, canonicalized path for a given path. + !> Calls custom C routine and is able to distinguish between Unix and Windows. + function c_realpath(path, resolved_path, maxLength) result(ptr) & + bind(C, name="c_realpath") + import :: c_ptr, c_char, c_int + character(kind=c_char, len=1), intent(in) :: path(*) + character(kind=c_char, len=1), intent(out) :: resolved_path(*) + integer(c_int), value, intent(in) :: maxLength + type(c_ptr) :: ptr + end function c_realpath end interface contains @@ -45,10 +68,10 @@ subroutine change_directory(path, error) character(kind=c_char, len=1), allocatable :: cpath(:) integer :: stat - allocate(cpath(len(path)+1)) - call f_c_character(path, cpath, len(path)+1) + allocate (cpath(len(path) + 1)) + call f_c_character(path, cpath, len(path) + 1) - stat = chdir(cpath) + stat = chdir_(cpath) if (stat /= 0) then call fatal_error(error, "Failed to change directory to '"//path//"'") @@ -60,12 +83,11 @@ subroutine get_current_directory(path, error) type(error_t), allocatable, intent(out) :: error character(kind=c_char, len=1), allocatable :: cpath(:) - integer(c_int), parameter :: buffersize = 1000_c_int type(c_ptr) :: tmp - allocate(cpath(buffersize)) + allocate (cpath(buffersize)) - tmp = getcwd(cpath, buffersize) + tmp = getcwd_(cpath, buffersize) if (c_associated(tmp)) then call c_f_character(cpath, path) else @@ -79,10 +101,10 @@ subroutine f_c_character(rhs, lhs, len) character(len=*), intent(in) :: rhs integer, intent(in) :: len integer :: length - length = min(len-1, len_trim(rhs)) + length = min(len - 1, len_trim(rhs)) lhs(1:length) = transfer(rhs(1:length), lhs(1:length)) - lhs(length+1:length+1) = c_null_char + lhs(length + 1:length + 1) = c_null_char end subroutine f_c_character @@ -97,9 +119,110 @@ subroutine c_f_character(rhs, lhs) exit end if end do - allocate(character(len=ii-1) :: lhs) - lhs = transfer(rhs(1:ii-1), lhs) + + allocate (character(len=ii - 1) :: lhs) + lhs = transfer(rhs(1:ii - 1), lhs) end subroutine c_f_character + !> Determine the canonical, absolute path for the given path. + subroutine get_realpath(path, real_path, error) + character(len=*), intent(in) :: path + character(len=:), allocatable, intent(out) :: real_path + type(error_t), allocatable, intent(out) :: error + + character(kind=c_char, len=1), allocatable :: appended_path(:) + character(kind=c_char, len=1), allocatable :: cpath(:) + type(c_ptr) :: ptr + + if (.not. exists(path)) then + call fatal_error(error, "Cannot determine absolute path. Path '"//path//"' does not exist.") + return + end if + + allocate (appended_path(len(path) + 1)) + call f_c_character(path, appended_path, len(path) + 1) + + allocate (cpath(buffersize)) + +! The _WIN32 macro is currently not exported using gfortran. +#if defined(FPM_BOOTSTRAP) && !defined(_WIN32) + ptr = realpath(appended_path, cpath) +#else + ptr = c_realpath(appended_path, cpath, buffersize) +#endif + + if (c_associated(ptr)) then + call c_f_character(cpath, real_path) + else + call fatal_error(error, "Failed to retrieve absolute path for '"//path//"'.") + end if + + end subroutine get_realpath + + !> Determine the canonical, absolute path for the given path. + !> Expands home folder (~) on both Unix and Windows. + subroutine get_absolute_path(path, absolute_path, error) + character(len=*), intent(in) :: path + character(len=:), allocatable, intent(out) :: absolute_path + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: home + + if (len_trim(path) < 1) then + ! Empty path + call fatal_error(error, 'Path cannot be empty') + return + else if (path(1:1) == '~') then + ! Expand home + call get_home(home, error) + if (allocated(error)) return + + if (len_trim(path) == 1) then + absolute_path = home + return + end if + + if (os_is_unix()) then + if (path(2:2) /= '/') then + call fatal_error(error, "Wrong separator in path: '"//path//"'") + return + end if + else + if (path(2:2) /= '\') then + call fatal_error(error, "Wrong separator in path: '"//path//"'") + return + end if + end if + + if (len_trim(path) == 2) then + absolute_path = home + return + end if + + absolute_path = join_path(home, path(3:len_trim(path))) + + if (.not. exists(absolute_path)) then + call fatal_error(error, "Path not found: '"//absolute_path//"'") + deallocate (absolute_path) + return + end if + else + ! Get canonicalized absolute path from either the absolute or the relative path. + call get_realpath(path, absolute_path, error) + end if + + end subroutine + + !> Converts a path to an absolute, canonical path. + subroutine convert_to_absolute_path(path, error) + character(len=*), intent(inout) :: path + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: absolute_path + + call get_absolute_path(path, absolute_path, error) + path = absolute_path + end subroutine + end module fpm_os diff --git a/src/fpm_os.c b/src/fpm_os.c new file mode 100644 index 0000000000..2d417a0695 --- /dev/null +++ b/src/fpm_os.c @@ -0,0 +1,16 @@ +#include + +/// @brief Determine the absolute, canonicalized path for a given path. +/// @param path +/// @param resolved_path +/// @param maxLength +/// @return +int c_realpath(char* path, char* resolved_path, int maxLength) { +// Checking macro in C because it doesn't work with gfortran on Windows, even +// when exported manually. +#ifndef _WIN32 + return realpath(path, resolved_path); +#else + return _fullpath(resolved_path, path, maxLength); +#endif +} diff --git a/src/fpm_settings.f90 b/src/fpm_settings.f90 new file mode 100644 index 0000000000..cc53df2f7d --- /dev/null +++ b/src/fpm_settings.f90 @@ -0,0 +1,231 @@ +!> Manages global settings which are defined in the global config file. +module fpm_settings + use fpm_filesystem, only: exists, join_path, get_local_prefix, is_absolute_path, mkdir + use fpm_environment, only: os_is_unix + use fpm_error, only: error_t, fatal_error + use fpm_toml, only: toml_table, toml_error, toml_stat, get_value, toml_load, check_keys + use fpm_os, only: get_current_directory, change_directory, get_absolute_path, & + convert_to_absolute_path + implicit none + private + public :: fpm_global_settings, get_global_settings, get_registry_settings, official_registry_base_url + + character(*), parameter :: official_registry_base_url = 'https://fpm-registry.onrender.com' + + type :: fpm_global_settings + !> Path to the global config file excluding the file name. + character(len=:), allocatable :: path_to_config_folder + !> Name of the global config file. The default is `config.toml`. + character(len=:), allocatable :: config_file_name + !> Registry configs. + type(fpm_registry_settings), allocatable :: registry_settings + contains + procedure :: has_custom_location, full_path + end type + + type :: fpm_registry_settings + !> The path to the local registry. If allocated, the local registry + !> will be used instead of the remote registry and replaces the + !> local cache. + character(len=:), allocatable :: path + !> The URL to the remote registry. Can be used to get packages + !> from the official or a custom registry. + character(len=:), allocatable :: url + !> The path to the cache folder. If not specified, the default cache + !> folders are `~/.local/share/fpm/dependencies` on Unix and + !> `%APPDATA%\local\fpm\dependencies` on Windows. + !> Cannot be used together with `path`. + character(len=:), allocatable :: cache_path + end type + +contains + !> Obtain global settings from the global config file. + subroutine get_global_settings(global_settings, error) + !> Global settings to be obtained. + type(fpm_global_settings), intent(inout) :: global_settings + !> Error reading config file. + type(error_t), allocatable, intent(out) :: error + !> TOML table to be filled with global config settings. + type(toml_table), allocatable :: table + !> Error parsing to TOML table. + type(toml_error), allocatable :: parse_error + + type(toml_table), pointer :: registry_table + integer :: stat + + ! Use custom path to the config file if it was specified. + if (global_settings%has_custom_location()) then + ! Throw error if folder doesn't exist. + if (.not. exists(global_settings%path_to_config_folder)) then + call fatal_error(error, "Folder not found: '"//global_settings%path_to_config_folder//"'."); return + end if + + ! Throw error if the file doesn't exist. + if (.not. exists(global_settings%full_path())) then + call fatal_error(error, "File not found: '"//global_settings%full_path()//"'."); return + end if + + ! Make sure that the path to the global config file is absolute. + call convert_to_absolute_path(global_settings%path_to_config_folder, error) + if (allocated(error)) return + else + ! Use default path if it wasn't specified. + if (os_is_unix()) then + global_settings%path_to_config_folder = join_path(get_local_prefix(), 'share', 'fpm') + else + global_settings%path_to_config_folder = join_path(get_local_prefix(), 'fpm') + end if + + ! Use default file name. + global_settings%config_file_name = 'config.toml' + + ! Apply default registry settings and return if config file doesn't exist. + if (.not. exists(global_settings%full_path())) then + call use_default_registry_settings(global_settings); return + end if + end if + + ! Load into TOML table. + call toml_load(table, global_settings%full_path(), error=parse_error) + + if (allocated(parse_error)) then + allocate (error); call move_alloc(parse_error%message, error%message); return + end if + + call get_value(table, 'registry', registry_table, requested=.false., stat=stat) + + if (stat /= toml_stat%success) then + call fatal_error(error, "Error reading registry from config file '"// & + & global_settings%full_path()//"'."); return + end if + + ! A registry table was found. + if (associated(registry_table)) then + call get_registry_settings(registry_table, global_settings, error) + else + call use_default_registry_settings(global_settings) + end if + + end subroutine get_global_settings + + !> Default registry settings are typically applied if the config file doesn't exist or no registry table was found in + !> the global config file. + subroutine use_default_registry_settings(global_settings) + type(fpm_global_settings), intent(inout) :: global_settings + + allocate (global_settings%registry_settings) + global_settings%registry_settings%url = official_registry_base_url + global_settings%registry_settings%cache_path = join_path(global_settings%path_to_config_folder, & + & 'dependencies') + end subroutine use_default_registry_settings + + !> Read registry settings from the global config file. + subroutine get_registry_settings(table, global_settings, error) + !> The [registry] subtable from the global config file. + type(toml_table), target, intent(inout) :: table + !> The global settings which can be filled with the registry settings. + type(fpm_global_settings), intent(inout) :: global_settings + !> Error handling. + type(error_t), allocatable, intent(out) :: error + + character(:), allocatable :: path, url, cache_path + integer :: stat + + !> List of valid keys for the dependency table. + character(*), dimension(*), parameter :: valid_keys = [character(10) :: & + & 'path', & + & 'url', & + & 'cache_path' & + & ] + + call check_keys(table, valid_keys, error) + if (allocated(error)) return + + allocate (global_settings%registry_settings) + + if (table%has_key('path')) then + call get_value(table, 'path', path, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Error reading registry path: '"//path//"'."); return + end if + end if + + if (allocated(path)) then + if (is_absolute_path(path)) then + global_settings%registry_settings%path = path + else + ! Get canonical, absolute path on both Unix and Windows. + call get_absolute_path(join_path(global_settings%path_to_config_folder, path), & + & global_settings%registry_settings%path, error) + if (allocated(error)) return + + ! Check if the path to the registry exists. + if (.not. exists(global_settings%registry_settings%path)) then + call fatal_error(error, "Directory '"//global_settings%registry_settings%path// & + & "' doesn't exist."); return + end if + end if + end if + + if (table%has_key('url')) then + call get_value(table, 'url', url, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Error reading registry url: '"//url//"'."); return + end if + end if + + if (allocated(url)) then + ! Throw error when both path and url were provided. + if (allocated(path)) then + call fatal_error(error, 'Do not provide both path and url to the registry.'); return + end if + global_settings%registry_settings%url = url + else if (.not. allocated(path)) then + global_settings%registry_settings%url = official_registry_base_url + end if + + if (table%has_key('cache_path')) then + call get_value(table, 'cache_path', cache_path, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Error reading path to registry cache: '"//cache_path//"'."); return + end if + end if + + if (allocated(cache_path)) then + ! Throw error when both path and cache_path were provided. + if (allocated(path)) then + call fatal_error(error, "Do not provide both 'path' and 'cache_path'."); return + end if + + if (is_absolute_path(cache_path)) then + if (.not. exists(cache_path)) call mkdir(cache_path) + global_settings%registry_settings%cache_path = cache_path + else + cache_path = join_path(global_settings%path_to_config_folder, cache_path) + if (.not. exists(cache_path)) call mkdir(cache_path) + ! Get canonical, absolute path on both Unix and Windows. + call get_absolute_path(cache_path, global_settings%registry_settings%cache_path, error) + if (allocated(error)) return + end if + else if (.not. allocated(path)) then + global_settings%registry_settings%cache_path = join_path(global_settings%path_to_config_folder, & + & 'dependencies') + end if + end subroutine get_registry_settings + + !> True if the global config file is not at the default location. + pure logical function has_custom_location(self) + class(fpm_global_settings), intent(in) :: self + + has_custom_location = allocated(self%path_to_config_folder) .and. allocated(self%config_file_name) + end function + + !> The full path to the global config file. + function full_path(self) result(result) + class(fpm_global_settings), intent(in) :: self + character(len=:), allocatable :: result + + result = join_path(self%path_to_config_folder, self%config_file_name) + end function + +end module fpm_settings diff --git a/src/fpm_targets.f90 b/src/fpm_targets.f90 index e7ec525c09..ddd34cd7d4 100644 --- a/src/fpm_targets.f90 +++ b/src/fpm_targets.f90 @@ -41,7 +41,7 @@ module fpm_targets FPM_TARGET_C_OBJECT, FPM_TARGET_CPP_OBJECT public build_target_t, build_target_ptr public targets_from_sources, resolve_module_dependencies -public resolve_target_linking, add_target, add_dependency +public add_target, add_dependency public filter_library_targets, filter_executable_targets, filter_modules diff --git a/test/cli_test/cli_test.f90 b/test/cli_test/cli_test.f90 index 4fa8e3acf2..9f82cb7056 100644 --- a/test/cli_test/cli_test.f90 +++ b/test/cli_test/cli_test.f90 @@ -206,7 +206,7 @@ subroutine parse() fpm_clean_settings, & fpm_install_settings, & get_command_line_settings -use fpm, only: cmd_build, cmd_run, cmd_clean +use fpm, only: cmd_run, cmd_clean use fpm_cmd_install, only: cmd_install use fpm_cmd_new, only: cmd_new class(fpm_cmd_settings), allocatable :: cmd_settings diff --git a/test/fpm_test/main.f90 b/test/fpm_test/main.f90 index 0a653076d6..be97e4d70f 100644 --- a/test/fpm_test/main.f90 +++ b/test/fpm_test/main.f90 @@ -1,8 +1,7 @@ !> Driver for unit testing program fpm_testing use, intrinsic :: iso_fortran_env, only : error_unit - use testsuite, only : run_testsuite, new_testsuite, testsuite_t, & - & select_suite, run_selected + use testsuite, only : run_testsuite, new_testsuite, testsuite_t, select_suite, run_selected use test_toml, only : collect_toml use test_manifest, only : collect_manifest use test_filesystem, only : collect_filesystem @@ -12,6 +11,9 @@ program fpm_testing use test_backend, only: collect_backend use test_installer, only : collect_installer use test_versioning, only : collect_versioning + use test_settings, only : collect_settings + use test_os, only: collect_os + implicit none integer :: stat, is character(len=:), allocatable :: suite_name, test_name @@ -29,7 +31,9 @@ program fpm_testing & new_testsuite("fpm_package_dependencies", collect_package_dependencies), & & new_testsuite("fpm_test_backend", collect_backend), & & new_testsuite("fpm_installer", collect_installer), & - & new_testsuite("fpm_versioning", collect_versioning) & + & new_testsuite("fpm_versioning", collect_versioning), & + & new_testsuite("fpm_settings", collect_settings), & + & new_testsuite("fpm_os", collect_os) & & ] call get_argument(1, suite_name) @@ -80,21 +84,21 @@ subroutine get_argument(idx, arg) !> Command line argument character(len=:), allocatable, intent(out) :: arg - integer :: length, stat + integer :: length, arg_stat - call get_command_argument(idx, length=length, status=stat) - if (stat /= 0) then + call get_command_argument(idx, length=length, status=arg_stat) + if (arg_stat /= 0) then return endif - allocate(character(len=length) :: arg, stat=stat) - if (stat /= 0) then + allocate(character(len=length) :: arg, stat=arg_stat) + if (arg_stat /= 0) then return endif if (length > 0) then - call get_command_argument(idx, arg, status=stat) - if (stat /= 0) then + call get_command_argument(idx, arg, status=arg_stat) + if (arg_stat /= 0) then deallocate(arg) return end if diff --git a/test/fpm_test/test_filesystem.f90 b/test/fpm_test/test_filesystem.f90 index b6b7681706..ad6e86d853 100644 --- a/test/fpm_test/test_filesystem.f90 +++ b/test/fpm_test/test_filesystem.f90 @@ -1,7 +1,7 @@ module test_filesystem - use testsuite, only : new_unittest, unittest_t, error_t, test_failed + use testsuite, only: new_unittest, unittest_t, error_t, test_failed use fpm_filesystem, only: canon_path, is_dir, mkdir, os_delete_dir, & - join_path + join_path, is_absolute_path, get_home use fpm_environment, only: OS_WINDOWS, get_os_type, os_is_unix implicit none private @@ -10,21 +10,21 @@ module test_filesystem contains - !> Collect all exported unit tests - subroutine collect_filesystem(testsuite) + subroutine collect_filesystem(tests) !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) + type(unittest_t), allocatable, intent(out) :: tests(:) - testsuite = [ & + tests = [ & & new_unittest("canon-path", test_canon_path), & - & new_unittest("create-delete-directory", test_mkdir_rmdir) & + & new_unittest("create-delete-directory", test_mkdir_rmdir), & + & new_unittest("test-is-absolute-path", test_is_absolute_path), & + & new_unittest("test-get-home", test_get_home) & ] end subroutine collect_filesystem - subroutine test_canon_path(error) !> Error handling @@ -84,7 +84,6 @@ subroutine test_canon_path(error) end subroutine test_canon_path - !> Check a character variable against a reference value subroutine check_string(error, actual, expected) @@ -99,19 +98,18 @@ subroutine check_string(error, actual, expected) if (actual /= expected) then call test_failed(error, & - "Character value mismatch "//& - "expected '"//expected//"' but got '"//actual//"'") + "Character value mismatch "// & + "expected '"//expected//"' but got '"//actual//"'") end if end subroutine check_string - subroutine test_mkdir_rmdir(error) !> Error handling type(error_t), allocatable, intent(out) :: error - call check_mkdir(error, join_path("tmpdir","subdir")) + call check_mkdir(error, join_path("tmpdir", "subdir")) if (allocated(error)) return call check_rmdir(error, "tmpdir") @@ -119,7 +117,6 @@ subroutine test_mkdir_rmdir(error) end subroutine test_mkdir_rmdir - !> Create a directory and verify its existence subroutine check_mkdir(error, path) @@ -132,7 +129,7 @@ subroutine check_mkdir(error, path) ! Directory shouldn't exist before it's created if (is_dir(path)) then call test_failed(error, & - "Directory path "//path//" already exists before its creation") + "Directory path "//path//" already exists before its creation") return end if @@ -140,13 +137,12 @@ subroutine check_mkdir(error, path) call mkdir(path) ! Check that directory is indeed created - if (.not.is_dir(path)) then + if (.not. is_dir(path)) then call test_failed(error, & - "Directory path "//path//" cannot be created") + "Directory path "//path//" cannot be created") end if - end subroutine check_mkdir - + end subroutine check_mkdir !> Create a directory and verify its existence subroutine check_rmdir(error, path) @@ -160,20 +156,138 @@ subroutine check_rmdir(error, path) ! Directory should exist before it's deleted if (.not. is_dir(path)) then call test_failed(error, & - "Directory path "//path//" doesn't exist before its deletion") + "Directory path "//path//" doesn't exist before its deletion") return end if ! Delete directory - call os_delete_dir(os_is_unix(),path) + call os_delete_dir(os_is_unix(), path) ! Check that directory is indeed deleted if (is_dir(path)) then call test_failed(error, & - "Directory path "//path//" cannot be deleted") + "Directory path "//path//" cannot be deleted") + end if + + end subroutine check_rmdir + + subroutine test_is_absolute_path(error) + type(error_t), allocatable, intent(out) :: error + + ! Unix tests + if (is_absolute_path('.', is_unix=.true.)) then + call test_failed(error, "Path '.' isn't absolute") + return + end if + + if (is_absolute_path('abc', is_unix=.true.)) then + call test_failed(error, "Path 'abc' isn't absolute") + return + end if + + if (is_absolute_path('~a', is_unix=.true.)) then + call test_failed(error, "Path '~a' isn't absolute") + return + end if + + if (is_absolute_path('C:', is_unix=.true.)) then + call test_failed(error, "Path 'C:' isn't absolute on Unix") + return + end if + + if (is_absolute_path('~', is_unix=.true.)) then + call test_failed(error, "Path '~' isn't absolute") + return + end if + + if (is_absolute_path('~/', is_unix=.true.)) then + call test_failed(error, "Path '~/' isn't absolute") + return + end if + + if (.not. is_absolute_path('/', is_unix=.true.)) then + call test_failed(error, "Path '/' is absolute") + return + end if + + if (.not. is_absolute_path('/a', is_unix=.true.)) then + call test_failed(error, "Path '/a' is absolute") + return + end if + + ! Windows tests + if (is_absolute_path('abc', is_unix=.false.)) then + call test_failed(error, "Path 'abc' isn't absolute") + return + end if + + if (is_absolute_path('..', is_unix=.false.)) then + call test_failed(error, "Path '..' isn't absolute") + return + end if + + if (is_absolute_path('~', is_unix=.false.)) then + call test_failed(error, "Path '~' isn't absolute") + return + end if + + if (is_absolute_path('/', is_unix=.false.)) then + call test_failed(error, "Path '/' isn't absolute on Windows") + return + end if + + if (is_absolute_path('c/', is_unix=.false.)) then + call test_failed(error, "Path 'c/' isn't absolute") + return end if - end subroutine check_rmdir + if (is_absolute_path('1:', is_unix=.false.)) then + call test_failed(error, "Path '1:' isn't absolute") + return + end if + + if (is_absolute_path('C', is_unix=.false.)) then + call test_failed(error, "Path 'C' isn't absolute") + return + end if + + if (.not. is_absolute_path('C:', is_unix=.false.)) then + call test_failed(error, "Path 'C:' is absolute") + return + end if + + if (.not. is_absolute_path('x:', is_unix=.false.)) then + call test_failed(error, "Path 'x:' is absolute") + return + end if + + if (.not. is_absolute_path('x:xyz', is_unix=.false.)) then + call test_failed(error, "Path 'x:xyz' is absolute") + return + end if + + end subroutine test_is_absolute_path + + subroutine test_get_home(error) + type(error_t), allocatable, intent(out) :: error + character(len=:), allocatable :: home + character(len=*), parameter :: letters = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + + call get_home(home, error) + if (allocated(error)) return + + if (os_is_unix()) then + if (home(1:1) /= '/') then + call test_failed(error, "This doesn't seem to be the correct home path: '"//home//"'") + return + end if + else + if (index(letters, home(1:1)) == 0 .or. home(2:2) /= ':') then + call test_failed(error, "This doesn't seem to be the correct home path: '"//home//"'") + return + end if + end if + end subroutine test_get_home end module test_filesystem diff --git a/test/fpm_test/test_manifest.f90 b/test/fpm_test/test_manifest.f90 index 820d6889ea..ccb401b7c6 100644 --- a/test/fpm_test/test_manifest.f90 +++ b/test/fpm_test/test_manifest.f90 @@ -1,27 +1,23 @@ !> Define tests for the `fpm_manifest` modules module test_manifest use fpm_filesystem, only: get_temp_filename - use testsuite, only : new_unittest, unittest_t, error_t, test_failed, & - & check_string + use testsuite, only : new_unittest, unittest_t, error_t, test_failed, check_string use fpm_manifest use fpm_manifest_profile, only: profile_config_t, find_profile use fpm_strings, only: operator(.in.) implicit none private - public :: collect_manifest - contains - !> Collect all exported unit tests - subroutine collect_manifest(testsuite) + subroutine collect_manifest(tests) !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) + type(unittest_t), allocatable, intent(out) :: tests(:) - testsuite = [ & + tests = [ & & new_unittest("valid-manifest", test_valid_manifest), & & new_unittest("invalid-manifest", test_invalid_manifest, should_fail=.true.), & & new_unittest("default-library", test_default_library), & @@ -32,6 +28,8 @@ subroutine collect_manifest(testsuite) & new_unittest("dependency-nourl", test_dependency_nourl, should_fail=.true.), & & new_unittest("dependency-gitconflict", test_dependency_gitconflict, should_fail=.true.), & & new_unittest("dependency-invalid-git", test_dependency_invalid_git, should_fail=.true.), & + & new_unittest("dependency-no-namespace", test_dependency_no_namespace, should_fail=.true.), & + & new_unittest("dependency-redundant-v", test_dependency_redundant_v, should_fail=.true.), & & new_unittest("dependency-wrongkey", test_dependency_wrongkey, should_fail=.true.), & & new_unittest("dependencies-empty", test_dependencies_empty), & & new_unittest("dependencies-typeerror", test_dependencies_typeerror, should_fail=.true.), & @@ -352,28 +350,62 @@ subroutine test_dependency_gitconflict(error) end subroutine test_dependency_gitconflict - !> Try to create a git dependency with invalid source format + !> Try to create a git dependency with an invalid source format. subroutine test_dependency_invalid_git(error) use fpm_manifest_dependency - use fpm_toml, only : new_table, add_table, toml_table, set_value + use fpm_toml, only : new_table, toml_table, set_value !> Error handling type(error_t), allocatable, intent(out) :: error type(toml_table) :: table - type(toml_table), pointer :: child - type(dependency_config_t) :: dependency call new_table(table) table%key = 'example' - call add_table(table, 'git', child) - call set_value(child, 'path', '../../package') + call set_value(table, 'git', 123) ! Not a string call new_dependency(dependency, table, error=error) end subroutine test_dependency_invalid_git + !> Namespace is necessary if a dependency is not a git or path dependency + subroutine test_dependency_no_namespace(error) + use fpm_manifest_dependency + use fpm_toml, only : new_table, toml_table, set_value + + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_config_t) :: dependency + + call new_table(table) + table%key = 'example' + call set_value(table, 'v', 'abc') + + call new_dependency(dependency, table, error=error) + + end subroutine test_dependency_no_namespace + + !> Do not specify version with a git or path dependency + subroutine test_dependency_redundant_v(error) + use fpm_manifest_dependency + use fpm_toml, only : new_table, toml_table, set_value + + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_config_t) :: dependency + + call new_table(table) + table%key = 'example' + call set_value(table, 'v', '0.0.0') + call set_value(table, 'path', 'abc') + + call new_dependency(dependency, table, error=error) + + end subroutine test_dependency_redundant_v + !> Try to create a dependency with conflicting entries subroutine test_dependency_wrongkey(error) @@ -1300,8 +1332,6 @@ subroutine test_macro_parsing(error) !> Error handling type(error_t), allocatable, intent(out) :: error - character(len=:), allocatable :: version - type(package_config_t) :: package character(:), allocatable :: temp_file integer :: unit @@ -1322,9 +1352,7 @@ subroutine test_macro_parsing(error) if (allocated(error)) return - call package%version%to_string(version) - - if (get_macros(id, package%preprocess(1)%macros, version) /= " -DFOO -DBAR=2 -DVERSION=0.1.0") then + if (get_macros(id, package%preprocess(1)%macros, package%version%s()) /= " -DFOO -DBAR=2 -DVERSION=0.1.0") then call test_failed(error, "Macros were not parsed correctly") end if @@ -1338,7 +1366,6 @@ subroutine test_macro_parsing_dependency(error) type(error_t), allocatable, intent(out) :: error character(len=:), allocatable :: macrosPackage, macrosDependency - character(len=:), allocatable :: versionPackage, versionDependency type(package_config_t) :: package, dependency @@ -1380,11 +1407,8 @@ subroutine test_macro_parsing_dependency(error) if (allocated(error)) return - call package%version%to_string(versionPackage) - call dependency%version%to_string(versionDependency) - - macrosPackage = get_macros(id, package%preprocess(1)%macros, versionPackage) - macrosDependency = get_macros(id, dependency%preprocess(1)%macros, versionDependency) + macrosPackage = get_macros(id, package%preprocess(1)%macros, package%version%s()) + macrosDependency = get_macros(id, dependency%preprocess(1)%macros, dependency%version%s()) if (macrosPackage == macrosDependency) then call test_failed(error, "Macros of package and dependency should not be equal") diff --git a/test/fpm_test/test_module_dependencies.f90 b/test/fpm_test/test_module_dependencies.f90 index 678f08f2ca..1e4bcf265c 100644 --- a/test/fpm_test/test_module_dependencies.f90 +++ b/test/fpm_test/test_module_dependencies.f90 @@ -2,7 +2,7 @@ module test_module_dependencies use testsuite, only : new_unittest, unittest_t, error_t, test_failed use fpm_targets, only: targets_from_sources, resolve_module_dependencies, & - resolve_target_linking, build_target_t, build_target_ptr, & + build_target_t, build_target_ptr, & FPM_TARGET_EXECUTABLE, FPM_TARGET_OBJECT, FPM_TARGET_ARCHIVE use fpm_model, only: fpm_model_t, srcfile_t, & FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & diff --git a/test/fpm_test/test_os.f90 b/test/fpm_test/test_os.f90 new file mode 100644 index 0000000000..c3b7c2e2af --- /dev/null +++ b/test/fpm_test/test_os.f90 @@ -0,0 +1,174 @@ +module test_os + use testsuite, only: new_unittest, unittest_t, error_t, test_failed + use fpm_filesystem, only: env_variable, join_path, mkdir, os_delete_dir, is_dir, get_local_prefix, get_home + use fpm_environment, only: os_is_unix + use fpm_os, only: get_absolute_path + + implicit none + private + public :: collect_os + + character(len=*), parameter :: tmp_folder = 'tmp' + +contains + + !> Collect unit tests. + subroutine collect_os(tests) + + !> Unit tests to collect. + type(unittest_t), allocatable, intent(out) :: tests(:) + + tests = [ & + & new_unittest('empty-path', empty_path, should_fail=.true.), & + & new_unittest('only-tilde', only_tilde), & + & new_unittest('invalid-tilde-path', invalid_tilde_path, should_fail=.true.), & + & new_unittest('tilde-correct-separator', tilde_correct_separator), & + & new_unittest('tilde-wrong-separator', tilde_wrong_separator, should_fail=.true.), & + & new_unittest('tilde-nonexistent-path', tilde_nonexistent_path, should_fail=.true.), & + & new_unittest('abs-path-nonexisting', abs_path_nonexisting, should_fail=.true.), & + & new_unittest('abs-path-root', abs_path_root), & + & new_unittest('abs-path-home', abs_path_home) & + ] + + end subroutine collect_os + + subroutine delete_tmp_folder + if (is_dir(tmp_folder)) call os_delete_dir(os_is_unix(), tmp_folder) + end + + subroutine empty_path(error) + type(error_t), allocatable, intent(out) :: error + character(len=:), allocatable :: result + call get_absolute_path('', result, error) + end + + subroutine only_tilde(error) + type(error_t), allocatable, intent(out) :: error + character(len=:), allocatable :: result + character(len=:), allocatable :: home + + call get_absolute_path('~', result, error) + + if (allocated(error)) then + call test_failed(error, "Unexpected error resolving '~'") + return + end if + + if (.not. allocated(result)) then + call test_failed(error, "Unexpected null result resolving '~'") + return + end if + + call get_home(home, error) + if (allocated(error)) return + + if (result /= home) then + call test_failed(error, "Result '"//result//"' doesn't equal home directory '"//home//"'") + return + end if + + end subroutine + + subroutine invalid_tilde_path(error) + type(error_t), allocatable, intent(out) :: error + character(len=:), allocatable :: result + call get_absolute_path('~a', result, error) + end + + subroutine tilde_correct_separator(error) + type(error_t), allocatable, intent(out) :: error + character(len=:), allocatable :: result + character(len=:), allocatable :: separator + character(len=:), allocatable :: home + + if (os_is_unix()) then + separator = '/' + else + separator = '\' + end if + + call get_absolute_path('~'//separator, result, error) + + call get_home(home, error) + if (allocated(error)) return + + if (result /= home) then + call test_failed(error, "Result '"//result//"' doesn't equal home directory '"//home//"'") + return + end if + end + + subroutine tilde_wrong_separator(error) + type(error_t), allocatable, intent(out) :: error + character(len=:), allocatable :: result + character(len=:), allocatable :: separator + + if (os_is_unix()) then + separator = '\' + else + separator = '/' + end if + + call get_absolute_path('~'//separator, result, error) + end + + !> Entering a non-existing path with ~ should fail. + subroutine tilde_nonexistent_path(error) + type(error_t), allocatable, intent(out) :: error + character(len=:), allocatable :: result + call get_absolute_path('~/abcde', result, error) + end + + !> Entering a non-existing absolute path should fail. + subroutine abs_path_nonexisting(error) + type(error_t), allocatable, intent(out) :: error + character(len=:), allocatable :: result + call get_absolute_path('/abcde', result, error) + end + + !> Testing the most obvious absolute path: The root directory. + subroutine abs_path_root(error) + type(error_t), allocatable, intent(out) :: error + character(len=:), allocatable :: result + character(len=:), allocatable :: home_drive + character(len=:), allocatable :: home_path + + if (os_is_unix()) then + call get_absolute_path('/', result, error) + + if (result /= '/') then + call test_failed(error, "Result '"//result//"' doesn't equal input value: '/'") + return + end if + else + call env_variable(home_drive, 'HOMEDRIVE') + home_path = home_drive//'\' + + call get_absolute_path(home_path, result, error) + + if (result /= home_path) then + call test_failed(error, "Result '"//result//"' doesn't equal input value: '"//home_path//"'") + return + end if + end if + end + + !> Testing an absolute path which is not root. It should not be altered. + subroutine abs_path_home(error) + type(error_t), allocatable, intent(out) :: error + character(len=:), allocatable :: result + character(len=:), allocatable :: home + + call get_home(home, error) + if (allocated(error)) return + + call get_absolute_path(home, result, error) + if (allocated(error)) return + + if (result /= home) then + call test_failed(error, "Result '"//result//"' doesn't equal home directory '"//home//"'") + return + end if + end + +end module test_os diff --git a/test/fpm_test/test_package_dependencies.f90 b/test/fpm_test/test_package_dependencies.f90 index 476d478a45..e7600bc6b4 100644 --- a/test/fpm_test/test_package_dependencies.f90 +++ b/test/fpm_test/test_package_dependencies.f90 @@ -1,315 +1,1397 @@ !> Define tests for the `fpm_dependency` module module test_package_dependencies - use fpm_filesystem, only: get_temp_filename - use testsuite, only : new_unittest, unittest_t, error_t, test_failed - use fpm_dependency - use fpm_manifest - use fpm_manifest_dependency - use fpm_toml - implicit none - private + use fpm_filesystem, only: get_temp_filename + use testsuite, only: new_unittest, unittest_t, error_t, test_failed + use fpm_filesystem, only: is_dir, join_path, filewrite, mkdir, os_delete_dir, exists + use fpm_environment, only: os_is_unix + use fpm_os, only: get_current_directory + use fpm_dependency + use fpm_manifest_dependency + use fpm_toml + use fpm_settings, only: fpm_global_settings, get_registry_settings + use fpm_downloader, only: downloader_t + use fpm_versioning, only: version_t + use jonquil, only: json_object, json_value, json_loads, cast_to_object + + implicit none + private + + public :: collect_package_dependencies + + character(*), parameter :: tmp_folder = 'tmp' + character(*), parameter :: config_file_name = 'config.toml' + + type, extends(dependency_tree_t) :: mock_dependency_tree_t + contains + procedure, private :: resolve_dependency => resolve_dependency_once + end type mock_dependency_tree_t + + type, extends(downloader_t) :: mock_downloader_t + contains + procedure, nopass :: get_pkg_data, get_file, unpack => unpack_mock_package + end type mock_downloader_t - public :: collect_package_dependencies +contains - type, extends(dependency_tree_t) :: mock_dependency_tree_t - contains - procedure :: resolve_dependency => resolve_dependency_once - end type mock_dependency_tree_t + !> Collect all exported unit tests + subroutine collect_package_dependencies(tests) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: tests(:) + + tests = [ & + & new_unittest("cache-load-dump", test_cache_load_dump), & + & new_unittest("cache-dump-load", test_cache_dump_load), & + & new_unittest("status-after-load", test_status), & + & new_unittest("add-dependencies", test_add_dependencies), & + & new_unittest("update-dependencies", test_update_dependencies), & + & new_unittest("registry-dir-not-found", registry_dir_not_found, should_fail=.true.), & + & new_unittest("no-versions-in-registry", no_versions_in_registry, should_fail=.true.), & + & new_unittest("local-registry-specified-version-not-found", local_registry_specified_version_not_found, should_fail=.true.), & + & new_unittest("local-registry-specified-no-manifest", local_registry_specified_no_manifest, should_fail=.true.), & + & new_unittest("local-registry-specified-has-manifest", local_registry_specified_has_manifest), & + & new_unittest("local-registry-specified-not-a-dir", local_registry_specified_not_a_dir, should_fail=.true.), & + & new_unittest("local-registry-unspecified-no-versions", local_registry_unspecified_no_versions, should_fail=.true.), & + & new_unittest("local-registry-unspecified-no-manifest", local_registry_unspecified_no_manifest, should_fail=.true.), & + & new_unittest("local-registry-unspecified-has-manifest", local_registry_unspecified_has_manifest), & + & new_unittest("cache-specified-version-found", cache_specified_version_found), & + & new_unittest("specified-version-not-found-in-cache", registry_specified_version_not_found_in_cache), & + & new_unittest("registry-specified-version-not-exists", registry_specified_version_not_exists, should_fail=.true.), & + & new_unittest("registry-specified-version-other-versions-exist", registry_specified_version_other_versions_exist), & + & new_unittest("registry-unspecified-version", registry_unspecified_version), & + & new_unittest("registry-unspecified-version_exists_in_cache", registry_unspecified_version_exists_in_cache), & + & new_unittest("pkg-data-no-code", pkg_data_no_code, should_fail=.true.), & + & new_unittest("pkg-data-corrupt-code", pkg_data_corrupt_code, should_fail=.true.), & + & new_unittest("pkg-data-missing-error-message", pkg_data_missing_error_msg, should_fail=.true.), & + & new_unittest("pkg-data-error-reading-message", pkg_data_error_reading_msg, should_fail=.true.), & + & new_unittest("pkg-data-error-has-message", pkg_data_error_has_msg, should_fail=.true.), & + & new_unittest("pkg-data-error-no-data", pkg_data_no_data, should_fail=.true.), & + & new_unittest("pkg-data-error-reading-data", pkg_data_error_reading_data, should_fail=.true.), & + & new_unittest("pkg-data-requested-version-wrong-key", pkg_data_requested_version_wrong_key, should_fail=.true.), & + & new_unittest("pkg-data-no-version-requested-wrong-key", pkg_data_no_version_requested_wrong_key, should_fail=.true.), & + & new_unittest("pkg-data-error-reading-latest-version", pkg_data_error_reading_latest_version, should_fail=.true.), & + & new_unittest("pkg-data-no-download-url", pkg_data_no_download_url, should_fail=.true.), & + & new_unittest("pkg-data-error-reading-donwload-url", pkg_data_error_reading_download_url, should_fail=.true.), & + & new_unittest("pkg-data-no-version", pkg_data_no_version, should_fail=.true.), & + & new_unittest("pkg-data-error-reading-version", pkg_data_error_reading_version, should_fail=.true.), & + & new_unittest("pkg-data-invalid-version", pkg_data_invalid_version, should_fail=.true.) & + & ] + + end subroutine collect_package_dependencies + + !> Round trip of the dependency cache from a dependency tree to a TOML document + !> to a dependency tree + subroutine test_cache_dump_load(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(dependency_tree_t) :: deps + type(dependency_config_t) :: dep + integer :: unit + + call new_dependency_tree(deps) + call resize(deps%dep, 5) + deps%ndep = 3 + dep%name = "dep1" + dep%path = "fpm-tmp1-dir" + call new_dependency_node(deps%dep(1), dep, proj_dir=dep%path) + dep%name = "dep2" + dep%path = "fpm-tmp2-dir" + call new_dependency_node(deps%dep(2), dep, proj_dir=dep%path) + dep%name = "dep3" + dep%path = "fpm-tmp3-dir" + call new_dependency_node(deps%dep(3), dep, proj_dir=dep%path) + + open (newunit=unit, status='scratch') + call deps%dump(unit, error) + if (.not. allocated(error)) then + rewind (unit) + + call new_dependency_tree(deps) + call resize(deps%dep, 2) + call deps%load(unit, error) + close (unit) + end if + if (allocated(error)) return + + if (deps%ndep /= 3) then + call test_failed(error, "Expected three dependencies in loaded cache") + return + end if + + end subroutine test_cache_dump_load + + !> Round trip of the dependency cache from a TOML data structure to + !> a dependency tree to a TOML data structure + subroutine test_cache_load_dump(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(toml_key), allocatable :: list(:) + type(dependency_tree_t) :: deps + + table = toml_table() + call add_table(table, "dep1", ptr) + call set_value(ptr, "version", "1.1.0") + call set_value(ptr, "proj-dir", "fpm-tmp1-dir") + call add_table(table, "dep2", ptr) + call set_value(ptr, "version", "0.55.3") + call set_value(ptr, "proj-dir", "fpm-tmp2-dir") + call set_value(ptr, "git", "https://github.com/fortran-lang/dep2") + call add_table(table, "dep3", ptr) + call set_value(ptr, "version", "20.1.15") + call set_value(ptr, "proj-dir", "fpm-tmp3-dir") + call set_value(ptr, "git", "https://gitlab.com/fortran-lang/dep3") + call set_value(ptr, "rev", "c0ffee") + call add_table(table, "dep4", ptr) + call set_value(ptr, "proj-dir", "fpm-tmp4-dir") + + call new_dependency_tree(deps) + call deps%load(table, error) + if (allocated(error)) return + + if (deps%ndep /= 4) then + call test_failed(error, "Expected four dependencies in loaded cache") + return + end if + + call table%destroy + table = toml_table() + + call deps%dump(table, error) + if (allocated(error)) return + + call table%get_keys(list) + + if (size(list) /= 4) then + call test_failed(error, "Expected four dependencies in dumped cache") + return + end if + + end subroutine test_cache_load_dump + + subroutine test_status(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(dependency_tree_t) :: deps + + table = toml_table() + call add_table(table, "dep1", ptr) + call set_value(ptr, "version", "1.1.0") + call set_value(ptr, "proj-dir", "fpm-tmp1-dir") + call add_table(table, "dep2", ptr) + call set_value(ptr, "version", "0.55.3") + call set_value(ptr, "proj-dir", "fpm-tmp2-dir") + call set_value(ptr, "git", "https://github.com/fortran-lang/dep2") + + call new_dependency_tree(deps) + call deps%load(table, error) + if (allocated(error)) return + + if (deps%finished()) then + call test_failed(error, "Newly initialized dependency tree cannot be reolved") + return + end if + + end subroutine test_status + + subroutine test_add_dependencies(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: ptr + type(mock_dependency_tree_t) :: deps + type(dependency_config_t), allocatable :: nodes(:) + + table = toml_table() + call add_table(table, "sub1", ptr) + call set_value(ptr, "path", "external") + call add_table(table, "lin2", ptr) + call set_value(ptr, "git", "https://github.com/fortran-lang/lin2") + call add_table(table, "pkg3", ptr) + call set_value(ptr, "git", "https://gitlab.com/fortran-lang/pkg3") + call set_value(ptr, "rev", "c0ffee") + call add_table(table, "proj4", ptr) + call set_value(ptr, "path", "vendor") + + call new_dependencies(nodes, table, error=error) + if (allocated(error)) return + + call new_dependencies(nodes, table, root='.', error=error) + if (allocated(error)) return + + call new_dependency_tree(deps%dependency_tree_t) + call deps%add(nodes, error) + if (allocated(error)) return + + if (deps%finished()) then + call test_failed(error, "Newly added nodes cannot be already resolved") + return + end if + + if (deps%ndep /= 4) then + call test_failed(error, "Expected for dependencies in tree") + return + end if + + call deps%resolve(".", error) + if (allocated(error)) return + + if (.not. deps%finished()) then + call test_failed(error, "Mocked dependency tree must resolve in one step") + return + end if + + end subroutine test_add_dependencies + + subroutine test_update_dependencies(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: cache, manifest + type(toml_table), pointer :: ptr + type(toml_key), allocatable :: list(:) + type(dependency_tree_t) :: deps, cached_deps + integer :: ii + + ! Create a dummy cache + cache = toml_table() + call add_table(cache, "dep1", ptr) + call set_value(ptr, "version", "1.1.0") + call set_value(ptr, "proj-dir", "fpm-tmp1-dir") + call add_table(cache, "dep2", ptr) + call set_value(ptr, "git", "https://gitlab.com/fortran-lang/lin2") + call set_value(ptr, "rev", "c0ffee") + call set_value(ptr, "proj-dir", "fpm-tmp1-dir") + call add_table(cache, "dep3", ptr) + call set_value(ptr, "git", "https://gitlab.com/fortran-lang/pkg3") + call set_value(ptr, "rev", "t4a") + call set_value(ptr, "proj-dir", "fpm-tmp1-dir") + call add_table(cache, "dep4", ptr) + call set_value(ptr, "version", "1.0.0") + call set_value(ptr, "proj-dir", "fpm-tmp1-dir") + + ! Load into a dependency tree + call new_dependency_tree(cached_deps) + call cached_deps%load(cache, error) + call cache%destroy() + if (allocated(error)) return + + ! Create a dummy manifest, with different version + manifest = toml_table() + call add_table(manifest, "dep1", ptr) + call set_value(ptr, "version", "1.1.1") + call set_value(ptr, "proj-dir", "fpm-tmp1-dir") + call add_table(manifest, "dep2", ptr) + call set_value(ptr, "git", "https://gitlab.com/fortran-lang/lin4") + call set_value(ptr, "rev", "c0ffee") + call set_value(ptr, "proj-dir", "fpm-tmp1-dir") + call add_table(manifest, "dep3", ptr) + call set_value(ptr, "git", "https://gitlab.com/fortran-lang/pkg3") + call set_value(ptr, "rev", "l4tte") + call set_value(ptr, "proj-dir", "fpm-tmp1-dir") + + ! Load dependencies from manifest + call new_dependency_tree(deps) + call deps%load(manifest, error) + call manifest%destroy() + if (allocated(error)) return + + ! Add manifest dependencies + do ii = 1, cached_deps%ndep + call deps%add(cached_deps%dep(ii), error) + if (allocated(error)) return + end do + + ! Test that all dependencies are flagged as "update" + if (.not. deps%dep(1)%update) then + call test_failed(error, "Updated dependency (different version) not detected") + return + end if + if (.not. deps%dep(2)%update) then + call test_failed(error, "Updated dependency (git address) not detected") + return + end if + if (.not. deps%dep(3)%update) then + call test_failed(error, "Updated dependency (git rev) not detected") + return + end if + + end subroutine test_update_dependencies + + !> Directories for namespace and package name not found in path registry. + subroutine registry_dir_not_found(error) + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_node_t) :: node + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: target_dir + type(toml_table), pointer :: child + + call new_table(table) + table%key = 'test-dep' + call set_value(table, 'namespace', 'test-org') + + call new_dependency(node%dependency_config_t, table, error=error) + if (allocated(error)) return + + call delete_tmp_folder + call mkdir(join_path(tmp_folder, 'cache')) ! Missing directories for namesapce and package name + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', 'cache') + + call setup_global_settings(global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_registry_settings(child, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call node%get_from_registry(target_dir, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call delete_tmp_folder + + end subroutine registry_dir_not_found + + !> No versions found in path registry. + subroutine no_versions_in_registry(error) + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_node_t) :: node + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: target_dir + type(toml_table), pointer :: child + + call new_table(table) + table%key = 'test-dep' + call set_value(table, 'namespace', 'test-org') + + call new_dependency(node%dependency_config_t, table, error=error) + if (allocated(error)) return + + call delete_tmp_folder + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep')) + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', 'cache') + + call setup_global_settings(global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_registry_settings(child, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call node%get_from_registry(target_dir, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call delete_tmp_folder + + end subroutine no_versions_in_registry + + !> Specific version not found in the local registry. + subroutine local_registry_specified_version_not_found(error) + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_node_t) :: node + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: target_dir + type(toml_table), pointer :: child + call new_table(table) + table%key = 'test-dep' + call set_value(table, 'namespace', 'test-org') + call set_value(table, 'v', '0.1.0') + + call new_dependency(node%dependency_config_t, table, error=error) + if (allocated(error)) return + + call delete_tmp_folder + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.0.9')) + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.1')) + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', 'cache') + + call setup_global_settings(global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_registry_settings(child, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call node%get_from_registry(target_dir, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call delete_tmp_folder + + end subroutine local_registry_specified_version_not_found + + !> Target package in path registry does not contain manifest. + subroutine local_registry_specified_no_manifest(error) + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_node_t) :: node + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: target_dir + type(toml_table), pointer :: child + + call new_table(table) + table%key = 'test-dep' + call set_value(table, 'namespace', 'test-org') + call set_value(table, 'v', '0.1.0') + + call new_dependency(node%dependency_config_t, table, error=error) + if (allocated(error)) return + + call delete_tmp_folder + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.0.9')) + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.0')) + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.1')) + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', 'cache') + + call setup_global_settings(global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_registry_settings(child, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call node%get_from_registry(target_dir, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call delete_tmp_folder + + end subroutine local_registry_specified_no_manifest + + !> Target package in path registry contains manifest. + subroutine local_registry_specified_has_manifest(error) + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_node_t) :: node + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: target_dir, cwd + type(toml_table), pointer :: child + + call new_table(table) + table%key = 'test-dep' + call set_value(table, 'namespace', 'test-org') + call set_value(table, 'v', '0.1.0') + + call new_dependency(node%dependency_config_t, table, error=error) + if (allocated(error)) return + + call delete_tmp_folder + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.0.0')) + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.0')) + call filewrite(join_path(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.0'), 'fpm.toml'), ['']) + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.2.0')) + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', 'cache') + + call setup_global_settings(global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_registry_settings(child, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call node%get_from_registry(target_dir, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_current_directory(cwd, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + if (target_dir /= join_path(cwd, join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.0'))) then + call test_failed(error, 'target_dir not set correctly') + call delete_tmp_folder; return + end if + + call delete_tmp_folder + + end subroutine local_registry_specified_has_manifest + + !> Target is a file, not a directory. + subroutine local_registry_specified_not_a_dir(error) + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_node_t) :: node + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: target_dir + type(toml_table), pointer :: child + + call new_table(table) + table%key = 'test-dep' + call set_value(table, 'namespace', 'test-org') + + call new_dependency(node%dependency_config_t, table, error=error) + if (allocated(error)) return + + call delete_tmp_folder + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep')) + call filewrite(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.0'), ['']) ! File, not directory + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', 'cache') + + call setup_global_settings(global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_registry_settings(child, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call node%get_from_registry(target_dir, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call delete_tmp_folder + + end subroutine local_registry_specified_not_a_dir + + !> Try fetching the latest version in the local registry, but none are found. + !> Compared to no-versions-in-registry, we aren't requesting a specific version here. + subroutine local_registry_unspecified_no_versions(error) + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_node_t) :: node + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: target_dir + type(toml_table), pointer :: child + + call new_table(table) + table%key = 'test-dep' + call set_value(table, 'namespace', 'test-org') + + call new_dependency(node%dependency_config_t, table, error=error) + if (allocated(error)) return + + call delete_tmp_folder + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep')) + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', 'cache') + + call setup_global_settings(global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_registry_settings(child, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call node%get_from_registry(target_dir, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call delete_tmp_folder + + end subroutine local_registry_unspecified_no_versions + + !> Latest version in the local registry does not have a manifest. + subroutine local_registry_unspecified_no_manifest(error) + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_node_t) :: node + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: target_dir, cwd + type(toml_table), pointer :: child + + call new_table(table) + table%key = 'test-dep' + call set_value(table, 'namespace', 'test-org') + + call new_dependency(node%dependency_config_t, table, error=error) + if (allocated(error)) return + + call delete_tmp_folder + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.0.0')) + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '1.3.0')) + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '1.2.1')) + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', 'cache') + + call setup_global_settings(global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_registry_settings(child, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call node%get_from_registry(target_dir, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_current_directory(cwd, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + if (target_dir /= join_path(cwd, join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '1.3.0'))) then + call test_failed(error, 'target_dir not set correctly: '//target_dir//"'") + call delete_tmp_folder; return + end if + + call delete_tmp_folder + + end subroutine local_registry_unspecified_no_manifest + + !> Latest version in the local registry has a manifest. + subroutine local_registry_unspecified_has_manifest(error) + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_node_t) :: node + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: target_dir, cwd + type(toml_table), pointer :: child + + call new_table(table) + table%key = 'test-dep' + call set_value(table, 'namespace', 'test-org') + + call new_dependency(node%dependency_config_t, table, error=error) + if (allocated(error)) return + + call delete_tmp_folder + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.0.0')) + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '1.3.0')) + call filewrite(join_path(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '1.3.0'), 'fpm.toml'), ['']) + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '1.2.1')) + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', 'cache') + + call setup_global_settings(global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_registry_settings(child, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call node%get_from_registry(target_dir, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_current_directory(cwd, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + if (target_dir /= join_path(cwd, join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '1.3.0'))) then + call test_failed(error, 'target_dir not set correctly: '//target_dir//"'") + call delete_tmp_folder; return + end if + + call delete_tmp_folder + + end subroutine local_registry_unspecified_has_manifest + + !> Version specified in manifest, version found in cache. + subroutine cache_specified_version_found(error) + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_node_t) :: node + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: target_dir, cwd, path + type(toml_table), pointer :: child + + call new_table(table) + table%key = 'test-dep' + call set_value(table, 'namespace', 'test-org') + call set_value(table, 'v', '2.3.0') + + call new_dependency(node%dependency_config_t, table, error=error) + if (allocated(error)) return + + call delete_tmp_folder + path = join_path(tmp_folder, 'dependencies', 'test-org', 'test-dep', '2.3.0') + call mkdir(path) + call filewrite(join_path(path, 'fpm.toml'), ['']) + + call new_table(table) + call add_table(table, 'registry', child) ! No cache_path specified, use default + + call setup_global_settings(global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_registry_settings(child, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call node%get_from_registry(target_dir, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_current_directory(cwd, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + if (target_dir /= join_path(cwd, join_path(tmp_folder, 'dependencies', 'test-org', 'test-dep', '2.3.0'))) then + call test_failed(error, "Target directory not set correctly: '"//target_dir//"'") + call delete_tmp_folder; return + end if + + call delete_tmp_folder + + end subroutine cache_specified_version_found + + !> Version specified in manifest, but not found in cache. Therefore download dependency. + subroutine registry_specified_version_not_found_in_cache(error) + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_node_t) :: node + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: target_dir, cwd + type(toml_table), pointer :: child + type(mock_downloader_t) :: mock_downloader + + call new_table(table) + table%key = 'test-dep' + call set_value(table, 'namespace', 'test-org') + call set_value(table, 'v', '0.1.0') + + call new_dependency(node%dependency_config_t, table, error=error) + if (allocated(error)) return + + call delete_tmp_folder + call mkdir(tmp_folder) ! Dependencies folder doesn't exist + + call new_table(table) + call add_table(table, 'registry', child) + + call setup_global_settings(global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_registry_settings(child, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call node%get_from_registry(target_dir, global_settings, error, mock_downloader) + if (allocated(error)) then + call delete_tmp_folder; return + end if -contains + call get_current_directory(cwd, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + if (target_dir /= join_path(cwd, join_path(tmp_folder, 'dependencies', 'test-org', 'test-dep', '0.1.0'))) then + call test_failed(error, "Target directory not set correctly: '"//target_dir//"'") + call delete_tmp_folder; return + end if + + call delete_tmp_folder + + end subroutine registry_specified_version_not_found_in_cache + + !> Version specified in manifest, but not found in cache or registry. + subroutine registry_specified_version_not_exists(error) + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_node_t) :: node + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: target_dir + type(toml_table), pointer :: child + type(mock_downloader_t) :: mock_downloader + + call new_table(table) + table%key = 'test-dep' + call set_value(table, 'namespace', 'test-org') + call set_value(table, 'v', '9.9.9') + + call new_dependency(node%dependency_config_t, table, error=error) + if (allocated(error)) return + + call delete_tmp_folder + call mkdir(tmp_folder) + + call new_table(table) + call add_table(table, 'registry', child) + + call setup_global_settings(global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_registry_settings(child, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call node%get_from_registry(target_dir, global_settings, error, mock_downloader) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call delete_tmp_folder + + end subroutine registry_specified_version_not_exists + + subroutine registry_specified_version_other_versions_exist(error) + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_node_t) :: node + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: target_dir + type(toml_table), pointer :: child + type(mock_downloader_t) :: mock_downloader + + call new_table(table) + table%key = 'test-dep' + call set_value(table, 'namespace', 'test-org') + call set_value(table, 'v', '0.1.0') + + call new_dependency(node%dependency_config_t, table, error=error) + if (allocated(error)) return + + call delete_tmp_folder + call mkdir(join_path(tmp_folder, 'dependencies', 'test-org', 'test-dep', '2.1.0')) + call mkdir(join_path(tmp_folder, 'dependencies', 'test-org', 'test-dep', '9.1.0')) + + call new_table(table) + call add_table(table, 'registry', child) + + call setup_global_settings(global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_registry_settings(child, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call node%get_from_registry(target_dir, global_settings, error, mock_downloader) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call delete_tmp_folder + + end subroutine registry_specified_version_other_versions_exist + + !> No version specified, get the newest version from the registry. + subroutine registry_unspecified_version(error) + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_node_t) :: node + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: target_dir, cwd + type(toml_table), pointer :: child + type(mock_downloader_t) :: mock_downloader + + call new_table(table) + table%key = 'test-dep' + call set_value(table, 'namespace', 'test-org') + + call new_dependency(node%dependency_config_t, table, error=error) + if (allocated(error)) return + + call delete_tmp_folder + call mkdir(tmp_folder) + + call new_table(table) + call add_table(table, 'registry', child) + + call setup_global_settings(global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_registry_settings(child, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call node%get_from_registry(target_dir, global_settings, error, mock_downloader) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_current_directory(cwd, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + if (target_dir /= join_path(cwd, join_path(tmp_folder, 'dependencies', 'test-org', 'test-dep', '0.1.0'))) then + call test_failed(error, "Target directory not set correctly: '"//target_dir//"'") + call delete_tmp_folder; return + end if + + call delete_tmp_folder + + end subroutine registry_unspecified_version + + !> No version specified, therefore load package data from the registry. Find out that there is a cached version of + !> the latest package. + subroutine registry_unspecified_version_exists_in_cache(error) + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_node_t) :: node + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: target_dir, cwd + type(toml_table), pointer :: child + type(mock_downloader_t) :: mock_downloader + + call new_table(table) + table%key = 'test-dep' + call set_value(table, 'namespace', 'test-org') + + call new_dependency(node%dependency_config_t, table, error=error) + if (allocated(error)) return + + call delete_tmp_folder + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.0.0')) + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.0')) + call filewrite(join_path(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '0.1.0'), 'fpm.toml'), ['']) + call mkdir(join_path(tmp_folder, 'cache', 'test-org', 'test-dep', '1.2.1')) + + call new_table(table) + call add_table(table, 'registry', child) + + call setup_global_settings(global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_registry_settings(child, global_settings, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call node%get_from_registry(target_dir, global_settings, error, mock_downloader) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + call get_current_directory(cwd, error) + if (allocated(error)) then + call delete_tmp_folder; return + end if + + if (target_dir /= join_path(cwd, join_path(tmp_folder, 'dependencies', 'test-org', 'test-dep', '0.1.0'))) then + call test_failed(error, "Target directory not set correctly: '"//target_dir//"'") + call delete_tmp_folder; return + end if + + call delete_tmp_folder + + end subroutine registry_unspecified_version_exists_in_cache + + !> Package data returned from the registry does not contain a code field. + subroutine pkg_data_no_code(error) + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: node + character(:), allocatable :: url + type(version_t) :: version + type(json_object) :: json + class(json_value), allocatable :: j_value + + call json_loads(j_value, '{}') + json = cast_to_object(j_value) + + call check_and_read_pkg_data(json, node, url, version, error) + + end subroutine pkg_data_no_code + + !> Error reading status code from package data. + subroutine pkg_data_corrupt_code(error) + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: node + character(:), allocatable :: url + type(version_t) :: version + type(json_object) :: json + class(json_value), allocatable :: j_value + + call json_loads(j_value, '{"code": "integer expected"}') + json = cast_to_object(j_value) + + call check_and_read_pkg_data(json, node, url, version, error) + + end subroutine pkg_data_corrupt_code + + subroutine pkg_data_missing_error_msg(error) + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: node + character(:), allocatable :: url + type(version_t) :: version + type(json_object) :: json + class(json_value), allocatable :: j_value + + call json_loads(j_value, '{"code": 123}') + json = cast_to_object(j_value) + + call check_and_read_pkg_data(json, node, url, version, error) + + end subroutine pkg_data_missing_error_msg + + subroutine pkg_data_error_reading_msg(error) + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: node + character(:), allocatable :: url + type(version_t) :: version + type(json_object) :: json + class(json_value), allocatable :: j_value + + call json_loads(j_value, '{"code": 123, "message": 123}') + json = cast_to_object(j_value) + + call check_and_read_pkg_data(json, node, url, version, error) + + end subroutine pkg_data_error_reading_msg + + subroutine pkg_data_error_has_msg(error) + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: node + character(:), allocatable :: url + type(version_t) :: version + type(json_object) :: json + class(json_value), allocatable :: j_value + + call json_loads(j_value, '{"code": 123, "message": "Really bad error message"}') + json = cast_to_object(j_value) + + call check_and_read_pkg_data(json, node, url, version, error) + + end subroutine pkg_data_error_has_msg + + subroutine pkg_data_no_data(error) + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: node + character(:), allocatable :: url + type(version_t) :: version + type(json_object) :: json + class(json_value), allocatable :: j_value + + call json_loads(j_value, '{"code": 200}') + json = cast_to_object(j_value) + + call check_and_read_pkg_data(json, node, url, version, error) + + end subroutine pkg_data_no_data + + subroutine pkg_data_error_reading_data(error) + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: node + character(:), allocatable :: url + type(version_t) :: version + type(json_object) :: json + class(json_value), allocatable :: j_value + + call json_loads(j_value, '{"code": 200, "data": 123}') + json = cast_to_object(j_value) + + call check_and_read_pkg_data(json, node, url, version, error) + + end subroutine pkg_data_error_reading_data + + subroutine pkg_data_requested_version_wrong_key(error) + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: node + character(:), allocatable :: url + type(version_t) :: version + type(json_object) :: json + class(json_value), allocatable :: j_value + + allocate (node%requested_version) + call json_loads(j_value, '{"code": 200, "data": {"latest_version_data": 123}}') ! Expected key: "version_data" + json = cast_to_object(j_value) + + call check_and_read_pkg_data(json, node, url, version, error) + + end subroutine pkg_data_requested_version_wrong_key + + subroutine pkg_data_no_version_requested_wrong_key(error) + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: node + character(:), allocatable :: url + type(version_t) :: version + type(json_object) :: json + class(json_value), allocatable :: j_value + + call json_loads(j_value, '{"code": 200, "data": {"version_data": 123}}') ! Expected key: "latest_version_data" + json = cast_to_object(j_value) + + call check_and_read_pkg_data(json, node, url, version, error) + + end subroutine pkg_data_no_version_requested_wrong_key + + subroutine pkg_data_error_reading_latest_version(error) + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: node + character(:), allocatable :: url + type(version_t) :: version + type(json_object) :: json + class(json_value), allocatable :: j_value + + call json_loads(j_value, '{"code": 200, "data": {"latest_version_data": 123}}') + json = cast_to_object(j_value) + + call check_and_read_pkg_data(json, node, url, version, error) + + end subroutine pkg_data_error_reading_latest_version + + subroutine pkg_data_no_download_url(error) + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: node + character(:), allocatable :: url + type(version_t) :: version + type(json_object) :: json + class(json_value), allocatable :: j_value + + call json_loads(j_value, '{"code": 200, "data": {"latest_version_data": {}}}') + json = cast_to_object(j_value) + + call check_and_read_pkg_data(json, node, url, version, error) + + end subroutine pkg_data_no_download_url + + subroutine pkg_data_error_reading_download_url(error) + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: node + character(:), allocatable :: url + type(version_t) :: version + type(json_object) :: json + class(json_value), allocatable :: j_value + + call json_loads(j_value, '{"code": 200, "data": {"latest_version_data": {"download_url": 123}}}') + json = cast_to_object(j_value) + + call check_and_read_pkg_data(json, node, url, version, error) + + end subroutine pkg_data_error_reading_download_url + + subroutine pkg_data_no_version(error) + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: node + character(:), allocatable :: url + type(version_t) :: version + type(json_object) :: json + class(json_value), allocatable :: j_value + + call json_loads(j_value, '{"code": 200, "data": {"latest_version_data": {"download_url": "abc"}}}') + json = cast_to_object(j_value) + + call check_and_read_pkg_data(json, node, url, version, error) + + end subroutine pkg_data_no_version + + subroutine pkg_data_error_reading_version(error) + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: node + character(:), allocatable :: url + type(version_t) :: version + type(json_object) :: json + class(json_value), allocatable :: j_value + + call json_loads(j_value, '{"code": 200, "data": {"latest_version_data": {"download_url": "abc", "version": 123}}}') + json = cast_to_object(j_value) + + call check_and_read_pkg_data(json, node, url, version, error) + + end subroutine pkg_data_error_reading_version + + subroutine pkg_data_invalid_version(error) + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: node + character(:), allocatable :: url + type(version_t) :: version + type(json_object) :: json + class(json_value), allocatable :: j_value + + call json_loads(j_value, '{"code": 200, "data": {"latest_version_data": {"download_url": "abc", "version": "abc"}}}') + json = cast_to_object(j_value) + + call check_and_read_pkg_data(json, node, url, version, error) + + end subroutine pkg_data_invalid_version + + !> Resolve a single dependency node + subroutine resolve_dependency_once(self, dependency, global_settings, root, error) + !> Mock instance of the dependency tree + class(mock_dependency_tree_t), intent(inout) :: self + !> Dependency configuration to add + type(dependency_node_t), intent(inout) :: dependency + !> Global configuration settings. + type(fpm_global_settings), intent(in) :: global_settings + !> Current installation prefix + character(len=*), intent(in) :: root + !> Error handling + type(error_t), allocatable, intent(out) :: error + + if (dependency%done) then + call test_failed(error, "Should only visit this node once") + return + end if + + dependency%done = .true. + + end subroutine resolve_dependency_once + + subroutine delete_tmp_folder + if (is_dir(tmp_folder)) call os_delete_dir(os_is_unix(), tmp_folder) + end + subroutine setup_global_settings(global_settings, error) + type(fpm_global_settings), intent(out) :: global_settings + type(error_t), allocatable, intent(out) :: error - !> Collect all exported unit tests - subroutine collect_package_dependencies(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("cache-load-dump", test_cache_load_dump), & - & new_unittest("cache-dump-load", test_cache_dump_load), & - & new_unittest("status-after-load", test_status), & - & new_unittest("add-dependencies", test_add_dependencies), & - & new_unittest("update-dependencies",test_update_dependencies)] + character(:), allocatable :: cwd - end subroutine collect_package_dependencies + call get_current_directory(cwd, error) + if (allocated(error)) return + global_settings%path_to_config_folder = join_path(cwd, tmp_folder) + global_settings%config_file_name = config_file_name + end - !> Round trip of the dependency cache from a dependency tree to a TOML document - !> to a dependency tree - subroutine test_cache_dump_load(error) + subroutine get_pkg_data(url, version, tmp_pkg_file, json, error) + character(*), intent(in) :: url + type(version_t), allocatable, intent(in) :: version + character(*), intent(in) :: tmp_pkg_file + type(json_object), intent(out) :: json + type(error_t), allocatable, intent(out) :: error - !> Error handling - type(error_t), allocatable, intent(out) :: error + class(json_value), allocatable :: j_value - type(dependency_tree_t) :: deps - type(dependency_config_t) :: dep - integer :: unit - - call new_dependency_tree(deps) - call resize(deps%dep, 5) - deps%ndep = 3 - dep%name = "dep1" - dep%path = "fpm-tmp1-dir" - call new_dependency_node(deps%dep(1), dep, proj_dir=dep%path) - dep%name = "dep2" - dep%path = "fpm-tmp2-dir" - call new_dependency_node(deps%dep(2), dep, proj_dir=dep%path) - dep%name = "dep3" - dep%path = "fpm-tmp3-dir" - call new_dependency_node(deps%dep(3), dep, proj_dir=dep%path) - - open(newunit=unit, status='scratch') - call deps%dump(unit, error) - if (.not.allocated(error)) then - rewind(unit) + if (allocated(version)) then + if (version%s() == '9.9.9') then + call json_loads(j_value, '{"code": 404, "message": "Package not found"}') + else + call json_loads(j_value, '{"code": 200, "data": {"version_data": {"version": "0.1.0", "download_url": "abc"}}}') + end if + else + call json_loads(j_value, '{"code": 200, "data": {"latest_version_data": {"version": "0.1.0", "download_url": "abc"}}}') + end if - call new_dependency_tree(deps) - call resize(deps%dep, 2) - call deps%load(unit, error) - close(unit) - end if - if (allocated(error)) return + json = cast_to_object(j_value) + end - if (deps%ndep /= 3) then - call test_failed(error, "Expected three dependencies in loaded cache") - return - end if + subroutine get_file(url, tmp_pkg_file, error) + character(*), intent(in) :: url + character(*), intent(in) :: tmp_pkg_file + type(error_t), allocatable, intent(out) :: error + end - end subroutine test_cache_dump_load - - - !> Round trip of the dependency cache from a TOML data structure to - !> a dependency tree to a TOML data structure - subroutine test_cache_load_dump(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: ptr - type(toml_key), allocatable :: list(:) - type(dependency_tree_t) :: deps - - table = toml_table() - call add_table(table, "dep1", ptr) - call set_value(ptr, "version", "1.1.0") - call set_value(ptr, "proj-dir", "fpm-tmp1-dir") - call add_table(table, "dep2", ptr) - call set_value(ptr, "version", "0.55.3") - call set_value(ptr, "proj-dir", "fpm-tmp2-dir") - call set_value(ptr, "git", "https://github.com/fortran-lang/dep2") - call add_table(table, "dep3", ptr) - call set_value(ptr, "version", "20.1.15") - call set_value(ptr, "proj-dir", "fpm-tmp3-dir") - call set_value(ptr, "git", "https://gitlab.com/fortran-lang/dep3") - call set_value(ptr, "rev", "c0ffee") - call add_table(table, "dep4", ptr) - call set_value(ptr, "proj-dir", "fpm-tmp4-dir") - - call new_dependency_tree(deps) - call deps%load(table, error) - if (allocated(error)) return - - if (deps%ndep /= 4) then - call test_failed(error, "Expected four dependencies in loaded cache") - return - end if + subroutine unpack_mock_package(tmp_pkg_file, destination, error) + character(*), intent(in) :: tmp_pkg_file + character(*), intent(in) :: destination + type(error_t), allocatable, intent(out) :: error + + integer :: stat - call table%destroy - table = toml_table() - - call deps%dump(table, error) - if (allocated(error)) return - - call table%get_keys(list) - - if (size(list) /= 4) then - call test_failed(error, "Expected four dependencies in dumped cache") - return - end if - - end subroutine test_cache_load_dump - - - subroutine test_status(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: ptr - type(dependency_tree_t) :: deps - - table = toml_table() - call add_table(table, "dep1", ptr) - call set_value(ptr, "version", "1.1.0") - call set_value(ptr, "proj-dir", "fpm-tmp1-dir") - call add_table(table, "dep2", ptr) - call set_value(ptr, "version", "0.55.3") - call set_value(ptr, "proj-dir", "fpm-tmp2-dir") - call set_value(ptr, "git", "https://github.com/fortran-lang/dep2") - - call new_dependency_tree(deps) - call deps%load(table, error) - if (allocated(error)) return - - if (deps%finished()) then - call test_failed(error, "Newly initialized dependency tree cannot be reolved") - return - end if - - end subroutine test_status - - - subroutine test_add_dependencies(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: ptr - type(mock_dependency_tree_t) :: deps - type(dependency_config_t), allocatable :: nodes(:) - - table = toml_table() - call add_table(table, "sub1", ptr) - call set_value(ptr, "path", "external") - call add_table(table, "lin2", ptr) - call set_value(ptr, "git", "https://github.com/fortran-lang/lin2") - call add_table(table, "pkg3", ptr) - call set_value(ptr, "git", "https://gitlab.com/fortran-lang/pkg3") - call set_value(ptr, "rev", "c0ffee") - call add_table(table, "proj4", ptr) - call set_value(ptr, "path", "vendor") - - call new_dependencies(nodes, table, error=error) - if (allocated(error)) return - - call new_dependencies(nodes, table, root='.', error=error) - if (allocated(error)) return - - call new_dependency_tree(deps%dependency_tree_t) - call deps%add(nodes, error) - if (allocated(error)) return - - if (deps%finished()) then - call test_failed(error, "Newly added nodes cannot be already resolved") - return - end if - - if (deps%ndep /= 4) then - call test_failed(error, "Expected for dependencies in tree") - return - end if - - call deps%resolve(".", error) - if (allocated(error)) return - - if (.not.deps%finished()) then - call test_failed(error, "Mocked dependency tree must resolve in one step") - return - end if - - end subroutine test_add_dependencies - - subroutine test_update_dependencies(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: cache,manifest - type(toml_table), pointer :: ptr - type(toml_key), allocatable :: list(:) - type(dependency_tree_t) :: deps,cached_deps - integer :: ii - - ! Create a dummy cache - cache = toml_table() - call add_table(cache, "dep1", ptr) - call set_value(ptr, "version", "1.1.0") - call set_value(ptr, "proj-dir", "fpm-tmp1-dir") - call add_table(cache, "dep2", ptr) - call set_value(ptr, "git", "https://gitlab.com/fortran-lang/lin2") - call set_value(ptr, "rev", "c0ffee") - call set_value(ptr, "proj-dir", "fpm-tmp1-dir") - call add_table(cache, "dep3", ptr) - call set_value(ptr, "git", "https://gitlab.com/fortran-lang/pkg3") - call set_value(ptr, "rev", "t4a") - call set_value(ptr, "proj-dir", "fpm-tmp1-dir") - call add_table(cache, "dep4", ptr) - call set_value(ptr, "version", "1.0.0") - call set_value(ptr, "proj-dir", "fpm-tmp1-dir") - - ! Load into a dependency tree - call new_dependency_tree(cached_deps) - call cached_deps%load(cache, error) - call cache%destroy() - if (allocated(error)) return - - ! Create a dummy manifest, with different version - manifest = toml_table() - call add_table(manifest, "dep1", ptr) - call set_value(ptr, "version", "1.1.1") - call set_value(ptr, "proj-dir", "fpm-tmp1-dir") - call add_table(manifest, "dep2", ptr) - call set_value(ptr, "git", "https://gitlab.com/fortran-lang/lin4") - call set_value(ptr, "rev", "c0ffee") - call set_value(ptr, "proj-dir", "fpm-tmp1-dir") - call add_table(manifest, "dep3", ptr) - call set_value(ptr, "git", "https://gitlab.com/fortran-lang/pkg3") - call set_value(ptr, "rev", "l4tte") - call set_value(ptr, "proj-dir", "fpm-tmp1-dir") - - ! Load dependencies from manifest - call new_dependency_tree(deps) - call deps%load(manifest, error) - call manifest%destroy() - if (allocated(error)) return - - ! Add manifest dependencies - do ii=1,cached_deps%ndep - call deps%add(cached_deps%dep(ii),error) - if (allocated(error)) return - end do - - ! Test that all dependencies are flagged as "update" - if (.not.deps%dep(1)%update) then - call test_failed(error, "Updated dependency (different version) not detected") - return - end if - if (.not.deps%dep(2)%update) then - call test_failed(error, "Updated dependency (git address) not detected") - return - end if - if (.not.deps%dep(3)%update) then - call test_failed(error, "Updated dependency (git rev) not detected") - return - end if - - - end subroutine test_update_dependencies - - - !> Resolve a single dependency node - subroutine resolve_dependency_once(self, dependency, root, error) - !> Mock instance of the dependency tree - class(mock_dependency_tree_t), intent(inout) :: self - !> Dependency configuration to add - type(dependency_node_t), intent(inout) :: dependency - !> Current installation prefix - character(len=*), intent(in) :: root - !> Error handling - type(error_t), allocatable, intent(out) :: error - - if (dependency%done) then - call test_failed(error, "Should only visit this node once") - return - end if - dependency%done = .true. - - end subroutine resolve_dependency_once + call execute_command_line('cp '//tmp_pkg_file//' '//destination, exitstat=stat) + if (stat /= 0) then + call test_failed(error, "Failed to create mock package"); return + end if + end end module test_package_dependencies diff --git a/test/fpm_test/test_settings.f90 b/test/fpm_test/test_settings.f90 new file mode 100644 index 0000000000..a63b022cde --- /dev/null +++ b/test/fpm_test/test_settings.f90 @@ -0,0 +1,676 @@ +module test_settings + use testsuite, only: new_unittest, unittest_t, error_t, test_failed + use fpm_settings, only: fpm_global_settings, get_global_settings, get_registry_settings, official_registry_base_url + use fpm_filesystem, only: is_dir, join_path, mkdir, filewrite, os_delete_dir, exists, get_local_prefix + use fpm_environment, only: os_is_unix + use fpm_toml, only: toml_table, new_table, add_table, set_value + use fpm_os, only: get_absolute_path, get_current_directory + + implicit none + private + public :: collect_settings + + character(len=*), parameter :: tmp_folder = 'tmp' + character(len=*), parameter :: config_file_name = 'config.toml' + +contains + + !> Collect unit tests. + subroutine collect_settings(tests) + + !> Unit tests to collect. + type(unittest_t), allocatable, intent(out) :: tests(:) + + tests = [ & + & new_unittest('no-folder', no_folder, should_fail=.true.), & + & new_unittest('no-file', no_file, should_fail=.true.), & + & new_unittest('empty-file', empty_file), & + & new_unittest('default-config-settings', default_config_settings), & + & new_unittest('error-reading-table', error_reading_table, should_fail=.true.), & + & new_unittest('empty-registry-table', empty_registry_table), & + & new_unittest('invalid-key', invalid_key, should_fail=.true.), & + & new_unittest('invalid-type', invalid_type, should_fail=.true.), & + & new_unittest('has-non-existent-path-to-registry', has_non_existent_path_to_registry, should_fail=.true.), & + & new_unittest('has-existent-path-to-registry', has_existent_path_to_registry), & + & new_unittest('absolute-path-to-registry', absolute_path_to_registry), & + & new_unittest('relative-path-to-registry', relative_path_to_registry), & + & new_unittest('relative-path-to-registry-file-read', relative_path_to_registry_file_read), & + & new_unittest('canonical-path-to-registry', canonical_path_to_registry), & + & new_unittest('has-url-to-registry', has_url_to_registry), & + & new_unittest('has-both-path-and-url-to-registry', has_both_path_and_url_to_registry, should_fail=.true.), & + & new_unittest('has-both-path-and-cache-path', has_both_path_and_cache_path, should_fail=.true.), & + & new_unittest('abs-cache-path-no-dir', abs_cache_path_no_dir), & + & new_unittest('abs-cache-path-has-dir', abs_cache_path_has_dir), & + & new_unittest('rel-cache-path-no-dir', rel_cache_path_no_dir), & + & new_unittest('rel-cache-path-has-dir', rel_cache_path_has_dir) & + ] + + end subroutine collect_settings + + subroutine delete_tmp_folder + if (is_dir(tmp_folder)) call os_delete_dir(os_is_unix(), tmp_folder) + end subroutine + + subroutine setup_global_settings(global_settings, error) + type(fpm_global_settings), intent(out) :: global_settings + type(error_t), allocatable, intent(out) :: error + + character(:), allocatable :: cwd + + call get_current_directory(cwd, error) + if (allocated(error)) return + + global_settings%path_to_config_folder = join_path(cwd, tmp_folder) + global_settings%config_file_name = config_file_name + end subroutine + + !> Throw error when custom path to config file was entered but no folder exists. + subroutine no_folder(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + + call delete_tmp_folder + + call setup_global_settings(global_settings, error) + if (allocated(error)) return + + call get_global_settings(global_settings, error) + end subroutine + + !> Throw error when custom path to config file was entered but no file exists. + subroutine no_file(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + + call delete_tmp_folder + call mkdir(tmp_folder) + + call setup_global_settings(global_settings, error) + if (allocated(error)) return + + call get_global_settings(global_settings, error) + end subroutine + + !> No custom path and config file specified, use default path and file name. + subroutine default_config_settings(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + + character(:), allocatable :: default_path + + call delete_tmp_folder + + call get_global_settings(global_settings, error) + if (allocated(error)) return + + if (os_is_unix()) then + default_path = join_path(get_local_prefix(), 'share', 'fpm') + else + default_path = join_path(get_local_prefix(), 'fpm') + end if + + if (global_settings%path_to_config_folder /= default_path) then + call test_failed(error, "Path to config folder not set correctly :'"//global_settings%config_file_name//"'") + return + end if + + if (global_settings%config_file_name /= 'config.toml') then + call test_failed(error, "Config file name not set correctly :'"//global_settings%config_file_name//"'") + return + end if + end subroutine + + !> Config file exists and the path to that file is set. + subroutine empty_file(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + + character(:), allocatable :: cwd + + call delete_tmp_folder + call mkdir(tmp_folder) + + call filewrite(join_path(tmp_folder, config_file_name), ['']) + + call setup_global_settings(global_settings, error) + if (allocated(error)) return + + call get_global_settings(global_settings, error) + + call delete_tmp_folder + + if (allocated(error)) return + + call get_current_directory(cwd, error) + if (allocated(error)) return + + if (global_settings%path_to_config_folder /= join_path(cwd, tmp_folder)) then + call test_failed(error, "global_settings%path_to_config_folder not set correctly :'" & + & //global_settings%path_to_config_folder//"'"); return + end if + + if (.not. allocated(global_settings%registry_settings)) then + call test_failed(error, 'global_settings%registry_settings not be allocated'); return + end if + + if (global_settings%registry_settings%url /= official_registry_base_url) then + call test_failed(error, 'Wrong default url'); return + end if + + if (global_settings%registry_settings%cache_path /= join_path(global_settings%path_to_config_folder, & + & 'dependencies')) then + call test_failed(error, 'Wrong default cache_path'); return + end if + end subroutine + + !> Invalid TOML file. + subroutine error_reading_table(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + + call delete_tmp_folder + call mkdir(tmp_folder) + + call filewrite(join_path(tmp_folder, config_file_name), ['[']) + + call setup_global_settings(global_settings, error) + if (allocated(error)) return + + call get_global_settings(global_settings, error) + + call delete_tmp_folder + + if (allocated(global_settings%registry_settings)) then + call test_failed(error, 'Registry settings should not be allocated'); return + end if + end subroutine + + subroutine empty_registry_table(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + type(toml_table) :: table + type(toml_table), pointer :: child + + call new_table(table) + call add_table(table, 'registry', child) + + call get_registry_settings(child, global_settings, error) + if (allocated(error)) return + + if (.not. allocated(global_settings%registry_settings)) then + call test_failed(error, 'Registry settings not allocated'); return + end if + + if (allocated(global_settings%registry_settings%path)) then + call test_failed(error, "Path shouldn't be allocated"); return + end if + + if (global_settings%registry_settings%url /= official_registry_base_url) then + call test_failed(error, "Url not be allocated"); return + end if + end subroutine + + subroutine invalid_key(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + type(toml_table) :: table + type(toml_table), pointer :: child + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'invalid_key', 'abc') + + call get_registry_settings(child, global_settings, error) + end subroutine + + subroutine invalid_type(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + type(toml_table) :: table + type(toml_table), pointer :: child + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', 42) + + call get_registry_settings(child, global_settings, error) + end subroutine + + subroutine has_non_existent_path_to_registry(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + type(toml_table) :: table + type(toml_table), pointer :: child + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', 'nonexistent_path') + + call get_registry_settings(child, global_settings, error) + end subroutine + + subroutine has_existent_path_to_registry(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + type(toml_table) :: table + type(toml_table), pointer :: child + character(:), allocatable :: cwd + + call delete_tmp_folder + call mkdir(tmp_folder) + + call setup_global_settings(global_settings, error) + if (allocated(error)) return + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', '.') + + call get_registry_settings(child, global_settings, error) + + if (.not. allocated(global_settings%registry_settings%path)) then + call test_failed(error, 'Path not allocated') + return + end if + + call delete_tmp_folder + + call get_current_directory(cwd, error) + if (allocated(error)) return + + if (global_settings%registry_settings%path /= join_path(cwd, tmp_folder)) then + call test_failed(error, "Path not set correctly: '"//global_settings%registry_settings%path//"'") + return + end if + + if (allocated(global_settings%registry_settings%url)) then + call test_failed(error, "Url shouldn't be allocated") + return + end if + + end subroutine + + subroutine absolute_path_to_registry(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: abs_path + type(toml_table) :: table + type(toml_table), pointer :: child + + call delete_tmp_folder + call mkdir(tmp_folder) + + call get_absolute_path(tmp_folder, abs_path, error) + if (allocated(error)) return + + call setup_global_settings(global_settings, error) + if (allocated(error)) return + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', abs_path) + + call get_registry_settings(child, global_settings, error) + + call delete_tmp_folder + + if (allocated(error)) return + + if (.not. allocated(global_settings%registry_settings)) then + call test_failed(error, 'Registry settings not allocated') + return + end if + + if (.not. allocated(global_settings%registry_settings%path)) then + call test_failed(error, 'Path not allocated') + return + end if + + if (global_settings%registry_settings%path /= abs_path) then + call test_failed(error, "Path not set correctly: '"//global_settings%registry_settings%path//"'") + return + end if + end subroutine + + subroutine relative_path_to_registry(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: abs_path + type(toml_table) :: table + type(toml_table), pointer :: child + + call delete_tmp_folder + call mkdir(join_path(tmp_folder, 'abc')) + + call setup_global_settings(global_settings, error) + if (allocated(error)) return + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', 'abc') + + call get_registry_settings(child, global_settings, error) + + call get_absolute_path(tmp_folder, abs_path, error) + + call delete_tmp_folder + + if (allocated(error)) return + + if (.not. allocated(global_settings%registry_settings)) then + call test_failed(error, 'Registry settings not allocated') + return + end if + + if (global_settings%registry_settings%path /= join_path(abs_path, 'abc')) then + call test_failed(error, "Path not set correctly: '"//global_settings%registry_settings%path//"'") + return + end if + end subroutine + + ! Test that the registry path is set correctly when the path is written to and read from a config file. + subroutine relative_path_to_registry_file_read(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: abs_path + + call delete_tmp_folder + call mkdir(join_path(tmp_folder, 'abc')) + + call filewrite(join_path(tmp_folder, config_file_name), ['[registry]', 'path="abc"']) + + call setup_global_settings(global_settings, error) + if (allocated(error)) return + + call get_global_settings(global_settings, error) + + call get_absolute_path(tmp_folder, abs_path, error) + + call delete_tmp_folder + + if (allocated(error)) return + + if (.not. allocated(global_settings%registry_settings)) then + call test_failed(error, 'Registry settings not allocated') + return + end if + + if (global_settings%registry_settings%path /= join_path(abs_path, 'abc')) then + call test_failed(error, "Path not set correctly: '"//global_settings%registry_settings%path//"'") + return + end if + end subroutine + + subroutine canonical_path_to_registry(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: abs_path + type(toml_table) :: table + type(toml_table), pointer :: child + + call delete_tmp_folder + call mkdir(tmp_folder) + + call setup_global_settings(global_settings, error) + if (allocated(error)) return + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', join_path('..', tmp_folder)) + + call get_registry_settings(child, global_settings, error) + + call get_absolute_path(tmp_folder, abs_path, error) + + call delete_tmp_folder + + if (allocated(error)) return + + if (.not. allocated(global_settings%registry_settings)) then + call test_failed(error, 'Registry settings not allocated') + return + end if + + if (global_settings%registry_settings%path /= abs_path) then + call test_failed(error, "Path not set correctly: '"//global_settings%registry_settings%path//"'") + return + end if + end subroutine + + subroutine has_url_to_registry(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + type(toml_table) :: table + type(toml_table), pointer :: child + + call delete_tmp_folder + call mkdir(tmp_folder) + + call setup_global_settings(global_settings, error) + if (allocated(error)) return + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'url', 'http') + + call get_registry_settings(child, global_settings, error) + + call delete_tmp_folder + + if (.not. allocated(global_settings%registry_settings)) then + call test_failed(error, 'Registry settings not allocated') + return + end if + + if (allocated(global_settings%registry_settings%path)) then + call test_failed(error, "Path shouldn't be allocated: '" & + & //global_settings%registry_settings%path//"'") + return + end if + + if (.not. allocated(global_settings%registry_settings%url)) then + call test_failed(error, 'Url not allocated') + return + end if + + if (global_settings%registry_settings%url /= 'http') then + call test_failed(error, 'Failed to parse url') + return + end if + end subroutine + + subroutine has_both_path_and_url_to_registry(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + type(toml_table) :: table + type(toml_table), pointer :: child + + call delete_tmp_folder + call mkdir(tmp_folder) + + call setup_global_settings(global_settings, error) + if (allocated(error)) return + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', '.') + call set_value(child, 'url', 'http') + + call get_registry_settings(child, global_settings, error) + + call delete_tmp_folder + end subroutine + + subroutine has_both_path_and_cache_path(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + type(toml_table) :: table + type(toml_table), pointer :: child + + call delete_tmp_folder + call mkdir(tmp_folder) + + call setup_global_settings(global_settings, error) + if (allocated(error)) return + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'path', '.') + call set_value(child, 'cache_path', 'cache') + + call get_registry_settings(child, global_settings, error) + + call delete_tmp_folder + end subroutine + + ! Custom cache location defined via absolute path but directory doesn't exist. Create it. + subroutine abs_cache_path_no_dir(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: abs_path, abs_path_to_cache + type(toml_table) :: table + type(toml_table), pointer :: child + + call delete_tmp_folder + call mkdir(tmp_folder) + + call get_absolute_path(tmp_folder, abs_path, error) + if (allocated(error)) return + + abs_path_to_cache = join_path(abs_path, 'cache') + + call setup_global_settings(global_settings, error) + if (allocated(error)) return + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'cache_path', abs_path_to_cache) + + call get_registry_settings(child, global_settings, error) + + if (.not. exists(abs_path_to_cache)) then + call test_failed(error, "Cache directory '"//abs_path_to_cache//"' not created.") + return + end if + + if (global_settings%registry_settings%cache_path /= abs_path_to_cache) then + call test_failed(error, "Cache path '"//abs_path_to_cache//"' not registered.") + return + end if + + call delete_tmp_folder + end subroutine + + ! Custom cache location defined via absolute path for existing directory. + subroutine abs_cache_path_has_dir(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: abs_path + type(toml_table) :: table + type(toml_table), pointer :: child + + call delete_tmp_folder + call mkdir(join_path(tmp_folder, 'cache')) + + call get_absolute_path(join_path(tmp_folder, 'cache'), abs_path, error) + if (allocated(error)) return + + call setup_global_settings(global_settings, error) + if (allocated(error)) return + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'cache_path', abs_path) + + call get_registry_settings(child, global_settings, error) + + if (.not. exists(abs_path)) then + call test_failed(error, "Cache directory '"//abs_path//"' not created.") + return + end if + + if (global_settings%registry_settings%cache_path /= abs_path) then + call test_failed(error, "Cache path '"//abs_path//"' not registered.") + return + end if + + call delete_tmp_folder + end subroutine + + ! Custom cache location defined via relative path but directory doesn't exist. Create it. + subroutine rel_cache_path_no_dir(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + character(:), allocatable :: cache_path, abs_path + type(toml_table) :: table + type(toml_table), pointer :: child + + call delete_tmp_folder + call mkdir(tmp_folder) + + call setup_global_settings(global_settings, error) + if (allocated(error)) return + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'cache_path', 'cache') + + call get_registry_settings(child, global_settings, error) + + cache_path = join_path(tmp_folder, 'cache') + + if (.not. exists(cache_path)) then + call test_failed(error, "Cache directory '"//cache_path//"' not created.") + return + end if + + call get_absolute_path(cache_path, abs_path, error) + if (allocated(error)) return + + if (global_settings%registry_settings%cache_path /= abs_path) then + call test_failed(error, "Cache path '"//cache_path//"' not registered.") + return + end if + + call delete_tmp_folder + end subroutine + + ! Custom cache location defined via relative path for existing directory. + subroutine rel_cache_path_has_dir(error) + type(error_t), allocatable, intent(out) :: error + type(fpm_global_settings) :: global_settings + character(len=:), allocatable :: cache_path, abs_path + type(toml_table) :: table + type(toml_table), pointer :: child + + call delete_tmp_folder + + cache_path = join_path(tmp_folder, 'cache') + call mkdir(cache_path) + + call setup_global_settings(global_settings, error) + if (allocated(error)) return + + call new_table(table) + call add_table(table, 'registry', child) + call set_value(child, 'cache_path', 'cache') + + call get_registry_settings(child, global_settings, error) + + if (.not. exists(cache_path)) then + call test_failed(error, "Cache directory '"//cache_path//"' not created.") + return + end if + + call get_absolute_path(cache_path, abs_path, error) + if (allocated(error)) return + + if (global_settings%registry_settings%cache_path /= abs_path) then + call test_failed(error, "Cache path '"//cache_path//"' not registered.") + return + end if + + call delete_tmp_folder + end subroutine + +end module test_settings diff --git a/test/fpm_test/test_versioning.f90 b/test/fpm_test/test_versioning.f90 index b309d1382c..f678c9730e 100644 --- a/test/fpm_test/test_versioning.f90 +++ b/test/fpm_test/test_versioning.f90 @@ -12,12 +12,12 @@ module test_versioning !> Collect all exported unit tests - subroutine collect_versioning(testsuite) + subroutine collect_versioning(tests) !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) + type(unittest_t), allocatable, intent(out) :: tests(:) - testsuite = [ & + tests = [ & & new_unittest("valid-version", test_valid_version), & & new_unittest("valid-equals", test_valid_equals), & & new_unittest("valid-notequals", test_valid_notequals), & @@ -262,6 +262,98 @@ subroutine test_valid_compare(error) return end if + call new_version(v1, [1, 2, 3]) + call new_version(v2, [2, 0, 0]) + + if (v1 > v2) then + call test_failed(error, "Version comparison failed (gt)") + return + end if + + if (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 (v2 <= v1) then + call test_failed(error, "Version comparison failed (le)") + return + end if + + call new_version(v1, [1, 2, 3]) + call new_version(v2, [1, 0, 4]) + + if (v2 > v1) then + call test_failed(error, "Version comparison failed (gt)") + return + end if + + if (v2 >= v1) then + call test_failed(error, "Version comparison failed (ge)") + return + end if + + if (v1 < v2) then + call test_failed(error, "Version comparison failed (lt)") + return + end if + + if (v1 <= v2) then + call test_failed(error, "Version comparison failed (le)") + return + end if + + call new_version(v1, [1, 0, 8]) + 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]) + call new_version(v2, [1, 0, 8]) + + if (v1 > v2) then + call test_failed(error, "Version comparison failed (gt)") + return + end if + + if (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 (v2 <= v1) then + call test_failed(error, "Version comparison failed (le)") + return + end if + end subroutine test_valid_compare @@ -322,15 +414,13 @@ subroutine test_valid_string(error) 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) + if (str_in /= version%s()) then + call test_failed(error, "Expected "//str_in//" but got "//version%s()) end if end subroutine test_valid_string