libsim Versione 7.2.1

◆ optionparser_make_completion()

subroutine optionparser_make_completion ( type(optionparser), intent(in)  this)
private
Parametri
[in]thisoptionparser object with correctly initialised options

Definizione alla linea 1818 del file optionparser_class.F90.

1819! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1820! authors:
1821! Davide Cesari <dcesari@arpa.emr.it>
1822! Paolo Patruno <ppatruno@arpa.emr.it>
1823
1824! This program is free software; you can redistribute it and/or
1825! modify it under the terms of the GNU General Public License as
1826! published by the Free Software Foundation; either version 2 of
1827! the License, or (at your option) any later version.
1828
1829! This program is distributed in the hope that it will be useful,
1830! but WITHOUT ANY WARRANTY; without even the implied warranty of
1831! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1832! GNU General Public License for more details.
1842#include "config.h"
1843
1844MODULE optionparser_class
1845USE log4fortran
1846USE err_handling
1847USE kinds
1851IMPLICIT NONE
1852
1853
1854! private class
1855TYPE option
1856 CHARACTER(len=1) :: short_opt=''
1857 CHARACTER(len=80) :: long_opt=''
1858 INTEGER :: opttype=-1
1859 INTEGER :: need_arg=0 ! 0=no, 1=optional, 2=yes, was .FALSE.
1860 LOGICAL :: has_default=.false.
1861 CHARACTER(len=1),POINTER :: destc=>null()
1862 INTEGER :: destclen=0
1863 INTEGER :: helpformat=0 ! 0=txt, 1=markdown, 2=htmlform, improve!
1864 INTEGER,POINTER :: desti=>null()
1865 TYPE(arrayof_integer),POINTER :: destiarr=>null()
1866 REAL,POINTER :: destr=>null()
1867 TYPE(arrayof_real),POINTER :: destrarr=>null()
1868 DOUBLE PRECISION, POINTER :: destd=>null()
1869 TYPE(arrayof_doubleprecision),POINTER :: destdarr=>null()
1870 LOGICAL,POINTER :: destl=>null()
1871 TYPE(arrayof_logical),POINTER :: destlarr=>null()
1872 INTEGER,POINTER :: destcount=>null()
1873 INTEGER(kind=int_b),ALLOCATABLE :: help_msg(:)
1874END TYPE option
1875
1876#define ARRAYOF_ORIGTYPE TYPE(option)
1877#define ARRAYOF_TYPE arrayof_option
1878#define ARRAYOF_ORIGDESTRUCTOR(x) CALL option_delete(x)
1879#define ARRAYOF_PRIVATE 1
1880#include "arrayof_pre_nodoc.F90"
1881! from arrayof
1882!PUBLIC insert, append, remove, packarray
1883!PUBLIC insert_unique, append_unique
1884
1962TYPE optionparser
1963 PRIVATE
1964 INTEGER(kind=int_b),POINTER :: usage_msg(:), description_msg(:)
1965 TYPE(arrayof_option) :: options
1966 LOGICAL :: httpmode=.false.
1967END TYPE optionparser
1968
1969
1973INTERFACE optionparser_add
1974 MODULE PROCEDURE optionparser_add_c, optionparser_add_i, optionparser_add_r, &
1975 optionparser_add_d, optionparser_add_l, &
1976 optionparser_add_iarray, optionparser_add_rarray, optionparser_add_darray
1977END INTERFACE
1978
1979INTERFACE c_e
1980 MODULE PROCEDURE option_c_e
1981END INTERFACE
1982
1990INTERFACE delete
1991 MODULE PROCEDURE optionparser_delete!?, option_delete
1992END INTERFACE
1993
1994
1995INTEGER,PARAMETER :: opttype_c = 1, opttype_i = 2, opttype_r = 3, &
1996 opttype_d = 4, opttype_l = 5, opttype_count = 6, opttype_help = 7, &
1997 opttype_sep = 8, opttype_carr = 11, opttype_iarr = 12, opttype_rarr = 13, &
1998 opttype_darr = 14, opttype_larr = 15
1999
2000INTEGER,PARAMETER :: optionparser_ok = 0
2001INTEGER,PARAMETER :: optionparser_help = 1
2002INTEGER,PARAMETER :: optionparser_err = 2
2003
2004
2005PRIVATE
2006PUBLIC optionparser, optionparser_new, delete, optionparser_add, &
2007 optionparser_add_count, optionparser_add_help, optionparser_add_sep, &
2008 optionparser_parse, optionparser_printhelp, &
2009 optionparser_ok, optionparser_help, optionparser_err
2010
2011
2012CONTAINS
2013
2014#include "arrayof_post_nodoc.F90"
2015
2016! Constructor for the option class
2017FUNCTION option_new(short_opt, long_opt, default, help) RESULT(this)
2018CHARACTER(len=*),INTENT(in) :: short_opt
2019CHARACTER(len=*),INTENT(in) :: long_opt
2020CHARACTER(len=*),INTENT(in) :: default
2021CHARACTER(len=*),OPTIONAL :: help
2022TYPE(option) :: this
2023
2024IF (short_opt == '' .AND. long_opt == '') THEN
2025#ifdef DEBUG
2026! programmer error condition, option empty
2027 CALL l4f_log(l4f_error, 'in optionparser, both short and long options empty')
2028 CALL raise_fatal_error()
2029#else
2030 CALL l4f_log(l4f_warn, 'in optionparser, both short and long options empty')
2031#endif
2032 RETURN
2033ENDIF
2034
2035this%short_opt = short_opt
2036this%long_opt = long_opt
2037IF (PRESENT(help)) THEN
2038 this%help_msg = fchar_to_cstr(trim(help)//trim(default)) ! f2003 automatic alloc
2039ENDIF
2040this%has_default = (len_trim(default) > 0)
2041
2042END FUNCTION option_new
2043
2044
2045! Destructor for the \a option class, the memory associated with
2046! the object is freed.
2047SUBROUTINE option_delete(this)
2048TYPE(option),INTENT(inout) :: this ! object to destroy
2049
2050IF (ALLOCATED(this%help_msg)) DEALLOCATE(this%help_msg)
2051NULLIFY(this%destc)
2052NULLIFY(this%desti)
2053NULLIFY(this%destr)
2054NULLIFY(this%destd)
2055NULLIFY(this%destl)
2056NULLIFY(this%destcount)
2057
2058END SUBROUTINE option_delete
2059
2060
2061FUNCTION option_found(this, optarg) RESULT(status)
2062TYPE(option),INTENT(inout) :: this
2063CHARACTER(len=*),INTENT(in),OPTIONAL :: optarg
2064INTEGER :: status
2065
2066TYPE(csv_record) :: arrparser
2067INTEGER :: ibuff
2068REAL :: rbuff
2069DOUBLE PRECISION :: dbuff
2070
2071status = optionparser_ok
2072
2073SELECT CASE(this%opttype)
2074CASE(opttype_c)
2075 CALL dirty_char_assignment(this%destc, this%destclen, trim(optarg))
2076! this%destc(1:this%destclen) = optarg
2077 IF (len_trim(optarg) > this%destclen) THEN
2078 CALL l4f_log(l4f_warn, &
2079 'in optionparser, argument '''//trim(optarg)//''' too long, truncated')
2080 ENDIF
2081CASE(opttype_i)
2082 READ(optarg,'(I12)',err=100)this%desti
2083CASE(opttype_iarr)
2084 CALL delete(this%destiarr) ! delete default values
2085 CALL init(arrparser, optarg)
2086 DO WHILE(.NOT.csv_record_end(arrparser))
2087 CALL csv_record_getfield(arrparser, ibuff)
2088 CALL insert(this%destiarr, ibuff)
2089 ENDDO
2090 CALL packarray(this%destiarr)
2091 CALL delete(arrparser)
2092CASE(opttype_r)
2093 READ(optarg,'(F20.0)',err=102)this%destr
2094CASE(opttype_rarr)
2095 CALL delete(this%destrarr) ! delete default values
2096 CALL init(arrparser, optarg)
2097 DO WHILE(.NOT.csv_record_end(arrparser))
2098 CALL csv_record_getfield(arrparser, rbuff)
2099 CALL insert(this%destrarr, rbuff)
2100 ENDDO
2101 CALL packarray(this%destrarr)
2102 CALL delete(arrparser)
2103CASE(opttype_d)
2104 READ(optarg,'(F20.0)',err=102)this%destd
2105CASE(opttype_darr)
2106 CALL delete(this%destdarr) ! delete default values
2107 CALL init(arrparser, optarg)
2108 DO WHILE(.NOT.csv_record_end(arrparser))
2109 CALL csv_record_getfield(arrparser, dbuff)
2110 CALL insert(this%destdarr, dbuff)
2111 ENDDO
2112 CALL packarray(this%destdarr)
2113 CALL delete(arrparser)
2114CASE(opttype_l)
2115 this%destl = .true.
2116CASE(opttype_count)
2117 this%destcount = this%destcount + 1
2118CASE(opttype_help)
2119 status = optionparser_help
2120 SELECT CASE(optarg) ! set help format
2121 CASE('md', 'markdown')
2122 this%helpformat = 1
2123 CASE('htmlform')
2124 this%helpformat = 2
2125 END SELECT
2126END SELECT
2127
2128RETURN
2129
2130100 status = optionparser_err
2131CALL l4f_log(l4f_error, &
2132 'in optionparser, argument '''//trim(optarg)//''' not valid as integer')
2133RETURN
2134102 status = optionparser_err
2135CALL l4f_log(l4f_error, &
2136 'in optionparser, argument '''//trim(optarg)//''' not valid as real')
2137RETURN
2138
2139END FUNCTION option_found
2140
2141
2142! Return a string which gives a short representation of the
2143! option \a this, without help message. The resulting string is quite
2144! long and it should be trimmed with the \a TRIM() intrinsic
2145! function.
2146FUNCTION option_format_opt(this) RESULT(format_opt)
2147TYPE(option),INTENT(in) :: this
2148
2149CHARACTER(len=100) :: format_opt
2150
2151CHARACTER(len=20) :: argname
2152
2153SELECT CASE(this%opttype)
2154CASE(opttype_c)
2155 argname = 'STRING'
2156CASE(opttype_i)
2157 argname = 'INT'
2158CASE(opttype_iarr)
2159 argname = 'INT[,INT...]'
2160CASE(opttype_r, opttype_d)
2161 argname = 'REAL'
2162CASE(opttype_rarr, opttype_darr)
2163 argname = 'REAL[,REAL...]'
2164CASE default
2165 argname = ''
2166END SELECT
2167
2168format_opt = ''
2169IF (this%short_opt /= '') THEN
2170 format_opt(len_trim(format_opt)+1:) = ' -'//this%short_opt
2171 IF (argname /= '') THEN
2172 format_opt(len_trim(format_opt)+1:) = ' '//trim(argname)
2173 ENDIF
2174ENDIF
2175IF (this%short_opt /= '' .AND. this%long_opt /= '') THEN
2176 format_opt(len_trim(format_opt)+1:) = ','
2177ENDIF
2178IF (this%long_opt /= '') THEN
2179 format_opt(len_trim(format_opt)+1:) = ' --'//this%long_opt
2180 IF (argname /= '') THEN
2181 format_opt(len_trim(format_opt)+1:) = '='//trim(argname)
2182 ENDIF
2183ENDIF
2184
2185END FUNCTION option_format_opt
2186
2187
2188! print on stdout a human-readable text representation of a single option
2189SUBROUTINE option_format_help(this, ncols)
2190TYPE(option),INTENT(in) :: this
2191INTEGER,INTENT(in) :: ncols
2192
2193INTEGER :: j
2194INTEGER, PARAMETER :: indent = 10
2195TYPE(line_split) :: help_line
2196
2197
2198IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
2199 IF (ALLOCATED(this%help_msg)) THEN
2200! help2man is quite picky about the treatment of arbitrary lines
2201! within options, the only universal way seems to be unindented lines
2202! with an empty line before and after
2203 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
2204 WRITE(*,'()')
2205 DO j = 1, line_split_get_nlines(help_line)
2206 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2207 ENDDO
2208 CALL delete(help_line)
2209 WRITE(*,'()')
2210 ENDIF
2211ELSE ! ordinary option
2212! print option brief representation
2213 WRITE(*,'(A)')trim(option_format_opt(this))
2214! print option help
2215 IF (ALLOCATED(this%help_msg)) THEN
2216 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
2217 DO j = 1, line_split_get_nlines(help_line)
2218 WRITE(*,'(T10,A)')trim(line_split_get_line(help_line,j))
2219 ENDDO
2220 CALL delete(help_line)
2221 ENDIF
2222ENDIF
2223
2224END SUBROUTINE option_format_help
2225
2226
2227! print on stdout a markdown representation of a single option
2228SUBROUTINE option_format_md(this, ncols)
2229TYPE(option),INTENT(in) :: this
2230INTEGER,INTENT(in) :: ncols
2231
2232INTEGER :: j
2233INTEGER, PARAMETER :: indent = 2
2234TYPE(line_split) :: help_line
2235
2236IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
2237 IF (ALLOCATED(this%help_msg)) THEN
2238 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
2239 WRITE(*,'()')
2240 DO j = 1, line_split_get_nlines(help_line)
2241 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2242 ENDDO
2243 CALL delete(help_line)
2244 WRITE(*,'()')
2245 ENDIF
2246ELSE ! ordinary option
2247! print option brief representation
2248 WRITE(*,'(''`'',A,''`'')')trim(option_format_opt(this))
2249! print option help
2250 IF (ALLOCATED(this%help_msg)) THEN
2251 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
2252 DO j = 1, line_split_get_nlines(help_line)
2253 WRITE(*,'(''> '',A)')trim(line_split_get_line(help_line,j))
2254 ENDDO
2255 CALL delete(help_line)
2256 WRITE(*,'()')
2257 ENDIF
2258ENDIF
2259
2260END SUBROUTINE option_format_md
2261
2262
2263! print on stdout an html form representation of a single option
2264SUBROUTINE option_format_htmlform(this)
2265TYPE(option),INTENT(in) :: this
2266
2267CHARACTER(len=80) :: opt_name, opt_id, opt_default ! check len of default
2268
2269IF (.NOT.c_e(this)) RETURN
2270IF (this%long_opt == '') THEN
2271 opt_name = this%short_opt
2272 opt_id = 'short_opt_'//this%short_opt
2273ELSE
2274 opt_name = this%long_opt
2275 opt_id = this%long_opt
2276ENDIF
2277
2278SELECT CASE(this%opttype)
2279CASE(opttype_c)
2280 CALL option_format_html_openspan('text')
2281
2282 IF (this%has_default .AND. ASSOCIATED(this%destc) .AND. this%destclen > 0) THEN
2283! opt_default = TRANSFER(this%destc(1:MIN(LEN(opt_default),this%destclen)), &
2284! opt_default) ! improve
2285 opt_default = ''
2286 WRITE(*,'(A)')' value="'//trim(opt_default)//'"'
2287 ENDIF
2288 CALL option_format_html_help()
2289 CALL option_format_html_closespan()
2290
2291CASE(opttype_i,opttype_r,opttype_d)
2292 CALL option_format_html_openspan('text')
2293 IF (this%has_default) THEN
2294 SELECT CASE(this%opttype)
2295 CASE(opttype_i)
2296 WRITE(*,'(3A)')' value="',t2c(this%desti),'"'
2297! todo CASE(opttype_iarr)
2298 CASE(opttype_r)
2299 WRITE(*,'(3A)')' value="',t2c(this%destr),'"'
2300 CASE(opttype_d)
2301 WRITE(*,'(3A)')' value="',t2c(this%destd),'"'
2302 END SELECT
2303 ENDIF
2304 CALL option_format_html_help()
2305 CALL option_format_html_closespan()
2306
2307! todo CASE(opttype_iarr)
2308
2309CASE(opttype_l)
2310 CALL option_format_html_openspan('checkbox')
2311 CALL option_format_html_help()
2312 CALL option_format_html_closespan()
2313
2314CASE(opttype_count)
2315 CALL option_format_html_openspan('number')
2316 CALL option_format_html_help()
2317 CALL option_format_html_closespan()
2318
2319CASE(opttype_sep)
2320END SELECT
2321
2322
2323CONTAINS
2324
2325SUBROUTINE option_format_html_openspan(formtype)
2326CHARACTER(len=*),INTENT(in) :: formtype
2327
2328WRITE(*,'(A)')'<span class="libsim_optbox" id="span_'//trim(opt_id)//'">'//trim(opt_name)//':'
2329! size=? maxlen=?
2330WRITE(*,'(A)')'<input class_"libsim_opt" id="'//trim(opt_id)//'" type="'//formtype// &
2331 '" name="'//trim(opt_id)//'" '
2332
2333END SUBROUTINE option_format_html_openspan
2334
2335SUBROUTINE option_format_html_closespan()
2336
2337WRITE(*,'(A)')'/></span>'
2338
2339END SUBROUTINE option_format_html_closespan
2340
2341SUBROUTINE option_format_html_help()
2342INTEGER :: j
2343TYPE(line_split) :: help_line
2344CHARACTER(len=20) :: form
2345
2346IF (ALLOCATED(this%help_msg)) THEN
2347 WRITE(*,'(A,$)')' title="'
2348
2349 help_line = line_split_new(cstr_to_fchar(this%help_msg), 80)
2350 form = '(A,'' '')'
2351 DO j = 1, line_split_get_nlines(help_line)
2352 IF (j == line_split_get_nlines(help_line)) form = '(A,''"'',$)'
2353 WRITE(*,form)trim(line_split_get_line(help_line,j)) ! lines should be properly quoted here
2354 ENDDO
2355
2356ENDIF
2357
2358END SUBROUTINE option_format_html_help
2359
2360END SUBROUTINE option_format_htmlform
2361
2362
2363FUNCTION option_c_e(this) RESULT(c_e)
2364TYPE(option),INTENT(in) :: this
2365
2366LOGICAL :: c_e
2367
2368c_e = this%long_opt /= ' ' .OR. this%short_opt /= ' '
2369
2370END FUNCTION option_c_e
2371
2372
2376FUNCTION optionparser_new(usage_msg, description_msg) RESULT(this)
2377CHARACTER(len=*), INTENT(in), OPTIONAL :: usage_msg
2378CHARACTER(len=*), INTENT(in), OPTIONAL :: description_msg
2379
2380TYPE(optionparser) :: this
2381
2382IF (PRESENT(usage_msg)) THEN
2383 CALL fchar_to_cstr_alloc(trim(usage_msg), this%usage_msg)
2384ELSE
2385 NULLIFY(this%usage_msg)
2386ENDIF
2387IF (PRESENT(description_msg)) THEN
2388 CALL fchar_to_cstr_alloc(trim(description_msg), this%description_msg)
2389ELSE
2390 NULLIFY(this%description_msg)
2391ENDIF
2392
2393END FUNCTION optionparser_new
2394
2395
2396SUBROUTINE optionparser_delete(this)
2397TYPE(optionparser),INTENT(inout) :: this
2398
2399IF (ASSOCIATED(this%usage_msg)) DEALLOCATE(this%usage_msg)
2400IF (ASSOCIATED(this%description_msg)) DEALLOCATE(this%description_msg)
2401CALL delete(this%options)
2402
2403END SUBROUTINE optionparser_delete
2404
2405
2413SUBROUTINE optionparser_add_c(this, short_opt, long_opt, dest, default, help, isopt)
2414TYPE(optionparser),INTENT(inout) :: this
2415CHARACTER(len=*),INTENT(in) :: short_opt
2416CHARACTER(len=*),INTENT(in) :: long_opt
2417CHARACTER(len=*),TARGET :: dest
2418CHARACTER(len=*),OPTIONAL :: default
2419CHARACTER(len=*),OPTIONAL :: help
2420LOGICAL,INTENT(in),OPTIONAL :: isopt
2421
2422CHARACTER(LEN=60) :: cdefault
2423INTEGER :: i
2424TYPE(option) :: myoption
2425
2426
2427IF (PRESENT(default)) THEN
2428 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2429ELSE
2430 cdefault = ''
2431ENDIF
2432
2433! common initialisation
2434myoption = option_new(short_opt, long_opt, cdefault, help)
2435IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2436
2437myoption%destc => dest(1:1)
2438myoption%destclen = len(dest) ! needed to avoid exceeding the length of dest
2439IF (PRESENT(default)) &
2440 CALL dirty_char_assignment(myoption%destc, myoption%destclen, default)
2441!IF (PRESENT(default)) myoption%destc(1:myoption%destclen) = default
2442myoption%opttype = opttype_c
2443IF (optio_log(isopt)) THEN
2444 myoption%need_arg = 1
2445ELSE
2446 myoption%need_arg = 2
2447ENDIF
2448
2449i = arrayof_option_append(this%options, myoption)
2450
2451END SUBROUTINE optionparser_add_c
2452
2453
2460SUBROUTINE optionparser_add_i(this, short_opt, long_opt, dest, default, help)
2461TYPE(optionparser),INTENT(inout) :: this
2462CHARACTER(len=*),INTENT(in) :: short_opt
2463CHARACTER(len=*),INTENT(in) :: long_opt
2464INTEGER,TARGET :: dest
2465INTEGER,OPTIONAL :: default
2466CHARACTER(len=*),OPTIONAL :: help
2467
2468CHARACTER(LEN=40) :: cdefault
2469INTEGER :: i
2470TYPE(option) :: myoption
2471
2472IF (PRESENT(default)) THEN
2473 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2474ELSE
2475 cdefault = ''
2476ENDIF
2477
2478! common initialisation
2479myoption = option_new(short_opt, long_opt, cdefault, help)
2480IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2481
2482myoption%desti => dest
2483IF (PRESENT(default)) myoption%desti = default
2484myoption%opttype = opttype_i
2485myoption%need_arg = 2
2486
2487i = arrayof_option_append(this%options, myoption)
2488
2489END SUBROUTINE optionparser_add_i
2490
2491
2501SUBROUTINE optionparser_add_iarray(this, short_opt, long_opt, dest, default, help)
2502TYPE(optionparser),INTENT(inout) :: this
2503CHARACTER(len=*),INTENT(in) :: short_opt
2504CHARACTER(len=*),INTENT(in) :: long_opt
2505TYPE(arrayof_integer),TARGET :: dest
2506INTEGER,OPTIONAL :: default(:)
2507CHARACTER(len=*),OPTIONAL :: help
2508
2509CHARACTER(LEN=40) :: cdefault
2510INTEGER :: i
2511TYPE(option) :: myoption
2512
2513cdefault = ''
2514IF (PRESENT(default)) THEN
2515 IF (SIZE(default) == 1) THEN
2516 cdefault = ' [default='//trim(to_char(default(1)))//']'
2517 ELSE IF (SIZE(default) > 1) THEN
2518 cdefault = ' [default='//trim(to_char(default(1)))//',...]'
2519 ENDIF
2520ENDIF
2521
2522! common initialisation
2523myoption = option_new(short_opt, long_opt, cdefault, help)
2524IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2525
2526myoption%destiarr => dest
2527IF (PRESENT(default)) THEN
2528 CALL insert(myoption%destiarr, default)
2529 CALL packarray(myoption%destiarr)
2530ENDIF
2531myoption%opttype = opttype_iarr
2532myoption%need_arg = 2
2533
2534i = arrayof_option_append(this%options, myoption)
2535
2536END SUBROUTINE optionparser_add_iarray
2537
2538
2545SUBROUTINE optionparser_add_r(this, short_opt, long_opt, dest, default, help)
2546TYPE(optionparser),INTENT(inout) :: this
2547CHARACTER(len=*),INTENT(in) :: short_opt
2548CHARACTER(len=*),INTENT(in) :: long_opt
2549REAL,TARGET :: dest
2550REAL,OPTIONAL :: default
2551CHARACTER(len=*),OPTIONAL :: help
2552
2553CHARACTER(LEN=40) :: cdefault
2554INTEGER :: i
2555TYPE(option) :: myoption
2556
2557IF (PRESENT(default)) THEN
2558 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2559ELSE
2560 cdefault = ''
2561ENDIF
2562
2563! common initialisation
2564myoption = option_new(short_opt, long_opt, cdefault, help)
2565IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2566
2567myoption%destr => dest
2568IF (PRESENT(default)) myoption%destr = default
2569myoption%opttype = opttype_r
2570myoption%need_arg = 2
2571
2572i = arrayof_option_append(this%options, myoption)
2573
2574END SUBROUTINE optionparser_add_r
2575
2576
2586SUBROUTINE optionparser_add_rarray(this, short_opt, long_opt, dest, default, help)
2587TYPE(optionparser),INTENT(inout) :: this
2588CHARACTER(len=*),INTENT(in) :: short_opt
2589CHARACTER(len=*),INTENT(in) :: long_opt
2590TYPE(arrayof_real),TARGET :: dest
2591REAL,OPTIONAL :: default(:)
2592CHARACTER(len=*),OPTIONAL :: help
2593
2594CHARACTER(LEN=40) :: cdefault
2595INTEGER :: i
2596TYPE(option) :: myoption
2597
2598cdefault = ''
2599IF (PRESENT(default)) THEN
2600 IF (SIZE(default) == 1) THEN
2601 cdefault = ' [default='//trim(to_char(default(1)))//']'
2602 ELSE IF (SIZE(default) > 1) THEN
2603 cdefault = ' [default='//trim(to_char(default(1)))//',...]'
2604 ENDIF
2605ENDIF
2606
2607! common initialisation
2608myoption = option_new(short_opt, long_opt, cdefault, help)
2609IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2610
2611myoption%destrarr => dest
2612IF (PRESENT(default)) THEN
2613 CALL insert(myoption%destrarr, default)
2614 CALL packarray(myoption%destrarr)
2615ENDIF
2616myoption%opttype = opttype_rarr
2617myoption%need_arg = 2
2618
2619i = arrayof_option_append(this%options, myoption)
2620
2621END SUBROUTINE optionparser_add_rarray
2622
2623
2630SUBROUTINE optionparser_add_d(this, short_opt, long_opt, dest, default, help)
2631TYPE(optionparser),INTENT(inout) :: this
2632CHARACTER(len=*),INTENT(in) :: short_opt
2633CHARACTER(len=*),INTENT(in) :: long_opt
2634DOUBLE PRECISION,TARGET :: dest
2635DOUBLE PRECISION,OPTIONAL :: default
2636CHARACTER(len=*),OPTIONAL :: help
2637
2638CHARACTER(LEN=40) :: cdefault
2639INTEGER :: i
2640TYPE(option) :: myoption
2641
2642IF (PRESENT(default)) THEN
2643 IF (c_e(default)) THEN
2644 cdefault = ' [default='//trim(adjustl(to_char(default,form='(G15.9)')))//']'
2645 ELSE
2646 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2647 ENDIF
2648ELSE
2649 cdefault = ''
2650ENDIF
2651
2652! common initialisation
2653myoption = option_new(short_opt, long_opt, cdefault, help)
2654IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2655
2656myoption%destd => dest
2657IF (PRESENT(default)) myoption%destd = default
2658myoption%opttype = opttype_d
2659myoption%need_arg = 2
2660
2661i = arrayof_option_append(this%options, myoption)
2662
2663END SUBROUTINE optionparser_add_d
2664
2665
2675SUBROUTINE optionparser_add_darray(this, short_opt, long_opt, dest, default, help)
2676TYPE(optionparser),INTENT(inout) :: this
2677CHARACTER(len=*),INTENT(in) :: short_opt
2678CHARACTER(len=*),INTENT(in) :: long_opt
2679TYPE(arrayof_doubleprecision),TARGET :: dest
2680DOUBLE PRECISION,OPTIONAL :: default(:)
2681CHARACTER(len=*),OPTIONAL :: help
2682
2683CHARACTER(LEN=40) :: cdefault
2684INTEGER :: i
2685TYPE(option) :: myoption
2686
2687cdefault = ''
2688IF (PRESENT(default)) THEN
2689 IF (SIZE(default) == 1) THEN
2690 cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//']'
2691 ELSE IF (SIZE(default) > 1) THEN
2692 cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//',...]'
2693 ENDIF
2694ENDIF
2695
2696! common initialisation
2697myoption = option_new(short_opt, long_opt, cdefault, help)
2698IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2699
2700myoption%destdarr => dest
2701IF (PRESENT(default)) THEN
2702 CALL insert(myoption%destdarr, default)
2703 CALL packarray(myoption%destdarr)
2704ENDIF
2705myoption%opttype = opttype_darr
2706myoption%need_arg = 2
2707
2708i = arrayof_option_append(this%options, myoption)
2709
2710END SUBROUTINE optionparser_add_darray
2711
2712
2719SUBROUTINE optionparser_add_l(this, short_opt, long_opt, dest, help)
2720TYPE(optionparser),INTENT(inout) :: this
2721CHARACTER(len=*),INTENT(in) :: short_opt
2722CHARACTER(len=*),INTENT(in) :: long_opt
2723LOGICAL,TARGET :: dest
2724CHARACTER(len=*),OPTIONAL :: help
2725
2726INTEGER :: i
2727TYPE(option) :: myoption
2728
2729! common initialisation
2730myoption = option_new(short_opt, long_opt, '', help)
2731IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2732
2733myoption%destl => dest
2734myoption%destl = .false. ! unconditionally set to false, option can only set it to true
2735myoption%opttype = opttype_l
2736myoption%need_arg = 0
2737
2738i = arrayof_option_append(this%options, myoption)
2739
2740END SUBROUTINE optionparser_add_l
2741
2742
2747SUBROUTINE optionparser_add_count(this, short_opt, long_opt, dest, start, help)
2748TYPE(optionparser),INTENT(inout) :: this
2749CHARACTER(len=*),INTENT(in) :: short_opt
2750CHARACTER(len=*),INTENT(in) :: long_opt
2751INTEGER,TARGET :: dest
2752INTEGER,OPTIONAL :: start
2753CHARACTER(len=*),OPTIONAL :: help
2754
2755INTEGER :: i
2756TYPE(option) :: myoption
2757
2758! common initialisation
2759myoption = option_new(short_opt, long_opt, '', help)
2760IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2761
2762myoption%destcount => dest
2763IF (PRESENT(start)) myoption%destcount = start
2764myoption%opttype = opttype_count
2765myoption%need_arg = 0
2766
2767i = arrayof_option_append(this%options, myoption)
2768
2769END SUBROUTINE optionparser_add_count
2770
2771
2786SUBROUTINE optionparser_add_help(this, short_opt, long_opt, help)
2787TYPE(optionparser),INTENT(inout) :: this
2788CHARACTER(len=*),INTENT(in) :: short_opt
2789CHARACTER(len=*),INTENT(in) :: long_opt
2790CHARACTER(len=*),OPTIONAL :: help
2791
2792INTEGER :: i
2793TYPE(option) :: myoption
2794
2795! common initialisation
2796myoption = option_new(short_opt, long_opt, '', help)
2797IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2798
2799myoption%opttype = opttype_help
2800myoption%need_arg = 1
2801
2802i = arrayof_option_append(this%options, myoption)
2803
2804END SUBROUTINE optionparser_add_help
2805
2806
2817SUBROUTINE optionparser_add_sep(this, help)
2818TYPE(optionparser),INTENT(inout) :: this
2819!CHARACTER(len=*),INTENT(in) :: short_opt !< the short option (may be empty)
2820!CHARACTER(len=*),INTENT(in) :: long_opt !< the long option (may be empty)
2821CHARACTER(len=*) :: help
2822
2823INTEGER :: i
2824TYPE(option) :: myoption
2825
2826! common initialisation
2827myoption = option_new('_', '_', '', help)
2828IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2829
2830myoption%opttype = opttype_sep
2831myoption%need_arg = 0
2832
2833i = arrayof_option_append(this%options, myoption)
2834
2835END SUBROUTINE optionparser_add_sep
2836
2837
2847SUBROUTINE optionparser_parse(this, nextarg, status)
2848TYPE(optionparser),INTENT(inout) :: this
2849INTEGER,INTENT(out) :: nextarg
2850INTEGER,INTENT(out) :: status
2851
2852INTEGER :: i, j, endopt, indeq, iargc
2853CHARACTER(len=16384) :: arg, optarg
2854
2855status = optionparser_ok
2856i = 1
2857DO WHILE(i <= iargc())
2858 CALL getarg(i, arg)
2859 IF (arg == '--') THEN ! explicit end of options
2860 i = i + 1 ! skip present option (--)
2861 EXIT
2862 ELSE IF (arg == '-') THEN ! a single - is not an option
2863 EXIT
2864 ELSE IF (arg(1:2) == '--') THEN ! long option
2865 indeq = index(arg, '=')
2866 IF (indeq /= 0) THEN ! = present
2867 endopt = indeq - 1
2868 ELSE ! no =
2869 endopt = len_trim(arg)
2870 ENDIF
2871 find_longopt: DO j = 1, this%options%arraysize
2872 IF (this%options%array(j)%long_opt == arg(3:endopt)) THEN ! found option
2873 SELECT CASE(this%options%array(j)%need_arg)
2874 CASE(2) ! compulsory
2875 IF (indeq /= 0) THEN
2876 optarg = arg(indeq+1:)
2877 status = max(option_found(this%options%array(j), optarg), &
2878 status)
2879 ELSE
2880 IF (i < iargc()) THEN
2881 i=i+1
2882 CALL getarg(i, optarg)
2883 status = max(option_found(this%options%array(j), optarg), &
2884 status)
2885 ELSE
2886 status = optionparser_err
2887 CALL l4f_log(l4f_error, &
2888 'in optionparser, option '''//trim(arg)//''' requires an argument')
2889 ENDIF
2890 ENDIF
2891 CASE(1) ! optional
2892 IF (indeq /= 0) THEN
2893 optarg = arg(indeq+1:)
2894 ELSE
2895 IF (i < iargc()) THEN
2896 CALL getarg(i+1, optarg)
2897 IF (optarg(1:1) == '-') THEN
2898 optarg = cmiss ! refused
2899 ELSE
2900 i=i+1 ! accepted
2901 ENDIF
2902 ELSE
2903 optarg = cmiss ! refused
2904 ENDIF
2905 ENDIF
2906 status = max(option_found(this%options%array(j), optarg), &
2907 status)
2908 CASE(0)
2909 status = max(option_found(this%options%array(j)), &
2910 status)
2911 END SELECT
2912 EXIT find_longopt
2913 ENDIF
2914 ENDDO find_longopt
2915 IF (j > this%options%arraysize) THEN
2916 status = optionparser_err
2917 CALL l4f_log(l4f_error, &
2918 'in optionparser, option '''//trim(arg)//''' not valid')
2919 ENDIF
2920 ELSE IF (arg(1:1) == '-') THEN ! short option
2921 find_shortopt: DO j = 1, this%options%arraysize
2922 IF (this%options%array(j)%short_opt == arg(2:2)) THEN ! found option
2923 SELECT CASE(this%options%array(j)%need_arg)
2924 CASE(2) ! compulsory
2925 IF (len_trim(arg) > 2) THEN
2926 optarg = arg(3:)
2927 status = max(option_found(this%options%array(j), optarg), &
2928 status)
2929 ELSE
2930 IF (i < iargc()) THEN
2931 i=i+1
2932 CALL getarg(i, optarg)
2933 status = max(option_found(this%options%array(j), optarg), &
2934 status)
2935 ELSE
2936 status = optionparser_err
2937 CALL l4f_log(l4f_error, &
2938 'in optionparser, option '''//trim(arg)//''' requires an argument')
2939 ENDIF
2940 ENDIF
2941 CASE(1) ! optional
2942 IF (len_trim(arg) > 2) THEN
2943 optarg = arg(3:)
2944 ELSE
2945 IF (i < iargc()) THEN
2946 CALL getarg(i+1, optarg)
2947 IF (optarg(1:1) == '-') THEN
2948 optarg = cmiss ! refused
2949 ELSE
2950 i=i+1 ! accepted
2951 ENDIF
2952 ELSE
2953 optarg = cmiss ! refused
2954 ENDIF
2955 ENDIF
2956 status = max(option_found(this%options%array(j), optarg), &
2957 status)
2958 CASE(0)
2959 status = max(option_found(this%options%array(j)), &
2960 status)
2961 END SELECT
2962 EXIT find_shortopt
2963 ENDIF
2964 ENDDO find_shortopt
2965 IF (j > this%options%arraysize) THEN
2966 status = optionparser_err
2967 CALL l4f_log(l4f_error, &
2968 'in optionparser, option '''//trim(arg)//''' not valid')
2969 ENDIF
2970 ELSE ! unrecognized = end of options
2971 EXIT
2972 ENDIF
2973 i = i + 1
2974ENDDO
2975
2976nextarg = i
2977SELECT CASE(status)
2978CASE(optionparser_err, optionparser_help)
2979 CALL optionparser_printhelp(this)
2980END SELECT
2981
2982END SUBROUTINE optionparser_parse
2983
2984
2988SUBROUTINE optionparser_printhelp(this)
2989TYPE(optionparser),INTENT(in) :: this
2990
2991INTEGER :: i, form
2992
2993form = 0
2994DO i = 1, this%options%arraysize ! loop over options
2995 IF (this%options%array(i)%opttype == opttype_help) THEN
2996 form = this%options%array(i)%helpformat
2997 ENDIF
2998ENDDO
2999
3000SELECT CASE(form)
3001CASE(0)
3002 CALL optionparser_printhelptxt(this)
3003CASE(1)
3004 CALL optionparser_printhelpmd(this)
3005CASE(2)
3006 CALL optionparser_printhelphtmlform(this)
3007END SELECT
3008
3009END SUBROUTINE optionparser_printhelp
3010
3011
3015SUBROUTINE optionparser_printhelptxt(this)
3016TYPE(optionparser),INTENT(in) :: this
3017
3018INTEGER :: i, j, ncols
3019CHARACTER(len=80) :: buf
3020TYPE(line_split) :: help_line
3021
3022ncols = default_columns()
3023
3024! print usage message
3025IF (ASSOCIATED(this%usage_msg)) THEN
3026 help_line = line_split_new(cstr_to_fchar(this%usage_msg), ncols)
3027 DO j = 1, line_split_get_nlines(help_line)
3028 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
3029 ENDDO
3030 CALL delete(help_line)
3031ELSE
3032 CALL getarg(0, buf)
3033 i = index(buf, '/', back=.true.) ! remove directory part
3034 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
3035 WRITE(*,'(A)')'Usage: '//trim(buf(i+1:))//' [options] [arguments]'
3036ENDIF
3037
3038! print description message
3039IF (ASSOCIATED(this%description_msg)) THEN
3040 WRITE(*,'()')
3041 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
3042 DO j = 1, line_split_get_nlines(help_line)
3043 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
3044 ENDDO
3045 CALL delete(help_line)
3046ENDIF
3047
3048WRITE(*,'(/,A)')'Options:'
3049
3050DO i = 1, this%options%arraysize ! loop over options
3051 CALL option_format_help(this%options%array(i), ncols)
3052ENDDO
3053
3054END SUBROUTINE optionparser_printhelptxt
3055
3056
3060SUBROUTINE optionparser_printhelpmd(this)
3061TYPE(optionparser),INTENT(in) :: this
3062
3063INTEGER :: i, j, ncols
3064CHARACTER(len=80) :: buf
3065TYPE(line_split) :: help_line
3066
3067ncols = default_columns()
3068
3069! print usage message
3070WRITE(*,'(A)')'### Synopsis'
3071
3072IF (ASSOCIATED(this%usage_msg)) THEN
3073 help_line = line_split_new(mdquote_usage_msg(cstr_to_fchar(this%usage_msg)), ncols)
3074 DO j = 1, line_split_get_nlines(help_line)
3075 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
3076 ENDDO
3077 CALL delete(help_line)
3078ELSE
3079 CALL getarg(0, buf)
3080 i = index(buf, '/', back=.true.) ! remove directory part
3081 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
3082 WRITE(*,'(A)')'Usage: `'//trim(buf(i+1:))//' [options] [arguments]`'
3083ENDIF
3084
3085! print description message
3086IF (ASSOCIATED(this%description_msg)) THEN
3087 WRITE(*,'()')
3088 WRITE(*,'(A)')'### Description'
3089 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
3090 DO j = 1, line_split_get_nlines(help_line)
3091 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
3092 ENDDO
3093 CALL delete(help_line)
3094
3095ENDIF
3096
3097WRITE(*,'(/,A)')'### Options'
3098
3099DO i = 1, this%options%arraysize ! loop over options
3100 CALL option_format_md(this%options%array(i), ncols)
3101ENDDO
3102
3103CONTAINS
3104
3105FUNCTION mdquote_usage_msg(usage_msg)
3106CHARACTER(len=*),INTENT(in) :: usage_msg
3107
3108CHARACTER(len=LEN(usage_msg)+2) :: mdquote_usage_msg
3109INTEGER :: colon
3110
3111colon = index(usage_msg, ':') ! typically 'Usage: cp [options] origin destination'
3112IF (colon > 0 .AND. colon < len(usage_msg)-1) THEN
3113 mdquote_usage_msg = usage_msg(:colon+1)//'`'//usage_msg(colon+2:)//'`'
3114ELSE
3115 mdquote_usage_msg = usage_msg
3116ENDIF
3117
3118END FUNCTION mdquote_usage_msg
3119
3120END SUBROUTINE optionparser_printhelpmd
3121
3125SUBROUTINE optionparser_printhelphtmlform(this)
3126TYPE(optionparser),INTENT(in) :: this
3127
3128INTEGER :: i
3129
3130DO i = 1, this%options%arraysize ! loop over options
3131 CALL option_format_htmlform(this%options%array(i))
3132ENDDO
3133
3134WRITE(*,'(A)')'<input class="libsim_sub" type="submit" value="runprogram" />'
3135
3136END SUBROUTINE optionparser_printhelphtmlform
3137
3138
3139SUBROUTINE optionparser_make_completion(this)
3140TYPE(optionparser),INTENT(in) :: this
3141
3142INTEGER :: i
3143CHARACTER(len=512) :: buf
3144
3145CALL getarg(0, buf)
3146
3147WRITE(*,'(A/A/A)')'_'//trim(buf)//'()','{','local cur'
3148
3149WRITE(*,'(A/A/A/A)')'COMPREPLY=()','cur=${COMP_WORDS[COMP_CWORD]}', &
3150 'case "$cur" in','-*)'
3151
3152!-*)
3153! COMPREPLY=( $( compgen -W
3154DO i = 1, this%options%arraysize ! loop over options
3155 IF (this%options%array(i)%need_arg == 2) THEN
3156 ENDIF
3157ENDDO
3158
3159WRITE(*,'(A/A/A)')'esac','return 0','}'
3160
3161END SUBROUTINE optionparser_make_completion
3162
3163
3164SUBROUTINE dirty_char_assignment(destc, destclen, src)
3165USE kinds
3166IMPLICIT NONE
3167
3168CHARACTER(len=1) :: destc(*)
3169CHARACTER(len=*) :: src
3170INTEGER :: destclen
3171
3172INTEGER :: i
3173
3174DO i = 1, min(destclen, len(src))
3175 destc(i) = src(i:i)
3176ENDDO
3177DO i = len(src)+1, destclen
3178 destc(i) = ' '
3179ENDDO
3180
3181END SUBROUTINE dirty_char_assignment
3182
3183END MODULE optionparser_class
Set of functions that return a trimmed CHARACTER representation of the input variable.
Set of functions that return a CHARACTER representation of the input variable.
Methods for successively obtaining the fields of a csv_record object.
Constructor for the class csv_record.
Index method.
Destructor for the optionparser class.
Add a new option of a specific type.
This module defines usefull general purpose function and subroutine.
Utilities for CHARACTER variables.
Gestione degli errori.
Utilities for managing files.
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:245
classe per la gestione del logging
Module for parsing command-line optons.
This class allows to parse the command-line options of a program in an object-oriented way,...

Generated with Doxygen.