libsim Versione 7.1.11
|
◆ optionparser_printhelpmd()
Print on stdout a markdown representation of the help message. It can be called by the user program and it is called anyway if the program has been called with the
Definizione alla linea 1745 del file optionparser_class.F90. 1746! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1747! authors:
1748! Davide Cesari <dcesari@arpa.emr.it>
1749! Paolo Patruno <ppatruno@arpa.emr.it>
1750
1751! This program is free software; you can redistribute it and/or
1752! modify it under the terms of the GNU General Public License as
1753! published by the Free Software Foundation; either version 2 of
1754! the License, or (at your option) any later version.
1755
1756! This program is distributed in the hope that it will be useful,
1757! but WITHOUT ANY WARRANTY; without even the implied warranty of
1758! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1759! GNU General Public License for more details.
1769#include "config.h"
1770
1778IMPLICIT NONE
1779
1780
1781! private class
1782TYPE option
1783 CHARACTER(len=1) :: short_opt=''
1784 CHARACTER(len=80) :: long_opt=''
1785 INTEGER :: opttype=-1
1786 INTEGER :: need_arg=0 ! 0=no, 1=optional, 2=yes, was .FALSE.
1787 LOGICAL :: has_default=.false.
1788 CHARACTER(len=1),POINTER :: destc=>null()
1789 INTEGER :: destclen=0
1790 INTEGER :: helpformat=0 ! 0=txt, 1=markdown, 2=htmlform, improve!
1791 INTEGER,POINTER :: desti=>null()
1792 TYPE(arrayof_integer),POINTER :: destiarr=>null()
1793 REAL,POINTER :: destr=>null()
1794 TYPE(arrayof_real),POINTER :: destrarr=>null()
1795 DOUBLE PRECISION, POINTER :: destd=>null()
1796 TYPE(arrayof_doubleprecision),POINTER :: destdarr=>null()
1797 LOGICAL,POINTER :: destl=>null()
1798 TYPE(arrayof_logical),POINTER :: destlarr=>null()
1799 INTEGER,POINTER :: destcount=>null()
1800 INTEGER(kind=int_b),ALLOCATABLE :: help_msg(:)
1801END TYPE option
1802
1803#define ARRAYOF_ORIGTYPE TYPE(option)
1804#define ARRAYOF_TYPE arrayof_option
1805#define ARRAYOF_ORIGDESTRUCTOR(x) CALL option_delete(x)
1806#define ARRAYOF_PRIVATE 1
1807#include "arrayof_pre_nodoc.F90"
1808! from arrayof
1809!PUBLIC insert, append, remove, packarray
1810!PUBLIC insert_unique, append_unique
1811
1890 PRIVATE
1891 INTEGER(kind=int_b),POINTER :: usage_msg(:), description_msg(:)
1892 TYPE(arrayof_option) :: options
1893 LOGICAL :: httpmode=.false.
1895
1896
1901 MODULE PROCEDURE optionparser_add_c, optionparser_add_i, optionparser_add_r, &
1902 optionparser_add_d, optionparser_add_l, &
1903 optionparser_add_iarray, optionparser_add_rarray, optionparser_add_darray
1904END INTERFACE
1905
1906INTERFACE c_e
1907 MODULE PROCEDURE option_c_e
1908END INTERFACE
1909
1918 MODULE PROCEDURE optionparser_delete!?, option_delete
1919END INTERFACE
1920
1921
1922INTEGER,PARAMETER :: opttype_c = 1, opttype_i = 2, opttype_r = 3, &
1923 opttype_d = 4, opttype_l = 5, opttype_count = 6, opttype_help = 7, &
1924 opttype_sep = 8, opttype_carr = 11, opttype_iarr = 12, opttype_rarr = 13, &
1925 opttype_darr = 14, opttype_larr = 15
1926
1927INTEGER,PARAMETER :: optionparser_ok = 0
1928INTEGER,PARAMETER :: optionparser_help = 1
1929INTEGER,PARAMETER :: optionparser_err = 2
1930
1931
1932PRIVATE
1934 optionparser_add_count, optionparser_add_help, optionparser_add_sep, &
1935 optionparser_parse, optionparser_printhelp, &
1936 optionparser_ok, optionparser_help, optionparser_err
1937
1938
1939CONTAINS
1940
1941#include "arrayof_post_nodoc.F90"
1942
1943! Constructor for the option class
1944FUNCTION option_new(short_opt, long_opt, default, help) RESULT(this)
1945CHARACTER(len=*),INTENT(in) :: short_opt
1946CHARACTER(len=*),INTENT(in) :: long_opt
1947CHARACTER(len=*),INTENT(in) :: default
1948CHARACTER(len=*),OPTIONAL :: help
1949TYPE(option) :: this
1950
1951IF (short_opt == '' .AND. long_opt == '') THEN
1952#ifdef DEBUG
1953! programmer error condition, option empty
1954 CALL l4f_log(l4f_error, 'in optionparser, both short and long options empty')
1955 CALL raise_fatal_error()
1956#else
1957 CALL l4f_log(l4f_warn, 'in optionparser, both short and long options empty')
1958#endif
1959 RETURN
1960ENDIF
1961
1962this%short_opt = short_opt
1963this%long_opt = long_opt
1964IF (PRESENT(help)) THEN
1965 this%help_msg = fchar_to_cstr(trim(help)//trim(default)) ! f2003 automatic alloc
1966ENDIF
1967this%has_default = (len_trim(default) > 0)
1968
1969END FUNCTION option_new
1970
1971
1972! Destructor for the \a option class, the memory associated with
1973! the object is freed.
1974SUBROUTINE option_delete(this)
1975TYPE(option),INTENT(inout) :: this ! object to destroy
1976
1977IF (ALLOCATED(this%help_msg)) DEALLOCATE(this%help_msg)
1978NULLIFY(this%destc)
1979NULLIFY(this%desti)
1980NULLIFY(this%destr)
1981NULLIFY(this%destd)
1982NULLIFY(this%destl)
1983NULLIFY(this%destcount)
1984
1985END SUBROUTINE option_delete
1986
1987
1988FUNCTION option_found(this, optarg) RESULT(status)
1989TYPE(option),INTENT(inout) :: this
1990CHARACTER(len=*),INTENT(in),OPTIONAL :: optarg
1991INTEGER :: status
1992
1993TYPE(csv_record) :: arrparser
1994INTEGER :: ibuff
1995REAL :: rbuff
1996DOUBLE PRECISION :: dbuff
1997
1998status = optionparser_ok
1999
2000SELECT CASE(this%opttype)
2001CASE(opttype_c)
2002 CALL dirty_char_assignment(this%destc, this%destclen, trim(optarg))
2003! this%destc(1:this%destclen) = optarg
2004 IF (len_trim(optarg) > this%destclen) THEN
2005 CALL l4f_log(l4f_warn, &
2006 'in optionparser, argument '''//trim(optarg)//''' too long, truncated')
2007 ENDIF
2008CASE(opttype_i)
2009 READ(optarg,'(I12)',err=100)this%desti
2010CASE(opttype_iarr)
2013 DO WHILE(.NOT.csv_record_end(arrparser))
2015 CALL insert(this%destiarr, ibuff)
2016 ENDDO
2017 CALL packarray(this%destiarr)
2019CASE(opttype_r)
2020 READ(optarg,'(F20.0)',err=102)this%destr
2021CASE(opttype_rarr)
2024 DO WHILE(.NOT.csv_record_end(arrparser))
2026 CALL insert(this%destrarr, rbuff)
2027 ENDDO
2028 CALL packarray(this%destrarr)
2030CASE(opttype_d)
2031 READ(optarg,'(F20.0)',err=102)this%destd
2032CASE(opttype_darr)
2035 DO WHILE(.NOT.csv_record_end(arrparser))
2037 CALL insert(this%destdarr, dbuff)
2038 ENDDO
2039 CALL packarray(this%destdarr)
2041CASE(opttype_l)
2042 this%destl = .true.
2043CASE(opttype_count)
2044 this%destcount = this%destcount + 1
2045CASE(opttype_help)
2046 status = optionparser_help
2047 SELECT CASE(optarg) ! set help format
2048 CASE('md', 'markdown')
2049 this%helpformat = 1
2050 CASE('htmlform')
2051 this%helpformat = 2
2052 END SELECT
2053END SELECT
2054
2055RETURN
2056
2057100 status = optionparser_err
2058CALL l4f_log(l4f_error, &
2059 'in optionparser, argument '''//trim(optarg)//''' not valid as integer')
2060RETURN
2061102 status = optionparser_err
2062CALL l4f_log(l4f_error, &
2063 'in optionparser, argument '''//trim(optarg)//''' not valid as real')
2064RETURN
2065
2066END FUNCTION option_found
2067
2068
2069! Return a string which gives a short representation of the
2070! option \a this, without help message. The resulting string is quite
2071! long and it should be trimmed with the \a TRIM() intrinsic
2072! function.
2073FUNCTION option_format_opt(this) RESULT(format_opt)
2074TYPE(option),INTENT(in) :: this
2075
2076CHARACTER(len=100) :: format_opt
2077
2078CHARACTER(len=20) :: argname
2079
2080SELECT CASE(this%opttype)
2081CASE(opttype_c)
2082 argname = 'STRING'
2083CASE(opttype_i)
2084 argname = 'INT'
2085CASE(opttype_iarr)
2086 argname = 'INT[,INT...]'
2087CASE(opttype_r, opttype_d)
2088 argname = 'REAL'
2089CASE(opttype_rarr, opttype_darr)
2090 argname = 'REAL[,REAL...]'
2091CASE default
2092 argname = ''
2093END SELECT
2094
2095format_opt = ''
2096IF (this%short_opt /= '') THEN
2097 format_opt(len_trim(format_opt)+1:) = ' -'//this%short_opt
2098 IF (argname /= '') THEN
2099 format_opt(len_trim(format_opt)+1:) = ' '//trim(argname)
2100 ENDIF
2101ENDIF
2102IF (this%short_opt /= '' .AND. this%long_opt /= '') THEN
2103 format_opt(len_trim(format_opt)+1:) = ','
2104ENDIF
2105IF (this%long_opt /= '') THEN
2106 format_opt(len_trim(format_opt)+1:) = ' --'//this%long_opt
2107 IF (argname /= '') THEN
2108 format_opt(len_trim(format_opt)+1:) = '='//trim(argname)
2109 ENDIF
2110ENDIF
2111
2112END FUNCTION option_format_opt
2113
2114
2115! print on stdout a human-readable text representation of a single option
2116SUBROUTINE option_format_help(this, ncols)
2117TYPE(option),INTENT(in) :: this
2118INTEGER,INTENT(in) :: ncols
2119
2120INTEGER :: j
2121INTEGER, PARAMETER :: indent = 10
2122TYPE(line_split) :: help_line
2123
2124
2125IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
2126 IF (ALLOCATED(this%help_msg)) THEN
2127! help2man is quite picky about the treatment of arbitrary lines
2128! within options, the only universal way seems to be unindented lines
2129! with an empty line before and after
2130 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
2131 WRITE(*,'()')
2132 DO j = 1, line_split_get_nlines(help_line)
2133 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2134 ENDDO
2136 WRITE(*,'()')
2137 ENDIF
2138ELSE ! ordinary option
2139! print option brief representation
2140 WRITE(*,'(A)')trim(option_format_opt(this))
2141! print option help
2142 IF (ALLOCATED(this%help_msg)) THEN
2143 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
2144 DO j = 1, line_split_get_nlines(help_line)
2145 WRITE(*,'(T10,A)')trim(line_split_get_line(help_line,j))
2146 ENDDO
2148 ENDIF
2149ENDIF
2150
2151END SUBROUTINE option_format_help
2152
2153
2154! print on stdout a markdown representation of a single option
2155SUBROUTINE option_format_md(this, ncols)
2156TYPE(option),INTENT(in) :: this
2157INTEGER,INTENT(in) :: ncols
2158
2159INTEGER :: j
2160INTEGER, PARAMETER :: indent = 2
2161TYPE(line_split) :: help_line
2162
2163IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
2164 IF (ALLOCATED(this%help_msg)) THEN
2165 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
2166 WRITE(*,'()')
2167 DO j = 1, line_split_get_nlines(help_line)
2168 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2169 ENDDO
2171 WRITE(*,'()')
2172 ENDIF
2173ELSE ! ordinary option
2174! print option brief representation
2175 WRITE(*,'(''`'',A,''`'')')trim(option_format_opt(this))
2176! print option help
2177 IF (ALLOCATED(this%help_msg)) THEN
2178 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
2179 DO j = 1, line_split_get_nlines(help_line)
2180 WRITE(*,'(''> '',A)')trim(line_split_get_line(help_line,j))
2181 ENDDO
2183 WRITE(*,'()')
2184 ENDIF
2185ENDIF
2186
2187END SUBROUTINE option_format_md
2188
2189
2190! print on stdout an html form representation of a single option
2191SUBROUTINE option_format_htmlform(this)
2192TYPE(option),INTENT(in) :: this
2193
2194CHARACTER(len=80) :: opt_name, opt_id, opt_default ! check len of default
2195
2196IF (.NOT.c_e(this)) RETURN
2197IF (this%long_opt == '') THEN
2198 opt_name = this%short_opt
2199 opt_id = 'short_opt_'//this%short_opt
2200ELSE
2201 opt_name = this%long_opt
2202 opt_id = this%long_opt
2203ENDIF
2204
2205SELECT CASE(this%opttype)
2206CASE(opttype_c)
2207 CALL option_format_html_openspan('text')
2208
2209 IF (this%has_default .AND. ASSOCIATED(this%destc) .AND. this%destclen > 0) THEN
2210! opt_default = TRANSFER(this%destc(1:MIN(LEN(opt_default),this%destclen)), &
2211! opt_default) ! improve
2212 opt_default = ''
2213 WRITE(*,'(A)')' value="'//trim(opt_default)//'"'
2214 ENDIF
2215 CALL option_format_html_help()
2216 CALL option_format_html_closespan()
2217
2218CASE(opttype_i,opttype_r,opttype_d)
2219 CALL option_format_html_openspan('text')
2220 IF (this%has_default) THEN
2221 SELECT CASE(this%opttype)
2222 CASE(opttype_i)
2224! todo CASE(opttype_iarr)
2225 CASE(opttype_r)
2227 CASE(opttype_d)
2229 END SELECT
2230 ENDIF
2231 CALL option_format_html_help()
2232 CALL option_format_html_closespan()
2233
2234! todo CASE(opttype_iarr)
2235
2236CASE(opttype_l)
2237 CALL option_format_html_openspan('checkbox')
2238 CALL option_format_html_help()
2239 CALL option_format_html_closespan()
2240
2241CASE(opttype_count)
2242 CALL option_format_html_openspan('number')
2243 CALL option_format_html_help()
2244 CALL option_format_html_closespan()
2245
2246CASE(opttype_sep)
2247END SELECT
2248
2249
2250CONTAINS
2251
2252SUBROUTINE option_format_html_openspan(formtype)
2253CHARACTER(len=*),INTENT(in) :: formtype
2254
2255WRITE(*,'(A)')'<span class="libsim_optbox" id="span_'//trim(opt_id)//'">'//trim(opt_name)//':'
2256! size=? maxlen=?
2257WRITE(*,'(A)')'<input class_"libsim_opt" id="'//trim(opt_id)//'" type="'//formtype// &
2258 '" name="'//trim(opt_id)//'" '
2259
2260END SUBROUTINE option_format_html_openspan
2261
2262SUBROUTINE option_format_html_closespan()
2263
2264WRITE(*,'(A)')'/></span>'
2265
2266END SUBROUTINE option_format_html_closespan
2267
2268SUBROUTINE option_format_html_help()
2269INTEGER :: j
2270TYPE(line_split) :: help_line
2271CHARACTER(len=20) :: form
2272
2273IF (ALLOCATED(this%help_msg)) THEN
2274 WRITE(*,'(A,$)')' title="'
2275
2276 help_line = line_split_new(cstr_to_fchar(this%help_msg), 80)
2277 form = '(A,'' '')'
2278 DO j = 1, line_split_get_nlines(help_line)
2279 IF (j == line_split_get_nlines(help_line)) form = '(A,''"'',$)'
2280 WRITE(*,form)trim(line_split_get_line(help_line,j)) ! lines should be properly quoted here
2281 ENDDO
2282
2283ENDIF
2284
2285END SUBROUTINE option_format_html_help
2286
2287END SUBROUTINE option_format_htmlform
2288
2289
2290FUNCTION option_c_e(this) RESULT(c_e)
2291TYPE(option),INTENT(in) :: this
2292
2293LOGICAL :: c_e
2294
2295c_e = this%long_opt /= ' ' .OR. this%short_opt /= ' '
2296
2297END FUNCTION option_c_e
2298
2299
2303FUNCTION optionparser_new(usage_msg, description_msg) RESULT(this)
2304CHARACTER(len=*), INTENT(in), OPTIONAL :: usage_msg
2305CHARACTER(len=*), INTENT(in), OPTIONAL :: description_msg
2306
2307TYPE(optionparser) :: this
2308
2309IF (PRESENT(usage_msg)) THEN
2310 CALL fchar_to_cstr_alloc(trim(usage_msg), this%usage_msg)
2311ELSE
2312 NULLIFY(this%usage_msg)
2313ENDIF
2314IF (PRESENT(description_msg)) THEN
2315 CALL fchar_to_cstr_alloc(trim(description_msg), this%description_msg)
2316ELSE
2317 NULLIFY(this%description_msg)
2318ENDIF
2319
2320END FUNCTION optionparser_new
2321
2322
2323SUBROUTINE optionparser_delete(this)
2324TYPE(optionparser),INTENT(inout) :: this
2325
2326IF (ASSOCIATED(this%usage_msg)) DEALLOCATE(this%usage_msg)
2327IF (ASSOCIATED(this%description_msg)) DEALLOCATE(this%description_msg)
2329
2330END SUBROUTINE optionparser_delete
2331
2332
2340SUBROUTINE optionparser_add_c(this, short_opt, long_opt, dest, default, help, isopt)
2341TYPE(optionparser),INTENT(inout) :: this
2342CHARACTER(len=*),INTENT(in) :: short_opt
2343CHARACTER(len=*),INTENT(in) :: long_opt
2344CHARACTER(len=*),TARGET :: dest
2345CHARACTER(len=*),OPTIONAL :: default
2346CHARACTER(len=*),OPTIONAL :: help
2347LOGICAL,INTENT(in),OPTIONAL :: isopt
2348
2349CHARACTER(LEN=60) :: cdefault
2350INTEGER :: i
2351TYPE(option) :: myoption
2352
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%destc => dest(1:1)
2365myoption%destclen = len(dest) ! needed to avoid exceeding the length of dest
2366IF (PRESENT(default)) &
2367 CALL dirty_char_assignment(myoption%destc, myoption%destclen, default)
2368!IF (PRESENT(default)) myoption%destc(1:myoption%destclen) = default
2369myoption%opttype = opttype_c
2370IF (optio_log(isopt)) THEN
2371 myoption%need_arg = 1
2372ELSE
2373 myoption%need_arg = 2
2374ENDIF
2375
2376i = arrayof_option_append(this%options, myoption)
2377
2378END SUBROUTINE optionparser_add_c
2379
2380
2387SUBROUTINE optionparser_add_i(this, short_opt, long_opt, dest, default, help)
2388TYPE(optionparser),INTENT(inout) :: this
2389CHARACTER(len=*),INTENT(in) :: short_opt
2390CHARACTER(len=*),INTENT(in) :: long_opt
2391INTEGER,TARGET :: dest
2392INTEGER,OPTIONAL :: default
2393CHARACTER(len=*),OPTIONAL :: help
2394
2395CHARACTER(LEN=40) :: cdefault
2396INTEGER :: i
2397TYPE(option) :: myoption
2398
2399IF (PRESENT(default)) THEN
2401ELSE
2402 cdefault = ''
2403ENDIF
2404
2405! common initialisation
2406myoption = option_new(short_opt, long_opt, cdefault, help)
2407IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2408
2409myoption%desti => dest
2410IF (PRESENT(default)) myoption%desti = default
2411myoption%opttype = opttype_i
2412myoption%need_arg = 2
2413
2414i = arrayof_option_append(this%options, myoption)
2415
2416END SUBROUTINE optionparser_add_i
2417
2418
2428SUBROUTINE optionparser_add_iarray(this, short_opt, long_opt, dest, default, help)
2429TYPE(optionparser),INTENT(inout) :: this
2430CHARACTER(len=*),INTENT(in) :: short_opt
2431CHARACTER(len=*),INTENT(in) :: long_opt
2432TYPE(arrayof_integer),TARGET :: dest
2433INTEGER,OPTIONAL :: default(:)
2434CHARACTER(len=*),OPTIONAL :: help
2435
2436CHARACTER(LEN=40) :: cdefault
2437INTEGER :: i
2438TYPE(option) :: myoption
2439
2440cdefault = ''
2441IF (PRESENT(default)) THEN
2442 IF (SIZE(default) == 1) THEN
2444 ELSE IF (SIZE(default) > 1) THEN
2446 ENDIF
2447ENDIF
2448
2449! common initialisation
2450myoption = option_new(short_opt, long_opt, cdefault, help)
2451IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2452
2453myoption%destiarr => dest
2454IF (PRESENT(default)) THEN
2455 CALL insert(myoption%destiarr, default)
2456 CALL packarray(myoption%destiarr)
2457ENDIF
2458myoption%opttype = opttype_iarr
2459myoption%need_arg = 2
2460
2461i = arrayof_option_append(this%options, myoption)
2462
2463END SUBROUTINE optionparser_add_iarray
2464
2465
2472SUBROUTINE optionparser_add_r(this, short_opt, long_opt, dest, default, help)
2473TYPE(optionparser),INTENT(inout) :: this
2474CHARACTER(len=*),INTENT(in) :: short_opt
2475CHARACTER(len=*),INTENT(in) :: long_opt
2476REAL,TARGET :: dest
2477REAL,OPTIONAL :: default
2478CHARACTER(len=*),OPTIONAL :: help
2479
2480CHARACTER(LEN=40) :: cdefault
2481INTEGER :: i
2482TYPE(option) :: myoption
2483
2484IF (PRESENT(default)) THEN
2486ELSE
2487 cdefault = ''
2488ENDIF
2489
2490! common initialisation
2491myoption = option_new(short_opt, long_opt, cdefault, help)
2492IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2493
2494myoption%destr => dest
2495IF (PRESENT(default)) myoption%destr = default
2496myoption%opttype = opttype_r
2497myoption%need_arg = 2
2498
2499i = arrayof_option_append(this%options, myoption)
2500
2501END SUBROUTINE optionparser_add_r
2502
2503
2513SUBROUTINE optionparser_add_rarray(this, short_opt, long_opt, dest, default, help)
2514TYPE(optionparser),INTENT(inout) :: this
2515CHARACTER(len=*),INTENT(in) :: short_opt
2516CHARACTER(len=*),INTENT(in) :: long_opt
2517TYPE(arrayof_real),TARGET :: dest
2518REAL,OPTIONAL :: default(:)
2519CHARACTER(len=*),OPTIONAL :: help
2520
2521CHARACTER(LEN=40) :: cdefault
2522INTEGER :: i
2523TYPE(option) :: myoption
2524
2525cdefault = ''
2526IF (PRESENT(default)) THEN
2527 IF (SIZE(default) == 1) THEN
2529 ELSE IF (SIZE(default) > 1) THEN
2531 ENDIF
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%destrarr => dest
2539IF (PRESENT(default)) THEN
2540 CALL insert(myoption%destrarr, default)
2541 CALL packarray(myoption%destrarr)
2542ENDIF
2543myoption%opttype = opttype_rarr
2544myoption%need_arg = 2
2545
2546i = arrayof_option_append(this%options, myoption)
2547
2548END SUBROUTINE optionparser_add_rarray
2549
2550
2557SUBROUTINE optionparser_add_d(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
2561DOUBLE PRECISION,TARGET :: dest
2562DOUBLE PRECISION,OPTIONAL :: default
2563CHARACTER(len=*),OPTIONAL :: help
2564
2565CHARACTER(LEN=40) :: cdefault
2566INTEGER :: i
2567TYPE(option) :: myoption
2568
2569IF (PRESENT(default)) THEN
2570 IF (c_e(default)) THEN
2572 ELSE
2574 ENDIF
2575ELSE
2576 cdefault = ''
2577ENDIF
2578
2579! common initialisation
2580myoption = option_new(short_opt, long_opt, cdefault, help)
2581IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2582
2583myoption%destd => dest
2584IF (PRESENT(default)) myoption%destd = default
2585myoption%opttype = opttype_d
2586myoption%need_arg = 2
2587
2588i = arrayof_option_append(this%options, myoption)
2589
2590END SUBROUTINE optionparser_add_d
2591
2592
2602SUBROUTINE optionparser_add_darray(this, short_opt, long_opt, dest, default, help)
2603TYPE(optionparser),INTENT(inout) :: this
2604CHARACTER(len=*),INTENT(in) :: short_opt
2605CHARACTER(len=*),INTENT(in) :: long_opt
2606TYPE(arrayof_doubleprecision),TARGET :: dest
2607DOUBLE PRECISION,OPTIONAL :: default(:)
2608CHARACTER(len=*),OPTIONAL :: help
2609
2610CHARACTER(LEN=40) :: cdefault
2611INTEGER :: i
2612TYPE(option) :: myoption
2613
2614cdefault = ''
2615IF (PRESENT(default)) THEN
2616 IF (SIZE(default) == 1) THEN
2618 ELSE IF (SIZE(default) > 1) THEN
2620 ENDIF
2621ENDIF
2622
2623! common initialisation
2624myoption = option_new(short_opt, long_opt, cdefault, help)
2625IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2626
2627myoption%destdarr => dest
2628IF (PRESENT(default)) THEN
2629 CALL insert(myoption%destdarr, default)
2630 CALL packarray(myoption%destdarr)
2631ENDIF
2632myoption%opttype = opttype_darr
2633myoption%need_arg = 2
2634
2635i = arrayof_option_append(this%options, myoption)
2636
2637END SUBROUTINE optionparser_add_darray
2638
2639
2646SUBROUTINE optionparser_add_l(this, short_opt, long_opt, dest, help)
2647TYPE(optionparser),INTENT(inout) :: this
2648CHARACTER(len=*),INTENT(in) :: short_opt
2649CHARACTER(len=*),INTENT(in) :: long_opt
2650LOGICAL,TARGET :: dest
2651CHARACTER(len=*),OPTIONAL :: help
2652
2653INTEGER :: i
2654TYPE(option) :: myoption
2655
2656! common initialisation
2657myoption = option_new(short_opt, long_opt, '', help)
2658IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2659
2660myoption%destl => dest
2661myoption%destl = .false. ! unconditionally set to false, option can only set it to true
2662myoption%opttype = opttype_l
2663myoption%need_arg = 0
2664
2665i = arrayof_option_append(this%options, myoption)
2666
2667END SUBROUTINE optionparser_add_l
2668
2669
2674SUBROUTINE optionparser_add_count(this, short_opt, long_opt, dest, start, help)
2675TYPE(optionparser),INTENT(inout) :: this
2676CHARACTER(len=*),INTENT(in) :: short_opt
2677CHARACTER(len=*),INTENT(in) :: long_opt
2678INTEGER,TARGET :: dest
2679INTEGER,OPTIONAL :: start
2680CHARACTER(len=*),OPTIONAL :: help
2681
2682INTEGER :: i
2683TYPE(option) :: myoption
2684
2685! common initialisation
2686myoption = option_new(short_opt, long_opt, '', help)
2687IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2688
2689myoption%destcount => dest
2690IF (PRESENT(start)) myoption%destcount = start
2691myoption%opttype = opttype_count
2692myoption%need_arg = 0
2693
2694i = arrayof_option_append(this%options, myoption)
2695
2696END SUBROUTINE optionparser_add_count
2697
2698
2713SUBROUTINE optionparser_add_help(this, short_opt, long_opt, help)
2714TYPE(optionparser),INTENT(inout) :: this
2715CHARACTER(len=*),INTENT(in) :: short_opt
2716CHARACTER(len=*),INTENT(in) :: long_opt
2717CHARACTER(len=*),OPTIONAL :: help
2718
2719INTEGER :: i
2720TYPE(option) :: myoption
2721
2722! common initialisation
2723myoption = option_new(short_opt, long_opt, '', help)
2724IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2725
2726myoption%opttype = opttype_help
2727myoption%need_arg = 1
2728
2729i = arrayof_option_append(this%options, myoption)
2730
2731END SUBROUTINE optionparser_add_help
2732
2733
2744SUBROUTINE optionparser_add_sep(this, help)
2745TYPE(optionparser),INTENT(inout) :: this
2746!CHARACTER(len=*),INTENT(in) :: short_opt !< the short option (may be empty)
2747!CHARACTER(len=*),INTENT(in) :: long_opt !< the long option (may be empty)
2748CHARACTER(len=*) :: help
2749
2750INTEGER :: i
2751TYPE(option) :: myoption
2752
2753! common initialisation
2754myoption = option_new('_', '_', '', help)
2755IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2756
2757myoption%opttype = opttype_sep
2758myoption%need_arg = 0
2759
2760i = arrayof_option_append(this%options, myoption)
2761
2762END SUBROUTINE optionparser_add_sep
2763
2764
2774SUBROUTINE optionparser_parse(this, nextarg, status)
2775TYPE(optionparser),INTENT(inout) :: this
2776INTEGER,INTENT(out) :: nextarg
2777INTEGER,INTENT(out) :: status
2778
2779INTEGER :: i, j, endopt, indeq, iargc
2780CHARACTER(len=16384) :: arg, optarg
2781
2782status = optionparser_ok
2783i = 1
2784DO WHILE(i <= iargc())
2785 CALL getarg(i, arg)
2786 IF (arg == '--') THEN ! explicit end of options
2787 i = i + 1 ! skip present option (--)
2788 EXIT
2789 ELSE IF (arg == '-') THEN ! a single - is not an option
2790 EXIT
2791 ELSE IF (arg(1:2) == '--') THEN ! long option
2793 IF (indeq /= 0) THEN ! = present
2794 endopt = indeq - 1
2795 ELSE ! no =
2796 endopt = len_trim(arg)
2797 ENDIF
2798 find_longopt: DO j = 1, this%options%arraysize
2799 IF (this%options%array(j)%long_opt == arg(3:endopt)) THEN ! found option
2800 SELECT CASE(this%options%array(j)%need_arg)
2801 CASE(2) ! compulsory
2802 IF (indeq /= 0) THEN
2803 optarg = arg(indeq+1:)
2804 status = max(option_found(this%options%array(j), optarg), &
2805 status)
2806 ELSE
2807 IF (i < iargc()) THEN
2808 i=i+1
2809 CALL getarg(i, optarg)
2810 status = max(option_found(this%options%array(j), optarg), &
2811 status)
2812 ELSE
2813 status = optionparser_err
2814 CALL l4f_log(l4f_error, &
2815 'in optionparser, option '''//trim(arg)//''' requires an argument')
2816 ENDIF
2817 ENDIF
2818 CASE(1) ! optional
2819 IF (indeq /= 0) THEN
2820 optarg = arg(indeq+1:)
2821 ELSE
2822 IF (i < iargc()) THEN
2823 CALL getarg(i+1, optarg)
2824 IF (optarg(1:1) == '-') THEN
2825 optarg = cmiss ! refused
2826 ELSE
2827 i=i+1 ! accepted
2828 ENDIF
2829 ELSE
2830 optarg = cmiss ! refused
2831 ENDIF
2832 ENDIF
2833 status = max(option_found(this%options%array(j), optarg), &
2834 status)
2835 CASE(0)
2836 status = max(option_found(this%options%array(j)), &
2837 status)
2838 END SELECT
2839 EXIT find_longopt
2840 ENDIF
2841 ENDDO find_longopt
2842 IF (j > this%options%arraysize) THEN
2843 status = optionparser_err
2844 CALL l4f_log(l4f_error, &
2845 'in optionparser, option '''//trim(arg)//''' not valid')
2846 ENDIF
2847 ELSE IF (arg(1:1) == '-') THEN ! short option
2848 find_shortopt: DO j = 1, this%options%arraysize
2849 IF (this%options%array(j)%short_opt == arg(2:2)) THEN ! found option
2850 SELECT CASE(this%options%array(j)%need_arg)
2851 CASE(2) ! compulsory
2852 IF (len_trim(arg) > 2) THEN
2853 optarg = arg(3:)
2854 status = max(option_found(this%options%array(j), optarg), &
2855 status)
2856 ELSE
2857 IF (i < iargc()) THEN
2858 i=i+1
2859 CALL getarg(i, optarg)
2860 status = max(option_found(this%options%array(j), optarg), &
2861 status)
2862 ELSE
2863 status = optionparser_err
2864 CALL l4f_log(l4f_error, &
2865 'in optionparser, option '''//trim(arg)//''' requires an argument')
2866 ENDIF
2867 ENDIF
2868 CASE(1) ! optional
2869 IF (len_trim(arg) > 2) THEN
2870 optarg = arg(3:)
2871 ELSE
2872 IF (i < iargc()) THEN
2873 CALL getarg(i+1, optarg)
2874 IF (optarg(1:1) == '-') THEN
2875 optarg = cmiss ! refused
2876 ELSE
2877 i=i+1 ! accepted
2878 ENDIF
2879 ELSE
2880 optarg = cmiss ! refused
2881 ENDIF
2882 ENDIF
2883 status = max(option_found(this%options%array(j), optarg), &
2884 status)
2885 CASE(0)
2886 status = max(option_found(this%options%array(j)), &
2887 status)
2888 END SELECT
2889 EXIT find_shortopt
2890 ENDIF
2891 ENDDO find_shortopt
2892 IF (j > this%options%arraysize) THEN
2893 status = optionparser_err
2894 CALL l4f_log(l4f_error, &
2895 'in optionparser, option '''//trim(arg)//''' not valid')
2896 ENDIF
2897 ELSE ! unrecognized = end of options
2898 EXIT
2899 ENDIF
2900 i = i + 1
2901ENDDO
2902
2903nextarg = i
2904SELECT CASE(status)
2905CASE(optionparser_err, optionparser_help)
2906 CALL optionparser_printhelp(this)
2907END SELECT
2908
2909END SUBROUTINE optionparser_parse
2910
2911
2915SUBROUTINE optionparser_printhelp(this)
2916TYPE(optionparser),INTENT(in) :: this
2917
2918INTEGER :: i, form
2919
2920form = 0
2921DO i = 1, this%options%arraysize ! loop over options
2922 IF (this%options%array(i)%opttype == opttype_help) THEN
2923 form = this%options%array(i)%helpformat
2924 ENDIF
2925ENDDO
2926
2927SELECT CASE(form)
2928CASE(0)
2929 CALL optionparser_printhelptxt(this)
2930CASE(1)
2931 CALL optionparser_printhelpmd(this)
2932CASE(2)
2933 CALL optionparser_printhelphtmlform(this)
2934END SELECT
2935
2936END SUBROUTINE optionparser_printhelp
2937
2938
2942SUBROUTINE optionparser_printhelptxt(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
2952IF (ASSOCIATED(this%usage_msg)) THEN
2953 help_line = line_split_new(cstr_to_fchar(this%usage_msg), ncols)
2954 DO j = 1, line_split_get_nlines(help_line)
2955 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2956 ENDDO
2958ELSE
2959 CALL getarg(0, buf)
2961 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2962 WRITE(*,'(A)')'Usage: '//trim(buf(i+1:))//' [options] [arguments]'
2963ENDIF
2964
2965! print description message
2966IF (ASSOCIATED(this%description_msg)) THEN
2967 WRITE(*,'()')
2968 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2969 DO j = 1, line_split_get_nlines(help_line)
2970 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2971 ENDDO
2973ENDIF
2974
2975WRITE(*,'(/,A)')'Options:'
2976
2977DO i = 1, this%options%arraysize ! loop over options
2978 CALL option_format_help(this%options%array(i), ncols)
2979ENDDO
2980
2981END SUBROUTINE optionparser_printhelptxt
2982
2983
2987SUBROUTINE optionparser_printhelpmd(this)
2988TYPE(optionparser),INTENT(in) :: this
2989
2990INTEGER :: i, j, ncols
2991CHARACTER(len=80) :: buf
2992TYPE(line_split) :: help_line
2993
2994ncols = default_columns()
2995
2996! print usage message
2997WRITE(*,'(A)')'### Synopsis'
2998
2999IF (ASSOCIATED(this%usage_msg)) THEN
3000 help_line = line_split_new(mdquote_usage_msg(cstr_to_fchar(this%usage_msg)), ncols)
3001 DO j = 1, line_split_get_nlines(help_line)
3002 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
3003 ENDDO
3005ELSE
3006 CALL getarg(0, buf)
3008 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
3009 WRITE(*,'(A)')'Usage: `'//trim(buf(i+1:))//' [options] [arguments]`'
3010ENDIF
3011
3012! print description message
3013IF (ASSOCIATED(this%description_msg)) THEN
3014 WRITE(*,'()')
3015 WRITE(*,'(A)')'### Description'
3016 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
3017 DO j = 1, line_split_get_nlines(help_line)
3018 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
3019 ENDDO
3021
3022ENDIF
3023
3024WRITE(*,'(/,A)')'### Options'
3025
3026DO i = 1, this%options%arraysize ! loop over options
3027 CALL option_format_md(this%options%array(i), ncols)
3028ENDDO
3029
3030CONTAINS
3031
3032FUNCTION mdquote_usage_msg(usage_msg)
3033CHARACTER(len=*),INTENT(in) :: usage_msg
3034
3035CHARACTER(len=LEN(usage_msg)+2) :: mdquote_usage_msg
3036INTEGER :: colon
3037
3039IF (colon > 0 .AND. colon < len(usage_msg)-1) THEN
3040 mdquote_usage_msg = usage_msg(:colon+1)//'`'//usage_msg(colon+2:)//'`'
3041ELSE
3042 mdquote_usage_msg = usage_msg
3043ENDIF
3044
3045END FUNCTION mdquote_usage_msg
3046
3047END SUBROUTINE optionparser_printhelpmd
3048
3052SUBROUTINE optionparser_printhelphtmlform(this)
3053TYPE(optionparser),INTENT(in) :: this
3054
3055INTEGER :: i
3056
3057DO i = 1, this%options%arraysize ! loop over options
3058 CALL option_format_htmlform(this%options%array(i))
3059ENDDO
3060
3061WRITE(*,'(A)')'<input class="libsim_sub" type="submit" value="runprogram" />'
3062
3063END SUBROUTINE optionparser_printhelphtmlform
3064
3065
3066SUBROUTINE optionparser_make_completion(this)
3067TYPE(optionparser),INTENT(in) :: this
3068
3069INTEGER :: i
3070CHARACTER(len=512) :: buf
3071
3072CALL getarg(0, buf)
3073
3074WRITE(*,'(A/A/A)')'_'//trim(buf)//'()','{','local cur'
3075
3076WRITE(*,'(A/A/A/A)')'COMPREPLY=()','cur=${COMP_WORDS[COMP_CWORD]}', &
3077 'case "$cur" in','-*)'
3078
3079!-*)
3080! COMPREPLY=( $( compgen -W
3081DO i = 1, this%options%arraysize ! loop over options
3082 IF (this%options%array(i)%need_arg == 2) THEN
3083 ENDIF
3084ENDDO
3085
3086WRITE(*,'(A/A/A)')'esac','return 0','}'
3087
3088END SUBROUTINE optionparser_make_completion
3089
3090
3091SUBROUTINE dirty_char_assignment(destc, destclen, src)
3093IMPLICIT NONE
3094
3095CHARACTER(len=1) :: destc(*)
3096CHARACTER(len=*) :: src
3097INTEGER :: destclen
3098
3099INTEGER :: i
3100
3101DO i = 1, min(destclen, len(src))
3102 destc(i) = src(i:i)
3103ENDDO
3104DO i = len(src)+1, destclen
3105 destc(i) = ' '
3106ENDDO
3107
3108END SUBROUTINE dirty_char_assignment
3109
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 |