Fortran Wiki
getopt_long_module

This is not well tested. I intended to finish it when allocatable-length strings became generally available.

This is based on Sun’s getopt_long, and include the Sun CLIP specification, which requires matching short and long versions of all options,s.

Precise getopt functionality is not really desirable. The biggest drawback of getopt is the use of globals. (It was designed a long time ago.) This interface uses OOP with a derived-type data object,

module getopt_long_module
public
integer, parameter :: max_option_len = 15

! return values 
character(len=1), parameter :: GETOPT_STATUS_BADCH = '?'
character(len=1), parameter :: GETOPT_STATUS_BADARG = ':'
character(len=1), parameter :: GETOPT_STATUS_INORDER = char(1)
character(len=1), parameter :: GETOPT_STATUS_END = char(255)
character(len=1), parameter :: GETOPT_STATUS_NIL = char(0)

! long options argument flag:
integer, parameter :: GETOPT_NO_ARG = 0
integer, parameter :: GETOPT_REQ_ARG = 1
integer, parameter :: GETOPT_OPT_ARG = 2

! Behavior flags:
integer, parameter :: GETOPT_FLAG_PERMUTE             = int(z'01') ! Permute non-optstring to the end of argv 
integer, parameter :: GETOPT_FLAG_ALLARGS             = int(z'02') ! Treat non-optstring as args to option INORDER
integer, parameter :: GETOPT_FLAG_LONGONLY            = int(z'04') ! Operate as getopt_long_only() 
integer, parameter :: GETOPT_FLAG_OPTIONAL_ARGS       = int(z'08') ! Support optional arguments in optstring 
integer, parameter :: GETOPT_FLAG_REQUIRE_EQUIVALENTS = int(z'10') ! Require short<->long equivalents 
integer, parameter :: GETOPT_FLAG_ABBREV              = int(z'20') ! Support long option abbreviations
integer, parameter :: GETOPT_FLAG_W_SEMICOLON         = int(z'40') ! Support W; in optstring 
integer, parameter :: GETOPT_FLAG_PLUS_DASH_START     = int(z'80') ! Support leading '+' or '-' in optstring 

integer, parameter :: GETOPT_FLAGS_GNU = &
         GETOPT_FLAG_PERMUTE + GETOPT_FLAG_OPTIONAL_ARGS + GETOPT_FLAG_ABBREV + &
         GETOPT_FLAG_W_SEMICOLON + GETOPT_FLAG_PLUS_DASH_START

integer, parameter :: GETOPT_FLAGS_POSIX = &
         GETOPT_FLAG_ABBREV  !?  + GETOPT_FLAG_PLUS_DASH_START

integer, parameter :: GETOPT_FLAGS_DEFAULT = &
         GETOPT_FLAG_PERMUTE + GETOPT_FLAG_ABBREV + GETOPT_FLAG_PLUS_DASH_START

integer, parameter :: GETOPT_FLAGS_LONG = &
         GETOPT_FLAG_PERMUTE + GETOPT_FLAG_OPTIONAL_ARGS + GETOPT_FLAG_ABBREV + &
         GETOPT_FLAG_W_SEMICOLON + GETOPT_FLAG_PLUS_DASH_START

integer, parameter :: GETOPT_FLAGS_LONG_ONLY = &
         GETOPT_FLAGS_LONG + GETOPT_FLAG_LONGONLY

integer, parameter :: GETOPT_FLAGS_SUN_CLIP = &
         GETOPT_FLAG_W_SEMICOLON + GETOPT_FLAG_REQUIRE_EQUIVALENTS
! GETOPT_FLAGS_SUN_CLIP behaves as Sun's getopt_clip() --
!  Parse argc/argv argument vector, requiring compliance with
!   Sun's CLIP specification (11/12/02)
! o Does not allow arguments to be optional (optional_argument is
!   treated as required_argument).
! o Does not allow long optstring to be abbreviated on the command line
! o Does not allow long argument to be preceded by a single dash
!   (Double-dash '--' is required)
! o Stops option processing at the first non-option
! o Requires that every long option have a short-option (single
!   character) equivalent and vice-versa. If a short option or
!   long option without an equivalent is found, an error message
!   is printed and -1 is returned on the first call, and errno
!   is set to EINVAL.
! o Leading + or - in optstring is ignored, and opstring is
!   treated as if it began after the + or - .
!
! It does support the special "W;" in optstring
!================================================================================
type getopt_option_type
  character(len=max_option_len) :: name
  integer :: has_arg = GETOPT_NO_ARG
  character(len=1), pointer :: flag => NULL() ! Reference to user's flag variable
  character(len=1) :: val = char(0)
end type getopt_option_type

type getopt_string_type
  character(len=1), allocatable :: string(:)
end type getopt_string_type

type getopt_type
! private:
  character(len=1), pointer :: place(:) ! => empty_string_array
  integer :: nonopt_start != -1; ! first non option argument (for permute) 
  integer :: nonopt_end != -1;   ! first option after non optstring (for permute) 
  logical :: posixly_correct ! = .false.
  integer :: flags
  character(len=512), pointer :: optstring ! should be (len=*)
  integer :: optstring_len
  type(getopt_option_type), pointer :: long_opts(:) ! reference to user's longopts array
! public:
  integer :: argc
  type(getopt_string_type), allocatable :: argv(:)
  integer :: index ! = 0
  logical :: error ! = .false.
  character(len=1), pointer :: optarg(:) ! => NULL()
  character(len=1) :: opt ! = char(0) == GETOPT_STATUS_NIL
end type getopt_type

character(len=1), target :: empty_string_array(0)
!================================================================================
interface warn
  module procedure warn_string, warn_char_array
end interface warn

private :: warn, warn_string, warn_char_array

private :: permute_args, parse_longopts

!================================================================================
contains

subroutine getopt_new(self, optstring, long_opts, flags, status)
  implicit none
  type(getopt_type), pointer :: self
  character(len=*), intent(in), target :: optstring
  type(getopt_option_type), intent(in), target, optional :: long_opts(:)
  integer, intent(in), optional :: flags
  integer, intent(out), optional :: status

  intrinsic :: command_argument_count, &
               get_command_argument, &
               get_environment_variable
  integer :: i, arglen

  allocate(self)
  self%optarg => NULL()
  self%place => empty_string_array
  self%nonopt_start = -1
  self%nonopt_end = -1
  self%index = 1
  self%error = .false.
  self%opt = GETOPT_STATUS_NIL

  if (present(flags)) then
    self%flags = flags
  else if (present(long_opts)) then
    self%flags = GETOPT_FLAGS_LONG
  else
    self%flags = GETOPT_FLAGS_DEFAULT
  end if

! Disable GNU extensions if ENV{POSIXLY_CORRECT} is set.
! If optstring begins with a '+' or '-', and the option flags
! enable this feature, the caller chooses POSIX correctness.
  self%posixly_correct = ( i <= 0 )
  self%optstring => optstring(1:len(self%optstring))
  self%optstring_len=len(optstring)
  if (iand(self%flags,GETOPT_FLAG_PLUS_DASH_START)/=0) then
    select case(optstring(1:1))
    case('+')
      self%posixly_correct = .true.
      self%optstring => optstring(2:)
      self%optstring_len=len(optstring)-1
    case('-')
      self%posixly_correct = .false.
      self%optstring => optstring(2:)
      self%optstring_len=len(optstring)-1
      self%flags = ior(self%flags,GETOPT_FLAG_ALLARGS)
    case default
      self%posixly_correct = ( i <= 0 )
    end select
  else
  end if

  if (self%posixly_correct) then
    self%flags = iand(self%flags,not( &
          GETOPT_FLAG_PERMUTE + GETOPT_FLAG_ALLARGS + GETOPT_FLAG_OPTIONAL_ARGS ))
  end if
  self%optarg => NULL()

!-------------------------------------------------------------------------
! EXTENSION: Sun's CLIP specification (11/12/02)
! This option requires a matching long and short version for every option.
  if ((self%index == 1) .and. iand(self%flags,GETOPT_FLAG_REQUIRE_EQUIVALENTS)/=0) then
    if (.not. verify_short_long_equivalents()) then
      if (.not. present(status)) stop 'Error in getopt_long() arguments'
      deallocate(self)
      status=.false.
      return
    end if
  end if
!-------------------------------------------------------------------------

  self%argc=command_argument_count()
  allocate(self%argv(0:self%argc))
  do i=0,self%argc
    call get_command_argument(i,length=arglen)
    allocate(self%argv(i)%string(arglen))
    call get_command_argument(i,self%argv(i)%string(1)(1:arglen))
  end do
  if (present(status)) status=.true.
  return

contains

! Verify that each short option (character flag) has a long equivalent,
! and that each long option has a short option equivalent. Note that
! multiple long optstring can map to the same character.
! This behavior is defined by Sun's CLIP specification (11/12/02).
!
! If error output is enabled and an error is found, this function
! prints ONE error message (the first error found) and returns an
! error value.
! ASSUMES: optstring is present and long_opts is optional
! Returns .TRUE. on success
  logical &
  function verify_short_long_equivalents() result(ok)
    implicit none
    !accessed by host association:
    !type(getopt_type), pointer :: self
    !character(len=*), intent(in) :: optstring
    !type(getopt_option_type), intent(in), optional :: long_opts(:)
    !integer, intent(in) :: flags

    integer :: i
    character(len=1) :: ch
    ch = GETOPT_STATUS_NIL

  ! Find a long option for each short option
    i=1
    do while ( ok .and. (i<=len(optstring)))
      ch = optstring(i:i)
      if (ch == ':') then
        i=i+1
        cycle
      end if

  ! 'W;' is a special case, if GETOPT_FLAG_W_SEMICOLON is set:
      if (iand(flags,GETOPT_FLAG_W_SEMICOLON)/=0 .and. &
        (ch == 'W') .and. (optstring(i+1:i+1) == ';')) then
        i=i+2
        cycle
      end if

      if (associated(self%long_opts)) then
        ok=any(ch==self%long_opts(:)%val)
      else
        ok=.false.
      end if
      if (.not.ok) then
        call warn(self,"equivalent long option required",ch)
        return
      end if

      i=i+1
    end do

  ! Find a short option for each long option.
    if (associated(self%long_opts)) then
      do i=1,size(self%long_opts)
        ok = (self%long_opts(i)%val /= GETOPT_STATUS_NIL .and. &
            index(optstring, self%long_opts(i)%val) > 0)
        if (.not. ok) then
          call warn(self,"equivalent short option required",self%long_opts(i)%name)
          return
        end if
      end do
    end if
    ok=.true.
    return
  end function verify_short_long_equivalents
end subroutine getopt_new

!----------------------------------------------------------------------
! Public interface procedures:
character(len=getopt_argv_len(self,argn)) &
function getopt_argv(self,argn) result(argv)
  implicit none
  type(getopt_type), pointer :: self
  integer, intent(in) :: argn
  argv = self%argv(argn)%string(1)(1:len(argv))
end function getopt_argv

! getopt() --
!  Parse argc/argv argument vector.  Called by user level routines.
! This implements all of the getopt variants, depending on flag bits.
character(len=1) &
function getopt(self, longindex) result(retval)
  implicit none
  type(getopt_type), pointer :: self
  integer, intent(out), optional :: longindex

  integer :: option_letter_index
  character(len=1) :: optchar
  logical :: short_too

  if (.not. allocated(self%argv)) then
    retval = GETOPT_STATUS_END
    return
  end if

  self%optarg => NULL()
  self%opt = GETOPT_STATUS_NIL
write(*,*)'index=',self%index
NEXT_ARG: do
    if (self%index==0 .or. size(self%place)==0) then    ! update scanning pointer 
      if (self%index > ubound(self%argv,1)) then    ! end of argument vector 
        self%place => empty_string_array
        if (self%nonopt_end /= -1) then
! do permutation, if we have to 
          self%index = self%index - (self%nonopt_end - self%nonopt_start)

        else if (self%nonopt_start /= -1) then
! If we skipped non-optstring, set self%index
! to the first of them.
          self%index = self%nonopt_start
        end if
        self%nonopt_start = -1
        self%nonopt_end = -1
        retval = GETOPT_STATUS_END
        return
      end if
      self%place => self%argv(self%index)%string
      if (self%place(1) /= '-' .or. size(self%place,1)<2 ) then
        self%place => empty_string_array  ! found non-option
        write(*,*) 'found non-option at ',self%index
        if (iand(self%flags,GETOPT_FLAG_ALLARGS)/=0) then
! GNU extension:
! return non-option as argument to option char(1)
          self%index=self%index+1
          self%optarg => self%argv(self%index)%string
          retval = GETOPT_STATUS_INORDER
          return
        end if
        if (iand(self%flags,GETOPT_FLAG_PERMUTE)==0) then
! If no permutation wanted, stop parsing
! at first non-option.
          retval = GETOPT_STATUS_END
          return
        end if
! do permutation 
        if (self%nonopt_start == -1) then
          self%nonopt_start = self%index
        else if (self%nonopt_end /= -1) then
          self%nonopt_start = self%index - (self%nonopt_end - self%nonopt_start)
          self%nonopt_end = -1
        end if
        self%index = self%index + 1
! process next argument 
        cycle NEXT_ARG
      end if
      if (self%nonopt_start /= -1 .and. self%nonopt_end == -1) &
        self%nonopt_end = self%index

! Check for "--" or "--foo" with no long optstring
! but if self%place is simply "-" leave it unmolested.
      if (size(self%place)>1) then
        self%place=>self%place(2:)
        if (self%place(1) == '-' .and. &
           (size(self%place)==1 .or. .not. associated(self%long_opts))) then
          self%index = self%index + 1
          self%place => empty_string_array
! We found an option (--), so if we skipped
! non-optstring, we have to permute.
          if (self%nonopt_end /= -1) then
            self%index = self%index - (self%nonopt_end - self%nonopt_start)
          end if
          self%nonopt_start = -1
          self%nonopt_end = -1
          retval = GETOPT_STATUS_END
          return
        end if
      end if
    end if
    exit NEXT_ARG
  end do NEXT_ARG

! Check long optstring if:
!  1) we were passed some
!  2) the arg is not just "-"
!  3) either the arg starts with -- or we are getopt_long_only()
!if (self%long_opts /= NULL .and. self%place /= self%argv[self%index] && (*self%place == '-' .or. (GETOPT_FLAG_IS_SET(GETOPT_FLAG_LONGONLY)))) then

  if (associated(self%long_opts) .and. &
      (.not. associated(self%place,self%argv(self%index)%string)) .and. &
      (self%place(1) == '-' .or. iand(self%flags,GETOPT_FLAG_LONGONLY)/=0)) then
    short_too = .false.
    if (self%place(1) == '-') then
      self%place => self%place(2:)  ! --foo long option 
    else if (self%place(1) /= ':' .and. index(self%optstring, self%place(1)) > 0) then
      short_too = .true.    ! could be short option too 
    end if

    optchar = parse_longopts(self, longindex, short_too)
    if (optchar /= GETOPT_STATUS_END) then
      self%place => empty_string_array
      retval = optchar
      return
    end if
  end if

  optchar = self%place(1)
  self%place => self%place(2:)
  option_letter_index = index(self%optstring(1:self%optstring_len), optchar)
  if (optchar == ':' .or. option_letter_index==0) then
! If the user didn't specify '-' as an option,
! assume it means GETOPT_STATUS_END (-1) as POSIX specifies.
    if (optchar == '-') then
      retval = GETOPT_STATUS_END
      return
    end if
! option letter unknown or ':' 
    if (size(self%place)==0) self%index=self%index+1
    if ((self%error) .and. self%optstring(1:1) /= ':') then
    end if
    self%opt = optchar
    retval = GETOPT_STATUS_BADCH
    return
  end if

! -W long-option 
  if (iand(self%flags,GETOPT_FLAG_W_SEMICOLON)/=0 &
      .and. associated(self%long_opts) &
      .and. optchar == 'W' &
      .and. self%optstring(option_letter_index:option_letter_index) == ';') then
    if (size(self%place)>0) then
      self%index=self%index+1
      if (self%index > ubound(self%argv,1)) then  ! no long-option after -W 
        self%place => empty_string_array
        if ((self%error) .and. self%optstring(1:1) /= ':') then
        end if
        self%opt = optchar
        retval = merge(GETOPT_STATUS_BADARG,GETOPT_STATUS_BADCH,self%optstring(1:1)==':')
        return
      else      ! white space 
        self%place => self%argv(self%index)%string
      end if
    end if
    optchar = parse_longopts(self, longindex, .false.)

! PSARC 2003/645 - Match GNU behavior, set self%optarg to
! the long-option.
    if (.not. associated(self%optarg)) then
      self%optarg => self%argv(self%index-1)%string
    end if
    self%place => empty_string_array
    retval = optchar
    return
  end if

  option_letter_index=option_letter_index+1
  if (self%optstring(option_letter_index:option_letter_index) /= ':') then ! no ':' suffix: doesn't take argument 
    if (size(self%place)==0) self%index=self%index+1
  else        ! ':' or '::' suffix: takes (optional) argument 
    self%optarg => NULL()
    if (size(self%place)>0) then  ! arg value joined (no white space)
      self%optarg => self%place
! XXX: disable test for :: if PC? (GNU doesn't) 
    else if (iand(self%flags,GETOPT_FLAG_OPTIONAL_ARGS)==0 .and. &
          self%optstring(option_letter_index+1:option_letter_index+1) == ':') then
! arg is required (not optional) 
      self%index=self%index+1
      if (self%index > ubound(self%argv,1)) then  ! no arg 
        self%place => empty_string_array
        if ((self%error) .and. self%optstring(1:1) /= ':') then
        end if
        self%opt = optchar
        retval = merge(GETOPT_STATUS_BADARG,GETOPT_STATUS_BADCH,self%optstring(1:1)==':')
        return
      else
        self%optarg => self%argv(self%index)%string
      end if
    end if
    self%place => empty_string_array
    self%index=self%index+1
  end if
! return valid option letter 
  self%opt = optchar  ! preserve getopt() behavior 
  retval = optchar
  return
end function getopt

!----------------------------------------------------------------------
pure integer &
function getopt_argv_len(self,argn) result(len)
  implicit none
  type(getopt_type), pointer :: self
  integer, intent(in) :: argn
  if (.not. allocated(self%argv)) then
    len = 0
  else if ( (argn < 0) .or. (argn > ubound(self%argv,1)) ) then
    len = 0
  else
    len = size(self%argv(argn)%string)
  end if
end function getopt_argv_len

!----------------------------------------------------------------------
! Private procedures:
subroutine warn_string(self, msg, arg)
  implicit none
  type(getopt_type), pointer :: self
  character(len=*), intent(in) :: msg, arg
  if (self%error .and. self%optstring(1:1) /= ':') then 
    write(0,"(A,': ',A,' -- ',A)") &
        self%argv(0)%string(1)(1:ubound(self%argv(0)%string,1)), &
        msg, trim(arg)
  end if
end subroutine warn_string

subroutine warn_char_array(self, msg, arg)
  implicit none
  type(getopt_type), pointer :: self
  character(len=*), intent(in) :: msg
  character(len=1), intent(in) :: arg(:)
  if (self%error .and. self%optstring(1:1) /= ':') then 
    write(0,"(A,': ',A,' -- ',100A1)") &
        self%argv(0)%string(1)(1:ubound(self%argv(0)%string,1)), &
        msg, arg
  end if
end subroutine warn_char_array

subroutine permute_args(self)
  implicit none
  type(getopt_type), pointer :: self

  integer :: cstart, cyclelen, i, j, ncycle, nnonopts, nopts, pos
  character(len=1), allocatable :: swap(:)

  if (.not. allocated(self%argv)) return

! compute lengths of blocks and number and size of cycles
  nnonopts = self%nonopt_end - self%nonopt_start
  nopts = self%index - self%nonopt_end
  ncycle = gcd(nnonopts, nopts)
  cyclelen = (self%index - self%nonopt_start) / ncycle

  do i=1,ncycle
    cstart = self%nonopt_end+i
    pos = cstart
    do j=0,cyclelen-1
      if (pos >= self%nonopt_end) then
        pos = pos - nnonopts
      else
        pos = pos + nopts
      end if

      allocate(swap(size(self%argv(pos)%string)))

      swap = self%argv(pos)%string
      deallocate(self%argv(pos)%string)
      allocate(self%argv(pos)%string(size(self%argv(cstart)%string)))
      self%argv(pos)%string = self%argv(cstart)%string

      deallocate(self%argv(cstart)%string)
      allocate(self%argv(cstart)%string(size(swap)))
      self%argv(cstart)%string = swap

      deallocate(swap)
    end do
  end do
contains
! Compute the greatest common divisor of a and b.
  integer function gcd(aval, bval)
    integer, intent(in) :: aval, bval
    integer :: a,b,c
    a = aval
    b = bval
    c = modulo(a,b)
    do while (c /= 0)
      a = b
      b = c
      c = modulo(a,b)
    end do
    gcd = b
  end function gcd
end subroutine permute_args

! parse_longopts --
!  Parse long optstring in argc/argv argument vector.
! Returns -1 if short_too is set and the option does not match self%long_opts.
character(len=1) &
function parse_longopts(self, longindex, short_too) result(retval)
  implicit none
  type(getopt_type), pointer :: self
  integer, intent(inout), optional :: longindex
  logical, intent(in) :: short_too

  character(len=1), pointer :: current_argv(:)
  character(len=1), pointer :: argv_equal_ptr(:)
  integer :: current_argv_len
  integer :: long_option_len
  integer :: i
  integer :: match
  logical :: longopt_requires_arg
  integer :: argv_equal_index

  current_argv => NULL()
  current_argv_len = 0
  long_option_len = 0
  i = 0
  match = 0
  current_argv => self%place
  match = -1

  self%index=self%index+1

  argv_equal_index = index(current_argv(1)(1:size(current_argv)), '=')
  if (argv_equal_index>0) then
! argument found (--option=arg) 
    current_argv_len = argv_equal_index - 1
    argv_equal_ptr => current_argv(argv_equal_index+1:)
  else
    current_argv_len = size(current_argv)
    argv_equal_ptr => NULL()
  end if

! find matching long option 
  do i=1,size(self%long_opts)
    long_option_len = len_trim(self%long_opts(i)%name)
    if (long_option_len < current_argv_len) cycle
    if (current_argv(1)(1:current_argv_len) /= self%long_opts(i)%name(1:current_argv_len)) cycle

    if (iand(self%flags,GETOPT_FLAG_ABBREV)==0 .and. &
        long_option_len > current_argv_len) then
      cycle  ! Abbreviations are disabled 
    end if

    if (long_option_len == current_argv_len) then
! exact match 
      match = i
      exit
    end if

! If this is a known short option, don't allow
! a partial match of a single character.
    if (short_too .and. current_argv_len == 1) cycle

    if (match == -1) then ! first partial match 
      match = i
    else ! ambiguous abbreviation 
      if (self%error .and. self%optstring(1:1) /= ':') then
      end if
      self%opt = GETOPT_STATUS_NIL
      retval = GETOPT_STATUS_BADCH
      return
    end if
  end do

  if (match /= -1) then    ! option found 
    if (self%long_opts(match)%has_arg == GETOPT_NO_ARG .and. &
        associated(argv_equal_ptr)) then
      if (self%error .and. self%optstring(1:1) /= ':') then
      end if
! XXX: GNU sets self%opt to val regardless of flag
      if (.not. associated(self%long_opts(match)%flag)) then
        self%opt = self%long_opts(match)%val
      else
        self%opt = GETOPT_STATUS_NIL
      end if
      retval = merge(GETOPT_STATUS_BADARG,GETOPT_STATUS_BADCH,self%optstring(1:1)==':')
      return
    end if

    longopt_requires_arg = &
        ( self%long_opts(match)%has_arg == GETOPT_OPT_ARG &
        .and.  iand(self%flags,GETOPT_FLAG_OPTIONAL_ARGS) == 0 ) &
        .or. self%long_opts(match)%has_arg == GETOPT_REQ_ARG

    if (self%long_opts(match)%has_arg == GETOPT_REQ_ARG .or. &
        self%long_opts(match)%has_arg == GETOPT_OPT_ARG) then
      if (associated(argv_equal_ptr)) then
        self%optarg => argv_equal_ptr
      else if (longopt_requires_arg) then
! The next argv must be the option argument 
        if (self%index <= ubound(self%argv,1)) then
          self%optarg => self%argv(self%index)%string
        end if
        self%index=self%index+1 ! code below depends on this 
      end if
    end if

    if (longopt_requires_arg .and. .not. associated(self%optarg)) then
! Missing argument; leading ':' indicates no error
! should be generated.
      if ((self%error) .and. (self%optstring(1:1) /= ':')) then
      end if
! XXX: GNU sets self%opt to val regardless of flag
      if (.not. associated(self%long_opts(match)%flag)) then
        self%opt = self%long_opts(match)%val
      else
        self%opt = GETOPT_STATUS_NIL
      end if
      self%index=self%index-1
      retval = merge(GETOPT_STATUS_BADARG,GETOPT_STATUS_BADCH,self%optstring(1:1)==':')
      return
    end if

  else     ! match==-1; unknown option 
    if (short_too) then
      self%index=self%index-1
      retval = GETOPT_STATUS_END
      return
    end if
    if ((self%error) .and. (self%optstring(1:1) /= ':')) then
    end if
    self%opt = GETOPT_STATUS_NIL
    retval = GETOPT_STATUS_BADCH
    return
  end if

  if (present(longindex)) longindex = match
  if (associated(self%long_opts(match)%flag)) then
    self%long_opts(match)%flag = self%long_opts(match)%val
    retval = GETOPT_STATUS_NIL
    return
  else
    self%opt = self%long_opts(match)%val
    retval = self%opt
  end if
end function parse_longopts

end module getopt_long_module
!
! C getopt_long globals:
! int   optind => integer::self%index
! int   opterr => integer::self%error
! int   optopt => integer::self%opt
! char *optarg => character(len=1)::self%optarg(:)
!EXAMPLE
#ifdef SELFTEST
program selftest_program
  use getopt_long_module
  implicit none
  character(len=1) :: c
  integer :: i
  integer :: digit_optind = 0
  type(getopt_type), pointer :: opts

  integer :: this_option_optind
  integer :: option_index
  character(len=1), parameter :: NIL = char(0)

  type(getopt_option_type) :: long_options(6) = (/ &
      getopt_option_type("add",     1, NULL(), NIL), &
      getopt_option_type("append",  0, NULL(), NIL), &
      getopt_option_type("delete",  1, NULL(), NIL), &
      getopt_option_type("verbose", 0, NULL(), NIL), &
      getopt_option_type("create",  1, NULL(), 'c'), &
      getopt_option_type("file",    1, NULL(), NIL) /)
  character(len=*), parameter :: optstring = "abc:d:012"

  call getopt_new(opts,optstring,long_options)

  do
    this_option_optind = merge(opts%index,1,opts%index>0)
    option_index = 0
    c = getopt(opts,option_index)
    write(*,*)'retval=',c
    select case(c)
    case (GETOPT_STATUS_END)
      exit
    case (GETOPT_STATUS_NIL)
      write(*,'(2A)',advance='no') "option ", trim(long_options(option_index)%name)
      if (associated(opts%optarg)) &
        write(*,'(2A)',advance='no') "with arg ", opts%optarg
      write(*,*) !newline

    case ('0','1','2')
      if (digit_optind /= 0 .and. digit_optind /= this_option_optind) &
        write(*,*) "digits occur in two different argv-elements."
      digit_optind = this_option_optind
      write(*,*)"option ",c

    case ('a','b')
      write(*,*)"option ",c

    case ('c','d')
      write(*,*)"option ",c," with value '",opts%optarg,'"'

    case default
      write(*,*) "?? getopt returned character code ",ichar(c)," ??"

    end select

  end do

  if (opts%index <= opts%argc) then
    write(*,'(A)',advance='no') "non-option ARGV-elements: "
    do i=opts%index,opts%argc
      write(*,'(A,1X)',advance='no') getopt_argv(opts,i)
    end do
    write(*,*) ! newline
  end if

  stop
end program selftest_program
#endif /* SELFTEST */