libsim Versione 7.1.11

◆ optionparser_parse()

subroutine, public optionparser_parse ( type(optionparser), intent(inout)  this,
integer, intent(out)  nextarg,
integer, intent(out)  status 
)

This method performs the parsing of the command-line options which have been previously added using the optionparser_add family of methods.

The destination variables set through the optionparser_add methods are assigned according to the options encountered on the command line. If any optional argument remains after interpretation of all command-line options, the index of the first of them is returned in nextarg, otherwise nextarg is equal to iargc() + 1. The status of the parsing process should be checked via the status argument.

Parametri
[in,out]thisoptionparser object with correctly initialised options
[out]nextargindex of the first optional argument after interpretation of all command-line options
[out]statusstatus of the parsing process, to be compared with the constants optionparser_ok, ecc.

Definizione alla linea 1532 del file optionparser_class.F90.

1533! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1534! authors:
1535! Davide Cesari <dcesari@arpa.emr.it>
1536! Paolo Patruno <ppatruno@arpa.emr.it>
1537
1538! This program is free software; you can redistribute it and/or
1539! modify it under the terms of the GNU General Public License as
1540! published by the Free Software Foundation; either version 2 of
1541! the License, or (at your option) any later version.
1542
1543! This program is distributed in the hope that it will be useful,
1544! but WITHOUT ANY WARRANTY; without even the implied warranty of
1545! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1546! GNU General Public License for more details.
1556#include "config.h"
1557
1558MODULE optionparser_class
1559USE log4fortran
1560USE err_handling
1561USE kinds
1565IMPLICIT NONE
1566
1567
1568! private class
1569TYPE option
1570 CHARACTER(len=1) :: short_opt=''
1571 CHARACTER(len=80) :: long_opt=''
1572 INTEGER :: opttype=-1
1573 INTEGER :: need_arg=0 ! 0=no, 1=optional, 2=yes, was .FALSE.
1574 LOGICAL :: has_default=.false.
1575 CHARACTER(len=1),POINTER :: destc=>null()
1576 INTEGER :: destclen=0
1577 INTEGER :: helpformat=0 ! 0=txt, 1=markdown, 2=htmlform, improve!
1578 INTEGER,POINTER :: desti=>null()
1579 TYPE(arrayof_integer),POINTER :: destiarr=>null()
1580 REAL,POINTER :: destr=>null()
1581 TYPE(arrayof_real),POINTER :: destrarr=>null()
1582 DOUBLE PRECISION, POINTER :: destd=>null()
1583 TYPE(arrayof_doubleprecision),POINTER :: destdarr=>null()
1584 LOGICAL,POINTER :: destl=>null()
1585 TYPE(arrayof_logical),POINTER :: destlarr=>null()
1586 INTEGER,POINTER :: destcount=>null()
1587 INTEGER(kind=int_b),ALLOCATABLE :: help_msg(:)
1588END TYPE option
1589
1590#define ARRAYOF_ORIGTYPE TYPE(option)
1591#define ARRAYOF_TYPE arrayof_option
1592#define ARRAYOF_ORIGDESTRUCTOR(x) CALL option_delete(x)
1593#define ARRAYOF_PRIVATE 1
1594#include "arrayof_pre_nodoc.F90"
1595! from arrayof
1596!PUBLIC insert, append, remove, packarray
1597!PUBLIC insert_unique, append_unique
1598
1676TYPE optionparser
1677 PRIVATE
1678 INTEGER(kind=int_b),POINTER :: usage_msg(:), description_msg(:)
1679 TYPE(arrayof_option) :: options
1680 LOGICAL :: httpmode=.false.
1681END TYPE optionparser
1682
1683
1687INTERFACE optionparser_add
1688 MODULE PROCEDURE optionparser_add_c, optionparser_add_i, optionparser_add_r, &
1689 optionparser_add_d, optionparser_add_l, &
1690 optionparser_add_iarray, optionparser_add_rarray, optionparser_add_darray
1691END INTERFACE
1692
1693INTERFACE c_e
1694 MODULE PROCEDURE option_c_e
1695END INTERFACE
1696
1704INTERFACE delete
1705 MODULE PROCEDURE optionparser_delete!?, option_delete
1706END INTERFACE
1707
1708
1709INTEGER,PARAMETER :: opttype_c = 1, opttype_i = 2, opttype_r = 3, &
1710 opttype_d = 4, opttype_l = 5, opttype_count = 6, opttype_help = 7, &
1711 opttype_sep = 8, opttype_carr = 11, opttype_iarr = 12, opttype_rarr = 13, &
1712 opttype_darr = 14, opttype_larr = 15
1713
1714INTEGER,PARAMETER :: optionparser_ok = 0
1715INTEGER,PARAMETER :: optionparser_help = 1
1716INTEGER,PARAMETER :: optionparser_err = 2
1717
1718
1719PRIVATE
1720PUBLIC optionparser, optionparser_new, delete, optionparser_add, &
1721 optionparser_add_count, optionparser_add_help, optionparser_add_sep, &
1722 optionparser_parse, optionparser_printhelp, &
1723 optionparser_ok, optionparser_help, optionparser_err
1724
1725
1726CONTAINS
1727
1728#include "arrayof_post_nodoc.F90"
1729
1730! Constructor for the option class
1731FUNCTION option_new(short_opt, long_opt, default, help) RESULT(this)
1732CHARACTER(len=*),INTENT(in) :: short_opt
1733CHARACTER(len=*),INTENT(in) :: long_opt
1734CHARACTER(len=*),INTENT(in) :: default
1735CHARACTER(len=*),OPTIONAL :: help
1736TYPE(option) :: this
1737
1738IF (short_opt == '' .AND. long_opt == '') THEN
1739#ifdef DEBUG
1740! programmer error condition, option empty
1741 CALL l4f_log(l4f_error, 'in optionparser, both short and long options empty')
1742 CALL raise_fatal_error()
1743#else
1744 CALL l4f_log(l4f_warn, 'in optionparser, both short and long options empty')
1745#endif
1746 RETURN
1747ENDIF
1748
1749this%short_opt = short_opt
1750this%long_opt = long_opt
1751IF (PRESENT(help)) THEN
1752 this%help_msg = fchar_to_cstr(trim(help)//trim(default)) ! f2003 automatic alloc
1753ENDIF
1754this%has_default = (len_trim(default) > 0)
1755
1756END FUNCTION option_new
1757
1758
1759! Destructor for the \a option class, the memory associated with
1760! the object is freed.
1761SUBROUTINE option_delete(this)
1762TYPE(option),INTENT(inout) :: this ! object to destroy
1763
1764IF (ALLOCATED(this%help_msg)) DEALLOCATE(this%help_msg)
1765NULLIFY(this%destc)
1766NULLIFY(this%desti)
1767NULLIFY(this%destr)
1768NULLIFY(this%destd)
1769NULLIFY(this%destl)
1770NULLIFY(this%destcount)
1771
1772END SUBROUTINE option_delete
1773
1774
1775FUNCTION option_found(this, optarg) RESULT(status)
1776TYPE(option),INTENT(inout) :: this
1777CHARACTER(len=*),INTENT(in),OPTIONAL :: optarg
1778INTEGER :: status
1779
1780TYPE(csv_record) :: arrparser
1781INTEGER :: ibuff
1782REAL :: rbuff
1783DOUBLE PRECISION :: dbuff
1784
1785status = optionparser_ok
1786
1787SELECT CASE(this%opttype)
1788CASE(opttype_c)
1789 CALL dirty_char_assignment(this%destc, this%destclen, trim(optarg))
1790! this%destc(1:this%destclen) = optarg
1791 IF (len_trim(optarg) > this%destclen) THEN
1792 CALL l4f_log(l4f_warn, &
1793 'in optionparser, argument '''//trim(optarg)//''' too long, truncated')
1794 ENDIF
1795CASE(opttype_i)
1796 READ(optarg,'(I12)',err=100)this%desti
1797CASE(opttype_iarr)
1798 CALL delete(this%destiarr) ! delete default values
1799 CALL init(arrparser, optarg)
1800 DO WHILE(.NOT.csv_record_end(arrparser))
1801 CALL csv_record_getfield(arrparser, ibuff)
1802 CALL insert(this%destiarr, ibuff)
1803 ENDDO
1804 CALL packarray(this%destiarr)
1805 CALL delete(arrparser)
1806CASE(opttype_r)
1807 READ(optarg,'(F20.0)',err=102)this%destr
1808CASE(opttype_rarr)
1809 CALL delete(this%destrarr) ! delete default values
1810 CALL init(arrparser, optarg)
1811 DO WHILE(.NOT.csv_record_end(arrparser))
1812 CALL csv_record_getfield(arrparser, rbuff)
1813 CALL insert(this%destrarr, rbuff)
1814 ENDDO
1815 CALL packarray(this%destrarr)
1816 CALL delete(arrparser)
1817CASE(opttype_d)
1818 READ(optarg,'(F20.0)',err=102)this%destd
1819CASE(opttype_darr)
1820 CALL delete(this%destdarr) ! delete default values
1821 CALL init(arrparser, optarg)
1822 DO WHILE(.NOT.csv_record_end(arrparser))
1823 CALL csv_record_getfield(arrparser, dbuff)
1824 CALL insert(this%destdarr, dbuff)
1825 ENDDO
1826 CALL packarray(this%destdarr)
1827 CALL delete(arrparser)
1828CASE(opttype_l)
1829 this%destl = .true.
1830CASE(opttype_count)
1831 this%destcount = this%destcount + 1
1832CASE(opttype_help)
1833 status = optionparser_help
1834 SELECT CASE(optarg) ! set help format
1835 CASE('md', 'markdown')
1836 this%helpformat = 1
1837 CASE('htmlform')
1838 this%helpformat = 2
1839 END SELECT
1840END SELECT
1841
1842RETURN
1843
1844100 status = optionparser_err
1845CALL l4f_log(l4f_error, &
1846 'in optionparser, argument '''//trim(optarg)//''' not valid as integer')
1847RETURN
1848102 status = optionparser_err
1849CALL l4f_log(l4f_error, &
1850 'in optionparser, argument '''//trim(optarg)//''' not valid as real')
1851RETURN
1852
1853END FUNCTION option_found
1854
1855
1856! Return a string which gives a short representation of the
1857! option \a this, without help message. The resulting string is quite
1858! long and it should be trimmed with the \a TRIM() intrinsic
1859! function.
1860FUNCTION option_format_opt(this) RESULT(format_opt)
1861TYPE(option),INTENT(in) :: this
1862
1863CHARACTER(len=100) :: format_opt
1864
1865CHARACTER(len=20) :: argname
1866
1867SELECT CASE(this%opttype)
1868CASE(opttype_c)
1869 argname = 'STRING'
1870CASE(opttype_i)
1871 argname = 'INT'
1872CASE(opttype_iarr)
1873 argname = 'INT[,INT...]'
1874CASE(opttype_r, opttype_d)
1875 argname = 'REAL'
1876CASE(opttype_rarr, opttype_darr)
1877 argname = 'REAL[,REAL...]'
1878CASE default
1879 argname = ''
1880END SELECT
1881
1882format_opt = ''
1883IF (this%short_opt /= '') THEN
1884 format_opt(len_trim(format_opt)+1:) = ' -'//this%short_opt
1885 IF (argname /= '') THEN
1886 format_opt(len_trim(format_opt)+1:) = ' '//trim(argname)
1887 ENDIF
1888ENDIF
1889IF (this%short_opt /= '' .AND. this%long_opt /= '') THEN
1890 format_opt(len_trim(format_opt)+1:) = ','
1891ENDIF
1892IF (this%long_opt /= '') THEN
1893 format_opt(len_trim(format_opt)+1:) = ' --'//this%long_opt
1894 IF (argname /= '') THEN
1895 format_opt(len_trim(format_opt)+1:) = '='//trim(argname)
1896 ENDIF
1897ENDIF
1898
1899END FUNCTION option_format_opt
1900
1901
1902! print on stdout a human-readable text representation of a single option
1903SUBROUTINE option_format_help(this, ncols)
1904TYPE(option),INTENT(in) :: this
1905INTEGER,INTENT(in) :: ncols
1906
1907INTEGER :: j
1908INTEGER, PARAMETER :: indent = 10
1909TYPE(line_split) :: help_line
1910
1911
1912IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
1913 IF (ALLOCATED(this%help_msg)) THEN
1914! help2man is quite picky about the treatment of arbitrary lines
1915! within options, the only universal way seems to be unindented lines
1916! with an empty line before and after
1917 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
1918 WRITE(*,'()')
1919 DO j = 1, line_split_get_nlines(help_line)
1920 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1921 ENDDO
1922 CALL delete(help_line)
1923 WRITE(*,'()')
1924 ENDIF
1925ELSE ! ordinary option
1926! print option brief representation
1927 WRITE(*,'(A)')trim(option_format_opt(this))
1928! print option help
1929 IF (ALLOCATED(this%help_msg)) THEN
1930 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
1931 DO j = 1, line_split_get_nlines(help_line)
1932 WRITE(*,'(T10,A)')trim(line_split_get_line(help_line,j))
1933 ENDDO
1934 CALL delete(help_line)
1935 ENDIF
1936ENDIF
1937
1938END SUBROUTINE option_format_help
1939
1940
1941! print on stdout a markdown representation of a single option
1942SUBROUTINE option_format_md(this, ncols)
1943TYPE(option),INTENT(in) :: this
1944INTEGER,INTENT(in) :: ncols
1945
1946INTEGER :: j
1947INTEGER, PARAMETER :: indent = 2
1948TYPE(line_split) :: help_line
1949
1950IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
1951 IF (ALLOCATED(this%help_msg)) THEN
1952 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
1953 WRITE(*,'()')
1954 DO j = 1, line_split_get_nlines(help_line)
1955 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1956 ENDDO
1957 CALL delete(help_line)
1958 WRITE(*,'()')
1959 ENDIF
1960ELSE ! ordinary option
1961! print option brief representation
1962 WRITE(*,'(''`'',A,''`'')')trim(option_format_opt(this))
1963! print option help
1964 IF (ALLOCATED(this%help_msg)) THEN
1965 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
1966 DO j = 1, line_split_get_nlines(help_line)
1967 WRITE(*,'(''> '',A)')trim(line_split_get_line(help_line,j))
1968 ENDDO
1969 CALL delete(help_line)
1970 WRITE(*,'()')
1971 ENDIF
1972ENDIF
1973
1974END SUBROUTINE option_format_md
1975
1976
1977! print on stdout an html form representation of a single option
1978SUBROUTINE option_format_htmlform(this)
1979TYPE(option),INTENT(in) :: this
1980
1981CHARACTER(len=80) :: opt_name, opt_id, opt_default ! check len of default
1982
1983IF (.NOT.c_e(this)) RETURN
1984IF (this%long_opt == '') THEN
1985 opt_name = this%short_opt
1986 opt_id = 'short_opt_'//this%short_opt
1987ELSE
1988 opt_name = this%long_opt
1989 opt_id = this%long_opt
1990ENDIF
1991
1992SELECT CASE(this%opttype)
1993CASE(opttype_c)
1994 CALL option_format_html_openspan('text')
1995
1996 IF (this%has_default .AND. ASSOCIATED(this%destc) .AND. this%destclen > 0) THEN
1997! opt_default = TRANSFER(this%destc(1:MIN(LEN(opt_default),this%destclen)), &
1998! opt_default) ! improve
1999 opt_default = ''
2000 WRITE(*,'(A)')' value="'//trim(opt_default)//'"'
2001 ENDIF
2002 CALL option_format_html_help()
2003 CALL option_format_html_closespan()
2004
2005CASE(opttype_i,opttype_r,opttype_d)
2006 CALL option_format_html_openspan('text')
2007 IF (this%has_default) THEN
2008 SELECT CASE(this%opttype)
2009 CASE(opttype_i)
2010 WRITE(*,'(3A)')' value="',t2c(this%desti),'"'
2011! todo CASE(opttype_iarr)
2012 CASE(opttype_r)
2013 WRITE(*,'(3A)')' value="',t2c(this%destr),'"'
2014 CASE(opttype_d)
2015 WRITE(*,'(3A)')' value="',t2c(this%destd),'"'
2016 END SELECT
2017 ENDIF
2018 CALL option_format_html_help()
2019 CALL option_format_html_closespan()
2020
2021! todo CASE(opttype_iarr)
2022
2023CASE(opttype_l)
2024 CALL option_format_html_openspan('checkbox')
2025 CALL option_format_html_help()
2026 CALL option_format_html_closespan()
2027
2028CASE(opttype_count)
2029 CALL option_format_html_openspan('number')
2030 CALL option_format_html_help()
2031 CALL option_format_html_closespan()
2032
2033CASE(opttype_sep)
2034END SELECT
2035
2036
2037CONTAINS
2038
2039SUBROUTINE option_format_html_openspan(formtype)
2040CHARACTER(len=*),INTENT(in) :: formtype
2041
2042WRITE(*,'(A)')'<span class="libsim_optbox" id="span_'//trim(opt_id)//'">'//trim(opt_name)//':'
2043! size=? maxlen=?
2044WRITE(*,'(A)')'<input class_"libsim_opt" id="'//trim(opt_id)//'" type="'//formtype// &
2045 '" name="'//trim(opt_id)//'" '
2046
2047END SUBROUTINE option_format_html_openspan
2048
2049SUBROUTINE option_format_html_closespan()
2050
2051WRITE(*,'(A)')'/></span>'
2052
2053END SUBROUTINE option_format_html_closespan
2054
2055SUBROUTINE option_format_html_help()
2056INTEGER :: j
2057TYPE(line_split) :: help_line
2058CHARACTER(len=20) :: form
2059
2060IF (ALLOCATED(this%help_msg)) THEN
2061 WRITE(*,'(A,$)')' title="'
2062
2063 help_line = line_split_new(cstr_to_fchar(this%help_msg), 80)
2064 form = '(A,'' '')'
2065 DO j = 1, line_split_get_nlines(help_line)
2066 IF (j == line_split_get_nlines(help_line)) form = '(A,''"'',$)'
2067 WRITE(*,form)trim(line_split_get_line(help_line,j)) ! lines should be properly quoted here
2068 ENDDO
2069
2070ENDIF
2071
2072END SUBROUTINE option_format_html_help
2073
2074END SUBROUTINE option_format_htmlform
2075
2076
2077FUNCTION option_c_e(this) RESULT(c_e)
2078TYPE(option),INTENT(in) :: this
2079
2080LOGICAL :: c_e
2081
2082c_e = this%long_opt /= ' ' .OR. this%short_opt /= ' '
2083
2084END FUNCTION option_c_e
2085
2086
2090FUNCTION optionparser_new(usage_msg, description_msg) RESULT(this)
2091CHARACTER(len=*), INTENT(in), OPTIONAL :: usage_msg
2092CHARACTER(len=*), INTENT(in), OPTIONAL :: description_msg
2093
2094TYPE(optionparser) :: this
2095
2096IF (PRESENT(usage_msg)) THEN
2097 CALL fchar_to_cstr_alloc(trim(usage_msg), this%usage_msg)
2098ELSE
2099 NULLIFY(this%usage_msg)
2100ENDIF
2101IF (PRESENT(description_msg)) THEN
2102 CALL fchar_to_cstr_alloc(trim(description_msg), this%description_msg)
2103ELSE
2104 NULLIFY(this%description_msg)
2105ENDIF
2106
2107END FUNCTION optionparser_new
2108
2109
2110SUBROUTINE optionparser_delete(this)
2111TYPE(optionparser),INTENT(inout) :: this
2112
2113IF (ASSOCIATED(this%usage_msg)) DEALLOCATE(this%usage_msg)
2114IF (ASSOCIATED(this%description_msg)) DEALLOCATE(this%description_msg)
2115CALL delete(this%options)
2116
2117END SUBROUTINE optionparser_delete
2118
2119
2127SUBROUTINE optionparser_add_c(this, short_opt, long_opt, dest, default, help, isopt)
2128TYPE(optionparser),INTENT(inout) :: this
2129CHARACTER(len=*),INTENT(in) :: short_opt
2130CHARACTER(len=*),INTENT(in) :: long_opt
2131CHARACTER(len=*),TARGET :: dest
2132CHARACTER(len=*),OPTIONAL :: default
2133CHARACTER(len=*),OPTIONAL :: help
2134LOGICAL,INTENT(in),OPTIONAL :: isopt
2135
2136CHARACTER(LEN=60) :: cdefault
2137INTEGER :: i
2138TYPE(option) :: myoption
2139
2140
2141IF (PRESENT(default)) THEN
2142 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2143ELSE
2144 cdefault = ''
2145ENDIF
2146
2147! common initialisation
2148myoption = option_new(short_opt, long_opt, cdefault, help)
2149IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2150
2151myoption%destc => dest(1:1)
2152myoption%destclen = len(dest) ! needed to avoid exceeding the length of dest
2153IF (PRESENT(default)) &
2154 CALL dirty_char_assignment(myoption%destc, myoption%destclen, default)
2155!IF (PRESENT(default)) myoption%destc(1:myoption%destclen) = default
2156myoption%opttype = opttype_c
2157IF (optio_log(isopt)) THEN
2158 myoption%need_arg = 1
2159ELSE
2160 myoption%need_arg = 2
2161ENDIF
2162
2163i = arrayof_option_append(this%options, myoption)
2164
2165END SUBROUTINE optionparser_add_c
2166
2167
2174SUBROUTINE optionparser_add_i(this, short_opt, long_opt, dest, default, help)
2175TYPE(optionparser),INTENT(inout) :: this
2176CHARACTER(len=*),INTENT(in) :: short_opt
2177CHARACTER(len=*),INTENT(in) :: long_opt
2178INTEGER,TARGET :: dest
2179INTEGER,OPTIONAL :: default
2180CHARACTER(len=*),OPTIONAL :: help
2181
2182CHARACTER(LEN=40) :: cdefault
2183INTEGER :: i
2184TYPE(option) :: myoption
2185
2186IF (PRESENT(default)) THEN
2187 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2188ELSE
2189 cdefault = ''
2190ENDIF
2191
2192! common initialisation
2193myoption = option_new(short_opt, long_opt, cdefault, help)
2194IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2195
2196myoption%desti => dest
2197IF (PRESENT(default)) myoption%desti = default
2198myoption%opttype = opttype_i
2199myoption%need_arg = 2
2200
2201i = arrayof_option_append(this%options, myoption)
2202
2203END SUBROUTINE optionparser_add_i
2204
2205
2215SUBROUTINE optionparser_add_iarray(this, short_opt, long_opt, dest, default, help)
2216TYPE(optionparser),INTENT(inout) :: this
2217CHARACTER(len=*),INTENT(in) :: short_opt
2218CHARACTER(len=*),INTENT(in) :: long_opt
2219TYPE(arrayof_integer),TARGET :: dest
2220INTEGER,OPTIONAL :: default(:)
2221CHARACTER(len=*),OPTIONAL :: help
2222
2223CHARACTER(LEN=40) :: cdefault
2224INTEGER :: i
2225TYPE(option) :: myoption
2226
2227cdefault = ''
2228IF (PRESENT(default)) THEN
2229 IF (SIZE(default) == 1) THEN
2230 cdefault = ' [default='//trim(to_char(default(1)))//']'
2231 ELSE IF (SIZE(default) > 1) THEN
2232 cdefault = ' [default='//trim(to_char(default(1)))//',...]'
2233 ENDIF
2234ENDIF
2235
2236! common initialisation
2237myoption = option_new(short_opt, long_opt, cdefault, help)
2238IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2239
2240myoption%destiarr => dest
2241IF (PRESENT(default)) THEN
2242 CALL insert(myoption%destiarr, default)
2243 CALL packarray(myoption%destiarr)
2244ENDIF
2245myoption%opttype = opttype_iarr
2246myoption%need_arg = 2
2247
2248i = arrayof_option_append(this%options, myoption)
2249
2250END SUBROUTINE optionparser_add_iarray
2251
2252
2259SUBROUTINE optionparser_add_r(this, short_opt, long_opt, dest, default, help)
2260TYPE(optionparser),INTENT(inout) :: this
2261CHARACTER(len=*),INTENT(in) :: short_opt
2262CHARACTER(len=*),INTENT(in) :: long_opt
2263REAL,TARGET :: dest
2264REAL,OPTIONAL :: default
2265CHARACTER(len=*),OPTIONAL :: help
2266
2267CHARACTER(LEN=40) :: cdefault
2268INTEGER :: i
2269TYPE(option) :: myoption
2270
2271IF (PRESENT(default)) THEN
2272 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2273ELSE
2274 cdefault = ''
2275ENDIF
2276
2277! common initialisation
2278myoption = option_new(short_opt, long_opt, cdefault, help)
2279IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2280
2281myoption%destr => dest
2282IF (PRESENT(default)) myoption%destr = default
2283myoption%opttype = opttype_r
2284myoption%need_arg = 2
2285
2286i = arrayof_option_append(this%options, myoption)
2287
2288END SUBROUTINE optionparser_add_r
2289
2290
2300SUBROUTINE optionparser_add_rarray(this, short_opt, long_opt, dest, default, help)
2301TYPE(optionparser),INTENT(inout) :: this
2302CHARACTER(len=*),INTENT(in) :: short_opt
2303CHARACTER(len=*),INTENT(in) :: long_opt
2304TYPE(arrayof_real),TARGET :: dest
2305REAL,OPTIONAL :: default(:)
2306CHARACTER(len=*),OPTIONAL :: help
2307
2308CHARACTER(LEN=40) :: cdefault
2309INTEGER :: i
2310TYPE(option) :: myoption
2311
2312cdefault = ''
2313IF (PRESENT(default)) THEN
2314 IF (SIZE(default) == 1) THEN
2315 cdefault = ' [default='//trim(to_char(default(1)))//']'
2316 ELSE IF (SIZE(default) > 1) THEN
2317 cdefault = ' [default='//trim(to_char(default(1)))//',...]'
2318 ENDIF
2319ENDIF
2320
2321! common initialisation
2322myoption = option_new(short_opt, long_opt, cdefault, help)
2323IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2324
2325myoption%destrarr => dest
2326IF (PRESENT(default)) THEN
2327 CALL insert(myoption%destrarr, default)
2328 CALL packarray(myoption%destrarr)
2329ENDIF
2330myoption%opttype = opttype_rarr
2331myoption%need_arg = 2
2332
2333i = arrayof_option_append(this%options, myoption)
2334
2335END SUBROUTINE optionparser_add_rarray
2336
2337
2344SUBROUTINE optionparser_add_d(this, short_opt, long_opt, dest, default, help)
2345TYPE(optionparser),INTENT(inout) :: this
2346CHARACTER(len=*),INTENT(in) :: short_opt
2347CHARACTER(len=*),INTENT(in) :: long_opt
2348DOUBLE PRECISION,TARGET :: dest
2349DOUBLE PRECISION,OPTIONAL :: default
2350CHARACTER(len=*),OPTIONAL :: help
2351
2352CHARACTER(LEN=40) :: cdefault
2353INTEGER :: i
2354TYPE(option) :: myoption
2355
2356IF (PRESENT(default)) THEN
2357 IF (c_e(default)) THEN
2358 cdefault = ' [default='//trim(adjustl(to_char(default,form='(G15.9)')))//']'
2359 ELSE
2360 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2361 ENDIF
2362ELSE
2363 cdefault = ''
2364ENDIF
2365
2366! common initialisation
2367myoption = option_new(short_opt, long_opt, cdefault, help)
2368IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2369
2370myoption%destd => dest
2371IF (PRESENT(default)) myoption%destd = default
2372myoption%opttype = opttype_d
2373myoption%need_arg = 2
2374
2375i = arrayof_option_append(this%options, myoption)
2376
2377END SUBROUTINE optionparser_add_d
2378
2379
2389SUBROUTINE optionparser_add_darray(this, short_opt, long_opt, dest, default, help)
2390TYPE(optionparser),INTENT(inout) :: this
2391CHARACTER(len=*),INTENT(in) :: short_opt
2392CHARACTER(len=*),INTENT(in) :: long_opt
2393TYPE(arrayof_doubleprecision),TARGET :: dest
2394DOUBLE PRECISION,OPTIONAL :: default(:)
2395CHARACTER(len=*),OPTIONAL :: help
2396
2397CHARACTER(LEN=40) :: cdefault
2398INTEGER :: i
2399TYPE(option) :: myoption
2400
2401cdefault = ''
2402IF (PRESENT(default)) THEN
2403 IF (SIZE(default) == 1) THEN
2404 cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//']'
2405 ELSE IF (SIZE(default) > 1) THEN
2406 cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//',...]'
2407 ENDIF
2408ENDIF
2409
2410! common initialisation
2411myoption = option_new(short_opt, long_opt, cdefault, help)
2412IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2413
2414myoption%destdarr => dest
2415IF (PRESENT(default)) THEN
2416 CALL insert(myoption%destdarr, default)
2417 CALL packarray(myoption%destdarr)
2418ENDIF
2419myoption%opttype = opttype_darr
2420myoption%need_arg = 2
2421
2422i = arrayof_option_append(this%options, myoption)
2423
2424END SUBROUTINE optionparser_add_darray
2425
2426
2433SUBROUTINE optionparser_add_l(this, short_opt, long_opt, dest, help)
2434TYPE(optionparser),INTENT(inout) :: this
2435CHARACTER(len=*),INTENT(in) :: short_opt
2436CHARACTER(len=*),INTENT(in) :: long_opt
2437LOGICAL,TARGET :: dest
2438CHARACTER(len=*),OPTIONAL :: help
2439
2440INTEGER :: i
2441TYPE(option) :: myoption
2442
2443! common initialisation
2444myoption = option_new(short_opt, long_opt, '', help)
2445IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2446
2447myoption%destl => dest
2448myoption%destl = .false. ! unconditionally set to false, option can only set it to true
2449myoption%opttype = opttype_l
2450myoption%need_arg = 0
2451
2452i = arrayof_option_append(this%options, myoption)
2453
2454END SUBROUTINE optionparser_add_l
2455
2456
2461SUBROUTINE optionparser_add_count(this, short_opt, long_opt, dest, start, help)
2462TYPE(optionparser),INTENT(inout) :: this
2463CHARACTER(len=*),INTENT(in) :: short_opt
2464CHARACTER(len=*),INTENT(in) :: long_opt
2465INTEGER,TARGET :: dest
2466INTEGER,OPTIONAL :: start
2467CHARACTER(len=*),OPTIONAL :: help
2468
2469INTEGER :: i
2470TYPE(option) :: myoption
2471
2472! common initialisation
2473myoption = option_new(short_opt, long_opt, '', help)
2474IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2475
2476myoption%destcount => dest
2477IF (PRESENT(start)) myoption%destcount = start
2478myoption%opttype = opttype_count
2479myoption%need_arg = 0
2480
2481i = arrayof_option_append(this%options, myoption)
2482
2483END SUBROUTINE optionparser_add_count
2484
2485
2500SUBROUTINE optionparser_add_help(this, short_opt, long_opt, help)
2501TYPE(optionparser),INTENT(inout) :: this
2502CHARACTER(len=*),INTENT(in) :: short_opt
2503CHARACTER(len=*),INTENT(in) :: long_opt
2504CHARACTER(len=*),OPTIONAL :: help
2505
2506INTEGER :: i
2507TYPE(option) :: myoption
2508
2509! common initialisation
2510myoption = option_new(short_opt, long_opt, '', help)
2511IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2512
2513myoption%opttype = opttype_help
2514myoption%need_arg = 1
2515
2516i = arrayof_option_append(this%options, myoption)
2517
2518END SUBROUTINE optionparser_add_help
2519
2520
2531SUBROUTINE optionparser_add_sep(this, help)
2532TYPE(optionparser),INTENT(inout) :: this
2533!CHARACTER(len=*),INTENT(in) :: short_opt !< the short option (may be empty)
2534!CHARACTER(len=*),INTENT(in) :: long_opt !< the long option (may be empty)
2535CHARACTER(len=*) :: help
2536
2537INTEGER :: i
2538TYPE(option) :: myoption
2539
2540! common initialisation
2541myoption = option_new('_', '_', '', help)
2542IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2543
2544myoption%opttype = opttype_sep
2545myoption%need_arg = 0
2546
2547i = arrayof_option_append(this%options, myoption)
2548
2549END SUBROUTINE optionparser_add_sep
2550
2551
2561SUBROUTINE optionparser_parse(this, nextarg, status)
2562TYPE(optionparser),INTENT(inout) :: this
2563INTEGER,INTENT(out) :: nextarg
2564INTEGER,INTENT(out) :: status
2565
2566INTEGER :: i, j, endopt, indeq, iargc
2567CHARACTER(len=16384) :: arg, optarg
2568
2569status = optionparser_ok
2570i = 1
2571DO WHILE(i <= iargc())
2572 CALL getarg(i, arg)
2573 IF (arg == '--') THEN ! explicit end of options
2574 i = i + 1 ! skip present option (--)
2575 EXIT
2576 ELSE IF (arg == '-') THEN ! a single - is not an option
2577 EXIT
2578 ELSE IF (arg(1:2) == '--') THEN ! long option
2579 indeq = index(arg, '=')
2580 IF (indeq /= 0) THEN ! = present
2581 endopt = indeq - 1
2582 ELSE ! no =
2583 endopt = len_trim(arg)
2584 ENDIF
2585 find_longopt: DO j = 1, this%options%arraysize
2586 IF (this%options%array(j)%long_opt == arg(3:endopt)) THEN ! found option
2587 SELECT CASE(this%options%array(j)%need_arg)
2588 CASE(2) ! compulsory
2589 IF (indeq /= 0) THEN
2590 optarg = arg(indeq+1:)
2591 status = max(option_found(this%options%array(j), optarg), &
2592 status)
2593 ELSE
2594 IF (i < iargc()) THEN
2595 i=i+1
2596 CALL getarg(i, optarg)
2597 status = max(option_found(this%options%array(j), optarg), &
2598 status)
2599 ELSE
2600 status = optionparser_err
2601 CALL l4f_log(l4f_error, &
2602 'in optionparser, option '''//trim(arg)//''' requires an argument')
2603 ENDIF
2604 ENDIF
2605 CASE(1) ! optional
2606 IF (indeq /= 0) THEN
2607 optarg = arg(indeq+1:)
2608 ELSE
2609 IF (i < iargc()) THEN
2610 CALL getarg(i+1, optarg)
2611 IF (optarg(1:1) == '-') THEN
2612 optarg = cmiss ! refused
2613 ELSE
2614 i=i+1 ! accepted
2615 ENDIF
2616 ELSE
2617 optarg = cmiss ! refused
2618 ENDIF
2619 ENDIF
2620 status = max(option_found(this%options%array(j), optarg), &
2621 status)
2622 CASE(0)
2623 status = max(option_found(this%options%array(j)), &
2624 status)
2625 END SELECT
2626 EXIT find_longopt
2627 ENDIF
2628 ENDDO find_longopt
2629 IF (j > this%options%arraysize) THEN
2630 status = optionparser_err
2631 CALL l4f_log(l4f_error, &
2632 'in optionparser, option '''//trim(arg)//''' not valid')
2633 ENDIF
2634 ELSE IF (arg(1:1) == '-') THEN ! short option
2635 find_shortopt: DO j = 1, this%options%arraysize
2636 IF (this%options%array(j)%short_opt == arg(2:2)) THEN ! found option
2637 SELECT CASE(this%options%array(j)%need_arg)
2638 CASE(2) ! compulsory
2639 IF (len_trim(arg) > 2) THEN
2640 optarg = arg(3:)
2641 status = max(option_found(this%options%array(j), optarg), &
2642 status)
2643 ELSE
2644 IF (i < iargc()) THEN
2645 i=i+1
2646 CALL getarg(i, optarg)
2647 status = max(option_found(this%options%array(j), optarg), &
2648 status)
2649 ELSE
2650 status = optionparser_err
2651 CALL l4f_log(l4f_error, &
2652 'in optionparser, option '''//trim(arg)//''' requires an argument')
2653 ENDIF
2654 ENDIF
2655 CASE(1) ! optional
2656 IF (len_trim(arg) > 2) THEN
2657 optarg = arg(3:)
2658 ELSE
2659 IF (i < iargc()) THEN
2660 CALL getarg(i+1, optarg)
2661 IF (optarg(1:1) == '-') THEN
2662 optarg = cmiss ! refused
2663 ELSE
2664 i=i+1 ! accepted
2665 ENDIF
2666 ELSE
2667 optarg = cmiss ! refused
2668 ENDIF
2669 ENDIF
2670 status = max(option_found(this%options%array(j), optarg), &
2671 status)
2672 CASE(0)
2673 status = max(option_found(this%options%array(j)), &
2674 status)
2675 END SELECT
2676 EXIT find_shortopt
2677 ENDIF
2678 ENDDO find_shortopt
2679 IF (j > this%options%arraysize) THEN
2680 status = optionparser_err
2681 CALL l4f_log(l4f_error, &
2682 'in optionparser, option '''//trim(arg)//''' not valid')
2683 ENDIF
2684 ELSE ! unrecognized = end of options
2685 EXIT
2686 ENDIF
2687 i = i + 1
2688ENDDO
2689
2690nextarg = i
2691SELECT CASE(status)
2692CASE(optionparser_err, optionparser_help)
2693 CALL optionparser_printhelp(this)
2694END SELECT
2695
2696END SUBROUTINE optionparser_parse
2697
2698
2702SUBROUTINE optionparser_printhelp(this)
2703TYPE(optionparser),INTENT(in) :: this
2704
2705INTEGER :: i, form
2706
2707form = 0
2708DO i = 1, this%options%arraysize ! loop over options
2709 IF (this%options%array(i)%opttype == opttype_help) THEN
2710 form = this%options%array(i)%helpformat
2711 ENDIF
2712ENDDO
2713
2714SELECT CASE(form)
2715CASE(0)
2716 CALL optionparser_printhelptxt(this)
2717CASE(1)
2718 CALL optionparser_printhelpmd(this)
2719CASE(2)
2720 CALL optionparser_printhelphtmlform(this)
2721END SELECT
2722
2723END SUBROUTINE optionparser_printhelp
2724
2725
2729SUBROUTINE optionparser_printhelptxt(this)
2730TYPE(optionparser),INTENT(in) :: this
2731
2732INTEGER :: i, j, ncols
2733CHARACTER(len=80) :: buf
2734TYPE(line_split) :: help_line
2735
2736ncols = default_columns()
2737
2738! print usage message
2739IF (ASSOCIATED(this%usage_msg)) THEN
2740 help_line = line_split_new(cstr_to_fchar(this%usage_msg), ncols)
2741 DO j = 1, line_split_get_nlines(help_line)
2742 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2743 ENDDO
2744 CALL delete(help_line)
2745ELSE
2746 CALL getarg(0, buf)
2747 i = index(buf, '/', back=.true.) ! remove directory part
2748 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2749 WRITE(*,'(A)')'Usage: '//trim(buf(i+1:))//' [options] [arguments]'
2750ENDIF
2751
2752! print description message
2753IF (ASSOCIATED(this%description_msg)) THEN
2754 WRITE(*,'()')
2755 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2756 DO j = 1, line_split_get_nlines(help_line)
2757 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2758 ENDDO
2759 CALL delete(help_line)
2760ENDIF
2761
2762WRITE(*,'(/,A)')'Options:'
2763
2764DO i = 1, this%options%arraysize ! loop over options
2765 CALL option_format_help(this%options%array(i), ncols)
2766ENDDO
2767
2768END SUBROUTINE optionparser_printhelptxt
2769
2770
2774SUBROUTINE optionparser_printhelpmd(this)
2775TYPE(optionparser),INTENT(in) :: this
2776
2777INTEGER :: i, j, ncols
2778CHARACTER(len=80) :: buf
2779TYPE(line_split) :: help_line
2780
2781ncols = default_columns()
2782
2783! print usage message
2784WRITE(*,'(A)')'### Synopsis'
2785
2786IF (ASSOCIATED(this%usage_msg)) THEN
2787 help_line = line_split_new(mdquote_usage_msg(cstr_to_fchar(this%usage_msg)), ncols)
2788 DO j = 1, line_split_get_nlines(help_line)
2789 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2790 ENDDO
2791 CALL delete(help_line)
2792ELSE
2793 CALL getarg(0, buf)
2794 i = index(buf, '/', back=.true.) ! remove directory part
2795 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2796 WRITE(*,'(A)')'Usage: `'//trim(buf(i+1:))//' [options] [arguments]`'
2797ENDIF
2798
2799! print description message
2800IF (ASSOCIATED(this%description_msg)) THEN
2801 WRITE(*,'()')
2802 WRITE(*,'(A)')'### Description'
2803 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2804 DO j = 1, line_split_get_nlines(help_line)
2805 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2806 ENDDO
2807 CALL delete(help_line)
2808
2809ENDIF
2810
2811WRITE(*,'(/,A)')'### Options'
2812
2813DO i = 1, this%options%arraysize ! loop over options
2814 CALL option_format_md(this%options%array(i), ncols)
2815ENDDO
2816
2817CONTAINS
2818
2819FUNCTION mdquote_usage_msg(usage_msg)
2820CHARACTER(len=*),INTENT(in) :: usage_msg
2821
2822CHARACTER(len=LEN(usage_msg)+2) :: mdquote_usage_msg
2823INTEGER :: colon
2824
2825colon = index(usage_msg, ':') ! typically 'Usage: cp [options] origin destination'
2826IF (colon > 0 .AND. colon < len(usage_msg)-1) THEN
2827 mdquote_usage_msg = usage_msg(:colon+1)//'`'//usage_msg(colon+2:)//'`'
2828ELSE
2829 mdquote_usage_msg = usage_msg
2830ENDIF
2831
2832END FUNCTION mdquote_usage_msg
2833
2834END SUBROUTINE optionparser_printhelpmd
2835
2839SUBROUTINE optionparser_printhelphtmlform(this)
2840TYPE(optionparser),INTENT(in) :: this
2841
2842INTEGER :: i
2843
2844DO i = 1, this%options%arraysize ! loop over options
2845 CALL option_format_htmlform(this%options%array(i))
2846ENDDO
2847
2848WRITE(*,'(A)')'<input class="libsim_sub" type="submit" value="runprogram" />'
2849
2850END SUBROUTINE optionparser_printhelphtmlform
2851
2852
2853SUBROUTINE optionparser_make_completion(this)
2854TYPE(optionparser),INTENT(in) :: this
2855
2856INTEGER :: i
2857CHARACTER(len=512) :: buf
2858
2859CALL getarg(0, buf)
2860
2861WRITE(*,'(A/A/A)')'_'//trim(buf)//'()','{','local cur'
2862
2863WRITE(*,'(A/A/A/A)')'COMPREPLY=()','cur=${COMP_WORDS[COMP_CWORD]}', &
2864 'case "$cur" in','-*)'
2865
2866!-*)
2867! COMPREPLY=( $( compgen -W
2868DO i = 1, this%options%arraysize ! loop over options
2869 IF (this%options%array(i)%need_arg == 2) THEN
2870 ENDIF
2871ENDDO
2872
2873WRITE(*,'(A/A/A)')'esac','return 0','}'
2874
2875END SUBROUTINE optionparser_make_completion
2876
2877
2878SUBROUTINE dirty_char_assignment(destc, destclen, src)
2879USE kinds
2880IMPLICIT NONE
2881
2882CHARACTER(len=1) :: destc(*)
2883CHARACTER(len=*) :: src
2884INTEGER :: destclen
2885
2886INTEGER :: i
2887
2888DO i = 1, min(destclen, len(src))
2889 destc(i) = src(i:i)
2890ENDDO
2891DO i = len(src)+1, destclen
2892 destc(i) = ' '
2893ENDDO
2894
2895END SUBROUTINE dirty_char_assignment
2896
2897END MODULE optionparser_class
Set of functions that return a trimmed CHARACTER representation of the input variable.
Set of functions that return a CHARACTER representation of the input variable.
Methods for successively obtaining the fields of a csv_record object.
Constructor for the class csv_record.
Index method.
Destructor for the optionparser class.
Add a new option of a specific type.
This module defines usefull general purpose function and subroutine.
Utilities for CHARACTER variables.
Gestione degli errori.
Utilities for managing files.
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:251
classe per la gestione del logging
Module for parsing command-line optons.
This class allows to parse the command-line options of a program in an object-oriented way,...

Generated with Doxygen.