diff options
| -rw-r--r-- | fpm/src/fpm.f90 | 109 | ||||
| -rw-r--r-- | fpm/src/fpm_command_line.f90 | 103 | ||||
| -rw-r--r-- | fpm/src/fpm_environment.f90 | 13 | ||||
| -rw-r--r-- | fpm/src/fpm_strings.f90 | 520 |
4 files changed, 585 insertions, 160 deletions
diff --git a/fpm/src/fpm.f90 b/fpm/src/fpm.f90 index 105fca7..1c937d0 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 @@ -213,8 +213,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 @@ -224,6 +223,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 @@ -269,7 +270,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 @@ -298,15 +299,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(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:' @@ -326,36 +373,24 @@ subroutine cmd_run(settings,test) j = j + 1 end if - end if - end do - write(stderr,*) - stop 1 - - end if - - call build_package(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 subroutine compact_list_all - 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_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 |