libsim Versione 7.1.11

◆ optionparser_make_completion()

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

Definizione alla linea 1824 del file optionparser_class.F90.

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