libsim Versione 7.1.11
|
◆ optionparser_add_sep()
Add a new separator option, with a text. This is a dummy option that inserts a separator line with a text within the list of options when the help is printed. It is useful to insert a visual separator between options or an explanation which is not associated with a specific options but applies to all the subsequent options. The text provided will be formatted into many lines if necessary. Any number of separator options can be added within the option list; they have no effect on the interpretation of the options associated with the optionparser object.
Definizione alla linea 1502 del file optionparser_class.F90. 1503! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1504! authors:
1505! Davide Cesari <dcesari@arpa.emr.it>
1506! Paolo Patruno <ppatruno@arpa.emr.it>
1507
1508! This program is free software; you can redistribute it and/or
1509! modify it under the terms of the GNU General Public License as
1510! published by the Free Software Foundation; either version 2 of
1511! the License, or (at your option) any later version.
1512
1513! This program is distributed in the hope that it will be useful,
1514! but WITHOUT ANY WARRANTY; without even the implied warranty of
1515! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1516! GNU General Public License for more details.
1526#include "config.h"
1527
1535IMPLICIT NONE
1536
1537
1538! private class
1539TYPE option
1540 CHARACTER(len=1) :: short_opt=''
1541 CHARACTER(len=80) :: long_opt=''
1542 INTEGER :: opttype=-1
1543 INTEGER :: need_arg=0 ! 0=no, 1=optional, 2=yes, was .FALSE.
1544 LOGICAL :: has_default=.false.
1545 CHARACTER(len=1),POINTER :: destc=>null()
1546 INTEGER :: destclen=0
1547 INTEGER :: helpformat=0 ! 0=txt, 1=markdown, 2=htmlform, improve!
1548 INTEGER,POINTER :: desti=>null()
1549 TYPE(arrayof_integer),POINTER :: destiarr=>null()
1550 REAL,POINTER :: destr=>null()
1551 TYPE(arrayof_real),POINTER :: destrarr=>null()
1552 DOUBLE PRECISION, POINTER :: destd=>null()
1553 TYPE(arrayof_doubleprecision),POINTER :: destdarr=>null()
1554 LOGICAL,POINTER :: destl=>null()
1555 TYPE(arrayof_logical),POINTER :: destlarr=>null()
1556 INTEGER,POINTER :: destcount=>null()
1557 INTEGER(kind=int_b),ALLOCATABLE :: help_msg(:)
1558END TYPE option
1559
1560#define ARRAYOF_ORIGTYPE TYPE(option)
1561#define ARRAYOF_TYPE arrayof_option
1562#define ARRAYOF_ORIGDESTRUCTOR(x) CALL option_delete(x)
1563#define ARRAYOF_PRIVATE 1
1564#include "arrayof_pre_nodoc.F90"
1565! from arrayof
1566!PUBLIC insert, append, remove, packarray
1567!PUBLIC insert_unique, append_unique
1568
1647 PRIVATE
1648 INTEGER(kind=int_b),POINTER :: usage_msg(:), description_msg(:)
1649 TYPE(arrayof_option) :: options
1650 LOGICAL :: httpmode=.false.
1652
1653
1658 MODULE PROCEDURE optionparser_add_c, optionparser_add_i, optionparser_add_r, &
1659 optionparser_add_d, optionparser_add_l, &
1660 optionparser_add_iarray, optionparser_add_rarray, optionparser_add_darray
1661END INTERFACE
1662
1663INTERFACE c_e
1664 MODULE PROCEDURE option_c_e
1665END INTERFACE
1666
1675 MODULE PROCEDURE optionparser_delete!?, option_delete
1676END INTERFACE
1677
1678
1679INTEGER,PARAMETER :: opttype_c = 1, opttype_i = 2, opttype_r = 3, &
1680 opttype_d = 4, opttype_l = 5, opttype_count = 6, opttype_help = 7, &
1681 opttype_sep = 8, opttype_carr = 11, opttype_iarr = 12, opttype_rarr = 13, &
1682 opttype_darr = 14, opttype_larr = 15
1683
1684INTEGER,PARAMETER :: optionparser_ok = 0
1685INTEGER,PARAMETER :: optionparser_help = 1
1686INTEGER,PARAMETER :: optionparser_err = 2
1687
1688
1689PRIVATE
1691 optionparser_add_count, optionparser_add_help, optionparser_add_sep, &
1692 optionparser_parse, optionparser_printhelp, &
1693 optionparser_ok, optionparser_help, optionparser_err
1694
1695
1696CONTAINS
1697
1698#include "arrayof_post_nodoc.F90"
1699
1700! Constructor for the option class
1701FUNCTION option_new(short_opt, long_opt, default, help) RESULT(this)
1702CHARACTER(len=*),INTENT(in) :: short_opt
1703CHARACTER(len=*),INTENT(in) :: long_opt
1704CHARACTER(len=*),INTENT(in) :: default
1705CHARACTER(len=*),OPTIONAL :: help
1706TYPE(option) :: this
1707
1708IF (short_opt == '' .AND. long_opt == '') THEN
1709#ifdef DEBUG
1710! programmer error condition, option empty
1711 CALL l4f_log(l4f_error, 'in optionparser, both short and long options empty')
1712 CALL raise_fatal_error()
1713#else
1714 CALL l4f_log(l4f_warn, 'in optionparser, both short and long options empty')
1715#endif
1716 RETURN
1717ENDIF
1718
1719this%short_opt = short_opt
1720this%long_opt = long_opt
1721IF (PRESENT(help)) THEN
1722 this%help_msg = fchar_to_cstr(trim(help)//trim(default)) ! f2003 automatic alloc
1723ENDIF
1724this%has_default = (len_trim(default) > 0)
1725
1726END FUNCTION option_new
1727
1728
1729! Destructor for the \a option class, the memory associated with
1730! the object is freed.
1731SUBROUTINE option_delete(this)
1732TYPE(option),INTENT(inout) :: this ! object to destroy
1733
1734IF (ALLOCATED(this%help_msg)) DEALLOCATE(this%help_msg)
1735NULLIFY(this%destc)
1736NULLIFY(this%desti)
1737NULLIFY(this%destr)
1738NULLIFY(this%destd)
1739NULLIFY(this%destl)
1740NULLIFY(this%destcount)
1741
1742END SUBROUTINE option_delete
1743
1744
1745FUNCTION option_found(this, optarg) RESULT(status)
1746TYPE(option),INTENT(inout) :: this
1747CHARACTER(len=*),INTENT(in),OPTIONAL :: optarg
1748INTEGER :: status
1749
1750TYPE(csv_record) :: arrparser
1751INTEGER :: ibuff
1752REAL :: rbuff
1753DOUBLE PRECISION :: dbuff
1754
1755status = optionparser_ok
1756
1757SELECT CASE(this%opttype)
1758CASE(opttype_c)
1759 CALL dirty_char_assignment(this%destc, this%destclen, trim(optarg))
1760! this%destc(1:this%destclen) = optarg
1761 IF (len_trim(optarg) > this%destclen) THEN
1762 CALL l4f_log(l4f_warn, &
1763 'in optionparser, argument '''//trim(optarg)//''' too long, truncated')
1764 ENDIF
1765CASE(opttype_i)
1766 READ(optarg,'(I12)',err=100)this%desti
1767CASE(opttype_iarr)
1770 DO WHILE(.NOT.csv_record_end(arrparser))
1772 CALL insert(this%destiarr, ibuff)
1773 ENDDO
1774 CALL packarray(this%destiarr)
1776CASE(opttype_r)
1777 READ(optarg,'(F20.0)',err=102)this%destr
1778CASE(opttype_rarr)
1781 DO WHILE(.NOT.csv_record_end(arrparser))
1783 CALL insert(this%destrarr, rbuff)
1784 ENDDO
1785 CALL packarray(this%destrarr)
1787CASE(opttype_d)
1788 READ(optarg,'(F20.0)',err=102)this%destd
1789CASE(opttype_darr)
1792 DO WHILE(.NOT.csv_record_end(arrparser))
1794 CALL insert(this%destdarr, dbuff)
1795 ENDDO
1796 CALL packarray(this%destdarr)
1798CASE(opttype_l)
1799 this%destl = .true.
1800CASE(opttype_count)
1801 this%destcount = this%destcount + 1
1802CASE(opttype_help)
1803 status = optionparser_help
1804 SELECT CASE(optarg) ! set help format
1805 CASE('md', 'markdown')
1806 this%helpformat = 1
1807 CASE('htmlform')
1808 this%helpformat = 2
1809 END SELECT
1810END SELECT
1811
1812RETURN
1813
1814100 status = optionparser_err
1815CALL l4f_log(l4f_error, &
1816 'in optionparser, argument '''//trim(optarg)//''' not valid as integer')
1817RETURN
1818102 status = optionparser_err
1819CALL l4f_log(l4f_error, &
1820 'in optionparser, argument '''//trim(optarg)//''' not valid as real')
1821RETURN
1822
1823END FUNCTION option_found
1824
1825
1826! Return a string which gives a short representation of the
1827! option \a this, without help message. The resulting string is quite
1828! long and it should be trimmed with the \a TRIM() intrinsic
1829! function.
1830FUNCTION option_format_opt(this) RESULT(format_opt)
1831TYPE(option),INTENT(in) :: this
1832
1833CHARACTER(len=100) :: format_opt
1834
1835CHARACTER(len=20) :: argname
1836
1837SELECT CASE(this%opttype)
1838CASE(opttype_c)
1839 argname = 'STRING'
1840CASE(opttype_i)
1841 argname = 'INT'
1842CASE(opttype_iarr)
1843 argname = 'INT[,INT...]'
1844CASE(opttype_r, opttype_d)
1845 argname = 'REAL'
1846CASE(opttype_rarr, opttype_darr)
1847 argname = 'REAL[,REAL...]'
1848CASE default
1849 argname = ''
1850END SELECT
1851
1852format_opt = ''
1853IF (this%short_opt /= '') THEN
1854 format_opt(len_trim(format_opt)+1:) = ' -'//this%short_opt
1855 IF (argname /= '') THEN
1856 format_opt(len_trim(format_opt)+1:) = ' '//trim(argname)
1857 ENDIF
1858ENDIF
1859IF (this%short_opt /= '' .AND. this%long_opt /= '') THEN
1860 format_opt(len_trim(format_opt)+1:) = ','
1861ENDIF
1862IF (this%long_opt /= '') THEN
1863 format_opt(len_trim(format_opt)+1:) = ' --'//this%long_opt
1864 IF (argname /= '') THEN
1865 format_opt(len_trim(format_opt)+1:) = '='//trim(argname)
1866 ENDIF
1867ENDIF
1868
1869END FUNCTION option_format_opt
1870
1871
1872! print on stdout a human-readable text representation of a single option
1873SUBROUTINE option_format_help(this, ncols)
1874TYPE(option),INTENT(in) :: this
1875INTEGER,INTENT(in) :: ncols
1876
1877INTEGER :: j
1878INTEGER, PARAMETER :: indent = 10
1879TYPE(line_split) :: help_line
1880
1881
1882IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
1883 IF (ALLOCATED(this%help_msg)) THEN
1884! help2man is quite picky about the treatment of arbitrary lines
1885! within options, the only universal way seems to be unindented lines
1886! with an empty line before and after
1887 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
1888 WRITE(*,'()')
1889 DO j = 1, line_split_get_nlines(help_line)
1890 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1891 ENDDO
1893 WRITE(*,'()')
1894 ENDIF
1895ELSE ! ordinary option
1896! print option brief representation
1897 WRITE(*,'(A)')trim(option_format_opt(this))
1898! print option help
1899 IF (ALLOCATED(this%help_msg)) THEN
1900 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
1901 DO j = 1, line_split_get_nlines(help_line)
1902 WRITE(*,'(T10,A)')trim(line_split_get_line(help_line,j))
1903 ENDDO
1905 ENDIF
1906ENDIF
1907
1908END SUBROUTINE option_format_help
1909
1910
1911! print on stdout a markdown representation of a single option
1912SUBROUTINE option_format_md(this, ncols)
1913TYPE(option),INTENT(in) :: this
1914INTEGER,INTENT(in) :: ncols
1915
1916INTEGER :: j
1917INTEGER, PARAMETER :: indent = 2
1918TYPE(line_split) :: help_line
1919
1920IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
1921 IF (ALLOCATED(this%help_msg)) THEN
1922 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
1923 WRITE(*,'()')
1924 DO j = 1, line_split_get_nlines(help_line)
1925 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1926 ENDDO
1928 WRITE(*,'()')
1929 ENDIF
1930ELSE ! ordinary option
1931! print option brief representation
1932 WRITE(*,'(''`'',A,''`'')')trim(option_format_opt(this))
1933! print option help
1934 IF (ALLOCATED(this%help_msg)) THEN
1935 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
1936 DO j = 1, line_split_get_nlines(help_line)
1937 WRITE(*,'(''> '',A)')trim(line_split_get_line(help_line,j))
1938 ENDDO
1940 WRITE(*,'()')
1941 ENDIF
1942ENDIF
1943
1944END SUBROUTINE option_format_md
1945
1946
1947! print on stdout an html form representation of a single option
1948SUBROUTINE option_format_htmlform(this)
1949TYPE(option),INTENT(in) :: this
1950
1951CHARACTER(len=80) :: opt_name, opt_id, opt_default ! check len of default
1952
1953IF (.NOT.c_e(this)) RETURN
1954IF (this%long_opt == '') THEN
1955 opt_name = this%short_opt
1956 opt_id = 'short_opt_'//this%short_opt
1957ELSE
1958 opt_name = this%long_opt
1959 opt_id = this%long_opt
1960ENDIF
1961
1962SELECT CASE(this%opttype)
1963CASE(opttype_c)
1964 CALL option_format_html_openspan('text')
1965
1966 IF (this%has_default .AND. ASSOCIATED(this%destc) .AND. this%destclen > 0) THEN
1967! opt_default = TRANSFER(this%destc(1:MIN(LEN(opt_default),this%destclen)), &
1968! opt_default) ! improve
1969 opt_default = ''
1970 WRITE(*,'(A)')' value="'//trim(opt_default)//'"'
1971 ENDIF
1972 CALL option_format_html_help()
1973 CALL option_format_html_closespan()
1974
1975CASE(opttype_i,opttype_r,opttype_d)
1976 CALL option_format_html_openspan('text')
1977 IF (this%has_default) THEN
1978 SELECT CASE(this%opttype)
1979 CASE(opttype_i)
1981! todo CASE(opttype_iarr)
1982 CASE(opttype_r)
1984 CASE(opttype_d)
1986 END SELECT
1987 ENDIF
1988 CALL option_format_html_help()
1989 CALL option_format_html_closespan()
1990
1991! todo CASE(opttype_iarr)
1992
1993CASE(opttype_l)
1994 CALL option_format_html_openspan('checkbox')
1995 CALL option_format_html_help()
1996 CALL option_format_html_closespan()
1997
1998CASE(opttype_count)
1999 CALL option_format_html_openspan('number')
2000 CALL option_format_html_help()
2001 CALL option_format_html_closespan()
2002
2003CASE(opttype_sep)
2004END SELECT
2005
2006
2007CONTAINS
2008
2009SUBROUTINE option_format_html_openspan(formtype)
2010CHARACTER(len=*),INTENT(in) :: formtype
2011
2012WRITE(*,'(A)')'<span class="libsim_optbox" id="span_'//trim(opt_id)//'">'//trim(opt_name)//':'
2013! size=? maxlen=?
2014WRITE(*,'(A)')'<input class_"libsim_opt" id="'//trim(opt_id)//'" type="'//formtype// &
2015 '" name="'//trim(opt_id)//'" '
2016
2017END SUBROUTINE option_format_html_openspan
2018
2019SUBROUTINE option_format_html_closespan()
2020
2021WRITE(*,'(A)')'/></span>'
2022
2023END SUBROUTINE option_format_html_closespan
2024
2025SUBROUTINE option_format_html_help()
2026INTEGER :: j
2027TYPE(line_split) :: help_line
2028CHARACTER(len=20) :: form
2029
2030IF (ALLOCATED(this%help_msg)) THEN
2031 WRITE(*,'(A,$)')' title="'
2032
2033 help_line = line_split_new(cstr_to_fchar(this%help_msg), 80)
2034 form = '(A,'' '')'
2035 DO j = 1, line_split_get_nlines(help_line)
2036 IF (j == line_split_get_nlines(help_line)) form = '(A,''"'',$)'
2037 WRITE(*,form)trim(line_split_get_line(help_line,j)) ! lines should be properly quoted here
2038 ENDDO
2039
2040ENDIF
2041
2042END SUBROUTINE option_format_html_help
2043
2044END SUBROUTINE option_format_htmlform
2045
2046
2047FUNCTION option_c_e(this) RESULT(c_e)
2048TYPE(option),INTENT(in) :: this
2049
2050LOGICAL :: c_e
2051
2052c_e = this%long_opt /= ' ' .OR. this%short_opt /= ' '
2053
2054END FUNCTION option_c_e
2055
2056
2060FUNCTION optionparser_new(usage_msg, description_msg) RESULT(this)
2061CHARACTER(len=*), INTENT(in), OPTIONAL :: usage_msg
2062CHARACTER(len=*), INTENT(in), OPTIONAL :: description_msg
2063
2064TYPE(optionparser) :: this
2065
2066IF (PRESENT(usage_msg)) THEN
2067 CALL fchar_to_cstr_alloc(trim(usage_msg), this%usage_msg)
2068ELSE
2069 NULLIFY(this%usage_msg)
2070ENDIF
2071IF (PRESENT(description_msg)) THEN
2072 CALL fchar_to_cstr_alloc(trim(description_msg), this%description_msg)
2073ELSE
2074 NULLIFY(this%description_msg)
2075ENDIF
2076
2077END FUNCTION optionparser_new
2078
2079
2080SUBROUTINE optionparser_delete(this)
2081TYPE(optionparser),INTENT(inout) :: this
2082
2083IF (ASSOCIATED(this%usage_msg)) DEALLOCATE(this%usage_msg)
2084IF (ASSOCIATED(this%description_msg)) DEALLOCATE(this%description_msg)
2086
2087END SUBROUTINE optionparser_delete
2088
2089
2097SUBROUTINE optionparser_add_c(this, short_opt, long_opt, dest, default, help, isopt)
2098TYPE(optionparser),INTENT(inout) :: this
2099CHARACTER(len=*),INTENT(in) :: short_opt
2100CHARACTER(len=*),INTENT(in) :: long_opt
2101CHARACTER(len=*),TARGET :: dest
2102CHARACTER(len=*),OPTIONAL :: default
2103CHARACTER(len=*),OPTIONAL :: help
2104LOGICAL,INTENT(in),OPTIONAL :: isopt
2105
2106CHARACTER(LEN=60) :: cdefault
2107INTEGER :: i
2108TYPE(option) :: myoption
2109
2110
2111IF (PRESENT(default)) THEN
2113ELSE
2114 cdefault = ''
2115ENDIF
2116
2117! common initialisation
2118myoption = option_new(short_opt, long_opt, cdefault, help)
2119IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2120
2121myoption%destc => dest(1:1)
2122myoption%destclen = len(dest) ! needed to avoid exceeding the length of dest
2123IF (PRESENT(default)) &
2124 CALL dirty_char_assignment(myoption%destc, myoption%destclen, default)
2125!IF (PRESENT(default)) myoption%destc(1:myoption%destclen) = default
2126myoption%opttype = opttype_c
2127IF (optio_log(isopt)) THEN
2128 myoption%need_arg = 1
2129ELSE
2130 myoption%need_arg = 2
2131ENDIF
2132
2133i = arrayof_option_append(this%options, myoption)
2134
2135END SUBROUTINE optionparser_add_c
2136
2137
2144SUBROUTINE optionparser_add_i(this, short_opt, long_opt, dest, default, help)
2145TYPE(optionparser),INTENT(inout) :: this
2146CHARACTER(len=*),INTENT(in) :: short_opt
2147CHARACTER(len=*),INTENT(in) :: long_opt
2148INTEGER,TARGET :: dest
2149INTEGER,OPTIONAL :: default
2150CHARACTER(len=*),OPTIONAL :: help
2151
2152CHARACTER(LEN=40) :: cdefault
2153INTEGER :: i
2154TYPE(option) :: myoption
2155
2156IF (PRESENT(default)) THEN
2158ELSE
2159 cdefault = ''
2160ENDIF
2161
2162! common initialisation
2163myoption = option_new(short_opt, long_opt, cdefault, help)
2164IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2165
2166myoption%desti => dest
2167IF (PRESENT(default)) myoption%desti = default
2168myoption%opttype = opttype_i
2169myoption%need_arg = 2
2170
2171i = arrayof_option_append(this%options, myoption)
2172
2173END SUBROUTINE optionparser_add_i
2174
2175
2185SUBROUTINE optionparser_add_iarray(this, short_opt, long_opt, dest, default, help)
2186TYPE(optionparser),INTENT(inout) :: this
2187CHARACTER(len=*),INTENT(in) :: short_opt
2188CHARACTER(len=*),INTENT(in) :: long_opt
2189TYPE(arrayof_integer),TARGET :: dest
2190INTEGER,OPTIONAL :: default(:)
2191CHARACTER(len=*),OPTIONAL :: help
2192
2193CHARACTER(LEN=40) :: cdefault
2194INTEGER :: i
2195TYPE(option) :: myoption
2196
2197cdefault = ''
2198IF (PRESENT(default)) THEN
2199 IF (SIZE(default) == 1) THEN
2201 ELSE IF (SIZE(default) > 1) THEN
2203 ENDIF
2204ENDIF
2205
2206! common initialisation
2207myoption = option_new(short_opt, long_opt, cdefault, help)
2208IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2209
2210myoption%destiarr => dest
2211IF (PRESENT(default)) THEN
2212 CALL insert(myoption%destiarr, default)
2213 CALL packarray(myoption%destiarr)
2214ENDIF
2215myoption%opttype = opttype_iarr
2216myoption%need_arg = 2
2217
2218i = arrayof_option_append(this%options, myoption)
2219
2220END SUBROUTINE optionparser_add_iarray
2221
2222
2229SUBROUTINE optionparser_add_r(this, short_opt, long_opt, dest, default, help)
2230TYPE(optionparser),INTENT(inout) :: this
2231CHARACTER(len=*),INTENT(in) :: short_opt
2232CHARACTER(len=*),INTENT(in) :: long_opt
2233REAL,TARGET :: dest
2234REAL,OPTIONAL :: default
2235CHARACTER(len=*),OPTIONAL :: help
2236
2237CHARACTER(LEN=40) :: cdefault
2238INTEGER :: i
2239TYPE(option) :: myoption
2240
2241IF (PRESENT(default)) THEN
2243ELSE
2244 cdefault = ''
2245ENDIF
2246
2247! common initialisation
2248myoption = option_new(short_opt, long_opt, cdefault, help)
2249IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2250
2251myoption%destr => dest
2252IF (PRESENT(default)) myoption%destr = default
2253myoption%opttype = opttype_r
2254myoption%need_arg = 2
2255
2256i = arrayof_option_append(this%options, myoption)
2257
2258END SUBROUTINE optionparser_add_r
2259
2260
2270SUBROUTINE optionparser_add_rarray(this, short_opt, long_opt, dest, default, help)
2271TYPE(optionparser),INTENT(inout) :: this
2272CHARACTER(len=*),INTENT(in) :: short_opt
2273CHARACTER(len=*),INTENT(in) :: long_opt
2274TYPE(arrayof_real),TARGET :: dest
2275REAL,OPTIONAL :: default(:)
2276CHARACTER(len=*),OPTIONAL :: help
2277
2278CHARACTER(LEN=40) :: cdefault
2279INTEGER :: i
2280TYPE(option) :: myoption
2281
2282cdefault = ''
2283IF (PRESENT(default)) THEN
2284 IF (SIZE(default) == 1) THEN
2286 ELSE IF (SIZE(default) > 1) THEN
2288 ENDIF
2289ENDIF
2290
2291! common initialisation
2292myoption = option_new(short_opt, long_opt, cdefault, help)
2293IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2294
2295myoption%destrarr => dest
2296IF (PRESENT(default)) THEN
2297 CALL insert(myoption%destrarr, default)
2298 CALL packarray(myoption%destrarr)
2299ENDIF
2300myoption%opttype = opttype_rarr
2301myoption%need_arg = 2
2302
2303i = arrayof_option_append(this%options, myoption)
2304
2305END SUBROUTINE optionparser_add_rarray
2306
2307
2314SUBROUTINE optionparser_add_d(this, short_opt, long_opt, dest, default, help)
2315TYPE(optionparser),INTENT(inout) :: this
2316CHARACTER(len=*),INTENT(in) :: short_opt
2317CHARACTER(len=*),INTENT(in) :: long_opt
2318DOUBLE PRECISION,TARGET :: dest
2319DOUBLE PRECISION,OPTIONAL :: default
2320CHARACTER(len=*),OPTIONAL :: help
2321
2322CHARACTER(LEN=40) :: cdefault
2323INTEGER :: i
2324TYPE(option) :: myoption
2325
2326IF (PRESENT(default)) THEN
2327 IF (c_e(default)) THEN
2329 ELSE
2331 ENDIF
2332ELSE
2333 cdefault = ''
2334ENDIF
2335
2336! common initialisation
2337myoption = option_new(short_opt, long_opt, cdefault, help)
2338IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2339
2340myoption%destd => dest
2341IF (PRESENT(default)) myoption%destd = default
2342myoption%opttype = opttype_d
2343myoption%need_arg = 2
2344
2345i = arrayof_option_append(this%options, myoption)
2346
2347END SUBROUTINE optionparser_add_d
2348
2349
2359SUBROUTINE optionparser_add_darray(this, short_opt, long_opt, dest, default, help)
2360TYPE(optionparser),INTENT(inout) :: this
2361CHARACTER(len=*),INTENT(in) :: short_opt
2362CHARACTER(len=*),INTENT(in) :: long_opt
2363TYPE(arrayof_doubleprecision),TARGET :: dest
2364DOUBLE PRECISION,OPTIONAL :: default(:)
2365CHARACTER(len=*),OPTIONAL :: help
2366
2367CHARACTER(LEN=40) :: cdefault
2368INTEGER :: i
2369TYPE(option) :: myoption
2370
2371cdefault = ''
2372IF (PRESENT(default)) THEN
2373 IF (SIZE(default) == 1) THEN
2375 ELSE IF (SIZE(default) > 1) THEN
2377 ENDIF
2378ENDIF
2379
2380! common initialisation
2381myoption = option_new(short_opt, long_opt, cdefault, help)
2382IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2383
2384myoption%destdarr => dest
2385IF (PRESENT(default)) THEN
2386 CALL insert(myoption%destdarr, default)
2387 CALL packarray(myoption%destdarr)
2388ENDIF
2389myoption%opttype = opttype_darr
2390myoption%need_arg = 2
2391
2392i = arrayof_option_append(this%options, myoption)
2393
2394END SUBROUTINE optionparser_add_darray
2395
2396
2403SUBROUTINE optionparser_add_l(this, short_opt, long_opt, dest, help)
2404TYPE(optionparser),INTENT(inout) :: this
2405CHARACTER(len=*),INTENT(in) :: short_opt
2406CHARACTER(len=*),INTENT(in) :: long_opt
2407LOGICAL,TARGET :: dest
2408CHARACTER(len=*),OPTIONAL :: help
2409
2410INTEGER :: i
2411TYPE(option) :: myoption
2412
2413! common initialisation
2414myoption = option_new(short_opt, long_opt, '', help)
2415IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2416
2417myoption%destl => dest
2418myoption%destl = .false. ! unconditionally set to false, option can only set it to true
2419myoption%opttype = opttype_l
2420myoption%need_arg = 0
2421
2422i = arrayof_option_append(this%options, myoption)
2423
2424END SUBROUTINE optionparser_add_l
2425
2426
2431SUBROUTINE optionparser_add_count(this, short_opt, long_opt, dest, start, help)
2432TYPE(optionparser),INTENT(inout) :: this
2433CHARACTER(len=*),INTENT(in) :: short_opt
2434CHARACTER(len=*),INTENT(in) :: long_opt
2435INTEGER,TARGET :: dest
2436INTEGER,OPTIONAL :: start
2437CHARACTER(len=*),OPTIONAL :: help
2438
2439INTEGER :: i
2440TYPE(option) :: myoption
2441
2442! common initialisation
2443myoption = option_new(short_opt, long_opt, '', help)
2444IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2445
2446myoption%destcount => dest
2447IF (PRESENT(start)) myoption%destcount = start
2448myoption%opttype = opttype_count
2449myoption%need_arg = 0
2450
2451i = arrayof_option_append(this%options, myoption)
2452
2453END SUBROUTINE optionparser_add_count
2454
2455
2470SUBROUTINE optionparser_add_help(this, short_opt, long_opt, help)
2471TYPE(optionparser),INTENT(inout) :: this
2472CHARACTER(len=*),INTENT(in) :: short_opt
2473CHARACTER(len=*),INTENT(in) :: long_opt
2474CHARACTER(len=*),OPTIONAL :: help
2475
2476INTEGER :: i
2477TYPE(option) :: myoption
2478
2479! common initialisation
2480myoption = option_new(short_opt, long_opt, '', help)
2481IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2482
2483myoption%opttype = opttype_help
2484myoption%need_arg = 1
2485
2486i = arrayof_option_append(this%options, myoption)
2487
2488END SUBROUTINE optionparser_add_help
2489
2490
2501SUBROUTINE optionparser_add_sep(this, help)
2502TYPE(optionparser),INTENT(inout) :: this
2503!CHARACTER(len=*),INTENT(in) :: short_opt !< the short option (may be empty)
2504!CHARACTER(len=*),INTENT(in) :: long_opt !< the long option (may be empty)
2505CHARACTER(len=*) :: help
2506
2507INTEGER :: i
2508TYPE(option) :: myoption
2509
2510! common initialisation
2511myoption = option_new('_', '_', '', help)
2512IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2513
2514myoption%opttype = opttype_sep
2515myoption%need_arg = 0
2516
2517i = arrayof_option_append(this%options, myoption)
2518
2519END SUBROUTINE optionparser_add_sep
2520
2521
2531SUBROUTINE optionparser_parse(this, nextarg, status)
2532TYPE(optionparser),INTENT(inout) :: this
2533INTEGER,INTENT(out) :: nextarg
2534INTEGER,INTENT(out) :: status
2535
2536INTEGER :: i, j, endopt, indeq, iargc
2537CHARACTER(len=16384) :: arg, optarg
2538
2539status = optionparser_ok
2540i = 1
2541DO WHILE(i <= iargc())
2542 CALL getarg(i, arg)
2543 IF (arg == '--') THEN ! explicit end of options
2544 i = i + 1 ! skip present option (--)
2545 EXIT
2546 ELSE IF (arg == '-') THEN ! a single - is not an option
2547 EXIT
2548 ELSE IF (arg(1:2) == '--') THEN ! long option
2550 IF (indeq /= 0) THEN ! = present
2551 endopt = indeq - 1
2552 ELSE ! no =
2553 endopt = len_trim(arg)
2554 ENDIF
2555 find_longopt: DO j = 1, this%options%arraysize
2556 IF (this%options%array(j)%long_opt == arg(3:endopt)) THEN ! found option
2557 SELECT CASE(this%options%array(j)%need_arg)
2558 CASE(2) ! compulsory
2559 IF (indeq /= 0) THEN
2560 optarg = arg(indeq+1:)
2561 status = max(option_found(this%options%array(j), optarg), &
2562 status)
2563 ELSE
2564 IF (i < iargc()) THEN
2565 i=i+1
2566 CALL getarg(i, optarg)
2567 status = max(option_found(this%options%array(j), optarg), &
2568 status)
2569 ELSE
2570 status = optionparser_err
2571 CALL l4f_log(l4f_error, &
2572 'in optionparser, option '''//trim(arg)//''' requires an argument')
2573 ENDIF
2574 ENDIF
2575 CASE(1) ! optional
2576 IF (indeq /= 0) THEN
2577 optarg = arg(indeq+1:)
2578 ELSE
2579 IF (i < iargc()) THEN
2580 CALL getarg(i+1, optarg)
2581 IF (optarg(1:1) == '-') THEN
2582 optarg = cmiss ! refused
2583 ELSE
2584 i=i+1 ! accepted
2585 ENDIF
2586 ELSE
2587 optarg = cmiss ! refused
2588 ENDIF
2589 ENDIF
2590 status = max(option_found(this%options%array(j), optarg), &
2591 status)
2592 CASE(0)
2593 status = max(option_found(this%options%array(j)), &
2594 status)
2595 END SELECT
2596 EXIT find_longopt
2597 ENDIF
2598 ENDDO find_longopt
2599 IF (j > this%options%arraysize) THEN
2600 status = optionparser_err
2601 CALL l4f_log(l4f_error, &
2602 'in optionparser, option '''//trim(arg)//''' not valid')
2603 ENDIF
2604 ELSE IF (arg(1:1) == '-') THEN ! short option
2605 find_shortopt: DO j = 1, this%options%arraysize
2606 IF (this%options%array(j)%short_opt == arg(2:2)) THEN ! found option
2607 SELECT CASE(this%options%array(j)%need_arg)
2608 CASE(2) ! compulsory
2609 IF (len_trim(arg) > 2) THEN
2610 optarg = arg(3:)
2611 status = max(option_found(this%options%array(j), optarg), &
2612 status)
2613 ELSE
2614 IF (i < iargc()) THEN
2615 i=i+1
2616 CALL getarg(i, optarg)
2617 status = max(option_found(this%options%array(j), optarg), &
2618 status)
2619 ELSE
2620 status = optionparser_err
2621 CALL l4f_log(l4f_error, &
2622 'in optionparser, option '''//trim(arg)//''' requires an argument')
2623 ENDIF
2624 ENDIF
2625 CASE(1) ! optional
2626 IF (len_trim(arg) > 2) THEN
2627 optarg = arg(3:)
2628 ELSE
2629 IF (i < iargc()) THEN
2630 CALL getarg(i+1, optarg)
2631 IF (optarg(1:1) == '-') THEN
2632 optarg = cmiss ! refused
2633 ELSE
2634 i=i+1 ! accepted
2635 ENDIF
2636 ELSE
2637 optarg = cmiss ! refused
2638 ENDIF
2639 ENDIF
2640 status = max(option_found(this%options%array(j), optarg), &
2641 status)
2642 CASE(0)
2643 status = max(option_found(this%options%array(j)), &
2644 status)
2645 END SELECT
2646 EXIT find_shortopt
2647 ENDIF
2648 ENDDO find_shortopt
2649 IF (j > this%options%arraysize) THEN
2650 status = optionparser_err
2651 CALL l4f_log(l4f_error, &
2652 'in optionparser, option '''//trim(arg)//''' not valid')
2653 ENDIF
2654 ELSE ! unrecognized = end of options
2655 EXIT
2656 ENDIF
2657 i = i + 1
2658ENDDO
2659
2660nextarg = i
2661SELECT CASE(status)
2662CASE(optionparser_err, optionparser_help)
2663 CALL optionparser_printhelp(this)
2664END SELECT
2665
2666END SUBROUTINE optionparser_parse
2667
2668
2672SUBROUTINE optionparser_printhelp(this)
2673TYPE(optionparser),INTENT(in) :: this
2674
2675INTEGER :: i, form
2676
2677form = 0
2678DO i = 1, this%options%arraysize ! loop over options
2679 IF (this%options%array(i)%opttype == opttype_help) THEN
2680 form = this%options%array(i)%helpformat
2681 ENDIF
2682ENDDO
2683
2684SELECT CASE(form)
2685CASE(0)
2686 CALL optionparser_printhelptxt(this)
2687CASE(1)
2688 CALL optionparser_printhelpmd(this)
2689CASE(2)
2690 CALL optionparser_printhelphtmlform(this)
2691END SELECT
2692
2693END SUBROUTINE optionparser_printhelp
2694
2695
2699SUBROUTINE optionparser_printhelptxt(this)
2700TYPE(optionparser),INTENT(in) :: this
2701
2702INTEGER :: i, j, ncols
2703CHARACTER(len=80) :: buf
2704TYPE(line_split) :: help_line
2705
2706ncols = default_columns()
2707
2708! print usage message
2709IF (ASSOCIATED(this%usage_msg)) THEN
2710 help_line = line_split_new(cstr_to_fchar(this%usage_msg), ncols)
2711 DO j = 1, line_split_get_nlines(help_line)
2712 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2713 ENDDO
2715ELSE
2716 CALL getarg(0, buf)
2718 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2719 WRITE(*,'(A)')'Usage: '//trim(buf(i+1:))//' [options] [arguments]'
2720ENDIF
2721
2722! print description message
2723IF (ASSOCIATED(this%description_msg)) THEN
2724 WRITE(*,'()')
2725 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2726 DO j = 1, line_split_get_nlines(help_line)
2727 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2728 ENDDO
2730ENDIF
2731
2732WRITE(*,'(/,A)')'Options:'
2733
2734DO i = 1, this%options%arraysize ! loop over options
2735 CALL option_format_help(this%options%array(i), ncols)
2736ENDDO
2737
2738END SUBROUTINE optionparser_printhelptxt
2739
2740
2744SUBROUTINE optionparser_printhelpmd(this)
2745TYPE(optionparser),INTENT(in) :: this
2746
2747INTEGER :: i, j, ncols
2748CHARACTER(len=80) :: buf
2749TYPE(line_split) :: help_line
2750
2751ncols = default_columns()
2752
2753! print usage message
2754WRITE(*,'(A)')'### Synopsis'
2755
2756IF (ASSOCIATED(this%usage_msg)) THEN
2757 help_line = line_split_new(mdquote_usage_msg(cstr_to_fchar(this%usage_msg)), ncols)
2758 DO j = 1, line_split_get_nlines(help_line)
2759 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2760 ENDDO
2762ELSE
2763 CALL getarg(0, buf)
2765 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2766 WRITE(*,'(A)')'Usage: `'//trim(buf(i+1:))//' [options] [arguments]`'
2767ENDIF
2768
2769! print description message
2770IF (ASSOCIATED(this%description_msg)) THEN
2771 WRITE(*,'()')
2772 WRITE(*,'(A)')'### Description'
2773 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2774 DO j = 1, line_split_get_nlines(help_line)
2775 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2776 ENDDO
2778
2779ENDIF
2780
2781WRITE(*,'(/,A)')'### Options'
2782
2783DO i = 1, this%options%arraysize ! loop over options
2784 CALL option_format_md(this%options%array(i), ncols)
2785ENDDO
2786
2787CONTAINS
2788
2789FUNCTION mdquote_usage_msg(usage_msg)
2790CHARACTER(len=*),INTENT(in) :: usage_msg
2791
2792CHARACTER(len=LEN(usage_msg)+2) :: mdquote_usage_msg
2793INTEGER :: colon
2794
2796IF (colon > 0 .AND. colon < len(usage_msg)-1) THEN
2797 mdquote_usage_msg = usage_msg(:colon+1)//'`'//usage_msg(colon+2:)//'`'
2798ELSE
2799 mdquote_usage_msg = usage_msg
2800ENDIF
2801
2802END FUNCTION mdquote_usage_msg
2803
2804END SUBROUTINE optionparser_printhelpmd
2805
2809SUBROUTINE optionparser_printhelphtmlform(this)
2810TYPE(optionparser),INTENT(in) :: this
2811
2812INTEGER :: i
2813
2814DO i = 1, this%options%arraysize ! loop over options
2815 CALL option_format_htmlform(this%options%array(i))
2816ENDDO
2817
2818WRITE(*,'(A)')'<input class="libsim_sub" type="submit" value="runprogram" />'
2819
2820END SUBROUTINE optionparser_printhelphtmlform
2821
2822
2823SUBROUTINE optionparser_make_completion(this)
2824TYPE(optionparser),INTENT(in) :: this
2825
2826INTEGER :: i
2827CHARACTER(len=512) :: buf
2828
2829CALL getarg(0, buf)
2830
2831WRITE(*,'(A/A/A)')'_'//trim(buf)//'()','{','local cur'
2832
2833WRITE(*,'(A/A/A/A)')'COMPREPLY=()','cur=${COMP_WORDS[COMP_CWORD]}', &
2834 'case "$cur" in','-*)'
2835
2836!-*)
2837! COMPREPLY=( $( compgen -W
2838DO i = 1, this%options%arraysize ! loop over options
2839 IF (this%options%array(i)%need_arg == 2) THEN
2840 ENDIF
2841ENDDO
2842
2843WRITE(*,'(A/A/A)')'esac','return 0','}'
2844
2845END SUBROUTINE optionparser_make_completion
2846
2847
2848SUBROUTINE dirty_char_assignment(destc, destclen, src)
2850IMPLICIT NONE
2851
2852CHARACTER(len=1) :: destc(*)
2853CHARACTER(len=*) :: src
2854INTEGER :: destclen
2855
2856INTEGER :: i
2857
2858DO i = 1, min(destclen, len(src))
2859 destc(i) = src(i:i)
2860ENDDO
2861DO i = len(src)+1, destclen
2862 destc(i) = ' '
2863ENDDO
2864
2865END SUBROUTINE dirty_char_assignment
2866
Set of functions that return a trimmed CHARACTER representation of the input variable. Definition: char_utilities.F90:284 Set of functions that return a CHARACTER representation of the input variable. Definition: char_utilities.F90:259 Methods for successively obtaining the fields of a csv_record object. Definition: file_utilities.F90:285 Destructor for the optionparser class. Definition: optionparser_class.F90:303 Add a new option of a specific type. Definition: optionparser_class.F90:418 This module defines usefull general purpose function and subroutine. Definition: array_utilities.F90:218 Definition of constants to be used for declaring variables of a desired type. Definition: kinds.F90:251 This class allows to parse the command-line options of a program in an object-oriented way,... Definition: optionparser_class.F90:407 |