libsim Versione 7.2.1

◆ optionparser_printhelp()

subroutine, public optionparser_printhelp ( type(optionparser), intent(in) this)

Print on stdout a human-readable text representation of the help message.

It can be called by the user program and it is called anyway in case of error in the interpretation of the command line.

Parametri
[in]thisoptionparser object with correctly initialised options

Definizione alla linea 1667 del file optionparser_class.F90.

1668! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1669! authors:
1670! Davide Cesari <dcesari@arpa.emr.it>
1671! Paolo Patruno <ppatruno@arpa.emr.it>
1672
1673! This program is free software; you can redistribute it and/or
1674! modify it under the terms of the GNU General Public License as
1675! published by the Free Software Foundation; either version 2 of
1676! the License, or (at your option) any later version.
1677
1678! This program is distributed in the hope that it will be useful,
1679! but WITHOUT ANY WARRANTY; without even the implied warranty of
1680! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1681! GNU General Public License for more details.
1691#include "config.h"
1692
1693MODULE optionparser_class
1694USE log4fortran
1695USE err_handling
1696USE kinds
1700IMPLICIT NONE
1701
1702
1703! private class
1704TYPE option
1705 CHARACTER(len=1) :: short_opt=''
1706 CHARACTER(len=80) :: long_opt=''
1707 INTEGER :: opttype=-1
1708 INTEGER :: need_arg=0 ! 0=no, 1=optional, 2=yes, was .FALSE.
1709 LOGICAL :: has_default=.false.
1710 CHARACTER(len=1),POINTER :: destc=>null()
1711 INTEGER :: destclen=0
1712 INTEGER :: helpformat=0 ! 0=txt, 1=markdown, 2=htmlform, improve!
1713 INTEGER,POINTER :: desti=>null()
1714 TYPE(arrayof_integer),POINTER :: destiarr=>null()
1715 REAL,POINTER :: destr=>null()
1716 TYPE(arrayof_real),POINTER :: destrarr=>null()
1717 DOUBLE PRECISION, POINTER :: destd=>null()
1718 TYPE(arrayof_doubleprecision),POINTER :: destdarr=>null()
1719 LOGICAL,POINTER :: destl=>null()
1720 TYPE(arrayof_logical),POINTER :: destlarr=>null()
1721 INTEGER,POINTER :: destcount=>null()
1722 INTEGER(kind=int_b),ALLOCATABLE :: help_msg(:)
1723END TYPE option
1724
1725#define ARRAYOF_ORIGTYPE TYPE(option)
1726#define ARRAYOF_TYPE arrayof_option
1727#define ARRAYOF_ORIGDESTRUCTOR(x) CALL option_delete(x)
1728#define ARRAYOF_PRIVATE 1
1729#include "arrayof_pre_nodoc.F90"
1730! from arrayof
1731!PUBLIC insert, append, remove, packarray
1732!PUBLIC insert_unique, append_unique
1733
1811TYPE optionparser
1812 PRIVATE
1813 INTEGER(kind=int_b),POINTER :: usage_msg(:), description_msg(:)
1814 TYPE(arrayof_option) :: options
1815 LOGICAL :: httpmode=.false.
1816END TYPE optionparser
1817
1818
1822INTERFACE optionparser_add
1823 MODULE PROCEDURE optionparser_add_c, optionparser_add_i, optionparser_add_r, &
1824 optionparser_add_d, optionparser_add_l, &
1825 optionparser_add_iarray, optionparser_add_rarray, optionparser_add_darray
1826END INTERFACE
1827
1828INTERFACE c_e
1829 MODULE PROCEDURE option_c_e
1830END INTERFACE
1831
1839INTERFACE delete
1840 MODULE PROCEDURE optionparser_delete!?, option_delete
1841END INTERFACE
1842
1843
1844INTEGER,PARAMETER :: opttype_c = 1, opttype_i = 2, opttype_r = 3, &
1845 opttype_d = 4, opttype_l = 5, opttype_count = 6, opttype_help = 7, &
1846 opttype_sep = 8, opttype_carr = 11, opttype_iarr = 12, opttype_rarr = 13, &
1847 opttype_darr = 14, opttype_larr = 15
1848
1849INTEGER,PARAMETER :: optionparser_ok = 0
1850INTEGER,PARAMETER :: optionparser_help = 1
1851INTEGER,PARAMETER :: optionparser_err = 2
1852
1853
1854PRIVATE
1855PUBLIC optionparser, optionparser_new, delete, optionparser_add, &
1856 optionparser_add_count, optionparser_add_help, optionparser_add_sep, &
1857 optionparser_parse, optionparser_printhelp, &
1858 optionparser_ok, optionparser_help, optionparser_err
1859
1860
1861CONTAINS
1862
1863#include "arrayof_post_nodoc.F90"
1864
1865! Constructor for the option class
1866FUNCTION option_new(short_opt, long_opt, default, help) RESULT(this)
1867CHARACTER(len=*),INTENT(in) :: short_opt
1868CHARACTER(len=*),INTENT(in) :: long_opt
1869CHARACTER(len=*),INTENT(in) :: default
1870CHARACTER(len=*),OPTIONAL :: help
1871TYPE(option) :: this
1872
1873IF (short_opt == '' .AND. long_opt == '') THEN
1874#ifdef DEBUG
1875! programmer error condition, option empty
1876 CALL l4f_log(l4f_error, 'in optionparser, both short and long options empty')
1877 CALL raise_fatal_error()
1878#else
1879 CALL l4f_log(l4f_warn, 'in optionparser, both short and long options empty')
1880#endif
1881 RETURN
1882ENDIF
1883
1884this%short_opt = short_opt
1885this%long_opt = long_opt
1886IF (PRESENT(help)) THEN
1887 this%help_msg = fchar_to_cstr(trim(help)//trim(default)) ! f2003 automatic alloc
1888ENDIF
1889this%has_default = (len_trim(default) > 0)
1890
1891END FUNCTION option_new
1892
1893
1894! Destructor for the \a option class, the memory associated with
1895! the object is freed.
1896SUBROUTINE option_delete(this)
1897TYPE(option),INTENT(inout) :: this ! object to destroy
1898
1899IF (ALLOCATED(this%help_msg)) DEALLOCATE(this%help_msg)
1900NULLIFY(this%destc)
1901NULLIFY(this%desti)
1902NULLIFY(this%destr)
1903NULLIFY(this%destd)
1904NULLIFY(this%destl)
1905NULLIFY(this%destcount)
1906
1907END SUBROUTINE option_delete
1908
1909
1910FUNCTION option_found(this, optarg) RESULT(status)
1911TYPE(option),INTENT(inout) :: this
1912CHARACTER(len=*),INTENT(in),OPTIONAL :: optarg
1913INTEGER :: status
1914
1915TYPE(csv_record) :: arrparser
1916INTEGER :: ibuff
1917REAL :: rbuff
1918DOUBLE PRECISION :: dbuff
1919
1920status = optionparser_ok
1921
1922SELECT CASE(this%opttype)
1923CASE(opttype_c)
1924 CALL dirty_char_assignment(this%destc, this%destclen, trim(optarg))
1925! this%destc(1:this%destclen) = optarg
1926 IF (len_trim(optarg) > this%destclen) THEN
1927 CALL l4f_log(l4f_warn, &
1928 'in optionparser, argument '''//trim(optarg)//''' too long, truncated')
1929 ENDIF
1930CASE(opttype_i)
1931 READ(optarg,'(I12)',err=100)this%desti
1932CASE(opttype_iarr)
1933 CALL delete(this%destiarr) ! delete default values
1934 CALL init(arrparser, optarg)
1935 DO WHILE(.NOT.csv_record_end(arrparser))
1936 CALL csv_record_getfield(arrparser, ibuff)
1937 CALL insert(this%destiarr, ibuff)
1938 ENDDO
1939 CALL packarray(this%destiarr)
1940 CALL delete(arrparser)
1941CASE(opttype_r)
1942 READ(optarg,'(F20.0)',err=102)this%destr
1943CASE(opttype_rarr)
1944 CALL delete(this%destrarr) ! delete default values
1945 CALL init(arrparser, optarg)
1946 DO WHILE(.NOT.csv_record_end(arrparser))
1947 CALL csv_record_getfield(arrparser, rbuff)
1948 CALL insert(this%destrarr, rbuff)
1949 ENDDO
1950 CALL packarray(this%destrarr)
1951 CALL delete(arrparser)
1952CASE(opttype_d)
1953 READ(optarg,'(F20.0)',err=102)this%destd
1954CASE(opttype_darr)
1955 CALL delete(this%destdarr) ! delete default values
1956 CALL init(arrparser, optarg)
1957 DO WHILE(.NOT.csv_record_end(arrparser))
1958 CALL csv_record_getfield(arrparser, dbuff)
1959 CALL insert(this%destdarr, dbuff)
1960 ENDDO
1961 CALL packarray(this%destdarr)
1962 CALL delete(arrparser)
1963CASE(opttype_l)
1964 this%destl = .true.
1965CASE(opttype_count)
1966 this%destcount = this%destcount + 1
1967CASE(opttype_help)
1968 status = optionparser_help
1969 SELECT CASE(optarg) ! set help format
1970 CASE('md', 'markdown')
1971 this%helpformat = 1
1972 CASE('htmlform')
1973 this%helpformat = 2
1974 END SELECT
1975END SELECT
1976
1977RETURN
1978
1979100 status = optionparser_err
1980CALL l4f_log(l4f_error, &
1981 'in optionparser, argument '''//trim(optarg)//''' not valid as integer')
1982RETURN
1983102 status = optionparser_err
1984CALL l4f_log(l4f_error, &
1985 'in optionparser, argument '''//trim(optarg)//''' not valid as real')
1986RETURN
1987
1988END FUNCTION option_found
1989
1990
1991! Return a string which gives a short representation of the
1992! option \a this, without help message. The resulting string is quite
1993! long and it should be trimmed with the \a TRIM() intrinsic
1994! function.
1995FUNCTION option_format_opt(this) RESULT(format_opt)
1996TYPE(option),INTENT(in) :: this
1997
1998CHARACTER(len=100) :: format_opt
1999
2000CHARACTER(len=20) :: argname
2001
2002SELECT CASE(this%opttype)
2003CASE(opttype_c)
2004 argname = 'STRING'
2005CASE(opttype_i)
2006 argname = 'INT'
2007CASE(opttype_iarr)
2008 argname = 'INT[,INT...]'
2009CASE(opttype_r, opttype_d)
2010 argname = 'REAL'
2011CASE(opttype_rarr, opttype_darr)
2012 argname = 'REAL[,REAL...]'
2013CASE default
2014 argname = ''
2015END SELECT
2016
2017format_opt = ''
2018IF (this%short_opt /= '') THEN
2019 format_opt(len_trim(format_opt)+1:) = ' -'//this%short_opt
2020 IF (argname /= '') THEN
2021 format_opt(len_trim(format_opt)+1:) = ' '//trim(argname)
2022 ENDIF
2023ENDIF
2024IF (this%short_opt /= '' .AND. this%long_opt /= '') THEN
2025 format_opt(len_trim(format_opt)+1:) = ','
2026ENDIF
2027IF (this%long_opt /= '') THEN
2028 format_opt(len_trim(format_opt)+1:) = ' --'//this%long_opt
2029 IF (argname /= '') THEN
2030 format_opt(len_trim(format_opt)+1:) = '='//trim(argname)
2031 ENDIF
2032ENDIF
2033
2034END FUNCTION option_format_opt
2035
2036
2037! print on stdout a human-readable text representation of a single option
2038SUBROUTINE option_format_help(this, ncols)
2039TYPE(option),INTENT(in) :: this
2040INTEGER,INTENT(in) :: ncols
2041
2042INTEGER :: j
2043INTEGER, PARAMETER :: indent = 10
2044TYPE(line_split) :: help_line
2045
2046
2047IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
2048 IF (ALLOCATED(this%help_msg)) THEN
2049! help2man is quite picky about the treatment of arbitrary lines
2050! within options, the only universal way seems to be unindented lines
2051! with an empty line before and after
2052 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
2053 WRITE(*,'()')
2054 DO j = 1, line_split_get_nlines(help_line)
2055 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2056 ENDDO
2057 CALL delete(help_line)
2058 WRITE(*,'()')
2059 ENDIF
2060ELSE ! ordinary option
2061! print option brief representation
2062 WRITE(*,'(A)')trim(option_format_opt(this))
2063! print option help
2064 IF (ALLOCATED(this%help_msg)) THEN
2065 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
2066 DO j = 1, line_split_get_nlines(help_line)
2067 WRITE(*,'(T10,A)')trim(line_split_get_line(help_line,j))
2068 ENDDO
2069 CALL delete(help_line)
2070 ENDIF
2071ENDIF
2072
2073END SUBROUTINE option_format_help
2074
2075
2076! print on stdout a markdown representation of a single option
2077SUBROUTINE option_format_md(this, ncols)
2078TYPE(option),INTENT(in) :: this
2079INTEGER,INTENT(in) :: ncols
2080
2081INTEGER :: j
2082INTEGER, PARAMETER :: indent = 2
2083TYPE(line_split) :: help_line
2084
2085IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
2086 IF (ALLOCATED(this%help_msg)) THEN
2087 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
2088 WRITE(*,'()')
2089 DO j = 1, line_split_get_nlines(help_line)
2090 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2091 ENDDO
2092 CALL delete(help_line)
2093 WRITE(*,'()')
2094 ENDIF
2095ELSE ! ordinary option
2096! print option brief representation
2097 WRITE(*,'(''`'',A,''`'')')trim(option_format_opt(this))
2098! print option help
2099 IF (ALLOCATED(this%help_msg)) THEN
2100 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
2101 DO j = 1, line_split_get_nlines(help_line)
2102 WRITE(*,'(''> '',A)')trim(line_split_get_line(help_line,j))
2103 ENDDO
2104 CALL delete(help_line)
2105 WRITE(*,'()')
2106 ENDIF
2107ENDIF
2108
2109END SUBROUTINE option_format_md
2110
2111
2112! print on stdout an html form representation of a single option
2113SUBROUTINE option_format_htmlform(this)
2114TYPE(option),INTENT(in) :: this
2115
2116CHARACTER(len=80) :: opt_name, opt_id, opt_default ! check len of default
2117
2118IF (.NOT.c_e(this)) RETURN
2119IF (this%long_opt == '') THEN
2120 opt_name = this%short_opt
2121 opt_id = 'short_opt_'//this%short_opt
2122ELSE
2123 opt_name = this%long_opt
2124 opt_id = this%long_opt
2125ENDIF
2126
2127SELECT CASE(this%opttype)
2128CASE(opttype_c)
2129 CALL option_format_html_openspan('text')
2130
2131 IF (this%has_default .AND. ASSOCIATED(this%destc) .AND. this%destclen > 0) THEN
2132! opt_default = TRANSFER(this%destc(1:MIN(LEN(opt_default),this%destclen)), &
2133! opt_default) ! improve
2134 opt_default = ''
2135 WRITE(*,'(A)')' value="'//trim(opt_default)//'"'
2136 ENDIF
2137 CALL option_format_html_help()
2138 CALL option_format_html_closespan()
2139
2140CASE(opttype_i,opttype_r,opttype_d)
2141 CALL option_format_html_openspan('text')
2142 IF (this%has_default) THEN
2143 SELECT CASE(this%opttype)
2144 CASE(opttype_i)
2145 WRITE(*,'(3A)')' value="',t2c(this%desti),'"'
2146! todo CASE(opttype_iarr)
2147 CASE(opttype_r)
2148 WRITE(*,'(3A)')' value="',t2c(this%destr),'"'
2149 CASE(opttype_d)
2150 WRITE(*,'(3A)')' value="',t2c(this%destd),'"'
2151 END SELECT
2152 ENDIF
2153 CALL option_format_html_help()
2154 CALL option_format_html_closespan()
2155
2156! todo CASE(opttype_iarr)
2157
2158CASE(opttype_l)
2159 CALL option_format_html_openspan('checkbox')
2160 CALL option_format_html_help()
2161 CALL option_format_html_closespan()
2162
2163CASE(opttype_count)
2164 CALL option_format_html_openspan('number')
2165 CALL option_format_html_help()
2166 CALL option_format_html_closespan()
2167
2168CASE(opttype_sep)
2169END SELECT
2170
2171
2172CONTAINS
2173
2174SUBROUTINE option_format_html_openspan(formtype)
2175CHARACTER(len=*),INTENT(in) :: formtype
2176
2177WRITE(*,'(A)')'<span class="libsim_optbox" id="span_'//trim(opt_id)//'">'//trim(opt_name)//':'
2178! size=? maxlen=?
2179WRITE(*,'(A)')'<input class_"libsim_opt" id="'//trim(opt_id)//'" type="'//formtype// &
2180 '" name="'//trim(opt_id)//'" '
2181
2182END SUBROUTINE option_format_html_openspan
2183
2184SUBROUTINE option_format_html_closespan()
2185
2186WRITE(*,'(A)')'/></span>'
2187
2188END SUBROUTINE option_format_html_closespan
2189
2190SUBROUTINE option_format_html_help()
2191INTEGER :: j
2192TYPE(line_split) :: help_line
2193CHARACTER(len=20) :: form
2194
2195IF (ALLOCATED(this%help_msg)) THEN
2196 WRITE(*,'(A,$)')' title="'
2197
2198 help_line = line_split_new(cstr_to_fchar(this%help_msg), 80)
2199 form = '(A,'' '')'
2200 DO j = 1, line_split_get_nlines(help_line)
2201 IF (j == line_split_get_nlines(help_line)) form = '(A,''"'',$)'
2202 WRITE(*,form)trim(line_split_get_line(help_line,j)) ! lines should be properly quoted here
2203 ENDDO
2204
2205ENDIF
2206
2207END SUBROUTINE option_format_html_help
2208
2209END SUBROUTINE option_format_htmlform
2210
2211
2212FUNCTION option_c_e(this) RESULT(c_e)
2213TYPE(option),INTENT(in) :: this
2214
2215LOGICAL :: c_e
2216
2217c_e = this%long_opt /= ' ' .OR. this%short_opt /= ' '
2218
2219END FUNCTION option_c_e
2220
2221
2225FUNCTION optionparser_new(usage_msg, description_msg) RESULT(this)
2226CHARACTER(len=*), INTENT(in), OPTIONAL :: usage_msg
2227CHARACTER(len=*), INTENT(in), OPTIONAL :: description_msg
2228
2229TYPE(optionparser) :: this
2230
2231IF (PRESENT(usage_msg)) THEN
2232 CALL fchar_to_cstr_alloc(trim(usage_msg), this%usage_msg)
2233ELSE
2234 NULLIFY(this%usage_msg)
2235ENDIF
2236IF (PRESENT(description_msg)) THEN
2237 CALL fchar_to_cstr_alloc(trim(description_msg), this%description_msg)
2238ELSE
2239 NULLIFY(this%description_msg)
2240ENDIF
2241
2242END FUNCTION optionparser_new
2243
2244
2245SUBROUTINE optionparser_delete(this)
2246TYPE(optionparser),INTENT(inout) :: this
2247
2248IF (ASSOCIATED(this%usage_msg)) DEALLOCATE(this%usage_msg)
2249IF (ASSOCIATED(this%description_msg)) DEALLOCATE(this%description_msg)
2250CALL delete(this%options)
2251
2252END SUBROUTINE optionparser_delete
2253
2254
2262SUBROUTINE optionparser_add_c(this, short_opt, long_opt, dest, default, help, isopt)
2263TYPE(optionparser),INTENT(inout) :: this
2264CHARACTER(len=*),INTENT(in) :: short_opt
2265CHARACTER(len=*),INTENT(in) :: long_opt
2266CHARACTER(len=*),TARGET :: dest
2267CHARACTER(len=*),OPTIONAL :: default
2268CHARACTER(len=*),OPTIONAL :: help
2269LOGICAL,INTENT(in),OPTIONAL :: isopt
2270
2271CHARACTER(LEN=60) :: cdefault
2272INTEGER :: i
2273TYPE(option) :: myoption
2274
2275
2276IF (PRESENT(default)) THEN
2277 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2278ELSE
2279 cdefault = ''
2280ENDIF
2281
2282! common initialisation
2283myoption = option_new(short_opt, long_opt, cdefault, help)
2284IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2285
2286myoption%destc => dest(1:1)
2287myoption%destclen = len(dest) ! needed to avoid exceeding the length of dest
2288IF (PRESENT(default)) &
2289 CALL dirty_char_assignment(myoption%destc, myoption%destclen, default)
2290!IF (PRESENT(default)) myoption%destc(1:myoption%destclen) = default
2291myoption%opttype = opttype_c
2292IF (optio_log(isopt)) THEN
2293 myoption%need_arg = 1
2294ELSE
2295 myoption%need_arg = 2
2296ENDIF
2297
2298i = arrayof_option_append(this%options, myoption)
2299
2300END SUBROUTINE optionparser_add_c
2301
2302
2309SUBROUTINE optionparser_add_i(this, short_opt, long_opt, dest, default, help)
2310TYPE(optionparser),INTENT(inout) :: this
2311CHARACTER(len=*),INTENT(in) :: short_opt
2312CHARACTER(len=*),INTENT(in) :: long_opt
2313INTEGER,TARGET :: dest
2314INTEGER,OPTIONAL :: default
2315CHARACTER(len=*),OPTIONAL :: help
2316
2317CHARACTER(LEN=40) :: cdefault
2318INTEGER :: i
2319TYPE(option) :: myoption
2320
2321IF (PRESENT(default)) THEN
2322 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2323ELSE
2324 cdefault = ''
2325ENDIF
2326
2327! common initialisation
2328myoption = option_new(short_opt, long_opt, cdefault, help)
2329IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2330
2331myoption%desti => dest
2332IF (PRESENT(default)) myoption%desti = default
2333myoption%opttype = opttype_i
2334myoption%need_arg = 2
2335
2336i = arrayof_option_append(this%options, myoption)
2337
2338END SUBROUTINE optionparser_add_i
2339
2340
2350SUBROUTINE optionparser_add_iarray(this, short_opt, long_opt, dest, default, help)
2351TYPE(optionparser),INTENT(inout) :: this
2352CHARACTER(len=*),INTENT(in) :: short_opt
2353CHARACTER(len=*),INTENT(in) :: long_opt
2354TYPE(arrayof_integer),TARGET :: dest
2355INTEGER,OPTIONAL :: default(:)
2356CHARACTER(len=*),OPTIONAL :: help
2357
2358CHARACTER(LEN=40) :: cdefault
2359INTEGER :: i
2360TYPE(option) :: myoption
2361
2362cdefault = ''
2363IF (PRESENT(default)) THEN
2364 IF (SIZE(default) == 1) THEN
2365 cdefault = ' [default='//trim(to_char(default(1)))//']'
2366 ELSE IF (SIZE(default) > 1) THEN
2367 cdefault = ' [default='//trim(to_char(default(1)))//',...]'
2368 ENDIF
2369ENDIF
2370
2371! common initialisation
2372myoption = option_new(short_opt, long_opt, cdefault, help)
2373IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2374
2375myoption%destiarr => dest
2376IF (PRESENT(default)) THEN
2377 CALL insert(myoption%destiarr, default)
2378 CALL packarray(myoption%destiarr)
2379ENDIF
2380myoption%opttype = opttype_iarr
2381myoption%need_arg = 2
2382
2383i = arrayof_option_append(this%options, myoption)
2384
2385END SUBROUTINE optionparser_add_iarray
2386
2387
2394SUBROUTINE optionparser_add_r(this, short_opt, long_opt, dest, default, help)
2395TYPE(optionparser),INTENT(inout) :: this
2396CHARACTER(len=*),INTENT(in) :: short_opt
2397CHARACTER(len=*),INTENT(in) :: long_opt
2398REAL,TARGET :: dest
2399REAL,OPTIONAL :: default
2400CHARACTER(len=*),OPTIONAL :: help
2401
2402CHARACTER(LEN=40) :: cdefault
2403INTEGER :: i
2404TYPE(option) :: myoption
2405
2406IF (PRESENT(default)) THEN
2407 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2408ELSE
2409 cdefault = ''
2410ENDIF
2411
2412! common initialisation
2413myoption = option_new(short_opt, long_opt, cdefault, help)
2414IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2415
2416myoption%destr => dest
2417IF (PRESENT(default)) myoption%destr = default
2418myoption%opttype = opttype_r
2419myoption%need_arg = 2
2420
2421i = arrayof_option_append(this%options, myoption)
2422
2423END SUBROUTINE optionparser_add_r
2424
2425
2435SUBROUTINE optionparser_add_rarray(this, short_opt, long_opt, dest, default, help)
2436TYPE(optionparser),INTENT(inout) :: this
2437CHARACTER(len=*),INTENT(in) :: short_opt
2438CHARACTER(len=*),INTENT(in) :: long_opt
2439TYPE(arrayof_real),TARGET :: dest
2440REAL,OPTIONAL :: default(:)
2441CHARACTER(len=*),OPTIONAL :: help
2442
2443CHARACTER(LEN=40) :: cdefault
2444INTEGER :: i
2445TYPE(option) :: myoption
2446
2447cdefault = ''
2448IF (PRESENT(default)) THEN
2449 IF (SIZE(default) == 1) THEN
2450 cdefault = ' [default='//trim(to_char(default(1)))//']'
2451 ELSE IF (SIZE(default) > 1) THEN
2452 cdefault = ' [default='//trim(to_char(default(1)))//',...]'
2453 ENDIF
2454ENDIF
2455
2456! common initialisation
2457myoption = option_new(short_opt, long_opt, cdefault, help)
2458IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2459
2460myoption%destrarr => dest
2461IF (PRESENT(default)) THEN
2462 CALL insert(myoption%destrarr, default)
2463 CALL packarray(myoption%destrarr)
2464ENDIF
2465myoption%opttype = opttype_rarr
2466myoption%need_arg = 2
2467
2468i = arrayof_option_append(this%options, myoption)
2469
2470END SUBROUTINE optionparser_add_rarray
2471
2472
2479SUBROUTINE optionparser_add_d(this, short_opt, long_opt, dest, default, help)
2480TYPE(optionparser),INTENT(inout) :: this
2481CHARACTER(len=*),INTENT(in) :: short_opt
2482CHARACTER(len=*),INTENT(in) :: long_opt
2483DOUBLE PRECISION,TARGET :: dest
2484DOUBLE PRECISION,OPTIONAL :: default
2485CHARACTER(len=*),OPTIONAL :: help
2486
2487CHARACTER(LEN=40) :: cdefault
2488INTEGER :: i
2489TYPE(option) :: myoption
2490
2491IF (PRESENT(default)) THEN
2492 IF (c_e(default)) THEN
2493 cdefault = ' [default='//trim(adjustl(to_char(default,form='(G15.9)')))//']'
2494 ELSE
2495 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2496 ENDIF
2497ELSE
2498 cdefault = ''
2499ENDIF
2500
2501! common initialisation
2502myoption = option_new(short_opt, long_opt, cdefault, help)
2503IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2504
2505myoption%destd => dest
2506IF (PRESENT(default)) myoption%destd = default
2507myoption%opttype = opttype_d
2508myoption%need_arg = 2
2509
2510i = arrayof_option_append(this%options, myoption)
2511
2512END SUBROUTINE optionparser_add_d
2513
2514
2524SUBROUTINE optionparser_add_darray(this, short_opt, long_opt, dest, default, help)
2525TYPE(optionparser),INTENT(inout) :: this
2526CHARACTER(len=*),INTENT(in) :: short_opt
2527CHARACTER(len=*),INTENT(in) :: long_opt
2528TYPE(arrayof_doubleprecision),TARGET :: dest
2529DOUBLE PRECISION,OPTIONAL :: default(:)
2530CHARACTER(len=*),OPTIONAL :: help
2531
2532CHARACTER(LEN=40) :: cdefault
2533INTEGER :: i
2534TYPE(option) :: myoption
2535
2536cdefault = ''
2537IF (PRESENT(default)) THEN
2538 IF (SIZE(default) == 1) THEN
2539 cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//']'
2540 ELSE IF (SIZE(default) > 1) THEN
2541 cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//',...]'
2542 ENDIF
2543ENDIF
2544
2545! common initialisation
2546myoption = option_new(short_opt, long_opt, cdefault, help)
2547IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2548
2549myoption%destdarr => dest
2550IF (PRESENT(default)) THEN
2551 CALL insert(myoption%destdarr, default)
2552 CALL packarray(myoption%destdarr)
2553ENDIF
2554myoption%opttype = opttype_darr
2555myoption%need_arg = 2
2556
2557i = arrayof_option_append(this%options, myoption)
2558
2559END SUBROUTINE optionparser_add_darray
2560
2561
2568SUBROUTINE optionparser_add_l(this, short_opt, long_opt, dest, help)
2569TYPE(optionparser),INTENT(inout) :: this
2570CHARACTER(len=*),INTENT(in) :: short_opt
2571CHARACTER(len=*),INTENT(in) :: long_opt
2572LOGICAL,TARGET :: dest
2573CHARACTER(len=*),OPTIONAL :: help
2574
2575INTEGER :: i
2576TYPE(option) :: myoption
2577
2578! common initialisation
2579myoption = option_new(short_opt, long_opt, '', help)
2580IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2581
2582myoption%destl => dest
2583myoption%destl = .false. ! unconditionally set to false, option can only set it to true
2584myoption%opttype = opttype_l
2585myoption%need_arg = 0
2586
2587i = arrayof_option_append(this%options, myoption)
2588
2589END SUBROUTINE optionparser_add_l
2590
2591
2596SUBROUTINE optionparser_add_count(this, short_opt, long_opt, dest, start, help)
2597TYPE(optionparser),INTENT(inout) :: this
2598CHARACTER(len=*),INTENT(in) :: short_opt
2599CHARACTER(len=*),INTENT(in) :: long_opt
2600INTEGER,TARGET :: dest
2601INTEGER,OPTIONAL :: start
2602CHARACTER(len=*),OPTIONAL :: help
2603
2604INTEGER :: i
2605TYPE(option) :: myoption
2606
2607! common initialisation
2608myoption = option_new(short_opt, long_opt, '', help)
2609IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2610
2611myoption%destcount => dest
2612IF (PRESENT(start)) myoption%destcount = start
2613myoption%opttype = opttype_count
2614myoption%need_arg = 0
2615
2616i = arrayof_option_append(this%options, myoption)
2617
2618END SUBROUTINE optionparser_add_count
2619
2620
2635SUBROUTINE optionparser_add_help(this, short_opt, long_opt, help)
2636TYPE(optionparser),INTENT(inout) :: this
2637CHARACTER(len=*),INTENT(in) :: short_opt
2638CHARACTER(len=*),INTENT(in) :: long_opt
2639CHARACTER(len=*),OPTIONAL :: help
2640
2641INTEGER :: i
2642TYPE(option) :: myoption
2643
2644! common initialisation
2645myoption = option_new(short_opt, long_opt, '', help)
2646IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2647
2648myoption%opttype = opttype_help
2649myoption%need_arg = 1
2650
2651i = arrayof_option_append(this%options, myoption)
2652
2653END SUBROUTINE optionparser_add_help
2654
2655
2666SUBROUTINE optionparser_add_sep(this, help)
2667TYPE(optionparser),INTENT(inout) :: this
2668!CHARACTER(len=*),INTENT(in) :: short_opt !< the short option (may be empty)
2669!CHARACTER(len=*),INTENT(in) :: long_opt !< the long option (may be empty)
2670CHARACTER(len=*) :: help
2671
2672INTEGER :: i
2673TYPE(option) :: myoption
2674
2675! common initialisation
2676myoption = option_new('_', '_', '', help)
2677IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2678
2679myoption%opttype = opttype_sep
2680myoption%need_arg = 0
2681
2682i = arrayof_option_append(this%options, myoption)
2683
2684END SUBROUTINE optionparser_add_sep
2685
2686
2696SUBROUTINE optionparser_parse(this, nextarg, status)
2697TYPE(optionparser),INTENT(inout) :: this
2698INTEGER,INTENT(out) :: nextarg
2699INTEGER,INTENT(out) :: status
2700
2701INTEGER :: i, j, endopt, indeq, iargc
2702CHARACTER(len=16384) :: arg, optarg
2703
2704status = optionparser_ok
2705i = 1
2706DO WHILE(i <= iargc())
2707 CALL getarg(i, arg)
2708 IF (arg == '--') THEN ! explicit end of options
2709 i = i + 1 ! skip present option (--)
2710 EXIT
2711 ELSE IF (arg == '-') THEN ! a single - is not an option
2712 EXIT
2713 ELSE IF (arg(1:2) == '--') THEN ! long option
2714 indeq = index(arg, '=')
2715 IF (indeq /= 0) THEN ! = present
2716 endopt = indeq - 1
2717 ELSE ! no =
2718 endopt = len_trim(arg)
2719 ENDIF
2720 find_longopt: DO j = 1, this%options%arraysize
2721 IF (this%options%array(j)%long_opt == arg(3:endopt)) THEN ! found option
2722 SELECT CASE(this%options%array(j)%need_arg)
2723 CASE(2) ! compulsory
2724 IF (indeq /= 0) THEN
2725 optarg = arg(indeq+1:)
2726 status = max(option_found(this%options%array(j), optarg), &
2727 status)
2728 ELSE
2729 IF (i < iargc()) THEN
2730 i=i+1
2731 CALL getarg(i, optarg)
2732 status = max(option_found(this%options%array(j), optarg), &
2733 status)
2734 ELSE
2735 status = optionparser_err
2736 CALL l4f_log(l4f_error, &
2737 'in optionparser, option '''//trim(arg)//''' requires an argument')
2738 ENDIF
2739 ENDIF
2740 CASE(1) ! optional
2741 IF (indeq /= 0) THEN
2742 optarg = arg(indeq+1:)
2743 ELSE
2744 IF (i < iargc()) THEN
2745 CALL getarg(i+1, optarg)
2746 IF (optarg(1:1) == '-') THEN
2747 optarg = cmiss ! refused
2748 ELSE
2749 i=i+1 ! accepted
2750 ENDIF
2751 ELSE
2752 optarg = cmiss ! refused
2753 ENDIF
2754 ENDIF
2755 status = max(option_found(this%options%array(j), optarg), &
2756 status)
2757 CASE(0)
2758 status = max(option_found(this%options%array(j)), &
2759 status)
2760 END SELECT
2761 EXIT find_longopt
2762 ENDIF
2763 ENDDO find_longopt
2764 IF (j > this%options%arraysize) THEN
2765 status = optionparser_err
2766 CALL l4f_log(l4f_error, &
2767 'in optionparser, option '''//trim(arg)//''' not valid')
2768 ENDIF
2769 ELSE IF (arg(1:1) == '-') THEN ! short option
2770 find_shortopt: DO j = 1, this%options%arraysize
2771 IF (this%options%array(j)%short_opt == arg(2:2)) THEN ! found option
2772 SELECT CASE(this%options%array(j)%need_arg)
2773 CASE(2) ! compulsory
2774 IF (len_trim(arg) > 2) THEN
2775 optarg = arg(3:)
2776 status = max(option_found(this%options%array(j), optarg), &
2777 status)
2778 ELSE
2779 IF (i < iargc()) THEN
2780 i=i+1
2781 CALL getarg(i, optarg)
2782 status = max(option_found(this%options%array(j), optarg), &
2783 status)
2784 ELSE
2785 status = optionparser_err
2786 CALL l4f_log(l4f_error, &
2787 'in optionparser, option '''//trim(arg)//''' requires an argument')
2788 ENDIF
2789 ENDIF
2790 CASE(1) ! optional
2791 IF (len_trim(arg) > 2) THEN
2792 optarg = arg(3:)
2793 ELSE
2794 IF (i < iargc()) THEN
2795 CALL getarg(i+1, optarg)
2796 IF (optarg(1:1) == '-') THEN
2797 optarg = cmiss ! refused
2798 ELSE
2799 i=i+1 ! accepted
2800 ENDIF
2801 ELSE
2802 optarg = cmiss ! refused
2803 ENDIF
2804 ENDIF
2805 status = max(option_found(this%options%array(j), optarg), &
2806 status)
2807 CASE(0)
2808 status = max(option_found(this%options%array(j)), &
2809 status)
2810 END SELECT
2811 EXIT find_shortopt
2812 ENDIF
2813 ENDDO find_shortopt
2814 IF (j > this%options%arraysize) THEN
2815 status = optionparser_err
2816 CALL l4f_log(l4f_error, &
2817 'in optionparser, option '''//trim(arg)//''' not valid')
2818 ENDIF
2819 ELSE ! unrecognized = end of options
2820 EXIT
2821 ENDIF
2822 i = i + 1
2823ENDDO
2824
2825nextarg = i
2826SELECT CASE(status)
2827CASE(optionparser_err, optionparser_help)
2828 CALL optionparser_printhelp(this)
2829END SELECT
2830
2831END SUBROUTINE optionparser_parse
2832
2833
2837SUBROUTINE optionparser_printhelp(this)
2838TYPE(optionparser),INTENT(in) :: this
2839
2840INTEGER :: i, form
2841
2842form = 0
2843DO i = 1, this%options%arraysize ! loop over options
2844 IF (this%options%array(i)%opttype == opttype_help) THEN
2845 form = this%options%array(i)%helpformat
2846 ENDIF
2847ENDDO
2848
2849SELECT CASE(form)
2850CASE(0)
2851 CALL optionparser_printhelptxt(this)
2852CASE(1)
2853 CALL optionparser_printhelpmd(this)
2854CASE(2)
2855 CALL optionparser_printhelphtmlform(this)
2856END SELECT
2857
2858END SUBROUTINE optionparser_printhelp
2859
2860
2864SUBROUTINE optionparser_printhelptxt(this)
2865TYPE(optionparser),INTENT(in) :: this
2866
2867INTEGER :: i, j, ncols
2868CHARACTER(len=80) :: buf
2869TYPE(line_split) :: help_line
2870
2871ncols = default_columns()
2872
2873! print usage message
2874IF (ASSOCIATED(this%usage_msg)) THEN
2875 help_line = line_split_new(cstr_to_fchar(this%usage_msg), ncols)
2876 DO j = 1, line_split_get_nlines(help_line)
2877 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2878 ENDDO
2879 CALL delete(help_line)
2880ELSE
2881 CALL getarg(0, buf)
2882 i = index(buf, '/', back=.true.) ! remove directory part
2883 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2884 WRITE(*,'(A)')'Usage: '//trim(buf(i+1:))//' [options] [arguments]'
2885ENDIF
2886
2887! print description message
2888IF (ASSOCIATED(this%description_msg)) THEN
2889 WRITE(*,'()')
2890 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2891 DO j = 1, line_split_get_nlines(help_line)
2892 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2893 ENDDO
2894 CALL delete(help_line)
2895ENDIF
2896
2897WRITE(*,'(/,A)')'Options:'
2898
2899DO i = 1, this%options%arraysize ! loop over options
2900 CALL option_format_help(this%options%array(i), ncols)
2901ENDDO
2902
2903END SUBROUTINE optionparser_printhelptxt
2904
2905
2909SUBROUTINE optionparser_printhelpmd(this)
2910TYPE(optionparser),INTENT(in) :: this
2911
2912INTEGER :: i, j, ncols
2913CHARACTER(len=80) :: buf
2914TYPE(line_split) :: help_line
2915
2916ncols = default_columns()
2917
2918! print usage message
2919WRITE(*,'(A)')'### Synopsis'
2920
2921IF (ASSOCIATED(this%usage_msg)) THEN
2922 help_line = line_split_new(mdquote_usage_msg(cstr_to_fchar(this%usage_msg)), ncols)
2923 DO j = 1, line_split_get_nlines(help_line)
2924 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2925 ENDDO
2926 CALL delete(help_line)
2927ELSE
2928 CALL getarg(0, buf)
2929 i = index(buf, '/', back=.true.) ! remove directory part
2930 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2931 WRITE(*,'(A)')'Usage: `'//trim(buf(i+1:))//' [options] [arguments]`'
2932ENDIF
2933
2934! print description message
2935IF (ASSOCIATED(this%description_msg)) THEN
2936 WRITE(*,'()')
2937 WRITE(*,'(A)')'### Description'
2938 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2939 DO j = 1, line_split_get_nlines(help_line)
2940 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2941 ENDDO
2942 CALL delete(help_line)
2943
2944ENDIF
2945
2946WRITE(*,'(/,A)')'### Options'
2947
2948DO i = 1, this%options%arraysize ! loop over options
2949 CALL option_format_md(this%options%array(i), ncols)
2950ENDDO
2951
2952CONTAINS
2953
2954FUNCTION mdquote_usage_msg(usage_msg)
2955CHARACTER(len=*),INTENT(in) :: usage_msg
2956
2957CHARACTER(len=LEN(usage_msg)+2) :: mdquote_usage_msg
2958INTEGER :: colon
2959
2960colon = index(usage_msg, ':') ! typically 'Usage: cp [options] origin destination'
2961IF (colon > 0 .AND. colon < len(usage_msg)-1) THEN
2962 mdquote_usage_msg = usage_msg(:colon+1)//'`'//usage_msg(colon+2:)//'`'
2963ELSE
2964 mdquote_usage_msg = usage_msg
2965ENDIF
2966
2967END FUNCTION mdquote_usage_msg
2968
2969END SUBROUTINE optionparser_printhelpmd
2970
2974SUBROUTINE optionparser_printhelphtmlform(this)
2975TYPE(optionparser),INTENT(in) :: this
2976
2977INTEGER :: i
2978
2979DO i = 1, this%options%arraysize ! loop over options
2980 CALL option_format_htmlform(this%options%array(i))
2981ENDDO
2982
2983WRITE(*,'(A)')'<input class="libsim_sub" type="submit" value="runprogram" />'
2984
2985END SUBROUTINE optionparser_printhelphtmlform
2986
2987
2988SUBROUTINE optionparser_make_completion(this)
2989TYPE(optionparser),INTENT(in) :: this
2990
2991INTEGER :: i
2992CHARACTER(len=512) :: buf
2993
2994CALL getarg(0, buf)
2995
2996WRITE(*,'(A/A/A)')'_'//trim(buf)//'()','{','local cur'
2997
2998WRITE(*,'(A/A/A/A)')'COMPREPLY=()','cur=${COMP_WORDS[COMP_CWORD]}', &
2999 'case "$cur" in','-*)'
3000
3001!-*)
3002! COMPREPLY=( $( compgen -W
3003DO i = 1, this%options%arraysize ! loop over options
3004 IF (this%options%array(i)%need_arg == 2) THEN
3005 ENDIF
3006ENDDO
3007
3008WRITE(*,'(A/A/A)')'esac','return 0','}'
3009
3010END SUBROUTINE optionparser_make_completion
3011
3012
3013SUBROUTINE dirty_char_assignment(destc, destclen, src)
3014USE kinds
3015IMPLICIT NONE
3016
3017CHARACTER(len=1) :: destc(*)
3018CHARACTER(len=*) :: src
3019INTEGER :: destclen
3020
3021INTEGER :: i
3022
3023DO i = 1, min(destclen, len(src))
3024 destc(i) = src(i:i)
3025ENDDO
3026DO i = len(src)+1, destclen
3027 destc(i) = ' '
3028ENDDO
3029
3030END SUBROUTINE dirty_char_assignment
3031
3032END MODULE optionparser_class
Set of functions that return a trimmed CHARACTER representation of the input variable.
Set of functions that return a CHARACTER representation of the input variable.
Methods for successively obtaining the fields of a csv_record object.
Constructor for the class csv_record.
Index method.
Destructor for the optionparser class.
Add a new option of a specific type.
This module defines usefull general purpose function and subroutine.
Utilities for CHARACTER variables.
Gestione degli errori.
Utilities for managing files.
Definition of constants to be used for declaring variables of a desired type.
Definition kinds.F90:245
classe per la gestione del logging
Module for parsing command-line optons.
This class allows to parse the command-line options of a program in an object-oriented way,...

Generated with Doxygen.