diff --git a/.github/workflows/meta.yml b/.github/workflows/meta.yml index be6a46dcb9..cf915f31b2 100644 --- a/.github/workflows/meta.yml +++ b/.github/workflows/meta.yml @@ -84,7 +84,7 @@ jobs: Remove-Item "oneAPI" -Force -Recurse - name: (Ubuntu) Install gfortran - if: contains(matrix.os,'ubuntu') && (!contains(matrix.mpi,'intel')) + if: contains(matrix.os,'ubuntu') run: | sudo update-alternatives --install /usr/bin/gcc gcc /usr/bin/gcc-${GCC_V} 100 \ --slave /usr/bin/gfortran gfortran /usr/bin/gfortran-${GCC_V} \ @@ -209,14 +209,6 @@ jobs: mv $(which fpm) fpm-bootstrap${{ matrix.exe }} echo "BOOTSTRAP=$PWD/fpm-bootstrap" >> $GITHUB_ENV - - name: Use Intel compiler for the metapackage tests - if: contains(matrix.mpi,'intel') - shell: bash - run: | - echo "FPM_FC=ifx" >> $GITHUB_ENV - echo "FPM_CC=icx" >> $GITHUB_ENV - echo "FPM_CXX=icpx" >> $GITHUB_ENV - - name: (macOS) Use gcc/g++ instead of Clang for C/C++ if: contains(matrix.os,'macOS') shell: bash @@ -300,6 +292,14 @@ jobs: env: EXE: fpm-${{ env.VERSION }}-${{ matrix.os-arch }}${{ matrix.exe }} + - name: Use Intel compiler for the metapackage tests + if: contains(matrix.mpi,'intel') + shell: bash + run: | + echo "FPM_FC=ifx" >> $GITHUB_ENV + echo "FPM_CC=icx" >> $GITHUB_ENV + echo "FPM_CXX=icpx" >> $GITHUB_ENV + - name: Run metapackage tests using the release version shell: bash run: | diff --git a/app/main.f90 b/app/main.f90 index 95df065097..4bd3ac5e33 100644 --- a/app/main.f90 +++ b/app/main.f90 @@ -4,6 +4,7 @@ program main fpm_cmd_settings, & fpm_new_settings, & fpm_build_settings, & + fpm_export_settings, & fpm_run_settings, & fpm_test_settings, & fpm_install_settings, & @@ -15,6 +16,7 @@ program main use fpm_filesystem, only: exists, parent_dir, join_path use fpm, only: cmd_build, cmd_run, cmd_clean use fpm_cmd_install, only: cmd_install +use fpm_cmd_export, only: cmd_export use fpm_cmd_new, only: cmd_new use fpm_cmd_update, only : cmd_update use fpm_cmd_publish, only: cmd_publish @@ -76,6 +78,8 @@ program main call cmd_run(settings,test=.false.) type is (fpm_test_settings) call cmd_run(settings,test=.true.) +type is (fpm_export_settings) + call cmd_export(settings) type is (fpm_install_settings) call cmd_install(settings) type is (fpm_update_settings) diff --git a/src/fpm.f90 b/src/fpm.f90 index bb2972bd9e..ae8a07d681 100644 --- a/src/fpm.f90 +++ b/src/fpm.f90 @@ -21,6 +21,7 @@ module fpm use fpm_manifest, only : get_package_data, package_config_t use fpm_meta, only : resolve_metapackages use fpm_error, only : error_t, fatal_error, fpm_stop +use fpm_toml, only: name_is_json use, intrinsic :: iso_fortran_env, only : stdin => input_unit, & & stdout => output_unit, & & stderr => error_unit @@ -449,6 +450,12 @@ subroutine cmd_build(settings) call fpm_stop(1,'*cmd_build* Target error: '//error%message) end if +!> Dump model to file +if (len_trim(settings%dump)>0) then + call model%dump(trim(settings%dump),error,json=name_is_json(trim(settings%dump))) + if (allocated(error)) call fpm_stop(1,'*cmd_build* Model dump error: '//error%message) +endif + if(settings%list)then do i=1,size(targets) write(stderr,*) targets(i)%ptr%output_file diff --git a/src/fpm/cmd/export.f90 b/src/fpm/cmd/export.f90 new file mode 100644 index 0000000000..d2ec0dbaf1 --- /dev/null +++ b/src/fpm/cmd/export.f90 @@ -0,0 +1,83 @@ +module fpm_cmd_export + use fpm_command_line, only : fpm_export_settings + use fpm_dependency, only : dependency_tree_t, new_dependency_tree + use fpm_error, only : error_t, fpm_stop + use fpm_filesystem, only : join_path + use fpm_manifest, only : package_config_t, get_package_data + use fpm_toml, only: name_is_json + use fpm_model, only: fpm_model_t + use fpm, only: build_model + implicit none + private + public :: cmd_export + +contains + + !> Entry point for the export subcommand + subroutine cmd_export(settings) + !> Representation of the command line arguments + type(fpm_export_settings), intent(inout) :: settings + type(package_config_t) :: package + type(dependency_tree_t) :: deps + type(fpm_model_t) :: model + type(error_t), allocatable :: error + + integer :: ii + character(len=:), allocatable :: filename + + if (len_trim(settings%dump_manifest)<=0 .and. & + len_trim(settings%dump_model)<=0 .and. & + len_trim(settings%dump_dependencies)<=0) then + call fpm_stop(0,'*cmd_export* exiting: no manifest/model/dependencies keyword provided') + end if + + !> Read in manifest + call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) + call handle_error(error) + + !> Export manifest + if (len_trim(settings%dump_manifest)>0) then + filename = trim(settings%dump_manifest) + call package%dump(filename, error, json=name_is_json(filename)) + end if + + !> Export dependency tree + if (len_trim(settings%dump_dependencies)>0) then + + !> Generate dependency tree + filename = join_path("build", "cache.toml") + call new_dependency_tree(deps, cache=filename, verbosity=merge(2, 1, settings%verbose)) + call deps%add(package, error) + call handle_error(error) + + !> Export dependency tree + filename = settings%dump_dependencies + call deps%dump(filename, error, json=name_is_json(filename)) + call handle_error(error) + end if + + !> Export full model + if (len_trim(settings%dump_model)>0) then + + call build_model(model, settings%fpm_build_settings, package, error) + if (allocated(error)) then + call fpm_stop(1,'*cmd_export* Model error: '//error%message) + end if + + filename = settings%dump_model + call model%dump(filename, error, json=name_is_json(filename)) + call handle_error(error) + end if + + end subroutine cmd_export + + !> Error handling for this command + subroutine handle_error(error) + !> Potential error + type(error_t), intent(in), optional :: error + if (present(error)) then + call fpm_stop(1, '*cmd_export* error: '//error%message) + end if + end subroutine handle_error + +end module fpm_cmd_export diff --git a/src/fpm/cmd/update.f90 b/src/fpm/cmd/update.f90 index 513e69599f..c1f09e07c6 100644 --- a/src/fpm/cmd/update.f90 +++ b/src/fpm/cmd/update.f90 @@ -4,6 +4,7 @@ module fpm_cmd_update use fpm_error, only : error_t, fpm_stop use fpm_filesystem, only : exists, mkdir, join_path, delete_file, filewrite use fpm_manifest, only : package_config_t, get_package_data + use fpm_toml, only: name_is_json implicit none private public :: cmd_update @@ -14,10 +15,10 @@ module fpm_cmd_update subroutine cmd_update(settings) !> Representation of the command line arguments type(fpm_update_settings), intent(in) :: settings + type(package_config_t) :: package type(dependency_tree_t) :: deps type(error_t), allocatable :: error - integer :: ii character(len=:), allocatable :: cache @@ -57,6 +58,11 @@ subroutine cmd_update(settings) end do end if + if (len_trim(settings%dump)>0) then + call deps%dump(trim(settings%dump), error, json=name_is_json(trim(settings%dump))) + call handle_error(error) + end if + end subroutine cmd_update !> Error handling for this command @@ -64,7 +70,7 @@ subroutine handle_error(error) !> Potential error type(error_t), intent(in), optional :: error if (present(error)) then - call fpm_stop(1, error%message) + call fpm_stop(1, '*cmd_update* error: '//error%message) end if end subroutine handle_error diff --git a/src/fpm/dependency.f90 b/src/fpm/dependency.f90 index 52e5c6ec12..71bc74514f 100644 --- a/src/fpm/dependency.f90 +++ b/src/fpm/dependency.f90 @@ -60,13 +60,14 @@ module fpm_dependency 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, get_temp_filename - use fpm_git, only: git_target_revision, git_target_default, git_revision, operator(==) + use fpm_git, only: git_target_revision, git_target_default, git_revision, operator(==), & + serializable_t use fpm_manifest, only: package_config_t, dependency_config_t, get_package_data - use fpm_manifest_dependency, only: manifest_has_changed + use fpm_manifest_dependency, only: manifest_has_changed, dependency_destroy use fpm_manifest_preprocess, only: operator(==) 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 + get_value, set_value, add_table, toml_load, toml_stat, set_string 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 @@ -76,7 +77,7 @@ module fpm_dependency private public :: dependency_tree_t, new_dependency_tree, dependency_node_t, new_dependency_node, resize, & - & check_and_read_pkg_data + & check_and_read_pkg_data, destroy_dependency_node !> Overloaded reallocation interface interface resize @@ -105,13 +106,19 @@ module fpm_dependency procedure, private :: get_from_local_registry !> Print information on this instance procedure :: info + + !> Serialization interface + procedure :: serializable_is_same => dependency_node_is_same + procedure :: dump_to_toml => node_dump_to_toml + procedure :: load_from_toml => node_load_from_toml + end type dependency_node_t !> Respresentation of a projects dependencies !> !> The dependencies are stored in a simple array for now, this can be replaced !> with a binary-search tree or a hash table in the future. - type :: dependency_tree_t + type, extends(serializable_t) :: dependency_tree_t !> Unit for IO integer :: unit = output_unit !> Verbosity of printout @@ -157,27 +164,33 @@ module fpm_dependency !> Depedendncy resolution finished procedure :: finished !> Reading of dependency tree - generic :: load => load_from_file, load_from_unit, load_from_toml + generic :: load_cache => load_cache_from_file, load_cache_from_unit, load_cache_from_toml !> Read dependency tree from file - procedure, private :: load_from_file + procedure, private :: load_cache_from_file !> Read dependency tree from formatted unit - procedure, private :: load_from_unit + procedure, private :: load_cache_from_unit !> Read dependency tree from TOML data structure - procedure, private :: load_from_toml + procedure, private :: load_cache_from_toml !> Writing of dependency tree - generic :: dump => dump_to_file, dump_to_unit, dump_to_toml + generic :: dump_cache => dump_cache_to_file, dump_cache_to_unit, dump_cache_to_toml !> Write dependency tree to file - procedure, private :: dump_to_file + procedure, private :: dump_cache_to_file !> Write dependency tree to formatted unit - procedure, private :: dump_to_unit + procedure, private :: dump_cache_to_unit !> Write dependency tree to TOML data structure - procedure, private :: dump_to_toml + procedure, private :: dump_cache_to_toml !> Update dependency tree generic :: update => update_dependency, update_tree !> Update a list of dependencies procedure, private :: update_dependency !> Update all dependencies in the tree procedure, private :: update_tree + + !> Serialization interface + procedure :: serializable_is_same => dependency_tree_is_same + procedure :: dump_to_toml => tree_dump_to_toml + procedure :: load_from_toml => tree_load_from_toml + end type dependency_tree_t !> Common output format for writing to the command line @@ -310,8 +323,8 @@ subroutine add_project(self, package, error) ! After resolving all dependencies, check if we have cached ones to avoid updates if (allocated(self%cache)) then - call new_dependency_tree(cached, verbosity=self%verbosity, cache=self%cache) - call cached%load(self%cache, error) + call new_dependency_tree(cached, verbosity=self%verbosity,cache=self%cache) + call cached%load_cache(self%cache, error) if (allocated(error)) return ! Skip root node @@ -330,7 +343,7 @@ subroutine add_project(self, package, error) if (allocated(error)) return if (allocated(self%cache)) then - call self%dump(self%cache, error) + call self%dump_cache(self%cache, error) if (allocated(error)) return end if @@ -961,7 +974,7 @@ subroutine register(self, package, root, fetch, revision, error) end subroutine register !> Read dependency tree from file - subroutine load_from_file(self, file, error) + subroutine load_cache_from_file(self, file, error) !> Instance of the dependency tree class(dependency_tree_t), intent(inout) :: self !> File name @@ -976,12 +989,12 @@ subroutine load_from_file(self, file, error) if (.not. exist) return open (file=file, newunit=unit) - call self%load(unit, error) + call self%load_cache(unit, error) close (unit) - end subroutine load_from_file + end subroutine load_cache_from_file !> Read dependency tree from file - subroutine load_from_unit(self, unit, error) + subroutine load_cache_from_unit(self, unit, error) !> Instance of the dependency tree class(dependency_tree_t), intent(inout) :: self !> File name @@ -1000,13 +1013,13 @@ subroutine load_from_unit(self, unit, error) return end if - call self%load(table, error) + call self%load_cache(table, error) if (allocated(error)) return - end subroutine load_from_unit + end subroutine load_cache_from_unit !> Read dependency tree from TOML data structure - subroutine load_from_toml(self, table, error) + subroutine load_cache_from_toml(self, table, error) !> Instance of the dependency tree class(dependency_tree_t), intent(inout) :: self !> Data structure @@ -1068,10 +1081,10 @@ subroutine load_from_toml(self, table, error) if (allocated(error)) return self%ndep = size(list) - end subroutine load_from_toml + end subroutine load_cache_from_toml !> Write dependency tree to file - subroutine dump_to_file(self, file, error) + subroutine dump_cache_to_file(self, file, error) !> Instance of the dependency tree class(dependency_tree_t), intent(inout) :: self !> File name @@ -1082,14 +1095,14 @@ subroutine dump_to_file(self, file, error) integer :: unit open (file=file, newunit=unit) - call self%dump(unit, error) + call self%dump_cache(unit, error) close (unit) if (allocated(error)) return - end subroutine dump_to_file + end subroutine dump_cache_to_file !> Write dependency tree to file - subroutine dump_to_unit(self, unit, error) + subroutine dump_cache_to_unit(self, unit, error) !> Instance of the dependency tree class(dependency_tree_t), intent(inout) :: self !> Formatted unit @@ -1100,14 +1113,14 @@ subroutine dump_to_unit(self, unit, error) type(toml_table) :: table table = toml_table() - call self%dump(table, error) + call self%dump_cache(table, error) write (unit, '(a)') toml_serialize(table) - end subroutine dump_to_unit + end subroutine dump_cache_to_unit !> Write dependency tree to TOML datastructure - subroutine dump_to_toml(self, table, error) + subroutine dump_cache_to_toml(self, table, error) !> Instance of the dependency tree class(dependency_tree_t), intent(inout) :: self !> Data structure @@ -1144,7 +1157,7 @@ subroutine dump_to_toml(self, table, error) end do if (allocated(error)) return - end subroutine dump_to_toml + end subroutine dump_cache_to_toml !> Reallocate a list of dependencies pure subroutine resize_dependency_node(var, n) @@ -1245,4 +1258,290 @@ logical function dependency_has_changed(cached, manifest, verbosity, iunit) resu end function dependency_has_changed + !> Check that two dependency nodes are equal + logical function dependency_node_is_same(this,that) + class(dependency_node_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + dependency_node_is_same = .false. + + select type (other=>that) + type is (dependency_node_t) + + ! Base class must match + if (.not.(this%dependency_config_t==other%dependency_config_t)) return + + ! Extension must match + if (.not.(this%done .eqv.other%done)) return + if (.not.(this%update.eqv.other%update)) return + if (.not.(this%cached.eqv.other%cached)) return + if (.not.(this%proj_dir==other%proj_dir)) return + if (.not.(this%revision==other%revision)) return + + if (.not.(allocated(this%version).eqv.allocated(other%version))) return + if (allocated(this%version)) then + if (.not.(this%version==other%version)) return + endif + + class default + ! Not the same type + return + end select + + !> All checks passed! + dependency_node_is_same = .true. + + end function dependency_node_is_same + + !> Dump dependency to toml table + subroutine node_dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(dependency_node_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr + + ! Dump parent class + call self%dependency_config_t%dump_to_toml(table, error) + if (allocated(error)) return + + if (allocated(self%version)) then + call set_string(table, "version", self%version%s(), error,'dependency_node_t') + if (allocated(error)) return + endif + call set_string(table, "proj-dir", self%proj_dir, error, 'dependency_node_t') + if (allocated(error)) return + call set_string(table, "revision", self%revision, error, 'dependency_node_t') + if (allocated(error)) return + call set_value(table, "done", self%done, error, 'dependency_node_t') + if (allocated(error)) return + call set_value(table, "update", self%update, error, 'dependency_node_t') + if (allocated(error)) return + call set_value(table, "cached", self%cached, error, 'dependency_node_t') + if (allocated(error)) return + + end subroutine node_dump_to_toml + + !> Read dependency from toml table (no checks made at this stage) + subroutine node_load_from_toml(self, table, error) + + !> Instance of the serializable object + class(dependency_node_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + character(len=:), allocatable :: version + integer :: ierr + + call destroy_dependency_node(self) + + ! Load parent class + call self%dependency_config_t%load_from_toml(table, error) + if (allocated(error)) return + + call get_value(table, "done", self%done, error, 'dependency_node_t') + if (allocated(error)) return + call get_value(table, "update", self%update, error, 'dependency_node_t') + if (allocated(error)) return + call get_value(table, "cached", self%cached, error, 'dependency_node_t') + if (allocated(error)) return + + call get_value(table, "proj-dir", self%proj_dir) + call get_value(table, "revision", self%revision) + + call get_value(table, "version", version) + if (allocated(version)) then + allocate(self%version) + call new_version(self%version, version, error) + if (allocated(error)) then + error%message = 'dependency_node_t: version error from TOML table - '//error%message + return + endif + end if + + end subroutine node_load_from_toml + + !> Destructor + elemental subroutine destroy_dependency_node(self) + + class(dependency_node_t), intent(inout) :: self + + integer :: ierr + + call dependency_destroy(self) + + deallocate(self%version,stat=ierr) + deallocate(self%proj_dir,stat=ierr) + deallocate(self%revision,stat=ierr) + self%done = .false. + self%update = .false. + self%cached = .false. + + end subroutine destroy_dependency_node + + !> Check that two dependency trees are equal + logical function dependency_tree_is_same(this,that) + class(dependency_tree_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + integer :: ii + + dependency_tree_is_same = .false. + + select type (other=>that) + type is (dependency_tree_t) + + if (.not.(this%unit==other%unit)) return + if (.not.(this%verbosity==other%verbosity)) return + if (.not.(this%dep_dir==other%dep_dir)) return + if (.not.(this%ndep==other%ndep)) return + if (.not.(allocated(this%dep).eqv.allocated(other%dep))) return + if (allocated(this%dep)) then + if (.not.(size(this%dep)==size(other%dep))) return + do ii = 1, size(this%dep) + if (.not.(this%dep(ii)==other%dep(ii))) return + end do + endif + if (.not.(this%cache==other%cache)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + dependency_tree_is_same = .true. + + end function dependency_tree_is_same + + !> Dump dependency to toml table + subroutine tree_dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(dependency_tree_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr, ii + type(toml_table), pointer :: ptr_deps,ptr + character(27) :: unnamed + + call set_value(table, "unit", self%unit, error, 'dependency_tree_t') + if (allocated(error)) return + call set_value(table, "verbosity", self%verbosity, error, 'dependency_tree_t') + if (allocated(error)) return + call set_string(table, "dep-dir", self%dep_dir, error, 'dependency_tree_t') + if (allocated(error)) return + call set_string(table, "cache", self%cache, error, 'dependency_tree_t') + if (allocated(error)) return + call set_value(table, "ndep", self%ndep, error, 'dependency_tree_t') + if (allocated(error)) return + + if (allocated(self%dep)) then + + ! Create dependency table + call add_table(table, "dependencies", ptr_deps) + if (.not. associated(ptr_deps)) then + call fatal_error(error, "dependency_tree_t cannot create dependency table ") + return + end if + + do ii = 1, size(self%dep) + associate (dep => self%dep(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(dep%name)==0) then + write(unnamed,1) ii + call add_table(ptr_deps, trim(unnamed), ptr) + else + call add_table(ptr_deps, dep%name, ptr) + end if + if (.not. associated(ptr)) then + call fatal_error(error, "dependency_tree_t cannot create entry for dependency "//dep%name) + return + end if + call dep%dump_to_toml(ptr, error) + if (allocated(error)) return + end associate + end do + + endif + + 1 format('UNNAMED_DEPENDENCY_',i0) + + end subroutine tree_dump_to_toml + + !> Read dependency from toml table (no checks made at this stage) + subroutine tree_load_from_toml(self, table, error) + + !> Instance of the serializable object + class(dependency_tree_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + type(toml_key), allocatable :: keys(:),dep_keys(:) + type(toml_table), pointer :: ptr_deps,ptr + integer :: ii, jj, ierr + + call table%get_keys(keys) + + call get_value(table, "unit", self%unit, error, 'dependency_tree_t') + if (allocated(error)) return + call get_value(table, "verbosity", self%verbosity, error, 'dependency_tree_t') + if (allocated(error)) return + call get_value(table, "ndep", self%ndep, error, 'dependency_tree_t') + if (allocated(error)) return + call get_value(table, "dep-dir", self%dep_dir) + call get_value(table, "cache", self%cache) + + find_deps_table: do ii = 1, size(keys) + if (keys(ii)%key=="dependencies") then + + call get_value(table, keys(ii), ptr_deps) + if (.not.associated(ptr_deps)) then + call fatal_error(error,'dependency_tree_t: error retrieving dependency table from TOML table') + return + end if + + !> Read all dependencies + call ptr_deps%get_keys(dep_keys) + call resize(self%dep, size(dep_keys)) + + do jj = 1, size(dep_keys) + + call get_value(ptr_deps, dep_keys(jj), ptr) + call self%dep(jj)%load_from_toml(ptr, error) + if (allocated(error)) return + + end do + + exit find_deps_table + + endif + end do find_deps_table + + end subroutine tree_load_from_toml + + end module fpm_dependency diff --git a/src/fpm/git.f90 b/src/fpm/git.f90 index c007743a90..22b4179553 100644 --- a/src/fpm/git.f90 +++ b/src/fpm/git.f90 @@ -2,7 +2,7 @@ module fpm_git use fpm_error, only: error_t, fatal_error use fpm_filesystem, only : get_temp_filename, getline, join_path, execute_and_read_output, run - + use fpm_toml, only: serializable_t, toml_table, get_value, set_value, toml_stat, set_string implicit none public :: git_target_t, git_target_default, git_target_branch, git_target_tag, git_target_revision, git_revision, & @@ -26,6 +26,9 @@ module fpm_git !> Commit hash integer :: revision = 203 + !> Invalid descriptor + integer :: error = -999 + end type enum_descriptor !> Actual enumerator for descriptors @@ -33,7 +36,7 @@ module fpm_git !> Description of an git target - type :: git_target_t + type, extends(serializable_t) :: git_target_t !> Kind of the git target integer :: descriptor = git_descriptor%default @@ -52,6 +55,11 @@ module fpm_git !> Show information on instance procedure :: info + !> Serialization interface + procedure :: serializable_is_same => git_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + end type git_target_t @@ -148,6 +156,30 @@ logical function git_target_eq(this,that) result(is_equal) end function git_target_eq + !> Check that two git targets are equal + logical function git_is_same(this,that) + class(git_target_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + git_is_same = .false. + + select type (other=>that) + type is (git_target_t) + + if (.not.(this%descriptor==other%descriptor)) return + if (.not.(this%url==other%url)) return + if (.not.(this%object==other%object)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + git_is_same = .true. + + end function git_is_same + !> Check that a cached dependency matches a manifest request logical function git_matches_manifest(cached,manifest,verbosity,iunit) @@ -308,6 +340,89 @@ subroutine info(self, unit, verbosity) end subroutine info + !> Dump dependency to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(git_target_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr + + call set_string(table, "descriptor", descriptor_name(self%descriptor), error, 'git_target_t') + if (allocated(error)) return + call set_string(table, "url", self%url, error, 'git_target_t') + if (allocated(error)) return + call set_string(table, "object", self%object, error, 'git_target_t') + if (allocated(error)) return + + end subroutine dump_to_toml + + !> Read dependency from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(git_target_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + character(len=:), allocatable :: descriptor_name + + call get_value(table, "descriptor", descriptor_name) + self%descriptor = parse_descriptor(descriptor_name) + + if (self%descriptor==git_descriptor%error) then + call fatal_error(error,"invalid descriptor ID <"//descriptor_name//"> in TOML entry") + return + end if + + !> Target URL of the git repository + call get_value(table, "url", self%url) + + !> Additional descriptor of the git object + call get_value(table,"object", self%object) + + end subroutine load_from_toml + + !> Parse git descriptor identifier from a string + pure integer function parse_descriptor(name) + character(len=*), intent(in) :: name + + select case (name) + case ("default"); parse_descriptor = git_descriptor%default + case ("branch"); parse_descriptor = git_descriptor%branch + case ("tag"); parse_descriptor = git_descriptor%tag + case ("revision"); parse_descriptor = git_descriptor%revision + case default; parse_descriptor = git_descriptor%error + end select + + end function parse_descriptor + + !> Code git descriptor to a string + pure function descriptor_name(descriptor) result(name) + integer, intent(in) :: descriptor + character(len=:), allocatable :: name + + select case (descriptor) + case (git_descriptor%default); name = "default" + case (git_descriptor%branch); name = "branch" + case (git_descriptor%tag); name = "tag" + case (git_descriptor%revision); name = "revision" + case default; name = "ERROR" + end select + + end function descriptor_name + !> Archive a folder using `git archive`. subroutine git_archive(source, destination, ref, verbose, error) !> Directory to archive. diff --git a/src/fpm/manifest/build.f90 b/src/fpm/manifest/build.f90 index 537fd3dd3a..035ea0d51d 100644 --- a/src/fpm/manifest/build.f90 +++ b/src/fpm/manifest/build.f90 @@ -11,24 +11,25 @@ !>``` module fpm_manifest_build use fpm_error, only : error_t, syntax_error, fatal_error - use fpm_strings, only : string_t, len_trim, is_valid_module_prefix - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list + use fpm_strings, only : string_t, len_trim, is_valid_module_prefix, operator(==) + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list, serializable_t, & + set_value, set_string, set_list implicit none private public :: build_config_t, new_build_config !> Configuration data for build - type :: build_config_t + type, extends(serializable_t) :: build_config_t !> Automatic discovery of executables - logical :: auto_executables + logical :: auto_executables = .true. !> Automatic discovery of examples - logical :: auto_examples + logical :: auto_examples = .true. !> Automatic discovery of tests - logical :: auto_tests + logical :: auto_tests = .true. !> Enforcing of package module names logical :: module_naming = .false. @@ -45,8 +46,15 @@ module fpm_manifest_build !> Print information on this instance procedure :: info + !> Serialization interface + procedure :: serializable_is_same => build_conf_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + end type build_config_t + character(*), parameter, private :: class_name = 'build_config_t' + contains @@ -97,9 +105,8 @@ subroutine new_build_config(self, table, package_name, error) if (stat == toml_stat%success) then - ! Boolean value found. Set no custom prefix. This also falls back to - ! key not provided - self%module_prefix = string_t("") + ! Boolean value found. Set no custom prefix. This also falls back to key not provided + if (allocated(self%module_prefix%s)) deallocate(self%module_prefix%s) else @@ -211,4 +218,110 @@ subroutine info(self, unit, verbosity) end subroutine info + !> Check that two dependency trees are equal + logical function build_conf_is_same(this,that) + class(build_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + build_conf_is_same = .false. + + select type (other=>that) + type is (build_config_t) + + if (this%auto_executables.neqv.other%auto_executables) return + if (this%auto_examples.neqv.other%auto_examples) return + if (this%auto_tests.neqv.other%auto_tests) return + if (this%module_naming.neqv.other%module_naming) return + if (.not.this%module_prefix==other%module_prefix) return + if (.not.this%link==other%link) return + if (.not.this%external_modules==other%external_modules) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + build_conf_is_same = .true. + + end function build_conf_is_same + + !> Dump build config to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(build_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call set_value(table, "auto-executables", self%auto_executables, error, class_name) + if (allocated(error)) return + call set_value(table, "auto-tests", self%auto_tests, error, class_name) + if (allocated(error)) return + call set_value(table, "auto-examples", self%auto_examples, error, class_name) + if (allocated(error)) return + + ! Module naming can either contain a boolean value, or the prefix + has_prefix: if (self%module_naming .and. len_trim(self%module_prefix)>0) then + call set_string(table, "module-naming", self%module_prefix, error, class_name) + else + call set_value (table, "module-naming", self%module_naming, error, class_name) + end if has_prefix + if (allocated(error)) return + + call set_list(table, "link", self%link, error) + if (allocated(error)) return + call set_list(table, "external-modules", self%external_modules, error) + if (allocated(error)) return + + end subroutine dump_to_toml + + !> Read build config from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(build_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: stat + + call get_value(table, "auto-executables", self%auto_executables, error, class_name) + if (allocated(error)) return + call get_value(table, "auto-tests", self%auto_tests, error, class_name) + if (allocated(error)) return + call get_value(table, "auto-examples", self%auto_examples, error, class_name) + if (allocated(error)) return + + !> Module naming: fist, attempt boolean value first + call get_value(table, "module-naming", self%module_naming, .false., stat=stat) + if (stat == toml_stat%success) then + ! Boolean value found. Set no custom prefix. This also falls back to key not provided + if (allocated(self%module_prefix%s)) deallocate(self%module_prefix%s) + else + !> Value found, but not a boolean. Attempt to read a prefix string + call get_value(table, "module-naming", self%module_prefix%s) + if (.not.allocated(self%module_prefix%s)) then + call syntax_error(error,"Could not read value for 'module-naming' in fpm.toml, expecting logical or a string") + return + end if + self%module_naming = .true. + end if + + call get_list(table, "link", self%link, error) + if (allocated(error)) return + call get_list(table, "external-modules", self%external_modules, error) + if (allocated(error)) return + + end subroutine load_from_toml + + end module fpm_manifest_build diff --git a/src/fpm/manifest/dependency.f90 b/src/fpm/manifest/dependency.f90 index de4f104db9..3ebbad7de6 100644 --- a/src/fpm/manifest/dependency.f90 +++ b/src/fpm/manifest/dependency.f90 @@ -23,10 +23,11 @@ !> 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_error, only: error_t, syntax_error, fatal_error use fpm_git, only: git_target_t, git_target_tag, git_target_branch, & & git_target_revision, git_target_default, operator(==), git_matches_manifest - use fpm_toml, only: toml_table, toml_key, toml_stat, get_value, check_keys + use fpm_toml, only: toml_table, toml_key, toml_stat, get_value, check_keys, serializable_t, add_table, & + & set_value, set_string use fpm_filesystem, only: windows_path, join_path use fpm_environment, only: get_os_type, OS_WINDOWS use fpm_manifest_metapackages, only: metapackage_config_t, is_meta_package, new_meta_config, & @@ -37,10 +38,11 @@ module fpm_manifest_dependency implicit none private - public :: dependency_config_t, new_dependency, new_dependencies, manifest_has_changed + public :: dependency_config_t, new_dependency, new_dependencies, manifest_has_changed, & + & dependency_destroy, resize !> Configuration meta data for a dependency - type :: dependency_config_t + type, extends(serializable_t) :: dependency_config_t !> Name of the dependency character(len=:), allocatable :: name @@ -68,11 +70,20 @@ module fpm_manifest_dependency !> Print information on this instance procedure :: info + !> Serialization interface + procedure :: serializable_is_same => dependency_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + end type dependency_config_t !> Common output format for writing to the command line character(len=*), parameter :: out_fmt = '("#", *(1x, g0))' + interface resize + module procedure resize_dependency_config + end interface resize + contains !> Construct a new dependency configuration from a TOML data structure @@ -377,5 +388,169 @@ logical function manifest_has_changed(cached, manifest, verbosity, iunit) result end function manifest_has_changed + !> Clean memory + elemental subroutine dependency_destroy(self) + class(dependency_config_t), intent(inout) :: self + + if (allocated(self%name)) deallocate(self%name) + if (allocated(self%path)) deallocate(self%path) + if (allocated(self%namespace)) deallocate(self%namespace) + if (allocated(self%requested_version)) deallocate(self%requested_version) + if (allocated(self%git)) deallocate(self%git) + + end subroutine dependency_destroy + + !> Check that two dependency configs are equal + logical function dependency_is_same(this,that) + class(dependency_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + dependency_is_same = .false. + + select type (other=>that) + type is (dependency_config_t) + + if (.not.(this%name==other%name)) return + if (.not.(this%path==other%path)) return + if (.not.(this%namespace==other%namespace)) return + if (.not.(allocated(this%requested_version).eqv.allocated(other%requested_version))) return + if (allocated(this%requested_version)) then + if (.not.(this%requested_version==other%requested_version)) return + endif + + if (.not.(allocated(this%git).eqv.allocated(other%git))) return + if (allocated(this%git)) then + if (.not.(this%git==other%git)) return + endif + + class default + ! Not the same type + return + end select + + !> All checks passed! + dependency_is_same = .true. + + end function dependency_is_same + + !> Dump dependency to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(dependency_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(toml_table), pointer :: ptr + type(error_t), allocatable, intent(out) :: error + + integer :: ierr + + call set_string(table, "name", self%name, error, 'dependency_config_t') + if (allocated(error)) return + call set_string(table, "path", self%path, error, 'dependency_config_t') + if (allocated(error)) return + call set_string(table, "namespace", self%namespace, error, 'dependency_config_t') + if (allocated(error)) return + if (allocated(self%requested_version)) then + call set_string(table, "requested_version", self%requested_version%s(), error, 'dependency_config_t') + if (allocated(error)) return + endif + + if (allocated(self%git)) then + call add_table(table, "git", ptr, error) + if (allocated(error)) return + call self%git%dump_to_toml(ptr, error) + if (allocated(error)) return + endif + + end subroutine dump_to_toml + + !> Read dependency from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(dependency_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + type(toml_key), allocatable :: list(:) + type(toml_table), pointer :: ptr + character(len=:), allocatable :: requested_version + integer :: ierr,ii + + call dependency_destroy(self) + + call get_value(table, "name", self%name) + call get_value(table, "path", self%path) + call get_value(table, "namespace", self%namespace) + call get_value(table, "requested_version", requested_version) + if (allocated(requested_version)) then + allocate(self%requested_version) + call new_version(self%requested_version, requested_version, error) + if (allocated(error)) then + error%message = 'dependency_config_t: version error from TOML table - '//error%message + return + endif + end if + + call table%get_keys(list) + add_git: do ii = 1, size(list) + if (list(ii)%key=="git") then + call get_value(table, list(ii)%key, ptr, stat=ierr) + if (ierr /= toml_stat%success) then + call fatal_error(error,'dependency_config_t: cannot retrieve git from TOML table') + exit + endif + allocate(self%git) + call self%git%load_from_toml(ptr, error) + if (allocated(error)) return + exit add_git + end if + end do add_git + + end subroutine load_from_toml + + !> Reallocate a list of dependencies + pure subroutine resize_dependency_config(var, n) + !> Instance of the array to be resized + type(dependency_config_t), allocatable, intent(inout) :: var(:) + !> Dimension of the final array size + integer, intent(in), optional :: n + + type(dependency_config_t), allocatable :: tmp(:) + integer :: this_size, new_size + integer, parameter :: initial_size = 16 + + if (allocated(var)) then + this_size = size(var, 1) + call move_alloc(var, tmp) + else + this_size = initial_size + end if + + if (present(n)) then + new_size = n + else + new_size = this_size + this_size/2 + 1 + end if + + 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) + end if + + end subroutine resize_dependency_config + end module fpm_manifest_dependency diff --git a/src/fpm/manifest/executable.f90 b/src/fpm/manifest/executable.f90 index 66bb0f2cb2..47c500a824 100644 --- a/src/fpm/manifest/executable.f90 +++ b/src/fpm/manifest/executable.f90 @@ -11,10 +11,11 @@ !>[executable.dependencies] !>``` module fpm_manifest_executable - use fpm_manifest_dependency, only : dependency_config_t, new_dependencies - use fpm_error, only : error_t, syntax_error, bad_name_error - use fpm_strings, only : string_t - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list + use fpm_manifest_dependency, only : dependency_config_t, new_dependencies, resize + use fpm_error, only : error_t, syntax_error, bad_name_error, fatal_error + use fpm_strings, only : string_t, operator(==) + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list, serializable_t, add_table, & + set_string, set_list implicit none private @@ -22,7 +23,7 @@ module fpm_manifest_executable !> Configuation meta data for an executable - type :: executable_config_t + type, extends(serializable_t) :: executable_config_t !> Name of the resulting executable character(len=:), allocatable :: name @@ -44,8 +45,15 @@ module fpm_manifest_executable !> Print information on this instance procedure :: info + !> Serialization interface + procedure :: serializable_is_same => exe_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + end type executable_config_t + character(*), parameter, private :: class_name = 'executable_config_t' + contains @@ -186,4 +194,156 @@ subroutine info(self, unit, verbosity) end subroutine info + logical function exe_is_same(this,that) + class(executable_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + integer :: ii + + exe_is_same = .false. + + select type (other=>that) + type is (executable_config_t) + if (.not.this%link==other%link) return + if (.not.allocated(this%name).eqv.allocated(other%name)) return + if (.not.this%name==other%name) return + if (.not.allocated(this%source_dir).eqv.allocated(other%source_dir)) return + if (.not.this%source_dir==other%source_dir) return + if (.not.allocated(this%main).eqv.allocated(other%main)) return + if (.not.this%main==other%main) return + if (.not.allocated(this%dependency).eqv.allocated(other%dependency)) return + if (allocated(this%dependency)) then + if (.not.(size(this%dependency)==size(other%dependency))) return + do ii = 1, size(this%dependency) + if (.not.(this%dependency(ii)==other%dependency(ii))) return + end do + end if + class default + ! Not the same type + return + end select + + !> All checks passed! + exe_is_same = .true. + + end function exe_is_same + + !> Dump install config to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(executable_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + integer :: ierr, ii + type(toml_table), pointer :: ptr_deps,ptr + character(27) :: unnamed + + call set_string(table, "name", self%name, error) + if (allocated(error)) return + call set_string(table, "source-dir", self%source_dir, error) + if (allocated(error)) return + call set_string(table, "main", self%main, error) + if (allocated(error)) return + + if (allocated(self%dependency)) then + + ! Create dependency table + call add_table(table, "dependencies", ptr_deps) + if (.not. associated(ptr_deps)) then + call fatal_error(error, class_name//" cannot create dependency table ") + return + end if + + do ii = 1, size(self%dependency) + associate (dep => self%dependency(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(dep%name)==0) then + write(unnamed,1) ii + call add_table(ptr_deps, trim(unnamed), ptr) + else + call add_table(ptr_deps, dep%name, ptr) + end if + if (.not. associated(ptr)) then + call fatal_error(error, class_name//" cannot create entry for dependency "//dep%name) + return + end if + call dep%dump_to_toml(ptr, error) + if (allocated(error)) return + end associate + end do + + endif + + call set_list(table, "link", self%link, error) + if (allocated(error)) return + + 1 format('UNNAMED_DEPENDENCY_',i0) + + end subroutine dump_to_toml + + !> Read install config from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(executable_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + type(toml_key), allocatable :: keys(:),dep_keys(:) + type(toml_table), pointer :: ptr_deps,ptr + integer :: ii, jj, ierr + + call table%get_keys(keys) + + call get_value(table, "name", self%name) + if (allocated(error)) return + call get_value(table, "source-dir", self%source_dir) + if (allocated(error)) return + call get_value(table, "main", self%main) + if (allocated(error)) return + call get_list(table, "link", self%link, error) + + find_deps_table: do ii = 1, size(keys) + if (keys(ii)%key=="dependencies") then + + call get_value(table, keys(ii), ptr_deps) + if (.not.associated(ptr_deps)) then + call fatal_error(error,class_name//': error retrieving dependency table from TOML table') + return + end if + + !> Read all dependencies + call ptr_deps%get_keys(dep_keys) + call resize(self%dependency, size(dep_keys)) + + do jj = 1, size(dep_keys) + + call get_value(ptr_deps, dep_keys(jj), ptr) + call self%dependency(jj)%load_from_toml(ptr, error) + if (allocated(error)) return + + end do + + exit find_deps_table + + endif + end do find_deps_table + + end subroutine load_from_toml + + end module fpm_manifest_executable diff --git a/src/fpm/manifest/fortran.f90 b/src/fpm/manifest/fortran.f90 index bf76fa2e38..083d61fe1e 100644 --- a/src/fpm/manifest/fortran.f90 +++ b/src/fpm/manifest/fortran.f90 @@ -1,25 +1,34 @@ module fpm_manifest_fortran use fpm_error, only : error_t, syntax_error, fatal_error - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, serializable_t, set_value, set_string implicit none private public :: fortran_config_t, new_fortran_config !> Configuration data for Fortran - type :: fortran_config_t + type, extends(serializable_t) :: fortran_config_t !> Enable default implicit typing - logical :: implicit_typing + logical :: implicit_typing = .false. !> Enable implicit external interfaces - logical :: implicit_external + logical :: implicit_external = .false. !> Form to use for all Fortran sources character(:), allocatable :: source_form + contains + + !> Serialization interface + procedure :: serializable_is_same => fortran_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + end type fortran_config_t + character(len=*), parameter, private :: class_name = 'fortran_config_t' + contains !> Construct a new build configuration from a TOML data structure @@ -102,4 +111,68 @@ subroutine check(table, error) end subroutine check + logical function fortran_is_same(this,that) + class(fortran_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + fortran_is_same = .false. + + select type (other=>that) + type is (fortran_config_t) + if (this%implicit_typing.neqv.other%implicit_typing) return + if (this%implicit_external.neqv.other%implicit_external) return + if (.not.allocated(this%source_form).eqv.allocated(other%source_form)) return + if (.not.this%source_form==other%source_form) return + class default + ! Not the same type + return + end select + + !> All checks passed! + fortran_is_same = .true. + + end function fortran_is_same + + !> Dump install config to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(fortran_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call set_value(table, "implicit-typing", self%implicit_typing, error, class_name) + if (allocated(error)) return + call set_value(table, "implicit-external", self%implicit_external, error, class_name) + if (allocated(error)) return + call set_string(table, "source-form", self%source_form, error, class_name) + if (allocated(error)) return + + end subroutine dump_to_toml + + !> Read install config from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(fortran_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call get_value(table, "implicit-typing", self%implicit_typing, error, class_name) + if (allocated(error)) return + call get_value(table, "implicit-external", self%implicit_external, error, class_name) + if (allocated(error)) return + call get_value(table, "source-form", self%source_form) + + end subroutine load_from_toml + + end module fpm_manifest_fortran diff --git a/src/fpm/manifest/install.f90 b/src/fpm/manifest/install.f90 index 6175873937..88c3097eb0 100644 --- a/src/fpm/manifest/install.f90 +++ b/src/fpm/manifest/install.f90 @@ -7,25 +7,32 @@ !>``` module fpm_manifest_install use fpm_error, only : error_t, fatal_error, syntax_error - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, set_value, serializable_t implicit none private public :: install_config_t, new_install_config !> Configuration data for installation - type :: install_config_t + type, extends(serializable_t) :: install_config_t !> Install library with this project - logical :: library + logical :: library = .false. contains !> Print information on this instance procedure :: info + !> Serialization interface + procedure :: serializable_is_same => install_conf_same + procedure :: dump_to_toml + procedure :: load_from_toml + end type install_config_t + character(*), parameter, private :: class_name = 'install_config_t' + contains !> Create a new installation configuration from a TOML data structure @@ -105,4 +112,58 @@ subroutine info(self, unit, verbosity) end subroutine info + logical function install_conf_same(this,that) + class(install_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + install_conf_same = .false. + + select type (other=>that) + type is (install_config_t) + if (this%library.neqv.other%library) return + class default + ! Not the same type + return + end select + + !> All checks passed! + install_conf_same = .true. + + end function install_conf_same + + !> Dump install config to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(install_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call set_value(table, "library", self%library, error, class_name) + + end subroutine dump_to_toml + + !> Read install config from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(install_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: stat + + call get_value(table, "library", self%library, error, class_name) + if (allocated(error)) return + + end subroutine load_from_toml + end module fpm_manifest_install diff --git a/src/fpm/manifest/library.f90 b/src/fpm/manifest/library.f90 index 68ccc203ef..52e33efecb 100644 --- a/src/fpm/manifest/library.f90 +++ b/src/fpm/manifest/library.f90 @@ -10,8 +10,9 @@ !>``` module fpm_manifest_library use fpm_error, only : error_t, syntax_error - use fpm_strings, only: string_t, string_cat - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list + use fpm_strings, only: string_t, string_cat, operator(==) + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list, serializable_t, set_value, & + set_list, set_string, get_value, get_list implicit none private @@ -19,7 +20,7 @@ module fpm_manifest_library !> Configuration meta data for a library - type :: library_config_t + type, extends(serializable_t) :: library_config_t !> Source path prefix character(len=:), allocatable :: source_dir @@ -35,8 +36,15 @@ module fpm_manifest_library !> Print information on this instance procedure :: info + !> Serialization interface + procedure :: serializable_is_same => library_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + end type library_config_t + character(*), parameter, private :: class_name = 'library_config_t' + contains @@ -138,5 +146,69 @@ subroutine info(self, unit, verbosity) end subroutine info + logical function library_is_same(this,that) + class(library_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + library_is_same = .false. + + select type (other=>that) + type is (library_config_t) + if (.not.this%include_dir==other%include_dir) return + if (.not.allocated(this%source_dir).eqv.allocated(other%source_dir)) return + if (.not.this%source_dir==other%source_dir) return + if (.not.allocated(this%build_script).eqv.allocated(other%build_script)) return + if (.not.this%build_script==other%build_script) return + class default + ! Not the same type + return + end select + + !> All checks passed! + library_is_same = .true. + + end function library_is_same + + !> Dump install config to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(library_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call set_string(table, "source-dir", self%source_dir, error, class_name) + if (allocated(error)) return + call set_string(table, "build-script", self%build_script, error, class_name) + if (allocated(error)) return + call set_list(table, "include-dir", self%include_dir, error) + if (allocated(error)) return + + end subroutine dump_to_toml + + !> Read install config from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(library_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call get_value(table, "source-dir", self%source_dir) + if (allocated(error)) return + call get_value(table, "build-script", self%build_script) + if (allocated(error)) return + call get_list(table, "include-dir", self%include_dir, error) + + end subroutine load_from_toml + end module fpm_manifest_library diff --git a/src/fpm/manifest/package.f90 b/src/fpm/manifest/package.f90 index 6c8fed4bb0..78bbb4d4df 100644 --- a/src/fpm/manifest/package.f90 +++ b/src/fpm/manifest/package.f90 @@ -47,7 +47,8 @@ module fpm_manifest_package use fpm_manifest_metapackages, only: metapackage_config_t, new_meta_config use fpm_filesystem, only : exists, getline, join_path use fpm_error, only : error_t, fatal_error, syntax_error, bad_name_error - use fpm_toml, only : toml_table, toml_array, toml_key, toml_stat, get_value, len + use fpm_toml, only : toml_table, toml_array, toml_key, toml_stat, get_value, len, & + serializable_t, set_value, set_string, set_list, add_table use fpm_versioning, only : version_t, new_version implicit none private @@ -62,7 +63,7 @@ module fpm_manifest_package !> Package meta data - type :: package_config_t + type, extends(serializable_t) :: package_config_t !> Name of the package character(len=:), allocatable :: name @@ -85,6 +86,15 @@ module fpm_manifest_package !> License meta data character(len=:), allocatable :: license + !> Author meta data + character(len=:), allocatable :: author + + !> Maintainer meta data + character(len=:), allocatable :: maintainer + + !> Copyright meta data + character(len=:), allocatable :: copyright + !> Library meta data type(library_config_t), allocatable :: library @@ -114,8 +124,15 @@ module fpm_manifest_package !> Print information on this instance procedure :: info + !> Serialization interface + procedure :: serializable_is_same => manifest_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + end type package_config_t + character(len=*), parameter, private :: class_name = 'package_config_t' + contains @@ -157,6 +174,9 @@ subroutine new_package(self, table, root, error) endif call get_value(table, "license", self%license) + call get_value(table, "author", self%author) + call get_value(table, "maintainer", self%maintainer) + call get_value(table, "copyright", self%copyright) if (len(self%name) <= 0) then call syntax_error(error, "Package name must be a non-empty string") @@ -511,5 +531,555 @@ subroutine unique_programs2(executable_i, executable_j, error) end subroutine unique_programs2 + logical function manifest_is_same(this,that) + class(package_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + integer :: ii + + manifest_is_same = .false. + + select type (other=>that) + type is (package_config_t) + + if (.not.this%name==other%name) return + if (.not.this%version==other%version) return + if (.not.this%build==other%build) return + if (.not.this%install==other%install) return + if (.not.this%fortran==other%fortran) return + if (.not.this%license==other%license) return + if (.not.this%author==other%author) return + if (.not.this%maintainer==other%maintainer) return + if (.not.this%copyright==other%copyright) return + if (allocated(this%library).neqv.allocated(other%library)) return + if (allocated(this%library)) then + if (.not.this%library==other%library) return + endif + if (allocated(this%executable).neqv.allocated(other%executable)) return + if (allocated(this%executable)) then + if (.not.size(this%executable)==size(other%executable)) return + do ii=1,size(this%executable) + if (.not.this%executable(ii)==other%executable(ii)) return + end do + end if + if (allocated(this%dependency).neqv.allocated(other%dependency)) return + if (allocated(this%dependency)) then + if (.not.size(this%dependency)==size(other%dependency)) return + do ii=1,size(this%dependency) + if (.not.this%dependency(ii)==other%dependency(ii)) return + end do + end if + if (allocated(this%dev_dependency).neqv.allocated(other%dev_dependency)) return + if (allocated(this%dev_dependency)) then + if (.not.size(this%dev_dependency)==size(other%dev_dependency)) return + do ii=1,size(this%dev_dependency) + if (.not.this%dev_dependency(ii)==other%dev_dependency(ii)) return + end do + end if + if (allocated(this%profiles).neqv.allocated(other%profiles)) return + if (allocated(this%profiles)) then + if (.not.size(this%profiles)==size(other%profiles)) return + do ii=1,size(this%profiles) + if (.not.this%profiles(ii)==other%profiles(ii)) return + end do + end if + if (allocated(this%example).neqv.allocated(other%example)) return + if (allocated(this%example)) then + if (.not.size(this%example)==size(other%example)) return + do ii=1,size(this%example) + if (.not.this%example(ii)==other%example(ii)) return + end do + end if + if (allocated(this%preprocess).neqv.allocated(other%preprocess)) return + if (allocated(this%preprocess)) then + if (.not.size(this%preprocess)==size(other%preprocess)) return + do ii=1,size(this%preprocess) + if (.not.this%preprocess(ii)==other%preprocess(ii)) return + end do + end if + if (allocated(this%test).neqv.allocated(other%test)) return + if (allocated(this%test)) then + if (.not.size(this%test)==size(other%test)) return + do ii=1,size(this%test) + if (.not.this%test(ii)==other%test(ii)) return + end do + end if + + class default + ! Not the same type + return + end select + + !> All checks passed! + manifest_is_same = .true. + + end function manifest_is_same + + !> Dump manifest to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(package_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr, ii + type(toml_table), pointer :: ptr,ptr_pkg + character(30) :: unnamed + character(128) :: profile_name + + call set_string(table, "name", self%name, error, class_name) + if (allocated(error)) return + call set_string(table, "version", self%version%s(), error, class_name) + if (allocated(error)) return + call set_string(table, "license", self%license, error, class_name) + if (allocated(error)) return + call set_string(table, "author", self%author, error, class_name) + if (allocated(error)) return + call set_string(table, "maintainer", self%maintainer, error, class_name) + if (allocated(error)) return + call set_string(table, "copyright", self%copyright, error, class_name) + if (allocated(error)) return + + call add_table(table, "build", ptr, error, class_name) + if (allocated(error)) return + call self%build%dump_to_toml(ptr, error) + if (allocated(error)) return + + call add_table(table, "fortran", ptr, error, class_name) + if (allocated(error)) return + call self%fortran%dump_to_toml(ptr, error) + if (allocated(error)) return + + call add_table(table, "install", ptr, error, class_name) + if (allocated(error)) return + call self%install%dump_to_toml(ptr, error) + if (allocated(error)) return + + if (allocated(self%library)) then + call add_table(table, "library", ptr, error, class_name) + if (allocated(error)) return + call self%library%dump_to_toml(ptr, error) + if (allocated(error)) return + end if + + if (allocated(self%executable)) then + + call add_table(table, "executable", ptr_pkg) + if (.not. associated(ptr_pkg)) then + call fatal_error(error, class_name//" cannot create 'executable' table ") + return + end if + + do ii = 1, size(self%executable) + + associate (pkg => self%executable(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(pkg%name)==0) then + write(unnamed,1) 'EXECUTABLE',ii + call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(executable)') + else + call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(executable)') + end if + if (allocated(error)) return + call pkg%dump_to_toml(ptr, error) + if (allocated(error)) return + + end associate + + end do + end if + + if (allocated(self%dependency)) then + + call add_table(table, "dependencies", ptr_pkg) + if (.not. associated(ptr_pkg)) then + call fatal_error(error, class_name//" cannot create 'dependencies' table ") + return + end if + + do ii = 1, size(self%dependency) + + associate (pkg => self%dependency(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(pkg%name)==0) then + write(unnamed,1) 'DEPENDENCY',ii + call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(dependencies)') + else + call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(dependencies)') + end if + if (allocated(error)) return + call pkg%dump_to_toml(ptr, error) + if (allocated(error)) return + + end associate + + end do + end if + + if (allocated(self%dev_dependency)) then + + call add_table(table, "dev-dependencies", ptr_pkg) + if (.not. associated(ptr_pkg)) then + call fatal_error(error, class_name//" cannot create 'dev-dependencies' table ") + return + end if + + do ii = 1, size(self%dev_dependency) + + associate (pkg => self%dev_dependency(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(pkg%name)==0) then + write(unnamed,1) 'DEV-DEPENDENCY',ii + call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(dev-dependencies)') + else + call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(dev-dependencies)') + end if + if (allocated(error)) return + call pkg%dump_to_toml(ptr, error) + if (allocated(error)) return + + end associate + + end do + end if + + if (allocated(self%profiles)) then + + call add_table(table, "profiles", ptr_pkg) + if (.not. associated(ptr_pkg)) then + call fatal_error(error, class_name//" cannot create 'profiles' table ") + return + end if + + do ii = 1, size(self%profiles) + + associate (pkg => self%profiles(ii)) + + !> Duplicate profile names are possible, as multiple profiles are possible with the + !> same name, same compiler, etc. So, use a unique name here + write(profile_name,2) ii + call add_table(ptr_pkg, trim(profile_name), ptr, error, class_name//'(profiles)') + if (allocated(error)) return + call pkg%dump_to_toml(ptr, error) + if (allocated(error)) return + + end associate + + end do + end if + + if (allocated(self%example)) then + + call add_table(table, "example", ptr_pkg) + if (.not. associated(ptr_pkg)) then + call fatal_error(error, class_name//" cannot create 'example' table ") + return + end if + + do ii = 1, size(self%example) + + associate (pkg => self%example(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(pkg%name)==0) then + write(unnamed,1) 'EXAMPLE',ii + call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(example)') + else + call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(example)') + end if + if (allocated(error)) return + call pkg%dump_to_toml(ptr, error) + if (allocated(error)) return + + end associate + + end do + end if + + if (allocated(self%test)) then + + call add_table(table, "test", ptr_pkg) + if (.not. associated(ptr_pkg)) then + call fatal_error(error, class_name//" cannot create 'test' table ") + return + end if + + do ii = 1, size(self%test) + + associate (pkg => self%test(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(pkg%name)==0) then + write(unnamed,1) 'TEST',ii + call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(test)') + else + call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(test)') + end if + if (allocated(error)) return + call pkg%dump_to_toml(ptr, error) + if (allocated(error)) return + + end associate + + end do + end if + + if (allocated(self%preprocess)) then + + call add_table(table, "preprocess", ptr_pkg) + if (.not. associated(ptr_pkg)) then + call fatal_error(error, class_name//" cannot create 'preprocess' table ") + return + end if + + do ii = 1, size(self%preprocess) + + associate (pkg => self%preprocess(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(pkg%name)==0) then + write(unnamed,1) 'PREPROCESS',ii + call add_table(ptr_pkg, trim(unnamed), ptr, error, class_name//'(preprocess)') + else + call add_table(ptr_pkg, pkg%name, ptr, error, class_name//'(preprocess)') + end if + if (allocated(error)) return + call pkg%dump_to_toml(ptr, error) + if (allocated(error)) return + + end associate + + end do + end if + + 1 format('UNNAMED_',a,'_',i0) + 2 format('PROFILE_',i0) + + end subroutine dump_to_toml + + !> Read manifest from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(package_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: keys(:),pkg_keys(:) + integer :: ierr, ii, jj + character(len=:), allocatable :: flag + type(toml_table), pointer :: ptr,ptr_pkg + + call table%get_keys(keys) + + call get_value(table, "name", self%name) + call get_value(table, "license", self%license) + call get_value(table, "author", self%author) + call get_value(table, "maintainer", self%maintainer) + call get_value(table, "copyright", self%copyright) + call get_value(table, "version", flag) + call new_version(self%version, flag, error) + if (allocated(error)) then + error%message = class_name//': version error from TOML table - '//error%message + return + endif + + if (allocated(self%library)) deallocate(self%library) + if (allocated(self%executable)) deallocate(self%executable) + if (allocated(self%dependency)) deallocate(self%dependency) + if (allocated(self%dev_dependency)) deallocate(self%dev_dependency) + if (allocated(self%profiles)) deallocate(self%profiles) + if (allocated(self%example)) deallocate(self%example) + if (allocated(self%test)) deallocate(self%test) + if (allocated(self%preprocess)) deallocate(self%preprocess) + sub_deps: do ii = 1, size(keys) + + select case (keys(ii)%key) + case ("build") + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving '//keys(ii)%key//' table') + return + end if + call self%build%load_from_toml(ptr, error) + if (allocated(error)) return + + case ("install") + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving '//keys(ii)%key//' table') + return + end if + call self%install%load_from_toml(ptr, error) + + case ("fortran") + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving '//keys(ii)%key//' table') + return + end if + call self%fortran%load_from_toml(ptr, error) + + case ("library") + + allocate(self%library) + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving '//keys(ii)%key//' table') + return + end if + call self%library%load_from_toml(ptr, error) + + case ("executable") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving executable table') + return + end if + + !> Read all packages + call ptr%get_keys(pkg_keys) + allocate(self%executable(size(pkg_keys))) + + do jj = 1, size(pkg_keys) + call get_value(ptr, pkg_keys(jj), ptr_pkg) + call self%executable(jj)%load_from_toml(ptr_pkg, error) + if (allocated(error)) return + end do + + case ("dependencies") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving dependency table') + return + end if + + !> Read all packages + call ptr%get_keys(pkg_keys) + allocate(self%dependency(size(pkg_keys))) + + do jj = 1, size(pkg_keys) + call get_value(ptr, pkg_keys(jj), ptr_pkg) + call self%dependency(jj)%load_from_toml(ptr_pkg, error) + if (allocated(error)) return + end do + + case ("dev-dependencies") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving dev-dependencies table') + return + end if + + !> Read all packages + call ptr%get_keys(pkg_keys) + allocate(self%dev_dependency(size(pkg_keys))) + + do jj = 1, size(pkg_keys) + call get_value(ptr, pkg_keys(jj), ptr_pkg) + call self%dev_dependency(jj)%load_from_toml(ptr_pkg, error) + if (allocated(error)) return + end do + + case ("profiles") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving profiles table') + return + end if + + !> Read all packages + call ptr%get_keys(pkg_keys) + allocate(self%profiles(size(pkg_keys))) + + do jj = 1, size(pkg_keys) + call get_value(ptr, pkg_keys(jj), ptr_pkg) + call self%profiles(jj)%load_from_toml(ptr_pkg, error) + if (allocated(error)) return + end do + + case ("example") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving example table') + return + end if + + !> Read all packages + call ptr%get_keys(pkg_keys) + allocate(self%example(size(pkg_keys))) + + do jj = 1, size(pkg_keys) + call get_value(ptr, pkg_keys(jj), ptr_pkg) + call self%example(jj)%load_from_toml(ptr_pkg, error) + if (allocated(error)) return + end do + + case ("test") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving test table') + return + end if + + !> Read all packages + call ptr%get_keys(pkg_keys) + allocate(self%test(size(pkg_keys))) + + do jj = 1, size(pkg_keys) + call get_value(ptr, pkg_keys(jj), ptr_pkg) + call self%test(jj)%load_from_toml(ptr_pkg, error) + if (allocated(error)) return + end do + + case ("preprocess") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,class_name//': error retrieving preprocess table') + return + end if + + !> Read all packages + call ptr%get_keys(pkg_keys) + allocate(self%preprocess(size(pkg_keys))) + + do jj = 1, size(pkg_keys) + call get_value(ptr, pkg_keys(jj), ptr_pkg) + call self%preprocess(jj)%load_from_toml(ptr_pkg, error) + if (allocated(error)) return + end do + + case default + cycle sub_deps + end select + + end do sub_deps + + end subroutine load_from_toml end module fpm_manifest_package diff --git a/src/fpm/manifest/preprocess.f90 b/src/fpm/manifest/preprocess.f90 index 2df2570e39..49ad24f82d 100644 --- a/src/fpm/manifest/preprocess.f90 +++ b/src/fpm/manifest/preprocess.f90 @@ -12,8 +12,9 @@ module fpm_manifest_preprocess use fpm_error, only : error_t, syntax_error - use fpm_strings, only : string_t - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list + use fpm_strings, only : string_t, operator(==) + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, get_list, serializable_t, set_value, set_list, & + set_string use,intrinsic :: iso_fortran_env, only : stderr=>error_unit implicit none private @@ -21,7 +22,7 @@ module fpm_manifest_preprocess public :: preprocess_config_t, new_preprocess_config, new_preprocessors, operator(==) !> Configuration meta data for a preprocessor - type :: preprocess_config_t + type, extends(serializable_t) :: preprocess_config_t !> Name of the preprocessor character(len=:), allocatable :: name @@ -40,6 +41,11 @@ module fpm_manifest_preprocess !> Print information on this instance procedure :: info + !> Serialization interface + procedure :: serializable_is_same => preprocess_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + !> Operations procedure :: destroy procedure :: add_config @@ -50,6 +56,8 @@ module fpm_manifest_preprocess end type preprocess_config_t + character(*), parameter, private :: class_name = 'preprocess_config_t' + interface operator(==) module procedure preprocess_is_same end interface @@ -196,10 +204,11 @@ end subroutine info logical function preprocess_is_same(this,that) class(preprocess_config_t), intent(in) :: this - class(preprocess_config_t), intent(in) :: that + class(serializable_t), intent(in) :: that integer :: istr + preprocess_is_same = .false. select type (other=>that) @@ -208,24 +217,10 @@ logical function preprocess_is_same(this,that) if (allocated(this%name)) then if (.not.(this%name==other%name)) return endif - if (.not.(allocated(this%suffixes).eqv.allocated(other%suffixes))) return - if (allocated(this%suffixes)) then - do istr=1,size(this%suffixes) - if (.not.(this%suffixes(istr)%s==other%suffixes(istr)%s)) return - end do - end if - if (.not.(allocated(this%directories).eqv.allocated(other%directories))) return - if (allocated(this%directories)) then - do istr=1,size(this%directories) - if (.not.(this%directories(istr)%s==other%directories(istr)%s)) return - end do - end if - if (.not.(allocated(this%macros).eqv.allocated(other%macros))) return - if (allocated(this%macros)) then - do istr=1,size(this%macros) - if (.not.(this%macros(istr)%s==other%macros(istr)%s)) return - end do - end if + + if (.not.(this%suffixes==other%suffixes)) return + if (.not.(this%directories==other%directories)) return + if (.not.(this%macros==other%macros)) return class default ! Not the same type @@ -237,6 +232,51 @@ logical function preprocess_is_same(this,that) end function preprocess_is_same + !> Dump install config to toml table + subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(preprocess_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call set_string(table, "name", self%name, error) + if (allocated(error)) return + call set_list(table, "suffixes", self%suffixes, error) + if (allocated(error)) return + call set_list(table, "directories", self%directories, error) + if (allocated(error)) return + call set_list(table, "macros", self%macros, error) + if (allocated(error)) return + + end subroutine dump_to_toml + + !> Read install config from toml table (no checks made at this stage) + subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(preprocess_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call get_value(table, "name", self%name) + call get_list(table, "suffixes", self%suffixes, error) + if (allocated(error)) return + call get_list(table, "directories", self%directories, error) + if (allocated(error)) return + call get_list(table, "macros", self%macros, error) + if (allocated(error)) return + + end subroutine load_from_toml + !> Clean preprocessor structure elemental subroutine destroy(this) class(preprocess_config_t), intent(inout) :: this diff --git a/src/fpm/manifest/profiles.f90 b/src/fpm/manifest/profiles.f90 index 8f1e82eaa5..f50cf32cff 100644 --- a/src/fpm/manifest/profiles.f90 +++ b/src/fpm/manifest/profiles.f90 @@ -43,10 +43,11 @@ !> module fpm_manifest_profile use fpm_error, only : error_t, syntax_error, fatal_error, fpm_stop - use fpm_toml, only : toml_table, toml_key, toml_stat, get_value + use fpm_toml, only : toml_table, toml_key, toml_stat, get_value, serializable_t, set_value, & + set_string, add_table use fpm_strings, only: lower use fpm_environment, only: get_os_type, OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & - OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD + OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD, OS_NAME use fpm_filesystem, only: join_path implicit none public :: profile_config_t, new_profile, new_profiles, get_default_profiles, & @@ -58,7 +59,7 @@ module fpm_manifest_profile character(len=:), allocatable :: path !> Type storing file name - file scope compiler flags pairs - type :: file_scope_flag + type, extends(serializable_t) :: file_scope_flag !> Name of the file character(len=:), allocatable :: file_name @@ -66,10 +67,17 @@ module fpm_manifest_profile !> File scope flags character(len=:), allocatable :: flags + contains + + !> Serialization interface + procedure :: serializable_is_same => file_scope_same + procedure :: dump_to_toml => file_scope_dump + procedure :: load_from_toml => file_scope_load + end type file_scope_flag !> Configuration meta data for a profile - type :: profile_config_t + type, extends(serializable_t) :: profile_config_t !> Name of the profile character(len=:), allocatable :: profile_name @@ -77,7 +85,7 @@ module fpm_manifest_profile character(len=:), allocatable :: compiler !> Value repesenting OS - integer :: os_type + integer :: os_type = OS_ALL !> Fortran compiler flags character(len=:), allocatable :: flags @@ -95,13 +103,18 @@ module fpm_manifest_profile type(file_scope_flag), allocatable :: file_scope_flags(:) !> Is this profile one of the built-in ones? - logical :: is_built_in + logical :: is_built_in = .false. contains !> Print information on this instance procedure :: info + !> Serialization interface + procedure :: serializable_is_same => profile_same + procedure :: dump_to_toml => profile_dump + procedure :: load_from_toml => profile_load + end type profile_config_t contains @@ -221,7 +234,8 @@ subroutine match_os_type(os_name, os_type) select case (os_name) case ("linux"); os_type = OS_LINUX - case ("macos"); os_type = OS_WINDOWS + case ("macos"); os_type = OS_MACOS + case ("windows"); os_type = OS_WINDOWS case ("cygwin"); os_type = OS_CYGWIN case ("solaris"); os_type = OS_SOLARIS case ("freebsd"); os_type = OS_FREEBSD @@ -232,6 +246,22 @@ subroutine match_os_type(os_name, os_type) end subroutine match_os_type + !> Match lowercase string with name of OS to os_type enum + function os_type_name(os_type) + + !> Name of operating system + character(len=:), allocatable :: os_type_name + + !> Enum representing type of OS + integer, intent(in) :: os_type + + select case (os_type) + case (OS_ALL); os_type_name = "all" + case default; os_type_name = lower(OS_NAME(os_type)) + end select + + end function os_type_name + subroutine validate_profile_table(profile_name, compiler_name, key_list, table, error, os_valid) !> Name of profile @@ -836,7 +866,7 @@ subroutine info(self, unit, verbosity) write(unit, fmt) "- compiler", self%compiler end if - write(unit, fmt) "- os", self%os_type + write(unit, fmt) "- os", os_type_name(self%os_type) if (allocated(self%flags)) then write(unit, fmt) "- compiler flags", self%flags @@ -954,4 +984,256 @@ subroutine find_profile(profiles, profile_name, compiler, os_type, found_matchin end do end if end subroutine find_profile + + + logical function file_scope_same(this,that) + class(file_scope_flag), intent(in) :: this + class(serializable_t), intent(in) :: that + + file_scope_same = .false. + + select type (other=>that) + type is (file_scope_flag) + if (allocated(this%file_name).neqv.allocated(other%file_name)) return + if (allocated(this%file_name)) then + if (.not.(this%file_name==other%file_name)) return + endif + if (allocated(this%flags).neqv.allocated(other%flags)) return + if (allocated(this%flags)) then + if (.not.(this%flags==other%flags)) return + endif + + class default + ! Not the same type + return + end select + + !> All checks passed! + file_scope_same = .true. + + end function file_scope_same + + !> Dump to toml table + subroutine file_scope_dump(self, table, error) + + !> Instance of the serializable object + class(file_scope_flag), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call set_string(table, "file-name", self%file_name, error) + if (allocated(error)) return + call set_string(table, "flags", self%flags, error) + if (allocated(error)) return + + end subroutine file_scope_dump + + !> Read from toml table (no checks made at this stage) + subroutine file_scope_load(self, table, error) + + !> Instance of the serializable object + class(file_scope_flag), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call get_value(table, "file-name", self%file_name) + call get_value(table, "flags", self%flags) + + end subroutine file_scope_load + + logical function profile_same(this,that) + class(profile_config_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + integer :: ii + + profile_same = .false. + + select type (other=>that) + type is (profile_config_t) + if (allocated(this%profile_name).neqv.allocated(other%profile_name)) return + if (allocated(this%profile_name)) then + if (.not.(this%profile_name==other%profile_name)) return + endif + if (allocated(this%compiler).neqv.allocated(other%compiler)) return + if (allocated(this%compiler)) then + if (.not.(this%compiler==other%compiler)) return + endif + if (this%os_type/=other%os_type) return + if (allocated(this%flags).neqv.allocated(other%flags)) return + if (allocated(this%flags)) then + if (.not.(this%flags==other%flags)) return + endif + if (allocated(this%c_flags).neqv.allocated(other%c_flags)) return + if (allocated(this%c_flags)) then + if (.not.(this%c_flags==other%c_flags)) return + endif + if (allocated(this%cxx_flags).neqv.allocated(other%cxx_flags)) return + if (allocated(this%cxx_flags)) then + if (.not.(this%cxx_flags==other%cxx_flags)) return + endif + if (allocated(this%link_time_flags).neqv.allocated(other%link_time_flags)) return + if (allocated(this%link_time_flags)) then + if (.not.(this%link_time_flags==other%link_time_flags)) return + endif + + if (allocated(this%file_scope_flags).neqv.allocated(other%file_scope_flags)) return + if (allocated(this%file_scope_flags)) then + if (.not.size(this%file_scope_flags)==size(other%file_scope_flags)) return + do ii=1,size(this%file_scope_flags) + print *, 'check ii-th file scope: ',ii + if (.not.this%file_scope_flags(ii)==other%file_scope_flags(ii)) return + end do + endif + + if (this%is_built_in.neqv.other%is_built_in) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + profile_same = .true. + + end function profile_same + + !> Dump to toml table + subroutine profile_dump(self, table, error) + + !> Instance of the serializable object + class(profile_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + integer :: ierr, ii + type(toml_table), pointer :: ptr_deps, ptr + character(len=30) :: unnamed + + call set_string(table, "profile-name", self%profile_name, error) + if (allocated(error)) return + call set_string(table, "compiler", self%compiler, error) + if (allocated(error)) return + call set_string(table,"os-type",os_type_name(self%os_type), error, 'profile_config_t') + if (allocated(error)) return + call set_string(table, "flags", self%flags, error) + if (allocated(error)) return + call set_string(table, "c-flags", self%c_flags, error) + if (allocated(error)) return + call set_string(table, "cxx-flags", self%cxx_flags, error) + if (allocated(error)) return + call set_string(table, "link-time-flags", self%link_time_flags, error) + if (allocated(error)) return + + if (allocated(self%file_scope_flags)) then + + ! Create dependency table + call add_table(table, "file-scope-flags", ptr_deps) + if (.not. associated(ptr_deps)) then + call fatal_error(error, "profile_config_t cannot create file scope table ") + return + end if + + do ii = 1, size(self%file_scope_flags) + associate (dep => self%file_scope_flags(ii)) + + !> Because files need a name, fallback if this has no name + if (len_trim(dep%file_name)==0) then + write(unnamed,1) ii + call add_table(ptr_deps, trim(unnamed), ptr) + else + call add_table(ptr_deps, dep%file_name, ptr) + end if + if (.not. associated(ptr)) then + call fatal_error(error, "profile_config_t cannot create entry for file "//dep%file_name) + return + end if + call dep%dump_to_toml(ptr, error) + if (allocated(error)) return + end associate + end do + + endif + + call set_value(table, "is-built-in", self%is_built_in, error, 'profile_config_t') + if (allocated(error)) return + + 1 format('UNNAMED_FILE_',i0) + + end subroutine profile_dump + + !> Read from toml table (no checks made at this stage) + subroutine profile_load(self, table, error) + + !> Instance of the serializable object + class(profile_config_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + character(len=:), allocatable :: flag + integer :: ii, jj + type(toml_table), pointer :: ptr_dep, ptr + type(toml_key), allocatable :: keys(:),dep_keys(:) + + call table%get_keys(keys) + + call get_value(table, "profile-name", self%profile_name) + call get_value(table, "compiler", self%compiler) + call get_value(table,"os-type",flag) + call match_os_type(flag, self%os_type) + call get_value(table, "flags", self%flags) + call get_value(table, "c-flags", self%c_flags) + call get_value(table, "cxx-flags", self%cxx_flags) + call get_value(table, "link-time-flags", self%link_time_flags) + call get_value(table, "is-built-in", self%is_built_in, error, 'profile_config_t') + if (allocated(error)) return + + if (allocated(self%file_scope_flags)) deallocate(self%file_scope_flags) + sub_deps: do ii = 1, size(keys) + + select case (keys(ii)%key) + case ("file-scope-flags") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,'profile_config_t: error retrieving file_scope_flags table') + return + end if + + !> Read all packages + call ptr%get_keys(dep_keys) + allocate(self%file_scope_flags(size(dep_keys))) + + do jj = 1, size(dep_keys) + + call get_value(ptr, dep_keys(jj), ptr_dep) + call self%file_scope_flags(jj)%load_from_toml(ptr_dep, error) + if (allocated(error)) return + + end do + + end select + end do sub_deps + + end subroutine profile_load + + end module fpm_manifest_profile diff --git a/src/fpm/toml.f90 b/src/fpm/toml.f90 index 71cb148330..2f0947d6a5 100644 --- a/src/fpm/toml.f90 +++ b/src/fpm/toml.f90 @@ -14,19 +14,295 @@ !> [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 fpm_strings, only: string_t, str_ends_with, lower 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 + & toml_serialize, len, toml_load, toml_value + use tomlf_de_parser, only: parse + use jonquil, only: json_serialize, json_error, json_value, json_object, json_load, & + cast_to_object + use iso_fortran_env, only: int64 implicit none private 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 + toml_error, toml_serialize, toml_load, check_keys, set_list, set_string, & + name_is_json + + !> An abstract interface for any fpm class that should be fully serializable to/from TOML/JSON + type, abstract, public :: serializable_t + + contains + + !> Dump to TOML table, unit, file + procedure(to_toml), deferred, private :: dump_to_toml + procedure, non_overridable, private :: dump_to_file + procedure, non_overridable, private :: dump_to_unit + generic :: dump => dump_to_toml, dump_to_file, dump_to_unit + + !> Load from TOML table, unit, file + procedure(from_toml), deferred, private :: load_from_toml + procedure, non_overridable, private :: load_from_file + procedure, non_overridable, private :: load_from_unit + generic :: load => load_from_toml, load_from_file, load_from_unit + + !> Serializable entities need a way to check that they're equal + procedure(is_equal), deferred, private :: serializable_is_same + generic :: operator(==) => serializable_is_same + + !> Test load/write roundtrip + procedure, non_overridable :: test_serialization + + end type serializable_t + + !> add_table: fpm interface + interface add_table + module procedure add_table_fpm + end interface add_table + + !> set_value: fpm interface + interface set_value + module procedure set_logical + module procedure set_integer + module procedure set_integer_64 + end interface set_value + + interface set_string + module procedure set_character + module procedure set_string_type + end interface set_string + + !> get_value: fpm interface + interface get_value + module procedure get_logical + module procedure get_integer + module procedure get_integer_64 + end interface get_value + + + abstract interface + + !> Write object to TOML datastructure + subroutine to_toml(self, table, error) + import serializable_t,toml_table,error_t + implicit none + + !> Instance of the serializable object + class(serializable_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + end subroutine to_toml + + !> Read dependency tree from TOML data structure + subroutine from_toml(self, table, error) + import serializable_t,toml_table,error_t + implicit none + + !> Instance of the serializable object + class(serializable_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + end subroutine from_toml + + !> Compare two serializable objects + logical function is_equal(this,that) + import serializable_t + class(serializable_t), intent(in) :: this,that + end function is_equal + + end interface contains + !> Test serialization of a serializable object + subroutine test_serialization(self, message, error) + class(serializable_t), intent(inout) :: self + character(len=*), intent(in) :: message + type(error_t), allocatable, intent(out) :: error + + integer :: iunit, ii + class(serializable_t), allocatable :: copy + character(len=4), parameter :: formats(2) = ['TOML','JSON'] + + all_formats: do ii = 1, 2 + + open(newunit=iunit,form='formatted',action='readwrite',status='scratch') + + !> Dump to scratch file + call self%dump(iunit, error, json=ii==2) + if (allocated(error)) then + error%message = formats(ii)//': '//error%message + return + endif + + !> Load from scratch file + rewind(iunit) + allocate(copy,mold=self) + call copy%load(iunit,error, json=ii==2) + if (allocated(error)) then + error%message = formats(ii)//': '//error%message + return + endif + close(iunit) + + !> Check same + if (.not.(self==copy)) then + call fatal_error(error,'serializable object failed '//formats(ii)//& + ' write/reread test: '//trim(message)) + return + end if + deallocate(copy) + + end do all_formats + + end subroutine test_serialization + + + !> Write serializable object to a formatted Fortran unit + subroutine dump_to_unit(self, unit, error, json) + !> Instance of the dependency tree + class(serializable_t), intent(inout) :: self + !> Formatted unit + integer, intent(in) :: unit + !> Error handling + type(error_t), allocatable, intent(out) :: error + !> Optional JSON format requested? + logical, optional, intent(in) :: json + + type(toml_table) :: table + logical :: is_json + + is_json = .false.; if (present(json)) is_json = json + + table = toml_table() + call self%dump(table, error) + + if (is_json) then + +! !> Deactivate JSON serialization for now +! call fatal_error(error, 'JSON serialization option is not yet available') +! return + + write (unit, '(a)') json_serialize(table) + else + write (unit, '(a)') toml_serialize(table) + end if + + call table%destroy() + + end subroutine dump_to_unit + + !> Write serializable object to file + subroutine dump_to_file(self, file, error, json) + !> Instance of the dependency tree + class(serializable_t), intent(inout) :: self + !> File name + character(len=*), intent(in) :: file + !> Error handling + type(error_t), allocatable, intent(out) :: error + !> Optional JSON format + logical, optional, intent(in) :: json + + integer :: unit + + open (file=file, newunit=unit) + call self%dump(unit, error, json) + close (unit) + if (allocated(error)) return + + end subroutine dump_to_file + + !> Read dependency tree from file + subroutine load_from_file(self, file, error, json) + !> Instance of the dependency tree + class(serializable_t), intent(inout) :: self + !> File name + character(len=*), intent(in) :: file + !> Error handling + type(error_t), allocatable, intent(out) :: error + !> Optional JSON format + logical, optional, intent(in) :: json + + integer :: unit + logical :: exist + + inquire (file=file, exist=exist) + if (.not. exist) return + + open (file=file, newunit=unit) + call self%load(unit, error, json) + close (unit) + end subroutine load_from_file + + !> Read dependency tree from file + subroutine load_from_unit(self, unit, error, json) + !> Instance of the dependency tree + class(serializable_t), intent(inout) :: self + !> File name + integer, intent(in) :: unit + !> Error handling + type(error_t), allocatable, intent(out) :: error + !> Optional JSON format + logical, optional, intent(in) :: json + + type(toml_error), allocatable :: toml_error + type(toml_table), allocatable :: table + type(toml_table), pointer :: jtable + class(toml_value), allocatable :: object + logical :: is_json + + is_json = .false.; if (present(json)) is_json = json + + if (is_json) then + + !> init JSON interpreter + call json_load(object, unit, error=toml_error) + if (allocated(toml_error)) then + allocate (error) + call move_alloc(toml_error%message, error%message) + return + end if + + jtable => cast_to_object(object) + if (.not.associated(jtable)) then + call fatal_error(error,'cannot initialize JSON table ') + return + end if + + !> Read object from TOML table + call self%load(jtable, error) + + else + + !> use default TOML parser + call toml_load(table, unit, error=toml_error) + + if (allocated(toml_error)) then + allocate (error) + call move_alloc(toml_error%message, error%message) + return + end if + + !> Read object from TOML table + call self%load(table, error) + + endif + + if (allocated(error)) return + + end subroutine load_from_unit + !> Process the configuration file to a TOML data structure subroutine read_package_file(table, manifest, error) @@ -109,6 +385,331 @@ subroutine get_list(table, key, list, error) end subroutine get_list + ! Set string array + subroutine set_list(table, key, list, error) + + !> Instance of the string array + type(string_t), allocatable, intent(in) :: list(:) + + !> Key to save to + character(len=*), intent(in) :: key + + !> Instance of the toml table + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Local variables + integer :: stat, ilist + type(toml_array), pointer :: children + character(len=:), allocatable :: str + + !> Set no key if array is not present + if (.not.allocated(list)) return + + !> Check the key is not empty + if (len_trim(key)<=0) then + call fatal_error(error, 'key is empty dumping string array to TOML table') + return + end if + + if (size(list)/=1) then ! includes empty list case + + !> String array + call add_array(table, key, children, stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Cannot set array table in "//key//" field") + return + end if + + do ilist = 1, size(list) + call set_value(children, ilist, list(ilist)%s, stat=stat) + if (stat /= toml_stat%success) then + call fatal_error(error, "Cannot store array entry in "//key//" field") + return + end if + end do + + else + + ! Single value: set string + call set_value(table, key, list(1)%s, stat=stat) + + if (stat /= toml_stat%success) & + call fatal_error(error, "Cannot store entry in "//key//" field") + + return + end if + + end subroutine set_list + + !> Function wrapper to set a character(len=:), allocatable variable to a toml table + subroutine set_character(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> List of keys to check. + character(len=*), intent(in) :: key + + !> The character variable + character(len=:), allocatable, intent(in) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + !> Check the key is not empty + if (len_trim(key)<=0) then + call fatal_error(error, 'key is empty setting character string to TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + if (allocated(var)) then + call set_value(table, key, var, ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot set character key <'//key//'> in TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + endif + + end subroutine set_character + + !> Function wrapper to set a logical variable to a toml table, returning an fpm error + subroutine set_logical(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> The key + character(len=*), intent(in) :: key + + !> The variable + logical, intent(in) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + call set_value(table, key, var, stat=ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot set logical key <'//key//'> in TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + end subroutine set_logical + + !> Function wrapper to set a default integer variable to a toml table, returning an fpm error + subroutine set_integer(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> The key + character(len=*), intent(in) :: key + + !> The variable + integer, intent(in) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + call set_value(table, key, var, stat=ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot set integer key <'//key//'> in TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + end subroutine set_integer + + !> Function wrapper to set a default integer variable to a toml table, returning an fpm error + subroutine set_integer_64(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> The key + character(len=*), intent(in) :: key + + !> The variable + integer(int64), intent(in) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + call set_value(table, key, var, stat=ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot set integer(int64) key <'//key//'> in TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + end subroutine set_integer_64 + + !> Function wrapper to set a character(len=:), allocatable variable to a toml table + subroutine set_string_type(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> List of keys to check. + character(len=*), intent(in) :: key + + !> The character variable + type(string_t), intent(in) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + call set_character(table, key, var%s, error, whereAt) + + end subroutine set_string_type + + !> Function wrapper to add a toml table and return an fpm error + subroutine add_table_fpm(table, key, ptr, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> Table key + character(len=*), intent(in) :: key + + !> The character variable + type(toml_table), pointer, intent(out) :: ptr + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + !> Nullify pointer + nullify(ptr) + + call add_table(table, key, ptr, ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot add <'//key//'> table in TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + end subroutine add_table_fpm + + !> Function wrapper to get a logical variable from a toml table, returning an fpm error + subroutine get_logical(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> The key + character(len=*), intent(in) :: key + + !> The variable + logical, intent(inout) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + call get_value(table, key, var, stat=ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot get logical key <'//key//'> from TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + end subroutine get_logical + + !> Function wrapper to get a default integer variable from a toml table, returning an fpm error + subroutine get_integer(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> The key + character(len=*), intent(in) :: key + + !> The variable + integer, intent(inout) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + call get_value(table, key, var, stat=ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot get integer key <'//key//'> from TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + end subroutine get_integer + + !> Function wrapper to get a integer(int64) variable from a toml table, returning an fpm error + subroutine get_integer_64(table, key, var, error, whereAt) + + !> Instance of the TOML data structure + type(toml_table), intent(inout) :: table + + !> The key + character(len=*), intent(in) :: key + + !> The variable + integer(int64), intent(inout) :: var + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Optional description + character(len=*), intent(in), optional :: whereAt + + integer :: ierr + + call get_value(table, key, var, stat=ierr) + if (ierr/=toml_stat%success) then + call fatal_error(error,'cannot get integer(int64) key <'//key//'> from TOML table') + if (present(whereAt)) error%message = whereAt//': '//error%message + return + end if + + end subroutine get_integer_64 + !> 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) @@ -161,4 +762,18 @@ subroutine check_keys(table, valid_keys, error) end subroutine check_keys + !> Choose between JSON or TOML based on a file name + logical function name_is_json(filename) + character(*), intent(in) :: filename + + character(*), parameter :: json_identifier = ".json" + + name_is_json = .false. + + if (len_trim(filename) First version is greater logical :: is_greater - integer :: ii + integer :: ii, lhs_size, rhs_size - do ii = 1, min(size(lhs%num), size(rhs%num)) + do ii = 1, min(ndigits(lhs),ndigits(rhs)) if (lhs%num(ii) /= rhs%num(ii)) then is_greater = lhs%num(ii) > rhs%num(ii) return end if end do - is_greater = size(lhs%num) > size(rhs%num) + is_greater = ndigits(lhs) > ndigits(rhs) if (is_greater) then - do ii = size(rhs%num) + 1, size(lhs%num) + do ii = ndigits(rhs) + 1, ndigits(lhs) is_greater = lhs%num(ii) > 0 if (is_greater) return end do @@ -393,6 +393,18 @@ elemental function match(lhs, rhs) end function match + !> Number of digits + elemental integer function ndigits(self) + class(version_t), intent(in) :: self + + if (allocated(self%num)) then + ndigits = size(self%num) + else + ndigits = 0 + end if + + end function ndigits + ! Extract canonical version flags "1.0.0" or "1.0" as the first instance inside a text ! (whatever long) using regex type(string_t) function regex_version_from_text(text,what,error) result(ver) diff --git a/src/fpm_command_line.f90 b/src/fpm_command_line.f90 index 025cffa163..aebfbb5127 100644 --- a/src/fpm_command_line.f90 +++ b/src/fpm_command_line.f90 @@ -25,7 +25,7 @@ module fpm_command_line use fpm_environment, only : get_os_type, get_env, & OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & - OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD + OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD, OS_NAME use M_CLI2, only : set_args, lget, sget, unnamed, remaining, specified use M_CLI2, only : get_subcommand, CLI_RESPONSE_FILE use fpm_strings, only : lower, split, to_fortran_name, is_fortran_name, remove_characters_in_set, string_t @@ -44,6 +44,7 @@ module fpm_command_line public :: fpm_cmd_settings, & fpm_build_settings, & fpm_install_settings, & + fpm_export_settings, & fpm_new_settings, & fpm_run_settings, & fpm_test_settings, & @@ -75,6 +76,7 @@ module fpm_command_line logical :: show_model=.false. logical :: build_tests=.false. logical :: prune=.true. + character(len=:),allocatable :: dump character(len=:),allocatable :: compiler character(len=:),allocatable :: c_compiler character(len=:),allocatable :: cxx_compiler @@ -110,8 +112,16 @@ module fpm_command_line !> Settings for interacting and updating with project dependencies type, extends(fpm_cmd_settings) :: fpm_update_settings character(len=ibug),allocatable :: name(:) - logical :: fetch_only - logical :: clean + character(len=:),allocatable :: dump + logical :: fetch_only + logical :: clean +end type + +!> Settings for exporting model data +type, extends(fpm_build_settings) :: fpm_export_settings + character(len=:),allocatable :: dump_manifest + character(len=:),allocatable :: dump_dependencies + character(len=:),allocatable :: dump_model end type type, extends(fpm_cmd_settings) :: fpm_clean_settings @@ -142,7 +152,8 @@ module fpm_command_line & 'test', 'runner', 'install', 'update', 'list', 'help', 'version', 'publish' ] character(len=:), allocatable :: val_runner, val_compiler, val_flag, val_cflag, val_cxxflag, val_ldflag, & - val_profile, val_runner_args + val_profile, val_runner_args, val_dump + ! '12345678901234567890123456789012345678901234567890123456789012345678901234567890',& character(len=80), parameter :: help_text_build_common(*) = [character(len=80) :: & @@ -220,6 +231,8 @@ subroutine get_command_line_settings(cmd_settings) integer :: i integer :: os type(fpm_install_settings), allocatable :: install_settings + type(fpm_publish_settings), allocatable :: publish_settings + type(fpm_export_settings) , allocatable :: export_settings type(version_t) :: version character(len=:), allocatable :: common_args, compiler_args, run_args, working_dir, & & c_compiler, cxx_compiler, archiver, version_s, token_s @@ -354,6 +367,7 @@ subroutine get_command_line_settings(cmd_settings) call set_args(common_args // compiler_args //'& & --list F & & --show-model F & + & --dump " " & & --tests F & & --',help_build,version_text) @@ -362,9 +376,14 @@ subroutine get_command_line_settings(cmd_settings) c_compiler = sget('c-compiler') cxx_compiler = sget('cxx-compiler') archiver = sget('archiver') + + val_dump = sget('dump') + if (specified('dump') .and. val_dump=='')val_dump='fpm_model.toml' + allocate( fpm_build_settings :: cmd_settings ) cmd_settings=fpm_build_settings( & & profile=val_profile,& + & dump=val_dump,& & prune=.not.lget('no-prune'), & & compiler=val_compiler, & & c_compiler=c_compiler, & @@ -606,7 +625,7 @@ subroutine get_command_line_settings(cmd_settings) & verbose=lget('verbose')) case('update') - call set_args(common_args // ' --fetch-only F --clean F', & + call set_args(common_args // ' --fetch-only F --clean F --dump " " ', & help_update, version_text) if( size(unnamed) > 1 )then @@ -615,11 +634,46 @@ subroutine get_command_line_settings(cmd_settings) names=[character(len=len(names)) :: ] endif + val_dump = sget('dump') + if (specified('dump') .and. val_dump=='')val_dump='fpm_dependencies.toml' + allocate(fpm_update_settings :: cmd_settings) - cmd_settings=fpm_update_settings(name=names, & + cmd_settings=fpm_update_settings(name=names, dump=val_dump, & fetch_only=lget('fetch-only'), verbose=lget('verbose'), & clean=lget('clean')) + case('export') + + call set_args(common_args // compiler_args // '& + & --manifest "filename" & + & --model "filename" & + & --dependencies "filename" ', & + help_build, version_text) + + call check_build_vals() + + c_compiler = sget('c-compiler') + cxx_compiler = sget('cxx-compiler') + archiver = sget('archiver') + allocate(export_settings, source=fpm_export_settings(& + profile=val_profile,& + prune=.not.lget('no-prune'), & + compiler=val_compiler, & + c_compiler=c_compiler, & + cxx_compiler=cxx_compiler, & + archiver=archiver, & + flag=val_flag, & + cflag=val_cflag, & + show_model=.true., & + cxxflag=val_cxxflag, & + ldflag=val_ldflag, & + verbose=lget('verbose'))) + call get_char_arg(export_settings%dump_model, 'model') + call get_char_arg(export_settings%dump_manifest, 'manifest') + call get_char_arg(export_settings%dump_dependencies, 'dependencies') + call move_alloc(export_settings, cmd_settings) + + case('clean') call set_args(common_args // & & ' --skip' // & @@ -757,11 +811,11 @@ subroutine set_help() help_list_dash = [character(len=80) :: & ' ', & ' build [--compiler COMPILER_NAME] [--profile PROF] [--flag FFLAGS] [--list] ', & - ' [--tests] [--no-prune] ', & + ' [--tests] [--no-prune] [--dump [FILENAME]] ', & ' help [NAME(s)] ', & ' new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & ' [--full|--bare][--backfill] ', & - ' update [NAME(s)] [--fetch-only] [--clean] [--verbose] ', & + ' update [NAME(s)] [--fetch-only] [--clean] [--verbose] [--dump [FILENAME]] ', & ' list [--list] ', & ' run [[--target] NAME(s) [--example] [--profile PROF] [--flag FFLAGS] [--all] ', & ' [--runner "CMD"] [--compiler COMPILER_NAME] [--list] [-- ARGS] ', & @@ -885,10 +939,10 @@ subroutine set_help() ' Their syntax is ', & ' ', & ' build [--profile PROF] [--flag FFLAGS] [--list] [--compiler COMPILER_NAME] ', & - ' [--tests] [--no-prune] ', & + ' [--tests] [--no-prune] [--dump [FILENAME]] ', & ' new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & ' [--full|--bare][--backfill] ', & - ' update [NAME(s)] [--fetch-only] [--clean] ', & + ' update [NAME(s)] [--fetch-only] [--clean] [--dump [FILENAME]] ', & ' run [[--target] NAME(s)] [--profile PROF] [--flag FFLAGS] [--list] [--all] ', & ' [--example] [--runner "CMD"] [--compiler COMPILER_NAME] ', & ' [--no-prune] [-- ARGS] ', & @@ -1073,7 +1127,7 @@ subroutine set_help() ' ', & 'SYNOPSIS ', & ' fpm build [--profile PROF] [--flag FFLAGS] [--compiler COMPILER_NAME] ', & - ' [--list] [--tests] ', & + ' [--list] [--tests] [--dump [FILENAME]] ', & ' ', & ' fpm build --help|--version ', & ' ', & @@ -1101,6 +1155,9 @@ subroutine set_help() ' --list list candidates instead of building or running them ', & ' --tests build all tests (otherwise only if needed) ', & ' --show-model show the model and exit (do not build) ', & + ' --dump [FILENAME] save model representation to file. use JSON format ', & + ' if file name is *.json; use TOML format otherwise ', & + ' (default file name: model.toml) ', & ' --help print this help and exit ', & ' --version print program version information and exit ', & ' ', & @@ -1302,7 +1359,7 @@ subroutine set_help() ' update(1) - manage project dependencies', & '', & 'SYNOPSIS', & - ' fpm update [--fetch-only] [--clean] [--verbose] [NAME(s)]', & + ' fpm update [--fetch-only] [--clean] [--verbose] [--dump [FILENAME]] [NAME(s)]', & '', & 'DESCRIPTION', & ' Manage and update project dependencies. If no dependency names are', & @@ -1312,6 +1369,9 @@ subroutine set_help() ' --fetch-only Only fetch dependencies, do not update existing projects', & ' --clean Do not use previous dependency cache', & ' --verbose Show additional printout', & + ' --dump [FILENAME] Dump updated dependency tree to file. use JSON format ', & + ' if file name is *.json; use TOML format otherwise ', & + ' (default file name: fpm_dependencies.toml) ', & '', & 'SEE ALSO', & ' The fpm(1) home page at https://github.com/fortran-lang/fpm', & diff --git a/src/fpm_compiler.F90 b/src/fpm_compiler.F90 index 55565ee31d..f173267659 100644 --- a/src/fpm_compiler.F90 +++ b/src/fpm_compiler.F90 @@ -40,7 +40,9 @@ module fpm_compiler use fpm_filesystem, only: join_path, basename, get_temp_filename, delete_file, unix_path, & & getline, run use fpm_strings, only: split, string_cat, string_t, str_ends_with, str_begins_with_str -use fpm_error, only: error_t +use fpm_manifest, only : package_config_t +use fpm_error, only: error_t, fatal_error +use fpm_toml, only: serializable_t, toml_table, set_string, set_value, toml_stat, get_value implicit none public :: compiler_t, new_compiler, archiver_t, new_archiver, get_macros public :: debug @@ -72,7 +74,7 @@ module fpm_compiler !> Definition of compiler object -type :: compiler_t +type, extends(serializable_t) :: compiler_t !> Identifier of the compiler integer(compiler_enum) :: id = id_unknown !> Path to the Fortran compiler @@ -112,13 +114,19 @@ module fpm_compiler procedure :: is_gnu !> Enumerate libraries, based on compiler and platform procedure :: enumerate_libraries + + !> Serialization interface + procedure :: serializable_is_same => compiler_is_same + procedure :: dump_to_toml => compiler_dump + procedure :: load_from_toml => compiler_load !> Return compiler name procedure :: name => compiler_name + end type compiler_t !> Definition of archiver object -type :: archiver_t +type, extends(serializable_t) :: archiver_t !> Path to archiver character(len=:), allocatable :: ar !> Use response files to pass arguments @@ -130,6 +138,12 @@ module fpm_compiler contains !> Create static archive procedure :: make_archive + + !> Serialization interface + procedure :: serializable_is_same => ar_is_same + procedure :: dump_to_toml + procedure :: load_from_toml + end type archiver_t @@ -1227,6 +1241,158 @@ pure function debug_archiver(self) result(repr) repr = 'ar="'//self%ar//'"' end function debug_archiver +!> Check that two archiver_t objects are equal +logical function ar_is_same(this,that) + class(archiver_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + ar_is_same = .false. + + select type (other=>that) + type is (archiver_t) + + if (.not.(this%ar==other%ar)) return + if (.not.(this%use_response_file.eqv.other%use_response_file)) return + if (.not.(this%echo.eqv.other%echo)) return + if (.not.(this%verbose.eqv.other%verbose)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + ar_is_same = .true. + +end function ar_is_same + +!> Dump dependency to toml table +subroutine dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(archiver_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Path to archiver + call set_string(table, "ar", self%ar, error, 'archiver_t') + if (allocated(error)) return + call set_value(table, "use-response-file", self%use_response_file, error, 'archiver_t') + if (allocated(error)) return + call set_value(table, "echo", self%echo, error, 'archiver_t') + if (allocated(error)) return + call set_value(table, "verbose", self%verbose, error, 'archiver_t') + if (allocated(error)) return + +end subroutine dump_to_toml + +!> Read dependency from toml table (no checks made at this stage) +subroutine load_from_toml(self, table, error) + + !> Instance of the serializable object + class(archiver_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call get_value(table, "ar", self%ar) + + call get_value(table, "use-response-file", self%use_response_file, error, 'archiver_t') + if (allocated(error)) return + call get_value(table, "echo", self%echo, error, 'archiver_t') + if (allocated(error)) return + call get_value(table, "verbose", self%verbose, error, 'archiver_t') + if (allocated(error)) return + +end subroutine load_from_toml + +!> Check that two compiler_t objects are equal +logical function compiler_is_same(this,that) + class(compiler_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + compiler_is_same = .false. + + select type (other=>that) + type is (compiler_t) + + if (.not.(this%id==other%id)) return + if (.not.(this%fc==other%fc)) return + if (.not.(this%cc==other%cc)) return + if (.not.(this%cxx==other%cxx)) return + if (.not.(this%echo.eqv.other%echo)) return + if (.not.(this%verbose.eqv.other%verbose)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + compiler_is_same = .true. + +end function compiler_is_same + +!> Dump dependency to toml table +subroutine compiler_dump(self, table, error) + + !> Instance of the serializable object + class(compiler_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr + + call set_value(table, "id", self%id, error, 'compiler_t') + if (allocated(error)) return + call set_string(table, "fc", self%fc, error, 'compiler_t') + if (allocated(error)) return + call set_string(table, "cc", self%cc, error, 'compiler_t') + if (allocated(error)) return + call set_string(table, "cxx", self%cxx, error, 'compiler_t') + if (allocated(error)) return + call set_value(table, "echo", self%echo, error, 'compiler_t') + if (allocated(error)) return + call set_value(table, "verbose", self%verbose, error, 'compiler_t') + if (allocated(error)) return + +end subroutine compiler_dump + +!> Read dependency from toml table (no checks made at this stage) +subroutine compiler_load(self, table, error) + + !> Instance of the serializable object + class(compiler_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call get_value(table, "id", self%id, error, 'compiler_t') + if (allocated(error)) return + call get_value(table, "fc", self%fc) + call get_value(table, "cc", self%cc) + call get_value(table, "cxx", self%cxx) + call get_value(table, "echo", self%echo, error, 'compiler_t') + if (allocated(error)) return + call get_value(table, "verbose", self%verbose, error, 'compiler_t') + if (allocated(error)) return + +end subroutine compiler_load + !> Return a compiler name string pure function compiler_name(self) result(name) !> Instance of the compiler object diff --git a/src/fpm_environment.f90 b/src/fpm_environment.f90 index 839fb17869..aba65e77bd 100644 --- a/src/fpm_environment.f90 +++ b/src/fpm_environment.f90 @@ -15,6 +15,7 @@ module fpm_environment public :: get_command_arguments_quoted public :: separator + public :: OS_NAME integer, parameter, public :: OS_UNKNOWN = 0 integer, parameter, public :: OS_LINUX = 1 integer, parameter, public :: OS_MACOS = 2 @@ -24,6 +25,25 @@ module fpm_environment integer, parameter, public :: OS_FREEBSD = 6 integer, parameter, public :: OS_OPENBSD = 7 contains + + !> Return string describing the OS type flag + pure function OS_NAME(os) + integer, intent(in) :: os + character(len=:), allocatable :: OS_NAME + + select case (os) + case (OS_LINUX); OS_NAME = "Linux" + case (OS_MACOS); OS_NAME = "macOS" + case (OS_WINDOWS); OS_NAME = "Windows" + case (OS_CYGWIN); OS_NAME = "Cygwin" + case (OS_SOLARIS); OS_NAME = "Solaris" + case (OS_FREEBSD); OS_NAME = "FreeBSD" + case (OS_OPENBSD); OS_NAME = "OpenBSD" + case (OS_UNKNOWN); OS_NAME = "Unknown" + case default ; OS_NAME = "UNKNOWN" + end select + end function OS_NAME + !> Determine the OS type integer function get_os_type() result(r) !! diff --git a/src/fpm_model.f90 b/src/fpm_model.f90 index 910498c2a2..8663f33b6e 100644 --- a/src/fpm_model.f90 +++ b/src/fpm_model.f90 @@ -38,12 +38,15 @@ module fpm_model use iso_fortran_env, only: int64 use fpm_compiler, only: compiler_t, archiver_t, debug use fpm_dependency, only: dependency_tree_t -use fpm_strings, only: string_t, str, len_trim +use fpm_strings, only: string_t, str, len_trim, upper, operator(==) +use fpm_toml, only: serializable_t, toml_table, toml_stat, set_value, set_list, get_value, & + & get_list, add_table, toml_key, add_array, set_string +use fpm_error, only: error_t, fatal_error use fpm_manifest_preprocess, only: preprocess_config_t implicit none private -public :: fpm_model_t, srcfile_t, show_model, fortran_features_t +public :: fpm_model_t, srcfile_t, show_model, fortran_features_t, package_t public :: FPM_UNIT_UNKNOWN, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE, & @@ -81,7 +84,7 @@ module fpm_model integer, parameter :: FPM_SCOPE_EXAMPLE = 5 !> Enabled Fortran language features -type :: fortran_features_t +type, extends(serializable_t) :: fortran_features_t !> Use default implicit typing logical :: implicit_typing = .false. @@ -91,10 +94,18 @@ module fpm_model !> Form to use for all Fortran sources character(:), allocatable :: source_form + + contains + + !> Serialization interface + procedure :: serializable_is_same => fft_is_same + procedure :: dump_to_toml => fft_dump_to_toml + procedure :: load_from_toml => fft_load_from_toml + end type fortran_features_t !> Type for describing a source file -type srcfile_t +type, extends(serializable_t) :: srcfile_t !> File path relative to cwd character(:), allocatable :: file_name @@ -125,11 +136,18 @@ module fpm_model !> Current hash integer(int64) :: digest + contains + + !> Serialization interface + procedure :: serializable_is_same => srcfile_is_same + procedure :: dump_to_toml => srcfile_dump_to_toml + procedure :: load_from_toml => srcfile_load_from_toml + end type srcfile_t !> Type for describing a single package -type package_t +type, extends(serializable_t) :: package_t !> Name of package character(:), allocatable :: name @@ -144,7 +162,7 @@ module fpm_model character(:), allocatable :: version !> Module naming conventions - logical :: enforce_module_names + logical :: enforce_module_names = .false. !> Prefix for all module names type(string_t) :: module_prefix @@ -152,12 +170,19 @@ module fpm_model !> Language features type(fortran_features_t) :: features + contains + + !> Serialization interface + procedure :: serializable_is_same => package_is_same + procedure :: dump_to_toml => package_dump_to_toml + procedure :: load_from_toml => package_load_from_toml + end type package_t !> Type describing everything required to build !> the root package and its dependencies. -type :: fpm_model_t +type, extends(serializable_t) :: fpm_model_t !> Name of root package character(:), allocatable :: package_name @@ -207,6 +232,13 @@ module fpm_model !> Prefix for all module names type(string_t) :: module_prefix + contains + + !> Serialization interface + procedure :: serializable_is_same => model_is_same + procedure :: dump_to_toml => model_dump_to_toml + procedure :: load_from_toml => model_load_from_toml + end type fpm_model_t contains @@ -250,23 +282,7 @@ function info_srcfile(source) result(s) ! character(:), allocatable :: exe_name s = s // ', exe_name="' // source%exe_name // '"' ! integer :: unit_scope = FPM_SCOPE_UNKNOWN - s = s // ", unit_scope=" - select case(source%unit_scope) - case (FPM_SCOPE_UNKNOWN) - s = s // "FPM_SCOPE_UNKNOWN" - case (FPM_SCOPE_LIB) - s = s // "FPM_SCOPE_LIB" - case (FPM_SCOPE_DEP) - s = s // "FPM_SCOPE_DEP" - case (FPM_SCOPE_APP) - s = s // "FPM_SCOPE_APP" - case (FPM_SCOPE_TEST) - s = s // "FPM_SCOPE_TEST" - case (FPM_SCOPE_EXAMPLE) - s = s // "FPM_SCOPE_EXAMPLE" - case default - s = s // "INVALID" - end select + s = s // ', unit_scope="' // FPM_SCOPE_NAME(source%unit_scope) // '"' ! type(string_t), allocatable :: modules_provided(:) s = s // ", modules_provided=[" do i = 1, size(source%modules_provided) @@ -281,27 +297,7 @@ function info_srcfile(source) result(s) end do s = s // "]" ! integer :: unit_type = FPM_UNIT_UNKNOWN - s = s // ", unit_type=" - select case(source%unit_type) - case (FPM_UNIT_UNKNOWN) - s = s // "FPM_UNIT_UNKNOWN" - case (FPM_UNIT_PROGRAM) - s = s // "FPM_UNIT_PROGRAM" - case (FPM_UNIT_MODULE) - s = s // "FPM_UNIT_MODULE" - case (FPM_UNIT_SUBMODULE) - s = s // "FPM_UNIT_SUBMODULE" - case (FPM_UNIT_SUBPROGRAM) - s = s // "FPM_UNIT_SUBPROGRAM" - case (FPM_UNIT_CSOURCE) - s = s // "FPM_UNIT_CSOURCE" - case (FPM_UNIT_CPPSOURCE) - s = s // "FPM_UNIT_CPPSOURCE" - case (FPM_UNIT_CHEADER) - s = s // "FPM_UNIT_CHEADER" - case default - s = s // "INVALID" - end select + s = s // ', unit_type="' // FPM_UNIT_NAME(source%unit_type) // '"' ! type(string_t), allocatable :: modules_used(:) s = s // ", modules_used=[" do i = 1, size(source%modules_used) @@ -397,4 +393,691 @@ subroutine show_model(model) print *, info_model(model) end subroutine show_model +!> Return the character name of a scope flag +function FPM_SCOPE_NAME(flag) result(name) + integer, intent(in) :: flag + character(len=:), allocatable :: name + + select case (flag) + case (FPM_SCOPE_UNKNOWN); name = "FPM_SCOPE_UNKNOWN" + case (FPM_SCOPE_LIB); name = "FPM_SCOPE_LIB" + case (FPM_SCOPE_DEP); name = "FPM_SCOPE_DEP" + case (FPM_SCOPE_APP); name = "FPM_SCOPE_APP" + case (FPM_SCOPE_TEST); name = "FPM_SCOPE_TEST" + case (FPM_SCOPE_EXAMPLE); name = "FPM_SCOPE_EXAMPLE" + case default; name = "INVALID" + end select +end function FPM_SCOPE_NAME + +!> Parse git FPM_SCOPE identifier from a string +integer function parse_scope(name) result(scope) + character(len=*), intent(in) :: name + + character(len=len(name)) :: uppercase + + !> Make it Case insensitive + uppercase = upper(name) + + select case (trim(uppercase)) + case ("FPM_SCOPE_UNKNOWN"); scope = FPM_SCOPE_UNKNOWN + case ("FPM_SCOPE_LIB"); scope = FPM_SCOPE_LIB + case ("FPM_SCOPE_DEP"); scope = FPM_SCOPE_DEP + case ("FPM_SCOPE_APP"); scope = FPM_SCOPE_APP + case ("FPM_SCOPE_TEST"); scope = FPM_SCOPE_TEST + case ("FPM_SCOPE_EXAMPLE"); scope = FPM_SCOPE_EXAMPLE + case default; scope = -9999 + end select + +end function parse_scope + +!> Return the character name of a unit flag +function FPM_UNIT_NAME(flag) result(name) + integer, intent(in) :: flag + character(len=:), allocatable :: name + + select case (flag) + case (FPM_UNIT_UNKNOWN); name = "FPM_UNIT_UNKNOWN" + case (FPM_UNIT_PROGRAM); name = "FPM_UNIT_PROGRAM" + case (FPM_UNIT_MODULE); name = "FPM_UNIT_MODULE" + case (FPM_UNIT_SUBMODULE); name = "FPM_UNIT_SUBMODULE" + case (FPM_UNIT_SUBPROGRAM); name = "FPM_UNIT_SUBPROGRAM" + case (FPM_UNIT_CSOURCE); name = "FPM_UNIT_CSOURCE" + case (FPM_UNIT_CPPSOURCE); name = "FPM_UNIT_CPPSOURCE" + case (FPM_UNIT_CHEADER); name = "FPM_UNIT_CHEADER" + case default; name = "INVALID" + end select +end function FPM_UNIT_NAME + +!> Parse git FPM_UNIT identifier from a string +integer function parse_unit(name) result(unit) + character(len=*), intent(in) :: name + + character(len=len(name)) :: uppercase + + !> Make it Case insensitive + uppercase = upper(name) + + select case (trim(uppercase)) + case ("FPM_UNIT_UNKNOWN"); unit = FPM_UNIT_UNKNOWN + case ("FPM_UNIT_PROGRAM"); unit = FPM_UNIT_PROGRAM + case ("FPM_UNIT_MODULE"); unit = FPM_UNIT_MODULE + case ("FPM_UNIT_SUBMODULE"); unit = FPM_UNIT_SUBMODULE + case ("FPM_UNIT_SUBPROGRAM"); unit = FPM_UNIT_SUBPROGRAM + case ("FPM_UNIT_CSOURCE"); unit = FPM_UNIT_CSOURCE + case ("FPM_UNIT_CPPSOURCE"); unit = FPM_UNIT_CPPSOURCE + case ("FPM_UNIT_CHEADER"); unit = FPM_UNIT_CHEADER + case default; unit = -9999 + end select + +end function parse_unit + +!> Check that two source files are equal +logical function srcfile_is_same(this,that) + class(srcfile_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + srcfile_is_same = .false. + + select type (other=>that) + type is (srcfile_t) + + if (.not.(this%file_name==other%file_name)) return + if (.not.(this%exe_name==other%exe_name)) return + if (.not.(this%unit_scope==other%unit_scope)) return + if (.not.(this%modules_provided==other%modules_provided)) return + if (.not.(this%unit_type==other%unit_type)) return + if (.not.(this%parent_modules==other%parent_modules)) return + if (.not.(this%modules_used==other%modules_used)) return + if (.not.(this%include_dependencies==other%include_dependencies)) return + if (.not.(this%link_libraries==other%link_libraries)) return + if (.not.(this%digest==other%digest)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + srcfile_is_same = .true. + +end function srcfile_is_same + +!> Dump dependency to toml table +subroutine srcfile_dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(srcfile_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr + + call set_string(table, "file-name", self%file_name, error, 'srcfile_t') + if (allocated(error)) return + call set_string(table, "exe-name", self%exe_name, error, 'srcfile_t') + if (allocated(error)) return + call set_value(table, "digest", self%digest, error, 'srcfile_t') + if (allocated(error)) return + + ! unit_scope and unit_type are saved as strings so the output is independent + ! of the internal representation + call set_string(table,"unit-scope",FPM_SCOPE_NAME(self%unit_scope), error, 'srcfile_t') + if (allocated(error)) return + call set_string(table,"unit-type",FPM_UNIT_NAME(self%unit_type), error, 'srcfile_t') + if (allocated(error)) return + call set_list(table, "modules-provided",self%modules_provided, error) + if (allocated(error)) return + call set_list(table, "parent-modules",self%parent_modules, error) + if (allocated(error)) return + call set_list(table, "modules-used",self%modules_used, error) + if (allocated(error)) return + call set_list(table, "include-dependencies",self%include_dependencies, error) + if (allocated(error)) return + call set_list(table, "link-libraries",self%link_libraries, error) + if (allocated(error)) return + +end subroutine srcfile_dump_to_toml + +!> Read dependency from toml table (no checks made at this stage) +subroutine srcfile_load_from_toml(self, table, error) + + !> Instance of the serializable object + class(srcfile_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=:), allocatable :: flag + integer :: ierr + + call get_value(table, "file-name", self%file_name) + call get_value(table, "exe-name", self%exe_name) + call get_value(table, "digest", self%digest, error, 'srcfile_t') + if (allocated(error)) return + + ! unit_scope and unit_type are saved as strings so the output is independent + ! of the internal representation + call get_value(table, "unit-scope", flag) + if (allocated(flag)) self%unit_scope = parse_scope(flag) + call get_value(table, "unit-type", flag) + if (allocated(flag)) self%unit_type = parse_unit(flag) + + call get_list(table,"modules-provided",self%modules_provided, error) + if (allocated(error)) return + + call get_list(table,"parent-modules",self%parent_modules, error) + if (allocated(error)) return + + call get_list(table,"modules-used",self%modules_used, error) + if (allocated(error)) return + + call get_list(table,"include-dependencies",self%include_dependencies, error) + if (allocated(error)) return + + call get_list(table,"link-libraries",self%link_libraries, error) + if (allocated(error)) return + +end subroutine srcfile_load_from_toml + +!> Check that two fortran feature objects are equal +logical function fft_is_same(this,that) + class(fortran_features_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + fft_is_same = .false. + + select type (other=>that) + type is (fortran_features_t) + + if (.not.(this%implicit_typing.eqv.other%implicit_typing)) return + if (.not.(this%implicit_external.eqv.other%implicit_external)) return + if (.not.(this%source_form==other%source_form)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + fft_is_same = .true. + +end function fft_is_same + +!> Dump fortran features to toml table +subroutine fft_dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(fortran_features_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + call set_value(table, "implicit-typing", self%implicit_typing, error, 'fortran_features_t') + if (allocated(error)) return + call set_value(table, "implicit-external", self%implicit_external, error, 'fortran_features_t') + if (allocated(error)) return + call set_string(table, "source-form", self%source_form, error, 'fortran_features_t') + if (allocated(error)) return + +end subroutine fft_dump_to_toml + +!> Read dependency from toml table (no checks made at this stage) +subroutine fft_load_from_toml(self, table, error) + + !> Instance of the serializable object + class(fortran_features_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr + + call get_value(table, "implicit-typing", self%implicit_typing, error, 'fortran_features_t') + if (allocated(error)) return + call get_value(table, "implicit-external", self%implicit_external, error, 'fortran_features_t') + if (allocated(error)) return + ! Return unallocated value if not present + call get_value(table, "source-form", self%source_form) + +end subroutine fft_load_from_toml + +!> Check that two package objects are equal +logical function package_is_same(this,that) + class(package_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + integer :: ii + + package_is_same = .false. + + select type (other=>that) + type is (package_t) + + if (.not.(this%name==other%name)) return + if (.not.(allocated(this%sources).eqv.allocated(other%sources))) return + if (allocated(this%sources)) then + if (.not.(size(this%sources)==size(other%sources))) return + do ii = 1, size(this%sources) + if (.not.(this%sources(ii)==other%sources(ii))) return + end do + end if + + if (.not.(this%preprocess==other%preprocess)) return + if (.not.(this%version==other%version)) return + + !> Module naming + if (.not.(this%enforce_module_names.eqv.other%enforce_module_names)) return + if (.not.(this%module_prefix==other%module_prefix)) return + + !> Fortran features + if (.not.(this%features==other%features)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + package_is_same = .true. + +end function package_is_same + +!> Dump dependency to toml table +subroutine package_dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(package_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr, ii + type(toml_table), pointer :: ptr,this_source + character(16) :: src_name + + call set_string(table, "name", self%name, error, 'package_t') + if (allocated(error)) return + + call set_string(table, "version", self%version, error, 'package_t') + if (allocated(error)) return + + call set_value(table, "module-naming", self%enforce_module_names, error, 'package_t') + if (allocated(error)) return + + call set_string(table, "module-prefix", self%module_prefix, error, 'package_t') + if (allocated(error)) return + + !> Create a preprocessor table + call add_table(table, "preprocess", ptr, error, 'package_t') + if (allocated(error)) return + call self%preprocess%dump_to_toml(ptr, error) + if (allocated(error)) return + + !> Create a fortran table + call add_table(table, "fortran", ptr, error, 'package_t') + if (allocated(error)) return + call self%features%dump_to_toml(ptr, error) + if (allocated(error)) return + + !> Create a sources table + if (allocated(self%sources)) then + + call add_table(table, "sources", ptr, error, 'package_t') + if (allocated(error)) return + + do ii = 1, size(self%sources) + + write(src_name,1) ii + call add_table(ptr, trim(src_name), this_source, error, 'package_t[source]') + if (allocated(error)) return + call self%sources(ii)%dump_to_toml(this_source,error) + if (allocated(error)) return + + end do + + end if + + 1 format('src_',i0) + +end subroutine package_dump_to_toml + +!> Read dependency from toml table (no checks made at this stage) +subroutine package_load_from_toml(self, table, error) + + !> Instance of the serializable object + class(package_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr,ii,jj + type(toml_key), allocatable :: keys(:),src_keys(:) + type(toml_table), pointer :: ptr_sources,ptr,ptr_fortran,ptr_preprocess + type(error_t), allocatable :: new_error + + call get_value(table, "name", self%name) + call get_value(table, "version", self%version) + + call get_value(table, "module-naming", self%enforce_module_names, error, 'package_t') + if (allocated(error)) return + + ! Return unallocated value if not present + call get_value(table, "module-prefix", self%module_prefix%s) + + ! Sources + call table%get_keys(keys) + + find_others: do ii = 1, size(keys) + select case (keys(ii)%key) + case ("fortran") + + call get_value(table, keys(ii), ptr_fortran) + if (.not.associated(ptr_fortran)) then + call fatal_error(error,'package_t: error retrieving fortran table from TOML table') + return + end if + + call self%features%load_from_toml(ptr_fortran,error) + if (allocated(error)) return + + case ("preprocess") + + call get_value(table, keys(ii), ptr_preprocess) + if (.not.associated(ptr_preprocess)) then + call fatal_error(error,'package_t: error retrieving preprocess table from TOML table') + return + end if + + call self%preprocess%load_from_toml(ptr_preprocess,error) + if (allocated(error)) return + + case ("sources") + + call get_value(table, keys(ii), ptr_sources) + if (.not.associated(ptr_sources)) then + call fatal_error(error,'package_t: error retrieving sources table from TOML table') + return + end if + + !> Read all dependencies + call ptr_sources%get_keys(src_keys) + allocate(self%sources(size(src_keys))) + + do jj = 1, size(src_keys) + call get_value(ptr_sources, src_keys(jj), ptr) + call self%sources(jj)%load_from_toml(ptr, error) + if (allocated(error)) return + end do + + case default + cycle find_others + end select + end do find_others + +end subroutine package_load_from_toml + + +!> Check that two model objects are equal +logical function model_is_same(this,that) + class(fpm_model_t), intent(in) :: this + class(serializable_t), intent(in) :: that + + type(fpm_model_t), pointer :: other + + integer :: ii + + model_is_same = .false. + + select type (other=>that) + type is (fpm_model_t) + + if (.not.(this%package_name==other%package_name)) return + if (.not.(allocated(this%packages).eqv.allocated(other%packages))) return + if (allocated(this%packages)) then + if (.not.(size(this%packages)==size(other%packages))) return + do ii = 1, size(this%packages) + if (.not.(this%packages(ii)==other%packages(ii))) return + end do + end if + + if (.not.(this%compiler==other%compiler)) return + if (.not.(this%archiver==other%archiver)) return + if (.not.(this%fortran_compile_flags==other%fortran_compile_flags)) return + if (.not.(this%c_compile_flags==other%c_compile_flags)) return + if (.not.(this%cxx_compile_flags==other%cxx_compile_flags)) return + if (.not.(this%link_flags==other%link_flags)) return + if (.not.(this%build_prefix==other%build_prefix)) return + if (.not.(this%include_dirs==other%include_dirs)) return + if (.not.(this%link_libraries==other%link_libraries)) return + if (.not.(this%external_modules==other%external_modules)) return + if (.not.(this%deps==other%deps)) return + if (.not.(this%include_tests.eqv.other%include_tests)) return + if (.not.(this%enforce_module_names.eqv.other%enforce_module_names)) return + if (.not.(this%module_prefix==other%module_prefix)) return + + class default + ! Not the same type + return + end select + + !> All checks passed! + model_is_same = .true. + +end function model_is_same + +!> Dump dependency to toml table +subroutine model_dump_to_toml(self, table, error) + + !> Instance of the serializable object + class(fpm_model_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: ierr, ii + type(toml_table), pointer :: ptr,ptr_pkg + character(27) :: unnamed + + call set_string(table, "package-name", self%package_name, error, 'fpm_model_t') + if (allocated(error)) return + + call add_table(table, "compiler", ptr, error, 'fpm_model_t') + if (allocated(error)) return + call self%compiler%dump_to_toml(ptr, error) + if (allocated(error)) return + + call add_table(table, "archiver", ptr, error, 'fpm_model_t') + if (allocated(error)) return + call self%archiver%dump_to_toml(ptr, error) + if (allocated(error)) return + + call set_string(table, "fortran-flags", self%fortran_compile_flags, error, 'fpm_model_t') + if (allocated(error)) return + call set_string(table, "c-flags", self%c_compile_flags, error, 'fpm_model_t') + if (allocated(error)) return + call set_string(table, "cxx-flags", self%cxx_compile_flags, error, 'fpm_model_t') + if (allocated(error)) return + call set_string(table, "link-flags", self%link_flags, error, 'fpm_model_t') + if (allocated(error)) return + call set_string(table, "build-prefix", self%build_prefix, error, 'fpm_model_t') + if (allocated(error)) return + call set_list(table, "include-dirs", self%include_dirs, error) + if (allocated(error)) return + call set_list(table, "link-libraries", self%link_libraries, error) + if (allocated(error)) return + call set_list(table, "external-modules", self%external_modules, error) + if (allocated(error)) return + + call set_value(table, "include-tests", self%include_tests, error, 'fpm_model_t') + if (allocated(error)) return + call set_value(table, "module-naming", self%enforce_module_names, error, 'fpm_model_t') + if (allocated(error)) return + call set_string(table, "module-prefix", self%module_prefix, error, 'fpm_model_t') + if (allocated(error)) return + + call add_table(table, "deps", ptr, error, 'fpm_model_t') + if (allocated(error)) return + call self%deps%dump_to_toml(ptr, error) + if (allocated(error)) return + + !> Array of packages (including the root package) + if (allocated(self%packages)) then + + ! Create packages table + call add_table(table, "packages", ptr_pkg) + if (.not. associated(ptr_pkg)) then + call fatal_error(error, "fpm_model_t cannot create dependency table ") + return + end if + + do ii = 1, size(self%packages) + + associate (pkg => self%packages(ii)) + + !> Because dependencies are named, fallback if this has no name + !> So, serialization will work regardless of size(self%dep) == self%ndep + if (len_trim(pkg%name)==0) then + write(unnamed,1) ii + call add_table(ptr_pkg, trim(unnamed), ptr, error, 'fpm_model_t[package]') + else + call add_table(ptr_pkg, pkg%name, ptr, error, 'fpm_model_t[package]') + end if + if (allocated(error)) return + call pkg%dump_to_toml(ptr, error) + if (allocated(error)) return + + end associate + + end do + end if + + 1 format('UNNAMED_PACKAGE_',i0) + +end subroutine model_dump_to_toml + +!> Read dependency from toml table (no checks made at this stage) +subroutine model_load_from_toml(self, table, error) + + !> Instance of the serializable object + class(fpm_model_t), intent(inout) :: self + + !> Data structure + type(toml_table), intent(inout) :: table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_key), allocatable :: keys(:),pkg_keys(:) + integer :: ierr, ii, jj + type(toml_table), pointer :: ptr,ptr_pkg + + call table%get_keys(keys) + + call get_value(table, "package-name", self%package_name) + call get_value(table, "fortran-flags", self%fortran_compile_flags) + call get_value(table, "c-flags", self%c_compile_flags) + call get_value(table, "cxx-flags", self%cxx_compile_flags) + call get_value(table, "link-flags", self%link_flags) + call get_value(table, "build-prefix", self%build_prefix) + + if (allocated(self%packages)) deallocate(self%packages) + sub_deps: do ii = 1, size(keys) + + select case (keys(ii)%key) + case ("compiler") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,'fpm_model_t: error retrieving compiler table') + return + end if + + call self%compiler%load_from_toml(ptr, error) + if (allocated(error)) return + + case ("archiver") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,'fpm_model_t: error retrieving archiver table') + return + end if + + call self%archiver%load_from_toml(ptr, error) + if (allocated(error)) return + + case ("deps") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,'fpm_model_t: error retrieving dependency tree table') + return + end if + + call self%deps%load_from_toml(ptr, error) + if (allocated(error)) return + + case ("packages") + + call get_value(table, keys(ii), ptr) + if (.not.associated(ptr)) then + call fatal_error(error,'fpm_model_t: error retrieving packages table') + return + end if + + !> Read all packages + call ptr%get_keys(pkg_keys) + allocate(self%packages(size(pkg_keys))) + + do jj = 1, size(pkg_keys) + + call get_value(ptr, pkg_keys(jj), ptr_pkg) + call self%packages(jj)%load_from_toml(ptr_pkg, error) + if (allocated(error)) return + + end do + + + case default + cycle sub_deps + end select + + end do sub_deps + + call get_list(table, "include-dirs", self%include_dirs, error) + if (allocated(error)) return + call get_list(table, "link-libraries", self%link_libraries, error) + if (allocated(error)) return + call get_list(table, "external-modules", self%external_modules, error) + if (allocated(error)) return + call get_value(table, "include-tests", self%include_tests, error, 'fpm_model_t') + if (allocated(error)) return + call get_value(table, "module-naming", self%enforce_module_names, error, 'fpm_model_t') + if (allocated(error)) return + call get_value(table, "module-prefix", self%module_prefix%s) + +end subroutine model_load_from_toml + end module fpm_model diff --git a/src/fpm_strings.f90 b/src/fpm_strings.f90 index c3187db786..e7c92beaf2 100644 --- a/src/fpm_strings.f90 +++ b/src/fpm_strings.f90 @@ -40,11 +40,12 @@ module fpm_strings implicit none private -public :: f_string, lower, split, str_ends_with, string_t, str_begins_with_str +public :: f_string, lower, upper, split, str_ends_with, string_t, str_begins_with_str public :: to_fortran_name, is_fortran_name public :: string_array_contains, string_cat, len_trim, operator(.in.), fnv_1a public :: replace, resize, str, join, glob public :: notabs, dilate, remove_newline_characters, remove_characters_in_set +public :: operator(==) !> Module naming public :: is_valid_module_name, is_valid_module_prefix, & @@ -91,6 +92,11 @@ module fpm_strings module procedure f_string, f_string_cptr, f_string_cptr_n end interface f_string +interface operator(==) + module procedure string_is_same + module procedure string_arrays_same +end interface + contains !> test if a CHARACTER string ends with a specified suffix @@ -287,6 +293,37 @@ elemental pure function lower(str,begin,end) result (string) end function lower + !!License: Public Domain + !! Changes a string to upprtcase over optional specified column range +elemental pure function upper(str,begin,end) result (string) + + character(*), intent(In) :: str + character(len(str)) :: string + integer,intent(in),optional :: begin, end + integer :: i + integer :: ibegin, iend + string = str + + ibegin = 1 + if (present(begin))then + ibegin = max(ibegin,begin) + endif + + iend = len_trim(str) + if (present(end))then + iend= min(iend,end) + endif + + do i = ibegin, iend ! step thru each letter in the string in specified range + select case (str(i:i)) + case ('a':'z') + string(i:i) = char(iachar(str(i:i))-32) ! change letter to capitalized + case default + end select + end do + +end function upper + !> Helper function to generate a new string_t instance !> (Required due to the allocatable component) function new_string_t(s) result(string) @@ -1239,6 +1276,53 @@ logical function has_valid_standard_prefix(module_name,package_name) result(vali end function has_valid_standard_prefix +!> Check that two string _objects_ are exactly identical +pure logical function string_is_same(this,that) + !> two strings to be compared + type(string_t), intent(in) :: this, that + + integer :: i + + string_is_same = .false. + + if (allocated(this%s).neqv.allocated(that%s)) return + if (allocated(this%s)) then + if (.not.len(this%s)==len(that%s)) return + if (.not.len_trim(this%s)==len_trim(that%s)) return + do i=1,len_trim(this%s) + if (.not.(this%s(i:i)==that%s(i:i))) return + end do + end if + + ! All checks passed + string_is_same = .true. + +end function string_is_same + +!> Check that two allocatable string _object_ arrays are exactly identical +pure logical function string_arrays_same(this,that) + !> two string arrays to be compared + type(string_t), allocatable, intent(in) :: this(:), that(:) + + integer :: i + + string_arrays_same = .false. + + if (allocated(this).neqv.allocated(that)) return + if (allocated(this)) then + if (.not.(size(this)==size(that))) return + if (.not.(ubound(this,1)==ubound(that,1))) return + if (.not.(lbound(this,1)==lbound(that,1))) return + do i=lbound(this,1),ubound(this,1) + if (.not.string_is_same(this(i),that(i))) return + end do + end if + + ! All checks passed + string_arrays_same = .true. + +end function string_arrays_same + ! Remove all characters from a set from a string subroutine remove_characters_in_set(string,set,replace_with) character(len=:), allocatable, intent(inout) :: string diff --git a/test/fpm_test/test_manifest.f90 b/test/fpm_test/test_manifest.f90 index be86b311cb..ddabe3cf49 100644 --- a/test/fpm_test/test_manifest.f90 +++ b/test/fpm_test/test_manifest.f90 @@ -167,6 +167,10 @@ subroutine test_valid_manifest(error) return end if + ! Test package serialization + call package%test_serialization('test_valid_manifest',error) + if (allocated(error)) return + end subroutine test_valid_manifest @@ -220,6 +224,9 @@ subroutine test_default_library(error) return end if + call package%test_serialization('test_default_library',error) + if (allocated(error)) return + end subroutine test_default_library @@ -243,6 +250,9 @@ subroutine test_default_executable(error) & "Default executable name") if (allocated(error)) return + call package%test_serialization('test_default_executable',error) + if (allocated(error)) return + end subroutine test_default_executable @@ -517,6 +527,9 @@ subroutine test_profiles(error) return end if + call chosen_profile%test_serialization('profile serialization: '//profile_name//' '//compiler,error) + if (allocated(error)) return + profile_name = 'release' compiler = 'gfortran' call find_profile(package%profiles, profile_name, compiler, 3, profile_found, chosen_profile) @@ -525,6 +538,9 @@ subroutine test_profiles(error) return end if + call chosen_profile%test_serialization('profile serialization: '//profile_name//' '//compiler,error) + if (allocated(error)) return + profile_name = 'publish' compiler = 'gfortran' call find_profile(package%profiles, profile_name, compiler, 1, profile_found, chosen_profile) @@ -533,6 +549,9 @@ subroutine test_profiles(error) return end if + call chosen_profile%test_serialization('profile serialization: '//profile_name//' '//compiler,error) + if (allocated(error)) return + profile_name = 'debug' compiler = 'ifort' call find_profile(package%profiles, profile_name, compiler, 3, profile_found, chosen_profile) @@ -542,6 +561,9 @@ subroutine test_profiles(error) return end if + call chosen_profile%test_serialization('profile serialization: '//profile_name//' '//compiler,error) + if (allocated(error)) return + profile_name = 'release' compiler = 'ifort' call find_profile(package%profiles, profile_name, compiler, 1, profile_found, chosen_profile) @@ -549,6 +571,10 @@ subroutine test_profiles(error) call test_failed(error, "Failed to overwrite built-in profile") return end if + + call chosen_profile%test_serialization('profile serialization: '//profile_name//' '//compiler,error) + if (allocated(error)) return + end subroutine test_profiles !> 'flags' is a key-value entry, test should fail as it is defined as a table @@ -1207,6 +1233,11 @@ subroutine test_link_string(error) call set_value(table, "link", "z", stat=stat) call new_build_config(build, table, 'test_link_string', error) + if (allocated(error)) return + + !> Test serialization roundtrip + call build%test_serialization('test_link_string', error) + if (allocated(error)) return end subroutine test_link_string @@ -1230,6 +1261,11 @@ subroutine test_link_array(error) call set_value(children, 2, "lapack", stat=stat) call new_build_config(build, table, 'test_link_array', error) + if (allocated(error)) return + + !> Test serialization roundtrip + call build%test_serialization('test_link_array', error) + if (allocated(error)) return end subroutine test_link_array diff --git a/test/fpm_test/test_package_dependencies.f90 b/test/fpm_test/test_package_dependencies.f90 index 0a5877a172..f87f3f02f4 100644 --- a/test/fpm_test/test_package_dependencies.f90 +++ b/test/fpm_test/test_package_dependencies.f90 @@ -108,13 +108,13 @@ subroutine test_cache_dump_load(error) call new_dependency_node(deps%dep(3), dep, proj_dir=dep%path) open (newunit=unit, status='scratch') - call deps%dump(unit, error) + call deps%dump_cache(unit, error) if (.not. allocated(error)) then rewind (unit) call new_dependency_tree(deps) call resize(deps%dep, 2) - call deps%load(unit, error) + call deps%load_cache(unit, error) close (unit) end if if (allocated(error)) return @@ -155,7 +155,7 @@ subroutine test_cache_load_dump(error) call set_value(ptr, "proj-dir", "fpm-tmp4-dir") call new_dependency_tree(deps) - call deps%load(table, error) + call deps%load_cache(table, error) if (allocated(error)) return if (deps%ndep /= 4) then @@ -166,7 +166,7 @@ subroutine test_cache_load_dump(error) call table%destroy table = toml_table() - call deps%dump(table, error) + call deps%dump_cache(table, error) if (allocated(error)) return call table%get_keys(list) @@ -197,7 +197,7 @@ subroutine test_status(error) call set_value(ptr, "git", "https://github.com/fortran-lang/dep2") call new_dependency_tree(deps) - call deps%load(table, error) + call deps%load_cache(table, error) if (allocated(error)) return if (deps%finished()) then @@ -289,7 +289,7 @@ subroutine test_non_updated_dependencies(error) ! Load into a dependency tree call new_dependency_tree(cached) - call cached%load(cache, error) + call cached%load_cache(cache, error) if (allocated(error)) return ! Mark all dependencies as "cached" do ii=1,cached%ndep @@ -313,7 +313,7 @@ subroutine test_non_updated_dependencies(error) ! Load dependencies from manifest call new_dependency_tree(manifest_deps) - call manifest_deps%load(manifest, error) + call manifest_deps%load_cache(manifest, error) call manifest%destroy() if (allocated(error)) return @@ -372,7 +372,7 @@ subroutine test_update_dependencies(error) ! Load into a dependency tree call new_dependency_tree(cached) - call cached%load(cache, error) + call cached%load_cache(cache, error) if (allocated(error)) return ! Mark all dependencies as "cached" do ii=1,cached%ndep @@ -396,7 +396,7 @@ subroutine test_update_dependencies(error) ! Load dependencies from manifest call new_dependency_tree(manifest_deps) - call manifest_deps%load(manifest, error) + call manifest_deps%load_cache(manifest, error) call manifest%destroy() if (allocated(error)) return diff --git a/test/fpm_test/test_source_parsing.f90 b/test/fpm_test/test_source_parsing.f90 index 9a5f5802ec..c407d0c857 100644 --- a/test/fpm_test/test_source_parsing.f90 +++ b/test/fpm_test/test_source_parsing.f90 @@ -119,6 +119,8 @@ subroutine test_modules_used(error) return end if + call f_source%test_serialization('srcfile_t: serialization', error) + end subroutine test_modules_used @@ -186,6 +188,8 @@ subroutine test_intrinsic_modules_used(error) return end if + call f_source%test_serialization('srcfile_t: serialization', error) + end subroutine test_intrinsic_modules_used @@ -315,6 +319,8 @@ subroutine test_include_stmt(error) return end if + call f_source%test_serialization('srcfile_t: serialization', error) + end subroutine test_include_stmt !> Try to parse a simple fortran program @@ -370,6 +376,8 @@ subroutine test_program(error) return end if + call f_source%test_serialization('srcfile_t: serialization', error) + end subroutine test_program @@ -452,6 +460,8 @@ subroutine test_module(error) return end if + call f_source%test_serialization('srcfile_t: serialization', error) + end subroutine test_module @@ -501,6 +511,8 @@ subroutine test_module_with_subprogram(error) return end if + call f_source%test_serialization('srcfile_t: serialization', error) + end subroutine test_module_with_subprogram @@ -566,6 +578,8 @@ subroutine test_module_end_stmt(error) return end if + call f_source%test_serialization('srcfile_t: serialization', error) + end subroutine test_module_end_stmt @@ -614,6 +628,8 @@ subroutine test_module_with_c_api(error) return end if + call f_source%test_serialization('srcfile_t: serialization', error) + end subroutine test_module_with_c_api @@ -677,6 +693,8 @@ subroutine test_program_with_module(error) return end if + call f_source%test_serialization('srcfile_t: serialization', error) + end subroutine test_program_with_module @@ -734,6 +752,8 @@ subroutine test_submodule(error) return end if + call f_source%test_serialization('srcfile_t: serialization', error) + end subroutine test_submodule @@ -791,6 +811,8 @@ subroutine test_submodule_ancestor(error) return end if + call f_source%test_serialization('srcfile_t: serialization', error) + end subroutine test_submodule_ancestor @@ -839,6 +861,8 @@ subroutine test_subprogram(error) return end if + call f_source%test_serialization('srcfile_t: serialization', error) + end subroutine test_subprogram @@ -909,6 +933,8 @@ subroutine test_csource(error) return end if + call f_source%test_serialization('srcfile_t: serialization', error) + end subroutine test_csource !> Try to parse fortran program with invalid use statement diff --git a/test/fpm_test/test_toml.f90 b/test/fpm_test/test_toml.f90 index 1ffea1d651..ad0a8b40c9 100644 --- a/test/fpm_test/test_toml.f90 +++ b/test/fpm_test/test_toml.f90 @@ -2,11 +2,30 @@ module test_toml use testsuite, only : new_unittest, unittest_t, error_t use fpm_toml + use tomlf_constants, only: tf_i8 + use fpm_git + use fpm_dependency, only: dependency_node_t, destroy_dependency_node, dependency_tree_t, & + & new_dependency_node, new_dependency_tree, resize + use fpm_manifest_dependency, only: dependency_config_t, dependency_destroy + use fpm_manifest_install + use fpm_manifest_fortran + use fpm_manifest_library + use fpm_manifest_executable + use fpm_manifest_preprocess + use fpm_manifest_profile + use fpm_versioning, only: new_version + use fpm_strings, only: string_t, operator(==), split + use fpm_model, only: fortran_features_t, package_t, FPM_SCOPE_LIB, FPM_UNIT_MODULE, fpm_model_t, & + & srcfile_t + use fpm_compiler, only: archiver_t, compiler_t, id_gcc + + implicit none private public :: collect_toml + character, parameter :: NL = new_line('a') contains @@ -18,9 +37,36 @@ subroutine collect_toml(testsuite) type(unittest_t), allocatable, intent(out) :: testsuite(:) testsuite = [ & - & new_unittest("valid-toml", test_valid_toml), & - & new_unittest("invalid-toml", test_invalid_toml, should_fail=.true.), & - & new_unittest("missing-file", test_missing_file, should_fail=.true.)] + & new_unittest("valid-toml", test_valid_toml), & + & new_unittest("invalid-toml", test_invalid_toml, should_fail=.true.), & + & new_unittest("missing-file", test_missing_file, should_fail=.true.), & + & new_unittest("serialize-git-target", git_target_roundtrip), & + & new_unittest("serialize-git-invalid", git_target_invalid, should_fail=.true.), & + & new_unittest("serialize-dependency-config", dependency_config_roundtrip), & + & new_unittest("serialize-dependency-node", dependency_node_roundtrip), & + & new_unittest("serialize-dependency-invalid", dependency_node_invalid, should_fail=.true.), & + & new_unittest("serialize-dependency-invalid2", dependency_node_invalid_2, should_fail=.true.), & + & new_unittest("serialize-dependency-tree", dependency_tree_roundtrip), & + & new_unittest("serialize-dependency-tree-invalid", dependency_tree_invalid, should_fail=.true.), & + & new_unittest("serialize-dependency-tree-invalid2", dependency_tree_invalid2, should_fail=.true.), & + & new_unittest("serialize-install-config", install_config_roundtrip), & + & new_unittest("serialize-fortran-config", fortran_features_roundtrip), & + & new_unittest("serialize-library-config", library_config_roundtrip), & + & new_unittest("serialize-executable-config", executable_config_roundtrip), & + & new_unittest("serialize-preprocess-config", preprocess_config_roundtrip), & + & new_unittest("serialize-file-scope-flag", file_scope_flag_roundtrip), & + & new_unittest("serialize-string-array", string_array_roundtrip), & + & new_unittest("serialize-fortran-features", fft_roundtrip), & + & new_unittest("serialize-fortran-invalid", fft_invalid, should_fail=.true.), & + & new_unittest("serialize-package", package_roundtrip), & + & new_unittest("serialize-package-invalid", package_invalid, should_fail=.true.), & + & new_unittest("serialize-srcfile-invalid", source_invalid, should_fail=.true.), & + & new_unittest("serialize-archiver", ar_roundtrip), & + & new_unittest("serialize-archiver-invalid", ar_invalid, should_fail=.true.), & + & new_unittest("serialize-compiler", compiler_roundtrip), & + & new_unittest("serialize-compiler-invalid", compiler_invalid, should_fail=.true.), & + & new_unittest("serialize-model", fpm_model_roundtrip), & + & new_unittest("serialize-model-invalid", fpm_model_invalid, should_fail=.true.)] end subroutine collect_toml @@ -103,5 +149,1145 @@ subroutine test_missing_file(error) end subroutine test_missing_file + !> Test git_target_t serialization + subroutine git_target_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(git_target_t) :: git + + ! Revision type + git = git_target_revision(url="https://github.com/urbanjost/M_CLI2.git", & + sha1="7264878cdb1baff7323cc48596d829ccfe7751b8") + call git%test_serialization("revision git type",error) + if (allocated(error)) return + + ! Branch type + git = git_target_branch(url="https://github.com/urbanjost/M_CLI2.git", & + branch="main") + call git%test_serialization("branch git type",error) + if (allocated(error)) return + + ! Tag type + git = git_target_tag(url="https://github.com/urbanjost/M_CLI2.git", & + tag="1.0.0") + call git%test_serialization("target git type",error) + if (allocated(error)) return + + ! Incomplete type + if (allocated(git%object)) deallocate(git%object) + call git%test_serialization("incomplete git type 1/2",error) + if (allocated(error)) return + + ! Incomplete type + if (allocated(git%url)) deallocate(git%url) + call git%test_serialization("incomplete git type 2/2",error) + if (allocated(error)) return + + end subroutine git_target_roundtrip + + + !> Test invalid git_target_t serialization + subroutine git_target_invalid(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(git_target_t) :: git + type(toml_table), allocatable :: table + + character(*), parameter :: toml = 'descriptor = ""'//NL//& ! invalid descriptor ID + 'url = "https://github.com/toml-f/toml-f"'//NL//& + 'object = "54686e45993f3a9a1d05d5c7419f39e7d5a4eb3f"' + + + call string_to_toml(toml, table) + + call git%load(table, error) + + end subroutine git_target_invalid + + !> Test git_target_t serialization + subroutine dependency_config_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(dependency_config_t) :: dep + + call dependency_destroy(dep) + + dep%name = "M_CLI2" + dep%path = "~/./some/dummy/path" + dep%namespace = "urbanjost" + allocate(dep%requested_version) + call new_version(dep%requested_version, "3.2.0",error); if (allocated(error)) return + + allocate(dep%git) + dep%git = git_target_revision(url="https://github.com/urbanjost/M_CLI2.git", & + sha1="7264878cdb1baff7323cc48596d829ccfe7751b8") + + ! Test full object + call dep%test_serialization("full object",error) + if (allocated(error)) return + + ! Remove namespace + deallocate(dep%namespace) + call dep%test_serialization("no namespace",error) + if (allocated(error)) return + + ! Remove git + deallocate(dep%git) + call dep%test_serialization("no git",error) + if (allocated(error)) return + + ! Remove version + deallocate(dep%requested_version) + call dep%test_serialization("no requested_version",error) + if (allocated(error)) return + + ! Remove name + deallocate(dep%name) + call dep%test_serialization("no name",error) + if (allocated(error)) return + + ! Remove path + deallocate(dep%path) + call dep%test_serialization("no path",error) + if (allocated(error)) return + + end subroutine dependency_config_roundtrip + + !> Test dependency_node_t serialization + subroutine dependency_node_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: dep + + call destroy_dependency_node(dep) + + dep%name = "M_CLI2" + dep%path = "~/./some/dummy/path" + dep%proj_dir = "~/./" + dep%namespace = "urbanjost" + dep%revision = "7264878cdb1baff7323cc48596d829ccfe7751b8" + dep%cached = .true. + dep%done = .false. + dep%update = .true. + allocate(dep%requested_version) + call new_version(dep%requested_version, "3.2.0",error); if (allocated(error)) return + allocate(dep%version) + call new_version(dep%version, "4.53.2",error); if (allocated(error)) return + + allocate(dep%git) + dep%git = git_target_revision(url="https://github.com/urbanjost/M_CLI2.git", & + sha1="7264878cdb1baff7323cc48596d829ccfe7751b8") + + ! Test full object + call dep%test_serialization("full object",error) + if (allocated(error)) return + + ! Remove namespace + deallocate(dep%namespace) + call dep%test_serialization("no namespace",error) + if (allocated(error)) return + + ! Remove git + deallocate(dep%git) + call dep%test_serialization("no git",error) + if (allocated(error)) return + + ! Remove version + deallocate(dep%requested_version) + call dep%test_serialization("no requested_version",error) + if (allocated(error)) return + + ! Remove name + deallocate(dep%name) + call dep%test_serialization("no name",error) + if (allocated(error)) return + + ! Remove path + deallocate(dep%path) + call dep%test_serialization("no path",error) + if (allocated(error)) return + + ! Remove revision + deallocate(dep%revision) + call dep%test_serialization("no revision",error) + if (allocated(error)) return + + ! Remove proj_dir + deallocate(dep%proj_dir) + call dep%test_serialization("no proj_dir",error) + if (allocated(error)) return + + ! Remove version + deallocate(dep%version) + call dep%test_serialization("no version",error) + if (allocated(error)) return + + end subroutine dependency_node_roundtrip + + !> Test loading invalid dependency node + subroutine dependency_node_invalid(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: dep + type(toml_table), allocatable :: table + + character(*), parameter :: toml = 'name = "jonquil" '//NL//& + & 'version = "h0.2.0"'//NL//& ! invalid version + & 'proj-dir = "build/dependencies/jonquil"'//NL//& + & 'revision = "05d30818bb12fb877226ce284b9a3a41b971a889"'//NL//& + & 'done = true'//NL//& + & 'update = false'//NL//& + & 'cached = true' + + call string_to_toml(toml, table) + + call dep%load(table, error) + + end subroutine dependency_node_invalid + + !> Test loading invalid dependency node + subroutine dependency_node_invalid_2(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(dependency_node_t) :: dep + type(toml_table), allocatable :: table + + character(*), parameter :: toml = 'name = "jonquil" '//NL//& + & 'version = "0.2.0"'//NL//& + & 'proj-dir = "build/dependencies/jonquil"'//NL//& + & 'revision = "05d30818bb12fb877226ce284b9a3a41b971a889"'//NL//& + & 'done = 123'//NL//& ! not a boolean + & 'update = false'//NL//& + & 'cached = true' + + call string_to_toml(toml, table) + call dep%load(table, error) + + end subroutine dependency_node_invalid_2 + + !> Test dependency_tree_t serialization + subroutine dependency_tree_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(dependency_tree_t) :: deps + type(dependency_config_t) :: dep + + integer, parameter :: ALLOCATED_DEPS = 5 + character(36) :: msg + integer :: ii + + ! Generate dummy tree with ndep=3 but 5 allocated dependencies + call new_dependency_tree(deps) + call resize(deps%dep, ALLOCATED_DEPS) + 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) + deps%dep(3)%name = "M_CLI2" + deps%dep(3)%path = "~/./some/dummy/path" + deps%dep(3)%proj_dir = "~/./" + deps%dep(3)%namespace = "urbanjost" + deps%dep(3)%revision = "7264878cdb1baff7323cc48596d829ccfe7751b8" + deps%dep(3)%cached = .true. + deps%dep(3)%done = .false. + deps%dep(3)%update = .true. + allocate(deps%dep(3)%requested_version) + call new_version(deps%dep(3)%requested_version, "3.2.0",error); if (allocated(error)) return + allocate(deps%dep(3)%version) + call new_version(deps%dep(3)%version, "4.53.2",error); if (allocated(error)) return + allocate(deps%dep(3)%git) + deps%dep(3)%git = git_target_revision(url="https://github.com/urbanjost/M_CLI2.git", & + sha1="7264878cdb1baff7323cc48596d829ccfe7751b8") + + call deps%test_serialization("full dependency tree", error) + if (allocated(error)) return + + ! Remove dependencies (including all them) + do ii = 1, ALLOCATED_DEPS + write(msg,1) ii + call resize(deps%dep, size(deps%dep) - 1) + call deps%test_serialization(trim(msg), error) + if (allocated(error)) return + end do + + ! deallocate dependencies + deallocate(deps%dep) + call deps%test_serialization("unallocated deps(:)", error) + if (allocated(error)) return + + ! Remove deps dir + deallocate(deps%dep_dir) + call deps%test_serialization("no deps dir", error) + if (allocated(error)) return + + 1 format('removed ',i0,' dependencies') + + end subroutine dependency_tree_roundtrip + + !> Test invalid dependency tree loading + subroutine dependency_tree_invalid(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), allocatable :: table + type(dependency_tree_t) :: dep + + character(len=*), parameter :: toml = & + & 'unit = 6 '//NL//& + & 'verbosity = true'//NL//& ! not a number + & 'dep-dir = "build/dependencies"'//NL//& + & 'ndep = 3'//NL//& ! consistency is not checked: + & '[dependencies]'//NL//& + & '[dependencies.dep1]'//NL//& + & 'name = "dep1"'//NL//& + & 'path = "fpm-tmp1-dir"'//NL//& + & 'proj-dir = "fpm-tmp1-dir"'//NL//& + & 'done = false'//NL//& + & 'update = false'//NL//& + & 'cached = false' + + call string_to_toml(toml, table) + call dep%load(table, error) + + end subroutine dependency_tree_invalid + + !> Test invalid dependency tree loading + subroutine dependency_tree_invalid2(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), allocatable :: table + type(dependency_tree_t) :: dep + + character(len=*), parameter :: toml = & + & 'unit = "" '//NL//& ! not provided + & 'verbosity = 1'//NL//& + & 'dep-dir = "build/dependencies"'//NL//& + & 'ndep = 3'//NL//& ! consistency is not checked: + & '[dependencies.M_CLI2]'//NL//& + & 'name = "M_CLI2"'//NL//& + & 'path = "~/./some/dummy/path"'//NL//& + & 'namespace = "urbanjost"'//NL//& + & 'requested_version = "3.2.0"'//NL//& + & 'version = "4.53.2"'//NL//& + & 'proj-dir = "~/./"'//NL//& + & 'revision = "7264878cdb1baff7323cc48596d829ccfe7751b8"'//NL//& + & 'done = false'//NL//& + & 'update = true'//NL//& + & 'cached = true'//NL//& + & '[dependencies.M_CLI2.git]'//NL//& + & 'descriptor = "revision"'//NL//& + & 'url = "https://github.com/urbanjost/M_CLI2.git"'//NL//& + & 'object = "7264878cdb1baff7323cc48596d829ccfe7751b8"' + + call string_to_toml(toml, table) + call dep%load(table, error) + + end subroutine dependency_tree_invalid2 + + !> Test serialization/deserialization of a string array + subroutine string_array_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=*), parameter :: lorem = "Lorem ipsum dolor sit amet, consectetur adipiscing " & + & //"elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad " & + & //"minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo " & + & //"consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum " & + & //"dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt " & + & //"in culpa qui officia deserunt mollit anim id est laborum" + + integer :: ii, nword + character(len=:), allocatable :: tokens(:) + type(string_t), allocatable :: list(:),copy(:) + type(toml_table) :: table + character(len=16) :: key + + call split(lorem, tokens) + nword = size(tokens) + + !> Convert to string_t array + allocate(list(nword)) + do ii = 1, nword + list(ii) = string_t(trim(tokens(ii))) + end do + + ! Test list with any length + do ii = nword, 1, -1 + + ! Shorten list + list = list(1:ii) + + ! Set list to table + table = toml_table() + + call set_list(table, key="lorem-ipsum", list=list, error=error) + if (allocated(error)) return + + ! Load list from table + call get_list(table, key="lorem-ipsum", list=copy, error=error) + if (allocated(error)) return + + if (.not.(list==copy)) then + call fatal_error(error,'string_array is not equal after TOML roundtrip') + return + end if + + end do + + ! Test empty list + deallocate(list) + allocate(list(0)) + ! Set list to table + table = toml_table() + + call set_list(table, key="lorem-ipsum", list=list, error=error) + if (allocated(error)) return + + ! Load list from table + call get_list(table, key="lorem-ipsum", list=copy, error=error) + if (allocated(error)) return + + if (.not.(list==copy)) then + call fatal_error(error,'empty string_array is not equal after TOML roundtrip') + return + end if + + ! Test unallocated list + deallocate(list) + table = toml_table() + + call set_list(table, key="lorem-ipsum", list=list, error=error) + if (allocated(error)) return + + ! Load list from table + call get_list(table, key="lorem-ipsum", list=copy, error=error) + if (allocated(error)) return + + if (.not.(list==copy)) then + call fatal_error(error,'deallocated string_array is not equal after TOML roundtrip') + return + end if + + 1 format('word_',i0) + + end subroutine string_array_roundtrip + + !> Test serialization/deserialization of a fortran-features structure + subroutine fft_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(fortran_features_t) :: fortran + + !> Default object + call fortran%test_serialization('fortran_features_t: default object',error) + if (allocated(error)) return + + !> Set form + fortran%source_form = "free" + call fortran%test_serialization('fortran_features_t: with form',error) + if (allocated(error)) return + + end subroutine fft_roundtrip + + !> Test deserialization of an invalid fortran-features structure + subroutine fft_invalid(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(fortran_features_t) :: fortran + type(toml_table), allocatable :: table + + character(len=*), parameter :: toml = 'implicit-typing = false '//NL//& + & 'implicit-external = 0 '//NL//& ! not a boolean + & 'source-form = "free" ' + + call string_to_toml(toml, table) + + !> Default object + call fortran%load(table,error) + + end subroutine fft_invalid + + !> Test serialization/deserialization of a package_t structure + subroutine package_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_t) :: pkg + integer :: ierr + + !> Default object + call pkg%test_serialization('package_t: default object',error) + if (allocated(error)) return + + !> Create a dummy package + pkg%name = "orderpack" + pkg%version = "0.1.0" + pkg%enforce_module_names = .false. + pkg%module_prefix = string_t("") + pkg%features%source_form = "free" + + if (allocated(pkg%sources)) deallocate(pkg%sources) + allocate(pkg%sources(4)) + + pkg%sources(1)%file_name = "build/dependencies/orderpack/src/M_valnth.f90" + pkg%sources(1)%digest = 2662523002405134329_tf_i8 + pkg%sources(1)%unit_scope = FPM_SCOPE_LIB + pkg%sources(1)%unit_type = FPM_UNIT_MODULE + pkg%sources(1)%modules_provided = [string_t("m_valnth")] + deallocate(pkg%sources(1)%parent_modules, stat=ierr) + deallocate(pkg%sources(1)%modules_used, stat=ierr) + deallocate(pkg%sources(1)%include_dependencies, stat=ierr) + deallocate(pkg%sources(1)%link_libraries, stat=ierr) + + pkg%sources(2)%file_name = "build/dependencies/orderpack/src/M_mrgrnk.f90" + pkg%sources(2)%digest = 7985690966656622651_tf_i8 + pkg%sources(2)%unit_scope = FPM_SCOPE_LIB + pkg%sources(2)%unit_type = FPM_UNIT_MODULE + pkg%sources(2)%modules_provided = [string_t("m_mrgrnk")] + pkg%sources(2)%link_libraries = [string_t("netcdf"),string_t("hdf-5")] + deallocate(pkg%sources(2)%parent_modules, stat=ierr) + deallocate(pkg%sources(2)%modules_used, stat=ierr) + deallocate(pkg%sources(2)%include_dependencies, stat=ierr) + deallocate(pkg%sources(2)%link_libraries, stat=ierr) + + pkg%sources(3)%file_name = "build/dependencies/orderpack/src/M_median.f90" + pkg%sources(3)%digest = 7985690966656622651_tf_i8 + pkg%sources(3)%unit_scope = FPM_SCOPE_LIB + pkg%sources(3)%unit_type = FPM_UNIT_MODULE + pkg%sources(3)%modules_provided = [string_t("m_median")] + deallocate(pkg%sources(3)%parent_modules, stat=ierr) + deallocate(pkg%sources(3)%modules_used, stat=ierr) + deallocate(pkg%sources(3)%include_dependencies, stat=ierr) + deallocate(pkg%sources(3)%link_libraries, stat=ierr) + + pkg%sources(4)%file_name = "build/dependencies/orderpack/src/M_unista.f90" + pkg%sources(4)%digest = -7512253540457404792_tf_i8 + pkg%sources(4)%unit_scope = FPM_SCOPE_LIB + pkg%sources(4)%unit_type = FPM_UNIT_MODULE + pkg%sources(4)%modules_provided = [string_t("m_unista")] + pkg%sources(4)%modules_used = [string_t("m_uniinv")] + deallocate(pkg%sources(4)%parent_modules, stat=ierr) + deallocate(pkg%sources(4)%include_dependencies, stat=ierr) + deallocate(pkg%sources(4)%link_libraries, stat=ierr) + + !> Package mock + call pkg%test_serialization('package_t: orderpack',error) + if (allocated(error)) return + + !> Remove some entries + pkg%sources(1)%file_name = "" + pkg%sources(3)%digest = 0 + pkg%sources = pkg%sources(1:3) + call pkg%test_serialization('package_t: orderpack (reduced)',error) + if (allocated(error)) return + + !> Remove all sources + deallocate(pkg%sources,stat=ierr) + call pkg%test_serialization('package_t: no sources',error) + if (allocated(error)) return + + end subroutine package_roundtrip + + !> Test deserialization of an invalid package TOML file + subroutine package_invalid(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=*), parameter :: toml = & + & 'name = "toml-f" '//NL//& + & 'version = "0.8.0" '//NL//& + & 'module-naming = "prefix" '//NL//& ! this should be boolean + & 'module-prefix = "" ' + + type(package_t) :: pkg + type(toml_table), allocatable :: table + + call string_to_toml(toml, table) + + !> Default object + call pkg%load(table,error) + + end subroutine package_invalid + + !> Test deserialization of an invalid source file + subroutine source_invalid(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=*), parameter :: toml = & + & 'file-name = "build/dependencies/toml-f/src/tomlf.f90" '//NL//& + & 'digest = "abcde" '//NL//& ! not a number + & 'unit-scope = "FPM_SCOPE_MODULE" '//NL//& + & 'unit-type = "FPM_UNIT_MODULE" '//NL//& + & 'modules-provided = "tomlf" '//NL//& + & 'parent-modules = [ ] '//NL//& + & 'modules-used = [ "tomlf_build", "tomlf_datetime" ] '//NL//& + & 'include-dependencies = [ ] '//NL//& + & 'link-libraries = [ ] ' + + type(srcfile_t) :: src + type(toml_table), allocatable :: table + + call string_to_toml(toml, table) + + !> Default object + call src%load(table,error) + + end subroutine source_invalid + + !> Test serialization/deserialization of an archiver_t structure + subroutine ar_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(archiver_t) :: ar + integer :: ierr + + !> Default object + call ar%test_serialization('archiver_t: default object',error) + if (allocated(error)) return + + !> change a few items + ar%ar = "ar" + ar%echo = .true. + ar%use_response_file = .false. + + call ar%test_serialization('archiver_t: ar',error) + + end subroutine ar_roundtrip + + !> Test deserialization of an invalid archiver_t structure + subroutine ar_invalid(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=*), parameter :: toml = & + & 'ar = "ar -rs " '//NL//& + & 'use-response-file = false '//NL//& + & 'echo = 123 '//NL//& ! not a boolean + & 'verbose = false ' + + type(archiver_t) :: ar + type(toml_table), allocatable :: table + + call string_to_toml(toml, table) + + !> Default object + call ar%load(table,error) + + end subroutine ar_invalid + + !> Test serialization/deserialization of a compiler_t structure + subroutine compiler_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(compiler_t) :: compiler + + !> Default object + call compiler%test_serialization('compiler_t: default object',error) + if (allocated(error)) return + + !> change a few items + compiler%id = id_gcc + compiler%fc = "gfortran -ffree-line-length-none -fdefault-real-8 -O3" + compiler%cc = "" + compiler%cxx = "g++ -O3 -std=c++11" + compiler%echo = .false. + + call compiler%test_serialization('compiler_t: gcc',error) + + end subroutine compiler_roundtrip + + !> Test deserialization of an invalid compiler_t TOML structure + subroutine compiler_invalid(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + character(len=*), parameter :: toml = & + & 'id = "gfortran" '//NL//& ! not an integer identifier + & 'fc = "gfortran" '//NL//& + & 'cc = "gcc" '//NL//& + & 'cxx = "g++" '//NL//& + & 'echo = false '//NL//& + & 'verbose = false ' + + type(compiler_t) :: cc + type(toml_table), allocatable :: table + + call string_to_toml(toml, table) + + !> Default object + call cc%load(table,error) + + end subroutine compiler_invalid + + !> Get a shortened TOML representation of the fpm v0.8.1 model + subroutine fpm_081_table(table) + + !> TOML representation of the fpm v0.8.1 model + type(toml_table), allocatable, intent(out) :: table + + !> simplified TOML representation of the fpm v0.8.1 model + character(len=:), allocatable :: fpm + + integer :: iunit + + allocate(character(len=0) :: fpm) + fpm = fpm//NL//'package-name = "fpm"' + fpm = fpm//NL//'fortran-flags = " -Wall -Wextra -fPIC -fmax-errors=1 -g "' + fpm = fpm//NL//'c-flags = ""' + fpm = fpm//NL//'cxx-flags = ""' + fpm = fpm//NL//'link-flags = ""' + fpm = fpm//NL//'build-prefix = "build/gfortran"' + fpm = fpm//NL//'include-dirs = [ ]' + fpm = fpm//NL//'link-libraries = [ ]' + fpm = fpm//NL//'external-modules = [ ]' + fpm = fpm//NL//'include-tests = false' + fpm = fpm//NL//'module-naming = false' + fpm = fpm//NL//'module-prefix = ""' + fpm = fpm//NL//'[compiler]' + fpm = fpm//NL//'id = 1' + fpm = fpm//NL//'fc = "gfortran"' + fpm = fpm//NL//'cc = "gcc"' + fpm = fpm//NL//'cxx = "g++"' + fpm = fpm//NL//'echo = false' + fpm = fpm//NL//'verbose = false' + fpm = fpm//NL//'[archiver]' + fpm = fpm//NL//'ar = "ar -rs "' + fpm = fpm//NL//'use-response-file = false' + fpm = fpm//NL//'echo = false' + fpm = fpm//NL//'verbose = false' + fpm = fpm//NL//'[deps]' + fpm = fpm//NL//'unit = 6' + fpm = fpm//NL//'verbosity = 1' + fpm = fpm//NL//'dep-dir = "build/dependencies"' + fpm = fpm//NL//'cache = "build/cache.toml"' + fpm = fpm//NL//'ndep = 4' + fpm = fpm//NL//'[deps.dependencies]' + fpm = fpm//NL//'[deps.dependencies.fpm]' + fpm = fpm//NL//'name = "fpm"' + fpm = fpm//NL//'path = "."' + fpm = fpm//NL//'version = "0.8.0"' + fpm = fpm//NL//'proj-dir = "./."' + fpm = fpm//NL//'done = true' + fpm = fpm//NL//'update = false' + fpm = fpm//NL//'cached = false' + fpm = fpm//NL//'[deps.dependencies.toml-f]' + fpm = fpm//NL//'name = "toml-f"' + fpm = fpm//NL//'version = "0.4.0"' + fpm = fpm//NL//'proj-dir = "build/dependencies/toml-f"' + fpm = fpm//NL//'revision = "54686e45993f3a9a1d05d5c7419f39e7d5a4eb3f"' + fpm = fpm//NL//'done = true' + fpm = fpm//NL//'update = false' + fpm = fpm//NL//'cached = true' + fpm = fpm//NL//'[deps.dependencies.toml-f.git]' + fpm = fpm//NL//'descriptor = "revision"' + fpm = fpm//NL//'url = "https://github.com/toml-f/toml-f"' + fpm = fpm//NL//'object = "54686e45993f3a9a1d05d5c7419f39e7d5a4eb3f"' + fpm = fpm//NL//'[deps.dependencies.UNNAMED_DEPENDENCY_5]' + fpm = fpm//NL//'done = false' + fpm = fpm//NL//'update = false' + fpm = fpm//NL//'cached = false' + fpm = fpm//NL//'[packages]' + fpm = fpm//NL//'[packages.fpm]' + fpm = fpm//NL//'name = "fpm"' + fpm = fpm//NL//'version = "0.8.0"' + fpm = fpm//NL//'module-naming = false' + fpm = fpm//NL//'module-prefix = ""' + fpm = fpm//NL//'[packages.fpm.fortran]' + fpm = fpm//NL//'implicit-typing = false' + fpm = fpm//NL//'implicit-external = false' + fpm = fpm//NL//'source-form = "free"' + fpm = fpm//NL//'[packages.fpm.sources]' + fpm = fpm//NL//'[packages.fpm.sources.src_1]' + fpm = fpm//NL//'file-name = "././src/fpm.f90"' + fpm = fpm//NL//'digest = 4322290725857190613' + fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"' + fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"' + fpm = fpm//NL//'modules-provided = "fpm"' + fpm = fpm//NL//'parent-modules = [ ]' + fpm = fpm//NL//'modules-used = [ "fpm_strings", "fpm_backend", "fpm_compiler", "fpm_error" ]' + fpm = fpm//NL//'include-dependencies = [ ]' + fpm = fpm//NL//'link-libraries = [ ]' + fpm = fpm//NL//'[packages.fpm.sources.src_2]' + fpm = fpm//NL//'file-name = "././src/fpm_backend.F90"' + fpm = fpm//NL//'digest = -3210121688944515946' + fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"' + fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"' + fpm = fpm//NL//'modules-provided = "fpm_backend"' + fpm = fpm//NL//'parent-modules = [ ]' + fpm = fpm//NL//'modules-used = [ "fpm_error", "fpm_filesystem", "fpm_backend_output" ]' + fpm = fpm//NL//'include-dependencies = [ ]' + fpm = fpm//NL//'link-libraries = [ ]' + fpm = fpm//NL//'[packages.fpm.sources.src_3]' + fpm = fpm//NL//'file-name = "././src/fpm_environment.f90"' + fpm = fpm//NL//'digest = 2235607720245152632' + fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"' + fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"' + fpm = fpm//NL//'modules-provided = "fpm_environment"' + fpm = fpm//NL//'parent-modules = [ ]' + fpm = fpm//NL//'modules-used = "fpm_error"' + fpm = fpm//NL//'include-dependencies = [ ]' + fpm = fpm//NL//'link-libraries = [ ]' + fpm = fpm//NL//'[packages.fpm.sources.src_4]' + fpm = fpm//NL//'file-name = "././src/fpm_model.f90"' + fpm = fpm//NL//'digest = -6774177234665080583' + fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"' + fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"' + fpm = fpm//NL//'modules-provided = "fpm_model"' + fpm = fpm//NL//'parent-modules = [ ]' + fpm = fpm//NL//'modules-used = [ "fpm_compiler", "fpm_dependency" ]' + fpm = fpm//NL//'include-dependencies = [ ]' + fpm = fpm//NL//'link-libraries = [ ]' + fpm = fpm//NL//'[packages.fpm.sources.src_5]' + fpm = fpm//NL//'file-name = "././src/filesystem_utilities.c"' + fpm = fpm//NL//'digest = 4957633104775755438' + fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"' + fpm = fpm//NL//'unit-type = "FPM_UNIT_CSOURCE"' + fpm = fpm//NL//'modules-provided = [ ]' + fpm = fpm//NL//'parent-modules = [ ]' + fpm = fpm//NL//'modules-used = [ ]' + fpm = fpm//NL//'include-dependencies = [ ]' + fpm = fpm//NL//'link-libraries = [ ]' + fpm = fpm//NL//'[packages.fpm.sources.src_59]' + fpm = fpm//NL//'file-name = "test/new_test/new_test.f90"' + fpm = fpm//NL//'exe-name = "new-test"' + fpm = fpm//NL//'digest = 4683353150944180202' + fpm = fpm//NL//'unit-scope = "FPM_SCOPE_TEST"' + fpm = fpm//NL//'unit-type = "FPM_UNIT_PROGRAM"' + fpm = fpm//NL//'modules-provided = [ ]' + fpm = fpm//NL//'parent-modules = [ ]' + fpm = fpm//NL//'modules-used = [ "fpm_filesystem", "fpm_strings", "fpm_environment" ]' + fpm = fpm//NL//'include-dependencies = [ ]' + fpm = fpm//NL//'link-libraries = [ ]' + fpm = fpm//NL//'[packages.toml-f]' + fpm = fpm//NL//'name = "toml-f"' + fpm = fpm//NL//'version = "0.8.0"' + fpm = fpm//NL//'module-naming = false' + fpm = fpm//NL//'module-prefix = ""' + fpm = fpm//NL//'[packages.toml-f.fortran]' + fpm = fpm//NL//'implicit-typing = false' + fpm = fpm//NL//'implicit-external = false' + fpm = fpm//NL//'source-form = "free"' + fpm = fpm//NL//'[packages.toml-f.sources]' + fpm = fpm//NL//'[packages.toml-f.sources.src_1]' + fpm = fpm//NL//'file-name = "build/dependencies/toml-f/src/tomlf.f90"' + fpm = fpm//NL//'digest = -8299830903248890534' + fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"' + fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"' + fpm = fpm//NL//'modules-provided = "tomlf"' + fpm = fpm//NL//'parent-modules = [ ]' + fpm = fpm//NL//'modules-used = [ "tomlf_build", "tomlf_datetime" ]' + fpm = fpm//NL//'include-dependencies = [ ]' + fpm = fpm//NL//'link-libraries = [ ]' + fpm = fpm//NL//'[packages.toml-f.sources.src_2]' + fpm = fpm//NL//'file-name = "build/dependencies/toml-f/src/tomlf/constants.f90"' + fpm = fpm//NL//'digest = 7170350792708576173' + fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"' + fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"' + fpm = fpm//NL//'modules-provided = "tomlf_constants"' + fpm = fpm//NL//'parent-modules = [ ]' + fpm = fpm//NL//'modules-used = [ ]' + fpm = fpm//NL//'include-dependencies = [ ]' + fpm = fpm//NL//'link-libraries = [ ]' + fpm = fpm//NL//'[packages.M_CLI2]' + fpm = fpm//NL//'name = "M_CLI2"' + fpm = fpm//NL//'version = "0.8.0"' + fpm = fpm//NL//'module-naming = false' + fpm = fpm//NL//'module-prefix = ""' + fpm = fpm//NL//'[packages.M_CLI2.fortran]' + fpm = fpm//NL//'implicit-typing = false' + fpm = fpm//NL//'implicit-external = false' + fpm = fpm//NL//'source-form = "free"' + fpm = fpm//NL//'[packages.M_CLI2.sources]' + fpm = fpm//NL//'[packages.M_CLI2.sources.src_1]' + fpm = fpm//NL//'file-name = "build/dependencies/M_CLI2/src/M_CLI2.F90"' + fpm = fpm//NL//'digest = -6169834068995303802' + fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"' + fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"' + fpm = fpm//NL//'modules-provided = "m_cli2"' + fpm = fpm//NL//'parent-modules = [ ]' + fpm = fpm//NL//'modules-used = [ ]' + fpm = fpm//NL//'include-dependencies = [ ]' + fpm = fpm//NL//'link-libraries = [ ]' + fpm = fpm//NL//'[packages.jonquil]' + fpm = fpm//NL//'name = "jonquil"' + fpm = fpm//NL//'version = "0.8.0"' + fpm = fpm//NL//'module-naming = false' + fpm = fpm//NL//'module-prefix = ""' + fpm = fpm//NL//'[packages.jonquil.fortran]' + fpm = fpm//NL//'implicit-typing = false' + fpm = fpm//NL//'implicit-external = false' + fpm = fpm//NL//'source-form = "free"' + fpm = fpm//NL//'[packages.jonquil.sources]' + fpm = fpm//NL//'[packages.jonquil.sources.src_1]' + fpm = fpm//NL//'file-name = "build/dependencies/jonquil/src/jonquil.f90"' + fpm = fpm//NL//'digest = 5552073973512025871' + fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"' + fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"' + fpm = fpm//NL//'modules-provided = "jonquil"' + fpm = fpm//NL//'parent-modules = [ ]' + fpm = fpm//NL//'modules-used = [ "tomlf", "tomlf_type", "jonquil_ser" ]' + fpm = fpm//NL//'include-dependencies = [ ]' + fpm = fpm//NL//'link-libraries = [ ]' + fpm = fpm//NL//'[packages.jonquil.sources.src_2]' + fpm = fpm//NL//'file-name = "build/dependencies/jonquil/src/jonquil/version.f90"' + fpm = fpm//NL//'digest = -2934903401983932826' + fpm = fpm//NL//'unit-scope = "FPM_SCOPE_LIB"' + fpm = fpm//NL//'unit-type = "FPM_UNIT_MODULE"' + fpm = fpm//NL//'modules-provided = "jonquil_version"' + fpm = fpm//NL//'parent-modules = [ ]' + fpm = fpm//NL//'modules-used = [ ]' + fpm = fpm//NL//'include-dependencies = [ ]' + fpm = fpm//NL//'link-libraries = [ ]' + + call string_to_toml(fpm, table) + + end subroutine fpm_081_table + + !> Convert a character string to a TOML table + subroutine string_to_toml(string, table) + + !> The input TOML as a string + character(*), intent(in) :: string + + !> The TOML table + type(toml_table), allocatable, intent(out) :: table + + integer :: iunit + + ! Write + open(newunit=iunit,form='formatted',status='scratch',action='readwrite') + + !> Dump to scratch file + write(iunit,*) string + + !> Load from scratch file + rewind(iunit) + call toml_load(table, iunit) + + close(iunit) + + end subroutine string_to_toml + + subroutine fpm_model_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + type(fpm_model_t) :: model + type(toml_table), allocatable :: table + + call model%test_serialization('fpm_model_t: default object', error) + if (allocated(error)) return + + !> Now init form fpm 0.8.1 table + call fpm_081_table(table) + + call model%load(table, error) + if (allocated(error)) then + call fatal_error(error, 'fpm_model_t: cannot load model from fpm v0.8.1 TOML') + return + end if + + call model%test_serialization('fpm_model_t: fpm v0.8.1 model test', error) + + end subroutine fpm_model_roundtrip + + + subroutine fpm_model_invalid(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(fpm_model_t) :: model + type(toml_table), allocatable :: table + character(len=:), allocatable :: fpm + + allocate(character(len=0) :: fpm) + fpm = fpm//NL//'package-name = "fpm"' + fpm = fpm//NL//'fortran-flags = " -Wall -Wextra -fPIC -fmax-errors=1 -g "' + fpm = fpm//NL//'c-flags = ""' + fpm = fpm//NL//'cxx-flags = ""' + fpm = fpm//NL//'link-flags = ""' + fpm = fpm//NL//'build-prefix = "build/gfortran"' + fpm = fpm//NL//'include-dirs = [ ]' + fpm = fpm//NL//'link-libraries = [ ]' + fpm = fpm//NL//'external-modules = "" ' + fpm = fpm//NL//'include-tests = "my_test"' ! not a boolean + fpm = fpm//NL//'module-naming = false' + fpm = fpm//NL//'module-prefix = ""' + + call string_to_toml(fpm, table) + call model%load(table,error) + + end subroutine fpm_model_invalid + + subroutine install_config_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(install_config_t) :: install + + integer :: loop + + do loop=1,2 + + install % library = mod(loop,2)==0 + + ! Test full object + call install%test_serialization('install_config_roundtrip',error) + if (allocated(error)) return + + end do + + end subroutine install_config_roundtrip + + subroutine fortran_features_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(fortran_config_t) :: fortran + + fortran%implicit_external = .true. + fortran%implicit_typing = .false. + fortran%source_form = 'free' + + call fortran%test_serialization('fortran_features_roundtrip',error) + if (allocated(error)) return + + deallocate(fortran%source_form) + call fortran%test_serialization('fortran_features_roundtrip 2',error) + + end subroutine fortran_features_roundtrip + + subroutine library_config_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(library_config_t) :: lib + + lib%source_dir = 'lib' + lib%include_dir = [string_t('a'),string_t('b')] + + call lib%test_serialization('library_config: 1',error) + if (allocated(error)) return + + lib%build_script = 'install.sh' + + call lib%test_serialization('library_config: 2',error) + if (allocated(error)) return + + deallocate(lib%include_dir) + call lib%test_serialization('library_config: 3',error) + + end subroutine library_config_roundtrip + + + subroutine executable_config_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(executable_config_t) :: exe + type(dependency_config_t) :: dep + + exe%name = "my_executable" + exe%source_dir = 'app' + + call exe%test_serialization('executable_config: 1',error) + if (allocated(error)) return + + exe%main = 'main_program.F90' + + call exe%test_serialization('executable_config: 2',error) + if (allocated(error)) return + + exe%link = [string_t('netcdf'),string_t('hdf5')] + call exe%test_serialization('executable_config: 3',error) + + call dependency_destroy(dep) + + dep%name = "M_CLI2" + dep%path = "~/./some/dummy/path" + dep%namespace = "urbanjost" + allocate(dep%requested_version) + call new_version(dep%requested_version, "3.2.0",error); if (allocated(error)) return + + allocate(dep%git) + dep%git = git_target_revision(url="https://github.com/urbanjost/M_CLI2.git", & + sha1="7264878cdb1baff7323cc48596d829ccfe7751b8") + + allocate(exe%dependency(1),source=dep) + call exe%test_serialization('executable_config: 4',error) + + end subroutine executable_config_roundtrip + + + subroutine preprocess_config_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(preprocess_config_t) :: prep + + prep%name = "preprocessor config" + prep%macros = [string_t('Whatever'),string_t('FPM_BOOTSTRAP')] + + call prep%test_serialization('preprocess_config', error) + + end subroutine preprocess_config_roundtrip + + subroutine file_scope_flag_roundtrip(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(file_scope_flag) :: ff + + call ff%test_serialization('file_scope_flag: empty', error) + if (allocated(error)) return + + ff%file_name = "preprocessor config" + ff%flags = "-1 -f -2 -g" + + call ff%test_serialization('file_scope_flag: non-empty', error) + + end subroutine file_scope_flag_roundtrip end module test_toml