Initial Commit
This commit is contained in:
Jordan Sherer
@@ -0,0 +1,337 @@
|
||||
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
|
||||
Reference in New Issue
Block a user