libsim Versione 7.2.1
|
◆ optionparser_printhelptxt()
Print on stdout a human-readable text representation of the help message. It can be called by the user program and it is called anyway in case of error in the interpretation of the command line.
Definizione alla linea 1694 del file optionparser_class.F90. 1695! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1696! authors:
1697! Davide Cesari <dcesari@arpa.emr.it>
1698! Paolo Patruno <ppatruno@arpa.emr.it>
1699
1700! This program is free software; you can redistribute it and/or
1701! modify it under the terms of the GNU General Public License as
1702! published by the Free Software Foundation; either version 2 of
1703! the License, or (at your option) any later version.
1704
1705! This program is distributed in the hope that it will be useful,
1706! but WITHOUT ANY WARRANTY; without even the implied warranty of
1707! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1708! GNU General Public License for more details.
1718#include "config.h"
1719
1727IMPLICIT NONE
1728
1729
1730! private class
1731TYPE option
1732 CHARACTER(len=1) :: short_opt=''
1733 CHARACTER(len=80) :: long_opt=''
1734 INTEGER :: opttype=-1
1735 INTEGER :: need_arg=0 ! 0=no, 1=optional, 2=yes, was .FALSE.
1736 LOGICAL :: has_default=.false.
1737 CHARACTER(len=1),POINTER :: destc=>null()
1738 INTEGER :: destclen=0
1739 INTEGER :: helpformat=0 ! 0=txt, 1=markdown, 2=htmlform, improve!
1740 INTEGER,POINTER :: desti=>null()
1741 TYPE(arrayof_integer),POINTER :: destiarr=>null()
1742 REAL,POINTER :: destr=>null()
1743 TYPE(arrayof_real),POINTER :: destrarr=>null()
1744 DOUBLE PRECISION, POINTER :: destd=>null()
1745 TYPE(arrayof_doubleprecision),POINTER :: destdarr=>null()
1746 LOGICAL,POINTER :: destl=>null()
1747 TYPE(arrayof_logical),POINTER :: destlarr=>null()
1748 INTEGER,POINTER :: destcount=>null()
1749 INTEGER(kind=int_b),ALLOCATABLE :: help_msg(:)
1750END TYPE option
1751
1752#define ARRAYOF_ORIGTYPE TYPE(option)
1753#define ARRAYOF_TYPE arrayof_option
1754#define ARRAYOF_ORIGDESTRUCTOR(x) CALL option_delete(x)
1755#define ARRAYOF_PRIVATE 1
1756#include "arrayof_pre_nodoc.F90"
1757! from arrayof
1758!PUBLIC insert, append, remove, packarray
1759!PUBLIC insert_unique, append_unique
1760
1839 PRIVATE
1840 INTEGER(kind=int_b),POINTER :: usage_msg(:), description_msg(:)
1841 TYPE(arrayof_option) :: options
1842 LOGICAL :: httpmode=.false.
1844
1845
1850 MODULE PROCEDURE optionparser_add_c, optionparser_add_i, optionparser_add_r, &
1851 optionparser_add_d, optionparser_add_l, &
1852 optionparser_add_iarray, optionparser_add_rarray, optionparser_add_darray
1853END INTERFACE
1854
1855INTERFACE c_e
1856 MODULE PROCEDURE option_c_e
1857END INTERFACE
1858
1867 MODULE PROCEDURE optionparser_delete!?, option_delete
1868END INTERFACE
1869
1870
1871INTEGER,PARAMETER :: opttype_c = 1, opttype_i = 2, opttype_r = 3, &
1872 opttype_d = 4, opttype_l = 5, opttype_count = 6, opttype_help = 7, &
1873 opttype_sep = 8, opttype_carr = 11, opttype_iarr = 12, opttype_rarr = 13, &
1874 opttype_darr = 14, opttype_larr = 15
1875
1876INTEGER,PARAMETER :: optionparser_ok = 0
1877INTEGER,PARAMETER :: optionparser_help = 1
1878INTEGER,PARAMETER :: optionparser_err = 2
1879
1880
1881PRIVATE
1883 optionparser_add_count, optionparser_add_help, optionparser_add_sep, &
1884 optionparser_parse, optionparser_printhelp, &
1885 optionparser_ok, optionparser_help, optionparser_err
1886
1887
1888CONTAINS
1889
1890#include "arrayof_post_nodoc.F90"
1891
1892! Constructor for the option class
1893FUNCTION option_new(short_opt, long_opt, default, help) RESULT(this)
1894CHARACTER(len=*),INTENT(in) :: short_opt
1895CHARACTER(len=*),INTENT(in) :: long_opt
1896CHARACTER(len=*),INTENT(in) :: default
1897CHARACTER(len=*),OPTIONAL :: help
1898TYPE(option) :: this
1899
1900IF (short_opt == '' .AND. long_opt == '') THEN
1901#ifdef DEBUG
1902! programmer error condition, option empty
1903 CALL l4f_log(l4f_error, 'in optionparser, both short and long options empty')
1904 CALL raise_fatal_error()
1905#else
1906 CALL l4f_log(l4f_warn, 'in optionparser, both short and long options empty')
1907#endif
1908 RETURN
1909ENDIF
1910
1911this%short_opt = short_opt
1912this%long_opt = long_opt
1913IF (PRESENT(help)) THEN
1914 this%help_msg = fchar_to_cstr(trim(help)//trim(default)) ! f2003 automatic alloc
1915ENDIF
1916this%has_default = (len_trim(default) > 0)
1917
1918END FUNCTION option_new
1919
1920
1921! Destructor for the \a option class, the memory associated with
1922! the object is freed.
1923SUBROUTINE option_delete(this)
1924TYPE(option),INTENT(inout) :: this ! object to destroy
1925
1926IF (ALLOCATED(this%help_msg)) DEALLOCATE(this%help_msg)
1927NULLIFY(this%destc)
1928NULLIFY(this%desti)
1929NULLIFY(this%destr)
1930NULLIFY(this%destd)
1931NULLIFY(this%destl)
1932NULLIFY(this%destcount)
1933
1934END SUBROUTINE option_delete
1935
1936
1937FUNCTION option_found(this, optarg) RESULT(status)
1938TYPE(option),INTENT(inout) :: this
1939CHARACTER(len=*),INTENT(in),OPTIONAL :: optarg
1940INTEGER :: status
1941
1942TYPE(csv_record) :: arrparser
1943INTEGER :: ibuff
1944REAL :: rbuff
1945DOUBLE PRECISION :: dbuff
1946
1947status = optionparser_ok
1948
1949SELECT CASE(this%opttype)
1950CASE(opttype_c)
1951 CALL dirty_char_assignment(this%destc, this%destclen, trim(optarg))
1952! this%destc(1:this%destclen) = optarg
1953 IF (len_trim(optarg) > this%destclen) THEN
1954 CALL l4f_log(l4f_warn, &
1955 'in optionparser, argument '''//trim(optarg)//''' too long, truncated')
1956 ENDIF
1957CASE(opttype_i)
1958 READ(optarg,'(I12)',err=100)this%desti
1959CASE(opttype_iarr)
1962 DO WHILE(.NOT.csv_record_end(arrparser))
1964 CALL insert(this%destiarr, ibuff)
1965 ENDDO
1966 CALL packarray(this%destiarr)
1968CASE(opttype_r)
1969 READ(optarg,'(F20.0)',err=102)this%destr
1970CASE(opttype_rarr)
1973 DO WHILE(.NOT.csv_record_end(arrparser))
1975 CALL insert(this%destrarr, rbuff)
1976 ENDDO
1977 CALL packarray(this%destrarr)
1979CASE(opttype_d)
1980 READ(optarg,'(F20.0)',err=102)this%destd
1981CASE(opttype_darr)
1984 DO WHILE(.NOT.csv_record_end(arrparser))
1986 CALL insert(this%destdarr, dbuff)
1987 ENDDO
1988 CALL packarray(this%destdarr)
1990CASE(opttype_l)
1991 this%destl = .true.
1992CASE(opttype_count)
1993 this%destcount = this%destcount + 1
1994CASE(opttype_help)
1995 status = optionparser_help
1996 SELECT CASE(optarg) ! set help format
1997 CASE('md', 'markdown')
1998 this%helpformat = 1
1999 CASE('htmlform')
2000 this%helpformat = 2
2001 END SELECT
2002END SELECT
2003
2004RETURN
2005
2006100 status = optionparser_err
2007CALL l4f_log(l4f_error, &
2008 'in optionparser, argument '''//trim(optarg)//''' not valid as integer')
2009RETURN
2010102 status = optionparser_err
2011CALL l4f_log(l4f_error, &
2012 'in optionparser, argument '''//trim(optarg)//''' not valid as real')
2013RETURN
2014
2015END FUNCTION option_found
2016
2017
2018! Return a string which gives a short representation of the
2019! option \a this, without help message. The resulting string is quite
2020! long and it should be trimmed with the \a TRIM() intrinsic
2021! function.
2022FUNCTION option_format_opt(this) RESULT(format_opt)
2023TYPE(option),INTENT(in) :: this
2024
2025CHARACTER(len=100) :: format_opt
2026
2027CHARACTER(len=20) :: argname
2028
2029SELECT CASE(this%opttype)
2030CASE(opttype_c)
2031 argname = 'STRING'
2032CASE(opttype_i)
2033 argname = 'INT'
2034CASE(opttype_iarr)
2035 argname = 'INT[,INT...]'
2036CASE(opttype_r, opttype_d)
2037 argname = 'REAL'
2038CASE(opttype_rarr, opttype_darr)
2039 argname = 'REAL[,REAL...]'
2040CASE default
2041 argname = ''
2042END SELECT
2043
2044format_opt = ''
2045IF (this%short_opt /= '') THEN
2046 format_opt(len_trim(format_opt)+1:) = ' -'//this%short_opt
2047 IF (argname /= '') THEN
2048 format_opt(len_trim(format_opt)+1:) = ' '//trim(argname)
2049 ENDIF
2050ENDIF
2051IF (this%short_opt /= '' .AND. this%long_opt /= '') THEN
2052 format_opt(len_trim(format_opt)+1:) = ','
2053ENDIF
2054IF (this%long_opt /= '') THEN
2055 format_opt(len_trim(format_opt)+1:) = ' --'//this%long_opt
2056 IF (argname /= '') THEN
2057 format_opt(len_trim(format_opt)+1:) = '='//trim(argname)
2058 ENDIF
2059ENDIF
2060
2061END FUNCTION option_format_opt
2062
2063
2064! print on stdout a human-readable text representation of a single option
2065SUBROUTINE option_format_help(this, ncols)
2066TYPE(option),INTENT(in) :: this
2067INTEGER,INTENT(in) :: ncols
2068
2069INTEGER :: j
2070INTEGER, PARAMETER :: indent = 10
2071TYPE(line_split) :: help_line
2072
2073
2074IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
2075 IF (ALLOCATED(this%help_msg)) THEN
2076! help2man is quite picky about the treatment of arbitrary lines
2077! within options, the only universal way seems to be unindented lines
2078! with an empty line before and after
2079 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
2080 WRITE(*,'()')
2081 DO j = 1, line_split_get_nlines(help_line)
2082 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2083 ENDDO
2085 WRITE(*,'()')
2086 ENDIF
2087ELSE ! ordinary option
2088! print option brief representation
2089 WRITE(*,'(A)')trim(option_format_opt(this))
2090! print option help
2091 IF (ALLOCATED(this%help_msg)) THEN
2092 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
2093 DO j = 1, line_split_get_nlines(help_line)
2094 WRITE(*,'(T10,A)')trim(line_split_get_line(help_line,j))
2095 ENDDO
2097 ENDIF
2098ENDIF
2099
2100END SUBROUTINE option_format_help
2101
2102
2103! print on stdout a markdown representation of a single option
2104SUBROUTINE option_format_md(this, ncols)
2105TYPE(option),INTENT(in) :: this
2106INTEGER,INTENT(in) :: ncols
2107
2108INTEGER :: j
2109INTEGER, PARAMETER :: indent = 2
2110TYPE(line_split) :: help_line
2111
2112IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
2113 IF (ALLOCATED(this%help_msg)) THEN
2114 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
2115 WRITE(*,'()')
2116 DO j = 1, line_split_get_nlines(help_line)
2117 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2118 ENDDO
2120 WRITE(*,'()')
2121 ENDIF
2122ELSE ! ordinary option
2123! print option brief representation
2124 WRITE(*,'(''`'',A,''`'')')trim(option_format_opt(this))
2125! print option help
2126 IF (ALLOCATED(this%help_msg)) THEN
2127 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
2128 DO j = 1, line_split_get_nlines(help_line)
2129 WRITE(*,'(''> '',A)')trim(line_split_get_line(help_line,j))
2130 ENDDO
2132 WRITE(*,'()')
2133 ENDIF
2134ENDIF
2135
2136END SUBROUTINE option_format_md
2137
2138
2139! print on stdout an html form representation of a single option
2140SUBROUTINE option_format_htmlform(this)
2141TYPE(option),INTENT(in) :: this
2142
2143CHARACTER(len=80) :: opt_name, opt_id, opt_default ! check len of default
2144
2145IF (.NOT.c_e(this)) RETURN
2146IF (this%long_opt == '') THEN
2147 opt_name = this%short_opt
2148 opt_id = 'short_opt_'//this%short_opt
2149ELSE
2150 opt_name = this%long_opt
2151 opt_id = this%long_opt
2152ENDIF
2153
2154SELECT CASE(this%opttype)
2155CASE(opttype_c)
2156 CALL option_format_html_openspan('text')
2157
2158 IF (this%has_default .AND. ASSOCIATED(this%destc) .AND. this%destclen > 0) THEN
2159! opt_default = TRANSFER(this%destc(1:MIN(LEN(opt_default),this%destclen)), &
2160! opt_default) ! improve
2161 opt_default = ''
2162 WRITE(*,'(A)')' value="'//trim(opt_default)//'"'
2163 ENDIF
2164 CALL option_format_html_help()
2165 CALL option_format_html_closespan()
2166
2167CASE(opttype_i,opttype_r,opttype_d)
2168 CALL option_format_html_openspan('text')
2169 IF (this%has_default) THEN
2170 SELECT CASE(this%opttype)
2171 CASE(opttype_i)
2173! todo CASE(opttype_iarr)
2174 CASE(opttype_r)
2176 CASE(opttype_d)
2178 END SELECT
2179 ENDIF
2180 CALL option_format_html_help()
2181 CALL option_format_html_closespan()
2182
2183! todo CASE(opttype_iarr)
2184
2185CASE(opttype_l)
2186 CALL option_format_html_openspan('checkbox')
2187 CALL option_format_html_help()
2188 CALL option_format_html_closespan()
2189
2190CASE(opttype_count)
2191 CALL option_format_html_openspan('number')
2192 CALL option_format_html_help()
2193 CALL option_format_html_closespan()
2194
2195CASE(opttype_sep)
2196END SELECT
2197
2198
2199CONTAINS
2200
2201SUBROUTINE option_format_html_openspan(formtype)
2202CHARACTER(len=*),INTENT(in) :: formtype
2203
2204WRITE(*,'(A)')'<span class="libsim_optbox" id="span_'//trim(opt_id)//'">'//trim(opt_name)//':'
2205! size=? maxlen=?
2206WRITE(*,'(A)')'<input class_"libsim_opt" id="'//trim(opt_id)//'" type="'//formtype// &
2207 '" name="'//trim(opt_id)//'" '
2208
2209END SUBROUTINE option_format_html_openspan
2210
2211SUBROUTINE option_format_html_closespan()
2212
2213WRITE(*,'(A)')'/></span>'
2214
2215END SUBROUTINE option_format_html_closespan
2216
2217SUBROUTINE option_format_html_help()
2218INTEGER :: j
2219TYPE(line_split) :: help_line
2220CHARACTER(len=20) :: form
2221
2222IF (ALLOCATED(this%help_msg)) THEN
2223 WRITE(*,'(A,$)')' title="'
2224
2225 help_line = line_split_new(cstr_to_fchar(this%help_msg), 80)
2226 form = '(A,'' '')'
2227 DO j = 1, line_split_get_nlines(help_line)
2228 IF (j == line_split_get_nlines(help_line)) form = '(A,''"'',$)'
2229 WRITE(*,form)trim(line_split_get_line(help_line,j)) ! lines should be properly quoted here
2230 ENDDO
2231
2232ENDIF
2233
2234END SUBROUTINE option_format_html_help
2235
2236END SUBROUTINE option_format_htmlform
2237
2238
2239FUNCTION option_c_e(this) RESULT(c_e)
2240TYPE(option),INTENT(in) :: this
2241
2242LOGICAL :: c_e
2243
2244c_e = this%long_opt /= ' ' .OR. this%short_opt /= ' '
2245
2246END FUNCTION option_c_e
2247
2248
2252FUNCTION optionparser_new(usage_msg, description_msg) RESULT(this)
2253CHARACTER(len=*), INTENT(in), OPTIONAL :: usage_msg
2254CHARACTER(len=*), INTENT(in), OPTIONAL :: description_msg
2255
2256TYPE(optionparser) :: this
2257
2258IF (PRESENT(usage_msg)) THEN
2259 CALL fchar_to_cstr_alloc(trim(usage_msg), this%usage_msg)
2260ELSE
2261 NULLIFY(this%usage_msg)
2262ENDIF
2263IF (PRESENT(description_msg)) THEN
2264 CALL fchar_to_cstr_alloc(trim(description_msg), this%description_msg)
2265ELSE
2266 NULLIFY(this%description_msg)
2267ENDIF
2268
2269END FUNCTION optionparser_new
2270
2271
2272SUBROUTINE optionparser_delete(this)
2273TYPE(optionparser),INTENT(inout) :: this
2274
2275IF (ASSOCIATED(this%usage_msg)) DEALLOCATE(this%usage_msg)
2276IF (ASSOCIATED(this%description_msg)) DEALLOCATE(this%description_msg)
2278
2279END SUBROUTINE optionparser_delete
2280
2281
2289SUBROUTINE optionparser_add_c(this, short_opt, long_opt, dest, default, help, isopt)
2290TYPE(optionparser),INTENT(inout) :: this
2291CHARACTER(len=*),INTENT(in) :: short_opt
2292CHARACTER(len=*),INTENT(in) :: long_opt
2293CHARACTER(len=*),TARGET :: dest
2294CHARACTER(len=*),OPTIONAL :: default
2295CHARACTER(len=*),OPTIONAL :: help
2296LOGICAL,INTENT(in),OPTIONAL :: isopt
2297
2298CHARACTER(LEN=60) :: cdefault
2299INTEGER :: i
2300TYPE(option) :: myoption
2301
2302
2303IF (PRESENT(default)) THEN
2305ELSE
2306 cdefault = ''
2307ENDIF
2308
2309! common initialisation
2310myoption = option_new(short_opt, long_opt, cdefault, help)
2311IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2312
2313myoption%destc => dest(1:1)
2314myoption%destclen = len(dest) ! needed to avoid exceeding the length of dest
2315IF (PRESENT(default)) &
2316 CALL dirty_char_assignment(myoption%destc, myoption%destclen, default)
2317!IF (PRESENT(default)) myoption%destc(1:myoption%destclen) = default
2318myoption%opttype = opttype_c
2319IF (optio_log(isopt)) THEN
2320 myoption%need_arg = 1
2321ELSE
2322 myoption%need_arg = 2
2323ENDIF
2324
2325i = arrayof_option_append(this%options, myoption)
2326
2327END SUBROUTINE optionparser_add_c
2328
2329
2336SUBROUTINE optionparser_add_i(this, short_opt, long_opt, dest, default, help)
2337TYPE(optionparser),INTENT(inout) :: this
2338CHARACTER(len=*),INTENT(in) :: short_opt
2339CHARACTER(len=*),INTENT(in) :: long_opt
2340INTEGER,TARGET :: dest
2341INTEGER,OPTIONAL :: default
2342CHARACTER(len=*),OPTIONAL :: help
2343
2344CHARACTER(LEN=40) :: cdefault
2345INTEGER :: i
2346TYPE(option) :: myoption
2347
2348IF (PRESENT(default)) THEN
2350ELSE
2351 cdefault = ''
2352ENDIF
2353
2354! common initialisation
2355myoption = option_new(short_opt, long_opt, cdefault, help)
2356IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2357
2358myoption%desti => dest
2359IF (PRESENT(default)) myoption%desti = default
2360myoption%opttype = opttype_i
2361myoption%need_arg = 2
2362
2363i = arrayof_option_append(this%options, myoption)
2364
2365END SUBROUTINE optionparser_add_i
2366
2367
2377SUBROUTINE optionparser_add_iarray(this, short_opt, long_opt, dest, default, help)
2378TYPE(optionparser),INTENT(inout) :: this
2379CHARACTER(len=*),INTENT(in) :: short_opt
2380CHARACTER(len=*),INTENT(in) :: long_opt
2381TYPE(arrayof_integer),TARGET :: dest
2382INTEGER,OPTIONAL :: default(:)
2383CHARACTER(len=*),OPTIONAL :: help
2384
2385CHARACTER(LEN=40) :: cdefault
2386INTEGER :: i
2387TYPE(option) :: myoption
2388
2389cdefault = ''
2390IF (PRESENT(default)) THEN
2391 IF (SIZE(default) == 1) THEN
2393 ELSE IF (SIZE(default) > 1) THEN
2395 ENDIF
2396ENDIF
2397
2398! common initialisation
2399myoption = option_new(short_opt, long_opt, cdefault, help)
2400IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2401
2402myoption%destiarr => dest
2403IF (PRESENT(default)) THEN
2404 CALL insert(myoption%destiarr, default)
2405 CALL packarray(myoption%destiarr)
2406ENDIF
2407myoption%opttype = opttype_iarr
2408myoption%need_arg = 2
2409
2410i = arrayof_option_append(this%options, myoption)
2411
2412END SUBROUTINE optionparser_add_iarray
2413
2414
2421SUBROUTINE optionparser_add_r(this, short_opt, long_opt, dest, default, help)
2422TYPE(optionparser),INTENT(inout) :: this
2423CHARACTER(len=*),INTENT(in) :: short_opt
2424CHARACTER(len=*),INTENT(in) :: long_opt
2425REAL,TARGET :: dest
2426REAL,OPTIONAL :: default
2427CHARACTER(len=*),OPTIONAL :: help
2428
2429CHARACTER(LEN=40) :: cdefault
2430INTEGER :: i
2431TYPE(option) :: myoption
2432
2433IF (PRESENT(default)) THEN
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%destr => dest
2444IF (PRESENT(default)) myoption%destr = default
2445myoption%opttype = opttype_r
2446myoption%need_arg = 2
2447
2448i = arrayof_option_append(this%options, myoption)
2449
2450END SUBROUTINE optionparser_add_r
2451
2452
2462SUBROUTINE optionparser_add_rarray(this, short_opt, long_opt, dest, default, help)
2463TYPE(optionparser),INTENT(inout) :: this
2464CHARACTER(len=*),INTENT(in) :: short_opt
2465CHARACTER(len=*),INTENT(in) :: long_opt
2466TYPE(arrayof_real),TARGET :: dest
2467REAL,OPTIONAL :: default(:)
2468CHARACTER(len=*),OPTIONAL :: help
2469
2470CHARACTER(LEN=40) :: cdefault
2471INTEGER :: i
2472TYPE(option) :: myoption
2473
2474cdefault = ''
2475IF (PRESENT(default)) THEN
2476 IF (SIZE(default) == 1) THEN
2478 ELSE IF (SIZE(default) > 1) THEN
2480 ENDIF
2481ENDIF
2482
2483! common initialisation
2484myoption = option_new(short_opt, long_opt, cdefault, help)
2485IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2486
2487myoption%destrarr => dest
2488IF (PRESENT(default)) THEN
2489 CALL insert(myoption%destrarr, default)
2490 CALL packarray(myoption%destrarr)
2491ENDIF
2492myoption%opttype = opttype_rarr
2493myoption%need_arg = 2
2494
2495i = arrayof_option_append(this%options, myoption)
2496
2497END SUBROUTINE optionparser_add_rarray
2498
2499
2506SUBROUTINE optionparser_add_d(this, short_opt, long_opt, dest, default, help)
2507TYPE(optionparser),INTENT(inout) :: this
2508CHARACTER(len=*),INTENT(in) :: short_opt
2509CHARACTER(len=*),INTENT(in) :: long_opt
2510DOUBLE PRECISION,TARGET :: dest
2511DOUBLE PRECISION,OPTIONAL :: default
2512CHARACTER(len=*),OPTIONAL :: help
2513
2514CHARACTER(LEN=40) :: cdefault
2515INTEGER :: i
2516TYPE(option) :: myoption
2517
2518IF (PRESENT(default)) THEN
2519 IF (c_e(default)) THEN
2521 ELSE
2523 ENDIF
2524ELSE
2525 cdefault = ''
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%destd => dest
2533IF (PRESENT(default)) myoption%destd = default
2534myoption%opttype = opttype_d
2535myoption%need_arg = 2
2536
2537i = arrayof_option_append(this%options, myoption)
2538
2539END SUBROUTINE optionparser_add_d
2540
2541
2551SUBROUTINE optionparser_add_darray(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
2555TYPE(arrayof_doubleprecision),TARGET :: dest
2556DOUBLE PRECISION,OPTIONAL :: default(:)
2557CHARACTER(len=*),OPTIONAL :: help
2558
2559CHARACTER(LEN=40) :: cdefault
2560INTEGER :: i
2561TYPE(option) :: myoption
2562
2563cdefault = ''
2564IF (PRESENT(default)) THEN
2565 IF (SIZE(default) == 1) THEN
2567 ELSE IF (SIZE(default) > 1) THEN
2569 ENDIF
2570ENDIF
2571
2572! common initialisation
2573myoption = option_new(short_opt, long_opt, cdefault, help)
2574IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2575
2576myoption%destdarr => dest
2577IF (PRESENT(default)) THEN
2578 CALL insert(myoption%destdarr, default)
2579 CALL packarray(myoption%destdarr)
2580ENDIF
2581myoption%opttype = opttype_darr
2582myoption%need_arg = 2
2583
2584i = arrayof_option_append(this%options, myoption)
2585
2586END SUBROUTINE optionparser_add_darray
2587
2588
2595SUBROUTINE optionparser_add_l(this, short_opt, long_opt, dest, help)
2596TYPE(optionparser),INTENT(inout) :: this
2597CHARACTER(len=*),INTENT(in) :: short_opt
2598CHARACTER(len=*),INTENT(in) :: long_opt
2599LOGICAL,TARGET :: dest
2600CHARACTER(len=*),OPTIONAL :: help
2601
2602INTEGER :: i
2603TYPE(option) :: myoption
2604
2605! common initialisation
2606myoption = option_new(short_opt, long_opt, '', help)
2607IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2608
2609myoption%destl => dest
2610myoption%destl = .false. ! unconditionally set to false, option can only set it to true
2611myoption%opttype = opttype_l
2612myoption%need_arg = 0
2613
2614i = arrayof_option_append(this%options, myoption)
2615
2616END SUBROUTINE optionparser_add_l
2617
2618
2623SUBROUTINE optionparser_add_count(this, short_opt, long_opt, dest, start, help)
2624TYPE(optionparser),INTENT(inout) :: this
2625CHARACTER(len=*),INTENT(in) :: short_opt
2626CHARACTER(len=*),INTENT(in) :: long_opt
2627INTEGER,TARGET :: dest
2628INTEGER,OPTIONAL :: start
2629CHARACTER(len=*),OPTIONAL :: help
2630
2631INTEGER :: i
2632TYPE(option) :: myoption
2633
2634! common initialisation
2635myoption = option_new(short_opt, long_opt, '', help)
2636IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2637
2638myoption%destcount => dest
2639IF (PRESENT(start)) myoption%destcount = start
2640myoption%opttype = opttype_count
2641myoption%need_arg = 0
2642
2643i = arrayof_option_append(this%options, myoption)
2644
2645END SUBROUTINE optionparser_add_count
2646
2647
2662SUBROUTINE optionparser_add_help(this, short_opt, long_opt, help)
2663TYPE(optionparser),INTENT(inout) :: this
2664CHARACTER(len=*),INTENT(in) :: short_opt
2665CHARACTER(len=*),INTENT(in) :: long_opt
2666CHARACTER(len=*),OPTIONAL :: help
2667
2668INTEGER :: i
2669TYPE(option) :: myoption
2670
2671! common initialisation
2672myoption = option_new(short_opt, long_opt, '', help)
2673IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2674
2675myoption%opttype = opttype_help
2676myoption%need_arg = 1
2677
2678i = arrayof_option_append(this%options, myoption)
2679
2680END SUBROUTINE optionparser_add_help
2681
2682
2693SUBROUTINE optionparser_add_sep(this, help)
2694TYPE(optionparser),INTENT(inout) :: this
2695!CHARACTER(len=*),INTENT(in) :: short_opt !< the short option (may be empty)
2696!CHARACTER(len=*),INTENT(in) :: long_opt !< the long option (may be empty)
2697CHARACTER(len=*) :: help
2698
2699INTEGER :: i
2700TYPE(option) :: myoption
2701
2702! common initialisation
2703myoption = option_new('_', '_', '', help)
2704IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2705
2706myoption%opttype = opttype_sep
2707myoption%need_arg = 0
2708
2709i = arrayof_option_append(this%options, myoption)
2710
2711END SUBROUTINE optionparser_add_sep
2712
2713
2723SUBROUTINE optionparser_parse(this, nextarg, status)
2724TYPE(optionparser),INTENT(inout) :: this
2725INTEGER,INTENT(out) :: nextarg
2726INTEGER,INTENT(out) :: status
2727
2728INTEGER :: i, j, endopt, indeq, iargc
2729CHARACTER(len=16384) :: arg, optarg
2730
2731status = optionparser_ok
2732i = 1
2733DO WHILE(i <= iargc())
2734 CALL getarg(i, arg)
2735 IF (arg == '--') THEN ! explicit end of options
2736 i = i + 1 ! skip present option (--)
2737 EXIT
2738 ELSE IF (arg == '-') THEN ! a single - is not an option
2739 EXIT
2740 ELSE IF (arg(1:2) == '--') THEN ! long option
2742 IF (indeq /= 0) THEN ! = present
2743 endopt = indeq - 1
2744 ELSE ! no =
2745 endopt = len_trim(arg)
2746 ENDIF
2747 find_longopt: DO j = 1, this%options%arraysize
2748 IF (this%options%array(j)%long_opt == arg(3:endopt)) THEN ! found option
2749 SELECT CASE(this%options%array(j)%need_arg)
2750 CASE(2) ! compulsory
2751 IF (indeq /= 0) THEN
2752 optarg = arg(indeq+1:)
2753 status = max(option_found(this%options%array(j), optarg), &
2754 status)
2755 ELSE
2756 IF (i < iargc()) THEN
2757 i=i+1
2758 CALL getarg(i, optarg)
2759 status = max(option_found(this%options%array(j), optarg), &
2760 status)
2761 ELSE
2762 status = optionparser_err
2763 CALL l4f_log(l4f_error, &
2764 'in optionparser, option '''//trim(arg)//''' requires an argument')
2765 ENDIF
2766 ENDIF
2767 CASE(1) ! optional
2768 IF (indeq /= 0) THEN
2769 optarg = arg(indeq+1:)
2770 ELSE
2771 IF (i < iargc()) THEN
2772 CALL getarg(i+1, optarg)
2773 IF (optarg(1:1) == '-') THEN
2774 optarg = cmiss ! refused
2775 ELSE
2776 i=i+1 ! accepted
2777 ENDIF
2778 ELSE
2779 optarg = cmiss ! refused
2780 ENDIF
2781 ENDIF
2782 status = max(option_found(this%options%array(j), optarg), &
2783 status)
2784 CASE(0)
2785 status = max(option_found(this%options%array(j)), &
2786 status)
2787 END SELECT
2788 EXIT find_longopt
2789 ENDIF
2790 ENDDO find_longopt
2791 IF (j > this%options%arraysize) THEN
2792 status = optionparser_err
2793 CALL l4f_log(l4f_error, &
2794 'in optionparser, option '''//trim(arg)//''' not valid')
2795 ENDIF
2796 ELSE IF (arg(1:1) == '-') THEN ! short option
2797 find_shortopt: DO j = 1, this%options%arraysize
2798 IF (this%options%array(j)%short_opt == arg(2:2)) THEN ! found option
2799 SELECT CASE(this%options%array(j)%need_arg)
2800 CASE(2) ! compulsory
2801 IF (len_trim(arg) > 2) THEN
2802 optarg = arg(3:)
2803 status = max(option_found(this%options%array(j), optarg), &
2804 status)
2805 ELSE
2806 IF (i < iargc()) THEN
2807 i=i+1
2808 CALL getarg(i, optarg)
2809 status = max(option_found(this%options%array(j), optarg), &
2810 status)
2811 ELSE
2812 status = optionparser_err
2813 CALL l4f_log(l4f_error, &
2814 'in optionparser, option '''//trim(arg)//''' requires an argument')
2815 ENDIF
2816 ENDIF
2817 CASE(1) ! optional
2818 IF (len_trim(arg) > 2) THEN
2819 optarg = arg(3:)
2820 ELSE
2821 IF (i < iargc()) THEN
2822 CALL getarg(i+1, optarg)
2823 IF (optarg(1:1) == '-') THEN
2824 optarg = cmiss ! refused
2825 ELSE
2826 i=i+1 ! accepted
2827 ENDIF
2828 ELSE
2829 optarg = cmiss ! refused
2830 ENDIF
2831 ENDIF
2832 status = max(option_found(this%options%array(j), optarg), &
2833 status)
2834 CASE(0)
2835 status = max(option_found(this%options%array(j)), &
2836 status)
2837 END SELECT
2838 EXIT find_shortopt
2839 ENDIF
2840 ENDDO find_shortopt
2841 IF (j > this%options%arraysize) THEN
2842 status = optionparser_err
2843 CALL l4f_log(l4f_error, &
2844 'in optionparser, option '''//trim(arg)//''' not valid')
2845 ENDIF
2846 ELSE ! unrecognized = end of options
2847 EXIT
2848 ENDIF
2849 i = i + 1
2850ENDDO
2851
2852nextarg = i
2853SELECT CASE(status)
2854CASE(optionparser_err, optionparser_help)
2855 CALL optionparser_printhelp(this)
2856END SELECT
2857
2858END SUBROUTINE optionparser_parse
2859
2860
2864SUBROUTINE optionparser_printhelp(this)
2865TYPE(optionparser),INTENT(in) :: this
2866
2867INTEGER :: i, form
2868
2869form = 0
2870DO i = 1, this%options%arraysize ! loop over options
2871 IF (this%options%array(i)%opttype == opttype_help) THEN
2872 form = this%options%array(i)%helpformat
2873 ENDIF
2874ENDDO
2875
2876SELECT CASE(form)
2877CASE(0)
2878 CALL optionparser_printhelptxt(this)
2879CASE(1)
2880 CALL optionparser_printhelpmd(this)
2881CASE(2)
2882 CALL optionparser_printhelphtmlform(this)
2883END SELECT
2884
2885END SUBROUTINE optionparser_printhelp
2886
2887
2891SUBROUTINE optionparser_printhelptxt(this)
2892TYPE(optionparser),INTENT(in) :: this
2893
2894INTEGER :: i, j, ncols
2895CHARACTER(len=80) :: buf
2896TYPE(line_split) :: help_line
2897
2898ncols = default_columns()
2899
2900! print usage message
2901IF (ASSOCIATED(this%usage_msg)) THEN
2902 help_line = line_split_new(cstr_to_fchar(this%usage_msg), ncols)
2903 DO j = 1, line_split_get_nlines(help_line)
2904 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2905 ENDDO
2907ELSE
2908 CALL getarg(0, buf)
2910 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2911 WRITE(*,'(A)')'Usage: '//trim(buf(i+1:))//' [options] [arguments]'
2912ENDIF
2913
2914! print description message
2915IF (ASSOCIATED(this%description_msg)) THEN
2916 WRITE(*,'()')
2917 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2918 DO j = 1, line_split_get_nlines(help_line)
2919 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2920 ENDDO
2922ENDIF
2923
2924WRITE(*,'(/,A)')'Options:'
2925
2926DO i = 1, this%options%arraysize ! loop over options
2927 CALL option_format_help(this%options%array(i), ncols)
2928ENDDO
2929
2930END SUBROUTINE optionparser_printhelptxt
2931
2932
2936SUBROUTINE optionparser_printhelpmd(this)
2937TYPE(optionparser),INTENT(in) :: this
2938
2939INTEGER :: i, j, ncols
2940CHARACTER(len=80) :: buf
2941TYPE(line_split) :: help_line
2942
2943ncols = default_columns()
2944
2945! print usage message
2946WRITE(*,'(A)')'### Synopsis'
2947
2948IF (ASSOCIATED(this%usage_msg)) THEN
2949 help_line = line_split_new(mdquote_usage_msg(cstr_to_fchar(this%usage_msg)), ncols)
2950 DO j = 1, line_split_get_nlines(help_line)
2951 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2952 ENDDO
2954ELSE
2955 CALL getarg(0, buf)
2957 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2958 WRITE(*,'(A)')'Usage: `'//trim(buf(i+1:))//' [options] [arguments]`'
2959ENDIF
2960
2961! print description message
2962IF (ASSOCIATED(this%description_msg)) THEN
2963 WRITE(*,'()')
2964 WRITE(*,'(A)')'### Description'
2965 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2966 DO j = 1, line_split_get_nlines(help_line)
2967 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2968 ENDDO
2970
2971ENDIF
2972
2973WRITE(*,'(/,A)')'### Options'
2974
2975DO i = 1, this%options%arraysize ! loop over options
2976 CALL option_format_md(this%options%array(i), ncols)
2977ENDDO
2978
2979CONTAINS
2980
2981FUNCTION mdquote_usage_msg(usage_msg)
2982CHARACTER(len=*),INTENT(in) :: usage_msg
2983
2984CHARACTER(len=LEN(usage_msg)+2) :: mdquote_usage_msg
2985INTEGER :: colon
2986
2988IF (colon > 0 .AND. colon < len(usage_msg)-1) THEN
2989 mdquote_usage_msg = usage_msg(:colon+1)//'`'//usage_msg(colon+2:)//'`'
2990ELSE
2991 mdquote_usage_msg = usage_msg
2992ENDIF
2993
2994END FUNCTION mdquote_usage_msg
2995
2996END SUBROUTINE optionparser_printhelpmd
2997
3001SUBROUTINE optionparser_printhelphtmlform(this)
3002TYPE(optionparser),INTENT(in) :: this
3003
3004INTEGER :: i
3005
3006DO i = 1, this%options%arraysize ! loop over options
3007 CALL option_format_htmlform(this%options%array(i))
3008ENDDO
3009
3010WRITE(*,'(A)')'<input class="libsim_sub" type="submit" value="runprogram" />'
3011
3012END SUBROUTINE optionparser_printhelphtmlform
3013
3014
3015SUBROUTINE optionparser_make_completion(this)
3016TYPE(optionparser),INTENT(in) :: this
3017
3018INTEGER :: i
3019CHARACTER(len=512) :: buf
3020
3021CALL getarg(0, buf)
3022
3023WRITE(*,'(A/A/A)')'_'//trim(buf)//'()','{','local cur'
3024
3025WRITE(*,'(A/A/A/A)')'COMPREPLY=()','cur=${COMP_WORDS[COMP_CWORD]}', &
3026 'case "$cur" in','-*)'
3027
3028!-*)
3029! COMPREPLY=( $( compgen -W
3030DO i = 1, this%options%arraysize ! loop over options
3031 IF (this%options%array(i)%need_arg == 2) THEN
3032 ENDIF
3033ENDDO
3034
3035WRITE(*,'(A/A/A)')'esac','return 0','}'
3036
3037END SUBROUTINE optionparser_make_completion
3038
3039
3040SUBROUTINE dirty_char_assignment(destc, destclen, src)
3042IMPLICIT NONE
3043
3044CHARACTER(len=1) :: destc(*)
3045CHARACTER(len=*) :: src
3046INTEGER :: destclen
3047
3048INTEGER :: i
3049
3050DO i = 1, min(destclen, len(src))
3051 destc(i) = src(i:i)
3052ENDDO
3053DO i = len(src)+1, destclen
3054 destc(i) = ' '
3055ENDDO
3056
3057END SUBROUTINE dirty_char_assignment
3058
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 |