dc_args.f90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright (c) 2000-2026 Gtool Development Group. All rights reserved.
!-----------------------------------------------------------------------
 
module dc_args
  use dc_types, only : string
  use dc_hash, only: hash
  implicit none
  private
 
  public:: args
  public:: dcargsopen, dcargsclose, dcargsoption
  public:: dcargsputline, dcargsdebug, dcargshelp
  public:: dcargshelpmsg, dcargsstrict, dcargsget
  public:: dcargsnumber
 
  !-----------------------------------------------
  ! 後方互換用
  ! For backward compatibility
  public:: Open, Close, option, putline, debug, help, helpmsg, strict, get
  public:: number
 
  type args
    private
    type(OPT_ENTRY), pointer :: opt_table(:) => null()
                              
    logical :: initialized = .false.
                              
    type(cmd_opts_internal), pointer :: cmd_opts_list(:) => null()
                              
    type(hash) :: helpmsg
                              
  end type args
 
  type opt_entry
    character(STRING), pointer:: options(:) => null()
                              
    character(STRING) :: help_message
                              
    logical :: optvalue_flag
                              
  end type opt_entry
 
  type cmd_opts_internal
    character(STRING) :: name
                              
    character(STRING) :: value
                              
    logical:: flag_called = .false.
                              
  end type cmd_opts_internal
 
  interface dcargsopen
    module procedure dcargsopen0
  end interface
 
  interface dcargsclose
    module procedure dcargsclose0
  end interface
 
  interface dcargsoption
    module procedure dcargsoption0
  end interface
 
  interface dcargsputline
    module procedure dcargsputline0
  end interface
 
  interface dcargsdebug
    module procedure dcargsdebug0
  end interface
 
  interface dcargshelp
    module procedure dcargshelp0
  end interface
 
  interface dcargshelpmsg
    module procedure dcargshelpmsg0
  end interface
 
  interface dcargsstrict
    module procedure dcargsstrict0
  end interface
 
  interface dcargsget
    module procedure dcargsget0
  end interface
 
  interface dcargsnumber
    module procedure dcargsnumber0
  end interface
 
  !-----------------------------------------------
  ! 後方互換用
  ! For backward compatibility
  interface open
    module procedure dcargsopen0
  end interface
 
  interface close
    module procedure dcargsclose0
  end interface
 
  interface option
    module procedure dcargsoption0
  end interface
 
  interface putline
    module procedure dcargsputline0
  end interface
 
  interface debug
    module procedure dcargsdebug0
  end interface
 
  interface help
    module procedure dcargshelp0
  end interface
 
  interface helpmsg
    module procedure dcargshelpmsg0
  end interface
 
  interface strict
    module procedure dcargsstrict0
  end interface
 
  interface get
    module procedure dcargsget0
  end interface
 
  interface number
    module procedure dcargsnumber0
  end interface
 
 
  !-------------------------------------
 
  character(STRING), allocatable, save:: argstr_table(:)
                              
 
  integer, save:: argind_count = -1
                              
 
  !-------------------------------------
 
  type(CMD_OPTS_INTERNAL), allocatable, save :: cmd_opts_list(:)
                              
 
  character(STRING), allocatable, save:: cmd_argv_list(:)
                              
 
contains
 
  subroutine dcargsopen0(arg)
    use dc_message, only: messagenotify
    implicit none
    type(args), intent(out) :: arg
    integer:: cmd_opts_max
    character(len = *), parameter :: subname = 'DCArgsOpen'
  continue
    if (arg % initialized) then
      call messagenotify('W', subname, 'This argument (type ARGS) is already opend.')
      return
    end if
    call buildargtable
    call sortargtable
    cmd_opts_max = size(cmd_opts_list)
    allocate(arg % cmd_opts_list(cmd_opts_max))
    arg % cmd_opts_list = cmd_opts_list
    nullify( arg % opt_table )
    arg % initialized = .true.
  end subroutine dcargsopen0
 
  subroutine dcargsclose0(arg)
    use dc_hash, only: dchashdelete
    implicit none
    type(args), intent(inout) :: arg
    integer :: i
  continue
    if (arg % initialized) then
      if ( associated( arg % opt_table ) ) then
        do i = 1, size(arg % opt_table)
          deallocate(arg % opt_table(i) % options)
        end do
 
        deallocate(arg % opt_table)
      end if
 
      deallocate(arg % cmd_opts_list)
      deallocate(argstr_table)
      deallocate(cmd_argv_list)
      deallocate(cmd_opts_list)
 
      call dchashdelete(arg % helpmsg)
    end if
  end subroutine dcargsclose0
 
  subroutine dcargsoption0(arg, options, flag, value, help)
    use dc_message, only: messagenotify
    implicit none
    type(args), intent(inout) :: arg
    character(len = *), intent(in) :: options(:)
    logical, intent(out) :: flag
    character(len = *), intent(out), optional :: value
    character(len = *), intent(in), optional :: help
    integer :: i, j, options_size, table_size
    type(opt_entry), allocatable :: local_tables(:)
    character(len = STRING) :: opt_name, opt_value, opt_full
    character(len = *), parameter  :: subname = 'DCArgsOption'
  continue
    flag = .false.
    if (present(value)) value = ''
    if (.not. arg % initialized) then
      call messagenotify('W', subname, 'Call Open before Option in dc_args.')
      call dcargsopen(arg)
    end if
    options_size = size(options)
    if (options_size < 1) then
      return
    end if
 
    !-----------------------------------
    ! 構造体 ARGS へのヘルプメッセージ用の情報登録
    ! * まずはテーブル arg % opt_table を一つ広げる.
    !-----------------------------------
    if ( .not. associated( arg % opt_table ) ) then
      ! 1 つめのオプション指定
      !
      table_size = 0
      allocate(arg % opt_table(table_size + 1))
    else
      ! 2 つめ以降のオプション指定
      !
      table_size = size(arg % opt_table)
      allocate(local_tables(table_size))
      local_tables(1:table_size) = arg % opt_table(1:table_size)
      deallocate(arg % opt_table)
      allocate(arg % opt_table(table_size + 1))
      arg % opt_table(1:table_size) = local_tables(1:table_size)
      deallocate(local_tables)
    end if
 
    !----- 値の代入 -----
    allocate(arg % opt_table(table_size + 1) % options(options_size))
    arg % opt_table(table_size + 1) % options = options
    arg % opt_table(table_size + 1) % help_message = ''
    if (present(help)) then
      arg % opt_table(table_size + 1) % help_message = help
    end if
    arg % opt_table(table_size + 1) % optvalue_flag = present(value)
 
 
    !----- options の正規化 -----
    do i = 1, options_size
      opt_full = arg % opt_table(table_size + 1) % options(i)
      if (dcoptionformc(opt_full, opt_name, opt_value)) then
        arg % opt_table(table_size + 1) % options(i) = opt_name
      else
        if (len(trim(adjustl(opt_full))) < 2) then
          arg % opt_table(table_size + 1) % options(i) = &
            & '-' // trim(adjustl(opt_full))
        else
          arg % opt_table(table_size + 1) % options(i) = &
            & '--' // trim(adjustl(opt_full))
        end if
      end if
    end do
 
    ! arg % cmd_opts_list 内の探査と flag, value への代入
    ! 呼ばれたものに関しては arg % cmd_opts_list % flag_called を
    ! .true. に
    do i = 1, options_size
      do j = 1, size(arg % cmd_opts_list)
        if (trim(arg % opt_table(table_size + 1) % options(i)) &
          &             == trim(arg % cmd_opts_list(j) % name)) then
          flag = .true.
          if (present(value)) then
            value = arg % cmd_opts_list(j) % value
          end if
          arg % cmd_opts_list(j) % flag_called = .true.
        end if
      end do
    end do
  end subroutine dcargsoption0
 
  subroutine dcargsdebug0(arg)
    use dc_types, only: string
    use dc_string, only: stoa, stoi
    use dc_trace, only: setdebug
    use dc_message, only: messagenotify
    implicit none
    type(args), intent(inout) :: arg
    logical :: OPT_debug
    character(STRING) :: VAL_debug
    character(len = *), parameter  :: subname = 'DCArgsDebug'
  continue
    if (.not. arg % initialized) then
      call messagenotify('W', subname, 'Call Open before Debug in dc_args.')
      call dcargsopen(arg)
    end if
    call option(arg, stoa('-D', '--debug'), opt_debug, val_debug, &
      & help="call dc_trace#SetDebug (display a lot of messages for debug). " // &
      & "VAL is unit number (default is standard output)")
    if (opt_debug) then
      if (trim(val_debug) == '') then
        call setdebug
      else
        call setdebug(stoi(val_debug))
      end if
    end if
    return
  end subroutine dcargsdebug0
 
 
  subroutine dcargshelp0(arg, force)
    use dc_types, only: string, stdout
    use dc_string, only: stoa, stoi, printf, concat, joinchar, uchar, lchar
    use dc_present, only: present_and_true
    use dc_message, only: messagenotify
    use dc_hash, only: dchashget, dchashdelete, dchashrewind, dchashnext
    implicit none
    type(args), intent(inout) :: arg
    logical, intent(in), optional :: force
    logical :: OPT_help, found, end
    character(STRING) :: VAL_help, options_msg, help_msg, category
    character(STRING), pointer :: localopts(:) => null()
    integer :: unit, i
    character(len = *), parameter  :: subname = 'DCArgsHelp'
  continue
    if (.not. arg % initialized) then
      call messagenotify('W', subname, 'Call Open before Help in dc_args.')
      call dcargsopen(arg)
    end if
    call dcargsoption(arg, stoa('-h', '-H', '--help'), opt_help, val_help, &
      & help="display this help and exit. " // &
      & "VAL is unit number (default is standard output)")
    if (.not. opt_help .and. .not. present_and_true(force)) then
      return
    end if
    if (trim(val_help) == '') then
      unit = stdout
    else
      unit = stoi(val_help)
    end if
 
    call printf(unit, '')
 
    call dchashget(arg % helpmsg, 'TITLE', help_msg, found)
    if (found) then
      call printf(unit, '%c', c1=trim(help_msg))
      call printf(unit, '')
      call dchashdelete(arg % helpmsg, 'TITLE')
    end if
 
    call dchashget(arg % helpmsg, 'OVERVIEW', help_msg, found)
    if (found) then
      call printf(unit, 'Overview::')
      call printautolinefeed(unit, help_msg, indent='     ')
      call printf(unit, '')
      call dchashdelete(arg % helpmsg, 'OVERVIEW')
    end if
 
    call dchashget(arg % helpmsg, 'USAGE', help_msg, found)
    if (found) then
      call printf(unit, 'Usage::')
      call printautolinefeed(unit, help_msg, indent='     ')
      call printf(unit, '')
      call dchashdelete(arg % helpmsg, 'USAGE')
    end if
 
    call printf(unit, 'Options::')
    if ( associated(arg % opt_table) ) then
      do i = 1, size(arg % opt_table)
        options_msg = ' '
        if (arg % opt_table(i) % optvalue_flag) then
          call concat(arg % opt_table(i) % options, '=VAL', localopts)
        else
          allocate(localopts(size(arg % opt_table(i) % options)))
          localopts = arg % opt_table(i) % options
        end if
        options_msg = trim(options_msg) // trim(joinchar(localopts))
        deallocate(localopts)
        call printf(unit, ' %c', c1=trim(options_msg))
        call printautolinefeed(unit, &
          & arg % opt_table(i) % help_message, indent='     ')
        call printf(unit, '')
      end do
    end if
 
    call dchashrewind(arg % helpmsg)
    do
      call dchashnext(arg % helpmsg, category, help_msg, end)
      if (end) exit
 
      call printf(unit, '%c%c::', &
        & c1=trim(uchar(category(1:1))), c2=trim(lchar(category(2:))))
      call printautolinefeed(unit, help_msg, indent='     ')
      call printf(unit, '')
 
    enddo
 
    call dcargsclose(arg)
 
    stop
  end subroutine dcargshelp0
 
  subroutine dcargshelpmsg0(arg, category, msg)
    use dc_hash, only: dchashput
    use dc_string, only: uchar
    use dc_message, only: messagenotify
    implicit none
    type(args), intent(inout) :: arg
    character(*), intent(in) :: category
    character(*), intent(in) :: msg
    character(len = *), parameter  :: subname = 'DCArgsHelpMsg'
  continue
    if (.not. arg % initialized) then
      call messagenotify('W', subname, 'Call Open before Help in dc_args.')
      call dcargsopen(arg)
    end if
    call dchashput(arg % helpmsg, key=uchar(category), value=msg)
  end subroutine dcargshelpmsg0
  
 
  subroutine dcargsstrict0(arg, severe)
    use dc_types, only: string
    use dc_present, only: present_and_true
    use dc_message, only: messagenotify
    implicit none
    type(args), intent(inout) :: arg
    logical, intent(in), optional :: severe
    character(STRING) :: err_mess
    integer :: i
    character(len = *), parameter  :: subname = 'DCArgsStrict'
  continue
    if (.not. arg % initialized) then
      call messagenotify('W', subname, 'Call Open before Help in dc_args.')
      call dcargsopen(arg)
    end if
    do i = 1, size(arg % cmd_opts_list)
      err_mess = trim(arg % cmd_opts_list(i) % name) // ' is invalid option.'
      if (.not. arg % cmd_opts_list(i) % flag_called) then
        if (present_and_true(severe)) then
          call messagenotify('E', subname, err_mess)
        else
          call messagenotify('W', subname, err_mess)
        end if
      end if
    end do
  end subroutine dcargsstrict0
 
 
  subroutine dcargsget0(arg, argv)
    use dc_string, only: stoa, stoi, printf, concat, joinchar
    use dc_present, only: present_and_true
    use dc_message, only: messagenotify
    implicit none
    type(args), intent(inout) :: arg
    character(*), pointer :: argv(:) !(out)
    integer :: i, cmd_argv_max
    character(len = *), parameter  :: subname = 'DCArgsGet'
  continue
    if (.not. arg % initialized) then
      call messagenotify('W', subname, 'Call Open before Help in dc_args.')
      call dcargsopen(arg)
    end if
    cmd_argv_max = size(cmd_argv_list)
    allocate(argv(cmd_argv_max))
    do i = 1, cmd_argv_max
      argv(i) = cmd_argv_list(i)
    end do
  end subroutine dcargsget0
 
  function dcargsnumber0(arg) result(result)
    use dc_message, only: messagenotify
    implicit none
    type(args), intent(inout) :: arg
    integer :: result
    character(len = *), parameter  :: subname = 'DCArgsNumber'
  continue
    if (.not. arg % initialized) then
      call messagenotify('W', subname, 'Call Open before Help in dc_args.')
      call dcargsopen(arg)
    end if
    result = size(cmd_argv_list)
  end function dcargsnumber0
 
  subroutine dcargsputline0(arg)
    use dc_types, only: stdout
    use dc_string, only: printf, joinchar
    implicit none
    type(args), intent(in) :: arg
    integer :: i
  continue
    if (.not. arg % initialized) then
      call printf(stdout, '#<ARGS:: @initialized=%y>', l=(/arg % initialized/))
      return
    end if
    call printf(stdout, '#<ARGS:: @initialized=%y,', l=(/arg % initialized/))
    call printf(stdout, '  @opt_table(:)=')
    if ( associated(arg % opt_table) ) then
      do i = 1, size(arg % opt_table)
        call printf(stdout, '    #<OPT_ENTRY:: ')
        call printf(stdout, '      @options=%c, @help_message=%c, @optvalue_flag=%y', &
          & c1=trim(joinchar(arg % opt_table(i) % options)), &
          & c2=trim(arg % opt_table(i) % help_message), &
          & l=(/arg % opt_table(i) % optvalue_flag/))
        call printf(stdout, '    >')
      end do
    end if
    call printf(stdout, '  ,')
    call printf(stdout, '  @cmd_opts_list(:)=')
    do i = 1, size(arg % cmd_opts_list)
      call printf(stdout, '    #<CMD_OPTS_INTERNAL:: ')
      call printf(stdout, '      @name=%c, @value=%c, @flag_called=%y', &
        & c1=trim(arg % cmd_opts_list(i) % name), &
        & c2=trim(arg % cmd_opts_list(i) % value), &
        & l=(/arg % cmd_opts_list(i) % flag_called/))
      call printf(stdout, '    >')
    end do
    call printf(stdout, '  ,')
    call printf(stdout, '  @cmd_argv_list(:)=%c', &
      & c1=trim(joinchar(cmd_argv_list)))
    call printf(stdout, '>')
 
  end subroutine dcargsputline0
 
  subroutine printautolinefeed(unit, fmt, length, indent)
    use dc_types, only: string, stdout
    use dc_string, only: split
    implicit none
    character(*), intent(in) :: fmt
    integer,      intent(in), optional :: length ! 一行の長さ
    character(*), intent(in), optional :: indent ! 字下げ文字列
    integer,      intent(in), optional :: unit   ! 出力装置
    character(STRING), pointer :: carray_tmp(:) => null()
    character(STRING) :: store_str
    integer, parameter :: default_len = 70
    integer :: i, split_len, indent_len, unit_num
    logical :: new_line_flag
  continue
    if (present(unit)) then
      unit_num = unit
    else
      unit_num = stdout
    end if
 
    if (present(indent)) then
      indent_len = len(indent)
    else
      indent_len = 0
    end if
 
    if (present(length)) then
      split_len = length - indent_len
    else
      split_len = default_len - indent_len
    end if
 
 
    nullify(carray_tmp)
    call split(fmt, carray_tmp, '')
    store_str = ''
    new_line_flag = .true.
    i = 1
    do
      if (i > size(carray_tmp)) then
        write(unit_num, '(A)') trim(store_str)
        exit
      end if
 
      if (len(trim(store_str)) + len(trim(carray_tmp(i))) > split_len) then
        if (new_line_flag) then
          write(unit_num, '(A)') trim(carray_tmp(i))
          i = i + 1
        else
          write(unit_num, '(A)') trim(store_str)
          store_str = ''
          new_line_flag = .true.
        end if
        cycle
      end if
 
      if (new_line_flag .and. present(indent)) then
        store_str = indent // trim(carray_tmp(i))
      else
        store_str = trim(store_str) // ' ' // trim(carray_tmp(i))
      end if
      new_line_flag = .false.
      i = i + 1
    end do
 
  end subroutine printautolinefeed
 
  subroutine sortargtable
    use dc_types, only: string
    implicit none
    character(STRING):: raw_arg, name, value
    integer:: i, cmd_argv_count, cmd_opts_count, cmd_argv_max, cmd_opts_max
  continue
    if (allocated(cmd_opts_list)) return
    cmd_argv_count = 0
    cmd_opts_count = 0
    check_count: do, i = 1, argind_count
      raw_arg = argstr_table(i)
      if (dcoptionformc(raw_arg, name, value)) then
        cmd_opts_count = cmd_opts_count + 1
      else
        cmd_argv_count = cmd_argv_count + 1
      end if
    end do check_count
 
    cmd_argv_max = cmd_argv_count
    cmd_opts_max = cmd_opts_count
 
    allocate(cmd_argv_list(cmd_argv_max))
    allocate(cmd_opts_list(cmd_opts_max))
 
    cmd_argv_count = 0
    cmd_opts_count = 0
    arg_get : do, i = 1, argind_count
      raw_arg = argstr_table(i)
      if (dcoptionformc(raw_arg, name, value)) then
        cmd_opts_count = cmd_opts_count + 1
        cmd_opts_list(cmd_opts_count) % name = name
        cmd_opts_list(cmd_opts_count) % value = value
        cmd_opts_list(cmd_opts_count) % flag_called = .false.
      else
        cmd_argv_count = cmd_argv_count + 1
        cmd_argv_list(cmd_argv_count) = raw_arg
      end if
    end do arg_get
  end subroutine sortargtable
 
  subroutine buildargtable
    use sysdep, only: sysdepargcount, sysdepargget
    use dc_types, only: string
    implicit none
    integer:: i, narg, nargmax
    character(len = STRING):: value
    character(len = STRING), allocatable:: localtab(:)
  continue
    if (argind_count >= 0) return
    nargmax = sysdepargcount()
    allocate(localtab(nargmax))
    narg = 0
    do, i = 1, nargmax
      call sysdepargget(i, value)
      narg = narg + 1
      localtab(narg) = value
    enddo
    argind_count = narg
    allocate(argstr_table(narg))
    argstr_table(1: narg) = localtab(1: narg)
    deallocate(localtab)
  end subroutine buildargtable
 
  function dcoptionformc(argument, name, value) result(result)
    implicit none
    character(len = *), intent(in):: argument
    character(len = *), intent(out):: name, value
    logical :: result
    integer:: equal
  continue
    equal = index(argument, '=')
    if (argument(1:1) == '-' .and. argument(2:2) /= '-') then
      ! Short Option
      if (equal == 0) then
        name = argument(1:2)
        value = ""
      else
        name = argument(1:2)
        value = argument(equal+1: )
      endif
      result = .true.
    elseif (argument(1:2) == '--') then
      ! Long Option
      if (equal == 0) then
        name = argument
        value = ""
      else
        name = argument(1:equal-1)
        value = argument(equal+1: )
      endif
      result = .true.
!    elseif (equal == 0 .and. &
!      &     verify(argument(1:equal-1), WORDCHARS) == 0) then
!      ! ???
!      name = argument(1:equal-1)
!      value = argument(equal+1: )
!      result = .true.
    else
      ! No Option (normal arguments)
      name = ""
      value = ""
      result = .false.
    endif
  end function dcoptionformc
 
 
 
end module dc_args