PartMC  2.2.0
getopt.F90
Go to the documentation of this file.
00001 ! ------------------------------------------------------------
00002 ! Copyright 2008 by Mark Gates
00003 !
00004 ! This program is free software; you can redistribute or modify it under
00005 ! the terms of the GNU general public license (GPL), version 2 or later.
00006 !
00007 ! This program is distributed in the hope that it will be useful, but
00008 ! WITHOUT ANY WARRANTY; without even the implied warranty of
00009 ! merchantability or fitness for a particular purpose.
00010 !
00011 ! If you wish to incorporate this into non-GPL software, please contact
00012 ! me regarding licensing terms.
00013 !
00014 ! ------------------------------------------------------------
00015 ! Fortran 95 getopt() and getopt_long(), similar to those in standard C library.
00016 !
00017 ! ch = getopt( optstring, [longopts] )
00018 ! Returns next option character from command line arguments.
00019 ! If an option is not recognized, it returns '?'.
00020 ! If no options are left, it returns a null character, char(0).
00021 !
00022 ! optstring contains characters that are recognized as options.
00023 ! If a character is followed by a colon, then it takes a required argument.
00024 ! For example, "x" recognizes "-x", while "x:" recognizes "-x arg" or "-xarg".
00025 !
00026 ! optopt is set to the option character, even if it isn't recognized.
00027 ! optarg is set to the option's argument.
00028 ! optind has the index of the next argument to process. Initially optind=1.
00029 ! Errors are printed by default. Set opterr=.false. to suppress them.
00030 !
00031 ! Grouped options are allowed, so "-abc" is the same as "-a -b -c".
00032 !
00033 ! If longopts is present, it is an array of type(option_s), where each entry
00034 ! describes one long option.
00035 !
00036 !    type option_s
00037 !        character(len=80) :: name
00038 !        logical           :: has_arg
00039 !        character         :: val
00040 !    end type
00041 !
00042 ! The name field is the option name, without the leading -- double dash.
00043 ! Set the has_arg field to true if it requires an argument, false if not.
00044 ! The val field is returned. Typically this is set to the corresponding short
00045 ! option, so short and long options can be processed together. (But there
00046 ! is no requirement that every long option has a short option, or vice-versa.)
00047 !
00048 ! -----
00049 ! EXAMPLE
00050 ! program test
00051 !     use getopt_m
00052 !     implicit none
00053 !     character:: ch
00054 !     type(option_s):: opts(2)
00055 !     opts(1) = option_s( "alpha", .false., 'a' )
00056 !     opts(2) = option_s( "beta",  .true.,  'b' )
00057 !     do
00058 !         select case( getopt( "ab:c", opts ))
00059 !             case( char(0))
00060 !                 exit
00061 !             case( 'a' )
00062 !                 print *, 'option alpha/a'
00063 !             case( 'b' )
00064 !                 print *, 'option beta/b=', optarg
00065 !             case( '?' )
00066 !                 print *, 'unknown option ', optopt
00067 !                 stop
00068 !             case default
00069 !                 print *, 'unhandled option ', optopt, ' (this is a bug)'
00070 !         end select
00071 !     end do
00072 ! end program test
00073 !
00074 ! Differences from C version:
00075 ! - when options are finished, C version returns -1 instead of char(0),
00076 !   and thus stupidly requires an int instead of a char.
00077 ! - does not support optreset
00078 ! - does not support "--" as last argument
00079 ! - if no argument, optarg is blank, not NULL
00080 ! - argc and argv are implicit
00081 !
00082 ! Differences for long options:
00083 ! - optional argument to getopt(), rather than separate function getopt_long()
00084 ! - has_arg is logical, and does not support optional_argument
00085 ! - does not support flag field (and thus always returns val)
00086 ! - does not support longindex
00087 ! - does not support "--opt=value" syntax, only "--opt value"
00088 ! - knows the length of longopts, so does not need an empty last record
00089 
00090 module getopt_m
00091   implicit none
00092   character(len=80):: optarg
00093   character:: optopt
00094   integer:: optind=1
00095   logical:: opterr=.true.
00096 
00097   type option_s
00098      character(len=80) :: name
00099      logical           :: has_arg
00100      character         :: val
00101   end type option_s
00102 
00103   ! grpind is index of next option within group; always >= 2
00104   integer, private:: grpind=2
00105 
00106 contains
00107 
00108   ! ----------------------------------------
00109   ! Return str(i:j) if 1 <= i <= j <= len(str),
00110   ! else return empty string.
00111   ! This is needed because Fortran standard allows but doesn't *require* short-circuited
00112   ! logical AND and OR operators. So this sometimes fails:
00113   !     if ( i < len(str) .and. str(i+1:i+1) == ':' ) then
00114   ! but this works:
00115   !     if ( substr(str, i+1, i+1) == ':' ) then
00116 
00117   character function substr( str, i, j )
00118     ! arguments
00119     character(len=*), intent(in):: str
00120     integer, intent(in):: i, j
00121 
00122     if ( 1 <= i .and. i <= j .and. j <= len(str)) then
00123        substr = str(i:j)
00124     else
00125        substr = ''
00126     endif
00127   end function substr
00128 
00129 
00130   ! ----------------------------------------
00131   character function getopt( optstring, longopts )
00132     ! arguments
00133     character(len=*), intent(in):: optstring
00134     type(option_s),   intent(in), optional:: longopts(:)
00135 
00136     ! local variables
00137     character(len=80):: arg
00138 
00139     optarg = ''
00140     if ( optind > iargc()) then
00141        getopt = char(0)
00142     endif
00143 
00144     call getarg( optind, arg )
00145     if ( present( longopts ) .and. arg(1:2) == '--' ) then
00146        getopt = process_long( longopts, arg )
00147     elseif ( arg(1:1) == '-' ) then
00148        getopt = process_short( optstring, arg )
00149     else
00150        getopt = char(0)
00151     endif
00152   end function getopt
00153 
00154 
00155   ! ----------------------------------------
00156   character function process_long( longopts, arg )
00157     ! arguments
00158     type(option_s),   intent(in):: longopts(:)
00159     character(len=*), intent(in):: arg
00160 
00161     ! local variables
00162     integer:: i
00163 
00164     ! search for matching long option
00165     optind = optind + 1
00166     do i = 1, size(longopts)
00167        if ( arg(3:) == longopts(i)%name ) then
00168           optopt = longopts(i)%val
00169           process_long = optopt
00170           if ( longopts(i)%has_arg ) then
00171              if ( optind <= iargc()) then
00172                 call getarg( optind, optarg )
00173                 optind = optind + 1
00174              elseif ( opterr ) then
00175                 print '(a,a,a)', "Error: option '", trim(arg), "' requires an argument"
00176              endif
00177           endif
00178           return
00179        endif
00180     end do
00181     ! else not found
00182     process_long = '?'
00183     if ( opterr ) then
00184        print '(a,a,a)', "Error: unrecognized option '", trim(arg), "'"
00185     endif
00186   end function process_long
00187 
00188 
00189   ! ----------------------------------------
00190   character function process_short( optstring, arg )
00191     ! arguments
00192     character(len=*), intent(in):: optstring, arg
00193 
00194     ! local variables
00195     integer:: i, arglen
00196 
00197     arglen = len( trim( arg ))
00198     optopt = arg(grpind:grpind)
00199     process_short = optopt
00200 
00201     i = index( optstring, optopt )
00202     if ( i == 0 ) then
00203        ! unrecognized option
00204        process_short = '?'
00205        if ( opterr ) then
00206           print '(a,a,a)', "Error: unrecognized option '-", optopt, "'"
00207        endif
00208     endif
00209     if ( i > 0 .and. substr( optstring, i+1, i+1 ) == ':' ) then
00210        ! required argument
00211        optind = optind + 1
00212        if ( arglen > grpind ) then
00213           ! -xarg, return remainder of arg
00214           optarg = arg(grpind+1:arglen)
00215        elseif ( optind <= iargc()) then
00216           ! -x arg, return next arg
00217           call getarg( optind, optarg )
00218           optind = optind + 1
00219        elseif ( opterr ) then
00220           print '(a,a,a)', "Error: option '-", optopt, "' requires an argument"
00221        endif
00222        grpind = 2
00223     elseif ( arglen > grpind ) then
00224        ! no argument (or unrecognized), go to next option in argument (-xyz)
00225        grpind = grpind + 1
00226     else
00227        ! no argument (or unrecognized), go to next argument
00228        grpind = 2
00229        optind = optind + 1
00230     endif
00231   end function process_short
00232 
00233 end module getopt_m