Pastebin launched a little side project called VERYVIRAL.com, check it out ;-) Want more features on Pastebin? Sign Up, it's FREE!
Guest

Untitled

By: a guest on Nov 1st, 2010  |  syntax: Fortran  |  size: 9.84 KB  |  views: 477  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. module options
  2.   implicit none
  3.  
  4.   type option
  5.     !> Long name.
  6.     character(len=100) :: name
  7.     !> Does the option require an argument?
  8.     logical :: has_arg
  9.     !> Corresponding short name.
  10.     character :: chr
  11.     !> Description.
  12.     character(len=500) :: descr
  13.     !> Argument name, if required.
  14.     character(len=20) :: argname
  15.   contains
  16.     procedure :: print => print_opt
  17.   end type
  18.  
  19. contains
  20.    
  21.   !> Parse command line options. Options and their arguments must come before
  22.   !> all non-option arguments. Short options have the form "-X", long options
  23.   !> have the form "--XXXX..." where "X" is any character. Parsing can be
  24.   !> stopped with the option '--'.
  25.   !> The following code snippet illustrates the intended use:
  26.   !> \code
  27.   !> do
  28.   !>   call getopt (..., optchar=c, ...)
  29.   !>   if (stat /= 0) then
  30.   !>     ! optional error handling
  31.   !>     exit
  32.   !>   end if
  33.   !>   select case (c)
  34.   !>     ! process options
  35.   !>   end select
  36.   !> end do
  37.   !> \endcode
  38.   subroutine getopt (options, longopts, optchar, optarg, arglen, stat, &
  39.       offset, remain, err)
  40.     use iso_fortran_env, only: error_unit
  41.  
  42.     !> String containing the characters that are valid short options. If
  43.     !> present, command line arguments are scanned for those options.
  44.     !> If a character is followed by a colon (:) its corresponding option
  45.     !> requires an argument. E.g. "vn:" defines two options -v and -n with -n
  46.     !> requiring an argument.
  47.     character(len=*), intent(in), optional :: options
  48.  
  49.     !> Array of long options. If present, options of the form '--XXXX...' are
  50.     !> recognised. Each option has an associated option character. This can be
  51.     !> any character of default kind, it is just an identifier. It can, but
  52.     !> doesn't have to, match any character in the options argument. In fact it
  53.     !> is possible to only pass long options and no short options at all.
  54.     !> Only name, has_arg and chr need to be set.
  55.     type(option), intent(in), optional :: longopts(:)
  56.  
  57.     !> If stat is not 1, optchar contains the option character that was parsed.
  58.     !> Otherwise its value is undefined.
  59.     character, intent(out), optional :: optchar
  60.  
  61.     !> If stat is 0 and the parsed option requires an argument, optarg contains
  62.     !> the first len(optarg) (but at most 500) characters of that argument.
  63.     !> Otherwise its value is undefined. If the arguments length exceeds 500
  64.     !> characters and err is .true., a warning is issued.
  65.     character(len=*), intent(out), optional :: optarg
  66.  
  67.     !> If stat is 0 and the parsed option requires an argument, arglen contains
  68.     !> the actual length of that argument. Otherwise its value is undefined.
  69.     !> This can be used to make sure the argument was not truncated by the
  70.     !> limited length of optarg.
  71.     integer, intent(out), optional :: arglen
  72.  
  73.     !> Status indicator. Can have the following values:
  74.     !>   -  0: An option was successfully parsed.
  75.     !>   -  1: Parsing stopped successfully because a non-option or '--' was
  76.     !>         encountered.
  77.     !>   - -1: An unrecognised option was encountered.
  78.     !>   - -2: A required argument was missing.
  79.     !>   .
  80.     !> Its value is never undefined.
  81.     integer, intent(out), optional :: stat
  82.  
  83.     !> If stat is 1, offset contains the number of the argument before the
  84.     !> first non-option argument, i.e. offset+n is the nth non-option argument.
  85.     !> If stat is not 1, offset contains the number of the argument that would
  86.     !> be parsed in the next call to getopt. This number can be greater than
  87.     !> the actual number of arguments.
  88.     integer, intent(out), optional :: offset
  89.  
  90.     !> If stat is 1, remain contains the number of remaining non-option
  91.     !> arguments, i.e. the non-option arguments are in the range
  92.     !> (offset+1:offset+remain). If stat is not 1, remain is undefined.
  93.     integer, intent(out), optional :: remain
  94.  
  95.     !> If err is present and .true., getopt prints messages to the standard
  96.     !> error unit if an error is encountered (i.e. whenever stat would be set
  97.     !> to a negative value).
  98.     logical, intent(in), optional :: err
  99.  
  100.     integer, save :: pos = 1, cnt = 0
  101.     character(len=500), save :: arg
  102.  
  103.     integer :: chrpos, length, st, id
  104.     character :: chr
  105.     logical :: long
  106.    
  107.     if (cnt == 0) cnt = command_argument_count()
  108.     long = .false.
  109.  
  110.     ! no more arguments left
  111.     if (pos > cnt) then
  112.       pos = pos - 1
  113.       st = 1
  114.       goto 10
  115.     end if
  116.  
  117.     call get_command_argument (pos, arg, length)
  118.  
  119.     ! is argument an option?
  120.     if (arg(1:1) == '-') then
  121.      
  122.       chr = arg(2:2)
  123.      
  124.       ! too long ('-xxxx...') for one dash?
  125.       if (chr /= '-' .and. len_trim(arg) > 2) then
  126.         st = -1
  127.         goto 10
  128.       end if
  129.  
  130.       ! forced stop ('--')
  131.       if (chr == '-' .and. arg(3:3) == ' ') then
  132.         st = 1
  133.         goto 10
  134.       end if
  135.  
  136.       ! long option ('--xxx...')
  137.       if (chr == '-') then
  138.  
  139.         long = .true.
  140.  
  141.         ! check if valid
  142.         id = lookup(arg(3:))
  143.        
  144.         ! option is invalid, stop
  145.         if (id == 0) then
  146.           st = -1
  147.           goto 10
  148.         end if
  149.        
  150.         chr = longopts(id)%chr
  151.  
  152.         ! check if option requires an argument
  153.         if (.not. longopts(id)%has_arg) then
  154.           st = 0
  155.           goto 10
  156.         end if
  157.        
  158.         ! check if there are still arguments left
  159.         if (pos == cnt) then
  160.           st = -2
  161.           goto 10
  162.         end if
  163.          
  164.         ! go to next position
  165.         pos = pos + 1
  166.        
  167.         ! get argument
  168.         call get_command_argument (pos, arg, length)
  169.          
  170.         ! make sure it is not an option
  171.         if (arg(1:1) == '-') then
  172.           st = -2
  173.           pos = pos - 1
  174.           goto 10
  175.         end if
  176.  
  177.       end if
  178.      
  179.       ! short option
  180.       ! check if valid
  181.       if (present(options)) then
  182.         chrpos = scan(options, chr)
  183.       else
  184.         chrpos = 0
  185.       end if
  186.  
  187.       ! option is invalid, stop
  188.       if (chrpos == 0) then
  189.         st = -1
  190.         goto 10
  191.       end if
  192.        
  193.       ! look for argument requirement
  194.       if (chrpos < len_trim(options)) then
  195.         if (options(chrpos+1:chrpos+1) == ':') then
  196.  
  197.           ! check if there are still arguments left
  198.           if (pos == cnt) then
  199.             st = -2
  200.             goto 10
  201.           end if
  202.            
  203.           ! go to next position
  204.           pos = pos + 1
  205.          
  206.           ! get argument
  207.           call get_command_argument (pos, arg, length)
  208.            
  209.           ! make sure it is not an option
  210.           if (arg(1:1) == '-') then
  211.             st = -2
  212.             pos = pos - 1
  213.             goto 10
  214.           end if
  215.              
  216.         end if
  217.       end if
  218.  
  219.       ! if we get to this point, no error happened
  220.       ! return option and the argument (if there is one)
  221.       st = 0
  222.       goto 10
  223.     end if
  224.  
  225.     ! not an option, parsing stops
  226.     st = 1
  227.     ! we are already at the first non-option argument
  228.     ! go one step back to the last option or option argument
  229.     pos = pos - 1
  230.  
  231.  
  232.     ! error handling and setting of return values
  233.     10 continue
  234.  
  235.     if (present(err)) then
  236.       if (err) then
  237.        
  238.         select case (st)
  239.         case (-1)
  240.             write (error_unit, *) "error: unrecognised option: " // trim(arg)
  241.         case (-2)
  242.           if (.not. long) then
  243.             write (error_unit, *) "error: option -" // chr &
  244.                 // " requires an argument"
  245.           else
  246.             write (error_unit, *) "error: option --" &
  247.                 // trim(longopts(id)%name) // " requires an argument"
  248.           end if
  249.         end select
  250.  
  251.       end if
  252.     end if
  253.  
  254.     if (present(optchar)) optchar = chr
  255.     if (present(optarg))  optarg  = arg
  256.     if (present(arglen))  arglen  = length
  257.     if (present(stat))    stat    = st
  258.     if (present(offset))  offset  = pos
  259.     if (present(remain))  remain  = cnt-pos
  260.  
  261.     ! setup pos for next call to getopt
  262.     pos = pos + 1
  263.  
  264.   contains
  265.  
  266.     integer function lookup (name)
  267.       character(len=*), intent(in) :: name
  268.       integer :: i
  269.  
  270.       ! if there are no long options, skip the loop
  271.       if (.not. present(longopts)) goto 10
  272.  
  273.       do i = 1, size(longopts)
  274.         if (name == longopts(i)%name) then
  275.           lookup = i
  276.           return
  277.         end if
  278.       end do
  279.       ! if we get to this point, the option was not found
  280.  
  281.       10 lookup = 0
  282.     end function
  283.  
  284.   end subroutine
  285.  
  286.   !============================================================================
  287.  
  288.   !> Print an option in the style of a man page. I.e.
  289.   !> \code
  290.   !> -o arg
  291.   !> --option arg
  292.   !>    description.................................................................
  293.   !>    ............................................................................
  294.   !> \endcode
  295.   subroutine print_opt (opt, unit)
  296.     !> the option
  297.     type(option), intent(in) :: opt
  298.     !> logical unit number
  299.     integer, intent(in) :: unit
  300.  
  301.     integer :: l, c1, c2
  302.  
  303.     if (opt%has_arg) then
  304.       write (unit, '(1x,"-",a,1x,a)') opt%chr, trim(opt%argname)
  305.       write (unit, '(1x,"--",a,1x,a)') trim(opt%name), trim(opt%argname)
  306.     else
  307.       write (unit, '(1x,"-",a)') opt%chr
  308.       write (unit, '(1x,"--",a)') trim(opt%name)
  309.     end if
  310.     l = len_trim(opt%descr)
  311.  
  312.     ! c1 is the first character of the line
  313.     ! c2 is one past the last character of the line
  314.     c1 = 1
  315.     do
  316.       if (c1 > l) exit
  317.       ! print at maximum 4+76 = 80 characters
  318.       c2 = min(c1 + 76, 500)
  319.       ! if not at the end of the whole string
  320.       if (c2 /= 500) then
  321.         ! find the end of a word
  322.         do
  323.           if (opt%descr(c2:c2) == ' ') exit
  324.           c2 = c2-1
  325.         end do
  326.       end if
  327.       write (unit, '(4x,a)') opt%descr(c1:c2-1)
  328.       c1 = c2+1
  329.     end do
  330.  
  331.   end subroutine
  332.  
  333. end module