libsim Versione 7.1.11
|
◆ optionparser_printhelptxt()
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 1700 del file optionparser_class.F90. 1701! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1702! authors:
1703! Davide Cesari <dcesari@arpa.emr.it>
1704! Paolo Patruno <ppatruno@arpa.emr.it>
1705
1706! This program is free software; you can redistribute it and/or
1707! modify it under the terms of the GNU General Public License as
1708! published by the Free Software Foundation; either version 2 of
1709! the License, or (at your option) any later version.
1710
1711! This program is distributed in the hope that it will be useful,
1712! but WITHOUT ANY WARRANTY; without even the implied warranty of
1713! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1714! GNU General Public License for more details.
1724#include "config.h"
1725
1733IMPLICIT NONE
1734
1735
1736! private class
1737TYPE option
1738 CHARACTER(len=1) :: short_opt=''
1739 CHARACTER(len=80) :: long_opt=''
1740 INTEGER :: opttype=-1
1741 INTEGER :: need_arg=0 ! 0=no, 1=optional, 2=yes, was .FALSE.
1742 LOGICAL :: has_default=.false.
1743 CHARACTER(len=1),POINTER :: destc=>null()
1744 INTEGER :: destclen=0
1745 INTEGER :: helpformat=0 ! 0=txt, 1=markdown, 2=htmlform, improve!
1746 INTEGER,POINTER :: desti=>null()
1747 TYPE(arrayof_integer),POINTER :: destiarr=>null()
1748 REAL,POINTER :: destr=>null()
1749 TYPE(arrayof_real),POINTER :: destrarr=>null()
1750 DOUBLE PRECISION, POINTER :: destd=>null()
1751 TYPE(arrayof_doubleprecision),POINTER :: destdarr=>null()
1752 LOGICAL,POINTER :: destl=>null()
1753 TYPE(arrayof_logical),POINTER :: destlarr=>null()
1754 INTEGER,POINTER :: destcount=>null()
1755 INTEGER(kind=int_b),ALLOCATABLE :: help_msg(:)
1756END TYPE option
1757
1758#define ARRAYOF_ORIGTYPE TYPE(option)
1759#define ARRAYOF_TYPE arrayof_option
1760#define ARRAYOF_ORIGDESTRUCTOR(x) CALL option_delete(x)
1761#define ARRAYOF_PRIVATE 1
1762#include "arrayof_pre_nodoc.F90"
1763! from arrayof
1764!PUBLIC insert, append, remove, packarray
1765!PUBLIC insert_unique, append_unique
1766
1845 PRIVATE
1846 INTEGER(kind=int_b),POINTER :: usage_msg(:), description_msg(:)
1847 TYPE(arrayof_option) :: options
1848 LOGICAL :: httpmode=.false.
1850
1851
1856 MODULE PROCEDURE optionparser_add_c, optionparser_add_i, optionparser_add_r, &
1857 optionparser_add_d, optionparser_add_l, &
1858 optionparser_add_iarray, optionparser_add_rarray, optionparser_add_darray
1859END INTERFACE
1860
1861INTERFACE c_e
1862 MODULE PROCEDURE option_c_e
1863END INTERFACE
1864
1873 MODULE PROCEDURE optionparser_delete!?, option_delete
1874END INTERFACE
1875
1876
1877INTEGER,PARAMETER :: opttype_c = 1, opttype_i = 2, opttype_r = 3, &
1878 opttype_d = 4, opttype_l = 5, opttype_count = 6, opttype_help = 7, &
1879 opttype_sep = 8, opttype_carr = 11, opttype_iarr = 12, opttype_rarr = 13, &
1880 opttype_darr = 14, opttype_larr = 15
1881
1882INTEGER,PARAMETER :: optionparser_ok = 0
1883INTEGER,PARAMETER :: optionparser_help = 1
1884INTEGER,PARAMETER :: optionparser_err = 2
1885
1886
1887PRIVATE
1889 optionparser_add_count, optionparser_add_help, optionparser_add_sep, &
1890 optionparser_parse, optionparser_printhelp, &
1891 optionparser_ok, optionparser_help, optionparser_err
1892
1893
1894CONTAINS
1895
1896#include "arrayof_post_nodoc.F90"
1897
1898! Constructor for the option class
1899FUNCTION option_new(short_opt, long_opt, default, help) RESULT(this)
1900CHARACTER(len=*),INTENT(in) :: short_opt
1901CHARACTER(len=*),INTENT(in) :: long_opt
1902CHARACTER(len=*),INTENT(in) :: default
1903CHARACTER(len=*),OPTIONAL :: help
1904TYPE(option) :: this
1905
1906IF (short_opt == '' .AND. long_opt == '') THEN
1907#ifdef DEBUG
1908! programmer error condition, option empty
1909 CALL l4f_log(l4f_error, 'in optionparser, both short and long options empty')
1910 CALL raise_fatal_error()
1911#else
1912 CALL l4f_log(l4f_warn, 'in optionparser, both short and long options empty')
1913#endif
1914 RETURN
1915ENDIF
1916
1917this%short_opt = short_opt
1918this%long_opt = long_opt
1919IF (PRESENT(help)) THEN
1920 this%help_msg = fchar_to_cstr(trim(help)//trim(default)) ! f2003 automatic alloc
1921ENDIF
1922this%has_default = (len_trim(default) > 0)
1923
1924END FUNCTION option_new
1925
1926
1927! Destructor for the \a option class, the memory associated with
1928! the object is freed.
1929SUBROUTINE option_delete(this)
1930TYPE(option),INTENT(inout) :: this ! object to destroy
1931
1932IF (ALLOCATED(this%help_msg)) DEALLOCATE(this%help_msg)
1933NULLIFY(this%destc)
1934NULLIFY(this%desti)
1935NULLIFY(this%destr)
1936NULLIFY(this%destd)
1937NULLIFY(this%destl)
1938NULLIFY(this%destcount)
1939
1940END SUBROUTINE option_delete
1941
1942
1943FUNCTION option_found(this, optarg) RESULT(status)
1944TYPE(option),INTENT(inout) :: this
1945CHARACTER(len=*),INTENT(in),OPTIONAL :: optarg
1946INTEGER :: status
1947
1948TYPE(csv_record) :: arrparser
1949INTEGER :: ibuff
1950REAL :: rbuff
1951DOUBLE PRECISION :: dbuff
1952
1953status = optionparser_ok
1954
1955SELECT CASE(this%opttype)
1956CASE(opttype_c)
1957 CALL dirty_char_assignment(this%destc, this%destclen, trim(optarg))
1958! this%destc(1:this%destclen) = optarg
1959 IF (len_trim(optarg) > this%destclen) THEN
1960 CALL l4f_log(l4f_warn, &
1961 'in optionparser, argument '''//trim(optarg)//''' too long, truncated')
1962 ENDIF
1963CASE(opttype_i)
1964 READ(optarg,'(I12)',err=100)this%desti
1965CASE(opttype_iarr)
1968 DO WHILE(.NOT.csv_record_end(arrparser))
1970 CALL insert(this%destiarr, ibuff)
1971 ENDDO
1972 CALL packarray(this%destiarr)
1974CASE(opttype_r)
1975 READ(optarg,'(F20.0)',err=102)this%destr
1976CASE(opttype_rarr)
1979 DO WHILE(.NOT.csv_record_end(arrparser))
1981 CALL insert(this%destrarr, rbuff)
1982 ENDDO
1983 CALL packarray(this%destrarr)
1985CASE(opttype_d)
1986 READ(optarg,'(F20.0)',err=102)this%destd
1987CASE(opttype_darr)
1990 DO WHILE(.NOT.csv_record_end(arrparser))
1992 CALL insert(this%destdarr, dbuff)
1993 ENDDO
1994 CALL packarray(this%destdarr)
1996CASE(opttype_l)
1997 this%destl = .true.
1998CASE(opttype_count)
1999 this%destcount = this%destcount + 1
2000CASE(opttype_help)
2001 status = optionparser_help
2002 SELECT CASE(optarg) ! set help format
2003 CASE('md', 'markdown')
2004 this%helpformat = 1
2005 CASE('htmlform')
2006 this%helpformat = 2
2007 END SELECT
2008END SELECT
2009
2010RETURN
2011
2012100 status = optionparser_err
2013CALL l4f_log(l4f_error, &
2014 'in optionparser, argument '''//trim(optarg)//''' not valid as integer')
2015RETURN
2016102 status = optionparser_err
2017CALL l4f_log(l4f_error, &
2018 'in optionparser, argument '''//trim(optarg)//''' not valid as real')
2019RETURN
2020
2021END FUNCTION option_found
2022
2023
2024! Return a string which gives a short representation of the
2025! option \a this, without help message. The resulting string is quite
2026! long and it should be trimmed with the \a TRIM() intrinsic
2027! function.
2028FUNCTION option_format_opt(this) RESULT(format_opt)
2029TYPE(option),INTENT(in) :: this
2030
2031CHARACTER(len=100) :: format_opt
2032
2033CHARACTER(len=20) :: argname
2034
2035SELECT CASE(this%opttype)
2036CASE(opttype_c)
2037 argname = 'STRING'
2038CASE(opttype_i)
2039 argname = 'INT'
2040CASE(opttype_iarr)
2041 argname = 'INT[,INT...]'
2042CASE(opttype_r, opttype_d)
2043 argname = 'REAL'
2044CASE(opttype_rarr, opttype_darr)
2045 argname = 'REAL[,REAL...]'
2046CASE default
2047 argname = ''
2048END SELECT
2049
2050format_opt = ''
2051IF (this%short_opt /= '') THEN
2052 format_opt(len_trim(format_opt)+1:) = ' -'//this%short_opt
2053 IF (argname /= '') THEN
2054 format_opt(len_trim(format_opt)+1:) = ' '//trim(argname)
2055 ENDIF
2056ENDIF
2057IF (this%short_opt /= '' .AND. this%long_opt /= '') THEN
2058 format_opt(len_trim(format_opt)+1:) = ','
2059ENDIF
2060IF (this%long_opt /= '') THEN
2061 format_opt(len_trim(format_opt)+1:) = ' --'//this%long_opt
2062 IF (argname /= '') THEN
2063 format_opt(len_trim(format_opt)+1:) = '='//trim(argname)
2064 ENDIF
2065ENDIF
2066
2067END FUNCTION option_format_opt
2068
2069
2070! print on stdout a human-readable text representation of a single option
2071SUBROUTINE option_format_help(this, ncols)
2072TYPE(option),INTENT(in) :: this
2073INTEGER,INTENT(in) :: ncols
2074
2075INTEGER :: j
2076INTEGER, PARAMETER :: indent = 10
2077TYPE(line_split) :: help_line
2078
2079
2080IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
2081 IF (ALLOCATED(this%help_msg)) THEN
2082! help2man is quite picky about the treatment of arbitrary lines
2083! within options, the only universal way seems to be unindented lines
2084! with an empty line before and after
2085 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
2086 WRITE(*,'()')
2087 DO j = 1, line_split_get_nlines(help_line)
2088 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2089 ENDDO
2091 WRITE(*,'()')
2092 ENDIF
2093ELSE ! ordinary option
2094! print option brief representation
2095 WRITE(*,'(A)')trim(option_format_opt(this))
2096! print option help
2097 IF (ALLOCATED(this%help_msg)) THEN
2098 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
2099 DO j = 1, line_split_get_nlines(help_line)
2100 WRITE(*,'(T10,A)')trim(line_split_get_line(help_line,j))
2101 ENDDO
2103 ENDIF
2104ENDIF
2105
2106END SUBROUTINE option_format_help
2107
2108
2109! print on stdout a markdown representation of a single option
2110SUBROUTINE option_format_md(this, ncols)
2111TYPE(option),INTENT(in) :: this
2112INTEGER,INTENT(in) :: ncols
2113
2114INTEGER :: j
2115INTEGER, PARAMETER :: indent = 2
2116TYPE(line_split) :: help_line
2117
2118IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
2119 IF (ALLOCATED(this%help_msg)) THEN
2120 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
2121 WRITE(*,'()')
2122 DO j = 1, line_split_get_nlines(help_line)
2123 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2124 ENDDO
2126 WRITE(*,'()')
2127 ENDIF
2128ELSE ! ordinary option
2129! print option brief representation
2130 WRITE(*,'(''`'',A,''`'')')trim(option_format_opt(this))
2131! print option help
2132 IF (ALLOCATED(this%help_msg)) THEN
2133 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
2134 DO j = 1, line_split_get_nlines(help_line)
2135 WRITE(*,'(''> '',A)')trim(line_split_get_line(help_line,j))
2136 ENDDO
2138 WRITE(*,'()')
2139 ENDIF
2140ENDIF
2141
2142END SUBROUTINE option_format_md
2143
2144
2145! print on stdout an html form representation of a single option
2146SUBROUTINE option_format_htmlform(this)
2147TYPE(option),INTENT(in) :: this
2148
2149CHARACTER(len=80) :: opt_name, opt_id, opt_default ! check len of default
2150
2151IF (.NOT.c_e(this)) RETURN
2152IF (this%long_opt == '') THEN
2153 opt_name = this%short_opt
2154 opt_id = 'short_opt_'//this%short_opt
2155ELSE
2156 opt_name = this%long_opt
2157 opt_id = this%long_opt
2158ENDIF
2159
2160SELECT CASE(this%opttype)
2161CASE(opttype_c)
2162 CALL option_format_html_openspan('text')
2163
2164 IF (this%has_default .AND. ASSOCIATED(this%destc) .AND. this%destclen > 0) THEN
2165! opt_default = TRANSFER(this%destc(1:MIN(LEN(opt_default),this%destclen)), &
2166! opt_default) ! improve
2167 opt_default = ''
2168 WRITE(*,'(A)')' value="'//trim(opt_default)//'"'
2169 ENDIF
2170 CALL option_format_html_help()
2171 CALL option_format_html_closespan()
2172
2173CASE(opttype_i,opttype_r,opttype_d)
2174 CALL option_format_html_openspan('text')
2175 IF (this%has_default) THEN
2176 SELECT CASE(this%opttype)
2177 CASE(opttype_i)
2179! todo CASE(opttype_iarr)
2180 CASE(opttype_r)
2182 CASE(opttype_d)
2184 END SELECT
2185 ENDIF
2186 CALL option_format_html_help()
2187 CALL option_format_html_closespan()
2188
2189! todo CASE(opttype_iarr)
2190
2191CASE(opttype_l)
2192 CALL option_format_html_openspan('checkbox')
2193 CALL option_format_html_help()
2194 CALL option_format_html_closespan()
2195
2196CASE(opttype_count)
2197 CALL option_format_html_openspan('number')
2198 CALL option_format_html_help()
2199 CALL option_format_html_closespan()
2200
2201CASE(opttype_sep)
2202END SELECT
2203
2204
2205CONTAINS
2206
2207SUBROUTINE option_format_html_openspan(formtype)
2208CHARACTER(len=*),INTENT(in) :: formtype
2209
2210WRITE(*,'(A)')'<span class="libsim_optbox" id="span_'//trim(opt_id)//'">'//trim(opt_name)//':'
2211! size=? maxlen=?
2212WRITE(*,'(A)')'<input class_"libsim_opt" id="'//trim(opt_id)//'" type="'//formtype// &
2213 '" name="'//trim(opt_id)//'" '
2214
2215END SUBROUTINE option_format_html_openspan
2216
2217SUBROUTINE option_format_html_closespan()
2218
2219WRITE(*,'(A)')'/></span>'
2220
2221END SUBROUTINE option_format_html_closespan
2222
2223SUBROUTINE option_format_html_help()
2224INTEGER :: j
2225TYPE(line_split) :: help_line
2226CHARACTER(len=20) :: form
2227
2228IF (ALLOCATED(this%help_msg)) THEN
2229 WRITE(*,'(A,$)')' title="'
2230
2231 help_line = line_split_new(cstr_to_fchar(this%help_msg), 80)
2232 form = '(A,'' '')'
2233 DO j = 1, line_split_get_nlines(help_line)
2234 IF (j == line_split_get_nlines(help_line)) form = '(A,''"'',$)'
2235 WRITE(*,form)trim(line_split_get_line(help_line,j)) ! lines should be properly quoted here
2236 ENDDO
2237
2238ENDIF
2239
2240END SUBROUTINE option_format_html_help
2241
2242END SUBROUTINE option_format_htmlform
2243
2244
2245FUNCTION option_c_e(this) RESULT(c_e)
2246TYPE(option),INTENT(in) :: this
2247
2248LOGICAL :: c_e
2249
2250c_e = this%long_opt /= ' ' .OR. this%short_opt /= ' '
2251
2252END FUNCTION option_c_e
2253
2254
2258FUNCTION optionparser_new(usage_msg, description_msg) RESULT(this)
2259CHARACTER(len=*), INTENT(in), OPTIONAL :: usage_msg
2260CHARACTER(len=*), INTENT(in), OPTIONAL :: description_msg
2261
2262TYPE(optionparser) :: this
2263
2264IF (PRESENT(usage_msg)) THEN
2265 CALL fchar_to_cstr_alloc(trim(usage_msg), this%usage_msg)
2266ELSE
2267 NULLIFY(this%usage_msg)
2268ENDIF
2269IF (PRESENT(description_msg)) THEN
2270 CALL fchar_to_cstr_alloc(trim(description_msg), this%description_msg)
2271ELSE
2272 NULLIFY(this%description_msg)
2273ENDIF
2274
2275END FUNCTION optionparser_new
2276
2277
2278SUBROUTINE optionparser_delete(this)
2279TYPE(optionparser),INTENT(inout) :: this
2280
2281IF (ASSOCIATED(this%usage_msg)) DEALLOCATE(this%usage_msg)
2282IF (ASSOCIATED(this%description_msg)) DEALLOCATE(this%description_msg)
2284
2285END SUBROUTINE optionparser_delete
2286
2287
2295SUBROUTINE optionparser_add_c(this, short_opt, long_opt, dest, default, help, isopt)
2296TYPE(optionparser),INTENT(inout) :: this
2297CHARACTER(len=*),INTENT(in) :: short_opt
2298CHARACTER(len=*),INTENT(in) :: long_opt
2299CHARACTER(len=*),TARGET :: dest
2300CHARACTER(len=*),OPTIONAL :: default
2301CHARACTER(len=*),OPTIONAL :: help
2302LOGICAL,INTENT(in),OPTIONAL :: isopt
2303
2304CHARACTER(LEN=60) :: cdefault
2305INTEGER :: i
2306TYPE(option) :: myoption
2307
2308
2309IF (PRESENT(default)) THEN
2311ELSE
2312 cdefault = ''
2313ENDIF
2314
2315! common initialisation
2316myoption = option_new(short_opt, long_opt, cdefault, help)
2317IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2318
2319myoption%destc => dest(1:1)
2320myoption%destclen = len(dest) ! needed to avoid exceeding the length of dest
2321IF (PRESENT(default)) &
2322 CALL dirty_char_assignment(myoption%destc, myoption%destclen, default)
2323!IF (PRESENT(default)) myoption%destc(1:myoption%destclen) = default
2324myoption%opttype = opttype_c
2325IF (optio_log(isopt)) THEN
2326 myoption%need_arg = 1
2327ELSE
2328 myoption%need_arg = 2
2329ENDIF
2330
2331i = arrayof_option_append(this%options, myoption)
2332
2333END SUBROUTINE optionparser_add_c
2334
2335
2342SUBROUTINE optionparser_add_i(this, short_opt, long_opt, dest, default, help)
2343TYPE(optionparser),INTENT(inout) :: this
2344CHARACTER(len=*),INTENT(in) :: short_opt
2345CHARACTER(len=*),INTENT(in) :: long_opt
2346INTEGER,TARGET :: dest
2347INTEGER,OPTIONAL :: default
2348CHARACTER(len=*),OPTIONAL :: help
2349
2350CHARACTER(LEN=40) :: cdefault
2351INTEGER :: i
2352TYPE(option) :: myoption
2353
2354IF (PRESENT(default)) THEN
2356ELSE
2357 cdefault = ''
2358ENDIF
2359
2360! common initialisation
2361myoption = option_new(short_opt, long_opt, cdefault, help)
2362IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2363
2364myoption%desti => dest
2365IF (PRESENT(default)) myoption%desti = default
2366myoption%opttype = opttype_i
2367myoption%need_arg = 2
2368
2369i = arrayof_option_append(this%options, myoption)
2370
2371END SUBROUTINE optionparser_add_i
2372
2373
2383SUBROUTINE optionparser_add_iarray(this, short_opt, long_opt, dest, default, help)
2384TYPE(optionparser),INTENT(inout) :: this
2385CHARACTER(len=*),INTENT(in) :: short_opt
2386CHARACTER(len=*),INTENT(in) :: long_opt
2387TYPE(arrayof_integer),TARGET :: dest
2388INTEGER,OPTIONAL :: default(:)
2389CHARACTER(len=*),OPTIONAL :: help
2390
2391CHARACTER(LEN=40) :: cdefault
2392INTEGER :: i
2393TYPE(option) :: myoption
2394
2395cdefault = ''
2396IF (PRESENT(default)) THEN
2397 IF (SIZE(default) == 1) THEN
2399 ELSE IF (SIZE(default) > 1) THEN
2401 ENDIF
2402ENDIF
2403
2404! common initialisation
2405myoption = option_new(short_opt, long_opt, cdefault, help)
2406IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2407
2408myoption%destiarr => dest
2409IF (PRESENT(default)) THEN
2410 CALL insert(myoption%destiarr, default)
2411 CALL packarray(myoption%destiarr)
2412ENDIF
2413myoption%opttype = opttype_iarr
2414myoption%need_arg = 2
2415
2416i = arrayof_option_append(this%options, myoption)
2417
2418END SUBROUTINE optionparser_add_iarray
2419
2420
2427SUBROUTINE optionparser_add_r(this, short_opt, long_opt, dest, default, help)
2428TYPE(optionparser),INTENT(inout) :: this
2429CHARACTER(len=*),INTENT(in) :: short_opt
2430CHARACTER(len=*),INTENT(in) :: long_opt
2431REAL,TARGET :: dest
2432REAL,OPTIONAL :: default
2433CHARACTER(len=*),OPTIONAL :: help
2434
2435CHARACTER(LEN=40) :: cdefault
2436INTEGER :: i
2437TYPE(option) :: myoption
2438
2439IF (PRESENT(default)) THEN
2441ELSE
2442 cdefault = ''
2443ENDIF
2444
2445! common initialisation
2446myoption = option_new(short_opt, long_opt, cdefault, help)
2447IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2448
2449myoption%destr => dest
2450IF (PRESENT(default)) myoption%destr = default
2451myoption%opttype = opttype_r
2452myoption%need_arg = 2
2453
2454i = arrayof_option_append(this%options, myoption)
2455
2456END SUBROUTINE optionparser_add_r
2457
2458
2468SUBROUTINE optionparser_add_rarray(this, short_opt, long_opt, dest, default, help)
2469TYPE(optionparser),INTENT(inout) :: this
2470CHARACTER(len=*),INTENT(in) :: short_opt
2471CHARACTER(len=*),INTENT(in) :: long_opt
2472TYPE(arrayof_real),TARGET :: dest
2473REAL,OPTIONAL :: default(:)
2474CHARACTER(len=*),OPTIONAL :: help
2475
2476CHARACTER(LEN=40) :: cdefault
2477INTEGER :: i
2478TYPE(option) :: myoption
2479
2480cdefault = ''
2481IF (PRESENT(default)) THEN
2482 IF (SIZE(default) == 1) THEN
2484 ELSE IF (SIZE(default) > 1) THEN
2486 ENDIF
2487ENDIF
2488
2489! common initialisation
2490myoption = option_new(short_opt, long_opt, cdefault, help)
2491IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2492
2493myoption%destrarr => dest
2494IF (PRESENT(default)) THEN
2495 CALL insert(myoption%destrarr, default)
2496 CALL packarray(myoption%destrarr)
2497ENDIF
2498myoption%opttype = opttype_rarr
2499myoption%need_arg = 2
2500
2501i = arrayof_option_append(this%options, myoption)
2502
2503END SUBROUTINE optionparser_add_rarray
2504
2505
2512SUBROUTINE optionparser_add_d(this, short_opt, long_opt, dest, default, help)
2513TYPE(optionparser),INTENT(inout) :: this
2514CHARACTER(len=*),INTENT(in) :: short_opt
2515CHARACTER(len=*),INTENT(in) :: long_opt
2516DOUBLE PRECISION,TARGET :: dest
2517DOUBLE PRECISION,OPTIONAL :: default
2518CHARACTER(len=*),OPTIONAL :: help
2519
2520CHARACTER(LEN=40) :: cdefault
2521INTEGER :: i
2522TYPE(option) :: myoption
2523
2524IF (PRESENT(default)) THEN
2525 IF (c_e(default)) THEN
2527 ELSE
2529 ENDIF
2530ELSE
2531 cdefault = ''
2532ENDIF
2533
2534! common initialisation
2535myoption = option_new(short_opt, long_opt, cdefault, help)
2536IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2537
2538myoption%destd => dest
2539IF (PRESENT(default)) myoption%destd = default
2540myoption%opttype = opttype_d
2541myoption%need_arg = 2
2542
2543i = arrayof_option_append(this%options, myoption)
2544
2545END SUBROUTINE optionparser_add_d
2546
2547
2557SUBROUTINE optionparser_add_darray(this, short_opt, long_opt, dest, default, help)
2558TYPE(optionparser),INTENT(inout) :: this
2559CHARACTER(len=*),INTENT(in) :: short_opt
2560CHARACTER(len=*),INTENT(in) :: long_opt
2561TYPE(arrayof_doubleprecision),TARGET :: dest
2562DOUBLE PRECISION,OPTIONAL :: default(:)
2563CHARACTER(len=*),OPTIONAL :: help
2564
2565CHARACTER(LEN=40) :: cdefault
2566INTEGER :: i
2567TYPE(option) :: myoption
2568
2569cdefault = ''
2570IF (PRESENT(default)) THEN
2571 IF (SIZE(default) == 1) THEN
2573 ELSE IF (SIZE(default) > 1) THEN
2575 ENDIF
2576ENDIF
2577
2578! common initialisation
2579myoption = option_new(short_opt, long_opt, cdefault, help)
2580IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2581
2582myoption%destdarr => dest
2583IF (PRESENT(default)) THEN
2584 CALL insert(myoption%destdarr, default)
2585 CALL packarray(myoption%destdarr)
2586ENDIF
2587myoption%opttype = opttype_darr
2588myoption%need_arg = 2
2589
2590i = arrayof_option_append(this%options, myoption)
2591
2592END SUBROUTINE optionparser_add_darray
2593
2594
2601SUBROUTINE optionparser_add_l(this, short_opt, long_opt, dest, help)
2602TYPE(optionparser),INTENT(inout) :: this
2603CHARACTER(len=*),INTENT(in) :: short_opt
2604CHARACTER(len=*),INTENT(in) :: long_opt
2605LOGICAL,TARGET :: dest
2606CHARACTER(len=*),OPTIONAL :: help
2607
2608INTEGER :: i
2609TYPE(option) :: myoption
2610
2611! common initialisation
2612myoption = option_new(short_opt, long_opt, '', help)
2613IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2614
2615myoption%destl => dest
2616myoption%destl = .false. ! unconditionally set to false, option can only set it to true
2617myoption%opttype = opttype_l
2618myoption%need_arg = 0
2619
2620i = arrayof_option_append(this%options, myoption)
2621
2622END SUBROUTINE optionparser_add_l
2623
2624
2629SUBROUTINE optionparser_add_count(this, short_opt, long_opt, dest, start, help)
2630TYPE(optionparser),INTENT(inout) :: this
2631CHARACTER(len=*),INTENT(in) :: short_opt
2632CHARACTER(len=*),INTENT(in) :: long_opt
2633INTEGER,TARGET :: dest
2634INTEGER,OPTIONAL :: start
2635CHARACTER(len=*),OPTIONAL :: help
2636
2637INTEGER :: i
2638TYPE(option) :: myoption
2639
2640! common initialisation
2641myoption = option_new(short_opt, long_opt, '', help)
2642IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2643
2644myoption%destcount => dest
2645IF (PRESENT(start)) myoption%destcount = start
2646myoption%opttype = opttype_count
2647myoption%need_arg = 0
2648
2649i = arrayof_option_append(this%options, myoption)
2650
2651END SUBROUTINE optionparser_add_count
2652
2653
2668SUBROUTINE optionparser_add_help(this, short_opt, long_opt, help)
2669TYPE(optionparser),INTENT(inout) :: this
2670CHARACTER(len=*),INTENT(in) :: short_opt
2671CHARACTER(len=*),INTENT(in) :: long_opt
2672CHARACTER(len=*),OPTIONAL :: help
2673
2674INTEGER :: i
2675TYPE(option) :: myoption
2676
2677! common initialisation
2678myoption = option_new(short_opt, long_opt, '', help)
2679IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2680
2681myoption%opttype = opttype_help
2682myoption%need_arg = 1
2683
2684i = arrayof_option_append(this%options, myoption)
2685
2686END SUBROUTINE optionparser_add_help
2687
2688
2699SUBROUTINE optionparser_add_sep(this, help)
2700TYPE(optionparser),INTENT(inout) :: this
2701!CHARACTER(len=*),INTENT(in) :: short_opt !< the short option (may be empty)
2702!CHARACTER(len=*),INTENT(in) :: long_opt !< the long option (may be empty)
2703CHARACTER(len=*) :: help
2704
2705INTEGER :: i
2706TYPE(option) :: myoption
2707
2708! common initialisation
2709myoption = option_new('_', '_', '', help)
2710IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2711
2712myoption%opttype = opttype_sep
2713myoption%need_arg = 0
2714
2715i = arrayof_option_append(this%options, myoption)
2716
2717END SUBROUTINE optionparser_add_sep
2718
2719
2729SUBROUTINE optionparser_parse(this, nextarg, status)
2730TYPE(optionparser),INTENT(inout) :: this
2731INTEGER,INTENT(out) :: nextarg
2732INTEGER,INTENT(out) :: status
2733
2734INTEGER :: i, j, endopt, indeq, iargc
2735CHARACTER(len=16384) :: arg, optarg
2736
2737status = optionparser_ok
2738i = 1
2739DO WHILE(i <= iargc())
2740 CALL getarg(i, arg)
2741 IF (arg == '--') THEN ! explicit end of options
2742 i = i + 1 ! skip present option (--)
2743 EXIT
2744 ELSE IF (arg == '-') THEN ! a single - is not an option
2745 EXIT
2746 ELSE IF (arg(1:2) == '--') THEN ! long option
2748 IF (indeq /= 0) THEN ! = present
2749 endopt = indeq - 1
2750 ELSE ! no =
2751 endopt = len_trim(arg)
2752 ENDIF
2753 find_longopt: DO j = 1, this%options%arraysize
2754 IF (this%options%array(j)%long_opt == arg(3:endopt)) THEN ! found option
2755 SELECT CASE(this%options%array(j)%need_arg)
2756 CASE(2) ! compulsory
2757 IF (indeq /= 0) THEN
2758 optarg = arg(indeq+1:)
2759 status = max(option_found(this%options%array(j), optarg), &
2760 status)
2761 ELSE
2762 IF (i < iargc()) THEN
2763 i=i+1
2764 CALL getarg(i, optarg)
2765 status = max(option_found(this%options%array(j), optarg), &
2766 status)
2767 ELSE
2768 status = optionparser_err
2769 CALL l4f_log(l4f_error, &
2770 'in optionparser, option '''//trim(arg)//''' requires an argument')
2771 ENDIF
2772 ENDIF
2773 CASE(1) ! optional
2774 IF (indeq /= 0) THEN
2775 optarg = arg(indeq+1:)
2776 ELSE
2777 IF (i < iargc()) THEN
2778 CALL getarg(i+1, optarg)
2779 IF (optarg(1:1) == '-') THEN
2780 optarg = cmiss ! refused
2781 ELSE
2782 i=i+1 ! accepted
2783 ENDIF
2784 ELSE
2785 optarg = cmiss ! refused
2786 ENDIF
2787 ENDIF
2788 status = max(option_found(this%options%array(j), optarg), &
2789 status)
2790 CASE(0)
2791 status = max(option_found(this%options%array(j)), &
2792 status)
2793 END SELECT
2794 EXIT find_longopt
2795 ENDIF
2796 ENDDO find_longopt
2797 IF (j > this%options%arraysize) THEN
2798 status = optionparser_err
2799 CALL l4f_log(l4f_error, &
2800 'in optionparser, option '''//trim(arg)//''' not valid')
2801 ENDIF
2802 ELSE IF (arg(1:1) == '-') THEN ! short option
2803 find_shortopt: DO j = 1, this%options%arraysize
2804 IF (this%options%array(j)%short_opt == arg(2:2)) THEN ! found option
2805 SELECT CASE(this%options%array(j)%need_arg)
2806 CASE(2) ! compulsory
2807 IF (len_trim(arg) > 2) THEN
2808 optarg = arg(3:)
2809 status = max(option_found(this%options%array(j), optarg), &
2810 status)
2811 ELSE
2812 IF (i < iargc()) THEN
2813 i=i+1
2814 CALL getarg(i, optarg)
2815 status = max(option_found(this%options%array(j), optarg), &
2816 status)
2817 ELSE
2818 status = optionparser_err
2819 CALL l4f_log(l4f_error, &
2820 'in optionparser, option '''//trim(arg)//''' requires an argument')
2821 ENDIF
2822 ENDIF
2823 CASE(1) ! optional
2824 IF (len_trim(arg) > 2) THEN
2825 optarg = arg(3:)
2826 ELSE
2827 IF (i < iargc()) THEN
2828 CALL getarg(i+1, optarg)
2829 IF (optarg(1:1) == '-') THEN
2830 optarg = cmiss ! refused
2831 ELSE
2832 i=i+1 ! accepted
2833 ENDIF
2834 ELSE
2835 optarg = cmiss ! refused
2836 ENDIF
2837 ENDIF
2838 status = max(option_found(this%options%array(j), optarg), &
2839 status)
2840 CASE(0)
2841 status = max(option_found(this%options%array(j)), &
2842 status)
2843 END SELECT
2844 EXIT find_shortopt
2845 ENDIF
2846 ENDDO find_shortopt
2847 IF (j > this%options%arraysize) THEN
2848 status = optionparser_err
2849 CALL l4f_log(l4f_error, &
2850 'in optionparser, option '''//trim(arg)//''' not valid')
2851 ENDIF
2852 ELSE ! unrecognized = end of options
2853 EXIT
2854 ENDIF
2855 i = i + 1
2856ENDDO
2857
2858nextarg = i
2859SELECT CASE(status)
2860CASE(optionparser_err, optionparser_help)
2861 CALL optionparser_printhelp(this)
2862END SELECT
2863
2864END SUBROUTINE optionparser_parse
2865
2866
2870SUBROUTINE optionparser_printhelp(this)
2871TYPE(optionparser),INTENT(in) :: this
2872
2873INTEGER :: i, form
2874
2875form = 0
2876DO i = 1, this%options%arraysize ! loop over options
2877 IF (this%options%array(i)%opttype == opttype_help) THEN
2878 form = this%options%array(i)%helpformat
2879 ENDIF
2880ENDDO
2881
2882SELECT CASE(form)
2883CASE(0)
2884 CALL optionparser_printhelptxt(this)
2885CASE(1)
2886 CALL optionparser_printhelpmd(this)
2887CASE(2)
2888 CALL optionparser_printhelphtmlform(this)
2889END SELECT
2890
2891END SUBROUTINE optionparser_printhelp
2892
2893
2897SUBROUTINE optionparser_printhelptxt(this)
2898TYPE(optionparser),INTENT(in) :: this
2899
2900INTEGER :: i, j, ncols
2901CHARACTER(len=80) :: buf
2902TYPE(line_split) :: help_line
2903
2904ncols = default_columns()
2905
2906! print usage message
2907IF (ASSOCIATED(this%usage_msg)) THEN
2908 help_line = line_split_new(cstr_to_fchar(this%usage_msg), ncols)
2909 DO j = 1, line_split_get_nlines(help_line)
2910 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2911 ENDDO
2913ELSE
2914 CALL getarg(0, buf)
2916 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2917 WRITE(*,'(A)')'Usage: '//trim(buf(i+1:))//' [options] [arguments]'
2918ENDIF
2919
2920! print description message
2921IF (ASSOCIATED(this%description_msg)) THEN
2922 WRITE(*,'()')
2923 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2924 DO j = 1, line_split_get_nlines(help_line)
2925 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2926 ENDDO
2928ENDIF
2929
2930WRITE(*,'(/,A)')'Options:'
2931
2932DO i = 1, this%options%arraysize ! loop over options
2933 CALL option_format_help(this%options%array(i), ncols)
2934ENDDO
2935
2936END SUBROUTINE optionparser_printhelptxt
2937
2938
2942SUBROUTINE optionparser_printhelpmd(this)
2943TYPE(optionparser),INTENT(in) :: this
2944
2945INTEGER :: i, j, ncols
2946CHARACTER(len=80) :: buf
2947TYPE(line_split) :: help_line
2948
2949ncols = default_columns()
2950
2951! print usage message
2952WRITE(*,'(A)')'### Synopsis'
2953
2954IF (ASSOCIATED(this%usage_msg)) THEN
2955 help_line = line_split_new(mdquote_usage_msg(cstr_to_fchar(this%usage_msg)), ncols)
2956 DO j = 1, line_split_get_nlines(help_line)
2957 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2958 ENDDO
2960ELSE
2961 CALL getarg(0, buf)
2963 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2964 WRITE(*,'(A)')'Usage: `'//trim(buf(i+1:))//' [options] [arguments]`'
2965ENDIF
2966
2967! print description message
2968IF (ASSOCIATED(this%description_msg)) THEN
2969 WRITE(*,'()')
2970 WRITE(*,'(A)')'### Description'
2971 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2972 DO j = 1, line_split_get_nlines(help_line)
2973 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2974 ENDDO
2976
2977ENDIF
2978
2979WRITE(*,'(/,A)')'### Options'
2980
2981DO i = 1, this%options%arraysize ! loop over options
2982 CALL option_format_md(this%options%array(i), ncols)
2983ENDDO
2984
2985CONTAINS
2986
2987FUNCTION mdquote_usage_msg(usage_msg)
2988CHARACTER(len=*),INTENT(in) :: usage_msg
2989
2990CHARACTER(len=LEN(usage_msg)+2) :: mdquote_usage_msg
2991INTEGER :: colon
2992
2994IF (colon > 0 .AND. colon < len(usage_msg)-1) THEN
2995 mdquote_usage_msg = usage_msg(:colon+1)//'`'//usage_msg(colon+2:)//'`'
2996ELSE
2997 mdquote_usage_msg = usage_msg
2998ENDIF
2999
3000END FUNCTION mdquote_usage_msg
3001
3002END SUBROUTINE optionparser_printhelpmd
3003
3007SUBROUTINE optionparser_printhelphtmlform(this)
3008TYPE(optionparser),INTENT(in) :: this
3009
3010INTEGER :: i
3011
3012DO i = 1, this%options%arraysize ! loop over options
3013 CALL option_format_htmlform(this%options%array(i))
3014ENDDO
3015
3016WRITE(*,'(A)')'<input class="libsim_sub" type="submit" value="runprogram" />'
3017
3018END SUBROUTINE optionparser_printhelphtmlform
3019
3020
3021SUBROUTINE optionparser_make_completion(this)
3022TYPE(optionparser),INTENT(in) :: this
3023
3024INTEGER :: i
3025CHARACTER(len=512) :: buf
3026
3027CALL getarg(0, buf)
3028
3029WRITE(*,'(A/A/A)')'_'//trim(buf)//'()','{','local cur'
3030
3031WRITE(*,'(A/A/A/A)')'COMPREPLY=()','cur=${COMP_WORDS[COMP_CWORD]}', &
3032 'case "$cur" in','-*)'
3033
3034!-*)
3035! COMPREPLY=( $( compgen -W
3036DO i = 1, this%options%arraysize ! loop over options
3037 IF (this%options%array(i)%need_arg == 2) THEN
3038 ENDIF
3039ENDDO
3040
3041WRITE(*,'(A/A/A)')'esac','return 0','}'
3042
3043END SUBROUTINE optionparser_make_completion
3044
3045
3046SUBROUTINE dirty_char_assignment(destc, destclen, src)
3048IMPLICIT NONE
3049
3050CHARACTER(len=1) :: destc(*)
3051CHARACTER(len=*) :: src
3052INTEGER :: destclen
3053
3054INTEGER :: i
3055
3056DO i = 1, min(destclen, len(src))
3057 destc(i) = src(i:i)
3058ENDDO
3059DO i = len(src)+1, destclen
3060 destc(i) = ' '
3061ENDDO
3062
3063END SUBROUTINE dirty_char_assignment
3064
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 |