Merge pull request #484 from urbanjost/master

alpha plugins, take III

3 files changed, 269 insertions, 24 deletions

diff --git a/src/fpm_command_line.f90 b/src/fpm_command_line.f90
index f44bcd0..d324b97 100644
--- a/src/fpm_command_line.f90
+++ b/src/fpm_command_line.f90
@@ -27,8 +27,10 @@ use fpm_environment,  only : get_os_type, get_env, &
                              OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, &
                              OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD
 use M_CLI2,           only : set_args, lget, sget, unnamed, remaining, specified
+use M_CLI2,           only : get_subcommand, CLI_RESPONSE_FILE
 use fpm_strings,      only : lower, split, fnv_1a
-use fpm_filesystem,   only : basename, canon_path, to_fortran_name
+use fpm_filesystem,   only : basename, canon_path, to_fortran_name, which
+use fpm_environment,  only : run, get_command_arguments_quoted
 use fpm_compiler, only : get_default_compile_flags
 use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, &
                                        & stdout=>output_unit, &
@@ -144,11 +146,8 @@ contains
          &  os_type]
         ! find the subcommand name by looking for first word on command
         ! not starting with dash
-        cmdarg=' '
-        do i = 1, command_argument_count()
-           call get_command_argument(i, cmdarg)
-           if(adjustl(cmdarg(1:1)) .ne. '-')exit
-        enddo
+        CLI_RESPONSE_FILE=.true.
+        cmdarg = get_subcommand()
 
         common_args = '--directory:C " " '
 
@@ -446,25 +445,29 @@ contains
 
         case default
 
-            call set_args(common_args // '&
-            & --list F&
-            & --verbose F&
-            &', help_fpm, version_text)
-            ! Note: will not get here if --version or --usage or --help
-            ! is present on commandline
-            help_text=help_usage
-            if(lget('list'))then
-               help_text=help_list_dash
-            elseif(len_trim(cmdarg).eq.0)then
-                write(stdout,'(*(a))')'Fortran Package Manager:'
-                write(stdout,'(*(a))')' '
-                call printhelp(help_list_nodash)
+            if(which('fpm-'//cmdarg).ne.'')then
+                call run('fpm-'//trim(cmdarg)//' '// get_command_arguments_quoted(),.false.)
             else
-                write(stderr,'(*(a))')'<ERROR> unknown subcommand [', &
-                 & trim(cmdarg), ']'
-                call printhelp(help_list_dash)
+                call set_args('&
+                & --list F&
+                & --verbose F&
+                &', help_fpm, version_text)
+                ! Note: will not get here if --version or --usage or --help
+                ! is present on commandline
+                help_text=help_usage
+                if(lget('list'))then
+                   help_text=help_list_dash
+                elseif(len_trim(cmdarg).eq.0)then
+                    write(stdout,'(*(a))')'Fortran Package Manager:'
+                    write(stdout,'(*(a))')' '
+                    call printhelp(help_list_nodash)
+                else
+                    write(stderr,'(*(a))')'<ERROR> unknown subcommand [', &
+                     & trim(cmdarg), ']'
+                    call printhelp(help_list_dash)
+                endif
+                call printhelp(help_text)
             endif
-            call printhelp(help_text)
 
         end select
 
@@ -666,7 +669,7 @@ contains
     '  + run   Run the local package binaries. defaults to all binaries for ', &
     '          that release.                                                ', &
     '  + test  Run the tests.                                               ', &
-    '  + help  Alternate method for displaying subcommand help.             ', &
+    '  + help  Alternate to the --help switch for displaying help text.     ', &
     '  + list  Display brief descriptions of all subcommands.               ', &
     '  + install Install project                                            ', &
     '                                                                       ', &
@@ -709,6 +712,37 @@ contains
     '  --verbose  Display additional information when available             ', &
     '  --version  Show version information and exit.                        ', &
     '                                                                       ', &
+    '@file                                                                  ', &
+    '   You may replace the default options for the fpm(1) command from a   ', &
+    '   file if your first options begin with @file. Initial options will   ', &
+    '   then be read from the "response file" "file.rsp" in the current     ', &
+    '   directory.                                                          ', &
+    '                                                                       ', &
+    '   If "file" does not exist or cannot be read, then an error occurs and', &
+    '   the program stops.  Each line of the file is prefixed with "options"', &
+    '   and interpreted as a separate argument. The file itself may not     ', &
+    '   contain @file arguments. That is, it is not processed recursively.  ', &
+    '                                                                       ', &
+    '   For more information on response files see                          ', &
+    '                                                                       ', &
+    '      https://urbanjost.github.io/M_CLI2/set_args.3m_cli2.html         ', &
+    '                                                                       ', &
+    '   The basic functionality described here will remain the same, but    ', &
+    '   other features described at the above reference may change.         ', &
+    '                                                                       ', &
+    '   An example file:                                                    ', &
+    '                                                                       ', &
+    '     # my build options                                                ', &
+    '     options build                                                     ', &
+    '     options --compiler gfortran                                       ', &
+    '     options --flag "-pg -static -pthread -Wunreachable-code -Wunused \', &
+    '      -Wuninitialized -g -O -fbacktrace -fdump-core -fno-underscoring \', &
+    '      -frecord-marker=4 -L/usr/X11R6/lib -L/usr/X11R6/lib64 -lX11"     ', &
+    '                                                                       ', &
+    '   Note --flag would have to be on one line as response files do not   ', &
+    '   (currently) allow for continued lines or multiple specifications of ', &
+    '   the same option.                                                    ', &
+    '                                                                       ', &
     'EXAMPLES                                                               ', &
     '   sample commands:                                                    ', &
     '                                                                       ', &
diff --git a/src/fpm_environment.f90 b/src/fpm_environment.f90
index 345f6ab..3754166 100644
--- a/src/fpm_environment.f90
+++ b/src/fpm_environment.f90
@@ -3,6 +3,9 @@
 !! * [get_os_type] -- Determine the OS type
 !! * [get_env] -- return the value of an environment variable
 module fpm_environment
+    use,intrinsic :: iso_fortran_env, only : stdin=>input_unit,   &
+                                           & stdout=>output_unit, &
+                                           & stderr=>error_unit
     implicit none
     private
     public :: get_os_type
@@ -10,6 +13,8 @@ module fpm_environment
     public :: run
     public :: get_env
     public :: get_archiver
+    public :: get_command_arguments_quoted
+    public :: separator
 
     integer, parameter, public :: OS_UNKNOWN = 0
     integer, parameter, public :: OS_LINUX   = 1
@@ -210,4 +215,127 @@ contains
             end if
         end associate
     end function
+    function get_command_arguments_quoted() result(args)
+    character(len=:),allocatable :: args
+    character(len=:),allocatable :: arg
+    character(len=1)             :: quote
+    integer                      :: ilength, istatus, i
+    ilength=0
+    args=''
+        quote=merge('"',"'",separator().eq.'\')
+        do i=2,command_argument_count() ! look at all arguments after subcommand
+            call get_command_argument(number=i,length=ilength,status=istatus)
+            if(istatus /= 0) then
+                write(stderr,'(*(g0,1x))')'<ERROR>*get_command_arguments_stack* error obtaining argument ',i
+                exit
+            else
+                if(allocated(arg))deallocate(arg)
+                allocate(character(len=ilength) :: arg)
+                call get_command_argument(number=i,value=arg,length=ilength,status=istatus)
+                if(istatus /= 0) then
+                    write(stderr,'(*(g0,1x))')'<ERROR>*get_command_arguments_stack* error obtaining argument ',i
+                    exit
+                elseif(ilength.gt.0)then
+                    if(index(arg//' ','-').ne.1)then
+                        args=args//quote//arg//quote//' '
+                    else
+                        args=args//arg//' '
+                    endif
+                else
+                    args=args//repeat(quote,2)//' '
+                endif
+             endif
+         enddo
+    end function get_command_arguments_quoted
+
+function separator() result(sep)
+!>
+!!##NAME
+!!    separator(3f) - [M_io:ENVIRONMENT] try to determine pathname directory separator character
+!!    (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!!    function separator() result(sep)
+!!
+!!     character(len=1) :: sep
+!!
+!!##DESCRIPTION
+!!    First using the name the program was invoked with, then the name
+!!    returned by an INQUIRE(3f) of that name, then ".\NAME" and "./NAME"
+!!    try to determine the separator character used to separate directory
+!!    names from file basenames.
+!!
+!!    If a slash or backslash is not found in the name, the environment
+!!    variable PATH is examined first for a backslash, then a slash.
+!!
+!!    Can be very system dependent. If the queries fail the default returned
+!!    is "/".
+!!
+!!##EXAMPLE
+!!
+!!   sample usage
+!!
+!!    program demo_separator
+!!    use M_io, only : separator
+!!    implicit none
+!!       write(*,*)'separator=',separator()
+!!    end program demo_separator
+
+! use the pathname returned as arg0 to determine pathname separator
+implicit none
+character(len=:),allocatable :: arg0
+integer                      :: arg0_length
+integer                      :: istat
+logical                      :: existing
+character(len=1)             :: sep
+!*ifort_bug*!character(len=1),save        :: sep_cache=' '
+character(len=4096)          :: name
+character(len=:),allocatable :: fname
+
+   !*ifort_bug*!   if(sep_cache.ne.' ')then  ! use cached value. NOTE:  A parallel code might theoretically use multiple OS
+   !*ifort_bug*!      sep=sep_cache
+   !*ifort_bug*!      return
+   !*ifort_bug*!   endif
+
+   arg0_length=0
+   name=' '
+   call get_command_argument(0,length=arg0_length,status=istat)
+   if(allocated(arg0))deallocate(arg0)
+   allocate(character(len=arg0_length) :: arg0)
+   call get_command_argument(0,arg0,status=istat)
+   ! check argument name
+   if(index(arg0,'\').ne.0)then
+      sep='\'
+   elseif(index(arg0,'/').ne.0)then
+      sep='/'
+   else
+      ! try name returned by INQUIRE(3f)
+      existing=.false.
+      name=' '
+      inquire(file=arg0,iostat=istat,exist=existing,name=name)
+      if(index(name,'\').ne.0)then
+         sep='\'
+      elseif(index(name,'/').ne.0)then
+         sep='/'
+      else
+         ! well, try some common syntax and assume in current directory
+         fname='.\'//arg0
+         inquire(file=fname,iostat=istat,exist=existing)
+         if(existing)then
+            sep='\'
+         else
+            fname='./'//arg0
+            inquire(file=fname,iostat=istat,exist=existing)
+            if(existing)then
+               sep='/'
+            else ! check environment variable PATH
+               sep=merge('\','/',index(get_env('PATH'),'\').ne.0)
+               !*!write(*,*)'<WARNING>unknown system directory path separator'
+            endif
+         endif
+      endif
+   endif
+   !*ifort_bug*!sep_cache=sep
+end function separator
 end module fpm_environment
diff --git a/src/fpm_filesystem.f90 b/src/fpm_filesystem.f90
index c9c97dd..486e989 100644
--- a/src/fpm_filesystem.f90
+++ b/src/fpm_filesystem.f90
@@ -5,15 +5,18 @@ use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit,
     use fpm_environment, only: get_os_type, &
                                OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, &
                                OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD
+    use fpm_environment, only: separator, get_env
     use fpm_strings, only: f_string, replace, string_t, split
     implicit none
     private
     public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, read_lines, list_files, env_variable, &
             mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file, to_fortran_name
     public :: fileopen, fileclose, filewrite, warnwrite, parent_dir
+    public :: which
 
     integer, parameter :: LINE_BUFFER_LEN = 1000
 
+
 contains
 
 
@@ -618,4 +621,84 @@ pure function to_fortran_name(string) result(res)
     res = replace(string, SPECIAL_CHARACTERS, '_')
 end function to_fortran_name
 
+function which(command) result(pathname)
+!>
+!!##NAME
+!!     which(3f) - [M_io:ENVIRONMENT] given a command name find the pathname by searching
+!!                 the directories in the environment variable $PATH
+!!     (LICENSE:PD)
+!!
+!!##SYNTAX
+!!   function which(command) result(pathname)
+!!
+!!    character(len=*),intent(in)  :: command
+!!    character(len=:),allocatable :: pathname
+!!
+!!##DESCRIPTION
+!!    Given a command name find the first file with that name in the directories
+!!    specified by the environment variable $PATH.
+!!
+!!##OPTIONS
+!!    COMMAND   the command to search for
+!!
+!!##RETURNS
+!!    PATHNAME  the first pathname found in the current user path. Returns blank
+!!              if the command is not found.
+!!
+!!##EXAMPLE
+!!
+!!   Sample program:
+!!
+!!   Checking the error message and counting lines:
+!!
+!!     program demo_which
+!!     use M_io, only : which
+!!     implicit none
+!!        write(*,*)'ls is ',which('ls')
+!!        write(*,*)'dir is ',which('dir')
+!!        write(*,*)'install is ',which('install')
+!!     end program demo_which
+!!
+!!##AUTHOR
+!!    John S. Urban
+!!##LICENSE
+!!    Public Domain
+
+character(len=*),intent(in)     :: command
+character(len=:),allocatable    :: pathname, checkon, paths(:), exts(:)
+integer                         :: i, j
+   pathname=''
+   call split(get_env('PATH'),paths,delimiters=merge(';',':',separator().eq.'\'))
+   SEARCH: do i=1,size(paths)
+      checkon=trim(join_path(trim(paths(i)),command))
+      select case(separator())
+      case('/')
+         if(exists(checkon))then
+            pathname=checkon
+            exit SEARCH
+         endif
+      case('\')
+         if(exists(checkon))then
+            pathname=checkon
+            exit SEARCH
+         endif
+         if(exists(checkon//'.bat'))then
+            pathname=checkon//'.bat'
+            exit SEARCH
+         endif
+         if(exists(checkon//'.exe'))then
+            pathname=checkon//'.exe'
+            exit SEARCH
+         endif
+         call split(get_env('PATHEXT'),exts,delimiters=';')
+         do j=1,size(exts)
+            if(exists(checkon//'.'//trim(exts(j))))then
+               pathname=checkon//'.'//trim(exts(j))
+               exit SEARCH
+            endif
+         enddo
+      end select
+   enddo SEARCH
+end function which
+
 end module fpm_filesystem