Skip to content

Commit 87a2cbf

Browse files
LKedwardLKedward
authored
Merge pull request #484 from urbanjost/master
alpha plugins, take III
2 parents 845217f + 6fc695f commit 87a2cbf

File tree

4 files changed

+270
-25
lines changed

4 files changed

+270
-25
lines changed

‎fpm.toml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,7 @@ rev = "2f5eaba864ff630ba0c3791126a3f811b6e437f3"
1212

1313
[dependencies.M_CLI2]
1414
git = "https://github.com/urbanjost/M_CLI2.git"
15-
rev = "e59fb2bfcf36199f1af506f937b3849180454a0f"
15+
rev = "1f3b922ce35f105d1a51869bed9a1013b5b552b6"
1616

1717
[[test]]
1818
name = "cli-test"

‎src/fpm_command_line.f90‎

Lines changed: 58 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -27,8 +27,10 @@ module fpm_command_line
2727
OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, &
2828
OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD
2929
use M_CLI2, only : set_args, lget, sget, unnamed, remaining, specified
30+
use M_CLI2, only : get_subcommand, CLI_RESPONSE_FILE
3031
use fpm_strings, only : lower, split, fnv_1a
31-
use fpm_filesystem, only : basename, canon_path, to_fortran_name
32+
use fpm_filesystem, only : basename, canon_path, to_fortran_name, which
33+
use fpm_environment, only : run, get_command_arguments_quoted
3234
use fpm_compiler, only : get_default_compile_flags
3335
use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, &
3436
& stdout=>output_unit, &
@@ -144,11 +146,8 @@ subroutine get_command_line_settings(cmd_settings)
144146
& os_type]
145147
! find the subcommand name by looking for first word on command
146148
! not starting with dash
147-
cmdarg=' '
148-
do i = 1, command_argument_count()
149-
call get_command_argument(i, cmdarg)
150-
if(adjustl(cmdarg(1:1)) .ne. '-')exit
151-
enddo
149+
CLI_RESPONSE_FILE=.true.
150+
cmdarg = get_subcommand()
152151

153152
common_args = '--directory:C " " '
154153

@@ -446,25 +445,29 @@ subroutine get_command_line_settings(cmd_settings)
446445

447446
case default
448447

449-
call set_args(common_args // '&
450-
& --list F&
451-
& --verbose F&
452-
&', help_fpm, version_text)
453-
! Note: will not get here if --version or --usage or --help
454-
! is present on commandline
455-
help_text=help_usage
456-
if(lget('list'))then
457-
help_text=help_list_dash
458-
elseif(len_trim(cmdarg).eq.0)then
459-
write(stdout,'(*(a))')'Fortran Package Manager:'
460-
write(stdout,'(*(a))')' '
461-
call printhelp(help_list_nodash)
448+
if(which('fpm-'//cmdarg).ne.'')then
449+
call run('fpm-'//trim(cmdarg)//' '// get_command_arguments_quoted(),.false.)
462450
else
463-
write(stderr,'(*(a))')'<ERROR> unknown subcommand [', &
464-
& trim(cmdarg), ']'
465-
call printhelp(help_list_dash)
451+
call set_args('&
452+
& --list F&
453+
& --verbose F&
454+
&', help_fpm, version_text)
455+
! Note: will not get here if --version or --usage or --help
456+
! is present on commandline
457+
help_text=help_usage
458+
if(lget('list'))then
459+
help_text=help_list_dash
460+
elseif(len_trim(cmdarg).eq.0)then
461+
write(stdout,'(*(a))')'Fortran Package Manager:'
462+
write(stdout,'(*(a))')' '
463+
call printhelp(help_list_nodash)
464+
else
465+
write(stderr,'(*(a))')'<ERROR> unknown subcommand [', &
466+
& trim(cmdarg), ']'
467+
call printhelp(help_list_dash)
468+
endif
469+
call printhelp(help_text)
466470
endif
467-
call printhelp(help_text)
468471

469472
end select
470473

@@ -666,7 +669,7 @@ subroutine set_help()
666669
' + run Run the local package binaries. defaults to all binaries for ', &
667670
' that release. ', &
668671
' + test Run the tests. ', &
669-
' + help Alternate method for displaying subcommand help. ', &
672+
' + help Alternate to the --help switch for displaying help text. ', &
670673
' + list Display brief descriptions of all subcommands. ', &
671674
' + install Install project ', &
672675
' ', &
@@ -709,6 +712,37 @@ subroutine set_help()
709712
' --verbose Display additional information when available ', &
710713
' --version Show version information and exit. ', &
711714
' ', &
715+
'@file ', &
716+
' You may replace the default options for the fpm(1) command from a ', &
717+
' file if your first options begin with @file. Initial options will ', &
718+
' then be read from the "response file" "file.rsp" in the current ', &
719+
' directory. ', &
720+
' ', &
721+
' If "file" does not exist or cannot be read, then an error occurs and', &
722+
' the program stops. Each line of the file is prefixed with "options"', &
723+
' and interpreted as a separate argument. The file itself may not ', &
724+
' contain @file arguments. That is, it is not processed recursively. ', &
725+
' ', &
726+
' For more information on response files see ', &
727+
' ', &
728+
' https://urbanjost.github.io/M_CLI2/set_args.3m_cli2.html ', &
729+
' ', &
730+
' The basic functionality described here will remain the same, but ', &
731+
' other features described at the above reference may change. ', &
732+
' ', &
733+
' An example file: ', &
734+
' ', &
735+
' # my build options ', &
736+
' options build ', &
737+
' options --compiler gfortran ', &
738+
' options --flag "-pg -static -pthread -Wunreachable-code -Wunused \', &
739+
' -Wuninitialized -g -O -fbacktrace -fdump-core -fno-underscoring \', &
740+
' -frecord-marker=4 -L/usr/X11R6/lib -L/usr/X11R6/lib64 -lX11" ', &
741+
' ', &
742+
' Note --flag would have to be on one line as response files do not ', &
743+
' (currently) allow for continued lines or multiple specifications of ', &
744+
' the same option. ', &
745+
' ', &
712746
'EXAMPLES ', &
713747
' sample commands: ', &
714748
' ', &

‎src/fpm_environment.f90‎

Lines changed: 128 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,13 +3,18 @@
33
!! * [get_os_type] -- Determine the OS type
44
!! * [get_env] -- return the value of an environment variable
55
module fpm_environment
6+
use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, &
7+
& stdout=>output_unit, &
8+
& stderr=>error_unit
69
implicit none
710
private
811
public :: get_os_type
912
public :: os_is_unix
1013
public :: run
1114
public :: get_env
1215
public :: get_archiver
16+
public :: get_command_arguments_quoted
17+
public :: separator
1318

1419
integer, parameter, public :: OS_UNKNOWN = 0
1520
integer, parameter, public :: OS_LINUX = 1
@@ -210,4 +215,127 @@ function get_archiver() result(archiver)
210215
end if
211216
end associate
212217
end function
218+
function get_command_arguments_quoted() result(args)
219+
character(len=:),allocatable :: args
220+
character(len=:),allocatable :: arg
221+
character(len=1) :: quote
222+
integer :: ilength, istatus, i
223+
ilength=0
224+
args=''
225+
quote=merge('"',"'",separator().eq.'\')
226+
do i=2,command_argument_count() ! look at all arguments after subcommand
227+
call get_command_argument(number=i,length=ilength,status=istatus)
228+
if(istatus /= 0) then
229+
write(stderr,'(*(g0,1x))')'<ERROR>*get_command_arguments_stack* error obtaining argument ',i
230+
exit
231+
else
232+
if(allocated(arg))deallocate(arg)
233+
allocate(character(len=ilength) :: arg)
234+
call get_command_argument(number=i,value=arg,length=ilength,status=istatus)
235+
if(istatus /= 0) then
236+
write(stderr,'(*(g0,1x))')'<ERROR>*get_command_arguments_stack* error obtaining argument ',i
237+
exit
238+
elseif(ilength.gt.0)then
239+
if(index(arg//' ','-').ne.1)then
240+
args=args//quote//arg//quote//' '
241+
else
242+
args=args//arg//' '
243+
endif
244+
else
245+
args=args//repeat(quote,2)//' '
246+
endif
247+
endif
248+
enddo
249+
end function get_command_arguments_quoted
250+
251+
function separator() result(sep)
252+
!>
253+
!!##NAME
254+
!! separator(3f) - [M_io:ENVIRONMENT] try to determine pathname directory separator character
255+
!! (LICENSE:PD)
256+
!!
257+
!!##SYNOPSIS
258+
!!
259+
!! function separator() result(sep)
260+
!!
261+
!! character(len=1) :: sep
262+
!!
263+
!!##DESCRIPTION
264+
!! First using the name the program was invoked with, then the name
265+
!! returned by an INQUIRE(3f) of that name, then ".\NAME" and "./NAME"
266+
!! try to determine the separator character used to separate directory
267+
!! names from file basenames.
268+
!!
269+
!! If a slash or backslash is not found in the name, the environment
270+
!! variable PATH is examined first for a backslash, then a slash.
271+
!!
272+
!! Can be very system dependent. If the queries fail the default returned
273+
!! is "/".
274+
!!
275+
!!##EXAMPLE
276+
!!
277+
!! sample usage
278+
!!
279+
!! program demo_separator
280+
!! use M_io, only : separator
281+
!! implicit none
282+
!! write(*,*)'separator=',separator()
283+
!! end program demo_separator
284+
285+
! use the pathname returned as arg0 to determine pathname separator
286+
implicit none
287+
character(len=:),allocatable :: arg0
288+
integer :: arg0_length
289+
integer :: istat
290+
logical :: existing
291+
character(len=1) :: sep
292+
!*ifort_bug*!character(len=1),save :: sep_cache=' '
293+
character(len=4096) :: name
294+
character(len=:),allocatable :: fname
295+
296+
!*ifort_bug*! if(sep_cache.ne.' ')then ! use cached value. NOTE: A parallel code might theoretically use multiple OS
297+
!*ifort_bug*! sep=sep_cache
298+
!*ifort_bug*! return
299+
!*ifort_bug*! endif
300+
301+
arg0_length=0
302+
name=' '
303+
call get_command_argument(0,length=arg0_length,status=istat)
304+
if(allocated(arg0))deallocate(arg0)
305+
allocate(character(len=arg0_length) :: arg0)
306+
call get_command_argument(0,arg0,status=istat)
307+
! check argument name
308+
if(index(arg0,'\').ne.0)then
309+
sep='\'
310+
elseif(index(arg0,'/').ne.0)then
311+
sep='/'
312+
else
313+
! try name returned by INQUIRE(3f)
314+
existing=.false.
315+
name=' '
316+
inquire(file=arg0,iostat=istat,exist=existing,name=name)
317+
if(index(name,'\').ne.0)then
318+
sep='\'
319+
elseif(index(name,'/').ne.0)then
320+
sep='/'
321+
else
322+
! well, try some common syntax and assume in current directory
323+
fname='.\'//arg0
324+
inquire(file=fname,iostat=istat,exist=existing)
325+
if(existing)then
326+
sep='\'
327+
else
328+
fname='./'//arg0
329+
inquire(file=fname,iostat=istat,exist=existing)
330+
if(existing)then
331+
sep='/'
332+
else ! check environment variable PATH
333+
sep=merge('\','/',index(get_env('PATH'),'\').ne.0)
334+
!*!write(*,*)'<WARNING>unknown system directory path separator'
335+
endif
336+
endif
337+
endif
338+
endif
339+
!*ifort_bug*!sep_cache=sep
340+
end function separator
213341
end module fpm_environment

‎src/fpm_filesystem.f90‎

Lines changed: 83 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,15 +5,18 @@ module fpm_filesystem
55
use fpm_environment, only: get_os_type, &
66
OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, &
77
OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD
8+
use fpm_environment, only: separator, get_env
89
use fpm_strings, only: f_string, replace, string_t, split
910
implicit none
1011
private
1112
public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, read_lines, list_files, env_variable, &
1213
mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file, to_fortran_name
1314
public :: fileopen, fileclose, filewrite, warnwrite, parent_dir
15+
public :: which
1416

1517
integer, parameter :: LINE_BUFFER_LEN = 1000
1618

19+
1720
contains
1821

1922

@@ -618,4 +621,84 @@ pure function to_fortran_name(string) result(res)
618621
res = replace(string, SPECIAL_CHARACTERS, '_')
619622
end function to_fortran_name
620623

624+
function which(command) result(pathname)
625+
!>
626+
!!##NAME
627+
!! which(3f) - [M_io:ENVIRONMENT] given a command name find the pathname by searching
628+
!! the directories in the environment variable $PATH
629+
!! (LICENSE:PD)
630+
!!
631+
!!##SYNTAX
632+
!! function which(command) result(pathname)
633+
!!
634+
!! character(len=*),intent(in) :: command
635+
!! character(len=:),allocatable :: pathname
636+
!!
637+
!!##DESCRIPTION
638+
!! Given a command name find the first file with that name in the directories
639+
!! specified by the environment variable $PATH.
640+
!!
641+
!!##OPTIONS
642+
!! COMMAND the command to search for
643+
!!
644+
!!##RETURNS
645+
!! PATHNAME the first pathname found in the current user path. Returns blank
646+
!! if the command is not found.
647+
!!
648+
!!##EXAMPLE
649+
!!
650+
!! Sample program:
651+
!!
652+
!! Checking the error message and counting lines:
653+
!!
654+
!! program demo_which
655+
!! use M_io, only : which
656+
!! implicit none
657+
!! write(*,*)'ls is ',which('ls')
658+
!! write(*,*)'dir is ',which('dir')
659+
!! write(*,*)'install is ',which('install')
660+
!! end program demo_which
661+
!!
662+
!!##AUTHOR
663+
!! John S. Urban
664+
!!##LICENSE
665+
!! Public Domain
666+
667+
character(len=*),intent(in) :: command
668+
character(len=:),allocatable :: pathname, checkon, paths(:), exts(:)
669+
integer :: i, j
670+
pathname=''
671+
call split(get_env('PATH'),paths,delimiters=merge(';',':',separator().eq.'\'))
672+
SEARCH: do i=1,size(paths)
673+
checkon=trim(join_path(trim(paths(i)),command))
674+
select case(separator())
675+
case('/')
676+
if(exists(checkon))then
677+
pathname=checkon
678+
exit SEARCH
679+
endif
680+
case('\')
681+
if(exists(checkon))then
682+
pathname=checkon
683+
exit SEARCH
684+
endif
685+
if(exists(checkon//'.bat'))then
686+
pathname=checkon//'.bat'
687+
exit SEARCH
688+
endif
689+
if(exists(checkon//'.exe'))then
690+
pathname=checkon//'.exe'
691+
exit SEARCH
692+
endif
693+
call split(get_env('PATHEXT'),exts,delimiters=';')
694+
do j=1,size(exts)
695+
if(exists(checkon//'.'//trim(exts(j))))then
696+
pathname=checkon//'.'//trim(exts(j))
697+
exit SEARCH
698+
endif
699+
enddo
700+
end select
701+
enddo SEARCH
702+
end function which
703+
621704
end module fpm_filesystem

0 commit comments

Comments
 (0)