Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- module options
- 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
- 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
- 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
- end subroutine
- !============================================================================
- !> 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
- type(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
- end module
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement