libsim Versione 7.1.11
|
◆ optionparser_add_count()
Add a new counter option, without optional argument. When parsing will be performed, the provided destination will be incremented by one, starting from start, each time the requested option is encountered.
Definizione alla linea 1432 del file optionparser_class.F90. 1433! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1434! authors:
1435! Davide Cesari <dcesari@arpa.emr.it>
1436! Paolo Patruno <ppatruno@arpa.emr.it>
1437
1438! This program is free software; you can redistribute it and/or
1439! modify it under the terms of the GNU General Public License as
1440! published by the Free Software Foundation; either version 2 of
1441! the License, or (at your option) any later version.
1442
1443! This program is distributed in the hope that it will be useful,
1444! but WITHOUT ANY WARRANTY; without even the implied warranty of
1445! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1446! GNU General Public License for more details.
1456#include "config.h"
1457
1465IMPLICIT NONE
1466
1467
1468! private class
1469TYPE option
1470 CHARACTER(len=1) :: short_opt=''
1471 CHARACTER(len=80) :: long_opt=''
1472 INTEGER :: opttype=-1
1473 INTEGER :: need_arg=0 ! 0=no, 1=optional, 2=yes, was .FALSE.
1474 LOGICAL :: has_default=.false.
1475 CHARACTER(len=1),POINTER :: destc=>null()
1476 INTEGER :: destclen=0
1477 INTEGER :: helpformat=0 ! 0=txt, 1=markdown, 2=htmlform, improve!
1478 INTEGER,POINTER :: desti=>null()
1479 TYPE(arrayof_integer),POINTER :: destiarr=>null()
1480 REAL,POINTER :: destr=>null()
1481 TYPE(arrayof_real),POINTER :: destrarr=>null()
1482 DOUBLE PRECISION, POINTER :: destd=>null()
1483 TYPE(arrayof_doubleprecision),POINTER :: destdarr=>null()
1484 LOGICAL,POINTER :: destl=>null()
1485 TYPE(arrayof_logical),POINTER :: destlarr=>null()
1486 INTEGER,POINTER :: destcount=>null()
1487 INTEGER(kind=int_b),ALLOCATABLE :: help_msg(:)
1488END TYPE option
1489
1490#define ARRAYOF_ORIGTYPE TYPE(option)
1491#define ARRAYOF_TYPE arrayof_option
1492#define ARRAYOF_ORIGDESTRUCTOR(x) CALL option_delete(x)
1493#define ARRAYOF_PRIVATE 1
1494#include "arrayof_pre_nodoc.F90"
1495! from arrayof
1496!PUBLIC insert, append, remove, packarray
1497!PUBLIC insert_unique, append_unique
1498
1577 PRIVATE
1578 INTEGER(kind=int_b),POINTER :: usage_msg(:), description_msg(:)
1579 TYPE(arrayof_option) :: options
1580 LOGICAL :: httpmode=.false.
1582
1583
1588 MODULE PROCEDURE optionparser_add_c, optionparser_add_i, optionparser_add_r, &
1589 optionparser_add_d, optionparser_add_l, &
1590 optionparser_add_iarray, optionparser_add_rarray, optionparser_add_darray
1591END INTERFACE
1592
1593INTERFACE c_e
1594 MODULE PROCEDURE option_c_e
1595END INTERFACE
1596
1605 MODULE PROCEDURE optionparser_delete!?, option_delete
1606END INTERFACE
1607
1608
1609INTEGER,PARAMETER :: opttype_c = 1, opttype_i = 2, opttype_r = 3, &
1610 opttype_d = 4, opttype_l = 5, opttype_count = 6, opttype_help = 7, &
1611 opttype_sep = 8, opttype_carr = 11, opttype_iarr = 12, opttype_rarr = 13, &
1612 opttype_darr = 14, opttype_larr = 15
1613
1614INTEGER,PARAMETER :: optionparser_ok = 0
1615INTEGER,PARAMETER :: optionparser_help = 1
1616INTEGER,PARAMETER :: optionparser_err = 2
1617
1618
1619PRIVATE
1621 optionparser_add_count, optionparser_add_help, optionparser_add_sep, &
1622 optionparser_parse, optionparser_printhelp, &
1623 optionparser_ok, optionparser_help, optionparser_err
1624
1625
1626CONTAINS
1627
1628#include "arrayof_post_nodoc.F90"
1629
1630! Constructor for the option class
1631FUNCTION option_new(short_opt, long_opt, default, help) RESULT(this)
1632CHARACTER(len=*),INTENT(in) :: short_opt
1633CHARACTER(len=*),INTENT(in) :: long_opt
1634CHARACTER(len=*),INTENT(in) :: default
1635CHARACTER(len=*),OPTIONAL :: help
1636TYPE(option) :: this
1637
1638IF (short_opt == '' .AND. long_opt == '') THEN
1639#ifdef DEBUG
1640! programmer error condition, option empty
1641 CALL l4f_log(l4f_error, 'in optionparser, both short and long options empty')
1642 CALL raise_fatal_error()
1643#else
1644 CALL l4f_log(l4f_warn, 'in optionparser, both short and long options empty')
1645#endif
1646 RETURN
1647ENDIF
1648
1649this%short_opt = short_opt
1650this%long_opt = long_opt
1651IF (PRESENT(help)) THEN
1652 this%help_msg = fchar_to_cstr(trim(help)//trim(default)) ! f2003 automatic alloc
1653ENDIF
1654this%has_default = (len_trim(default) > 0)
1655
1656END FUNCTION option_new
1657
1658
1659! Destructor for the \a option class, the memory associated with
1660! the object is freed.
1661SUBROUTINE option_delete(this)
1662TYPE(option),INTENT(inout) :: this ! object to destroy
1663
1664IF (ALLOCATED(this%help_msg)) DEALLOCATE(this%help_msg)
1665NULLIFY(this%destc)
1666NULLIFY(this%desti)
1667NULLIFY(this%destr)
1668NULLIFY(this%destd)
1669NULLIFY(this%destl)
1670NULLIFY(this%destcount)
1671
1672END SUBROUTINE option_delete
1673
1674
1675FUNCTION option_found(this, optarg) RESULT(status)
1676TYPE(option),INTENT(inout) :: this
1677CHARACTER(len=*),INTENT(in),OPTIONAL :: optarg
1678INTEGER :: status
1679
1680TYPE(csv_record) :: arrparser
1681INTEGER :: ibuff
1682REAL :: rbuff
1683DOUBLE PRECISION :: dbuff
1684
1685status = optionparser_ok
1686
1687SELECT CASE(this%opttype)
1688CASE(opttype_c)
1689 CALL dirty_char_assignment(this%destc, this%destclen, trim(optarg))
1690! this%destc(1:this%destclen) = optarg
1691 IF (len_trim(optarg) > this%destclen) THEN
1692 CALL l4f_log(l4f_warn, &
1693 'in optionparser, argument '''//trim(optarg)//''' too long, truncated')
1694 ENDIF
1695CASE(opttype_i)
1696 READ(optarg,'(I12)',err=100)this%desti
1697CASE(opttype_iarr)
1700 DO WHILE(.NOT.csv_record_end(arrparser))
1702 CALL insert(this%destiarr, ibuff)
1703 ENDDO
1704 CALL packarray(this%destiarr)
1706CASE(opttype_r)
1707 READ(optarg,'(F20.0)',err=102)this%destr
1708CASE(opttype_rarr)
1711 DO WHILE(.NOT.csv_record_end(arrparser))
1713 CALL insert(this%destrarr, rbuff)
1714 ENDDO
1715 CALL packarray(this%destrarr)
1717CASE(opttype_d)
1718 READ(optarg,'(F20.0)',err=102)this%destd
1719CASE(opttype_darr)
1722 DO WHILE(.NOT.csv_record_end(arrparser))
1724 CALL insert(this%destdarr, dbuff)
1725 ENDDO
1726 CALL packarray(this%destdarr)
1728CASE(opttype_l)
1729 this%destl = .true.
1730CASE(opttype_count)
1731 this%destcount = this%destcount + 1
1732CASE(opttype_help)
1733 status = optionparser_help
1734 SELECT CASE(optarg) ! set help format
1735 CASE('md', 'markdown')
1736 this%helpformat = 1
1737 CASE('htmlform')
1738 this%helpformat = 2
1739 END SELECT
1740END SELECT
1741
1742RETURN
1743
1744100 status = optionparser_err
1745CALL l4f_log(l4f_error, &
1746 'in optionparser, argument '''//trim(optarg)//''' not valid as integer')
1747RETURN
1748102 status = optionparser_err
1749CALL l4f_log(l4f_error, &
1750 'in optionparser, argument '''//trim(optarg)//''' not valid as real')
1751RETURN
1752
1753END FUNCTION option_found
1754
1755
1756! Return a string which gives a short representation of the
1757! option \a this, without help message. The resulting string is quite
1758! long and it should be trimmed with the \a TRIM() intrinsic
1759! function.
1760FUNCTION option_format_opt(this) RESULT(format_opt)
1761TYPE(option),INTENT(in) :: this
1762
1763CHARACTER(len=100) :: format_opt
1764
1765CHARACTER(len=20) :: argname
1766
1767SELECT CASE(this%opttype)
1768CASE(opttype_c)
1769 argname = 'STRING'
1770CASE(opttype_i)
1771 argname = 'INT'
1772CASE(opttype_iarr)
1773 argname = 'INT[,INT...]'
1774CASE(opttype_r, opttype_d)
1775 argname = 'REAL'
1776CASE(opttype_rarr, opttype_darr)
1777 argname = 'REAL[,REAL...]'
1778CASE default
1779 argname = ''
1780END SELECT
1781
1782format_opt = ''
1783IF (this%short_opt /= '') THEN
1784 format_opt(len_trim(format_opt)+1:) = ' -'//this%short_opt
1785 IF (argname /= '') THEN
1786 format_opt(len_trim(format_opt)+1:) = ' '//trim(argname)
1787 ENDIF
1788ENDIF
1789IF (this%short_opt /= '' .AND. this%long_opt /= '') THEN
1790 format_opt(len_trim(format_opt)+1:) = ','
1791ENDIF
1792IF (this%long_opt /= '') THEN
1793 format_opt(len_trim(format_opt)+1:) = ' --'//this%long_opt
1794 IF (argname /= '') THEN
1795 format_opt(len_trim(format_opt)+1:) = '='//trim(argname)
1796 ENDIF
1797ENDIF
1798
1799END FUNCTION option_format_opt
1800
1801
1802! print on stdout a human-readable text representation of a single option
1803SUBROUTINE option_format_help(this, ncols)
1804TYPE(option),INTENT(in) :: this
1805INTEGER,INTENT(in) :: ncols
1806
1807INTEGER :: j
1808INTEGER, PARAMETER :: indent = 10
1809TYPE(line_split) :: help_line
1810
1811
1812IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
1813 IF (ALLOCATED(this%help_msg)) THEN
1814! help2man is quite picky about the treatment of arbitrary lines
1815! within options, the only universal way seems to be unindented lines
1816! with an empty line before and after
1817 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
1818 WRITE(*,'()')
1819 DO j = 1, line_split_get_nlines(help_line)
1820 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1821 ENDDO
1823 WRITE(*,'()')
1824 ENDIF
1825ELSE ! ordinary option
1826! print option brief representation
1827 WRITE(*,'(A)')trim(option_format_opt(this))
1828! print option help
1829 IF (ALLOCATED(this%help_msg)) THEN
1830 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
1831 DO j = 1, line_split_get_nlines(help_line)
1832 WRITE(*,'(T10,A)')trim(line_split_get_line(help_line,j))
1833 ENDDO
1835 ENDIF
1836ENDIF
1837
1838END SUBROUTINE option_format_help
1839
1840
1841! print on stdout a markdown representation of a single option
1842SUBROUTINE option_format_md(this, ncols)
1843TYPE(option),INTENT(in) :: this
1844INTEGER,INTENT(in) :: ncols
1845
1846INTEGER :: j
1847INTEGER, PARAMETER :: indent = 2
1848TYPE(line_split) :: help_line
1849
1850IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
1851 IF (ALLOCATED(this%help_msg)) THEN
1852 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
1853 WRITE(*,'()')
1854 DO j = 1, line_split_get_nlines(help_line)
1855 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1856 ENDDO
1858 WRITE(*,'()')
1859 ENDIF
1860ELSE ! ordinary option
1861! print option brief representation
1862 WRITE(*,'(''`'',A,''`'')')trim(option_format_opt(this))
1863! print option help
1864 IF (ALLOCATED(this%help_msg)) THEN
1865 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
1866 DO j = 1, line_split_get_nlines(help_line)
1867 WRITE(*,'(''> '',A)')trim(line_split_get_line(help_line,j))
1868 ENDDO
1870 WRITE(*,'()')
1871 ENDIF
1872ENDIF
1873
1874END SUBROUTINE option_format_md
1875
1876
1877! print on stdout an html form representation of a single option
1878SUBROUTINE option_format_htmlform(this)
1879TYPE(option),INTENT(in) :: this
1880
1881CHARACTER(len=80) :: opt_name, opt_id, opt_default ! check len of default
1882
1883IF (.NOT.c_e(this)) RETURN
1884IF (this%long_opt == '') THEN
1885 opt_name = this%short_opt
1886 opt_id = 'short_opt_'//this%short_opt
1887ELSE
1888 opt_name = this%long_opt
1889 opt_id = this%long_opt
1890ENDIF
1891
1892SELECT CASE(this%opttype)
1893CASE(opttype_c)
1894 CALL option_format_html_openspan('text')
1895
1896 IF (this%has_default .AND. ASSOCIATED(this%destc) .AND. this%destclen > 0) THEN
1897! opt_default = TRANSFER(this%destc(1:MIN(LEN(opt_default),this%destclen)), &
1898! opt_default) ! improve
1899 opt_default = ''
1900 WRITE(*,'(A)')' value="'//trim(opt_default)//'"'
1901 ENDIF
1902 CALL option_format_html_help()
1903 CALL option_format_html_closespan()
1904
1905CASE(opttype_i,opttype_r,opttype_d)
1906 CALL option_format_html_openspan('text')
1907 IF (this%has_default) THEN
1908 SELECT CASE(this%opttype)
1909 CASE(opttype_i)
1911! todo CASE(opttype_iarr)
1912 CASE(opttype_r)
1914 CASE(opttype_d)
1916 END SELECT
1917 ENDIF
1918 CALL option_format_html_help()
1919 CALL option_format_html_closespan()
1920
1921! todo CASE(opttype_iarr)
1922
1923CASE(opttype_l)
1924 CALL option_format_html_openspan('checkbox')
1925 CALL option_format_html_help()
1926 CALL option_format_html_closespan()
1927
1928CASE(opttype_count)
1929 CALL option_format_html_openspan('number')
1930 CALL option_format_html_help()
1931 CALL option_format_html_closespan()
1932
1933CASE(opttype_sep)
1934END SELECT
1935
1936
1937CONTAINS
1938
1939SUBROUTINE option_format_html_openspan(formtype)
1940CHARACTER(len=*),INTENT(in) :: formtype
1941
1942WRITE(*,'(A)')'<span class="libsim_optbox" id="span_'//trim(opt_id)//'">'//trim(opt_name)//':'
1943! size=? maxlen=?
1944WRITE(*,'(A)')'<input class_"libsim_opt" id="'//trim(opt_id)//'" type="'//formtype// &
1945 '" name="'//trim(opt_id)//'" '
1946
1947END SUBROUTINE option_format_html_openspan
1948
1949SUBROUTINE option_format_html_closespan()
1950
1951WRITE(*,'(A)')'/></span>'
1952
1953END SUBROUTINE option_format_html_closespan
1954
1955SUBROUTINE option_format_html_help()
1956INTEGER :: j
1957TYPE(line_split) :: help_line
1958CHARACTER(len=20) :: form
1959
1960IF (ALLOCATED(this%help_msg)) THEN
1961 WRITE(*,'(A,$)')' title="'
1962
1963 help_line = line_split_new(cstr_to_fchar(this%help_msg), 80)
1964 form = '(A,'' '')'
1965 DO j = 1, line_split_get_nlines(help_line)
1966 IF (j == line_split_get_nlines(help_line)) form = '(A,''"'',$)'
1967 WRITE(*,form)trim(line_split_get_line(help_line,j)) ! lines should be properly quoted here
1968 ENDDO
1969
1970ENDIF
1971
1972END SUBROUTINE option_format_html_help
1973
1974END SUBROUTINE option_format_htmlform
1975
1976
1977FUNCTION option_c_e(this) RESULT(c_e)
1978TYPE(option),INTENT(in) :: this
1979
1980LOGICAL :: c_e
1981
1982c_e = this%long_opt /= ' ' .OR. this%short_opt /= ' '
1983
1984END FUNCTION option_c_e
1985
1986
1990FUNCTION optionparser_new(usage_msg, description_msg) RESULT(this)
1991CHARACTER(len=*), INTENT(in), OPTIONAL :: usage_msg
1992CHARACTER(len=*), INTENT(in), OPTIONAL :: description_msg
1993
1994TYPE(optionparser) :: this
1995
1996IF (PRESENT(usage_msg)) THEN
1997 CALL fchar_to_cstr_alloc(trim(usage_msg), this%usage_msg)
1998ELSE
1999 NULLIFY(this%usage_msg)
2000ENDIF
2001IF (PRESENT(description_msg)) THEN
2002 CALL fchar_to_cstr_alloc(trim(description_msg), this%description_msg)
2003ELSE
2004 NULLIFY(this%description_msg)
2005ENDIF
2006
2007END FUNCTION optionparser_new
2008
2009
2010SUBROUTINE optionparser_delete(this)
2011TYPE(optionparser),INTENT(inout) :: this
2012
2013IF (ASSOCIATED(this%usage_msg)) DEALLOCATE(this%usage_msg)
2014IF (ASSOCIATED(this%description_msg)) DEALLOCATE(this%description_msg)
2016
2017END SUBROUTINE optionparser_delete
2018
2019
2027SUBROUTINE optionparser_add_c(this, short_opt, long_opt, dest, default, help, isopt)
2028TYPE(optionparser),INTENT(inout) :: this
2029CHARACTER(len=*),INTENT(in) :: short_opt
2030CHARACTER(len=*),INTENT(in) :: long_opt
2031CHARACTER(len=*),TARGET :: dest
2032CHARACTER(len=*),OPTIONAL :: default
2033CHARACTER(len=*),OPTIONAL :: help
2034LOGICAL,INTENT(in),OPTIONAL :: isopt
2035
2036CHARACTER(LEN=60) :: cdefault
2037INTEGER :: i
2038TYPE(option) :: myoption
2039
2040
2041IF (PRESENT(default)) THEN
2043ELSE
2044 cdefault = ''
2045ENDIF
2046
2047! common initialisation
2048myoption = option_new(short_opt, long_opt, cdefault, help)
2049IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2050
2051myoption%destc => dest(1:1)
2052myoption%destclen = len(dest) ! needed to avoid exceeding the length of dest
2053IF (PRESENT(default)) &
2054 CALL dirty_char_assignment(myoption%destc, myoption%destclen, default)
2055!IF (PRESENT(default)) myoption%destc(1:myoption%destclen) = default
2056myoption%opttype = opttype_c
2057IF (optio_log(isopt)) THEN
2058 myoption%need_arg = 1
2059ELSE
2060 myoption%need_arg = 2
2061ENDIF
2062
2063i = arrayof_option_append(this%options, myoption)
2064
2065END SUBROUTINE optionparser_add_c
2066
2067
2074SUBROUTINE optionparser_add_i(this, short_opt, long_opt, dest, default, help)
2075TYPE(optionparser),INTENT(inout) :: this
2076CHARACTER(len=*),INTENT(in) :: short_opt
2077CHARACTER(len=*),INTENT(in) :: long_opt
2078INTEGER,TARGET :: dest
2079INTEGER,OPTIONAL :: default
2080CHARACTER(len=*),OPTIONAL :: help
2081
2082CHARACTER(LEN=40) :: cdefault
2083INTEGER :: i
2084TYPE(option) :: myoption
2085
2086IF (PRESENT(default)) THEN
2088ELSE
2089 cdefault = ''
2090ENDIF
2091
2092! common initialisation
2093myoption = option_new(short_opt, long_opt, cdefault, help)
2094IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2095
2096myoption%desti => dest
2097IF (PRESENT(default)) myoption%desti = default
2098myoption%opttype = opttype_i
2099myoption%need_arg = 2
2100
2101i = arrayof_option_append(this%options, myoption)
2102
2103END SUBROUTINE optionparser_add_i
2104
2105
2115SUBROUTINE optionparser_add_iarray(this, short_opt, long_opt, dest, default, help)
2116TYPE(optionparser),INTENT(inout) :: this
2117CHARACTER(len=*),INTENT(in) :: short_opt
2118CHARACTER(len=*),INTENT(in) :: long_opt
2119TYPE(arrayof_integer),TARGET :: dest
2120INTEGER,OPTIONAL :: default(:)
2121CHARACTER(len=*),OPTIONAL :: help
2122
2123CHARACTER(LEN=40) :: cdefault
2124INTEGER :: i
2125TYPE(option) :: myoption
2126
2127cdefault = ''
2128IF (PRESENT(default)) THEN
2129 IF (SIZE(default) == 1) THEN
2131 ELSE IF (SIZE(default) > 1) THEN
2133 ENDIF
2134ENDIF
2135
2136! common initialisation
2137myoption = option_new(short_opt, long_opt, cdefault, help)
2138IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2139
2140myoption%destiarr => dest
2141IF (PRESENT(default)) THEN
2142 CALL insert(myoption%destiarr, default)
2143 CALL packarray(myoption%destiarr)
2144ENDIF
2145myoption%opttype = opttype_iarr
2146myoption%need_arg = 2
2147
2148i = arrayof_option_append(this%options, myoption)
2149
2150END SUBROUTINE optionparser_add_iarray
2151
2152
2159SUBROUTINE optionparser_add_r(this, short_opt, long_opt, dest, default, help)
2160TYPE(optionparser),INTENT(inout) :: this
2161CHARACTER(len=*),INTENT(in) :: short_opt
2162CHARACTER(len=*),INTENT(in) :: long_opt
2163REAL,TARGET :: dest
2164REAL,OPTIONAL :: default
2165CHARACTER(len=*),OPTIONAL :: help
2166
2167CHARACTER(LEN=40) :: cdefault
2168INTEGER :: i
2169TYPE(option) :: myoption
2170
2171IF (PRESENT(default)) THEN
2173ELSE
2174 cdefault = ''
2175ENDIF
2176
2177! common initialisation
2178myoption = option_new(short_opt, long_opt, cdefault, help)
2179IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2180
2181myoption%destr => dest
2182IF (PRESENT(default)) myoption%destr = default
2183myoption%opttype = opttype_r
2184myoption%need_arg = 2
2185
2186i = arrayof_option_append(this%options, myoption)
2187
2188END SUBROUTINE optionparser_add_r
2189
2190
2200SUBROUTINE optionparser_add_rarray(this, short_opt, long_opt, dest, default, help)
2201TYPE(optionparser),INTENT(inout) :: this
2202CHARACTER(len=*),INTENT(in) :: short_opt
2203CHARACTER(len=*),INTENT(in) :: long_opt
2204TYPE(arrayof_real),TARGET :: dest
2205REAL,OPTIONAL :: default(:)
2206CHARACTER(len=*),OPTIONAL :: help
2207
2208CHARACTER(LEN=40) :: cdefault
2209INTEGER :: i
2210TYPE(option) :: myoption
2211
2212cdefault = ''
2213IF (PRESENT(default)) THEN
2214 IF (SIZE(default) == 1) THEN
2216 ELSE IF (SIZE(default) > 1) THEN
2218 ENDIF
2219ENDIF
2220
2221! common initialisation
2222myoption = option_new(short_opt, long_opt, cdefault, help)
2223IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2224
2225myoption%destrarr => dest
2226IF (PRESENT(default)) THEN
2227 CALL insert(myoption%destrarr, default)
2228 CALL packarray(myoption%destrarr)
2229ENDIF
2230myoption%opttype = opttype_rarr
2231myoption%need_arg = 2
2232
2233i = arrayof_option_append(this%options, myoption)
2234
2235END SUBROUTINE optionparser_add_rarray
2236
2237
2244SUBROUTINE optionparser_add_d(this, short_opt, long_opt, dest, default, help)
2245TYPE(optionparser),INTENT(inout) :: this
2246CHARACTER(len=*),INTENT(in) :: short_opt
2247CHARACTER(len=*),INTENT(in) :: long_opt
2248DOUBLE PRECISION,TARGET :: dest
2249DOUBLE PRECISION,OPTIONAL :: default
2250CHARACTER(len=*),OPTIONAL :: help
2251
2252CHARACTER(LEN=40) :: cdefault
2253INTEGER :: i
2254TYPE(option) :: myoption
2255
2256IF (PRESENT(default)) THEN
2257 IF (c_e(default)) THEN
2259 ELSE
2261 ENDIF
2262ELSE
2263 cdefault = ''
2264ENDIF
2265
2266! common initialisation
2267myoption = option_new(short_opt, long_opt, cdefault, help)
2268IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2269
2270myoption%destd => dest
2271IF (PRESENT(default)) myoption%destd = default
2272myoption%opttype = opttype_d
2273myoption%need_arg = 2
2274
2275i = arrayof_option_append(this%options, myoption)
2276
2277END SUBROUTINE optionparser_add_d
2278
2279
2289SUBROUTINE optionparser_add_darray(this, short_opt, long_opt, dest, default, help)
2290TYPE(optionparser),INTENT(inout) :: this
2291CHARACTER(len=*),INTENT(in) :: short_opt
2292CHARACTER(len=*),INTENT(in) :: long_opt
2293TYPE(arrayof_doubleprecision),TARGET :: dest
2294DOUBLE PRECISION,OPTIONAL :: default(:)
2295CHARACTER(len=*),OPTIONAL :: help
2296
2297CHARACTER(LEN=40) :: cdefault
2298INTEGER :: i
2299TYPE(option) :: myoption
2300
2301cdefault = ''
2302IF (PRESENT(default)) THEN
2303 IF (SIZE(default) == 1) THEN
2305 ELSE IF (SIZE(default) > 1) THEN
2307 ENDIF
2308ENDIF
2309
2310! common initialisation
2311myoption = option_new(short_opt, long_opt, cdefault, help)
2312IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2313
2314myoption%destdarr => dest
2315IF (PRESENT(default)) THEN
2316 CALL insert(myoption%destdarr, default)
2317 CALL packarray(myoption%destdarr)
2318ENDIF
2319myoption%opttype = opttype_darr
2320myoption%need_arg = 2
2321
2322i = arrayof_option_append(this%options, myoption)
2323
2324END SUBROUTINE optionparser_add_darray
2325
2326
2333SUBROUTINE optionparser_add_l(this, short_opt, long_opt, dest, help)
2334TYPE(optionparser),INTENT(inout) :: this
2335CHARACTER(len=*),INTENT(in) :: short_opt
2336CHARACTER(len=*),INTENT(in) :: long_opt
2337LOGICAL,TARGET :: dest
2338CHARACTER(len=*),OPTIONAL :: help
2339
2340INTEGER :: i
2341TYPE(option) :: myoption
2342
2343! common initialisation
2344myoption = option_new(short_opt, long_opt, '', help)
2345IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2346
2347myoption%destl => dest
2348myoption%destl = .false. ! unconditionally set to false, option can only set it to true
2349myoption%opttype = opttype_l
2350myoption%need_arg = 0
2351
2352i = arrayof_option_append(this%options, myoption)
2353
2354END SUBROUTINE optionparser_add_l
2355
2356
2361SUBROUTINE optionparser_add_count(this, short_opt, long_opt, dest, start, help)
2362TYPE(optionparser),INTENT(inout) :: this
2363CHARACTER(len=*),INTENT(in) :: short_opt
2364CHARACTER(len=*),INTENT(in) :: long_opt
2365INTEGER,TARGET :: dest
2366INTEGER,OPTIONAL :: start
2367CHARACTER(len=*),OPTIONAL :: help
2368
2369INTEGER :: i
2370TYPE(option) :: myoption
2371
2372! common initialisation
2373myoption = option_new(short_opt, long_opt, '', help)
2374IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2375
2376myoption%destcount => dest
2377IF (PRESENT(start)) myoption%destcount = start
2378myoption%opttype = opttype_count
2379myoption%need_arg = 0
2380
2381i = arrayof_option_append(this%options, myoption)
2382
2383END SUBROUTINE optionparser_add_count
2384
2385
2400SUBROUTINE optionparser_add_help(this, short_opt, long_opt, help)
2401TYPE(optionparser),INTENT(inout) :: this
2402CHARACTER(len=*),INTENT(in) :: short_opt
2403CHARACTER(len=*),INTENT(in) :: long_opt
2404CHARACTER(len=*),OPTIONAL :: help
2405
2406INTEGER :: i
2407TYPE(option) :: myoption
2408
2409! common initialisation
2410myoption = option_new(short_opt, long_opt, '', help)
2411IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2412
2413myoption%opttype = opttype_help
2414myoption%need_arg = 1
2415
2416i = arrayof_option_append(this%options, myoption)
2417
2418END SUBROUTINE optionparser_add_help
2419
2420
2431SUBROUTINE optionparser_add_sep(this, help)
2432TYPE(optionparser),INTENT(inout) :: this
2433!CHARACTER(len=*),INTENT(in) :: short_opt !< the short option (may be empty)
2434!CHARACTER(len=*),INTENT(in) :: long_opt !< the long option (may be empty)
2435CHARACTER(len=*) :: help
2436
2437INTEGER :: i
2438TYPE(option) :: myoption
2439
2440! common initialisation
2441myoption = option_new('_', '_', '', help)
2442IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2443
2444myoption%opttype = opttype_sep
2445myoption%need_arg = 0
2446
2447i = arrayof_option_append(this%options, myoption)
2448
2449END SUBROUTINE optionparser_add_sep
2450
2451
2461SUBROUTINE optionparser_parse(this, nextarg, status)
2462TYPE(optionparser),INTENT(inout) :: this
2463INTEGER,INTENT(out) :: nextarg
2464INTEGER,INTENT(out) :: status
2465
2466INTEGER :: i, j, endopt, indeq, iargc
2467CHARACTER(len=16384) :: arg, optarg
2468
2469status = optionparser_ok
2470i = 1
2471DO WHILE(i <= iargc())
2472 CALL getarg(i, arg)
2473 IF (arg == '--') THEN ! explicit end of options
2474 i = i + 1 ! skip present option (--)
2475 EXIT
2476 ELSE IF (arg == '-') THEN ! a single - is not an option
2477 EXIT
2478 ELSE IF (arg(1:2) == '--') THEN ! long option
2480 IF (indeq /= 0) THEN ! = present
2481 endopt = indeq - 1
2482 ELSE ! no =
2483 endopt = len_trim(arg)
2484 ENDIF
2485 find_longopt: DO j = 1, this%options%arraysize
2486 IF (this%options%array(j)%long_opt == arg(3:endopt)) THEN ! found option
2487 SELECT CASE(this%options%array(j)%need_arg)
2488 CASE(2) ! compulsory
2489 IF (indeq /= 0) THEN
2490 optarg = arg(indeq+1:)
2491 status = max(option_found(this%options%array(j), optarg), &
2492 status)
2493 ELSE
2494 IF (i < iargc()) THEN
2495 i=i+1
2496 CALL getarg(i, optarg)
2497 status = max(option_found(this%options%array(j), optarg), &
2498 status)
2499 ELSE
2500 status = optionparser_err
2501 CALL l4f_log(l4f_error, &
2502 'in optionparser, option '''//trim(arg)//''' requires an argument')
2503 ENDIF
2504 ENDIF
2505 CASE(1) ! optional
2506 IF (indeq /= 0) THEN
2507 optarg = arg(indeq+1:)
2508 ELSE
2509 IF (i < iargc()) THEN
2510 CALL getarg(i+1, optarg)
2511 IF (optarg(1:1) == '-') THEN
2512 optarg = cmiss ! refused
2513 ELSE
2514 i=i+1 ! accepted
2515 ENDIF
2516 ELSE
2517 optarg = cmiss ! refused
2518 ENDIF
2519 ENDIF
2520 status = max(option_found(this%options%array(j), optarg), &
2521 status)
2522 CASE(0)
2523 status = max(option_found(this%options%array(j)), &
2524 status)
2525 END SELECT
2526 EXIT find_longopt
2527 ENDIF
2528 ENDDO find_longopt
2529 IF (j > this%options%arraysize) THEN
2530 status = optionparser_err
2531 CALL l4f_log(l4f_error, &
2532 'in optionparser, option '''//trim(arg)//''' not valid')
2533 ENDIF
2534 ELSE IF (arg(1:1) == '-') THEN ! short option
2535 find_shortopt: DO j = 1, this%options%arraysize
2536 IF (this%options%array(j)%short_opt == arg(2:2)) THEN ! found option
2537 SELECT CASE(this%options%array(j)%need_arg)
2538 CASE(2) ! compulsory
2539 IF (len_trim(arg) > 2) THEN
2540 optarg = arg(3:)
2541 status = max(option_found(this%options%array(j), optarg), &
2542 status)
2543 ELSE
2544 IF (i < iargc()) THEN
2545 i=i+1
2546 CALL getarg(i, optarg)
2547 status = max(option_found(this%options%array(j), optarg), &
2548 status)
2549 ELSE
2550 status = optionparser_err
2551 CALL l4f_log(l4f_error, &
2552 'in optionparser, option '''//trim(arg)//''' requires an argument')
2553 ENDIF
2554 ENDIF
2555 CASE(1) ! optional
2556 IF (len_trim(arg) > 2) THEN
2557 optarg = arg(3:)
2558 ELSE
2559 IF (i < iargc()) THEN
2560 CALL getarg(i+1, optarg)
2561 IF (optarg(1:1) == '-') THEN
2562 optarg = cmiss ! refused
2563 ELSE
2564 i=i+1 ! accepted
2565 ENDIF
2566 ELSE
2567 optarg = cmiss ! refused
2568 ENDIF
2569 ENDIF
2570 status = max(option_found(this%options%array(j), optarg), &
2571 status)
2572 CASE(0)
2573 status = max(option_found(this%options%array(j)), &
2574 status)
2575 END SELECT
2576 EXIT find_shortopt
2577 ENDIF
2578 ENDDO find_shortopt
2579 IF (j > this%options%arraysize) THEN
2580 status = optionparser_err
2581 CALL l4f_log(l4f_error, &
2582 'in optionparser, option '''//trim(arg)//''' not valid')
2583 ENDIF
2584 ELSE ! unrecognized = end of options
2585 EXIT
2586 ENDIF
2587 i = i + 1
2588ENDDO
2589
2590nextarg = i
2591SELECT CASE(status)
2592CASE(optionparser_err, optionparser_help)
2593 CALL optionparser_printhelp(this)
2594END SELECT
2595
2596END SUBROUTINE optionparser_parse
2597
2598
2602SUBROUTINE optionparser_printhelp(this)
2603TYPE(optionparser),INTENT(in) :: this
2604
2605INTEGER :: i, form
2606
2607form = 0
2608DO i = 1, this%options%arraysize ! loop over options
2609 IF (this%options%array(i)%opttype == opttype_help) THEN
2610 form = this%options%array(i)%helpformat
2611 ENDIF
2612ENDDO
2613
2614SELECT CASE(form)
2615CASE(0)
2616 CALL optionparser_printhelptxt(this)
2617CASE(1)
2618 CALL optionparser_printhelpmd(this)
2619CASE(2)
2620 CALL optionparser_printhelphtmlform(this)
2621END SELECT
2622
2623END SUBROUTINE optionparser_printhelp
2624
2625
2629SUBROUTINE optionparser_printhelptxt(this)
2630TYPE(optionparser),INTENT(in) :: this
2631
2632INTEGER :: i, j, ncols
2633CHARACTER(len=80) :: buf
2634TYPE(line_split) :: help_line
2635
2636ncols = default_columns()
2637
2638! print usage message
2639IF (ASSOCIATED(this%usage_msg)) THEN
2640 help_line = line_split_new(cstr_to_fchar(this%usage_msg), ncols)
2641 DO j = 1, line_split_get_nlines(help_line)
2642 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2643 ENDDO
2645ELSE
2646 CALL getarg(0, buf)
2648 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2649 WRITE(*,'(A)')'Usage: '//trim(buf(i+1:))//' [options] [arguments]'
2650ENDIF
2651
2652! print description message
2653IF (ASSOCIATED(this%description_msg)) THEN
2654 WRITE(*,'()')
2655 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2656 DO j = 1, line_split_get_nlines(help_line)
2657 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2658 ENDDO
2660ENDIF
2661
2662WRITE(*,'(/,A)')'Options:'
2663
2664DO i = 1, this%options%arraysize ! loop over options
2665 CALL option_format_help(this%options%array(i), ncols)
2666ENDDO
2667
2668END SUBROUTINE optionparser_printhelptxt
2669
2670
2674SUBROUTINE optionparser_printhelpmd(this)
2675TYPE(optionparser),INTENT(in) :: this
2676
2677INTEGER :: i, j, ncols
2678CHARACTER(len=80) :: buf
2679TYPE(line_split) :: help_line
2680
2681ncols = default_columns()
2682
2683! print usage message
2684WRITE(*,'(A)')'### Synopsis'
2685
2686IF (ASSOCIATED(this%usage_msg)) THEN
2687 help_line = line_split_new(mdquote_usage_msg(cstr_to_fchar(this%usage_msg)), ncols)
2688 DO j = 1, line_split_get_nlines(help_line)
2689 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2690 ENDDO
2692ELSE
2693 CALL getarg(0, buf)
2695 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2696 WRITE(*,'(A)')'Usage: `'//trim(buf(i+1:))//' [options] [arguments]`'
2697ENDIF
2698
2699! print description message
2700IF (ASSOCIATED(this%description_msg)) THEN
2701 WRITE(*,'()')
2702 WRITE(*,'(A)')'### Description'
2703 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2704 DO j = 1, line_split_get_nlines(help_line)
2705 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2706 ENDDO
2708
2709ENDIF
2710
2711WRITE(*,'(/,A)')'### Options'
2712
2713DO i = 1, this%options%arraysize ! loop over options
2714 CALL option_format_md(this%options%array(i), ncols)
2715ENDDO
2716
2717CONTAINS
2718
2719FUNCTION mdquote_usage_msg(usage_msg)
2720CHARACTER(len=*),INTENT(in) :: usage_msg
2721
2722CHARACTER(len=LEN(usage_msg)+2) :: mdquote_usage_msg
2723INTEGER :: colon
2724
2726IF (colon > 0 .AND. colon < len(usage_msg)-1) THEN
2727 mdquote_usage_msg = usage_msg(:colon+1)//'`'//usage_msg(colon+2:)//'`'
2728ELSE
2729 mdquote_usage_msg = usage_msg
2730ENDIF
2731
2732END FUNCTION mdquote_usage_msg
2733
2734END SUBROUTINE optionparser_printhelpmd
2735
2739SUBROUTINE optionparser_printhelphtmlform(this)
2740TYPE(optionparser),INTENT(in) :: this
2741
2742INTEGER :: i
2743
2744DO i = 1, this%options%arraysize ! loop over options
2745 CALL option_format_htmlform(this%options%array(i))
2746ENDDO
2747
2748WRITE(*,'(A)')'<input class="libsim_sub" type="submit" value="runprogram" />'
2749
2750END SUBROUTINE optionparser_printhelphtmlform
2751
2752
2753SUBROUTINE optionparser_make_completion(this)
2754TYPE(optionparser),INTENT(in) :: this
2755
2756INTEGER :: i
2757CHARACTER(len=512) :: buf
2758
2759CALL getarg(0, buf)
2760
2761WRITE(*,'(A/A/A)')'_'//trim(buf)//'()','{','local cur'
2762
2763WRITE(*,'(A/A/A/A)')'COMPREPLY=()','cur=${COMP_WORDS[COMP_CWORD]}', &
2764 'case "$cur" in','-*)'
2765
2766!-*)
2767! COMPREPLY=( $( compgen -W
2768DO i = 1, this%options%arraysize ! loop over options
2769 IF (this%options%array(i)%need_arg == 2) THEN
2770 ENDIF
2771ENDDO
2772
2773WRITE(*,'(A/A/A)')'esac','return 0','}'
2774
2775END SUBROUTINE optionparser_make_completion
2776
2777
2778SUBROUTINE dirty_char_assignment(destc, destclen, src)
2780IMPLICIT NONE
2781
2782CHARACTER(len=1) :: destc(*)
2783CHARACTER(len=*) :: src
2784INTEGER :: destclen
2785
2786INTEGER :: i
2787
2788DO i = 1, min(destclen, len(src))
2789 destc(i) = src(i:i)
2790ENDDO
2791DO i = len(src)+1, destclen
2792 destc(i) = ' '
2793ENDDO
2794
2795END SUBROUTINE dirty_char_assignment
2796
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 |