libsim Versione 7.1.11

◆ optionparser_printhelphtmlform()

subroutine optionparser_printhelphtmlform ( type(optionparser), intent(in)  this)
private

Print on stdout an html form reflecting the command line options set up.

It can be called by the user program and it is called anyway if the program has been called with the --help htmlform option.

Parametri
[in]thisoptionparser object with correctly initialised options

Definizione alla linea 1810 del file optionparser_class.F90.

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