libsim Versione 7.1.11

◆ optionparser_add_help()

subroutine, public optionparser_add_help ( type(optionparser), intent(inout)  this,
character(len=*), intent(in)  short_opt,
character(len=*), intent(in)  long_opt,
character(len=*), optional  help 
)

Add a new help option, with an optional argument.

When parsing will be performed, the full help message will be printed if this option is encountered. The message can be directly printed as well by calling the optparser_printhelp method. The optional argument given by the user to the option specifies the format of the help message, it can be one fo the following:

  • txt or no extra argument: generic plain-text format suitable for printing to screen and to be fed to the help2man command for generating man pages
  • md or markdown: print help in markdown format, suitable for wiki/github/doxygen etc. pages
  • htmlform: print help as an html form suitable for providing the options through a web interface (experimental)
    Parametri
    [in,out]thisoptionparser object
    [in]short_optthe short option (may be empty)
    [in]long_optthe long option (may be empty)
    helpthe help message that will be formatted and pretty-printed on screen

Definizione alla linea 1471 del file optionparser_class.F90.

1472! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1473! authors:
1474! Davide Cesari <dcesari@arpa.emr.it>
1475! Paolo Patruno <ppatruno@arpa.emr.it>
1476
1477! This program is free software; you can redistribute it and/or
1478! modify it under the terms of the GNU General Public License as
1479! published by the Free Software Foundation; either version 2 of
1480! the License, or (at your option) any later version.
1481
1482! This program is distributed in the hope that it will be useful,
1483! but WITHOUT ANY WARRANTY; without even the implied warranty of
1484! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1485! GNU General Public License for more details.
1495#include "config.h"
1496
1497MODULE optionparser_class
1498USE log4fortran
1499USE err_handling
1500USE kinds
1504IMPLICIT NONE
1505
1506
1507! private class
1508TYPE option
1509 CHARACTER(len=1) :: short_opt=''
1510 CHARACTER(len=80) :: long_opt=''
1511 INTEGER :: opttype=-1
1512 INTEGER :: need_arg=0 ! 0=no, 1=optional, 2=yes, was .FALSE.
1513 LOGICAL :: has_default=.false.
1514 CHARACTER(len=1),POINTER :: destc=>null()
1515 INTEGER :: destclen=0
1516 INTEGER :: helpformat=0 ! 0=txt, 1=markdown, 2=htmlform, improve!
1517 INTEGER,POINTER :: desti=>null()
1518 TYPE(arrayof_integer),POINTER :: destiarr=>null()
1519 REAL,POINTER :: destr=>null()
1520 TYPE(arrayof_real),POINTER :: destrarr=>null()
1521 DOUBLE PRECISION, POINTER :: destd=>null()
1522 TYPE(arrayof_doubleprecision),POINTER :: destdarr=>null()
1523 LOGICAL,POINTER :: destl=>null()
1524 TYPE(arrayof_logical),POINTER :: destlarr=>null()
1525 INTEGER,POINTER :: destcount=>null()
1526 INTEGER(kind=int_b),ALLOCATABLE :: help_msg(:)
1527END TYPE option
1528
1529#define ARRAYOF_ORIGTYPE TYPE(option)
1530#define ARRAYOF_TYPE arrayof_option
1531#define ARRAYOF_ORIGDESTRUCTOR(x) CALL option_delete(x)
1532#define ARRAYOF_PRIVATE 1
1533#include "arrayof_pre_nodoc.F90"
1534! from arrayof
1535!PUBLIC insert, append, remove, packarray
1536!PUBLIC insert_unique, append_unique
1537
1615TYPE optionparser
1616 PRIVATE
1617 INTEGER(kind=int_b),POINTER :: usage_msg(:), description_msg(:)
1618 TYPE(arrayof_option) :: options
1619 LOGICAL :: httpmode=.false.
1620END TYPE optionparser
1621
1622
1626INTERFACE optionparser_add
1627 MODULE PROCEDURE optionparser_add_c, optionparser_add_i, optionparser_add_r, &
1628 optionparser_add_d, optionparser_add_l, &
1629 optionparser_add_iarray, optionparser_add_rarray, optionparser_add_darray
1630END INTERFACE
1631
1632INTERFACE c_e
1633 MODULE PROCEDURE option_c_e
1634END INTERFACE
1635
1643INTERFACE delete
1644 MODULE PROCEDURE optionparser_delete!?, option_delete
1645END INTERFACE
1646
1647
1648INTEGER,PARAMETER :: opttype_c = 1, opttype_i = 2, opttype_r = 3, &
1649 opttype_d = 4, opttype_l = 5, opttype_count = 6, opttype_help = 7, &
1650 opttype_sep = 8, opttype_carr = 11, opttype_iarr = 12, opttype_rarr = 13, &
1651 opttype_darr = 14, opttype_larr = 15
1652
1653INTEGER,PARAMETER :: optionparser_ok = 0
1654INTEGER,PARAMETER :: optionparser_help = 1
1655INTEGER,PARAMETER :: optionparser_err = 2
1656
1657
1658PRIVATE
1659PUBLIC optionparser, optionparser_new, delete, optionparser_add, &
1660 optionparser_add_count, optionparser_add_help, optionparser_add_sep, &
1661 optionparser_parse, optionparser_printhelp, &
1662 optionparser_ok, optionparser_help, optionparser_err
1663
1664
1665CONTAINS
1666
1667#include "arrayof_post_nodoc.F90"
1668
1669! Constructor for the option class
1670FUNCTION option_new(short_opt, long_opt, default, help) RESULT(this)
1671CHARACTER(len=*),INTENT(in) :: short_opt
1672CHARACTER(len=*),INTENT(in) :: long_opt
1673CHARACTER(len=*),INTENT(in) :: default
1674CHARACTER(len=*),OPTIONAL :: help
1675TYPE(option) :: this
1676
1677IF (short_opt == '' .AND. long_opt == '') THEN
1678#ifdef DEBUG
1679! programmer error condition, option empty
1680 CALL l4f_log(l4f_error, 'in optionparser, both short and long options empty')
1681 CALL raise_fatal_error()
1682#else
1683 CALL l4f_log(l4f_warn, 'in optionparser, both short and long options empty')
1684#endif
1685 RETURN
1686ENDIF
1687
1688this%short_opt = short_opt
1689this%long_opt = long_opt
1690IF (PRESENT(help)) THEN
1691 this%help_msg = fchar_to_cstr(trim(help)//trim(default)) ! f2003 automatic alloc
1692ENDIF
1693this%has_default = (len_trim(default) > 0)
1694
1695END FUNCTION option_new
1696
1697
1698! Destructor for the \a option class, the memory associated with
1699! the object is freed.
1700SUBROUTINE option_delete(this)
1701TYPE(option),INTENT(inout) :: this ! object to destroy
1702
1703IF (ALLOCATED(this%help_msg)) DEALLOCATE(this%help_msg)
1704NULLIFY(this%destc)
1705NULLIFY(this%desti)
1706NULLIFY(this%destr)
1707NULLIFY(this%destd)
1708NULLIFY(this%destl)
1709NULLIFY(this%destcount)
1710
1711END SUBROUTINE option_delete
1712
1713
1714FUNCTION option_found(this, optarg) RESULT(status)
1715TYPE(option),INTENT(inout) :: this
1716CHARACTER(len=*),INTENT(in),OPTIONAL :: optarg
1717INTEGER :: status
1718
1719TYPE(csv_record) :: arrparser
1720INTEGER :: ibuff
1721REAL :: rbuff
1722DOUBLE PRECISION :: dbuff
1723
1724status = optionparser_ok
1725
1726SELECT CASE(this%opttype)
1727CASE(opttype_c)
1728 CALL dirty_char_assignment(this%destc, this%destclen, trim(optarg))
1729! this%destc(1:this%destclen) = optarg
1730 IF (len_trim(optarg) > this%destclen) THEN
1731 CALL l4f_log(l4f_warn, &
1732 'in optionparser, argument '''//trim(optarg)//''' too long, truncated')
1733 ENDIF
1734CASE(opttype_i)
1735 READ(optarg,'(I12)',err=100)this%desti
1736CASE(opttype_iarr)
1737 CALL delete(this%destiarr) ! delete default values
1738 CALL init(arrparser, optarg)
1739 DO WHILE(.NOT.csv_record_end(arrparser))
1740 CALL csv_record_getfield(arrparser, ibuff)
1741 CALL insert(this%destiarr, ibuff)
1742 ENDDO
1743 CALL packarray(this%destiarr)
1744 CALL delete(arrparser)
1745CASE(opttype_r)
1746 READ(optarg,'(F20.0)',err=102)this%destr
1747CASE(opttype_rarr)
1748 CALL delete(this%destrarr) ! delete default values
1749 CALL init(arrparser, optarg)
1750 DO WHILE(.NOT.csv_record_end(arrparser))
1751 CALL csv_record_getfield(arrparser, rbuff)
1752 CALL insert(this%destrarr, rbuff)
1753 ENDDO
1754 CALL packarray(this%destrarr)
1755 CALL delete(arrparser)
1756CASE(opttype_d)
1757 READ(optarg,'(F20.0)',err=102)this%destd
1758CASE(opttype_darr)
1759 CALL delete(this%destdarr) ! delete default values
1760 CALL init(arrparser, optarg)
1761 DO WHILE(.NOT.csv_record_end(arrparser))
1762 CALL csv_record_getfield(arrparser, dbuff)
1763 CALL insert(this%destdarr, dbuff)
1764 ENDDO
1765 CALL packarray(this%destdarr)
1766 CALL delete(arrparser)
1767CASE(opttype_l)
1768 this%destl = .true.
1769CASE(opttype_count)
1770 this%destcount = this%destcount + 1
1771CASE(opttype_help)
1772 status = optionparser_help
1773 SELECT CASE(optarg) ! set help format
1774 CASE('md', 'markdown')
1775 this%helpformat = 1
1776 CASE('htmlform')
1777 this%helpformat = 2
1778 END SELECT
1779END SELECT
1780
1781RETURN
1782
1783100 status = optionparser_err
1784CALL l4f_log(l4f_error, &
1785 'in optionparser, argument '''//trim(optarg)//''' not valid as integer')
1786RETURN
1787102 status = optionparser_err
1788CALL l4f_log(l4f_error, &
1789 'in optionparser, argument '''//trim(optarg)//''' not valid as real')
1790RETURN
1791
1792END FUNCTION option_found
1793
1794
1795! Return a string which gives a short representation of the
1796! option \a this, without help message. The resulting string is quite
1797! long and it should be trimmed with the \a TRIM() intrinsic
1798! function.
1799FUNCTION option_format_opt(this) RESULT(format_opt)
1800TYPE(option),INTENT(in) :: this
1801
1802CHARACTER(len=100) :: format_opt
1803
1804CHARACTER(len=20) :: argname
1805
1806SELECT CASE(this%opttype)
1807CASE(opttype_c)
1808 argname = 'STRING'
1809CASE(opttype_i)
1810 argname = 'INT'
1811CASE(opttype_iarr)
1812 argname = 'INT[,INT...]'
1813CASE(opttype_r, opttype_d)
1814 argname = 'REAL'
1815CASE(opttype_rarr, opttype_darr)
1816 argname = 'REAL[,REAL...]'
1817CASE default
1818 argname = ''
1819END SELECT
1820
1821format_opt = ''
1822IF (this%short_opt /= '') THEN
1823 format_opt(len_trim(format_opt)+1:) = ' -'//this%short_opt
1824 IF (argname /= '') THEN
1825 format_opt(len_trim(format_opt)+1:) = ' '//trim(argname)
1826 ENDIF
1827ENDIF
1828IF (this%short_opt /= '' .AND. this%long_opt /= '') THEN
1829 format_opt(len_trim(format_opt)+1:) = ','
1830ENDIF
1831IF (this%long_opt /= '') THEN
1832 format_opt(len_trim(format_opt)+1:) = ' --'//this%long_opt
1833 IF (argname /= '') THEN
1834 format_opt(len_trim(format_opt)+1:) = '='//trim(argname)
1835 ENDIF
1836ENDIF
1837
1838END FUNCTION option_format_opt
1839
1840
1841! print on stdout a human-readable text representation of a single option
1842SUBROUTINE option_format_help(this, ncols)
1843TYPE(option),INTENT(in) :: this
1844INTEGER,INTENT(in) :: ncols
1845
1846INTEGER :: j
1847INTEGER, PARAMETER :: indent = 10
1848TYPE(line_split) :: help_line
1849
1850
1851IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
1852 IF (ALLOCATED(this%help_msg)) THEN
1853! help2man is quite picky about the treatment of arbitrary lines
1854! within options, the only universal way seems to be unindented lines
1855! with an empty line before and after
1856 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
1857 WRITE(*,'()')
1858 DO j = 1, line_split_get_nlines(help_line)
1859 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1860 ENDDO
1861 CALL delete(help_line)
1862 WRITE(*,'()')
1863 ENDIF
1864ELSE ! ordinary option
1865! print option brief representation
1866 WRITE(*,'(A)')trim(option_format_opt(this))
1867! print option help
1868 IF (ALLOCATED(this%help_msg)) THEN
1869 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
1870 DO j = 1, line_split_get_nlines(help_line)
1871 WRITE(*,'(T10,A)')trim(line_split_get_line(help_line,j))
1872 ENDDO
1873 CALL delete(help_line)
1874 ENDIF
1875ENDIF
1876
1877END SUBROUTINE option_format_help
1878
1879
1880! print on stdout a markdown representation of a single option
1881SUBROUTINE option_format_md(this, ncols)
1882TYPE(option),INTENT(in) :: this
1883INTEGER,INTENT(in) :: ncols
1884
1885INTEGER :: j
1886INTEGER, PARAMETER :: indent = 2
1887TYPE(line_split) :: help_line
1888
1889IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
1890 IF (ALLOCATED(this%help_msg)) THEN
1891 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
1892 WRITE(*,'()')
1893 DO j = 1, line_split_get_nlines(help_line)
1894 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1895 ENDDO
1896 CALL delete(help_line)
1897 WRITE(*,'()')
1898 ENDIF
1899ELSE ! ordinary option
1900! print option brief representation
1901 WRITE(*,'(''`'',A,''`'')')trim(option_format_opt(this))
1902! print option help
1903 IF (ALLOCATED(this%help_msg)) THEN
1904 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
1905 DO j = 1, line_split_get_nlines(help_line)
1906 WRITE(*,'(''> '',A)')trim(line_split_get_line(help_line,j))
1907 ENDDO
1908 CALL delete(help_line)
1909 WRITE(*,'()')
1910 ENDIF
1911ENDIF
1912
1913END SUBROUTINE option_format_md
1914
1915
1916! print on stdout an html form representation of a single option
1917SUBROUTINE option_format_htmlform(this)
1918TYPE(option),INTENT(in) :: this
1919
1920CHARACTER(len=80) :: opt_name, opt_id, opt_default ! check len of default
1921
1922IF (.NOT.c_e(this)) RETURN
1923IF (this%long_opt == '') THEN
1924 opt_name = this%short_opt
1925 opt_id = 'short_opt_'//this%short_opt
1926ELSE
1927 opt_name = this%long_opt
1928 opt_id = this%long_opt
1929ENDIF
1930
1931SELECT CASE(this%opttype)
1932CASE(opttype_c)
1933 CALL option_format_html_openspan('text')
1934
1935 IF (this%has_default .AND. ASSOCIATED(this%destc) .AND. this%destclen > 0) THEN
1936! opt_default = TRANSFER(this%destc(1:MIN(LEN(opt_default),this%destclen)), &
1937! opt_default) ! improve
1938 opt_default = ''
1939 WRITE(*,'(A)')' value="'//trim(opt_default)//'"'
1940 ENDIF
1941 CALL option_format_html_help()
1942 CALL option_format_html_closespan()
1943
1944CASE(opttype_i,opttype_r,opttype_d)
1945 CALL option_format_html_openspan('text')
1946 IF (this%has_default) THEN
1947 SELECT CASE(this%opttype)
1948 CASE(opttype_i)
1949 WRITE(*,'(3A)')' value="',t2c(this%desti),'"'
1950! todo CASE(opttype_iarr)
1951 CASE(opttype_r)
1952 WRITE(*,'(3A)')' value="',t2c(this%destr),'"'
1953 CASE(opttype_d)
1954 WRITE(*,'(3A)')' value="',t2c(this%destd),'"'
1955 END SELECT
1956 ENDIF
1957 CALL option_format_html_help()
1958 CALL option_format_html_closespan()
1959
1960! todo CASE(opttype_iarr)
1961
1962CASE(opttype_l)
1963 CALL option_format_html_openspan('checkbox')
1964 CALL option_format_html_help()
1965 CALL option_format_html_closespan()
1966
1967CASE(opttype_count)
1968 CALL option_format_html_openspan('number')
1969 CALL option_format_html_help()
1970 CALL option_format_html_closespan()
1971
1972CASE(opttype_sep)
1973END SELECT
1974
1975
1976CONTAINS
1977
1978SUBROUTINE option_format_html_openspan(formtype)
1979CHARACTER(len=*),INTENT(in) :: formtype
1980
1981WRITE(*,'(A)')'<span class="libsim_optbox" id="span_'//trim(opt_id)//'">'//trim(opt_name)//':'
1982! size=? maxlen=?
1983WRITE(*,'(A)')'<input class_"libsim_opt" id="'//trim(opt_id)//'" type="'//formtype// &
1984 '" name="'//trim(opt_id)//'" '
1985
1986END SUBROUTINE option_format_html_openspan
1987
1988SUBROUTINE option_format_html_closespan()
1989
1990WRITE(*,'(A)')'/></span>'
1991
1992END SUBROUTINE option_format_html_closespan
1993
1994SUBROUTINE option_format_html_help()
1995INTEGER :: j
1996TYPE(line_split) :: help_line
1997CHARACTER(len=20) :: form
1998
1999IF (ALLOCATED(this%help_msg)) THEN
2000 WRITE(*,'(A,$)')' title="'
2001
2002 help_line = line_split_new(cstr_to_fchar(this%help_msg), 80)
2003 form = '(A,'' '')'
2004 DO j = 1, line_split_get_nlines(help_line)
2005 IF (j == line_split_get_nlines(help_line)) form = '(A,''"'',$)'
2006 WRITE(*,form)trim(line_split_get_line(help_line,j)) ! lines should be properly quoted here
2007 ENDDO
2008
2009ENDIF
2010
2011END SUBROUTINE option_format_html_help
2012
2013END SUBROUTINE option_format_htmlform
2014
2015
2016FUNCTION option_c_e(this) RESULT(c_e)
2017TYPE(option),INTENT(in) :: this
2018
2019LOGICAL :: c_e
2020
2021c_e = this%long_opt /= ' ' .OR. this%short_opt /= ' '
2022
2023END FUNCTION option_c_e
2024
2025
2029FUNCTION optionparser_new(usage_msg, description_msg) RESULT(this)
2030CHARACTER(len=*), INTENT(in), OPTIONAL :: usage_msg
2031CHARACTER(len=*), INTENT(in), OPTIONAL :: description_msg
2032
2033TYPE(optionparser) :: this
2034
2035IF (PRESENT(usage_msg)) THEN
2036 CALL fchar_to_cstr_alloc(trim(usage_msg), this%usage_msg)
2037ELSE
2038 NULLIFY(this%usage_msg)
2039ENDIF
2040IF (PRESENT(description_msg)) THEN
2041 CALL fchar_to_cstr_alloc(trim(description_msg), this%description_msg)
2042ELSE
2043 NULLIFY(this%description_msg)
2044ENDIF
2045
2046END FUNCTION optionparser_new
2047
2048
2049SUBROUTINE optionparser_delete(this)
2050TYPE(optionparser),INTENT(inout) :: this
2051
2052IF (ASSOCIATED(this%usage_msg)) DEALLOCATE(this%usage_msg)
2053IF (ASSOCIATED(this%description_msg)) DEALLOCATE(this%description_msg)
2054CALL delete(this%options)
2055
2056END SUBROUTINE optionparser_delete
2057
2058
2066SUBROUTINE optionparser_add_c(this, short_opt, long_opt, dest, default, help, isopt)
2067TYPE(optionparser),INTENT(inout) :: this
2068CHARACTER(len=*),INTENT(in) :: short_opt
2069CHARACTER(len=*),INTENT(in) :: long_opt
2070CHARACTER(len=*),TARGET :: dest
2071CHARACTER(len=*),OPTIONAL :: default
2072CHARACTER(len=*),OPTIONAL :: help
2073LOGICAL,INTENT(in),OPTIONAL :: isopt
2074
2075CHARACTER(LEN=60) :: cdefault
2076INTEGER :: i
2077TYPE(option) :: myoption
2078
2079
2080IF (PRESENT(default)) THEN
2081 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2082ELSE
2083 cdefault = ''
2084ENDIF
2085
2086! common initialisation
2087myoption = option_new(short_opt, long_opt, cdefault, help)
2088IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2089
2090myoption%destc => dest(1:1)
2091myoption%destclen = len(dest) ! needed to avoid exceeding the length of dest
2092IF (PRESENT(default)) &
2093 CALL dirty_char_assignment(myoption%destc, myoption%destclen, default)
2094!IF (PRESENT(default)) myoption%destc(1:myoption%destclen) = default
2095myoption%opttype = opttype_c
2096IF (optio_log(isopt)) THEN
2097 myoption%need_arg = 1
2098ELSE
2099 myoption%need_arg = 2
2100ENDIF
2101
2102i = arrayof_option_append(this%options, myoption)
2103
2104END SUBROUTINE optionparser_add_c
2105
2106
2113SUBROUTINE optionparser_add_i(this, short_opt, long_opt, dest, default, help)
2114TYPE(optionparser),INTENT(inout) :: this
2115CHARACTER(len=*),INTENT(in) :: short_opt
2116CHARACTER(len=*),INTENT(in) :: long_opt
2117INTEGER,TARGET :: dest
2118INTEGER,OPTIONAL :: default
2119CHARACTER(len=*),OPTIONAL :: help
2120
2121CHARACTER(LEN=40) :: cdefault
2122INTEGER :: i
2123TYPE(option) :: myoption
2124
2125IF (PRESENT(default)) THEN
2126 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2127ELSE
2128 cdefault = ''
2129ENDIF
2130
2131! common initialisation
2132myoption = option_new(short_opt, long_opt, cdefault, help)
2133IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2134
2135myoption%desti => dest
2136IF (PRESENT(default)) myoption%desti = default
2137myoption%opttype = opttype_i
2138myoption%need_arg = 2
2139
2140i = arrayof_option_append(this%options, myoption)
2141
2142END SUBROUTINE optionparser_add_i
2143
2144
2154SUBROUTINE optionparser_add_iarray(this, short_opt, long_opt, dest, default, help)
2155TYPE(optionparser),INTENT(inout) :: this
2156CHARACTER(len=*),INTENT(in) :: short_opt
2157CHARACTER(len=*),INTENT(in) :: long_opt
2158TYPE(arrayof_integer),TARGET :: dest
2159INTEGER,OPTIONAL :: default(:)
2160CHARACTER(len=*),OPTIONAL :: help
2161
2162CHARACTER(LEN=40) :: cdefault
2163INTEGER :: i
2164TYPE(option) :: myoption
2165
2166cdefault = ''
2167IF (PRESENT(default)) THEN
2168 IF (SIZE(default) == 1) THEN
2169 cdefault = ' [default='//trim(to_char(default(1)))//']'
2170 ELSE IF (SIZE(default) > 1) THEN
2171 cdefault = ' [default='//trim(to_char(default(1)))//',...]'
2172 ENDIF
2173ENDIF
2174
2175! common initialisation
2176myoption = option_new(short_opt, long_opt, cdefault, help)
2177IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2178
2179myoption%destiarr => dest
2180IF (PRESENT(default)) THEN
2181 CALL insert(myoption%destiarr, default)
2182 CALL packarray(myoption%destiarr)
2183ENDIF
2184myoption%opttype = opttype_iarr
2185myoption%need_arg = 2
2186
2187i = arrayof_option_append(this%options, myoption)
2188
2189END SUBROUTINE optionparser_add_iarray
2190
2191
2198SUBROUTINE optionparser_add_r(this, short_opt, long_opt, dest, default, help)
2199TYPE(optionparser),INTENT(inout) :: this
2200CHARACTER(len=*),INTENT(in) :: short_opt
2201CHARACTER(len=*),INTENT(in) :: long_opt
2202REAL,TARGET :: dest
2203REAL,OPTIONAL :: default
2204CHARACTER(len=*),OPTIONAL :: help
2205
2206CHARACTER(LEN=40) :: cdefault
2207INTEGER :: i
2208TYPE(option) :: myoption
2209
2210IF (PRESENT(default)) THEN
2211 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2212ELSE
2213 cdefault = ''
2214ENDIF
2215
2216! common initialisation
2217myoption = option_new(short_opt, long_opt, cdefault, help)
2218IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2219
2220myoption%destr => dest
2221IF (PRESENT(default)) myoption%destr = default
2222myoption%opttype = opttype_r
2223myoption%need_arg = 2
2224
2225i = arrayof_option_append(this%options, myoption)
2226
2227END SUBROUTINE optionparser_add_r
2228
2229
2239SUBROUTINE optionparser_add_rarray(this, short_opt, long_opt, dest, default, help)
2240TYPE(optionparser),INTENT(inout) :: this
2241CHARACTER(len=*),INTENT(in) :: short_opt
2242CHARACTER(len=*),INTENT(in) :: long_opt
2243TYPE(arrayof_real),TARGET :: dest
2244REAL,OPTIONAL :: default(:)
2245CHARACTER(len=*),OPTIONAL :: help
2246
2247CHARACTER(LEN=40) :: cdefault
2248INTEGER :: i
2249TYPE(option) :: myoption
2250
2251cdefault = ''
2252IF (PRESENT(default)) THEN
2253 IF (SIZE(default) == 1) THEN
2254 cdefault = ' [default='//trim(to_char(default(1)))//']'
2255 ELSE IF (SIZE(default) > 1) THEN
2256 cdefault = ' [default='//trim(to_char(default(1)))//',...]'
2257 ENDIF
2258ENDIF
2259
2260! common initialisation
2261myoption = option_new(short_opt, long_opt, cdefault, help)
2262IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2263
2264myoption%destrarr => dest
2265IF (PRESENT(default)) THEN
2266 CALL insert(myoption%destrarr, default)
2267 CALL packarray(myoption%destrarr)
2268ENDIF
2269myoption%opttype = opttype_rarr
2270myoption%need_arg = 2
2271
2272i = arrayof_option_append(this%options, myoption)
2273
2274END SUBROUTINE optionparser_add_rarray
2275
2276
2283SUBROUTINE optionparser_add_d(this, short_opt, long_opt, dest, default, help)
2284TYPE(optionparser),INTENT(inout) :: this
2285CHARACTER(len=*),INTENT(in) :: short_opt
2286CHARACTER(len=*),INTENT(in) :: long_opt
2287DOUBLE PRECISION,TARGET :: dest
2288DOUBLE PRECISION,OPTIONAL :: default
2289CHARACTER(len=*),OPTIONAL :: help
2290
2291CHARACTER(LEN=40) :: cdefault
2292INTEGER :: i
2293TYPE(option) :: myoption
2294
2295IF (PRESENT(default)) THEN
2296 IF (c_e(default)) THEN
2297 cdefault = ' [default='//trim(adjustl(to_char(default,form='(G15.9)')))//']'
2298 ELSE
2299 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2300 ENDIF
2301ELSE
2302 cdefault = ''
2303ENDIF
2304
2305! common initialisation
2306myoption = option_new(short_opt, long_opt, cdefault, help)
2307IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2308
2309myoption%destd => dest
2310IF (PRESENT(default)) myoption%destd = default
2311myoption%opttype = opttype_d
2312myoption%need_arg = 2
2313
2314i = arrayof_option_append(this%options, myoption)
2315
2316END SUBROUTINE optionparser_add_d
2317
2318
2328SUBROUTINE optionparser_add_darray(this, short_opt, long_opt, dest, default, help)
2329TYPE(optionparser),INTENT(inout) :: this
2330CHARACTER(len=*),INTENT(in) :: short_opt
2331CHARACTER(len=*),INTENT(in) :: long_opt
2332TYPE(arrayof_doubleprecision),TARGET :: dest
2333DOUBLE PRECISION,OPTIONAL :: default(:)
2334CHARACTER(len=*),OPTIONAL :: help
2335
2336CHARACTER(LEN=40) :: cdefault
2337INTEGER :: i
2338TYPE(option) :: myoption
2339
2340cdefault = ''
2341IF (PRESENT(default)) THEN
2342 IF (SIZE(default) == 1) THEN
2343 cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//']'
2344 ELSE IF (SIZE(default) > 1) THEN
2345 cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//',...]'
2346 ENDIF
2347ENDIF
2348
2349! common initialisation
2350myoption = option_new(short_opt, long_opt, cdefault, help)
2351IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2352
2353myoption%destdarr => dest
2354IF (PRESENT(default)) THEN
2355 CALL insert(myoption%destdarr, default)
2356 CALL packarray(myoption%destdarr)
2357ENDIF
2358myoption%opttype = opttype_darr
2359myoption%need_arg = 2
2360
2361i = arrayof_option_append(this%options, myoption)
2362
2363END SUBROUTINE optionparser_add_darray
2364
2365
2372SUBROUTINE optionparser_add_l(this, short_opt, long_opt, dest, help)
2373TYPE(optionparser),INTENT(inout) :: this
2374CHARACTER(len=*),INTENT(in) :: short_opt
2375CHARACTER(len=*),INTENT(in) :: long_opt
2376LOGICAL,TARGET :: dest
2377CHARACTER(len=*),OPTIONAL :: help
2378
2379INTEGER :: i
2380TYPE(option) :: myoption
2381
2382! common initialisation
2383myoption = option_new(short_opt, long_opt, '', help)
2384IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2385
2386myoption%destl => dest
2387myoption%destl = .false. ! unconditionally set to false, option can only set it to true
2388myoption%opttype = opttype_l
2389myoption%need_arg = 0
2390
2391i = arrayof_option_append(this%options, myoption)
2392
2393END SUBROUTINE optionparser_add_l
2394
2395
2400SUBROUTINE optionparser_add_count(this, short_opt, long_opt, dest, start, help)
2401TYPE(optionparser),INTENT(inout) :: this
2402CHARACTER(len=*),INTENT(in) :: short_opt
2403CHARACTER(len=*),INTENT(in) :: long_opt
2404INTEGER,TARGET :: dest
2405INTEGER,OPTIONAL :: start
2406CHARACTER(len=*),OPTIONAL :: help
2407
2408INTEGER :: i
2409TYPE(option) :: myoption
2410
2411! common initialisation
2412myoption = option_new(short_opt, long_opt, '', help)
2413IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2414
2415myoption%destcount => dest
2416IF (PRESENT(start)) myoption%destcount = start
2417myoption%opttype = opttype_count
2418myoption%need_arg = 0
2419
2420i = arrayof_option_append(this%options, myoption)
2421
2422END SUBROUTINE optionparser_add_count
2423
2424
2439SUBROUTINE optionparser_add_help(this, short_opt, long_opt, help)
2440TYPE(optionparser),INTENT(inout) :: this
2441CHARACTER(len=*),INTENT(in) :: short_opt
2442CHARACTER(len=*),INTENT(in) :: long_opt
2443CHARACTER(len=*),OPTIONAL :: help
2444
2445INTEGER :: i
2446TYPE(option) :: myoption
2447
2448! common initialisation
2449myoption = option_new(short_opt, long_opt, '', help)
2450IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2451
2452myoption%opttype = opttype_help
2453myoption%need_arg = 1
2454
2455i = arrayof_option_append(this%options, myoption)
2456
2457END SUBROUTINE optionparser_add_help
2458
2459
2470SUBROUTINE optionparser_add_sep(this, help)
2471TYPE(optionparser),INTENT(inout) :: this
2472!CHARACTER(len=*),INTENT(in) :: short_opt !< the short option (may be empty)
2473!CHARACTER(len=*),INTENT(in) :: long_opt !< the long option (may be empty)
2474CHARACTER(len=*) :: help
2475
2476INTEGER :: i
2477TYPE(option) :: myoption
2478
2479! common initialisation
2480myoption = option_new('_', '_', '', help)
2481IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2482
2483myoption%opttype = opttype_sep
2484myoption%need_arg = 0
2485
2486i = arrayof_option_append(this%options, myoption)
2487
2488END SUBROUTINE optionparser_add_sep
2489
2490
2500SUBROUTINE optionparser_parse(this, nextarg, status)
2501TYPE(optionparser),INTENT(inout) :: this
2502INTEGER,INTENT(out) :: nextarg
2503INTEGER,INTENT(out) :: status
2504
2505INTEGER :: i, j, endopt, indeq, iargc
2506CHARACTER(len=16384) :: arg, optarg
2507
2508status = optionparser_ok
2509i = 1
2510DO WHILE(i <= iargc())
2511 CALL getarg(i, arg)
2512 IF (arg == '--') THEN ! explicit end of options
2513 i = i + 1 ! skip present option (--)
2514 EXIT
2515 ELSE IF (arg == '-') THEN ! a single - is not an option
2516 EXIT
2517 ELSE IF (arg(1:2) == '--') THEN ! long option
2518 indeq = index(arg, '=')
2519 IF (indeq /= 0) THEN ! = present
2520 endopt = indeq - 1
2521 ELSE ! no =
2522 endopt = len_trim(arg)
2523 ENDIF
2524 find_longopt: DO j = 1, this%options%arraysize
2525 IF (this%options%array(j)%long_opt == arg(3:endopt)) THEN ! found option
2526 SELECT CASE(this%options%array(j)%need_arg)
2527 CASE(2) ! compulsory
2528 IF (indeq /= 0) THEN
2529 optarg = arg(indeq+1:)
2530 status = max(option_found(this%options%array(j), optarg), &
2531 status)
2532 ELSE
2533 IF (i < iargc()) THEN
2534 i=i+1
2535 CALL getarg(i, optarg)
2536 status = max(option_found(this%options%array(j), optarg), &
2537 status)
2538 ELSE
2539 status = optionparser_err
2540 CALL l4f_log(l4f_error, &
2541 'in optionparser, option '''//trim(arg)//''' requires an argument')
2542 ENDIF
2543 ENDIF
2544 CASE(1) ! optional
2545 IF (indeq /= 0) THEN
2546 optarg = arg(indeq+1:)
2547 ELSE
2548 IF (i < iargc()) THEN
2549 CALL getarg(i+1, optarg)
2550 IF (optarg(1:1) == '-') THEN
2551 optarg = cmiss ! refused
2552 ELSE
2553 i=i+1 ! accepted
2554 ENDIF
2555 ELSE
2556 optarg = cmiss ! refused
2557 ENDIF
2558 ENDIF
2559 status = max(option_found(this%options%array(j), optarg), &
2560 status)
2561 CASE(0)
2562 status = max(option_found(this%options%array(j)), &
2563 status)
2564 END SELECT
2565 EXIT find_longopt
2566 ENDIF
2567 ENDDO find_longopt
2568 IF (j > this%options%arraysize) THEN
2569 status = optionparser_err
2570 CALL l4f_log(l4f_error, &
2571 'in optionparser, option '''//trim(arg)//''' not valid')
2572 ENDIF
2573 ELSE IF (arg(1:1) == '-') THEN ! short option
2574 find_shortopt: DO j = 1, this%options%arraysize
2575 IF (this%options%array(j)%short_opt == arg(2:2)) THEN ! found option
2576 SELECT CASE(this%options%array(j)%need_arg)
2577 CASE(2) ! compulsory
2578 IF (len_trim(arg) > 2) THEN
2579 optarg = arg(3:)
2580 status = max(option_found(this%options%array(j), optarg), &
2581 status)
2582 ELSE
2583 IF (i < iargc()) THEN
2584 i=i+1
2585 CALL getarg(i, optarg)
2586 status = max(option_found(this%options%array(j), optarg), &
2587 status)
2588 ELSE
2589 status = optionparser_err
2590 CALL l4f_log(l4f_error, &
2591 'in optionparser, option '''//trim(arg)//''' requires an argument')
2592 ENDIF
2593 ENDIF
2594 CASE(1) ! optional
2595 IF (len_trim(arg) > 2) THEN
2596 optarg = arg(3:)
2597 ELSE
2598 IF (i < iargc()) THEN
2599 CALL getarg(i+1, optarg)
2600 IF (optarg(1:1) == '-') THEN
2601 optarg = cmiss ! refused
2602 ELSE
2603 i=i+1 ! accepted
2604 ENDIF
2605 ELSE
2606 optarg = cmiss ! refused
2607 ENDIF
2608 ENDIF
2609 status = max(option_found(this%options%array(j), optarg), &
2610 status)
2611 CASE(0)
2612 status = max(option_found(this%options%array(j)), &
2613 status)
2614 END SELECT
2615 EXIT find_shortopt
2616 ENDIF
2617 ENDDO find_shortopt
2618 IF (j > this%options%arraysize) THEN
2619 status = optionparser_err
2620 CALL l4f_log(l4f_error, &
2621 'in optionparser, option '''//trim(arg)//''' not valid')
2622 ENDIF
2623 ELSE ! unrecognized = end of options
2624 EXIT
2625 ENDIF
2626 i = i + 1
2627ENDDO
2628
2629nextarg = i
2630SELECT CASE(status)
2631CASE(optionparser_err, optionparser_help)
2632 CALL optionparser_printhelp(this)
2633END SELECT
2634
2635END SUBROUTINE optionparser_parse
2636
2637
2641SUBROUTINE optionparser_printhelp(this)
2642TYPE(optionparser),INTENT(in) :: this
2643
2644INTEGER :: i, form
2645
2646form = 0
2647DO i = 1, this%options%arraysize ! loop over options
2648 IF (this%options%array(i)%opttype == opttype_help) THEN
2649 form = this%options%array(i)%helpformat
2650 ENDIF
2651ENDDO
2652
2653SELECT CASE(form)
2654CASE(0)
2655 CALL optionparser_printhelptxt(this)
2656CASE(1)
2657 CALL optionparser_printhelpmd(this)
2658CASE(2)
2659 CALL optionparser_printhelphtmlform(this)
2660END SELECT
2661
2662END SUBROUTINE optionparser_printhelp
2663
2664
2668SUBROUTINE optionparser_printhelptxt(this)
2669TYPE(optionparser),INTENT(in) :: this
2670
2671INTEGER :: i, j, ncols
2672CHARACTER(len=80) :: buf
2673TYPE(line_split) :: help_line
2674
2675ncols = default_columns()
2676
2677! print usage message
2678IF (ASSOCIATED(this%usage_msg)) THEN
2679 help_line = line_split_new(cstr_to_fchar(this%usage_msg), ncols)
2680 DO j = 1, line_split_get_nlines(help_line)
2681 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2682 ENDDO
2683 CALL delete(help_line)
2684ELSE
2685 CALL getarg(0, buf)
2686 i = index(buf, '/', back=.true.) ! remove directory part
2687 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2688 WRITE(*,'(A)')'Usage: '//trim(buf(i+1:))//' [options] [arguments]'
2689ENDIF
2690
2691! print description message
2692IF (ASSOCIATED(this%description_msg)) THEN
2693 WRITE(*,'()')
2694 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2695 DO j = 1, line_split_get_nlines(help_line)
2696 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2697 ENDDO
2698 CALL delete(help_line)
2699ENDIF
2700
2701WRITE(*,'(/,A)')'Options:'
2702
2703DO i = 1, this%options%arraysize ! loop over options
2704 CALL option_format_help(this%options%array(i), ncols)
2705ENDDO
2706
2707END SUBROUTINE optionparser_printhelptxt
2708
2709
2713SUBROUTINE optionparser_printhelpmd(this)
2714TYPE(optionparser),INTENT(in) :: this
2715
2716INTEGER :: i, j, ncols
2717CHARACTER(len=80) :: buf
2718TYPE(line_split) :: help_line
2719
2720ncols = default_columns()
2721
2722! print usage message
2723WRITE(*,'(A)')'### Synopsis'
2724
2725IF (ASSOCIATED(this%usage_msg)) THEN
2726 help_line = line_split_new(mdquote_usage_msg(cstr_to_fchar(this%usage_msg)), ncols)
2727 DO j = 1, line_split_get_nlines(help_line)
2728 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2729 ENDDO
2730 CALL delete(help_line)
2731ELSE
2732 CALL getarg(0, buf)
2733 i = index(buf, '/', back=.true.) ! remove directory part
2734 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2735 WRITE(*,'(A)')'Usage: `'//trim(buf(i+1:))//' [options] [arguments]`'
2736ENDIF
2737
2738! print description message
2739IF (ASSOCIATED(this%description_msg)) THEN
2740 WRITE(*,'()')
2741 WRITE(*,'(A)')'### Description'
2742 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2743 DO j = 1, line_split_get_nlines(help_line)
2744 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2745 ENDDO
2746 CALL delete(help_line)
2747
2748ENDIF
2749
2750WRITE(*,'(/,A)')'### Options'
2751
2752DO i = 1, this%options%arraysize ! loop over options
2753 CALL option_format_md(this%options%array(i), ncols)
2754ENDDO
2755
2756CONTAINS
2757
2758FUNCTION mdquote_usage_msg(usage_msg)
2759CHARACTER(len=*),INTENT(in) :: usage_msg
2760
2761CHARACTER(len=LEN(usage_msg)+2) :: mdquote_usage_msg
2762INTEGER :: colon
2763
2764colon = index(usage_msg, ':') ! typically 'Usage: cp [options] origin destination'
2765IF (colon > 0 .AND. colon < len(usage_msg)-1) THEN
2766 mdquote_usage_msg = usage_msg(:colon+1)//'`'//usage_msg(colon+2:)//'`'
2767ELSE
2768 mdquote_usage_msg = usage_msg
2769ENDIF
2770
2771END FUNCTION mdquote_usage_msg
2772
2773END SUBROUTINE optionparser_printhelpmd
2774
2778SUBROUTINE optionparser_printhelphtmlform(this)
2779TYPE(optionparser),INTENT(in) :: this
2780
2781INTEGER :: i
2782
2783DO i = 1, this%options%arraysize ! loop over options
2784 CALL option_format_htmlform(this%options%array(i))
2785ENDDO
2786
2787WRITE(*,'(A)')'<input class="libsim_sub" type="submit" value="runprogram" />'
2788
2789END SUBROUTINE optionparser_printhelphtmlform
2790
2791
2792SUBROUTINE optionparser_make_completion(this)
2793TYPE(optionparser),INTENT(in) :: this
2794
2795INTEGER :: i
2796CHARACTER(len=512) :: buf
2797
2798CALL getarg(0, buf)
2799
2800WRITE(*,'(A/A/A)')'_'//trim(buf)//'()','{','local cur'
2801
2802WRITE(*,'(A/A/A/A)')'COMPREPLY=()','cur=${COMP_WORDS[COMP_CWORD]}', &
2803 'case "$cur" in','-*)'
2804
2805!-*)
2806! COMPREPLY=( $( compgen -W
2807DO i = 1, this%options%arraysize ! loop over options
2808 IF (this%options%array(i)%need_arg == 2) THEN
2809 ENDIF
2810ENDDO
2811
2812WRITE(*,'(A/A/A)')'esac','return 0','}'
2813
2814END SUBROUTINE optionparser_make_completion
2815
2816
2817SUBROUTINE dirty_char_assignment(destc, destclen, src)
2818USE kinds
2819IMPLICIT NONE
2820
2821CHARACTER(len=1) :: destc(*)
2822CHARACTER(len=*) :: src
2823INTEGER :: destclen
2824
2825INTEGER :: i
2826
2827DO i = 1, min(destclen, len(src))
2828 destc(i) = src(i:i)
2829ENDDO
2830DO i = len(src)+1, destclen
2831 destc(i) = ' '
2832ENDDO
2833
2834END SUBROUTINE dirty_char_assignment
2835
2836END 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.