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