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