From 260a09255d6652ed4d0f8d03ed97735013927d15 Mon Sep 17 00:00:00 2001 From: "init current directory[i]" Date: Sun, 20 Sep 2020 15:46:24 -0400 Subject: CLI interface to further development of subcommands pass settings extended help for each subcommand change commit= to ver= in fpm.toml ver= does not work either no specific version as ver= does not work for M_CLI2 add test program for CLI fix fpm.toml version reference remove --usage references from help text comment and clarify CLI unit test basic RUN subcommand restore fpm_command_line.f90 changes remove non-zero STOP for no parameters for testing spelling error in help use basename to make sure name is a simple name remove dash from executable name to see if it clears MSWindows build error try one more like previous build to clear error one more time like previous version to see if build error clears on MSWindows debug run to see PC variables make quoting of -- ARGS values less platform dependent and change test accordingly change .gitignore --- fpm/.gitignore | 1 + fpm/app/main.f90 | 8 +- fpm/fpm.toml | 13 +- fpm/src/fpm.f90 | 120 ++++- fpm/src/fpm_command_line.f90 | 375 ++++++++++++--- fpm/test/cli_test/cli_test.f90 | 232 +++++++++ fpm/test/fpm_test/main.f90 | 94 ++++ fpm/test/fpm_test/test_manifest.f90 | 749 ++++++++++++++++++++++++++++++ fpm/test/fpm_test/test_source_parsing.f90 | 695 +++++++++++++++++++++++++++ fpm/test/fpm_test/test_toml.f90 | 107 +++++ fpm/test/fpm_test/testsuite.f90 | 286 ++++++++++++ fpm/test/main.f90 | 94 ---- fpm/test/test_manifest.f90 | 749 ------------------------------ fpm/test/test_source_parsing.f90 | 695 --------------------------- fpm/test/test_toml.f90 | 107 ----- fpm/test/testsuite.f90 | 286 ------------ 16 files changed, 2598 insertions(+), 2013 deletions(-) create mode 100644 fpm/test/cli_test/cli_test.f90 create mode 100644 fpm/test/fpm_test/main.f90 create mode 100644 fpm/test/fpm_test/test_manifest.f90 create mode 100644 fpm/test/fpm_test/test_source_parsing.f90 create mode 100644 fpm/test/fpm_test/test_toml.f90 create mode 100644 fpm/test/fpm_test/testsuite.f90 delete mode 100644 fpm/test/main.f90 delete mode 100644 fpm/test/test_manifest.f90 delete mode 100644 fpm/test/test_source_parsing.f90 delete mode 100644 fpm/test/test_toml.f90 delete mode 100644 fpm/test/testsuite.f90 diff --git a/fpm/.gitignore b/fpm/.gitignore index a007fea..c602557 100644 --- a/fpm/.gitignore +++ b/fpm/.gitignore @@ -1 +1,2 @@ build/* +*/FODDER/* diff --git a/fpm/app/main.f90 b/fpm/app/main.f90 index c7f9786..be9b805 100644 --- a/fpm/app/main.f90 +++ b/fpm/app/main.f90 @@ -17,15 +17,15 @@ call get_command_line_settings(cmd_settings) select type(settings=>cmd_settings) type is (fpm_new_settings) - call cmd_new() + call cmd_new(settings) type is (fpm_build_settings) call cmd_build(settings) type is (fpm_run_settings) - call cmd_run() + call cmd_run(settings) type is (fpm_test_settings) - call cmd_test() + call cmd_test(settings) type is (fpm_install_settings) - call cmd_install() + call cmd_install(settings) end select end program main diff --git a/fpm/fpm.toml b/fpm/fpm.toml index d29994a..ee2e714 100644 --- a/fpm/fpm.toml +++ b/fpm/fpm.toml @@ -10,7 +10,18 @@ copyright = "2020 fpm contributors" git = "https://github.com/toml-f/toml-f" tag = "v0.2" +[dependencies.M_CLI2] +git = "https://github.com/urbanjost/M_CLI2.git" +rev = "5c7df1267c918ec2b1b8e2c6a0ac000367b562cf" + +[[test]] +name = "cli-test" +source-dir = "test/cli_test" +main = "cli_test.f90" + [[test]] name = "fpm-test" -source-dir = "test" +source-dir = "test/fpm_test" main = "main.f90" + + diff --git a/fpm/src/fpm.f90 b/fpm/src/fpm.f90 index b57a713..1975d28 100644 --- a/fpm/src/fpm.f90 +++ b/fpm/src/fpm.f90 @@ -2,15 +2,19 @@ module fpm use fpm_strings, only: string_t, str_ends_with use fpm_backend, only: build_package -use fpm_command_line, only: fpm_build_settings +use fpm_command_line, only: fpm_build_settings, fpm_new_settings, & + fpm_run_settings, fpm_install_settings, fpm_test_settings use fpm_environment, only: run, get_os_type, OS_LINUX, OS_MACOS, OS_WINDOWS -use fpm_filesystem, only: join_path, number_of_rows, list_files, exists +use fpm_filesystem, only: join_path, number_of_rows, list_files, exists, basename use fpm_model, only: srcfile_ptr, srcfile_t, fpm_model_t use fpm_sources, only: add_executable_sources, add_sources_from_dir, & resolve_module_dependencies use fpm_manifest, only : get_package_data, default_executable, & default_library, package_t use fpm_error, only : error_t +use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, & + & stdout=>output_unit, & + & stderr=>error_unit implicit none private public :: cmd_build, cmd_install, cmd_new, cmd_run, cmd_test @@ -30,10 +34,23 @@ subroutine build_model(model, settings, package, error) ! #TODO: Choose flags and output directory based on cli settings & manifest inputs model%fortran_compiler = 'gfortran' - model%output_directory = 'build/gfortran_debug' - model%fortran_compile_flags = ' -Wall -Wextra -Wimplicit-interface -fPIC -fmax-errors=1 -g '// & - '-fbounds-check -fcheck-array-temporaries -fbacktrace '// & - '-J'//join_path(model%output_directory,model%package_name) + + if(settings%release)then + model%output_directory = 'build/gfortran_release' + model%fortran_compile_flags=' & + & -O3 & + & -Wimplicit-interface & + & -fPIC & + & -fmax-errors=1 & + & -ffast-math & + & -funroll-loops ' // & + & '-J'//join_path(model%output_directory,model%package_name) + else + model%output_directory = 'build/gfortran_debug' + model%fortran_compile_flags = ' -Wall -Wextra -Wimplicit-interface -fPIC -fmax-errors=1 -g '// & + '-fbounds-check -fcheck-array-temporaries -fbacktrace '// & + '-J'//join_path(model%output_directory,model%package_name) + endif model%link_flags = '' ! Add sources from executable directories @@ -41,7 +58,7 @@ subroutine build_model(model, settings, package, error) call add_executable_sources(model%sources, package%executable, & is_test=.false., error=error) - + if (allocated(error)) then return end if @@ -111,24 +128,91 @@ call build_package(model) end subroutine -subroutine cmd_install() +subroutine cmd_install(settings) +type(fpm_install_settings), intent(in) :: settings print *, "fpm error: 'fpm install' not implemented." error stop 1 -end subroutine - -subroutine cmd_new() - print *, "fpm error: 'fpm new' not implemented." - error stop 1 -end subroutine +end subroutine cmd_install + +subroutine cmd_new(settings) ! --with-executable F --with-test F ' +type(fpm_new_settings), intent(in) :: settings +character(len=:),allocatable :: message(:) +character(len=:),allocatable :: bname + bname=basename(settings%name) !! new basename(dirname) if full paths are allowed ??? + + message=[character(len=80) :: & ! create fpm.toml + &'name = "'//bname//'" ', & + &'version = "0.1.0" ', & + &'license = "license" ', & + &'author = "Jane Doe" ', & + &'maintainer = "jane.doe@example.com" ', & + &'copyright = "2020 Jane Doe" ', & + &' ', & + &'[library] ', & + &'source-dir="src" ', & + &''] + + if(settings%with_test)then + message=[character(len=80) :: message, & ! create next section of fpm.toml + &'[[test]] ', & + &'name="runTests" ', & + &'source-dir="test" ', & + &'main="main.f90" ', & + &''] + endif + + if(settings%with_executable)then + message=[character(len=80) :: message, & ! create next section of fpm.toml + &'[[executable]] ', & + &'name="'//bname//'" ', & + &'source-dir="app" ', & + &'main="main.f90" ', & + &''] + endif + + write(*,'(a)')message + print *, "fpm error: 'fpm new' not implemented." + error stop 1 +end subroutine cmd_new + +subroutine cmd_run(settings) + type(fpm_run_settings), intent(in) :: settings + integer :: i + + write(*,*)'RELEASE=',settings%release + if(size(settings%name).eq.0)then + write(*,*)'RUN DEFAULTS with arguments ['//settings%args//']' + else + do i=1,size(settings%name) + write(*,*)'RUN:'//trim(settings%name(i))//' with arguments ['//settings%args//']' + enddo + endif -subroutine cmd_run() print *, "fpm error: 'fpm run' not implemented." error stop 1 -end subroutine -subroutine cmd_test() +end subroutine cmd_run + +subroutine cmd_test(settings) + type(fpm_test_settings), intent(in) :: settings + character(len=:),allocatable :: release_name + integer :: i + + !! looks like would get this from model when cmd_test is implimented + release_name=trim(merge('gfortran_release','gfortran_debug ',settings%release)) + + write(*,*)'RELEASE=',settings%release,' RELEASE_NAME=',release_name,' ARGS=',settings%args + if( size(settings%name) .gt.0 )then + write(*,*)'RUN THESE:' + do i=1,size(settings%name) + write(*,*)'RUN:'//trim(settings%name(i))//' with arguments ['//settings%args//']' + enddo + else + write(*,*)'RUN DEFAULTS: with arguments ['//settings%args//']' + endif + print *, "fpm error: 'fpm test' not implemented." error stop 1 -end subroutine +end subroutine cmd_test end module fpm diff --git a/fpm/src/fpm_command_line.f90 b/fpm/src/fpm_command_line.f90 index 406b58e..84b4693 100644 --- a/fpm/src/fpm_command_line.f90 +++ b/fpm/src/fpm_command_line.f90 @@ -1,7 +1,14 @@ +!! new are full pathnames allowed? Is more than one pathname allowed? +!! fpm --search search keywords, descriptions, names of fpm(1) package registry +!! install not sure what it is supposed to do. Install files in build/ to a user-specified area? module fpm_command_line use fpm_environment, only: get_os_type, & OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, & OS_CYGWIN, OS_SOLARIS, OS_FREEBSD + use M_CLI2, only : set_args, lget, unnamed, remaining + use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, & + & stdout=>output_unit, & + & stderr=>error_unit implicit none private @@ -16,87 +23,337 @@ module fpm_command_line type, abstract :: fpm_cmd_settings end type - type, extends(fpm_cmd_settings) :: fpm_new_settings + integer,parameter :: ibug=4096 + type, extends(fpm_cmd_settings) :: fpm_new_settings + character(len=:),allocatable :: name + logical :: with_executable=.false. + logical :: with_test=.false. end type - type, extends(fpm_cmd_settings) :: fpm_build_settings + type, extends(fpm_cmd_settings) :: fpm_build_settings + logical :: release=.false. end type - type, extends(fpm_cmd_settings) :: fpm_run_settings + type, extends(fpm_cmd_settings) :: fpm_run_settings + character(len=ibug),allocatable :: name(:) + logical :: release=.false. + logical :: list=.false. + character(len=:),allocatable :: args end type - type, extends(fpm_cmd_settings) :: fpm_test_settings + type, extends(fpm_cmd_settings) :: fpm_test_settings + character(len=ibug),allocatable :: name(:) + logical :: release=.false. + character(len=:),allocatable :: args end type - type, extends(fpm_cmd_settings) :: fpm_install_settings + type, extends(fpm_cmd_settings) :: fpm_install_settings end type + character(len=:),allocatable :: name + character(len=ibug),allocatable :: names(:) + contains subroutine get_command_line_settings(cmd_settings) class(fpm_cmd_settings), allocatable, intent(out) :: cmd_settings - character(len=100) :: cmdarg - - if (command_argument_count() == 0) then - call print_help() - else if (command_argument_count() == 1) then - call get_command_argument(1, cmdarg) - select case(trim(cmdarg)) - case("new") - allocate(fpm_new_settings :: cmd_settings) - case("build") - allocate(fpm_build_settings :: cmd_settings) - case("run") - allocate(fpm_run_settings :: cmd_settings) - case("test") - allocate(fpm_test_settings :: cmd_settings) - case("install") - allocate(fpm_install_settings :: cmd_settings) - case default - print *, "fpm error: No such command " // trim(cmdarg) - error stop 1 - end select - else - print *, "Too many arguments" - error stop 1 - end if - end subroutine + character(len=4096) :: cmdarg + integer :: i + character(len=:), allocatable :: help_text(:), version_text(:) + + ! text for --version switch, + version_text = [character(len=80) :: & + & 'VERSION: 0.1.0, Pre-alpha', & + & 'PROGRAM: fpm(1)', & + & 'DESCRIPTION: A Fortran package manager and build system', & + & 'HOME PAGE: https://github.com/fortran-lang/fpm', & + & 'LICENSE: MIT', & + & ''] + ! find the subcommand name by looking for first word on command not starting with dash + cmdarg = '' + do i = 1, command_argument_count() + call get_command_argument(i, cmdarg) + if(adjustl(cmdarg(1:1)) .ne. '-')exit + enddo + + ! now set subcommand-specific help text and process commandline arguments. Then call subcommand routine + select case(trim(cmdarg)) + + case('run') + help_text=[character(len=80) :: & + 'NAME ', & + ' run(1) - the fpm(1) subcommand to run project applications ', & + ' ', & + 'SYNOPSIS ', & + ' fpm run [NAME(s)] [--release] [-- ARGS] ', & + ' ', & + ' fpm run --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' Run applications you have built in your fpm(1) project. ', & + ' ', & + 'OPTIONS ', & + ' NAME(s) optional list of specific names to execute. ', & + ' The default is to run all the applications in app/ ', & + ' or the programs listed in the "fpm.toml" file. ', & + ' --release selects the optimized build instead of the debug ', & + ' build. ', & + ' -- ARGS optional arguments to pass to the program(s). ', & + ' The same arguments are passed to all names ', & + ' specified. ', & + ' ', & + 'EXAMPLES ', & + 'run fpm(1) project applications ', & + ' ', & + ' # run default programs in /app or as specified in "fpm.toml" ', & + ' fpm run ', & + ' ', & + ' # run a specific program and pass arguments to the command ', & + ' fpm run mytest -- -x 10 -y 20 -title "my title line" ', & + ' ', & + ' # production version of two applications ', & + ' fpm run tst1 test2 -release ', & + '' ] + call set_args('--list F --release F --',help_text,version_text) + + if( size(unnamed) .gt. 1 )then + names=unnamed(2:) + else + names=[character(len=len(names)) :: ] + endif - subroutine print_help() - print *, 'fpm - A Fortran package manager and build system' + allocate(fpm_run_settings :: cmd_settings) + cmd_settings=fpm_run_settings( name=names, release=lget('release'), args=remaining ) - select case (get_os_type()) - case (OS_UNKNOWN) - print *, 'OS Type: Unknown' + case('build') + help_text=[character(len=80) :: & + 'NAME ', & + ' build(1) - the fpm(1) subcommand to build a project ', & + 'SYNOPSIS ', & + ' fpm build [--release] build ', & + ' fpm build --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' Finds the Fortran source files in app/, test/, and ', & + ' src/ by default; determines the dependencies ', & + ' between the files and rebuilds unbuilt or changed ', & + ' files. The results are placed in the build/ directory. ', & + ' ', & + ' Non-default pathnames are used if specified in the ', & + ' "fpm.toml" file. ', & + ' ', & + ' Remote dependencies are satisfied as well if specified ', & + ' in the "fpm.toml" file. ', & + ' ', & + 'OPTIONS ', & + ' --release build in build/*_release instead of ', & + ' build/*_debug/ with high optimization ', & + ' instead of full debug options. ', & + ' --help print this help and exit ', & + ' --version print program version information and exit ', & + ' ', & + 'EXAMPLES ', & + ' Sample commands: ', & + ' ', & + ' fpm build # build with debug options ', & + ' fpm build -release # build with high optimization ', & + '' ] + call set_args( '--release F --',help_text,version_text ) - case (OS_LINUX) - print *, 'OS Type: Linux' + allocate( fpm_build_settings :: cmd_settings ) + cmd_settings=fpm_build_settings( release=lget('release') ) - case (OS_MACOS) - print *, 'OS Type: macOS' + case('new') + help_text=[character(len=80) :: & + 'NAME ', & + ' new(1) - the fpm(1) subcommand to initialize a new project ', & + 'SYNOPSIS ', & + ' fpm new NAME [--with-executable] [--with-test] ', & + ' ', & + ' fpm new --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' Create a new programming project in a new directory ', & + ' ', & + ' The "new" subcommand creates a directory and runs the command ', & + ' "git init" in that directory and makes an example "fpm.toml" ', & + ' file, a src/ directory, and optionally a test/ and app/ ', & + ' directory with trivial example Fortran source files. ', & + ' ', & + ' Remember to update the information in the sample "fpm.toml" ', & + ' file with such information as your name and e-mail address. ', & + ' ', & + 'EXAMPLES ', & + ' Sample use ', & + ' ', & + ' # create new project directory and seed it ', & + ' fpm new myproject ', & + ' # Enter the new directory ', & + ' cd myproject ', & + ' # and run commands such as ', & + ' fpm build ', & + ' fpm run # if you selected --with-executable ', & + ' fpm test # if you selected --with-test ', & + ' ', & + '' ] + call set_args(' --with-executable F --with-test F ', help_text, version_text) + select case(size(unnamed)) + case(1) + write(stderr,'(*(g0))')'ERROR: directory name required' + write(stderr,'(*(g0))')' usage: fpm new NAME [--with-executable] [--with-test]' + stop 1 + case(2) + name=trim(unnamed(2)) + case default + write(stderr,'(*(g0))')'ERROR: only one directory name allowed' + write(stderr,'(*(g0))')' usage: fpm new NAME [--with-executable] [--with-test]' + stop 2 + end select - case (OS_WINDOWS) - print *, 'OS Type: Windows' + allocate(fpm_new_settings :: cmd_settings) + cmd_settings=fpm_new_settings(name=name, with_executable=lget('with-executable'), with_test=lget('with-test') ) - case (OS_CYGWIN) - print *, 'OS Type: Cygwin' + case('install') + help_text=[character(len=80) :: & + ' fpm(1) subcommand "install" ', & + ' ', & + ' Usage: fpm install NAME ', & + '' ] + call set_args('--release F ', help_text, version_text) + + allocate(fpm_install_settings :: cmd_settings) + + case('test') + help_text=[character(len=80) :: & + 'NAME ', & + ' test(1) - the fpm(1) subcommand to run project tests ', & + ' ', & + 'SYNOPSIS ', & + ' fpm test [NAME(s)] [--release] [-- ARGS] ', & + ' ', & + ' fpm test --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' Run applications you have built to test your project. ', & + ' ', & + 'OPTIONS ', & + ' NAME(s) optional list of specific test names to execute. ', & + ' The default is to run all the tests in test/ ', & + ' or the tests listed in the "fpm.toml" file. ', & + ' --release selects the optimized build instead of the debug ', & + ' build. ', & + ' -- ARGS optional arguments to pass to the test program(s). ', & + ' The same arguments are passed to all test names ', & + ' specified. ', & + ' ', & + 'EXAMPLES ', & + 'run tests ', & + ' ', & + ' # run default tests in /test or as specified in "fpm.toml" ', & + ' fpm test ', & + ' ', & + ' # run a specific test and pass arguments to the command ', & + ' fpm test mytest -- -x 10 -y 20 -title "my title line" ', & + ' ', & + ' fpm test tst1 test2 -release # production version of two tests', & + ' ', & + '' ] + call set_args(' -release F --', help_text, version_text) + + if( size(unnamed) .gt. 1 )then + names=unnamed(2:) + else + names=[character(len=len(names)) :: ] + endif + + allocate(fpm_test_settings :: cmd_settings) + cmd_settings=fpm_test_settings(name=names, release=lget('release'), args=remaining ) + + case default + help_text=[character(len=80) :: & + 'NAME', & + ' fpm(1) - A Fortran package manager and build system', & + 'OS TYPE' ] + select case (get_os_type()) + case (OS_LINUX); help_text=[character(len=80) :: help_text, " Linux" ] + case (OS_MACOS); help_text=[character(len=80) :: help_text, " macOS" ] + case (OS_WINDOWS); help_text=[character(len=80) :: help_text, " Windows" ] + case (OS_CYGWIN); help_text=[character(len=80) :: help_text, " Cygwin" ] + case (OS_SOLARIS); help_text=[character(len=80) :: help_text, " Solaris" ] + case (OS_FREEBSD); help_text=[character(len=80) :: help_text, " FreeBSD" ] + case (OS_UNKNOWN); help_text=[character(len=80) :: help_text, " Unknown" ] + case default ; help_text=[character(len=80) :: help_text, " UNKNOWN" ] + end select + help_text=[character(len=80) :: help_text, & + 'SYNTAX ', & + ' fpm SUBCOMMAND [SUBCOMMAND_OPTIONS] ', & + ' ', & + ' fpm --help|--version ', & + ' ', & + 'DESCRIPTION ', & + ' fpm is a package manager that helps you create Fortran projects that are ', & + ' optionally dependent on multiple files and other fpm(1) packages. ', & + ' ', & + ' Most significantly fpm(1) lets you pull upon other fpm(1) packages in ', & + ' distributed git(1) repositories as if the packages were a basic part ', & + ' of your default programming environment, as well as letting you share ', & + ' your projects with others in a similar manner. ', & + ' ', & + ' See the fpm(1) repository for a listing of such available projects. ', & + ' ', & + ' All output goes into the directory "build/". ', & + ' ', & + 'SUBCOMMANDS ', & + ' Valid fpm subcommands are: ', & + ' ', & + ' build [--release] Compile the packages into the "build/" directory. ', & + ' new NAME [--with-executable] [--with-test] ', & + ' Create a new Fortran package directory ', & + ' with sample files ', & + ' run [NAME(s)] [--release] [--list] [-- ARGS] ', & + ' Run the local package binaries. defaults to all ', & + ' binaries for that release. ', & + ' test [NAME(s)] [--release] [-- ARGS] ', & + ' Run the tests ', & + 'SUBCOMMAND OPTIONS ', & + ' --release Builds or runs in release mode (versus debug mode). fpm(1) ', & + ' Defaults to using common compiler debug flags and building ', & + ' in "build/gfortran_debug/". When this flag is present build ', & + ' output goes into "build/gfortran_release/" and common ', & + ' compiler optimization flags are used. ', & + ' --list list candidates instead of building or running them ', & + ' -- ARGS Arguments to pass to executables/tests ', & + ' --help Show this help text and exit. Valid for all subcommands. ', & + ' --version Show version information and exit. Valid for all subcommands.', & + 'EXAMPLES ', & + ' sample commands: ', & + ' ', & + ' fpm build ', & + ' fpm test ', & + ' fpm run ', & + ' fpm new --help ', & + ' fpm new mypackage --with-executable --with-test ', & + ' fpm run myprogram --release -- -x 10 -y 20 --title "my title" ', & + 'SEE ALSO ', & + ' For examples and documentation see https://github.com/fortran-lang/fpm ', & + ''] - case (OS_SOLARIS) - print *, 'OS Type: Solaris' + call set_args(' ', help_text, version_text) + ! Note: will not get here if --version or --usage or --help is present on commandline + if(len_trim(cmdarg).eq.0)then + write(stderr,'(*(a))')'ERROR: missing subcommand' + else + write(stderr,'(*(a))')'ERROR: unknown subcommand [', trim(cmdarg), ']' + endif + help_text=[character(len=80) :: & + 'USAGE: fpm [ SUBCOMMAND [SUBCOMMAND_OPTIONS] ] | [|--help|--version] ', & + ' Enter "fpm --help" for more information ', & + '' ] + write(stderr,'(g0)')(trim(help_text(i)), i=1, size(help_text) ) + !!stop 3 ! causes github site tests to fail + stop - case (OS_FREEBSD) - print *, 'OS Type: FreeBSD' end select + end subroutine get_command_line_settings - print * - print *, 'Usage:' - print *, ' fpm [COMMAND]' - print * - print *, 'Valid fpm commands are:' - print *, ' build Compile the current package' - print *, ' install Install a Fortran binary or library (not implemented)' - print *, ' new Create a new Fortran package (not implemented)' - print *, ' run Run a binary of the local package (not implemented)' - print *, ' test Run the tests (not implemented)' - end subroutine end module fpm_command_line diff --git a/fpm/test/cli_test/cli_test.f90 b/fpm/test/cli_test/cli_test.f90 new file mode 100644 index 0000000..ab032f5 --- /dev/null +++ b/fpm/test/cli_test/cli_test.f90 @@ -0,0 +1,232 @@ +program main + +! for each set of command options, call this command recursively which will print the resulting parameters with a +! given test command CMD from the TEST() array. +! +! Then read the expected values as a NAMELIST group from the test array and compare the expected +! results with the actual results. +! +! the PARSE() subroutine is a copy of the app/main.f90 program except it creates and writes a NAMELIST file instead +! of actually calling the subcommands. +! +! The program will exit with a non-zero status if any of the tests fail + +use, intrinsic :: iso_fortran_env, only : compiler_version, compiler_options +implicit none + +! convenient arbitrary sizes for test + +! assuming no name over 15 characters to make output have shorter lines +character(len=15),allocatable :: name(:),act_name(:) ; namelist/act_cli/act_name +integer,parameter :: max_names=10 + +character(len=:),allocatable :: command +character(len=:),allocatable :: cmd +integer :: cstat, estat +integer :: act_cstat, act_estat +integer :: i, ios +logical :: w_e,act_w_e ; namelist/act_cli/act_w_e +logical :: w_t,act_w_t ; namelist/act_cli/act_w_t + +logical :: release,act_release ; namelist/act_cli/act_release +character(len=:),allocatable :: args,act_args ; namelist/act_cli/act_args +namelist/expected/cmd,cstat,estat,w_e,w_t,name,release,args +integer :: lun +logical,allocatable :: tally(:) +logical,allocatable :: subtally(:) +character(len=256) :: message + +! table of arguments to pass to program and expected non-default values for that execution in NAMELIST group format +character(len=*),parameter :: tests(*)= [ character(len=256) :: & + +'CMD="new", ESTAT=1,', & +'CMD="new -unknown", ESTAT=2,', & +'CMD="new my_project another yet_another -with-test", ESTAT=2,', & +'CMD="new my_project --with-executable", W_E=T, NAME="my_project",', & +'CMD="new my_project --with-executable -with-test", W_E=T,W_T=T, NAME="my_project",', & +'CMD="new my_project -with-test", W_T=T, NAME="my_project",', & +'CMD="new my_project", NAME="my_project",', & + +'CMD="run", ', & +'CMD="run my_project", NAME="my_project", ', & +'CMD="run proj1 p2 project3", NAME="proj1","p2","project3", ', & +'CMD="run proj1 p2 project3 --release", NAME="proj1","p2","project3",RELEASE=T,', & +'CMD="run proj1 p2 project3 --release -- arg1 -x ""and a long one""", & + &NAME="proj1","p2","project3",RELEASE=T ARGS="""arg1"" -x ""and a long one""", ', & + +'CMD="test", ', & +'CMD="test my_project", NAME="my_project", ', & +'CMD="test proj1 p2 project3", NAME="proj1","p2","project3", ', & +'CMD="test proj1 p2 project3 --release", NAME="proj1","p2","project3",RELEASE=T,', & +'CMD="test proj1 p2 project3 --release -- arg1 -x ""and a long one""", & + &NAME="proj1","p2","project3",RELEASE=T ARGS="""arg1"" -x ""and a long one""", ', & + +'CMD="build", NAME= RELEASE=F,ARGS="",', & +'CMD="build --release", NAME= RELEASE=T,ARGS="",', & +' ' ] +character(len=256) :: readme(3) + +readme(1)='&EXPECTED' ! top and bottom line for a NAMELIST group read from TEST() used to set the expected values +readme(3)=' /' +tally=[logical ::] ! an array that tabulates the command test results as pass or fail. + +if(command_argument_count().eq.0)then ! assume if called with no arguments to do the tests. This means you cannot + ! have a test of no parameters. Could improve on this. + ! if called with parameters assume this is a test and call the routine to + ! parse the resulting values after calling the CLI command line parser + ! and write the NAMELIST group so it can be read and tested against the + ! expected results + write(*,*)'start tests of the CLI command line parser' + command=repeat(' ',4096) + call get_command_argument(0,command) + command=trim(command) + write(*,*)'command=',command + + do i=1,size(tests) + if(tests(i).eq.' ')then + open(file='_test_cli',newunit=lun,delim='quote') + close(unit=lun,status='delete') + exit + endif + ! blank out name group EXPECTED + name=[(repeat(' ',len(name)),i=1,max_names)] ! the words on the command line sans the subcommand name + release=.false. ! --release + w_e=.false. ! --with-executable + w_t=.false. ! --with-test + args=repeat(' ',132) ! -- ARGS + cmd=repeat(' ',132) ! the command line arguments to test + cstat=0 ! status values from EXECUTE_COMMAND_LINE() + estat=0 + readme(2)=' '//tests(i) ! select command options to test for CMD and set nondefault expected values + read(readme,nml=expected) + + write(*,'(*(g0))')'START: TEST ',i,' CMD=',trim(cmd) + ! call this program which will crack command line and write results to scratch file _test_cli + call execute_command_line(command//' '//trim(cmd),cmdstat=act_cstat,exitstat=act_estat) + if(cstat.eq.act_cstat.and.estat.eq.act_estat)then + if(estat.eq.0)then + open(file='_test_cli',newunit=lun,delim='quote') + act_name=[(repeat(' ',len(act_name)),i=1,max_names)] + act_release=.false. + act_w_e=.false. + act_w_t=.false. + act_args=repeat(' ',132) + read(lun,nml=act_cli,iostat=ios,iomsg=message) + if(ios.ne.0)then + write(*,'(a)')'ERROR:',trim(message) + endif + close(unit=lun) + ! compare results to expected values + subtally=[logical ::] + call test_test('NAME',all(act_name.eq.name)) + call test_test('RELEASE',act_release.eqv.release) + call test_test('WITH_EXPECTED',act_w_e.eqv.w_e) + call test_test('WITH_TESTED',act_w_t.eqv.w_t) + call test_test('WITH_TEST',act_w_t.eqv.w_t) + call test_test('ARGS',act_args.eq.args) + if(all(subtally))then + write(*,'(*(g0))')'PASSED: TEST ',i,' STATUS: expected ',cstat,' ',estat,' actual ',act_cstat,' ',act_estat,& + & ' for [',trim(cmd),']' + tally=[tally,.true.] + else + write(*,'(*(g0))')'FAILED: TEST ',i,' STATUS: expected ',cstat,' ',estat,' actual ',act_cstat,' ',act_estat,& + & ' for [',trim(cmd),']' + print '(4a)', & + 'This file was compiled by ', & + compiler_version(), & + ' using the options ', & + compiler_options() + write(*,nml=act_cli,delim='quote') + tally=[tally,.false.] + endif + else + write(*,'(*(g0))')'PASSED: TEST ',i,' EXPECTED BAD STATUS: expected ',cstat,' ',estat, & + ' actual ',act_cstat,' ',act_estat,' for [',trim(cmd),']' + tally=[tally,.true.] + endif + else + write(*,'(*(g0))')'FAILED: TEST ',i,'BAD STATUS: expected ',cstat,' ',estat,' actual ',act_cstat,' ',act_estat,& + ' for [',trim(cmd),']' + tally=[tally,.false.] + endif + enddo + ! write up total results and if anything failed exit with a non-zero status + write(*,'(*(g0))')'TALLY;',tally + if(all(tally))then + write(*,'(*(g0))')'PASSED: all ',count(tally),' tests passed ' + else + write(*,*)'FAILED: PASSED=',count(tally),' FAILED=',count(.not.tally) + stop 4 + endif +else + ! call this program with arguments + !============================================= + debugit: block + integer :: j, ilen + character(len=256) :: big_argument + write(*,*)'arguments seen directly by program' + do j=1,command_argument_count() + call get_command_argument(number=j,value=big_argument,length=ilen) + write(*,'(*(g0))')j,'[',big_argument(:ilen),']' + enddo + end block debugit + !============================================= + call parse() +endif + +contains + +subroutine test_test(name,tst) +character(len=*) :: name +logical,intent(in) :: tst + !!write(*,'(*(g0,1x))')' SUBTEST ',name,' ',merge('PASSED','FAILED',tst) + subtally=[subtally,tst] +end subroutine test_test + +subroutine parse() +! all the extended types for settings from the main program +use fpm_command_line, only: & + fpm_cmd_settings, & + fpm_new_settings, & + fpm_build_settings, & + fpm_run_settings, & + fpm_test_settings, & + fpm_install_settings, & + get_command_line_settings +use fpm, only: cmd_build, cmd_install, cmd_new, cmd_run, cmd_test +class(fpm_cmd_settings), allocatable :: cmd_settings +! duplicates the calls as seen in the main program for fpm +call get_command_line_settings(cmd_settings) + +allocate (character(len=len(name)) :: act_name(0) ) +act_args='' +act_w_e=.false. +act_w_t=.false. +act_release=.false. + +select type(settings=>cmd_settings) +type is (fpm_new_settings) + act_w_e=settings%with_executable + act_w_t=settings%with_test + act_name=[trim(settings%name)] +type is (fpm_build_settings) + act_release=settings%release +type is (fpm_run_settings) + act_release=settings%release + act_name=settings%name + act_args=settings%args +type is (fpm_test_settings) + act_release=settings%release + act_name=settings%name + act_args=settings%args +type is (fpm_install_settings) +end select + +open(file='_test_cli',newunit=lun,delim='quote') +write(lun,nml=act_cli,delim='quote') +!!write(*,nml=act_cli) +close(unit=lun) + +end subroutine parse + +end program main diff --git a/fpm/test/fpm_test/main.f90 b/fpm/test/fpm_test/main.f90 new file mode 100644 index 0000000..bc8ad29 --- /dev/null +++ b/fpm/test/fpm_test/main.f90 @@ -0,0 +1,94 @@ +!> Driver for unit testing +program fpm_testing + use, intrinsic :: iso_fortran_env, only : error_unit + use testsuite, only : run_testsuite, new_testsuite, testsuite_t, & + & select_suite, run_selected + use test_toml, only : collect_toml + use test_manifest, only : collect_manifest + use test_source_parsing, only : collect_source_parsing + implicit none + integer :: stat, is + character(len=:), allocatable :: suite_name, test_name + type(testsuite_t), allocatable :: testsuite(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuite = [ & + & new_testsuite("fpm_toml", collect_toml), & + & new_testsuite("fpm_manifest", collect_manifest), & + & new_testsuite("fpm_source_parsing", collect_source_parsing) & + & ] + + call get_argument(1, suite_name) + call get_argument(2, test_name) + + if (allocated(suite_name)) then + is = select_suite(testsuite, suite_name) + if (is > 0 .and. is <= size(testsuite)) then + if (allocated(test_name)) then + write(error_unit, fmt) "Suite:", testsuite(is)%name + call run_selected(testsuite(is)%collect, test_name, error_unit, stat) + if (stat < 0) then + error stop 1 + end if + else + write(error_unit, fmt) "Testing:", testsuite(is)%name + call run_testsuite(testsuite(is)%collect, error_unit, stat) + end if + else + write(error_unit, fmt) "Available testsuites" + do is = 1, size(testsuite) + write(error_unit, fmt) "-", testsuite(is)%name + end do + error stop 1 + end if + else + do is = 1, size(testsuite) + write(error_unit, fmt) "Testing:", testsuite(is)%name + call run_testsuite(testsuite(is)%collect, error_unit, stat) + end do + end if + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop 1 + end if + + +contains + + + !> Obtain the command line argument at a given index + subroutine get_argument(idx, arg) + + !> Index of command line argument, range [0:command_argument_count()] + integer, intent(in) :: idx + + !> Command line argument + character(len=:), allocatable, intent(out) :: arg + + integer :: length, stat + + call get_command_argument(idx, length=length, status=stat) + if (stat /= 0) then + return + endif + + allocate(character(len=length) :: arg, stat=stat) + if (stat /= 0) then + return + endif + + if (length > 0) then + call get_command_argument(idx, arg, status=stat) + if (stat /= 0) then + deallocate(arg) + return + end if + end if + + end subroutine get_argument + + +end program fpm_testing diff --git a/fpm/test/fpm_test/test_manifest.f90 b/fpm/test/fpm_test/test_manifest.f90 new file mode 100644 index 0000000..d2dc891 --- /dev/null +++ b/fpm/test/fpm_test/test_manifest.f90 @@ -0,0 +1,749 @@ +!> Define tests for the `fpm_manifest` modules +module test_manifest + use testsuite, only : new_unittest, unittest_t, error_t, test_failed, & + & check_string + use fpm_manifest + implicit none + private + + public :: collect_manifest + + +contains + + + !> Collect all exported unit tests + subroutine collect_manifest(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("valid-manifest", test_valid_manifest), & + & new_unittest("invalid-manifest", test_invalid_manifest, should_fail=.true.), & + & new_unittest("default-library", test_default_library), & + & new_unittest("default-executable", test_default_executable), & + & new_unittest("dependency-empty", test_dependency_empty, should_fail=.true.), & + & new_unittest("dependency-pathtag", test_dependency_pathtag, should_fail=.true.), & + & new_unittest("dependency-gitpath", test_dependency_gitpath, should_fail=.true.), & + & new_unittest("dependency-nourl", test_dependency_nourl, should_fail=.true.), & + & new_unittest("dependency-gitconflict", test_dependency_gitconflict, should_fail=.true.), & + & new_unittest("dependency-wrongkey", test_dependency_wrongkey, should_fail=.true.), & + & new_unittest("dependencies-empty", test_dependencies_empty), & + & new_unittest("dependencies-typeerror", test_dependencies_typeerror, should_fail=.true.), & + & new_unittest("executable-empty", test_executable_empty, should_fail=.true.), & + & new_unittest("executable-typeerror", test_executable_typeerror, should_fail=.true.), & + & new_unittest("executable-noname", test_executable_noname, should_fail=.true.), & + & new_unittest("executable-wrongkey", test_executable_wrongkey, should_fail=.true.), & + & new_unittest("library-empty", test_library_empty), & + & new_unittest("library-wrongkey", test_library_wrongkey, should_fail=.true.), & + & new_unittest("package-simple", test_package_simple), & + & new_unittest("package-empty", test_package_empty, should_fail=.true.), & + & new_unittest("package-typeerror", test_package_typeerror, should_fail=.true.), & + & new_unittest("package-noname", test_package_noname, should_fail=.true.), & + & new_unittest("package-wrongexe", test_package_wrongexe, should_fail=.true.), & + & new_unittest("package-wrongtest", test_package_wrongtest, should_fail=.true.), & + & new_unittest("test-simple", test_test_simple), & + & new_unittest("test-empty", test_test_empty, should_fail=.true.), & + & new_unittest("test-typeerror", test_test_typeerror, should_fail=.true.), & + & new_unittest("test-noname", test_test_noname, should_fail=.true.), & + & new_unittest("test-wrongkey", test_test_wrongkey, should_fail=.true.)] + + end subroutine collect_manifest + + + !> Try to read some unnecessary obscure and convoluted but not invalid package file + subroutine test_valid_manifest(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_t) :: package + character(len=*), parameter :: manifest = 'fpm-valid-manifest.toml' + integer :: unit + + open(file=manifest, newunit=unit) + write(unit, '(a)') & + & 'name = "example"', & + & '[dependencies.fpm]', & + & 'git = "https://github.com/fortran-lang/fpm"', & + & '[[executable]]', & + & 'name = "example-#1" # comment', & + & 'source-dir = "prog"', & + & '[dependencies]', & + & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & + & '"toml..f" = { path = ".." }', & + & '[["executable"]]', & + & 'name = "example-#2"', & + & 'source-dir = "prog"', & + & '[executable.dependencies]', & + & '[''library'']', & + & 'source-dir = """', & + & 'lib""" # comment' + close(unit) + + call get_package_data(package, manifest, error) + + open(file=manifest, newunit=unit) + close(unit, status='delete') + + if (allocated(error)) return + + if (package%name /= "example") then + call test_failed(error, "Package name is "//package%name//" but should be example") + return + end if + + if (.not.allocated(package%library)) then + call test_failed(error, "library is not present in package data") + return + end if + + if (.not.allocated(package%executable)) then + call test_failed(error, "executable is not present in package data") + return + end if + + if (size(package%executable) /= 2) then + call test_failed(error, "Number of executables in package is not two") + return + end if + + if (.not.allocated(package%dependency)) then + call test_failed(error, "dependency is not present in package data") + return + end if + + if (size(package%dependency) /= 3) then + call test_failed(error, "Number of dependencies in package is not three") + return + end if + + if (allocated(package%test)) then + call test_failed(error, "test is present in package but not in package file") + return + end if + + end subroutine test_valid_manifest + + + !> Try to read a valid TOML document which represent an invalid package file + subroutine test_invalid_manifest(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_t) :: package + character(len=*), parameter :: manifest = 'fpm-invalid-manifest.toml' + integer :: unit + + open(file=manifest, newunit=unit) + write(unit, '(a)') & + & '[package]', & + & 'name = "example"', & + & 'version = "0.1.0"' + close(unit) + + call get_package_data(package, manifest, error) + + open(file=manifest, newunit=unit) + close(unit, status='delete') + + end subroutine test_invalid_manifest + + + !> Create a default library + subroutine test_default_library(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_t) :: package + + allocate(package%library) + call default_library(package%library) + + call check_string(error, package%library%source_dir, "src", & + & "Default library source-dir") + if (allocated(error)) return + + end subroutine test_default_library + + + !> Create a default executable + subroutine test_default_executable(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(package_t) :: package + character(len=*), parameter :: name = "default" + + allocate(package%executable(1)) + call default_executable(package%executable(1), name) + + call check_string(error, package%executable(1)%source_dir, "app", & + & "Default executable source-dir") + if (allocated(error)) return + + call check_string(error, package%executable(1)%name, name, & + & "Default executable name") + if (allocated(error)) return + + end subroutine test_default_executable + + + !> Dependencies cannot be created from empty tables + subroutine test_dependency_empty(error) + use fpm_manifest_dependency + use fpm_toml, only : new_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_t) :: dependency + + call new_table(table) + table%key = "example" + + call new_dependency(dependency, table, error) + + end subroutine test_dependency_empty + + + !> Try to create a dependency with conflicting entries + subroutine test_dependency_pathtag(error) + use fpm_manifest_dependency + use fpm_toml, only : new_table, toml_table, set_value + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + integer :: stat + type(dependency_t) :: dependency + + call new_table(table) + table%key = 'example' + call set_value(table, 'path', '"package"', stat) + call set_value(table, 'tag', '"v20.1"', stat) + + call new_dependency(dependency, table, error) + + end subroutine test_dependency_pathtag + + + !> Try to create a dependency with conflicting entries + subroutine test_dependency_nourl(error) + use fpm_manifest_dependency + use fpm_toml, only : new_table, toml_table, set_value + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + integer :: stat + type(dependency_t) :: dependency + + call new_table(table) + table%key = 'example' + call set_value(table, 'tag', '"v20.1"', stat) + + call new_dependency(dependency, table, error) + + end subroutine test_dependency_nourl + + + !> Try to create a dependency with conflicting entries + subroutine test_dependency_gitpath(error) + use fpm_manifest_dependency + use fpm_toml, only : new_table, toml_table, set_value + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + integer :: stat + type(dependency_t) :: dependency + + call new_table(table) + table%key = 'example' + call set_value(table, 'path', '"package"', stat) + call set_value(table, 'git', '"https://gitea.com/fortran-lang/pack"', stat) + + call new_dependency(dependency, table, error) + + end subroutine test_dependency_gitpath + + + !> Try to create a dependency with conflicting entries + subroutine test_dependency_gitconflict(error) + use fpm_manifest_dependency + use fpm_toml, only : new_table, toml_table, set_value + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + integer :: stat + type(dependency_t) :: dependency + + call new_table(table) + table%key = 'example' + call set_value(table, 'git', '"https://gitea.com/fortran-lang/pack"', stat) + call set_value(table, 'branch', '"latest"', stat) + call set_value(table, 'tag', '"v20.1"', stat) + + call new_dependency(dependency, table, error) + + end subroutine test_dependency_gitconflict + + + !> Try to create a dependency with conflicting entries + subroutine test_dependency_wrongkey(error) + use fpm_manifest_dependency + use fpm_toml, only : new_table, toml_table, set_value + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + integer :: stat + type(dependency_t) :: dependency + + call new_table(table) + table%key = 'example' + call set_value(table, 'not-available', '"anywhere"', stat) + + call new_dependency(dependency, table, error) + + end subroutine test_dependency_wrongkey + + + !> Dependency tables can be empty + subroutine test_dependencies_empty(error) + use fpm_manifest_dependency + use fpm_toml, only : new_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(dependency_t), allocatable :: dependencies(:) + + call new_table(table) + + call new_dependencies(dependencies, table, error) + if (allocated(error)) return + + if (allocated(dependencies)) then + call test_failed(error, "Found dependencies in empty table") + end if + + end subroutine test_dependencies_empty + + + !> Add a dependency as an array, which is not supported + subroutine test_dependencies_typeerror(error) + use fpm_manifest_dependency + use fpm_toml, only : new_table, add_array, toml_table, toml_array + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_array), pointer :: children + integer :: stat + type(dependency_t), allocatable :: dependencies(:) + + call new_table(table) + call add_array(table, 'dep1', children, stat) + + call new_dependencies(dependencies, table, error) + + end subroutine test_dependencies_typeerror + + + !> Executables cannot be created from empty tables + subroutine test_executable_empty(error) + use fpm_manifest_executable + use fpm_toml, only : new_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(executable_t) :: executable + + call new_table(table) + + call new_executable(executable, table, error) + + end subroutine test_executable_empty + + + !> Pass a wrong TOML type to the name field of the executable + subroutine test_executable_typeerror(error) + use fpm_manifest_executable + use fpm_toml, only : new_table, add_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(executable_t) :: executable + + call new_table(table) + call add_table(table, 'name', child, stat) + + call new_executable(executable, table, error) + + end subroutine test_executable_typeerror + + + !> Pass a TOML table with insufficient entries to the executable constructor + subroutine test_executable_noname(error) + use fpm_manifest_executable + use fpm_toml, only : new_table, add_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(executable_t) :: executable + + call new_table(table) + call add_table(table, 'dependencies', child, stat) + + call new_executable(executable, table, error) + + end subroutine test_executable_noname + + + !> Pass a TOML table with not allowed keys + subroutine test_executable_wrongkey(error) + use fpm_manifest_executable + use fpm_toml, only : new_table, add_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(executable_t) :: executable + + call new_table(table) + call add_table(table, 'wrong-field', child, stat) + + call new_executable(executable, table, error) + + end subroutine test_executable_wrongkey + + + !> Libraries can be created from empty tables + subroutine test_library_empty(error) + use fpm_manifest_library + use fpm_toml, only : new_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(library_t) :: library + + call new_table(table) + + call new_library(library, table, error) + if (allocated(error)) return + + call check_string(error, library%source_dir, "src", & + & "Default library source-dir") + if (allocated(error)) return + + end subroutine test_library_empty + + + !> Pass a TOML table with not allowed keys + subroutine test_library_wrongkey(error) + use fpm_manifest_library + use fpm_toml, only : new_table, add_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(library_t) :: library + + call new_table(table) + call add_table(table, 'not-allowed', child, stat) + + call new_library(library, table, error) + + end subroutine test_library_wrongkey + + + !> Packages cannot be created from empty tables + subroutine test_package_simple(error) + use fpm_manifest_package + use fpm_toml, only : new_table, add_table, add_array, set_value, & + & toml_table, toml_array + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child, child2 + type(toml_array), pointer :: children + integer :: stat + type(package_t) :: package + + call new_table(table) + call set_value(table, 'name', '"example"', stat) + call set_value(table, 'license', '"MIT"', stat) + call add_table(table, 'dev-dependencies', child, stat) + call add_table(child, 'pkg1', child2, stat) + call set_value(child2, 'git', '"https://github.com/fortran-lang/pkg1"', stat) + call add_table(child, 'pkg2', child2) + call set_value(child2, 'git', '"https://gitlab.com/fortran-lang/pkg2"', stat) + call set_value(child2, 'branch', '"devel"', stat) + call add_table(child, 'pkg3', child2) + call set_value(child2, 'git', '"https://bitbucket.org/fortran-lang/pkg3"', stat) + call set_value(child2, 'rev', '"9fceb02d0ae598e95dc970b74767f19372d61af8"', stat) + call add_table(child, 'pkg4', child2) + call set_value(child2, 'git', '"https://gitea.com/fortran-lang/pkg4"', stat) + call set_value(child2, 'tag', '"v1.8.5-rc3"', stat) + call add_array(table, 'test', children, stat) + call add_table(children, child, stat) + call set_value(child, 'name', '"tester"', stat) + + call new_package(package, table, error) + + end subroutine test_package_simple + + + !> Packages cannot be created from empty tables + subroutine test_package_empty(error) + use fpm_manifest_package + use fpm_toml, only : new_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(package_t) :: package + + call new_table(table) + + call new_package(package, table, error) + + end subroutine test_package_empty + + + !> Create an array in the package name, which should cause an error + subroutine test_package_typeerror(error) + use fpm_manifest_package + use fpm_toml, only : new_table, add_array, toml_table, toml_array + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_array), pointer :: child + integer :: stat + type(package_t) :: package + + call new_table(table) + call add_array(table, "name", child, stat) + + call new_package(package, table, error) + + end subroutine test_package_typeerror + + + !> Try to create a new package without a name field + subroutine test_package_noname(error) + use fpm_manifest_package + use fpm_toml, only : new_table, add_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(package_t) :: package + + call new_table(table) + call add_table(table, "library", child, stat) + call add_table(table, "dev-dependencies", child, stat) + call add_table(table, "dependencies", child, stat) + + call new_package(package, table, error) + + end subroutine test_package_noname + + + !> Try to read executables from a mixed type array + subroutine test_package_wrongexe(error) + use fpm_manifest_package + use fpm_toml, only : new_table, set_value, add_array, toml_table, toml_array + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_array), pointer :: children, children2 + integer :: stat + type(package_t) :: package + + call new_table(table) + call set_value(table, 'name', '"example"', stat) + call add_array(table, 'executable', children, stat) + call add_array(children, children2, stat) + + call new_package(package, table, error) + + end subroutine test_package_wrongexe + + + !> Try to read tests from a mixed type array + subroutine test_package_wrongtest(error) + use fpm_manifest_package + use fpm_toml, only : new_table, set_value, add_array, toml_table, toml_array + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_array), pointer :: children, children2 + integer :: stat + type(package_t) :: package + + call new_table(table) + call set_value(table, 'name', '"example"', stat) + call add_array(table, 'test', children, stat) + call add_array(children, children2, stat) + + call new_package(package, table, error) + + end subroutine test_package_wrongtest + + + !> Tests cannot be created from empty tables + subroutine test_test_simple(error) + use fpm_manifest_test + use fpm_toml, only : new_table, set_value, add_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(test_t) :: test + + call new_table(table) + call set_value(table, 'name', '"example"', stat) + call set_value(table, 'source-dir', '"tests"', stat) + call set_value(table, 'main', '"tester.f90"', stat) + call add_table(table, 'dependencies', child, stat) + + call new_test(test, table, error) + if (allocated(error)) return + + call check_string(error, test%main, "tester.f90", "Test main") + if (allocated(error)) return + + end subroutine test_test_simple + + + !> Tests cannot be created from empty tables + subroutine test_test_empty(error) + use fpm_manifest_test + use fpm_toml, only : new_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(test_t) :: test + + call new_table(table) + + call new_test(test, table, error) + + end subroutine test_test_empty + + + !> Pass a wrong TOML type to the name field of the test + subroutine test_test_typeerror(error) + use fpm_manifest_test + use fpm_toml, only : new_table, add_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(test_t) :: test + + call new_table(table) + call add_table(table, 'name', child, stat) + + call new_test(test, table, error) + + end subroutine test_test_typeerror + + + !> Pass a TOML table with insufficient entries to the test constructor + subroutine test_test_noname(error) + use fpm_manifest_test + use fpm_toml, only : new_table, add_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(test_t) :: test + + call new_table(table) + call add_table(table, 'dependencies', child, stat) + + call new_test(test, table, error) + + end subroutine test_test_noname + + + !> Pass a TOML table with not allowed keys + subroutine test_test_wrongkey(error) + use fpm_manifest_test + use fpm_toml, only : new_table, add_table, toml_table + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table) :: table + type(toml_table), pointer :: child + integer :: stat + type(test_t) :: test + + call new_table(table) + call add_table(table, 'not-supported', child, stat) + + call new_test(test, table, error) + + end subroutine test_test_wrongkey + + +end module test_manifest diff --git a/fpm/test/fpm_test/test_source_parsing.f90 b/fpm/test/fpm_test/test_source_parsing.f90 new file mode 100644 index 0000000..0b92bef --- /dev/null +++ b/fpm/test/fpm_test/test_source_parsing.f90 @@ -0,0 +1,695 @@ +!> Define tests for the `fpm_sources` module (parsing routines) +module test_source_parsing + use testsuite, only : new_unittest, unittest_t, error_t, test_failed + use fpm_filesystem, only: get_temp_filename + use fpm_sources, only: parse_f_source, parse_c_source + use fpm_model, only: srcfile_t, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & + FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE + use fpm_strings, only: operator(.in.) + implicit none + private + + public :: collect_source_parsing + +contains + + + !> Collect all exported unit tests + subroutine collect_source_parsing(testsuite) + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + & new_unittest("modules-used", test_modules_used), & + & new_unittest("intrinsic-modules-used", test_intrinsic_modules_used), & + & new_unittest("include-stmt", test_include_stmt), & + & new_unittest("module", test_module), & + & new_unittest("program-with-module", test_program_with_module), & + & new_unittest("submodule", test_submodule), & + & new_unittest("submodule-ancestor", test_submodule_ancestor), & + & new_unittest("subprogram", test_subprogram), & + & new_unittest("csource", test_csource), & + & new_unittest("invalid-use-stmt", & + test_invalid_use_stmt, should_fail=.true.), & + & new_unittest("invalid-include-stmt", & + test_invalid_include_stmt, should_fail=.true.), & + & new_unittest("invalid-module", & + test_invalid_module, should_fail=.true.), & + & new_unittest("invalid-submodule", & + test_invalid_submodule, should_fail=.true.) & + ] + + end subroutine collect_source_parsing + + + !> Check parsing of module 'USE' statements + subroutine test_modules_used(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'program test', & + & ' use module_one', & + & ' use :: module_two', & + & ' use module_three, only: a, b, c', & + & ' use :: module_four, only: a => b', & + & '! use module_not_used', & + & ' implicit none', & + & 'end program test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_PROGRAM) then + call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_PROGRAM') + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error,'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 4) then + call test_failed(error,'Incorrect number of modules_used - expecting four') + return + end if + + if (.not.('module_one' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + if (.not.('module_two' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + if (.not.('module_three' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + if (.not.('module_four' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + if ('module_not_used' .in. f_source%modules_used) then + call test_failed(error,'Commented module found in modules_used') + return + end if + + end subroutine test_modules_used + + + !> Check that intrinsic modules are properly ignore + subroutine test_intrinsic_modules_used(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'program test', & + & ' use iso_c_binding', & + & ' use iso_fortran_env', & + & ' use ieee_arithmetic', & + & ' use ieee_exceptions', & + & ' use ieee_features', & + & ' implicit none', & + & 'end program test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error,'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 0) then + call test_failed(error,'Incorrect number of modules_used - expecting zero') + return + end if + + if ('iso_c_binding' .in. f_source%modules_used) then + call test_failed(error,'Intrinsic module found in modules_used') + return + end if + + if ('iso_fortran_env' .in. f_source%modules_used) then + call test_failed(error,'Intrinsic module found in modules_used') + return + end if + + if ('ieee_arithmetic' .in. f_source%modules_used) then + call test_failed(error,'Intrinsic module found in modules_used') + return + end if + + if ('ieee_exceptions' .in. f_source%modules_used) then + call test_failed(error,'Intrinsic module found in modules_used') + return + end if + + if ('ieee_features' .in. f_source%modules_used) then + call test_failed(error,'Intrinsic module found in modules_used') + return + end if + + end subroutine test_intrinsic_modules_used + + + !> Check parsing of include statements + subroutine test_include_stmt(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'program test', & + & ' implicit none', & + & ' include "included_file.f90"', & + & ' contains ', & + & ' include "second_include.f90"', & + & 'end program test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error,'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 0) then + call test_failed(error,'Incorrect number of modules_used - expecting zero') + return + end if + + if (size(f_source%include_dependencies) /= 2) then + call test_failed(error,'Incorrect number of include_dependencies - expecting two') + return + end if + + if (.not.('included_file.f90' .in. f_source%include_dependencies)) then + call test_failed(error,'Missing include file in include_dependencies') + return + end if + + if (.not.('second_include.f90' .in. f_source%include_dependencies)) then + call test_failed(error,'Missing include file in include_dependencies') + return + end if + + end subroutine test_include_stmt + + + !> Try to parse fortran module + subroutine test_module(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'module my_mod', & + & 'use module_one', & + & 'interface', & + & ' module subroutine f()', & + & 'end interface', & + & 'contains', & + & 'module procedure f()', & + & 'end procedure f', & + & 'end module test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_MODULE) then + call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_MODULE') + return + end if + + if (size(f_source%modules_provided) /= 1) then + call test_failed(error,'Unexpected modules_provided - expecting one') + return + end if + + if (size(f_source%modules_used) /= 1) then + call test_failed(error,'Incorrect number of modules_used - expecting one') + return + end if + + if (.not.('my_mod' .in. f_source%modules_provided)) then + call test_failed(error,'Missing module in modules_provided') + return + end if + + if (.not.('module_one' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + end subroutine test_module + + + !> Try to parse combined fortran module and program + !> Check that parsed unit type is FPM_UNIT_PROGRAM + subroutine test_program_with_module(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'module my_mod', & + & 'use module_one', & + & 'interface', & + & ' module subroutine f()', & + & 'end interface', & + & 'contains', & + & 'module procedure f()', & + & 'end procedure f', & + & 'end module test', & + & 'program my_program', & + & 'use my_mod', & + & 'implicit none', & + & 'end my_program' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_PROGRAM) then + call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_PROGRAM') + return + end if + + if (size(f_source%modules_provided) /= 1) then + call test_failed(error,'Unexpected modules_provided - expecting one') + return + end if + + if (.not.('my_mod' .in. f_source%modules_provided)) then + call test_failed(error,'Missing module in modules_provided') + return + end if + + if (.not.('module_one' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + if (.not.('my_mod' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + end subroutine test_program_with_module + + + !> Try to parse fortran submodule for ancestry + subroutine test_submodule(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'submodule (parent) child', & + & 'use module_one', & + & 'end submodule test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_SUBMODULE) then + call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBMODULE') + return + end if + + if (size(f_source%modules_provided) /= 1) then + call test_failed(error,'Unexpected modules_provided - expecting one') + return + end if + + if (size(f_source%modules_used) /= 2) then + call test_failed(error,'Incorrect number of modules_used - expecting two') + return + end if + + if (.not.('child' .in. f_source%modules_provided)) then + call test_failed(error,'Missing module in modules_provided') + return + end if + + if (.not.('module_one' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + if (.not.('parent' .in. f_source%modules_used)) then + call test_failed(error,'Missing parent module in modules_used') + return + end if + + end subroutine test_submodule + + + !> Try to parse fortran multi-level submodule for ancestry + subroutine test_submodule_ancestor(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'submodule (ancestor:parent) child', & + & 'use module_one', & + & 'end submodule test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_SUBMODULE) then + call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBMODULE') + return + end if + + if (size(f_source%modules_provided) /= 1) then + call test_failed(error,'Unexpected modules_provided - expecting one') + return + end if + + if (size(f_source%modules_used) /= 2) then + call test_failed(error,'Incorrect number of modules_used - expecting two') + return + end if + + if (.not.('child' .in. f_source%modules_provided)) then + call test_failed(error,'Missing module in modules_provided') + return + end if + + if (.not.('module_one' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + if (.not.('parent' .in. f_source%modules_used)) then + call test_failed(error,'Missing parent module in modules_used') + return + end if + + end subroutine test_submodule_ancestor + + + !> Try to parse standard fortran sub-program (non-module) source + subroutine test_subprogram(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'subroutine my_sub(a)', & + & ' use module_one', & + & ' integer, intent(in) :: a', & + & 'end subroutine my_sub' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_SUBPROGRAM) then + call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBPROGRAM') + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error,'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 1) then + call test_failed(error,'Incorrect number of modules_used - expecting one') + return + end if + + if (.not.('module_one' .in. f_source%modules_used)) then + call test_failed(error,'Missing module in modules_used') + return + end if + + end subroutine test_subprogram + + + !> Try to parse standard c source for includes + subroutine test_csource(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + temp_file = temp_file//'.c' + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & '#include "proto.h"', & + & 'void c_func(int a) {', & + & ' #include "function_body.c"', & + & ' return', & + & '}' + close(unit) + + f_source = parse_c_source(temp_file,error) + if (allocated(error)) then + return + end if + + if (f_source%unit_type /= FPM_UNIT_CSOURCE) then + call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_CSOURCE') + return + end if + + if (size(f_source%modules_provided) /= 0) then + call test_failed(error,'Unexpected modules_provided - expecting zero') + return + end if + + if (size(f_source%modules_used) /= 0) then + call test_failed(error,'Incorrect number of modules_used - expecting zero') + return + end if + + if (size(f_source%include_dependencies) /= 2) then + call test_failed(error,'Incorrect number of include_dependencies - expecting two') + return + end if + + if (.not.('proto.h' .in. f_source%include_dependencies)) then + call test_failed(error,'Missing file in include_dependencies') + return + end if + + if (.not.('function_body.c' .in. f_source%include_dependencies)) then + call test_failed(error,'Missing file in include_dependencies') + return + end if + + end subroutine test_csource + + + !> Try to parse fortran program with invalid use statement + subroutine test_invalid_use_stmt(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'program test', & + & 'use module_one', & + & 'use :: ', & + & 'end program test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + end subroutine test_invalid_use_stmt + + + !> Try to parse fortran program with invalid use statement + subroutine test_invalid_include_stmt(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'program test', & + & ' include "', & + & 'end program test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + end subroutine test_invalid_include_stmt + + + !> Try to parse incorrect fortran module syntax + subroutine test_invalid_module(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'module :: my_mod', & + & 'end module test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + write(*,*) '"',f_source%modules_used(1)%s,'"' + + end subroutine test_invalid_module + + + !> Try to parse incorrect fortran submodule syntax + subroutine test_invalid_submodule(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + integer :: unit + character(:), allocatable :: temp_file + type(srcfile_t), allocatable :: f_source + + allocate(temp_file, source=get_temp_filename()) + + open(file=temp_file, newunit=unit) + write(unit, '(a)') & + & 'submodule :: child', & + & 'end submodule test' + close(unit) + + f_source = parse_f_source(temp_file,error) + if (allocated(error)) then + return + end if + + write(*,*) '"',f_source%modules_used(1)%s,'"' + + end subroutine test_invalid_submodule + + + +end module test_source_parsing diff --git a/fpm/test/fpm_test/test_toml.f90 b/fpm/test/fpm_test/test_toml.f90 new file mode 100644 index 0000000..ba48307 --- /dev/null +++ b/fpm/test/fpm_test/test_toml.f90 @@ -0,0 +1,107 @@ +!> Define tests for the `fpm_toml` modules +module test_toml + use testsuite, only : new_unittest, unittest_t, error_t + use fpm_toml + implicit none + private + + public :: collect_toml + + +contains + + + !> Collect all exported unit tests + subroutine collect_toml(testsuite) + + !> Collection of tests + 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.)] + + end subroutine collect_toml + + + !> Try to read some unnecessary obscure and convoluted but not invalid package file + subroutine test_valid_toml(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), allocatable :: table + character(len=*), parameter :: manifest = 'fpm-valid-toml.toml' + integer :: unit + + open(file=manifest, newunit=unit) + write(unit, '(a)') & + & 'name = "example"', & + & '[dependencies.fpm]', & + & 'git = "https://github.com/fortran-lang/fpm"', & + & '[[executable]]', & + & 'name = "example-#1" # comment', & + & 'source-dir = "prog"', & + & '[dependencies]', & + & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & + & '"toml..f" = { path = ".." }', & + & '[["executable"]]', & + & 'name = "example-#2"', & + & 'source-dir = "prog"', & + & '[executable.dependencies]', & + & '[''library'']', & + & 'source-dir = """', & + & 'lib""" # comment' + close(unit) + + call read_package_file(table, manifest, error) + + open(file=manifest, newunit=unit) + close(unit, status='delete') + + end subroutine test_valid_toml + + + !> Try to read an invalid TOML document + subroutine test_invalid_toml(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), allocatable :: table + character(len=*), parameter :: manifest = 'fpm-invalid-toml.toml' + integer :: unit + + open(file=manifest, newunit=unit) + write(unit, '(a)') & + & '# INVALID TOML DOC', & + & 'name = "example"', & + & 'dependencies.fpm.git = "https://github.com/fortran-lang/fpm"', & + & '[dependencies]', & + & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & + & '"toml..f" = { path = ".." }' + close(unit) + + call read_package_file(table, manifest, error) + + open(file=manifest, newunit=unit) + close(unit, status='delete') + + end subroutine test_invalid_toml + + + !> Try to read configuration from a non-existing file + subroutine test_missing_file(error) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + type(toml_table), allocatable :: table + + call read_package_file(table, 'low+chance+of+existing.toml', error) + + end subroutine test_missing_file + + +end module test_toml diff --git a/fpm/test/fpm_test/testsuite.f90 b/fpm/test/fpm_test/testsuite.f90 new file mode 100644 index 0000000..124d19a --- /dev/null +++ b/fpm/test/fpm_test/testsuite.f90 @@ -0,0 +1,286 @@ +!> Define some procedures to automate collecting and launching of tests +module testsuite + use fpm_error, only : error_t, test_failed => fatal_error + implicit none + private + + public :: run_testsuite, run_selected, new_unittest, new_testsuite, test_failed + public :: select_test, select_suite + public :: check_string + public :: unittest_t, testsuite_t, error_t + + + abstract interface + !> Entry point for tests + subroutine test_interface(error) + import :: error_t + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + end subroutine test_interface + end interface + + + !> Declaration of a unit test + type :: unittest_t + + !> Name of the test + character(len=:), allocatable :: name + + !> Entry point of the test + procedure(test_interface), pointer, nopass :: test => null() + + !> Whether test is supposed to fail + logical :: should_fail = .false. + + end type unittest_t + + + abstract interface + !> Collect all tests + subroutine collect_interface(testsuite) + import :: unittest_t + + !> Collection of tests + type(unittest_t), allocatable, intent(out) :: testsuite(:) + + end subroutine collect_interface + end interface + + + !> Collection of unit tests + type :: testsuite_t + + !> Name of the testsuite + character(len=:), allocatable :: name + + !> Entry point of the test + procedure(collect_interface), pointer, nopass :: collect => null() + + end type testsuite_t + + + character(len=*), parameter :: fmt = '("#", *(1x, a))' + character(len=*), parameter :: indent = repeat(" ", 5) // repeat(".", 3) + + +contains + + + !> Driver for testsuite + subroutine run_testsuite(collect, unit, stat) + + !> Collect tests + procedure(collect_interface) :: collect + + !> Unit for IO + integer, intent(in) :: unit + + !> Number of failed tests + integer, intent(inout) :: stat + + type(unittest_t), allocatable :: testsuite(:) + integer :: ii + + call collect(testsuite) + + do ii = 1, size(testsuite) + write(unit, '("#", 3(1x, a), 1x, "(", i0, "/", i0, ")")') & + & "Starting", testsuite(ii)%name, "...", ii, size(testsuite) + call run_unittest(testsuite(ii), unit, stat) + end do + + end subroutine run_testsuite + + + !> Driver for selective testing + subroutine run_selected(collect, name, unit, stat) + + !> Collect tests + procedure(collect_interface) :: collect + + !> Name of the selected test + character(len=*), intent(in) :: name + + !> Unit for IO + integer, intent(in) :: unit + + !> Number of failed tests + integer, intent(inout) :: stat + + type(unittest_t), allocatable :: testsuite(:) + integer :: ii + + call collect(testsuite) + + ii = select_test(testsuite, name) + + if (ii > 0 .and. ii <= size(testsuite)) then + call run_unittest(testsuite(ii), unit, stat) + else + write(unit, fmt) "Available tests:" + do ii = 1, size(testsuite) + write(unit, fmt) "-", testsuite(ii)%name + end do + stat = -huge(ii) + end if + + end subroutine run_selected + + + !> Run a selected unit test + subroutine run_unittest(test, unit, stat) + + !> Unit test + type(unittest_t), intent(in) :: test + + !> Unit for IO + integer, intent(in) :: unit + + !> Number of failed tests + integer, intent(inout) :: stat + + type(error_t), allocatable :: error + + call test%test(error) + if (allocated(error) .neqv. test%should_fail) then + if (test%should_fail) then + write(unit, fmt) indent, test%name, "[UNEXPECTED PASS]" + else + write(unit, fmt) indent, test%name, "[FAILED]" + end if + stat = stat + 1 + else + if (test%should_fail) then + write(unit, fmt) indent, test%name, "[EXPECTED FAIL]" + else + write(unit, fmt) indent, test%name, "[PASSED]" + end if + end if + if (allocated(error)) then + write(unit, fmt) "Message:", error%message + end if + + end subroutine run_unittest + + + !> Select a unit test from all available tests + function select_test(tests, name) result(pos) + + !> Name identifying the test suite + character(len=*), intent(in) :: name + + !> Available unit tests + type(unittest_t) :: tests(:) + + !> Selected test suite + integer :: pos + + integer :: it + + pos = 0 + do it = 1, size(tests) + if (name == tests(it)%name) then + pos = it + exit + end if + end do + + end function select_test + + + !> Select a test suite from all available suites + function select_suite(suites, name) result(pos) + + !> Name identifying the test suite + character(len=*), intent(in) :: name + + !> Available test suites + type(testsuite_t) :: suites(:) + + !> Selected test suite + integer :: pos + + integer :: it + + pos = 0 + do it = 1, size(suites) + if (name == suites(it)%name) then + pos = it + exit + end if + end do + + end function select_suite + + + !> Register a new unit test + function new_unittest(name, test, should_fail) result(self) + + !> Name of the test + character(len=*), intent(in) :: name + + !> Entry point for the test + procedure(test_interface) :: test + + !> Whether test is supposed to error or not + logical, intent(in), optional :: should_fail + + !> Newly registered test + type(unittest_t) :: self + + self%name = name + self%test => test + if (present(should_fail)) self%should_fail = should_fail + + end function new_unittest + + + !> Register a new testsuite + function new_testsuite(name, collect) result(self) + + !> Name of the testsuite + character(len=*), intent(in) :: name + + !> Entry point to collect tests + procedure(collect_interface) :: collect + + !> Newly registered testsuite + type(testsuite_t) :: self + + self%name = name + self%collect => collect + + end function new_testsuite + + + !> Check a deferred length character variable against a reference value + subroutine check_string(error, actual, expected, name) + + !> Error handling + type(error_t), allocatable, intent(out) :: error + + !> Actual string value + character(len=:), allocatable, intent(in) :: actual + + !> Expected string value + character(len=*), intent(in) :: expected + + !> Name of the string to check + character(len=*), intent(in) :: name + + if (.not.allocated(actual)) then + call test_failed(error, name//" is not set correctly") + return + end if + + if (actual /= expected) then + call test_failed(error, name//" is "//actual// & + & " but should be "//expected) + end if + + end subroutine check_string + + +end module testsuite diff --git a/fpm/test/main.f90 b/fpm/test/main.f90 deleted file mode 100644 index bc8ad29..0000000 --- a/fpm/test/main.f90 +++ /dev/null @@ -1,94 +0,0 @@ -!> Driver for unit testing -program fpm_testing - use, intrinsic :: iso_fortran_env, only : error_unit - use testsuite, only : run_testsuite, new_testsuite, testsuite_t, & - & select_suite, run_selected - use test_toml, only : collect_toml - use test_manifest, only : collect_manifest - use test_source_parsing, only : collect_source_parsing - implicit none - integer :: stat, is - character(len=:), allocatable :: suite_name, test_name - type(testsuite_t), allocatable :: testsuite(:) - character(len=*), parameter :: fmt = '("#", *(1x, a))' - - stat = 0 - - testsuite = [ & - & new_testsuite("fpm_toml", collect_toml), & - & new_testsuite("fpm_manifest", collect_manifest), & - & new_testsuite("fpm_source_parsing", collect_source_parsing) & - & ] - - call get_argument(1, suite_name) - call get_argument(2, test_name) - - if (allocated(suite_name)) then - is = select_suite(testsuite, suite_name) - if (is > 0 .and. is <= size(testsuite)) then - if (allocated(test_name)) then - write(error_unit, fmt) "Suite:", testsuite(is)%name - call run_selected(testsuite(is)%collect, test_name, error_unit, stat) - if (stat < 0) then - error stop 1 - end if - else - write(error_unit, fmt) "Testing:", testsuite(is)%name - call run_testsuite(testsuite(is)%collect, error_unit, stat) - end if - else - write(error_unit, fmt) "Available testsuites" - do is = 1, size(testsuite) - write(error_unit, fmt) "-", testsuite(is)%name - end do - error stop 1 - end if - else - do is = 1, size(testsuite) - write(error_unit, fmt) "Testing:", testsuite(is)%name - call run_testsuite(testsuite(is)%collect, error_unit, stat) - end do - end if - - if (stat > 0) then - write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" - error stop 1 - end if - - -contains - - - !> Obtain the command line argument at a given index - subroutine get_argument(idx, arg) - - !> Index of command line argument, range [0:command_argument_count()] - integer, intent(in) :: idx - - !> Command line argument - character(len=:), allocatable, intent(out) :: arg - - integer :: length, stat - - call get_command_argument(idx, length=length, status=stat) - if (stat /= 0) then - return - endif - - allocate(character(len=length) :: arg, stat=stat) - if (stat /= 0) then - return - endif - - if (length > 0) then - call get_command_argument(idx, arg, status=stat) - if (stat /= 0) then - deallocate(arg) - return - end if - end if - - end subroutine get_argument - - -end program fpm_testing diff --git a/fpm/test/test_manifest.f90 b/fpm/test/test_manifest.f90 deleted file mode 100644 index d2dc891..0000000 --- a/fpm/test/test_manifest.f90 +++ /dev/null @@ -1,749 +0,0 @@ -!> Define tests for the `fpm_manifest` modules -module test_manifest - use testsuite, only : new_unittest, unittest_t, error_t, test_failed, & - & check_string - use fpm_manifest - implicit none - private - - public :: collect_manifest - - -contains - - - !> Collect all exported unit tests - subroutine collect_manifest(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("valid-manifest", test_valid_manifest), & - & new_unittest("invalid-manifest", test_invalid_manifest, should_fail=.true.), & - & new_unittest("default-library", test_default_library), & - & new_unittest("default-executable", test_default_executable), & - & new_unittest("dependency-empty", test_dependency_empty, should_fail=.true.), & - & new_unittest("dependency-pathtag", test_dependency_pathtag, should_fail=.true.), & - & new_unittest("dependency-gitpath", test_dependency_gitpath, should_fail=.true.), & - & new_unittest("dependency-nourl", test_dependency_nourl, should_fail=.true.), & - & new_unittest("dependency-gitconflict", test_dependency_gitconflict, should_fail=.true.), & - & new_unittest("dependency-wrongkey", test_dependency_wrongkey, should_fail=.true.), & - & new_unittest("dependencies-empty", test_dependencies_empty), & - & new_unittest("dependencies-typeerror", test_dependencies_typeerror, should_fail=.true.), & - & new_unittest("executable-empty", test_executable_empty, should_fail=.true.), & - & new_unittest("executable-typeerror", test_executable_typeerror, should_fail=.true.), & - & new_unittest("executable-noname", test_executable_noname, should_fail=.true.), & - & new_unittest("executable-wrongkey", test_executable_wrongkey, should_fail=.true.), & - & new_unittest("library-empty", test_library_empty), & - & new_unittest("library-wrongkey", test_library_wrongkey, should_fail=.true.), & - & new_unittest("package-simple", test_package_simple), & - & new_unittest("package-empty", test_package_empty, should_fail=.true.), & - & new_unittest("package-typeerror", test_package_typeerror, should_fail=.true.), & - & new_unittest("package-noname", test_package_noname, should_fail=.true.), & - & new_unittest("package-wrongexe", test_package_wrongexe, should_fail=.true.), & - & new_unittest("package-wrongtest", test_package_wrongtest, should_fail=.true.), & - & new_unittest("test-simple", test_test_simple), & - & new_unittest("test-empty", test_test_empty, should_fail=.true.), & - & new_unittest("test-typeerror", test_test_typeerror, should_fail=.true.), & - & new_unittest("test-noname", test_test_noname, should_fail=.true.), & - & new_unittest("test-wrongkey", test_test_wrongkey, should_fail=.true.)] - - end subroutine collect_manifest - - - !> Try to read some unnecessary obscure and convoluted but not invalid package file - subroutine test_valid_manifest(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_t) :: package - character(len=*), parameter :: manifest = 'fpm-valid-manifest.toml' - integer :: unit - - open(file=manifest, newunit=unit) - write(unit, '(a)') & - & 'name = "example"', & - & '[dependencies.fpm]', & - & 'git = "https://github.com/fortran-lang/fpm"', & - & '[[executable]]', & - & 'name = "example-#1" # comment', & - & 'source-dir = "prog"', & - & '[dependencies]', & - & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & - & '"toml..f" = { path = ".." }', & - & '[["executable"]]', & - & 'name = "example-#2"', & - & 'source-dir = "prog"', & - & '[executable.dependencies]', & - & '[''library'']', & - & 'source-dir = """', & - & 'lib""" # comment' - close(unit) - - call get_package_data(package, manifest, error) - - open(file=manifest, newunit=unit) - close(unit, status='delete') - - if (allocated(error)) return - - if (package%name /= "example") then - call test_failed(error, "Package name is "//package%name//" but should be example") - return - end if - - if (.not.allocated(package%library)) then - call test_failed(error, "library is not present in package data") - return - end if - - if (.not.allocated(package%executable)) then - call test_failed(error, "executable is not present in package data") - return - end if - - if (size(package%executable) /= 2) then - call test_failed(error, "Number of executables in package is not two") - return - end if - - if (.not.allocated(package%dependency)) then - call test_failed(error, "dependency is not present in package data") - return - end if - - if (size(package%dependency) /= 3) then - call test_failed(error, "Number of dependencies in package is not three") - return - end if - - if (allocated(package%test)) then - call test_failed(error, "test is present in package but not in package file") - return - end if - - end subroutine test_valid_manifest - - - !> Try to read a valid TOML document which represent an invalid package file - subroutine test_invalid_manifest(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_t) :: package - character(len=*), parameter :: manifest = 'fpm-invalid-manifest.toml' - integer :: unit - - open(file=manifest, newunit=unit) - write(unit, '(a)') & - & '[package]', & - & 'name = "example"', & - & 'version = "0.1.0"' - close(unit) - - call get_package_data(package, manifest, error) - - open(file=manifest, newunit=unit) - close(unit, status='delete') - - end subroutine test_invalid_manifest - - - !> Create a default library - subroutine test_default_library(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_t) :: package - - allocate(package%library) - call default_library(package%library) - - call check_string(error, package%library%source_dir, "src", & - & "Default library source-dir") - if (allocated(error)) return - - end subroutine test_default_library - - - !> Create a default executable - subroutine test_default_executable(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(package_t) :: package - character(len=*), parameter :: name = "default" - - allocate(package%executable(1)) - call default_executable(package%executable(1), name) - - call check_string(error, package%executable(1)%source_dir, "app", & - & "Default executable source-dir") - if (allocated(error)) return - - call check_string(error, package%executable(1)%name, name, & - & "Default executable name") - if (allocated(error)) return - - end subroutine test_default_executable - - - !> Dependencies cannot be created from empty tables - subroutine test_dependency_empty(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(dependency_t) :: dependency - - call new_table(table) - table%key = "example" - - call new_dependency(dependency, table, error) - - end subroutine test_dependency_empty - - - !> Try to create a dependency with conflicting entries - subroutine test_dependency_pathtag(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table, set_value - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - integer :: stat - type(dependency_t) :: dependency - - call new_table(table) - table%key = 'example' - call set_value(table, 'path', '"package"', stat) - call set_value(table, 'tag', '"v20.1"', stat) - - call new_dependency(dependency, table, error) - - end subroutine test_dependency_pathtag - - - !> Try to create a dependency with conflicting entries - subroutine test_dependency_nourl(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table, set_value - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - integer :: stat - type(dependency_t) :: dependency - - call new_table(table) - table%key = 'example' - call set_value(table, 'tag', '"v20.1"', stat) - - call new_dependency(dependency, table, error) - - end subroutine test_dependency_nourl - - - !> Try to create a dependency with conflicting entries - subroutine test_dependency_gitpath(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table, set_value - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - integer :: stat - type(dependency_t) :: dependency - - call new_table(table) - table%key = 'example' - call set_value(table, 'path', '"package"', stat) - call set_value(table, 'git', '"https://gitea.com/fortran-lang/pack"', stat) - - call new_dependency(dependency, table, error) - - end subroutine test_dependency_gitpath - - - !> Try to create a dependency with conflicting entries - subroutine test_dependency_gitconflict(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table, set_value - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - integer :: stat - type(dependency_t) :: dependency - - call new_table(table) - table%key = 'example' - call set_value(table, 'git', '"https://gitea.com/fortran-lang/pack"', stat) - call set_value(table, 'branch', '"latest"', stat) - call set_value(table, 'tag', '"v20.1"', stat) - - call new_dependency(dependency, table, error) - - end subroutine test_dependency_gitconflict - - - !> Try to create a dependency with conflicting entries - subroutine test_dependency_wrongkey(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table, set_value - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - integer :: stat - type(dependency_t) :: dependency - - call new_table(table) - table%key = 'example' - call set_value(table, 'not-available', '"anywhere"', stat) - - call new_dependency(dependency, table, error) - - end subroutine test_dependency_wrongkey - - - !> Dependency tables can be empty - subroutine test_dependencies_empty(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(dependency_t), allocatable :: dependencies(:) - - call new_table(table) - - call new_dependencies(dependencies, table, error) - if (allocated(error)) return - - if (allocated(dependencies)) then - call test_failed(error, "Found dependencies in empty table") - end if - - end subroutine test_dependencies_empty - - - !> Add a dependency as an array, which is not supported - subroutine test_dependencies_typeerror(error) - use fpm_manifest_dependency - use fpm_toml, only : new_table, add_array, toml_table, toml_array - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_array), pointer :: children - integer :: stat - type(dependency_t), allocatable :: dependencies(:) - - call new_table(table) - call add_array(table, 'dep1', children, stat) - - call new_dependencies(dependencies, table, error) - - end subroutine test_dependencies_typeerror - - - !> Executables cannot be created from empty tables - subroutine test_executable_empty(error) - use fpm_manifest_executable - use fpm_toml, only : new_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(executable_t) :: executable - - call new_table(table) - - call new_executable(executable, table, error) - - end subroutine test_executable_empty - - - !> Pass a wrong TOML type to the name field of the executable - subroutine test_executable_typeerror(error) - use fpm_manifest_executable - use fpm_toml, only : new_table, add_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(executable_t) :: executable - - call new_table(table) - call add_table(table, 'name', child, stat) - - call new_executable(executable, table, error) - - end subroutine test_executable_typeerror - - - !> Pass a TOML table with insufficient entries to the executable constructor - subroutine test_executable_noname(error) - use fpm_manifest_executable - use fpm_toml, only : new_table, add_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(executable_t) :: executable - - call new_table(table) - call add_table(table, 'dependencies', child, stat) - - call new_executable(executable, table, error) - - end subroutine test_executable_noname - - - !> Pass a TOML table with not allowed keys - subroutine test_executable_wrongkey(error) - use fpm_manifest_executable - use fpm_toml, only : new_table, add_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(executable_t) :: executable - - call new_table(table) - call add_table(table, 'wrong-field', child, stat) - - call new_executable(executable, table, error) - - end subroutine test_executable_wrongkey - - - !> Libraries can be created from empty tables - subroutine test_library_empty(error) - use fpm_manifest_library - use fpm_toml, only : new_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(library_t) :: library - - call new_table(table) - - call new_library(library, table, error) - if (allocated(error)) return - - call check_string(error, library%source_dir, "src", & - & "Default library source-dir") - if (allocated(error)) return - - end subroutine test_library_empty - - - !> Pass a TOML table with not allowed keys - subroutine test_library_wrongkey(error) - use fpm_manifest_library - use fpm_toml, only : new_table, add_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(library_t) :: library - - call new_table(table) - call add_table(table, 'not-allowed', child, stat) - - call new_library(library, table, error) - - end subroutine test_library_wrongkey - - - !> Packages cannot be created from empty tables - subroutine test_package_simple(error) - use fpm_manifest_package - use fpm_toml, only : new_table, add_table, add_array, set_value, & - & toml_table, toml_array - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: child, child2 - type(toml_array), pointer :: children - integer :: stat - type(package_t) :: package - - call new_table(table) - call set_value(table, 'name', '"example"', stat) - call set_value(table, 'license', '"MIT"', stat) - call add_table(table, 'dev-dependencies', child, stat) - call add_table(child, 'pkg1', child2, stat) - call set_value(child2, 'git', '"https://github.com/fortran-lang/pkg1"', stat) - call add_table(child, 'pkg2', child2) - call set_value(child2, 'git', '"https://gitlab.com/fortran-lang/pkg2"', stat) - call set_value(child2, 'branch', '"devel"', stat) - call add_table(child, 'pkg3', child2) - call set_value(child2, 'git', '"https://bitbucket.org/fortran-lang/pkg3"', stat) - call set_value(child2, 'rev', '"9fceb02d0ae598e95dc970b74767f19372d61af8"', stat) - call add_table(child, 'pkg4', child2) - call set_value(child2, 'git', '"https://gitea.com/fortran-lang/pkg4"', stat) - call set_value(child2, 'tag', '"v1.8.5-rc3"', stat) - call add_array(table, 'test', children, stat) - call add_table(children, child, stat) - call set_value(child, 'name', '"tester"', stat) - - call new_package(package, table, error) - - end subroutine test_package_simple - - - !> Packages cannot be created from empty tables - subroutine test_package_empty(error) - use fpm_manifest_package - use fpm_toml, only : new_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(package_t) :: package - - call new_table(table) - - call new_package(package, table, error) - - end subroutine test_package_empty - - - !> Create an array in the package name, which should cause an error - subroutine test_package_typeerror(error) - use fpm_manifest_package - use fpm_toml, only : new_table, add_array, toml_table, toml_array - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_array), pointer :: child - integer :: stat - type(package_t) :: package - - call new_table(table) - call add_array(table, "name", child, stat) - - call new_package(package, table, error) - - end subroutine test_package_typeerror - - - !> Try to create a new package without a name field - subroutine test_package_noname(error) - use fpm_manifest_package - use fpm_toml, only : new_table, add_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(package_t) :: package - - call new_table(table) - call add_table(table, "library", child, stat) - call add_table(table, "dev-dependencies", child, stat) - call add_table(table, "dependencies", child, stat) - - call new_package(package, table, error) - - end subroutine test_package_noname - - - !> Try to read executables from a mixed type array - subroutine test_package_wrongexe(error) - use fpm_manifest_package - use fpm_toml, only : new_table, set_value, add_array, toml_table, toml_array - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_array), pointer :: children, children2 - integer :: stat - type(package_t) :: package - - call new_table(table) - call set_value(table, 'name', '"example"', stat) - call add_array(table, 'executable', children, stat) - call add_array(children, children2, stat) - - call new_package(package, table, error) - - end subroutine test_package_wrongexe - - - !> Try to read tests from a mixed type array - subroutine test_package_wrongtest(error) - use fpm_manifest_package - use fpm_toml, only : new_table, set_value, add_array, toml_table, toml_array - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_array), pointer :: children, children2 - integer :: stat - type(package_t) :: package - - call new_table(table) - call set_value(table, 'name', '"example"', stat) - call add_array(table, 'test', children, stat) - call add_array(children, children2, stat) - - call new_package(package, table, error) - - end subroutine test_package_wrongtest - - - !> Tests cannot be created from empty tables - subroutine test_test_simple(error) - use fpm_manifest_test - use fpm_toml, only : new_table, set_value, add_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(test_t) :: test - - call new_table(table) - call set_value(table, 'name', '"example"', stat) - call set_value(table, 'source-dir', '"tests"', stat) - call set_value(table, 'main', '"tester.f90"', stat) - call add_table(table, 'dependencies', child, stat) - - call new_test(test, table, error) - if (allocated(error)) return - - call check_string(error, test%main, "tester.f90", "Test main") - if (allocated(error)) return - - end subroutine test_test_simple - - - !> Tests cannot be created from empty tables - subroutine test_test_empty(error) - use fpm_manifest_test - use fpm_toml, only : new_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(test_t) :: test - - call new_table(table) - - call new_test(test, table, error) - - end subroutine test_test_empty - - - !> Pass a wrong TOML type to the name field of the test - subroutine test_test_typeerror(error) - use fpm_manifest_test - use fpm_toml, only : new_table, add_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(test_t) :: test - - call new_table(table) - call add_table(table, 'name', child, stat) - - call new_test(test, table, error) - - end subroutine test_test_typeerror - - - !> Pass a TOML table with insufficient entries to the test constructor - subroutine test_test_noname(error) - use fpm_manifest_test - use fpm_toml, only : new_table, add_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(test_t) :: test - - call new_table(table) - call add_table(table, 'dependencies', child, stat) - - call new_test(test, table, error) - - end subroutine test_test_noname - - - !> Pass a TOML table with not allowed keys - subroutine test_test_wrongkey(error) - use fpm_manifest_test - use fpm_toml, only : new_table, add_table, toml_table - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table) :: table - type(toml_table), pointer :: child - integer :: stat - type(test_t) :: test - - call new_table(table) - call add_table(table, 'not-supported', child, stat) - - call new_test(test, table, error) - - end subroutine test_test_wrongkey - - -end module test_manifest diff --git a/fpm/test/test_source_parsing.f90 b/fpm/test/test_source_parsing.f90 deleted file mode 100644 index 0b92bef..0000000 --- a/fpm/test/test_source_parsing.f90 +++ /dev/null @@ -1,695 +0,0 @@ -!> Define tests for the `fpm_sources` module (parsing routines) -module test_source_parsing - use testsuite, only : new_unittest, unittest_t, error_t, test_failed - use fpm_filesystem, only: get_temp_filename - use fpm_sources, only: parse_f_source, parse_c_source - use fpm_model, only: srcfile_t, FPM_UNIT_PROGRAM, FPM_UNIT_MODULE, & - FPM_UNIT_SUBMODULE, FPM_UNIT_SUBPROGRAM, FPM_UNIT_CSOURCE - use fpm_strings, only: operator(.in.) - implicit none - private - - public :: collect_source_parsing - -contains - - - !> Collect all exported unit tests - subroutine collect_source_parsing(testsuite) - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - & new_unittest("modules-used", test_modules_used), & - & new_unittest("intrinsic-modules-used", test_intrinsic_modules_used), & - & new_unittest("include-stmt", test_include_stmt), & - & new_unittest("module", test_module), & - & new_unittest("program-with-module", test_program_with_module), & - & new_unittest("submodule", test_submodule), & - & new_unittest("submodule-ancestor", test_submodule_ancestor), & - & new_unittest("subprogram", test_subprogram), & - & new_unittest("csource", test_csource), & - & new_unittest("invalid-use-stmt", & - test_invalid_use_stmt, should_fail=.true.), & - & new_unittest("invalid-include-stmt", & - test_invalid_include_stmt, should_fail=.true.), & - & new_unittest("invalid-module", & - test_invalid_module, should_fail=.true.), & - & new_unittest("invalid-submodule", & - test_invalid_submodule, should_fail=.true.) & - ] - - end subroutine collect_source_parsing - - - !> Check parsing of module 'USE' statements - subroutine test_modules_used(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'program test', & - & ' use module_one', & - & ' use :: module_two', & - & ' use module_three, only: a, b, c', & - & ' use :: module_four, only: a => b', & - & '! use module_not_used', & - & ' implicit none', & - & 'end program test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_PROGRAM) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_PROGRAM') - return - end if - - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if - - if (size(f_source%modules_used) /= 4) then - call test_failed(error,'Incorrect number of modules_used - expecting four') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('module_two' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('module_three' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('module_four' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if ('module_not_used' .in. f_source%modules_used) then - call test_failed(error,'Commented module found in modules_used') - return - end if - - end subroutine test_modules_used - - - !> Check that intrinsic modules are properly ignore - subroutine test_intrinsic_modules_used(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'program test', & - & ' use iso_c_binding', & - & ' use iso_fortran_env', & - & ' use ieee_arithmetic', & - & ' use ieee_exceptions', & - & ' use ieee_features', & - & ' implicit none', & - & 'end program test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if - - if (size(f_source%modules_used) /= 0) then - call test_failed(error,'Incorrect number of modules_used - expecting zero') - return - end if - - if ('iso_c_binding' .in. f_source%modules_used) then - call test_failed(error,'Intrinsic module found in modules_used') - return - end if - - if ('iso_fortran_env' .in. f_source%modules_used) then - call test_failed(error,'Intrinsic module found in modules_used') - return - end if - - if ('ieee_arithmetic' .in. f_source%modules_used) then - call test_failed(error,'Intrinsic module found in modules_used') - return - end if - - if ('ieee_exceptions' .in. f_source%modules_used) then - call test_failed(error,'Intrinsic module found in modules_used') - return - end if - - if ('ieee_features' .in. f_source%modules_used) then - call test_failed(error,'Intrinsic module found in modules_used') - return - end if - - end subroutine test_intrinsic_modules_used - - - !> Check parsing of include statements - subroutine test_include_stmt(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'program test', & - & ' implicit none', & - & ' include "included_file.f90"', & - & ' contains ', & - & ' include "second_include.f90"', & - & 'end program test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if - - if (size(f_source%modules_used) /= 0) then - call test_failed(error,'Incorrect number of modules_used - expecting zero') - return - end if - - if (size(f_source%include_dependencies) /= 2) then - call test_failed(error,'Incorrect number of include_dependencies - expecting two') - return - end if - - if (.not.('included_file.f90' .in. f_source%include_dependencies)) then - call test_failed(error,'Missing include file in include_dependencies') - return - end if - - if (.not.('second_include.f90' .in. f_source%include_dependencies)) then - call test_failed(error,'Missing include file in include_dependencies') - return - end if - - end subroutine test_include_stmt - - - !> Try to parse fortran module - subroutine test_module(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'module my_mod', & - & 'use module_one', & - & 'interface', & - & ' module subroutine f()', & - & 'end interface', & - & 'contains', & - & 'module procedure f()', & - & 'end procedure f', & - & 'end module test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_MODULE) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_MODULE') - return - end if - - if (size(f_source%modules_provided) /= 1) then - call test_failed(error,'Unexpected modules_provided - expecting one') - return - end if - - if (size(f_source%modules_used) /= 1) then - call test_failed(error,'Incorrect number of modules_used - expecting one') - return - end if - - if (.not.('my_mod' .in. f_source%modules_provided)) then - call test_failed(error,'Missing module in modules_provided') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - end subroutine test_module - - - !> Try to parse combined fortran module and program - !> Check that parsed unit type is FPM_UNIT_PROGRAM - subroutine test_program_with_module(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'module my_mod', & - & 'use module_one', & - & 'interface', & - & ' module subroutine f()', & - & 'end interface', & - & 'contains', & - & 'module procedure f()', & - & 'end procedure f', & - & 'end module test', & - & 'program my_program', & - & 'use my_mod', & - & 'implicit none', & - & 'end my_program' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_PROGRAM) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_PROGRAM') - return - end if - - if (size(f_source%modules_provided) /= 1) then - call test_failed(error,'Unexpected modules_provided - expecting one') - return - end if - - if (.not.('my_mod' .in. f_source%modules_provided)) then - call test_failed(error,'Missing module in modules_provided') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('my_mod' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - end subroutine test_program_with_module - - - !> Try to parse fortran submodule for ancestry - subroutine test_submodule(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'submodule (parent) child', & - & 'use module_one', & - & 'end submodule test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_SUBMODULE) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBMODULE') - return - end if - - if (size(f_source%modules_provided) /= 1) then - call test_failed(error,'Unexpected modules_provided - expecting one') - return - end if - - if (size(f_source%modules_used) /= 2) then - call test_failed(error,'Incorrect number of modules_used - expecting two') - return - end if - - if (.not.('child' .in. f_source%modules_provided)) then - call test_failed(error,'Missing module in modules_provided') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('parent' .in. f_source%modules_used)) then - call test_failed(error,'Missing parent module in modules_used') - return - end if - - end subroutine test_submodule - - - !> Try to parse fortran multi-level submodule for ancestry - subroutine test_submodule_ancestor(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'submodule (ancestor:parent) child', & - & 'use module_one', & - & 'end submodule test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_SUBMODULE) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBMODULE') - return - end if - - if (size(f_source%modules_provided) /= 1) then - call test_failed(error,'Unexpected modules_provided - expecting one') - return - end if - - if (size(f_source%modules_used) /= 2) then - call test_failed(error,'Incorrect number of modules_used - expecting two') - return - end if - - if (.not.('child' .in. f_source%modules_provided)) then - call test_failed(error,'Missing module in modules_provided') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - if (.not.('parent' .in. f_source%modules_used)) then - call test_failed(error,'Missing parent module in modules_used') - return - end if - - end subroutine test_submodule_ancestor - - - !> Try to parse standard fortran sub-program (non-module) source - subroutine test_subprogram(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'subroutine my_sub(a)', & - & ' use module_one', & - & ' integer, intent(in) :: a', & - & 'end subroutine my_sub' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_SUBPROGRAM) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_SUBPROGRAM') - return - end if - - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if - - if (size(f_source%modules_used) /= 1) then - call test_failed(error,'Incorrect number of modules_used - expecting one') - return - end if - - if (.not.('module_one' .in. f_source%modules_used)) then - call test_failed(error,'Missing module in modules_used') - return - end if - - end subroutine test_subprogram - - - !> Try to parse standard c source for includes - subroutine test_csource(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - temp_file = temp_file//'.c' - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & '#include "proto.h"', & - & 'void c_func(int a) {', & - & ' #include "function_body.c"', & - & ' return', & - & '}' - close(unit) - - f_source = parse_c_source(temp_file,error) - if (allocated(error)) then - return - end if - - if (f_source%unit_type /= FPM_UNIT_CSOURCE) then - call test_failed(error,'Wrong unit type detected - expecting FPM_UNIT_CSOURCE') - return - end if - - if (size(f_source%modules_provided) /= 0) then - call test_failed(error,'Unexpected modules_provided - expecting zero') - return - end if - - if (size(f_source%modules_used) /= 0) then - call test_failed(error,'Incorrect number of modules_used - expecting zero') - return - end if - - if (size(f_source%include_dependencies) /= 2) then - call test_failed(error,'Incorrect number of include_dependencies - expecting two') - return - end if - - if (.not.('proto.h' .in. f_source%include_dependencies)) then - call test_failed(error,'Missing file in include_dependencies') - return - end if - - if (.not.('function_body.c' .in. f_source%include_dependencies)) then - call test_failed(error,'Missing file in include_dependencies') - return - end if - - end subroutine test_csource - - - !> Try to parse fortran program with invalid use statement - subroutine test_invalid_use_stmt(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'program test', & - & 'use module_one', & - & 'use :: ', & - & 'end program test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - end subroutine test_invalid_use_stmt - - - !> Try to parse fortran program with invalid use statement - subroutine test_invalid_include_stmt(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'program test', & - & ' include "', & - & 'end program test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - end subroutine test_invalid_include_stmt - - - !> Try to parse incorrect fortran module syntax - subroutine test_invalid_module(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'module :: my_mod', & - & 'end module test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - write(*,*) '"',f_source%modules_used(1)%s,'"' - - end subroutine test_invalid_module - - - !> Try to parse incorrect fortran submodule syntax - subroutine test_invalid_submodule(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - integer :: unit - character(:), allocatable :: temp_file - type(srcfile_t), allocatable :: f_source - - allocate(temp_file, source=get_temp_filename()) - - open(file=temp_file, newunit=unit) - write(unit, '(a)') & - & 'submodule :: child', & - & 'end submodule test' - close(unit) - - f_source = parse_f_source(temp_file,error) - if (allocated(error)) then - return - end if - - write(*,*) '"',f_source%modules_used(1)%s,'"' - - end subroutine test_invalid_submodule - - - -end module test_source_parsing diff --git a/fpm/test/test_toml.f90 b/fpm/test/test_toml.f90 deleted file mode 100644 index ba48307..0000000 --- a/fpm/test/test_toml.f90 +++ /dev/null @@ -1,107 +0,0 @@ -!> Define tests for the `fpm_toml` modules -module test_toml - use testsuite, only : new_unittest, unittest_t, error_t - use fpm_toml - implicit none - private - - public :: collect_toml - - -contains - - - !> Collect all exported unit tests - subroutine collect_toml(testsuite) - - !> Collection of tests - 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.)] - - end subroutine collect_toml - - - !> Try to read some unnecessary obscure and convoluted but not invalid package file - subroutine test_valid_toml(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table), allocatable :: table - character(len=*), parameter :: manifest = 'fpm-valid-toml.toml' - integer :: unit - - open(file=manifest, newunit=unit) - write(unit, '(a)') & - & 'name = "example"', & - & '[dependencies.fpm]', & - & 'git = "https://github.com/fortran-lang/fpm"', & - & '[[executable]]', & - & 'name = "example-#1" # comment', & - & 'source-dir = "prog"', & - & '[dependencies]', & - & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & - & '"toml..f" = { path = ".." }', & - & '[["executable"]]', & - & 'name = "example-#2"', & - & 'source-dir = "prog"', & - & '[executable.dependencies]', & - & '[''library'']', & - & 'source-dir = """', & - & 'lib""" # comment' - close(unit) - - call read_package_file(table, manifest, error) - - open(file=manifest, newunit=unit) - close(unit, status='delete') - - end subroutine test_valid_toml - - - !> Try to read an invalid TOML document - subroutine test_invalid_toml(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table), allocatable :: table - character(len=*), parameter :: manifest = 'fpm-invalid-toml.toml' - integer :: unit - - open(file=manifest, newunit=unit) - write(unit, '(a)') & - & '# INVALID TOML DOC', & - & 'name = "example"', & - & 'dependencies.fpm.git = "https://github.com/fortran-lang/fpm"', & - & '[dependencies]', & - & 'toml-f.git = "git@github.com:toml-f/toml-f.git"', & - & '"toml..f" = { path = ".." }' - close(unit) - - call read_package_file(table, manifest, error) - - open(file=manifest, newunit=unit) - close(unit, status='delete') - - end subroutine test_invalid_toml - - - !> Try to read configuration from a non-existing file - subroutine test_missing_file(error) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - type(toml_table), allocatable :: table - - call read_package_file(table, 'low+chance+of+existing.toml', error) - - end subroutine test_missing_file - - -end module test_toml diff --git a/fpm/test/testsuite.f90 b/fpm/test/testsuite.f90 deleted file mode 100644 index 124d19a..0000000 --- a/fpm/test/testsuite.f90 +++ /dev/null @@ -1,286 +0,0 @@ -!> Define some procedures to automate collecting and launching of tests -module testsuite - use fpm_error, only : error_t, test_failed => fatal_error - implicit none - private - - public :: run_testsuite, run_selected, new_unittest, new_testsuite, test_failed - public :: select_test, select_suite - public :: check_string - public :: unittest_t, testsuite_t, error_t - - - abstract interface - !> Entry point for tests - subroutine test_interface(error) - import :: error_t - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - end subroutine test_interface - end interface - - - !> Declaration of a unit test - type :: unittest_t - - !> Name of the test - character(len=:), allocatable :: name - - !> Entry point of the test - procedure(test_interface), pointer, nopass :: test => null() - - !> Whether test is supposed to fail - logical :: should_fail = .false. - - end type unittest_t - - - abstract interface - !> Collect all tests - subroutine collect_interface(testsuite) - import :: unittest_t - - !> Collection of tests - type(unittest_t), allocatable, intent(out) :: testsuite(:) - - end subroutine collect_interface - end interface - - - !> Collection of unit tests - type :: testsuite_t - - !> Name of the testsuite - character(len=:), allocatable :: name - - !> Entry point of the test - procedure(collect_interface), pointer, nopass :: collect => null() - - end type testsuite_t - - - character(len=*), parameter :: fmt = '("#", *(1x, a))' - character(len=*), parameter :: indent = repeat(" ", 5) // repeat(".", 3) - - -contains - - - !> Driver for testsuite - subroutine run_testsuite(collect, unit, stat) - - !> Collect tests - procedure(collect_interface) :: collect - - !> Unit for IO - integer, intent(in) :: unit - - !> Number of failed tests - integer, intent(inout) :: stat - - type(unittest_t), allocatable :: testsuite(:) - integer :: ii - - call collect(testsuite) - - do ii = 1, size(testsuite) - write(unit, '("#", 3(1x, a), 1x, "(", i0, "/", i0, ")")') & - & "Starting", testsuite(ii)%name, "...", ii, size(testsuite) - call run_unittest(testsuite(ii), unit, stat) - end do - - end subroutine run_testsuite - - - !> Driver for selective testing - subroutine run_selected(collect, name, unit, stat) - - !> Collect tests - procedure(collect_interface) :: collect - - !> Name of the selected test - character(len=*), intent(in) :: name - - !> Unit for IO - integer, intent(in) :: unit - - !> Number of failed tests - integer, intent(inout) :: stat - - type(unittest_t), allocatable :: testsuite(:) - integer :: ii - - call collect(testsuite) - - ii = select_test(testsuite, name) - - if (ii > 0 .and. ii <= size(testsuite)) then - call run_unittest(testsuite(ii), unit, stat) - else - write(unit, fmt) "Available tests:" - do ii = 1, size(testsuite) - write(unit, fmt) "-", testsuite(ii)%name - end do - stat = -huge(ii) - end if - - end subroutine run_selected - - - !> Run a selected unit test - subroutine run_unittest(test, unit, stat) - - !> Unit test - type(unittest_t), intent(in) :: test - - !> Unit for IO - integer, intent(in) :: unit - - !> Number of failed tests - integer, intent(inout) :: stat - - type(error_t), allocatable :: error - - call test%test(error) - if (allocated(error) .neqv. test%should_fail) then - if (test%should_fail) then - write(unit, fmt) indent, test%name, "[UNEXPECTED PASS]" - else - write(unit, fmt) indent, test%name, "[FAILED]" - end if - stat = stat + 1 - else - if (test%should_fail) then - write(unit, fmt) indent, test%name, "[EXPECTED FAIL]" - else - write(unit, fmt) indent, test%name, "[PASSED]" - end if - end if - if (allocated(error)) then - write(unit, fmt) "Message:", error%message - end if - - end subroutine run_unittest - - - !> Select a unit test from all available tests - function select_test(tests, name) result(pos) - - !> Name identifying the test suite - character(len=*), intent(in) :: name - - !> Available unit tests - type(unittest_t) :: tests(:) - - !> Selected test suite - integer :: pos - - integer :: it - - pos = 0 - do it = 1, size(tests) - if (name == tests(it)%name) then - pos = it - exit - end if - end do - - end function select_test - - - !> Select a test suite from all available suites - function select_suite(suites, name) result(pos) - - !> Name identifying the test suite - character(len=*), intent(in) :: name - - !> Available test suites - type(testsuite_t) :: suites(:) - - !> Selected test suite - integer :: pos - - integer :: it - - pos = 0 - do it = 1, size(suites) - if (name == suites(it)%name) then - pos = it - exit - end if - end do - - end function select_suite - - - !> Register a new unit test - function new_unittest(name, test, should_fail) result(self) - - !> Name of the test - character(len=*), intent(in) :: name - - !> Entry point for the test - procedure(test_interface) :: test - - !> Whether test is supposed to error or not - logical, intent(in), optional :: should_fail - - !> Newly registered test - type(unittest_t) :: self - - self%name = name - self%test => test - if (present(should_fail)) self%should_fail = should_fail - - end function new_unittest - - - !> Register a new testsuite - function new_testsuite(name, collect) result(self) - - !> Name of the testsuite - character(len=*), intent(in) :: name - - !> Entry point to collect tests - procedure(collect_interface) :: collect - - !> Newly registered testsuite - type(testsuite_t) :: self - - self%name = name - self%collect => collect - - end function new_testsuite - - - !> Check a deferred length character variable against a reference value - subroutine check_string(error, actual, expected, name) - - !> Error handling - type(error_t), allocatable, intent(out) :: error - - !> Actual string value - character(len=:), allocatable, intent(in) :: actual - - !> Expected string value - character(len=*), intent(in) :: expected - - !> Name of the string to check - character(len=*), intent(in) :: name - - if (.not.allocated(actual)) then - call test_failed(error, name//" is not set correctly") - return - end if - - if (actual /= expected) then - call test_failed(error, name//" is "//actual// & - & " but should be "//expected) - end if - - end subroutine check_string - - -end module testsuite -- cgit v1.2.3 From ea1dc19a0f73259b34f9b0881b20a090ef95bf0a Mon Sep 17 00:00:00 2001 From: "init current directory[i]" Date: Fri, 25 Sep 2020 18:15:32 -0400 Subject: RESTORE --- fpm/src/fpm.f90 | 245 +++++++++++++++++++++++++++++++++++++------ fpm/src/fpm_command_line.f90 | 3 +- fpm/src/fpm_filesystem.f90 | 4 +- 3 files changed, 215 insertions(+), 37 deletions(-) diff --git a/fpm/src/fpm.f90 b/fpm/src/fpm.f90 index 1975d28..d2ba95d 100644 --- a/fpm/src/fpm.f90 +++ b/fpm/src/fpm.f90 @@ -5,7 +5,7 @@ use fpm_backend, only: build_package use fpm_command_line, only: fpm_build_settings, fpm_new_settings, & fpm_run_settings, fpm_install_settings, fpm_test_settings use fpm_environment, only: run, get_os_type, OS_LINUX, OS_MACOS, OS_WINDOWS -use fpm_filesystem, only: join_path, number_of_rows, list_files, exists, basename +use fpm_filesystem, only: join_path, number_of_rows, list_files, exists, basename, mkdir use fpm_model, only: srcfile_ptr, srcfile_t, fpm_model_t use fpm_sources, only: add_executable_sources, add_sources_from_dir, & resolve_module_dependencies @@ -19,9 +19,10 @@ implicit none private public :: cmd_build, cmd_install, cmd_new, cmd_run, cmd_test - contains - +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== subroutine build_model(model, settings, package, error) ! Constructs a valid fpm model from command line settings and toml manifest ! @@ -89,7 +90,9 @@ subroutine build_model(model, settings, package, error) call resolve_module_dependencies(model%sources) end subroutine build_model - +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== subroutine cmd_build(settings) type(fpm_build_settings), intent(in) :: settings type(package_t) :: package @@ -126,21 +129,51 @@ end if call build_package(model) -end subroutine - +end subroutine cmd_build +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== subroutine cmd_install(settings) type(fpm_install_settings), intent(in) :: settings print *, "fpm error: 'fpm install' not implemented." error stop 1 end subroutine cmd_install - +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== subroutine cmd_new(settings) ! --with-executable F --with-test F ' type(fpm_new_settings), intent(in) :: settings +integer :: ierr +character(len=:),allocatable :: bname ! baeename of NAME character(len=:),allocatable :: message(:) -character(len=:),allocatable :: bname - bname=basename(settings%name) !! new basename(dirname) if full paths are allowed ??? - - message=[character(len=80) :: & ! create fpm.toml +character(len=:),allocatable :: littlefile(:) + call mkdir(settings%name) ! make new directory + call run('cd '//settings%name) ! change to new directory as a test. New OS routines to improve this; system depenent potentially + call mkdir(join_path(settings%name,'src') ) + !! NOTE: need some system routines to handle filenames like "." like realpath() or getcwd(). + bname=basename(settings%name) + + !! weird gfortran bug?? lines truncated to concatenated string length, not 80 + !! hit some weird gfortran bug when littlefile data was an argument to warnwrite(3f), ok when a variable + littlefile=[character(len=80) :: & + &'module '//bname, & + &' implicit none', & + &' private', & + &'', & + &' public :: say_hello', & + &'contains', & + &' subroutine say_hello', & + &' print *, "Hello, '//bname//'!"', & + &' end subroutine say_hello', & + &'end module '//bname] + call warnwrite(join_path(settings%name, 'src', bname//'.f90'), littlefile) ! create NAME/src/NAME.f90 + + call warnwrite(join_path(settings%name, '.gitignore'), ['build/*']) ! create NAME/.gitignore file + + littlefile=[character(len=80) :: '# '//bname, 'My cool new project!'] + call warnwrite(join_path(settings%name, 'README.md'), littlefile) ! create NAME/README.md + + message=[character(len=80) :: & ! build NAME/fpm.toml &'name = "'//bname//'" ', & &'version = "0.1.0" ', & &'license = "license" ', & @@ -153,46 +186,188 @@ character(len=:),allocatable :: bname &''] if(settings%with_test)then - message=[character(len=80) :: message, & ! create next section of fpm.toml + message=[character(len=80) :: message, & ! create next section of fpm.toml &'[[test]] ', & &'name="runTests" ', & &'source-dir="test" ', & &'main="main.f90" ', & &''] + + call mkdir(join_path(settings%name, 'test')) ! create NAME/test or stop + littlefile=[character(len=80) :: & + &'program main', & + &'implicit none', & + &'', & + &'print *, "Put some tests in here!"', & + &'end program main'] + call warnwrite(join_path(settings%name, 'test/main.f90'), littlefile) ! create NAME/test/main.f90 endif if(settings%with_executable)then - message=[character(len=80) :: message, & ! create next section of fpm.toml + message=[character(len=80) :: message, & ! create next section of fpm.toml &'[[executable]] ', & &'name="'//bname//'" ', & &'source-dir="app" ', & &'main="main.f90" ', & &''] + + call mkdir(join_path(settings%name, 'app')) ! create NAME/app or stop + littlefile=[character(len=80) :: & + &'program main', & + &' use '//bname//', only: say_hello', & + &'', & + &' implicit none', & + &'', & + &' call say_hello', & + &'end program main'] + call warnwrite(join_path(settings%name, 'app/main.f90'), littlefile) endif - write(*,'(a)')message - print *, "fpm error: 'fpm new' not implemented." - error stop 1 -end subroutine cmd_new + call warnwrite(join_path(settings%name, 'fpm.toml'), message) ! now that built it write NAME/fpm.toml + + call run('cd ' // settings%name // ';git init') ! assumes these commands work on all systems and git(1) is installed + contains +!=================================================================================================================================== +subroutine warnwrite(fname,data) +character(len=*),intent(in) :: fname +character(len=*),intent(in) :: data(:) + if(.not.exists(fname))then + call filewrite(fname,data) + else + write(stderr,'(*(g0,1x))')'fpm::new',fname,'already exists. Not overwriting' + endif +end subroutine warnwrite +!=================================================================================================================================== +subroutine filewrite(filename,filedata) +use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit +! write filedata to file filename +character(len=*),intent(in) :: filename +character(len=*),intent(in) :: filedata(:) +integer :: lun, i, ios +character(len=256) :: message + message=' ' + ios=0 + if(filename.ne.' ')then + open(file=filename, & + & newunit=lun, & + & form='formatted', & ! FORM = FORMATTED | UNFORMATTED + & access='sequential', & ! ACCESS = SEQUENTIAL | DIRECT | STREAM + & action='write', & ! ACTION = READ|WRITE | READWRITE + & position='rewind', & ! POSITION = ASIS | REWIND | APPEND + & status='new', & ! STATUS = NEW | REPLACE | OLD | SCRATCH | UNKNOWN + & iostat=ios, & + & iomsg=message) + else + lun=stdout + ios=0 + endif + if(ios.ne.0)then + write(stderr,'(*(a,1x))')'*filewrite* error:',filename,trim(message) + error stop 1 + endif + do i=1,size(filedata) ! write file + write(lun,'(a)',iostat=ios,iomsg=message)trim(filedata(i)) + if(ios.ne.0)then + write(stderr,'(*(a,1x))')'*filewrite* error:',filename,trim(message) + stop 4 + endif + enddo + close(unit=lun,iostat=ios,iomsg=message) ! close file + if(ios.ne.0)then + write(stderr,'(*(a,1x))')'*filewrite* error:',trim(message) + error stop 2 + endif +end subroutine filewrite +end subroutine cmd_new +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== subroutine cmd_run(settings) - type(fpm_run_settings), intent(in) :: settings - integer :: i - - write(*,*)'RELEASE=',settings%release - if(size(settings%name).eq.0)then - write(*,*)'RUN DEFAULTS with arguments ['//settings%args//']' - else - do i=1,size(settings%name) - write(*,*)'RUN:'//trim(settings%name(i))//' with arguments ['//settings%args//']' - enddo - endif - - print *, "fpm error: 'fpm run' not implemented." - error stop 1 - +type(fpm_run_settings), intent(in) :: settings +character(len=:),allocatable :: release_name, cmd, fname +integer :: i, j +type(package_t) :: package +type(error_t), allocatable :: error +character(len=:),allocatable :: newwords(:) +logical,allocatable :: foundit(:) +logical :: list + call get_package_data(package, "fpm.toml", error) + if (allocated(error)) then + print '(a)', error%message + stop + endif + release_name=trim(merge('gfortran_release','gfortran_debug ',settings%release)) + newwords=[character(len=0) ::] + ! Populate executable in case we find the default app directory + if (.not.allocated(package%executable) .and. exists("app")) then + allocate(package%executable(1)) + call default_executable(package%executable(1), package%name) + endif + if(size(settings%name).eq.0)then + if ( .not.allocated(package%executable) ) then + write(stderr,'(*(g0,1x))')'fpm::run:no executables found in fpm.toml and no default app/ directory' + stop + endif + allocate(foundit(size(package%executable))) + do i=1,size(package%executable) + fname=join_path('build',release_name,package%executable(i)%source_dir,package%executable(i)%name) + newwords=[character(len=max(len(newwords),len(fname))) :: newwords,fname] + enddo + if(size(newwords).lt.1)then + write(stderr,'(*(g0,1x))')'fpm::run:no executables found in fpm.toml' + stop + endif + else + !! expand names, duplicates are a problem?? + allocate(foundit(size(settings%name))) + foundit=.false. + FINDIT: do i=1,size(package%executable) + do j=1,size(settings%name) + if(settings%name(j).eq.package%executable(i)%name)then + fname=join_path('build',release_name,package%executable(i)%source_dir,package%executable(i)%name) + newwords=[character(len=max(len(newwords),len(fname))) :: newwords,fname] + foundit(j)=.true. + endif + enddo + enddo FINDIT + do i=1,size(settings%name) + if(.not.foundit(i))then + write(stderr,'(*(g0,1x))')'fpm::run:executable',trim(settings%name(i)),'not located' + !!elseif(settings%debug)then + !! write(stderr,'(*(g0,1x))')'fpm::run:executable',trim(settings%name(i)),'located at',newwords(i),& + !! & merge('exists ','does not exist',exists(trim(settings%name(i)))) + endif + enddo + if(allocated(foundit))deallocate(foundit) + endif + do i=1,size(newwords) + !! list is a new option for use with xargs, to move files to production area, valgrind, gdb, ls -l, .... + !! maybe add as --mask and could do --mask 'echo %xx' or --mask 'cp %XX /usr/local/bin/' an so on + !! default if blank would be filename uptodate|needs|updated|doesnotexist creation_date, ... + !! or maybe just list filenames so can pipe through xargs, and so on + if(settings%list)then + write(stderr,'(*(g0,1x))')'fpm::run:executable expected at',newwords(i),& + & merge('exists ','does not exist',exists(newwords(i))) + cycle + endif + cmd=newwords(i) // ' ' // settings%args + if(exists(newwords(i)))then + call run(cmd) + else ! try to build + !!call cmd_build() + if(exists(newwords(i)))then + call run(cmd) + else + write(stderr,*)'fpm::run',cmd,' not found' + endif + endif + enddo + deallocate(newwords) end subroutine cmd_run - +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== subroutine cmd_test(settings) type(fpm_test_settings), intent(in) :: settings character(len=:),allocatable :: release_name @@ -214,5 +389,7 @@ subroutine cmd_test(settings) print *, "fpm error: 'fpm test' not implemented." error stop 1 end subroutine cmd_test - +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== end module fpm diff --git a/fpm/src/fpm_command_line.f90 b/fpm/src/fpm_command_line.f90 index 84b4693..9f9dcbe 100644 --- a/fpm/src/fpm_command_line.f90 +++ b/fpm/src/fpm_command_line.f90 @@ -123,7 +123,8 @@ contains endif allocate(fpm_run_settings :: cmd_settings) - cmd_settings=fpm_run_settings( name=names, release=lget('release'), args=remaining ) + cmd_settings=fpm_run_settings( name=names, list=lget('list'), & + & release=lget('release'), args=remaining ) case('build') help_text=[character(len=80) :: & diff --git a/fpm/src/fpm_filesystem.f90 b/fpm/src/fpm_filesystem.f90 index 488a202..9acbb85 100644 --- a/fpm/src/fpm_filesystem.f90 +++ b/fpm/src/fpm_filesystem.f90 @@ -135,11 +135,11 @@ subroutine mkdir(dir) select case (get_os_type()) case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD) call execute_command_line('mkdir -p ' // dir, exitstat=stat) - write (*, '(2a)') 'mkdir -p ' // dir + write (*, '(" + ",2a)') 'mkdir -p ' // dir case (OS_WINDOWS) call execute_command_line("mkdir " // windows_path(dir), exitstat=stat) - write (*, '(2a)') 'mkdir ' // windows_path(dir) + write (*, '(" + ",2a)') 'mkdir ' // windows_path(dir) end select if (stat /= 0) then -- cgit v1.2.3 From a42775d3ace284d8041d874bdfa7ce9eb947314f Mon Sep 17 00:00:00 2001 From: "init current directory[i]" Date: Fri, 25 Sep 2020 18:49:04 -0400 Subject: RESTORE FROM BACKUP --- fpm/src/fpm.f90 | 245 ++++++------------------------------------- fpm/src/fpm_command_line.f90 | 3 +- fpm/src/fpm_filesystem.f90 | 4 +- 3 files changed, 37 insertions(+), 215 deletions(-) diff --git a/fpm/src/fpm.f90 b/fpm/src/fpm.f90 index d2ba95d..1975d28 100644 --- a/fpm/src/fpm.f90 +++ b/fpm/src/fpm.f90 @@ -5,7 +5,7 @@ use fpm_backend, only: build_package use fpm_command_line, only: fpm_build_settings, fpm_new_settings, & fpm_run_settings, fpm_install_settings, fpm_test_settings use fpm_environment, only: run, get_os_type, OS_LINUX, OS_MACOS, OS_WINDOWS -use fpm_filesystem, only: join_path, number_of_rows, list_files, exists, basename, mkdir +use fpm_filesystem, only: join_path, number_of_rows, list_files, exists, basename use fpm_model, only: srcfile_ptr, srcfile_t, fpm_model_t use fpm_sources, only: add_executable_sources, add_sources_from_dir, & resolve_module_dependencies @@ -19,10 +19,9 @@ implicit none private public :: cmd_build, cmd_install, cmd_new, cmd_run, cmd_test + contains -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + subroutine build_model(model, settings, package, error) ! Constructs a valid fpm model from command line settings and toml manifest ! @@ -90,9 +89,7 @@ subroutine build_model(model, settings, package, error) call resolve_module_dependencies(model%sources) end subroutine build_model -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + subroutine cmd_build(settings) type(fpm_build_settings), intent(in) :: settings type(package_t) :: package @@ -129,51 +126,21 @@ end if call build_package(model) -end subroutine cmd_build -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== +end subroutine + subroutine cmd_install(settings) type(fpm_install_settings), intent(in) :: settings print *, "fpm error: 'fpm install' not implemented." error stop 1 end subroutine cmd_install -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + subroutine cmd_new(settings) ! --with-executable F --with-test F ' type(fpm_new_settings), intent(in) :: settings -integer :: ierr -character(len=:),allocatable :: bname ! baeename of NAME character(len=:),allocatable :: message(:) -character(len=:),allocatable :: littlefile(:) - call mkdir(settings%name) ! make new directory - call run('cd '//settings%name) ! change to new directory as a test. New OS routines to improve this; system depenent potentially - call mkdir(join_path(settings%name,'src') ) - !! NOTE: need some system routines to handle filenames like "." like realpath() or getcwd(). - bname=basename(settings%name) - - !! weird gfortran bug?? lines truncated to concatenated string length, not 80 - !! hit some weird gfortran bug when littlefile data was an argument to warnwrite(3f), ok when a variable - littlefile=[character(len=80) :: & - &'module '//bname, & - &' implicit none', & - &' private', & - &'', & - &' public :: say_hello', & - &'contains', & - &' subroutine say_hello', & - &' print *, "Hello, '//bname//'!"', & - &' end subroutine say_hello', & - &'end module '//bname] - call warnwrite(join_path(settings%name, 'src', bname//'.f90'), littlefile) ! create NAME/src/NAME.f90 - - call warnwrite(join_path(settings%name, '.gitignore'), ['build/*']) ! create NAME/.gitignore file - - littlefile=[character(len=80) :: '# '//bname, 'My cool new project!'] - call warnwrite(join_path(settings%name, 'README.md'), littlefile) ! create NAME/README.md - - message=[character(len=80) :: & ! build NAME/fpm.toml +character(len=:),allocatable :: bname + bname=basename(settings%name) !! new basename(dirname) if full paths are allowed ??? + + message=[character(len=80) :: & ! create fpm.toml &'name = "'//bname//'" ', & &'version = "0.1.0" ', & &'license = "license" ', & @@ -186,188 +153,46 @@ character(len=:),allocatable :: littlefile(:) &''] if(settings%with_test)then - message=[character(len=80) :: message, & ! create next section of fpm.toml + message=[character(len=80) :: message, & ! create next section of fpm.toml &'[[test]] ', & &'name="runTests" ', & &'source-dir="test" ', & &'main="main.f90" ', & &''] - - call mkdir(join_path(settings%name, 'test')) ! create NAME/test or stop - littlefile=[character(len=80) :: & - &'program main', & - &'implicit none', & - &'', & - &'print *, "Put some tests in here!"', & - &'end program main'] - call warnwrite(join_path(settings%name, 'test/main.f90'), littlefile) ! create NAME/test/main.f90 endif if(settings%with_executable)then - message=[character(len=80) :: message, & ! create next section of fpm.toml + message=[character(len=80) :: message, & ! create next section of fpm.toml &'[[executable]] ', & &'name="'//bname//'" ', & &'source-dir="app" ', & &'main="main.f90" ', & &''] - - call mkdir(join_path(settings%name, 'app')) ! create NAME/app or stop - littlefile=[character(len=80) :: & - &'program main', & - &' use '//bname//', only: say_hello', & - &'', & - &' implicit none', & - &'', & - &' call say_hello', & - &'end program main'] - call warnwrite(join_path(settings%name, 'app/main.f90'), littlefile) endif - call warnwrite(join_path(settings%name, 'fpm.toml'), message) ! now that built it write NAME/fpm.toml - - call run('cd ' // settings%name // ';git init') ! assumes these commands work on all systems and git(1) is installed - contains -!=================================================================================================================================== -subroutine warnwrite(fname,data) -character(len=*),intent(in) :: fname -character(len=*),intent(in) :: data(:) - if(.not.exists(fname))then - call filewrite(fname,data) - else - write(stderr,'(*(g0,1x))')'fpm::new',fname,'already exists. Not overwriting' - endif -end subroutine warnwrite -!=================================================================================================================================== -subroutine filewrite(filename,filedata) -use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit -! write filedata to file filename -character(len=*),intent(in) :: filename -character(len=*),intent(in) :: filedata(:) -integer :: lun, i, ios -character(len=256) :: message - message=' ' - ios=0 - if(filename.ne.' ')then - open(file=filename, & - & newunit=lun, & - & form='formatted', & ! FORM = FORMATTED | UNFORMATTED - & access='sequential', & ! ACCESS = SEQUENTIAL | DIRECT | STREAM - & action='write', & ! ACTION = READ|WRITE | READWRITE - & position='rewind', & ! POSITION = ASIS | REWIND | APPEND - & status='new', & ! STATUS = NEW | REPLACE | OLD | SCRATCH | UNKNOWN - & iostat=ios, & - & iomsg=message) - else - lun=stdout - ios=0 - endif - if(ios.ne.0)then - write(stderr,'(*(a,1x))')'*filewrite* error:',filename,trim(message) - error stop 1 - endif - do i=1,size(filedata) ! write file - write(lun,'(a)',iostat=ios,iomsg=message)trim(filedata(i)) - if(ios.ne.0)then - write(stderr,'(*(a,1x))')'*filewrite* error:',filename,trim(message) - stop 4 - endif - enddo - close(unit=lun,iostat=ios,iomsg=message) ! close file - if(ios.ne.0)then - write(stderr,'(*(a,1x))')'*filewrite* error:',trim(message) - error stop 2 - endif -end subroutine filewrite - + write(*,'(a)')message + print *, "fpm error: 'fpm new' not implemented." + error stop 1 end subroutine cmd_new -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + subroutine cmd_run(settings) -type(fpm_run_settings), intent(in) :: settings -character(len=:),allocatable :: release_name, cmd, fname -integer :: i, j -type(package_t) :: package -type(error_t), allocatable :: error -character(len=:),allocatable :: newwords(:) -logical,allocatable :: foundit(:) -logical :: list - call get_package_data(package, "fpm.toml", error) - if (allocated(error)) then - print '(a)', error%message - stop - endif - release_name=trim(merge('gfortran_release','gfortran_debug ',settings%release)) - newwords=[character(len=0) ::] - ! Populate executable in case we find the default app directory - if (.not.allocated(package%executable) .and. exists("app")) then - allocate(package%executable(1)) - call default_executable(package%executable(1), package%name) - endif - if(size(settings%name).eq.0)then - if ( .not.allocated(package%executable) ) then - write(stderr,'(*(g0,1x))')'fpm::run:no executables found in fpm.toml and no default app/ directory' - stop - endif - allocate(foundit(size(package%executable))) - do i=1,size(package%executable) - fname=join_path('build',release_name,package%executable(i)%source_dir,package%executable(i)%name) - newwords=[character(len=max(len(newwords),len(fname))) :: newwords,fname] - enddo - if(size(newwords).lt.1)then - write(stderr,'(*(g0,1x))')'fpm::run:no executables found in fpm.toml' - stop - endif - else - !! expand names, duplicates are a problem?? - allocate(foundit(size(settings%name))) - foundit=.false. - FINDIT: do i=1,size(package%executable) - do j=1,size(settings%name) - if(settings%name(j).eq.package%executable(i)%name)then - fname=join_path('build',release_name,package%executable(i)%source_dir,package%executable(i)%name) - newwords=[character(len=max(len(newwords),len(fname))) :: newwords,fname] - foundit(j)=.true. - endif - enddo - enddo FINDIT - do i=1,size(settings%name) - if(.not.foundit(i))then - write(stderr,'(*(g0,1x))')'fpm::run:executable',trim(settings%name(i)),'not located' - !!elseif(settings%debug)then - !! write(stderr,'(*(g0,1x))')'fpm::run:executable',trim(settings%name(i)),'located at',newwords(i),& - !! & merge('exists ','does not exist',exists(trim(settings%name(i)))) - endif - enddo - if(allocated(foundit))deallocate(foundit) - endif - do i=1,size(newwords) - !! list is a new option for use with xargs, to move files to production area, valgrind, gdb, ls -l, .... - !! maybe add as --mask and could do --mask 'echo %xx' or --mask 'cp %XX /usr/local/bin/' an so on - !! default if blank would be filename uptodate|needs|updated|doesnotexist creation_date, ... - !! or maybe just list filenames so can pipe through xargs, and so on - if(settings%list)then - write(stderr,'(*(g0,1x))')'fpm::run:executable expected at',newwords(i),& - & merge('exists ','does not exist',exists(newwords(i))) - cycle - endif - cmd=newwords(i) // ' ' // settings%args - if(exists(newwords(i)))then - call run(cmd) - else ! try to build - !!call cmd_build() - if(exists(newwords(i)))then - call run(cmd) - else - write(stderr,*)'fpm::run',cmd,' not found' - endif - endif - enddo - deallocate(newwords) + type(fpm_run_settings), intent(in) :: settings + integer :: i + + write(*,*)'RELEASE=',settings%release + if(size(settings%name).eq.0)then + write(*,*)'RUN DEFAULTS with arguments ['//settings%args//']' + else + do i=1,size(settings%name) + write(*,*)'RUN:'//trim(settings%name(i))//' with arguments ['//settings%args//']' + enddo + endif + + print *, "fpm error: 'fpm run' not implemented." + error stop 1 + end subroutine cmd_run -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + subroutine cmd_test(settings) type(fpm_test_settings), intent(in) :: settings character(len=:),allocatable :: release_name @@ -389,7 +214,5 @@ subroutine cmd_test(settings) print *, "fpm error: 'fpm test' not implemented." error stop 1 end subroutine cmd_test -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + end module fpm diff --git a/fpm/src/fpm_command_line.f90 b/fpm/src/fpm_command_line.f90 index 9f9dcbe..84b4693 100644 --- a/fpm/src/fpm_command_line.f90 +++ b/fpm/src/fpm_command_line.f90 @@ -123,8 +123,7 @@ contains endif allocate(fpm_run_settings :: cmd_settings) - cmd_settings=fpm_run_settings( name=names, list=lget('list'), & - & release=lget('release'), args=remaining ) + cmd_settings=fpm_run_settings( name=names, release=lget('release'), args=remaining ) case('build') help_text=[character(len=80) :: & diff --git a/fpm/src/fpm_filesystem.f90 b/fpm/src/fpm_filesystem.f90 index 9acbb85..488a202 100644 --- a/fpm/src/fpm_filesystem.f90 +++ b/fpm/src/fpm_filesystem.f90 @@ -135,11 +135,11 @@ subroutine mkdir(dir) select case (get_os_type()) case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD) call execute_command_line('mkdir -p ' // dir, exitstat=stat) - write (*, '(" + ",2a)') 'mkdir -p ' // dir + write (*, '(2a)') 'mkdir -p ' // dir case (OS_WINDOWS) call execute_command_line("mkdir " // windows_path(dir), exitstat=stat) - write (*, '(" + ",2a)') 'mkdir ' // windows_path(dir) + write (*, '(2a)') 'mkdir ' // windows_path(dir) end select if (stat /= 0) then -- cgit v1.2.3 From d653c11d6445a9744d5cbd10c9f0ffbac9922a7d Mon Sep 17 00:00:00 2001 From: Brad Richardson Date: Sun, 27 Sep 2020 15:25:13 -0500 Subject: Fix test build issue hapenning on Windows --- bootstrap/src/Build.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bootstrap/src/Build.hs b/bootstrap/src/Build.hs index ffbf264..cdcbb02 100644 --- a/bootstrap/src/Build.hs +++ b/bootstrap/src/Build.hs @@ -259,7 +259,7 @@ createSourceToObjectMap buildDirectory libraryDirectory sourceFile = sourceFileToObjectFile :: FilePath -> FilePath -> FilePath -> FilePath sourceFileToObjectFile buildDirectory libraryDirectory sourceFile = - buildDirectory + (foldl () "" $ splitDirectories buildDirectory) map toLower (pathSeparatorsToUnderscores -- cgit v1.2.3