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