libsim Versione 7.2.1

◆ 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 1465 del file optionparser_class.F90.

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