diff options
| -rw-r--r-- | README.md | 24 | ||||
| -rw-r--r-- | fpm/src/fpm.f90 | 112 | ||||
| -rw-r--r-- | fpm/src/fpm_command_line.f90 | 103 | ||||
| -rw-r--r-- | fpm/src/fpm_compiler.f90 | 27 | ||||
| -rw-r--r-- | fpm/src/fpm_environment.f90 | 13 | ||||
| -rw-r--r-- | fpm/src/fpm_strings.f90 | 520 | ||||
| -rw-r--r-- | fpm/test/help_test/help_test.f90 | 101 | ||||
| -rw-r--r-- | fpm/test/new_test/new_test.f90 | 34 | ||||
| -rwxr-xr-x | install.sh | 118 |
9 files changed, 787 insertions, 265 deletions
@@ -72,32 +72,26 @@ $ cd fpm/ #### Build a bootstrap version of fpm -You can use the install script to perform the build of the Haskell version of *fpm* with: +You can use the install script to bootstrap and install *fpm*: ```bash $ ./install.sh ``` -On Linux, the above command installs `fpm` to `${HOME}/.local/bin/`. - -Now you can build the Fortran *fpm* version with +By default, the above command installs `fpm` to `${HOME}/.local/bin/`. +To specify an alternative destination use the `--prefix=` flag, for example: ```bash -$ cd fpm/ -$ fpm build +$ ./install.sh --prefix=/usr/local ``` -Test that everything is working as expected +which will install *fpm* to `/usr/local/bin`. -```bash -$ fpm test -``` - -Finally, install the Fortran *fpm* version with +To test that everything is working as expected you can now build *fpm* +with itself and run the tests with: ```bash -$ fpm run --runner mv -- ~/.local/bin +$ cd fpm +$ fpm test ``` -Or choose another location if you do not want to overwrite the bootstrapping version. -From now on you can rebuild *fpm* with your Fortran *fpm* version. diff --git a/fpm/src/fpm.f90 b/fpm/src/fpm.f90 index 5837189..68385cd 100644 --- a/fpm/src/fpm.f90 +++ b/fpm/src/fpm.f90 @@ -1,5 +1,5 @@ module fpm -use fpm_strings, only: string_t, operator(.in.) +use fpm_strings, only: string_t, operator(.in.), glob, join 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 @@ -65,6 +65,9 @@ subroutine build_model(model, settings, package, error) model%output_directory = join_path('build',basename(model%fortran_compiler)//'_'//settings%build_name) call add_compile_flag_defaults(settings%build_name, basename(model%fortran_compiler), model) + if(settings%verbose)then + write(*,*)'<INFO>COMPILER OPTIONS: ', model%fortran_compile_flags + endif allocate(model%packages(model%deps%ndep)) @@ -197,8 +200,7 @@ subroutine cmd_run(settings,test) class(fpm_run_settings), intent(in) :: settings logical, intent(in) :: test - integer, parameter :: LINE_WIDTH = 80 - integer :: i, j, col_width, nCol + integer :: i, j, col_width logical :: found(size(settings%name)) type(error_t), allocatable :: error type(package_config_t) :: package @@ -209,6 +211,8 @@ subroutine cmd_run(settings,test) type(build_target_t), pointer :: exe_target type(srcfile_t), pointer :: exe_source integer :: run_scope + character(len=:),allocatable :: line + logical :: toomany call get_package_data(package, "fpm.toml", error, apply_defaults=.true.) if (allocated(error)) then @@ -260,7 +264,7 @@ subroutine cmd_run(settings,test) do j=1,size(settings%name) - if (trim(settings%name(j))==exe_source%exe_name) then + if (glob(trim(exe_source%exe_name),trim(settings%name(j)))) then found(j) = .true. exe_cmd%s = exe_target%output_file @@ -289,15 +293,61 @@ subroutine cmd_run(settings,test) end if ! Check all names are valid - if (any(.not.found)) then + ! or no name and found more than one file + toomany= size(settings%name).eq.0 .and. size(executables).gt.1 + if ( any(.not.found) & + & .or. & + & ( (toomany .and. .not.test) .or. (toomany .and. settings%runner .ne. '') ) & + & .and. & + & .not.settings%list) then + line=join(settings%name) + if(line.ne.'.')then ! do not report these special strings + if(any(.not.found))then + write(stderr,'(A)',advance="no")'fpm::run<ERROR> specified names ' + do j=1,size(settings%name) + if (.not.found(j)) write(stderr,'(A)',advance="no") '"'//trim(settings%name(j))//'" ' + end do + write(stderr,'(A)') 'not found.' + write(stderr,*) + else if(settings%verbose)then + write(stderr,'(A)',advance="yes")'<INFO>when more than one executable is available' + write(stderr,'(A)',advance="yes")' program names must be specified.' + endif + endif - write(stderr,'(A)',advance="no")'fpm::run<ERROR> specified names ' - do j=1,size(settings%name) - if (.not.found(j)) write(stderr,'(A)',advance="no") '"'//trim(settings%name(j))//'" ' - end do - write(stderr,'(A)') 'not found.' - write(stderr,*) + call compact_list_all() + + if(line.eq.'.' .or. line.eq.' ')then ! do not report these special strings + stop + else + stop 1 + endif + + end if + + call build_package(targets,model) + if (settings%list) then + call compact_list() + else + + do i=1,size(executables) + if (exists(executables(i)%s)) then + if(settings%runner .ne. ' ')then + call run(settings%runner//' '//executables(i)%s//" "//settings%args,echo=settings%verbose) + else + call run(executables(i)%s//" "//settings%args,echo=settings%verbose) + endif + else + write(stderr,*)'fpm::run<ERROR>',executables(i)%s,' not found' + stop 1 + end if + end do + endif + contains + subroutine compact_list_all() + integer, parameter :: LINE_WIDTH = 80 + integer :: i, j, nCol j = 1 nCol = LINE_WIDTH/col_width write(stderr,*) 'Available names:' @@ -317,36 +367,24 @@ subroutine cmd_run(settings,test) j = j + 1 end if - end if - end do - write(stderr,*) - stop 1 + end subroutine compact_list_all - end if - - call build_package(targets,model) - - do i=1,size(executables) - if (settings%list) then - write(stderr,*) executables(i)%s - else - - if (exists(executables(i)%s)) then - if(settings%runner .ne. ' ')then - call run(settings%runner//' '//executables(i)%s//" "//settings%args) - else - call run(executables(i)%s//" "//settings%args) - endif - else - write(stderr,*)'fpm::run<ERROR>',executables(i)%s,' not found' - stop 1 - end if - - end if - end do + subroutine compact_list() + integer, parameter :: LINE_WIDTH = 80 + integer :: i, j, nCol + j = 1 + nCol = LINE_WIDTH/col_width + write(stderr,*) 'Matched names:' + do i=1,size(executables) + write(stderr,'(A)',advance=(merge("yes","no ",modulo(j,nCol)==0))) & + & [character(len=col_width) :: basename(executables(i)%s)] + j = j + 1 + enddo + write(stderr,*) + end subroutine compact_list end subroutine cmd_run diff --git a/fpm/src/fpm_command_line.f90 b/fpm/src/fpm_command_line.f90 index 0217154..4d184e4 100644 --- a/fpm/src/fpm_command_line.f90 +++ b/fpm/src/fpm_command_line.f90 @@ -152,6 +152,7 @@ contains call set_args('& & --target " " & & --list F & + & --all F & & --release F& & --example F& & --runner " " & @@ -167,13 +168,26 @@ contains names=[character(len=len(names)) :: ] endif + if(specified('target') )then call split(sget('target'),tnames,delimiters=' ,:') names=[character(len=max(len(names),len(tnames))) :: names,tnames] endif + ! convert --all to '*' + if(lget('all'))then + names=[character(len=max(len(names),1)) :: names,'*' ] + endif + + ! convert special string '..' to equivalent (shorter) '*' + ! to allow for a string that does not require shift-key and quoting + do i=1,size(names) + if(names(i).eq.'..')names(i)='*' + enddo + allocate(fpm_run_settings :: cmd_settings) val_runner=sget('runner') + if(specified('runner') .and. val_runner.eq.'')val_runner='echo' cmd_settings=fpm_run_settings(& & args=remaining,& & build_name=val_build,& @@ -375,8 +389,15 @@ contains names=[character(len=max(len(names),len(tnames))) :: names,tnames] endif + ! convert special string '..' to equivalent (shorter) '*' + ! to allow for a string that does not require shift-key and quoting + do i=1,size(names) + if(names(i).eq.'..')names(i)='*' + enddo + allocate(fpm_test_settings :: cmd_settings) val_runner=sget('runner') + if(specified('runner') .and. val_runner.eq.'')val_runner='echo' cmd_settings=fpm_test_settings(& & args=remaining, & & build_name=val_build, & @@ -501,8 +522,8 @@ contains ' [--full|--bare][--backfill] ', & ' update [NAME(s)] [--fetch-only] [--clean] [--verbose] ', & ' list [--list] ', & - ' run [[--target] NAME(s)] [--release] [--runner "CMD"] [--list] [--example] ', & - ' [--compiler COMPILER_NAME] [-- ARGS] ', & + ' run [[--target] NAME(s) [--example] [--release] [--all] [--runner "CMD"] ', & + ' [--compiler COMPILER_NAME] [--list] [-- ARGS] ', & ' test [[--target] NAME(s)] [--release] [--runner "CMD"] [--list] ', & ' [--compiler COMPILER_NAME] [-- ARGS] ', & ' install [--release] [--no-rebuild] [--prefix PATH] [options] ', & @@ -529,7 +550,8 @@ contains 'OPTION ', & ' --runner ''CMD'' quoted command used to launch the fpm(1) executables. ', & ' Available for both the "run" and "test" subcommands. ', & - ' ', & + ' If the keyword is specified without a value the default command ', & + ' is "echo". ', & ' -- SUFFIX_OPTIONS additional options to suffix the command CMD and executable ', & ' file names with. ', & 'EXAMPLES ', & @@ -584,7 +606,7 @@ contains ' ', & 'DESCRIPTION ', & ' fpm(1) is a package manager that helps you create Fortran projects ', & - ' from source. ', & + ' from source -- it automatically determines dependencies! ', & ' ', & ' Most significantly fpm(1) lets you draw upon other fpm(1) packages ', & ' in distributed git(1) repositories as if the packages were a basic ', & @@ -614,7 +636,7 @@ contains ' new NAME [[--lib|--src] [--app] [--test] [--example]]| ', & ' [--full|--bare][--backfill] ', & ' update [NAME(s)] [--fetch-only] [--clean] ', & - ' run [[--target] NAME(s)] [--release] [--list] [--example] ', & + ' run [[--target] NAME(s)] [--release] [--list] [--example] [--all] ', & ' [--runner "CMD"] [--compiler COMPILER_NAME] [-- ARGS] ', & ' test [[--target] NAME(s)] [--release] [--list] ', & ' [--runner "CMD"] [--compiler COMPILER_NAME] [-- ARGS] ', & @@ -686,50 +708,60 @@ contains ' run(1) - the fpm(1) subcommand to run project applications ', & ' ', & 'SYNOPSIS ', & - ' fpm run [[--target] NAME(s)][--release][--compiler COMPILER_NAME] ', & - ' [--runner "CMD"] [--example] [--list][-- ARGS] ', & + ' fpm run [[--target] NAME(s)[--release][--compiler COMPILER_NAME] ', & + ' [--runner "CMD"] [--example] [--list] [--all] [-- ARGS] ', & ' ', & ' fpm run --help|--version ', & ' ', & 'DESCRIPTION ', & - ' Run applications you have built in your fpm(1) project. ', & - ' By default applications specified in as "executable" in your package ', & - ' manifest are used, alternatively also demonstration programs under ', & - ' "example" can be used with this subcommand. ', & + ' Run the applications in your fpm(1) package. By default applications ', & + ' in /app or specified as "executable" in your "fpm.toml" manifest are ', & + ' used. Alternatively demonstration programs in example/ or specified in', & + ' the "example" section in "fpm.toml" can be executed. The applications ', & + ' are automatically rebuilt before being run if they are out of date. ', & ' ', & 'OPTIONS ', & - ' --target 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. ', & - ' --example run example programs instead of applications ', & - ' --release selects the optimized build instead of the debug ', & - ' build. ', & + ' --target NAME(s) list of application names to execute. No name is ', & + ' required if only one target exists. If no name is ', & + ' supplied and more than one candidate exists or a ', & + ' name has no match a list is produced and fpm(1) ', & + ' exits. ', & + ' ', & + ' Basic "globbing" is supported where "?" represents ', & + ' any single character and "*" represents any string. ', & + ' Note The glob string normally needs quoted to ', & + ' the special characters from shell expansion. ', & + ' --all Run all examples or applications. An alias for --target ''*''. ', & + ' --example Run example programs instead of applications. ', & + ' --release selects the optimized build instead of the debug build. ', & ' --compiler COMPILER_NAME Specify a compiler name. The default is ', & ' "gfortran" unless set by the environment ', & ' variable FPM_COMPILER. ', & ' --runner CMD A command to prefix the program execution paths with. ', & ' see "fpm help runner" for further details. ', & - ' --list list candidates instead of building or running them ', & - ' -- ARGS optional arguments to pass to the program(s). ', & - ' The same arguments are passed to all names ', & - ' specified. ', & + ' --list list pathname of candidates instead of running them. Note ', & + ' out-of-date candidates will still be rebuilt before being ', & + ' listed. ', & + ' -- ARGS optional arguments to pass to the program(s). The same ', & + ' arguments are passed to all program names specified. ', & ' ', & 'EXAMPLES ', & - ' fpm(1) "run" project applications ', & + ' fpm(1) - run or display project applications: ', & ' ', & - ' # run default programs in /app or as specified in "fpm.toml" ', & - ' fpm run ', & + ' fpm run # run a target when only one exists or list targets ', & + ' fpm run --list # list all targets, running nothing. ', & + ' fpm run --all # run all targets, no matter how many there are. ', & ' ', & - ' # run default programs in /app or as specified in "fpm.toml" ', & - ' # using the compiler command "f90". ', & + ' # run default program built or to be built with the compiler command ', & + ' # "f90". If more than one app exists a list displays and target names', & + ' # are required. ', & ' fpm run --compiler f90 ', & ' ', & - ' # run example and demonstration programs instead of the default ', & - ' # application programs (specified in "fpm.toml") ', & - ' fpm run --example ', & + ' # run example programs instead of the application programs. ', & + ' fpm run --example ''*'' ', & ' ', & ' # run a specific program and pass arguments to the command ', & - ' fpm run mytest -- -x 10 -y 20 --title "my title line" ', & + ' fpm run myprog -- -x 10 -y 20 --title "my title line" ', & ' ', & ' # run production version of two applications ', & ' fpm run --target prg1,prg2 --release ', & @@ -756,7 +788,7 @@ contains ' o src/ for modules and procedure source ', & ' o app/ main program(s) for applications ', & ' o test/ main program(s) and support files for project tests ', & - ' o example/ main program(s) for examples and demonstrations ', & + ' o example/ main program(s) for example programs ', & ' Changed or new files found are rebuilt. The results are placed in ', & ' the build/ directory. ', & ' ', & @@ -908,9 +940,9 @@ contains ' cd myproject # Enter the new directory ', & ' # and run commands such as ', & ' fpm build ', & - ' fpm run # run example application program(s) ', & + ' fpm run # run lone example application program ', & ' fpm test # run example test program(s) ', & - ' fpm run --example # run example program(s) ', & + ' fpm run --example # run lone example program ', & ' ', & ' fpm new A --full # create example/ and an annotated fpm.toml as well', & ' fpm new A --bare # create no directories ', & @@ -934,6 +966,11 @@ contains ' --target 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. ', & + ' ', & + ' Basic "globbing" is supported where "?" represents ', & + ' any single character and "*" represents any string. ', & + ' Note The glob string normally needs quoted to ', & + ' protect the special characters from shell expansion.', & ' --release selects the optimized build instead of the debug ', & ' build. ', & ' --compiler COMPILER_NAME Specify a compiler name. The default is ', & diff --git a/fpm/src/fpm_compiler.f90 b/fpm/src/fpm_compiler.f90 index ba840e6..99aa77d 100644 --- a/fpm/src/fpm_compiler.f90 +++ b/fpm/src/fpm_compiler.f90 @@ -12,7 +12,7 @@ type(fpm_model_t), intent(inout) :: model ! could just be a function to return a string instead of passing model ! but likely to change other components like matching C compiler -character(len=:),allocatable :: fflags ! optional flags that might be overridden by user +character(len=:),allocatable :: fflags ! optional flags that might be overridden by user character(len=:),allocatable :: modpath character(len=:),allocatable :: mandatory ! flags required for fpm to function properly; ! ie. add module path and module include directory as appropriate @@ -42,6 +42,24 @@ character(len=:),allocatable :: mandatory ! flags required for fpm to function p ! G95 ? ? -fmod= -I -fopenmp discontinued ! Open64 ? ? -module -I -mp discontinued ! Unisys ? ? ? ? ? discontinued +character(len=*),parameter :: names(*)=[ character(len=10) :: & +& 'caf', & +& 'gfortran', & +& 'f95', & +& 'nvfortran', & +& 'ifort', & +& 'ifx', & +& 'pgfortran', & +& 'pgf90', & +& 'pgf95', & +& 'flang', & +& 'lfc', & +& 'nagfor', & +& 'crayftn', & +& 'xlf90', & +& 'unknown'] +integer :: i + modpath=join_path(model%output_directory,model%package_name) fflags='' mandatory='' @@ -143,7 +161,6 @@ character(len=:),allocatable :: mandatory ! flags required for fpm to function p & -reentrancy threaded& & -nogen-interfaces& & -assume byterecl& - & -assume nounderscore& &' mandatory=' -module '//modpath//' -I '//modpath case('debug_ifort') @@ -219,10 +236,8 @@ character(len=:),allocatable :: mandatory ! flags required for fpm to function p case default fflags = ' ' mandatory=' -module '//modpath//' -I '//modpath - write(*,*)'<WARNING> unknown compiler (',compiler,')' - write(*,*)' and build name (',build_name,')' - write(*,*)' combination.' - write(*,*)' known compilers are gfortran, nvfortran, ifort' + write(*,'(*(a))')'<WARNING> unknown compiler (',compiler,') and build name (',build_name,') combination.' + write(*,'(a,*(T31,6(a:,", "),/))')' known compilers are ',(trim(names(i)),i=1,size(names)-1) end select model%fortran_compile_flags = fflags//' '//mandatory diff --git a/fpm/src/fpm_environment.f90 b/fpm/src/fpm_environment.f90 index 181252d..929a704 100644 --- a/fpm/src/fpm_environment.f90 +++ b/fpm/src/fpm_environment.f90 @@ -117,10 +117,19 @@ contains unix = os /= OS_WINDOWS end function os_is_unix - subroutine run(cmd) + subroutine run(cmd,echo) character(len=*), intent(in) :: cmd + logical,intent(in),optional :: echo + logical :: echo_local integer :: stat - print *, '+ ', cmd + + if(present(echo))then + echo_local=echo + else + echo_local=.true. + endif + if(echo_local) print *, '+ ', cmd + call execute_command_line(cmd, exitstat=stat) if (stat /= 0) then print *, 'Command failed' diff --git a/fpm/src/fpm_strings.f90 b/fpm/src/fpm_strings.f90 index 2b036d1..7623e43 100644 --- a/fpm/src/fpm_strings.f90 +++ b/fpm/src/fpm_strings.f90 @@ -5,7 +5,7 @@ implicit none private public :: f_string, lower, split, str_ends_with, string_t public :: string_array_contains, string_cat, len_trim, operator(.in.), fnv_1a -public :: replace, resize, str, join +public :: replace, resize, str, join, glob type string_t character(len=:), allocatable :: s @@ -383,93 +383,103 @@ subroutine resize_string(list, n) end subroutine resize_string -pure function join(str,sep,trm,left,right) result (string) - -!> M_strings::join(3f): append an array of character variables with specified separator into a single CHARACTER variable -!> -!>##NAME -!> join(3f) - [M_strings:EDITING] append CHARACTER variable array into -!> a single CHARACTER variable with specified separator -!> (LICENSE:PD) -!> -!>##SYNOPSIS -!> -!> pure function join(str,sep,trm,left,right) result (string) -!> -!> character(len=*),intent(in) :: str(:) -!> character(len=*),intent(in),optional :: sep -!> logical,intent(in),optional :: trm -!> character(len=*),intent(in),optional :: right -!> character(len=*),intent(in),optional :: left -!> character(len=:),allocatable :: string -!> -!>##DESCRIPTION -!> JOIN(3f) appends the elements of a CHARACTER array into a single -!> CHARACTER variable, with elements 1 to N joined from left to right. -!> By default each element is trimmed of trailing spaces and the -!> default separator is a null string. -!> -!>##OPTIONS -!> STR(:) array of CHARACTER variables to be joined -!> SEP separator string to place between each variable. defaults -!> to a null string. -!> LEFT string to place at left of each element -!> RIGHT string to place at right of each element -!> TRM option to trim each element of STR of trailing -!> spaces. Defaults to .TRUE. -!> -!>##RESULT -!> STRING CHARACTER variable composed of all of the elements of STR() -!> appended together with the optional separator SEP placed -!> between the elements and optional left and right elements. -!> -!>##EXAMPLE -!> -!> Sample program: -!> -!> program demo_join -!> use M_strings, only: join -!> implicit none -!> character(len=:),allocatable :: s(:) -!> character(len=:),allocatable :: out -!> integer :: i -!> s=[character(len=10) :: 'United',' we',' stand,', & -!> & ' divided',' we fall.'] -!> out=join(s) -!> write(*,'(a)') out -!> write(*,'(a)') join(s,trm=.false.) -!> write(*,'(a)') (join(s,trm=.false.,sep='|'),i=1,3) -!> write(*,'(a)') join(s,sep='<>') -!> write(*,'(a)') join(s,sep=';',left='[',right=']') -!> write(*,'(a)') join(s,left='[',right=']') -!> write(*,'(a)') join(s,left='>>') -!> end program demo_join -!> -!> Expected output: -!> -!> United we stand, divided we fall. -!> United we stand, divided we fall. -!> United | we | stand, | divided | we fall. | -!> United | we | stand, | divided | we fall. | -!> United | we | stand, | divided | we fall. | -!> United<> we<> stand,<> divided<> we fall.<> -!> [United];[ we];[ stand,];[ divided];[ we fall.]; -!> [United][ we][ stand,][ divided][ we fall.] -!> >>United>> we>> stand,>> divided>> we fall. +pure function join(str,sep,trm,left,right,start,end) result (string) !> -!>##AUTHOR -!> John S. Urban -!> -!>##LICENSE -!> Public Domain - -character(len=*),intent(in) :: str(:) -character(len=*),intent(in),optional :: sep, right, left -logical,intent(in),optional :: trm -character(len=:),allocatable :: string -integer :: i -logical :: trm_local -character(len=:),allocatable :: sep_local, left_local, right_local +!!##NAME +!! join(3f) - [fpm_strings:EDITING] append CHARACTER variable array into +!! a single CHARACTER variable with specified separator +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! pure function join(str,sep,trm,left,right,start,end) result (string) +!! +!! character(len=*),intent(in) :: str(:) +!! character(len=*),intent(in),optional :: sep +!! logical,intent(in),optional :: trm +!! character(len=*),intent(in),optional :: right +!! character(len=*),intent(in),optional :: left +!! character(len=*),intent(in),optional :: start +!! character(len=*),intent(in),optional :: end +!! character(len=:),allocatable :: string +!! +!!##DESCRIPTION +!! JOIN(3f) appends the elements of a CHARACTER array into a single +!! CHARACTER variable, with elements 1 to N joined from left to right. +!! By default each element is trimmed of trailing spaces and the +!! default separator is a null string. +!! +!!##OPTIONS +!! STR(:) array of CHARACTER variables to be joined +!! SEP separator string to place between each variable. defaults +!! to a null string. +!! LEFT string to place at left of each element +!! RIGHT string to place at right of each element +!! START prefix string +!! END suffix string +!! TRM option to trim each element of STR of trailing +!! spaces. Defaults to .TRUE. +!! +!!##RESULT +!! STRING CHARACTER variable composed of all of the elements of STR() +!! appended together with the optional separator SEP placed +!! between the elements. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_join +!! use fpm_strings, only: join +!! implicit none +!! character(len=:),allocatable :: s(:) +!! character(len=:),allocatable :: out +!! integer :: i +!! s=[character(len=10) :: 'United',' we',' stand,', & +!! & ' divided',' we fall.'] +!! out=join(s) +!! write(*,'(a)') out +!! write(*,'(a)') join(s,trm=.false.) +!! write(*,'(a)') (join(s,trm=.false.,sep='|'),i=1,3) +!! write(*,'(a)') join(s,sep='<>') +!! write(*,'(a)') join(s,sep=';',left='[',right=']') +!! write(*,'(a)') join(s,left='[',right=']') +!! write(*,'(a)') join(s,left='>>') +!! end program demo_join +!! +!! Expected output: +!! +!! United we stand, divided we fall. +!! United we stand, divided we fall. +!! United | we | stand, | divided | we fall. +!! United | we | stand, | divided | we fall. +!! United | we | stand, | divided | we fall. +!! United<> we<> stand,<> divided<> we fall. +!! [United];[ we];[ stand,];[ divided];[ we fall.] +!! [United][ we][ stand,][ divided][ we fall.] +!! >>United>> we>> stand,>> divided>> we fall. +!! +!!##AUTHOR +!! John S. Urban +!! +!!##LICENSE +!! Public Domain + +! @(#)join(3f): append an array of character variables with specified separator into a single CHARACTER variable + +character(len=*),intent(in) :: str(:) +character(len=*),intent(in),optional :: sep +character(len=*),intent(in),optional :: right +character(len=*),intent(in),optional :: left +character(len=*),intent(in),optional :: start +character(len=*),intent(in),optional :: end +logical,intent(in),optional :: trm +character(len=:),allocatable :: string +integer :: i +logical :: trm_local +character(len=:),allocatable :: sep_local +character(len=:),allocatable :: left_local +character(len=:),allocatable :: right_local if(present(sep))then ; sep_local=sep ; else ; sep_local='' ; endif if(present(trm))then ; trm_local=trm ; else ; trm_local=.true. ; endif @@ -477,14 +487,348 @@ character(len=:),allocatable :: sep_local, left_local, right_local if(present(right))then ; right_local=right ; else ; right_local='' ; endif string='' - do i = 1,size(str) + do i = 1,size(str)-1 if(trm_local)then string=string//left_local//trim(str(i))//right_local//sep_local else string=string//left_local//str(i)//right_local//sep_local endif enddo + if(trm_local)then + string=string//left_local//trim(str(i))//right_local + else + string=string//left_local//str(i)//right_local + endif + if(present(start))string=start//string + if(present(end))string=string//end end function join + +function glob(tame,wild) +!> +!!##NAME +!! glob(3f) - [fpm_strings:COMPARE] compare given string for match to +!! pattern which may contain wildcard characters +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! logical function glob(string, pattern ) +!! +!! character(len=*),intent(in) :: string +!! character(len=*),intent(in) :: pattern +!! +!!##DESCRIPTION +!! glob(3f) compares given STRING for match to PATTERN which may +!! contain wildcard characters. +!! +!! In this version to get a match the entire string must be described +!! by PATTERN. Trailing whitespace is significant, so trim the input +!! string to have trailing whitespace ignored. +!! +!!##OPTIONS +!! string the input string to test to see if it contains the pattern. +!! pattern the following simple globbing options are available +!! +!! o "?" matching any one character +!! o "*" matching zero or more characters. +!! Do NOT use adjacent asterisks. +!! o Both strings may have trailing spaces which +!! are ignored. +!! o There is no escape character, so matching strings with +!! literal question mark and asterisk is problematic. +!! +!!##EXAMPLES +!! +!! Example program +!! +!! program demo_glob +!! implicit none +!! ! This main() routine passes a bunch of test strings +!! ! into the above code. In performance comparison mode, +!! ! it does that over and over. Otherwise, it does it just +!! ! once. Either way, it outputs a passed/failed result. +!! ! +!! integer :: nReps +!! logical :: allpassed +!! integer :: i +!! allpassed = .true. +!! +!! nReps = 10000 +!! ! Can choose as many repetitions as you're expecting +!! ! in the real world. +!! nReps = 1 +!! +!! do i=1,nReps +!! ! Cases with repeating character sequences. +!! allpassed=allpassed .and. test("a*abab", "a*b", .true.) +!! !!cycle +!! allpassed=allpassed .and. test("ab", "*?", .true.) +!! allpassed=allpassed .and. test("abc", "*?", .true.) +!! allpassed=allpassed .and. test("abcccd", "*ccd", .true.) +!! allpassed=allpassed .and. test("bLah", "bLaH", .false.) +!! allpassed=allpassed .and. test("mississippi", "*sip*", .true.) +!! allpassed=allpassed .and. & +!! & test("xxxx*zzzzzzzzy*f", "xxx*zzy*f", .true.) +!! allpassed=allpassed .and. & +!! & test("xxxx*zzzzzzzzy*f", "xxxx*zzy*fffff", .false.) +!! allpassed=allpassed .and. & +!! & test("mississipissippi", "*issip*ss*", .true.) +!! allpassed=allpassed .and. & +!! & test("xxxxzzzzzzzzyf", "xxxx*zzy*fffff", .false.) +!! allpassed=allpassed .and. & +!! & test("xxxxzzzzzzzzyf", "xxxx*zzy*f", .true.) +!! allpassed=allpassed .and. test("xyxyxyzyxyz", "xy*z*xyz", .true.) +!! allpassed=allpassed .and. test("xyxyxyxyz", "xy*xyz", .true.) +!! allpassed=allpassed .and. test("mississippi", "mi*sip*", .true.) +!! allpassed=allpassed .and. test("ababac", "*abac*", .true.) +!! allpassed=allpassed .and. test("aaazz", "a*zz*", .true.) +!! allpassed=allpassed .and. test("a12b12", "*12*23", .false.) +!! allpassed=allpassed .and. test("a12b12", "a12b", .false.) +!! allpassed=allpassed .and. test("a12b12", "*12*12*", .true.) +!! +!! ! Additional cases where the '*' char appears in the tame string. +!! allpassed=allpassed .and. test("*", "*", .true.) +!! allpassed=allpassed .and. test("a*r", "a*", .true.) +!! allpassed=allpassed .and. test("a*ar", "a*aar", .false.) +!! +!! ! More double wildcard scenarios. +!! allpassed=allpassed .and. test("XYXYXYZYXYz", "XY*Z*XYz", .true.) +!! allpassed=allpassed .and. test("missisSIPpi", "*SIP*", .true.) +!! allpassed=allpassed .and. test("mississipPI", "*issip*PI", .true.) +!! allpassed=allpassed .and. test("xyxyxyxyz", "xy*xyz", .true.) +!! allpassed=allpassed .and. test("miSsissippi", "mi*sip*", .true.) +!! allpassed=allpassed .and. test("miSsissippi", "mi*Sip*", .false.) +!! allpassed=allpassed .and. test("abAbac", "*Abac*", .true.) +!! allpassed=allpassed .and. test("aAazz", "a*zz*", .true.) +!! allpassed=allpassed .and. test("A12b12", "*12*23", .false.) +!! allpassed=allpassed .and. test("a12B12", "*12*12*", .true.) +!! allpassed=allpassed .and. test("oWn", "*oWn*", .true.) +!! +!! ! Completely tame (no wildcards) cases. +!! allpassed=allpassed .and. test("bLah", "bLah", .true.) +!! +!! ! Simple mixed wildcard tests suggested by IBMer Marlin Deckert. +!! allpassed=allpassed .and. test("a", "*?", .true.) +!! +!! ! More mixed wildcard tests including coverage for false positives. +!! allpassed=allpassed .and. test("a", "??", .false.) +!! allpassed=allpassed .and. test("ab", "?*?", .true.) +!! allpassed=allpassed .and. test("ab", "*?*?*", .true.) +!! allpassed=allpassed .and. test("abc", "?**?*?", .true.) +!! allpassed=allpassed .and. test("abc", "?**?*&?", .false.) +!! allpassed=allpassed .and. test("abcd", "?b*??", .true.) +!! allpassed=allpassed .and. test("abcd", "?a*??", .false.) +!! allpassed=allpassed .and. test("abcd", "?**?c?", .true.) +!! allpassed=allpassed .and. test("abcd", "?**?d?", .false.) +!! allpassed=allpassed .and. test("abcde", "?*b*?*d*?", .true.) +!! +!! ! Single-character-match cases. +!! allpassed=allpassed .and. test("bLah", "bL?h", .true.) +!! allpassed=allpassed .and. test("bLaaa", "bLa?", .false.) +!! allpassed=allpassed .and. test("bLah", "bLa?", .true.) +!! allpassed=allpassed .and. test("bLaH", "?Lah", .false.) +!! allpassed=allpassed .and. test("bLaH", "?LaH", .true.) +!! +!! ! Many-wildcard scenarios. +!! allpassed=allpassed .and. test(& +!! &"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa& +!! &aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaab",& +!! &"a*a*a*a*a*a*aa*aaa*a*a*b",& +!! &.true.) +!! allpassed=allpassed .and. test(& +!! &"abababababababababababababababababababaacacacacacacac& +!! &adaeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& +!! &"*a*b*ba*ca*a*aa*aaa*fa*ga*b*",& +!! &.true.) +!! allpassed=allpassed .and. test(& +!! &"abababababababababababababababababababaacacacacacaca& +!! &cadaeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& +!! &"*a*b*ba*ca*a*x*aaa*fa*ga*b*",& +!! &.false.) +!! allpassed=allpassed .and. test(& +!! &"abababababababababababababababababababaacacacacacacacad& +!! &aeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& +!! &"*a*b*ba*ca*aaaa*fa*ga*gggg*b*",& +!! &.false.) +!! allpassed=allpassed .and. test(& +!! &"abababababababababababababababababababaacacacacacacacad& +!! &aeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& +!! &"*a*b*ba*ca*aaaa*fa*ga*ggg*b*",& +!! &.true.) +!! allpassed=allpassed .and. test("aaabbaabbaab", "*aabbaa*a*", .true.) +!! allpassed=allpassed .and. & +!! test("a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*",& +!! &"a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .true.) +!! allpassed=allpassed .and. test("aaaaaaaaaaaaaaaaa",& +!! &"*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .true.) +!! allpassed=allpassed .and. test("aaaaaaaaaaaaaaaa",& +!! &"*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .false.) +!! allpassed=allpassed .and. test(& +!! &"abc*abcd*abcde*abcdef*abcdefg*abcdefgh*abcdefghi*abcdefghij& +!! &*abcdefghijk*abcdefghijkl*abcdefghijklm*abcdefghijklmn",& +!! & "abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc& +!! &*abc*abc*abc*",& +!! &.false.) +!! allpassed=allpassed .and. test(& +!! &"abc*abcd*abcde*abcdef*abcdefg*abcdefgh*abcdefghi*abcdefghij& +!! &*abcdefghijk*abcdefghijkl*abcdefghijklm*abcdefghijklmn",& +!! &"abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*",& +!! &.true.) +!! allpassed=allpassed .and. test("abc*abcd*abcd*abc*abcd",& +!! &"abc*abc*abc*abc*abc", .false.) +!! allpassed=allpassed .and. test( "abc*abcd*abcd*abc*abcd*abcd& +!! &*abc*abcd*abc*abc*abcd", & +!! &"abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abcd",& +!! &.true.) +!! allpassed=allpassed .and. test("abc",& +!! &"********a********b********c********", .true.) +!! allpassed=allpassed .and.& +!! &test("********a********b********c********", "abc", .false.) +!! allpassed=allpassed .and. & +!! &test("abc", "********a********b********b********", .false.) +!! allpassed=allpassed .and. test("*abc*", "***a*b*c***", .true.) +!! +!! ! A case-insensitive algorithm test. +!! ! allpassed=allpassed .and. test("mississippi", "*issip*PI", .true.) +!! enddo +!! +!! if (allpassed)then +!! write(*,'(a)')"Passed",nReps +!! else +!! write(*,'(a)')"Failed" +!! endif +!! contains +!! ! This is a test program for wildcard matching routines. +!! ! It can be used either to test a single routine for correctness, +!! ! or to compare the timings of two (or more) different wildcard +!! ! matching routines. +!! ! +!! function test(tame, wild, bExpectedResult) result(bpassed) +!! use fpm_strings, only : glob +!! character(len=*) :: tame +!! character(len=*) :: wild +!! logical :: bExpectedResult +!! logical :: bResult +!! logical :: bPassed +!! bResult = .true. ! We'll do "&=" cumulative checking. +!! bPassed = .false. ! Assume the worst. +!! write(*,*)repeat('=',79) +!! bResult = glob(tame, wild) ! Call a wildcard matching routine. +!! +!! ! To assist correctness checking, output the two strings in any +!! ! failing scenarios. +!! if (bExpectedResult .eqv. bResult) then +!! bPassed = .true. +!! if(nReps == 1) write(*,*)"Passed match on ",tame," vs. ", wild +!! else +!! if(nReps == 1) write(*,*)"Failed match on ",tame," vs. ", wild +!! endif +!! +!! end function test +!! end program demo_glob +!! +!! Expected output +!! +!!##AUTHOR +!! John S. Urban +!! +!!##REFERENCE +!! The article "Matching Wildcards: An Empirical Way to Tame an Algorithm" +!! in Dr Dobb's Journal, By Kirk J. Krauss, October 07, 2014 +!! +!!##LICENSE +!! Public Domain + +! @(#)fpm_strings::glob(3f): function compares text strings, one of which can have wildcards ('*' or '?'). + +logical :: glob +character(len=*) :: tame ! A string without wildcards +character(len=*) :: wild ! A (potentially) corresponding string with wildcards +character(len=len(tame)+1) :: tametext +character(len=len(wild)+1) :: wildtext +character(len=1),parameter :: NULL=char(0) +integer :: wlen +integer :: ti, wi +integer :: i +character(len=:),allocatable :: tbookmark, wbookmark +! These two values are set when we observe a wildcard character. They +! represent the locations, in the two strings, from which we start once we've observed it. + tametext=tame//NULL + wildtext=wild//NULL + tbookmark = NULL + wbookmark = NULL + wlen=len(wild) + wi=1 + ti=1 + do ! Walk the text strings one character at a time. + if(wildtext(wi:wi) == '*')then ! How do you match a unique text string? + do i=wi,wlen ! Easy: unique up on it! + if(wildtext(wi:wi).eq.'*')then + wi=wi+1 + else + exit + endif + enddo + if(wildtext(wi:wi).eq.NULL) then ! "x" matches "*" + glob=.true. + return + endif + if(wildtext(wi:wi) .ne. '?') then + ! Fast-forward to next possible match. + do while (tametext(ti:ti) .ne. wildtext(wi:wi)) + ti=ti+1 + if (tametext(ti:ti).eq.NULL)then + glob=.false. + return ! "x" doesn't match "*y*" + endif + enddo + endif + wbookmark = wildtext(wi:) + tbookmark = tametext(ti:) + elseif(tametext(ti:ti) .ne. wildtext(wi:wi) .and. wildtext(wi:wi) .ne. '?') then + ! Got a non-match. If we've set our bookmarks, back up to one or both of them and retry. + if(wbookmark.ne.NULL) then + if(wildtext(wi:).ne. wbookmark) then + wildtext = wbookmark; + wlen=len_trim(wbookmark) + wi=1 + ! Don't go this far back again. + if (tametext(ti:ti) .ne. wildtext(wi:wi)) then + tbookmark=tbookmark(2:) + tametext = tbookmark + ti=1 + cycle ! "xy" matches "*y" + else + wi=wi+1 + endif + endif + if (tametext(ti:ti).ne.NULL) then + ti=ti+1 + cycle ! "mississippi" matches "*sip*" + endif + endif + glob=.false. + return ! "xy" doesn't match "x" + endif + ti=ti+1 + wi=wi+1 + if (tametext(ti:ti).eq.NULL) then ! How do you match a tame text string? + if(wildtext(wi:wi).ne.NULL)then + do while (wildtext(wi:wi) == '*') ! The tame way: unique up on it! + wi=wi+1 ! "x" matches "x*" + if(wildtext(wi:wi).eq.NULL)exit + enddo + endif + if (wildtext(wi:wi).eq.NULL)then + glob=.true. + return ! "x" matches "x" + endif + glob=.false. + return ! "x" doesn't match "xy" + endif + enddo +end function glob + pure integer function str_int_len(i) result(sz) ! Returns the length of the string representation of 'i' integer, intent(in) :: i diff --git a/fpm/test/help_test/help_test.f90 b/fpm/test/help_test/help_test.f90 index a44786c..8f0c455 100644 --- a/fpm/test/help_test/help_test.f90 +++ b/fpm/test/help_test/help_test.f90 @@ -2,6 +2,8 @@ program help_test ! note hardcoded len=k1 instead of len=: in this test is a work-around a gfortran bug in old ! pre-v8.3 versions use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit +use fpm_filesystem, only : dirname, join_path, exists +use fpm_environment, only : get_os_type, OS_WINDOWS implicit none integer :: i, j integer :: be, af @@ -11,7 +13,7 @@ integer,parameter :: k1=132 character(len=k1) :: message logical,allocatable :: tally(:) !intel-bug!character(len=:),allocatable :: book1(:), book2(:) -character(len=k1),allocatable :: book1(:), book2(:), book3(:) +character(len=k1),allocatable :: book1(:), book2(:) !intel-bug!character(len=:),allocatable :: page1(:) character(len=k1),allocatable :: page1(:) integer :: lines @@ -20,58 +22,57 @@ integer :: chars character(len=*),parameter :: cmds(*) = [character(len=80) :: & ! build manual as pieces using various help commands ! debug version -'fpm run -- --version ',& ! verify fpm version being used -'fpm run -- --help > fpm_scratch_help.txt',& -'fpm run -- help new >> fpm_scratch_help.txt',& -'fpm run -- help update >> fpm_scratch_help.txt',& -'fpm run -- build --help >> fpm_scratch_help.txt',& -'fpm run -- help run >> fpm_scratch_help.txt',& -'fpm run -- help test >> fpm_scratch_help.txt',& -'fpm run -- help runner >> fpm_scratch_help.txt',& -'fpm run -- help install >> fpm_scratch_help.txt',& -'fpm run -- help list >> fpm_scratch_help.txt',& -'fpm run -- help help >> fpm_scratch_help.txt',& -'fpm run -- --version >> fpm_scratch_help.txt',& -! release version -'fpm run --release -- --version ',& ! verify fpm version being used -'fpm run --release -- --help > fpm_scratch_help3.txt',& -'fpm run --release -- help new >> fpm_scratch_help3.txt',& -'fpm run --release -- help update >> fpm_scratch_help3.txt',& -'fpm run --release -- build --help >> fpm_scratch_help3.txt',& -'fpm run --release -- help run >> fpm_scratch_help3.txt',& -'fpm run --release -- help test >> fpm_scratch_help3.txt',& -'fpm run --release -- help runner >> fpm_scratch_help3.txt',& -'fpm run --release -- help install >> fpm_scratch_help3.txt',& -'fpm run --release -- help list >> fpm_scratch_help3.txt',& -'fpm run --release -- help help >> fpm_scratch_help3.txt',& -'fpm run --release -- --version >> fpm_scratch_help3.txt',& +' --version ',& ! verify fpm version being used +' --help > fpm_scratch_help.txt',& +' help new >> fpm_scratch_help.txt',& +' help update >> fpm_scratch_help.txt',& +' build --help >> fpm_scratch_help.txt',& +' help run >> fpm_scratch_help.txt',& +' help test >> fpm_scratch_help.txt',& +' help runner >> fpm_scratch_help.txt',& +' help install >> fpm_scratch_help.txt',& +' help list >> fpm_scratch_help.txt',& +' help help >> fpm_scratch_help.txt',& +' --version >> fpm_scratch_help.txt',& ! generate manual -'fpm run -- help manual > fpm_scratch_manual.txt'] +' help manual > fpm_scratch_manual.txt'] !'fpm run >> fpm_scratch_help.txt',& !'fpm run -- --list >> fpm_scratch_help.txt',& !'fpm run -- list --list >> fpm_scratch_help.txt',& character(len=*),parameter :: names(*)=[character(len=10) ::& 'fpm','new','update','build','run','test','runner','install','list','help'] -character(len=:),allocatable :: add +character(len=:), allocatable :: prog +integer :: length + + ! FIXME: Super hacky way to get the name of the fpm executable, + ! it works better than invoking fpm again but should be replaced ASAP. + call get_command_argument(0, length=length) + allocate(character(len=length) :: prog) + call get_command_argument(0, prog) + path = dirname(prog) + if (get_os_type() == OS_WINDOWS) then + prog = join_path(path, "..", "app", "fpm.exe") + if (.not.exists(prog)) then + prog = join_path(path, "..", "..", "app", "fpm.exe") + end if + else + prog = join_path(path, "..", "app", "fpm") + if (.not.exists(prog)) then + prog = join_path(path, "..", "..", "app", "fpm") + end if + end if write(*,'(g0:,1x)')'<INFO>TEST help SUBCOMMAND STARTED' if(allocated(tally))deallocate(tally) allocate(tally(0)) call wipe('fpm_scratch_help.txt') - call wipe('fpm_scratch_help3.txt') call wipe('fpm_scratch_manual.txt') ! check that output has NAME SYNOPSIS DESCRIPTION - do j=1,2 - if(j.eq.1)then - ADD=' ' - else - ADD=' --release ' - endif do i=1,size(names) write(*,*)'<INFO>check '//names(i)//' for NAME SYNOPSIS DESCRIPTION' - path= 'fpm run '//add//' -- help '//names(i)//' >fpm_scratch_help.txt' + path= prog // ' help '//names(i)//' >fpm_scratch_help.txt' message='' call execute_command_line(path,exitstat=estat,cmdstat=cstat,cmdmsg=message) write(*,'(*(g0))')'<INFO>CMD=',path,' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message) @@ -99,13 +100,12 @@ character(len=:),allocatable :: add write(*,*)'<INFO>have completed ',count(tally),' tests' call wipe('fpm_scratch_help.txt') enddo - enddo ! execute the fpm(1) commands do i=1,size(cmds) message='' - path= cmds(i) + path= prog // cmds(i) call execute_command_line(path,exitstat=estat,cmdstat=cstat,cmdmsg=message) write(*,'(*(g0))')'<INFO>CMD=',path,' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message) tally=[tally,all([estat.eq.0,cstat.eq.0])] @@ -114,14 +114,11 @@ character(len=:),allocatable :: add ! compare book written in fragments with manual call swallow('fpm_scratch_help.txt',book1) call swallow('fpm_scratch_manual.txt',book2) - call swallow('fpm_scratch_help3.txt',book3) ! get rid of lines from run() which is not on stderr at the moment book1=pack(book1,index(book1,' + build/').eq.0) book2=pack(book1,index(book2,' + build/').eq.0) - book3=pack(book3,index(book3,' + build/').eq.0) write(*,*)'<INFO>book1 ',size(book1), len(book1) write(*,*)'<INFO>book2 ',size(book2), len(book2) - write(*,*)'<INFO>book2 ',size(book3), len(book3) if(size(book1).ne.size(book2))then write(*,*)'<ERROR>manual and "debug" appended pages are not the same size' tally=[tally,.false.] @@ -134,18 +131,6 @@ character(len=:),allocatable :: add tally=[tally,.true.] endif endif - if(size(book3).ne.size(book2))then - write(*,*)'<ERROR>manual and "release" appended pages are not the same size' - tally=[tally,.false.] - else - if(all(book3.ne.book2))then - tally=[tally,.false.] - write(*,*)'<ERROR>manual and "release" appended pages are not the same' - else - write(*,*)'<INFO>manual and "release" appended pages are the same' - tally=[tally,.true.] - endif - endif ! overall size of manual !chars=size(book2) @@ -159,19 +144,9 @@ character(len=:),allocatable :: add write(*,*)'<INFO>"debug" manual size in bytes=',chars,' lines=',lines tally=[tally,.true.] endif - chars=sum(len_trim(book3)) ! SUM TRIMMED LENGTH - lines=size(book3) - if( (chars.lt.12000) .or. (lines.lt.350) )then - write(*,*)'<ERROR>"release" manual is suspiciously small, bytes=',chars,' lines=',lines - tally=[tally,.false.] - else - write(*,*)'<INFO>"release" manual size in bytes=',chars,' lines=',lines - tally=[tally,.true.] - endif write(*,'("<INFO>HELP TEST TALLY=",*(g0))')tally call wipe('fpm_scratch_help.txt') - call wipe('fpm_scratch_help3.txt') call wipe('fpm_scratch_manual.txt') if(all(tally))then write(*,'(*(g0))')'<INFO>PASSED: all ',count(tally),' tests passed ' diff --git a/fpm/test/new_test/new_test.f90 b/fpm/test/new_test/new_test.f90 index 4ff00c3..3c8c453 100644 --- a/fpm/test/new_test/new_test.f90 +++ b/fpm/test/new_test/new_test.f90 @@ -1,6 +1,7 @@ program new_test use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit -use fpm_filesystem, only : is_dir, list_files, exists, windows_path, join_path +use fpm_filesystem, only : is_dir, list_files, exists, windows_path, join_path, & + dirname use fpm_strings, only : string_t, operator(.in.) use fpm_environment, only : run, get_os_type use fpm_environment, only : OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_WINDOWS @@ -158,18 +159,29 @@ logical :: IS_OS_WINDOWS stop 5 endif contains - function get_command_path() result(command_path) - character(len=:), allocatable :: command_path + function get_command_path() result(prog) + character(len=:), allocatable :: prog - type(string_t), allocatable :: files(:) - integer :: i + character(len=:), allocatable :: path + integer :: length - call list_files("build", files) - do i = 1, size(files) - if (index(files(i)%s, "gfortran") > 0) then - command_path = join_path(files(i)%s, "app", "fpm") - return + ! FIXME: Super hacky way to get the name of the fpm executable, + ! it works better than invoking fpm again but should be replaced ASAP. + call get_command_argument(0, length=length) + allocate(character(len=length) :: prog) + call get_command_argument(0, prog) + path = dirname(prog) + if (get_os_type() == OS_WINDOWS) then + prog = join_path(path, "..", "app", "fpm.exe") + if (.not.exists(prog)) then + prog = join_path(path, "..", "..", "app", "fpm.exe") end if - end do + else + prog = join_path(path, "..", "app", "fpm") + if (.not.exists(prog)) then + prog = join_path(path, "..", "..", "app", "fpm") + end if + end if + end function end program new_test @@ -1,33 +1,131 @@ #!/bin/sh -set -u # error on use of undefined variable set -e # exit on error -install_path="$HOME/.local/bin" +usage() +{ + echo "Fortran Package Manager Bootstrap Script" + echo "" + echo "USAGE:" + echo "./install.sh [--help | [--prefix=PREFIX] [--update[=REF]]" + echo " [--no-openmp] [--static] [--haskell] ]" + echo "" + echo " --help Display this help text" + echo " --prefix=PREFIX Install binary in 'PREFIX/bin'" + echo " Default prefix='\$HOME/.local/bin'" + echo " --update[=REF] Update repository from latest release tag" + echo " or from git reference REF if specified" + echo " --no-openmp Don't build fpm with openmp support" + echo " --static Statically link fpm executable" + echo " (implies --no-openmp)" + echo " --haskell Only install Haskell fpm" + echo "" + echo " '--no-openmp' and '--static' do not affect the Haskell fpm" + echo " build." + echo "" +} + +PREFIX="$HOME/.local" +UPDATE=false +OMP=true +STATIC=false +HASKELL_ONLY=false + +STACK_BIN_PATH="$HOME/.local/bin" +REF=$(git describe --tag --abbrev=0) +RELEASE_FLAGS="--flag -g --flag -fbacktrace --flag -O3" + +while [ "$1" != "" ]; do + PARAM=$(echo "$1" | awk -F= '{print $1}') + VALUE=$(echo "$1" | awk -F= '{print $2}') + case $PARAM in + -h | --help) + usage + exit + ;; + --prefix) + PREFIX=$VALUE + ;; + --update) + UPDATE=true + if [ "$VALUE" != "" ]; then + REF=$VALUE + fi + ;; + --no-openmp) + OMP=false + ;; + --static) + STATIC=true + OMP=false + ;; + --haskell) + HASKELL_ONLY=true + ;; + *) + echo "ERROR: unknown parameter \"$PARAM\"" + usage + exit 1 + ;; + esac + shift +done + +set -u # error on use of undefined variable + +INSTALL_PATH="$PREFIX/bin" if command -v stack 1> /dev/null 2>&1 ; then - echo "found stack" + echo "Found stack" else echo "Haskell stack not found." - echo "Installing Haskell stack to." + echo "Installing Haskell stack" curl -sSL https://get.haskellstack.org/ | sh if command -v stack 1> /dev/null 2>&1 ; then echo "Haskell stack installation successful." else - echo "Haskell stack installation unsuccessful." + echo "ERROR: Haskell stack installation unsuccessful." exit 1 fi fi -if [ -x "$install_path/fpm" ]; then - echo "Overwriting existing fpm installation in $install_path" +if [ -x "$INSTALL_PATH/fpm" ]; then + echo "Overwriting existing fpm installation in $INSTALL_PATH" +fi + +if [ "$UPDATE" = true ]; then + git checkout "$REF" + if [ $? != 0 ]; then + echo "ERROR: Unable to checkout $REF." + exit 1 + fi fi cd bootstrap stack install -if [ -x "$install_path/fpm" ]; then - echo "fpm installed successfully to $install_path" +if [ "$STACK_BIN_PATH" != "$INSTALL_PATH" ]; then + mv "$STACK_BIN_PATH/fpm" "$INSTALL_PATH/" +fi + +if [ "$HASKELL_ONLY" = true ]; then + exit +fi + +if [ "$STATIC" = true ]; then + RELEASE_FLAGS="$RELEASE_FLAGS --flag -static" +fi + +if [ "$OMP" = true ]; then + RELEASE_FLAGS="$RELEASE_FLAGS --flag -fopenmp" +fi + +cd ../fpm +"$INSTALL_PATH/fpm" run $RELEASE_FLAGS --runner mv -- "$INSTALL_PATH/" + +if [ -x "$INSTALL_PATH/fpm" ]; then + echo "fpm installed successfully to $INSTALL_PATH" else - echo "fpm installation unsuccessful: fpm not found in $install_path" + echo "ERROR: fpm installation unsuccessful: fpm not found in $INSTALL_PATH" + exit 1 fi |