338 lines
10 KiB
Fortran
338 lines
10 KiB
Fortran
|
module options
|
||
|
|
!
|
||
|
|
! Source code copied from:
|
||
|
|
! http://fortranwiki.org/fortran/show/Command-line+arguments
|
||
|
|
!
|
||
|
|
implicit none
|
||
|
|
|
||
|
|
type option
|
||
|
|
!> Long name.
|
||
|
|
character(len=100) :: name
|
||
|
|
!> Does the option require an argument?
|
||
|
|
logical :: has_arg
|
||
|
|
!> Corresponding short name.
|
||
|
|
character :: chr
|
||
|
|
!> Description.
|
||
|
|
character(len=500) :: descr
|
||
|
|
!> Argument name, if required.
|
||
|
|
character(len=20) :: argname
|
||
|
|
contains
|
||
|
|
procedure :: print => print_opt
|
||
|
|
end type option
|
||
|
|
|
||
|
|
contains
|
||
|
|
|
||
|
|
!> Parse command line options. Options and their arguments must come before
|
||
|
|
!> all non-option arguments. Short options have the form "-X", long options
|
||
|
|
!> have the form "--XXXX..." where "X" is any character. Parsing can be
|
||
|
|
!> stopped with the option '--'.
|
||
|
|
!> The following code snippet illustrates the intended use:
|
||
|
|
!> \code
|
||
|
|
!> do
|
||
|
|
!> call getopt (..., optchar=c, ...)
|
||
|
|
!> if (stat /= 0) then
|
||
|
|
!> ! optional error handling
|
||
|
|
!> exit
|
||
|
|
!> end if
|
||
|
|
!> select case (c)
|
||
|
|
!> ! process options
|
||
|
|
!> end select
|
||
|
|
!> end do
|
||
|
|
!> \endcode
|
||
|
|
subroutine getopt (options, longopts, optchar, optarg, arglen, stat, &
|
||
|
|
offset, remain, err)
|
||
|
|
use iso_fortran_env, only: error_unit
|
||
|
|
|
||
|
|
!> String containing the characters that are valid short options. If
|
||
|
|
!> present, command line arguments are scanned for those options.
|
||
|
|
!> If a character is followed by a colon (:) its corresponding option
|
||
|
|
!> requires an argument. E.g. "vn:" defines two options -v and -n with -n
|
||
|
|
!> requiring an argument.
|
||
|
|
character(len=*), intent(in), optional :: options
|
||
|
|
|
||
|
|
!> Array of long options. If present, options of the form '--XXXX...' are
|
||
|
|
!> recognised. Each option has an associated option character. This can be
|
||
|
|
!> any character of default kind, it is just an identifier. It can, but
|
||
|
|
!> doesn't have to, match any character in the options argument. In fact it
|
||
|
|
!> is possible to only pass long options and no short options at all.
|
||
|
|
!> Only name, has_arg and chr need to be set.
|
||
|
|
type(option), intent(in), optional :: longopts(:)
|
||
|
|
|
||
|
|
!> If stat is not 1, optchar contains the option character that was parsed.
|
||
|
|
!> Otherwise its value is undefined.
|
||
|
|
character, intent(out), optional :: optchar
|
||
|
|
|
||
|
|
!> If stat is 0 and the parsed option requires an argument, optarg contains
|
||
|
|
!> the first len(optarg) (but at most 500) characters of that argument.
|
||
|
|
!> Otherwise its value is undefined. If the arguments length exceeds 500
|
||
|
|
!> characters and err is .true., a warning is issued.
|
||
|
|
character(len=*), intent(out), optional :: optarg
|
||
|
|
|
||
|
|
!> If stat is 0 and the parsed option requires an argument, arglen contains
|
||
|
|
!> the actual length of that argument. Otherwise its value is undefined.
|
||
|
|
!> This can be used to make sure the argument was not truncated by the
|
||
|
|
!> limited length of optarg.
|
||
|
|
integer, intent(out), optional :: arglen
|
||
|
|
|
||
|
|
!> Status indicator. Can have the following values:
|
||
|
|
!> - 0: An option was successfully parsed.
|
||
|
|
!> - 1: Parsing stopped successfully because a non-option or '--' was
|
||
|
|
!> encountered.
|
||
|
|
!> - -1: An unrecognised option was encountered.
|
||
|
|
!> - -2: A required argument was missing.
|
||
|
|
!> .
|
||
|
|
!> Its value is never undefined.
|
||
|
|
integer, intent(out), optional :: stat
|
||
|
|
|
||
|
|
!> If stat is 1, offset contains the number of the argument before the
|
||
|
|
!> first non-option argument, i.e. offset+n is the nth non-option argument.
|
||
|
|
!> If stat is not 1, offset contains the number of the argument that would
|
||
|
|
!> be parsed in the next call to getopt. This number can be greater than
|
||
|
|
!> the actual number of arguments.
|
||
|
|
integer, intent(out), optional :: offset
|
||
|
|
|
||
|
|
!> If stat is 1, remain contains the number of remaining non-option
|
||
|
|
!> arguments, i.e. the non-option arguments are in the range
|
||
|
|
!> (offset+1:offset+remain). If stat is not 1, remain is undefined.
|
||
|
|
integer, intent(out), optional :: remain
|
||
|
|
|
||
|
|
!> If err is present and .true., getopt prints messages to the standard
|
||
|
|
!> error unit if an error is encountered (i.e. whenever stat would be set
|
||
|
|
!> to a negative value).
|
||
|
|
logical, intent(in), optional :: err
|
||
|
|
|
||
|
|
integer, save :: pos = 1, cnt = 0
|
||
|
|
character(len=500), save :: arg
|
||
|
|
|
||
|
|
integer :: chrpos, length, st, id = 0
|
||
|
|
character :: chr
|
||
|
|
logical :: long
|
||
|
|
|
||
|
|
if (cnt == 0) cnt = command_argument_count()
|
||
|
|
long = .false.
|
||
|
|
|
||
|
|
! no more arguments left
|
||
|
|
if (pos > cnt) then
|
||
|
|
pos = pos - 1
|
||
|
|
st = 1
|
||
|
|
goto 10
|
||
|
|
end if
|
||
|
|
|
||
|
|
call get_command_argument (pos, arg, length)
|
||
|
|
|
||
|
|
! is argument an option?
|
||
|
|
if (arg(1:1) == '-') then
|
||
|
|
|
||
|
|
chr = arg(2:2)
|
||
|
|
|
||
|
|
! too long ('-xxxx...') for one dash?
|
||
|
|
if (chr /= '-' .and. len_trim(arg) > 2) then
|
||
|
|
st = -1
|
||
|
|
goto 10
|
||
|
|
end if
|
||
|
|
|
||
|
|
! forced stop ('--')
|
||
|
|
if (chr == '-' .and. arg(3:3) == ' ') then
|
||
|
|
st = 1
|
||
|
|
goto 10
|
||
|
|
end if
|
||
|
|
|
||
|
|
! long option ('--xxx...')
|
||
|
|
if (chr == '-') then
|
||
|
|
|
||
|
|
long = .true.
|
||
|
|
|
||
|
|
! check if valid
|
||
|
|
id = lookup(arg(3:))
|
||
|
|
|
||
|
|
! option is invalid, stop
|
||
|
|
if (id == 0) then
|
||
|
|
st = -1
|
||
|
|
goto 10
|
||
|
|
end if
|
||
|
|
|
||
|
|
chr = longopts(id)%chr
|
||
|
|
|
||
|
|
! check if option requires an argument
|
||
|
|
if (.not. longopts(id)%has_arg) then
|
||
|
|
st = 0
|
||
|
|
goto 10
|
||
|
|
end if
|
||
|
|
|
||
|
|
! check if there are still arguments left
|
||
|
|
if (pos == cnt) then
|
||
|
|
st = -2
|
||
|
|
goto 10
|
||
|
|
end if
|
||
|
|
|
||
|
|
! go to next position
|
||
|
|
pos = pos + 1
|
||
|
|
|
||
|
|
! get argument
|
||
|
|
call get_command_argument (pos, arg, length)
|
||
|
|
|
||
|
|
! make sure it is not an option
|
||
|
|
if (arg(1:1) == '-') then
|
||
|
|
st = -2
|
||
|
|
pos = pos - 1
|
||
|
|
goto 10
|
||
|
|
end if
|
||
|
|
|
||
|
|
end if
|
||
|
|
|
||
|
|
! short option
|
||
|
|
! check if valid
|
||
|
|
if (present(options)) then
|
||
|
|
chrpos = scan(options, chr)
|
||
|
|
else
|
||
|
|
chrpos = 0
|
||
|
|
end if
|
||
|
|
|
||
|
|
! option is invalid, stop
|
||
|
|
if (chrpos == 0) then
|
||
|
|
st = -1
|
||
|
|
goto 10
|
||
|
|
end if
|
||
|
|
|
||
|
|
! look for argument requirement
|
||
|
|
if (chrpos < len_trim(options)) then
|
||
|
|
if (options(chrpos+1:chrpos+1) == ':') then
|
||
|
|
|
||
|
|
! check if there are still arguments left
|
||
|
|
if (pos == cnt) then
|
||
|
|
st = -2
|
||
|
|
goto 10
|
||
|
|
end if
|
||
|
|
|
||
|
|
! go to next position
|
||
|
|
pos = pos + 1
|
||
|
|
|
||
|
|
! get argument
|
||
|
|
call get_command_argument (pos, arg, length)
|
||
|
|
|
||
|
|
! make sure it is not an option
|
||
|
|
if (arg(1:1) == '-') then
|
||
|
|
st = -2
|
||
|
|
pos = pos - 1
|
||
|
|
goto 10
|
||
|
|
end if
|
||
|
|
|
||
|
|
end if
|
||
|
|
end if
|
||
|
|
|
||
|
|
! if we get to this point, no error happened
|
||
|
|
! return option and the argument (if there is one)
|
||
|
|
st = 0
|
||
|
|
goto 10
|
||
|
|
end if
|
||
|
|
|
||
|
|
! not an option, parsing stops
|
||
|
|
st = 1
|
||
|
|
! we are already at the first non-option argument
|
||
|
|
! go one step back to the last option or option argument
|
||
|
|
pos = pos - 1
|
||
|
|
|
||
|
|
|
||
|
|
! error handling and setting of return values
|
||
|
|
10 continue
|
||
|
|
|
||
|
|
if (present(err)) then
|
||
|
|
if (err) then
|
||
|
|
|
||
|
|
select case (st)
|
||
|
|
case (-1)
|
||
|
|
write (error_unit, *) "error: unrecognised option: " // trim(arg)
|
||
|
|
case (-2)
|
||
|
|
if (.not. long) then
|
||
|
|
write (error_unit, *) "error: option -" // chr &
|
||
|
|
// " requires an argument"
|
||
|
|
else
|
||
|
|
write (error_unit, *) "error: option --" &
|
||
|
|
// trim(longopts(id)%name) // " requires an argument"
|
||
|
|
end if
|
||
|
|
end select
|
||
|
|
|
||
|
|
end if
|
||
|
|
end if
|
||
|
|
|
||
|
|
if (present(optchar)) optchar = chr
|
||
|
|
if (present(optarg)) optarg = arg
|
||
|
|
if (present(arglen)) arglen = length
|
||
|
|
if (present(stat)) stat = st
|
||
|
|
if (present(offset)) offset = pos
|
||
|
|
if (present(remain)) remain = cnt-pos
|
||
|
|
|
||
|
|
! setup pos for next call to getopt
|
||
|
|
pos = pos + 1
|
||
|
|
|
||
|
|
contains
|
||
|
|
|
||
|
|
integer function lookup (name)
|
||
|
|
character(len=*), intent(in) :: name
|
||
|
|
integer :: i
|
||
|
|
|
||
|
|
! if there are no long options, skip the loop
|
||
|
|
if (.not. present(longopts)) goto 10
|
||
|
|
|
||
|
|
do i = 1, size(longopts)
|
||
|
|
if (name == longopts(i)%name) then
|
||
|
|
lookup = i
|
||
|
|
return
|
||
|
|
end if
|
||
|
|
end do
|
||
|
|
! if we get to this point, the option was not found
|
||
|
|
|
||
|
|
10 lookup = 0
|
||
|
|
end function lookup
|
||
|
|
|
||
|
|
end subroutine getopt
|
||
|
|
|
||
|
|
!============================================================================
|
||
|
|
|
||
|
|
!> Print an option in the style of a man page. I.e.
|
||
|
|
!> \code
|
||
|
|
!> -o arg
|
||
|
|
!> --option arg
|
||
|
|
!> description.................................................................
|
||
|
|
!> ............................................................................
|
||
|
|
!> \endcode
|
||
|
|
subroutine print_opt (opt, unit)
|
||
|
|
!> the option
|
||
|
|
class(option), intent(in) :: opt
|
||
|
|
!> logical unit number
|
||
|
|
integer, intent(in) :: unit
|
||
|
|
|
||
|
|
integer :: l, c1, c2
|
||
|
|
|
||
|
|
if (opt%has_arg) then
|
||
|
|
write (unit, '(1x,"-",a,1x,a)') opt%chr, trim(opt%argname)
|
||
|
|
write (unit, '(1x,"--",a,1x,a)') trim(opt%name), trim(opt%argname)
|
||
|
|
else
|
||
|
|
write (unit, '(1x,"-",a)') opt%chr
|
||
|
|
write (unit, '(1x,"--",a)') trim(opt%name)
|
||
|
|
end if
|
||
|
|
l = len_trim(opt%descr)
|
||
|
|
|
||
|
|
! c1 is the first character of the line
|
||
|
|
! c2 is one past the last character of the line
|
||
|
|
c1 = 1
|
||
|
|
do
|
||
|
|
if (c1 > l) exit
|
||
|
|
! print at maximum 4+76 = 80 characters
|
||
|
|
c2 = min(c1 + 76, 500)
|
||
|
|
! if not at the end of the whole string
|
||
|
|
if (c2 /= 500) then
|
||
|
|
! find the end of a word
|
||
|
|
do
|
||
|
|
if (opt%descr(c2:c2) == ' ') exit
|
||
|
|
c2 = c2-1
|
||
|
|
end do
|
||
|
|
end if
|
||
|
|
write (unit, '(4x,a)') opt%descr(c1:c2-1)
|
||
|
|
c1 = c2+1
|
||
|
|
end do
|
||
|
|
|
||
|
|
end subroutine print_opt
|
||
|
|
|
||
|
|
end module options
|