libsim Versione 7.1.11

◆ optionparser_add_l()

subroutine optionparser_add_l ( type(optionparser), intent(inout)  this,
character(len=*), intent(in)  short_opt,
character(len=*), intent(in)  long_opt,
logical, target  dest,
character(len=*), optional  help 
)

Add a new logical option, without optional argument.

When parsing will be performed, if the requested option is encountered, the provided destination will be set to .TRUE. . The provided destination is initially set to .FALSE. . Please use the generic optionparser_add method rather than this particular method.

Parametri
[in,out]thisoptionparser object
[in]short_optthe short option (may be empty)
[in]long_optthe long option (may be empty)
destthe destination of the option parse result
helpthe help message that will be formatted and pretty-printed on screen

Definizione alla linea 1404 del file optionparser_class.F90.

1405! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1406! authors:
1407! Davide Cesari <dcesari@arpa.emr.it>
1408! Paolo Patruno <ppatruno@arpa.emr.it>
1409
1410! This program is free software; you can redistribute it and/or
1411! modify it under the terms of the GNU General Public License as
1412! published by the Free Software Foundation; either version 2 of
1413! the License, or (at your option) any later version.
1414
1415! This program is distributed in the hope that it will be useful,
1416! but WITHOUT ANY WARRANTY; without even the implied warranty of
1417! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1418! GNU General Public License for more details.
1428#include "config.h"
1429
1430MODULE optionparser_class
1431USE log4fortran
1432USE err_handling
1433USE kinds
1437IMPLICIT NONE
1438
1439
1440! private class
1441TYPE option
1442 CHARACTER(len=1) :: short_opt=''
1443 CHARACTER(len=80) :: long_opt=''
1444 INTEGER :: opttype=-1
1445 INTEGER :: need_arg=0 ! 0=no, 1=optional, 2=yes, was .FALSE.
1446 LOGICAL :: has_default=.false.
1447 CHARACTER(len=1),POINTER :: destc=>null()
1448 INTEGER :: destclen=0
1449 INTEGER :: helpformat=0 ! 0=txt, 1=markdown, 2=htmlform, improve!
1450 INTEGER,POINTER :: desti=>null()
1451 TYPE(arrayof_integer),POINTER :: destiarr=>null()
1452 REAL,POINTER :: destr=>null()
1453 TYPE(arrayof_real),POINTER :: destrarr=>null()
1454 DOUBLE PRECISION, POINTER :: destd=>null()
1455 TYPE(arrayof_doubleprecision),POINTER :: destdarr=>null()
1456 LOGICAL,POINTER :: destl=>null()
1457 TYPE(arrayof_logical),POINTER :: destlarr=>null()
1458 INTEGER,POINTER :: destcount=>null()
1459 INTEGER(kind=int_b),ALLOCATABLE :: help_msg(:)
1460END TYPE option
1461
1462#define ARRAYOF_ORIGTYPE TYPE(option)
1463#define ARRAYOF_TYPE arrayof_option
1464#define ARRAYOF_ORIGDESTRUCTOR(x) CALL option_delete(x)
1465#define ARRAYOF_PRIVATE 1
1466#include "arrayof_pre_nodoc.F90"
1467! from arrayof
1468!PUBLIC insert, append, remove, packarray
1469!PUBLIC insert_unique, append_unique
1470
1548TYPE optionparser
1549 PRIVATE
1550 INTEGER(kind=int_b),POINTER :: usage_msg(:), description_msg(:)
1551 TYPE(arrayof_option) :: options
1552 LOGICAL :: httpmode=.false.
1553END TYPE optionparser
1554
1555
1559INTERFACE optionparser_add
1560 MODULE PROCEDURE optionparser_add_c, optionparser_add_i, optionparser_add_r, &
1561 optionparser_add_d, optionparser_add_l, &
1562 optionparser_add_iarray, optionparser_add_rarray, optionparser_add_darray
1563END INTERFACE
1564
1565INTERFACE c_e
1566 MODULE PROCEDURE option_c_e
1567END INTERFACE
1568
1576INTERFACE delete
1577 MODULE PROCEDURE optionparser_delete!?, option_delete
1578END INTERFACE
1579
1580
1581INTEGER,PARAMETER :: opttype_c = 1, opttype_i = 2, opttype_r = 3, &
1582 opttype_d = 4, opttype_l = 5, opttype_count = 6, opttype_help = 7, &
1583 opttype_sep = 8, opttype_carr = 11, opttype_iarr = 12, opttype_rarr = 13, &
1584 opttype_darr = 14, opttype_larr = 15
1585
1586INTEGER,PARAMETER :: optionparser_ok = 0
1587INTEGER,PARAMETER :: optionparser_help = 1
1588INTEGER,PARAMETER :: optionparser_err = 2
1589
1590
1591PRIVATE
1592PUBLIC optionparser, optionparser_new, delete, optionparser_add, &
1593 optionparser_add_count, optionparser_add_help, optionparser_add_sep, &
1594 optionparser_parse, optionparser_printhelp, &
1595 optionparser_ok, optionparser_help, optionparser_err
1596
1597
1598CONTAINS
1599
1600#include "arrayof_post_nodoc.F90"
1601
1602! Constructor for the option class
1603FUNCTION option_new(short_opt, long_opt, default, help) RESULT(this)
1604CHARACTER(len=*),INTENT(in) :: short_opt
1605CHARACTER(len=*),INTENT(in) :: long_opt
1606CHARACTER(len=*),INTENT(in) :: default
1607CHARACTER(len=*),OPTIONAL :: help
1608TYPE(option) :: this
1609
1610IF (short_opt == '' .AND. long_opt == '') THEN
1611#ifdef DEBUG
1612! programmer error condition, option empty
1613 CALL l4f_log(l4f_error, 'in optionparser, both short and long options empty')
1614 CALL raise_fatal_error()
1615#else
1616 CALL l4f_log(l4f_warn, 'in optionparser, both short and long options empty')
1617#endif
1618 RETURN
1619ENDIF
1620
1621this%short_opt = short_opt
1622this%long_opt = long_opt
1623IF (PRESENT(help)) THEN
1624 this%help_msg = fchar_to_cstr(trim(help)//trim(default)) ! f2003 automatic alloc
1625ENDIF
1626this%has_default = (len_trim(default) > 0)
1627
1628END FUNCTION option_new
1629
1630
1631! Destructor for the \a option class, the memory associated with
1632! the object is freed.
1633SUBROUTINE option_delete(this)
1634TYPE(option),INTENT(inout) :: this ! object to destroy
1635
1636IF (ALLOCATED(this%help_msg)) DEALLOCATE(this%help_msg)
1637NULLIFY(this%destc)
1638NULLIFY(this%desti)
1639NULLIFY(this%destr)
1640NULLIFY(this%destd)
1641NULLIFY(this%destl)
1642NULLIFY(this%destcount)
1643
1644END SUBROUTINE option_delete
1645
1646
1647FUNCTION option_found(this, optarg) RESULT(status)
1648TYPE(option),INTENT(inout) :: this
1649CHARACTER(len=*),INTENT(in),OPTIONAL :: optarg
1650INTEGER :: status
1651
1652TYPE(csv_record) :: arrparser
1653INTEGER :: ibuff
1654REAL :: rbuff
1655DOUBLE PRECISION :: dbuff
1656
1657status = optionparser_ok
1658
1659SELECT CASE(this%opttype)
1660CASE(opttype_c)
1661 CALL dirty_char_assignment(this%destc, this%destclen, trim(optarg))
1662! this%destc(1:this%destclen) = optarg
1663 IF (len_trim(optarg) > this%destclen) THEN
1664 CALL l4f_log(l4f_warn, &
1665 'in optionparser, argument '''//trim(optarg)//''' too long, truncated')
1666 ENDIF
1667CASE(opttype_i)
1668 READ(optarg,'(I12)',err=100)this%desti
1669CASE(opttype_iarr)
1670 CALL delete(this%destiarr) ! delete default values
1671 CALL init(arrparser, optarg)
1672 DO WHILE(.NOT.csv_record_end(arrparser))
1673 CALL csv_record_getfield(arrparser, ibuff)
1674 CALL insert(this%destiarr, ibuff)
1675 ENDDO
1676 CALL packarray(this%destiarr)
1677 CALL delete(arrparser)
1678CASE(opttype_r)
1679 READ(optarg,'(F20.0)',err=102)this%destr
1680CASE(opttype_rarr)
1681 CALL delete(this%destrarr) ! delete default values
1682 CALL init(arrparser, optarg)
1683 DO WHILE(.NOT.csv_record_end(arrparser))
1684 CALL csv_record_getfield(arrparser, rbuff)
1685 CALL insert(this%destrarr, rbuff)
1686 ENDDO
1687 CALL packarray(this%destrarr)
1688 CALL delete(arrparser)
1689CASE(opttype_d)
1690 READ(optarg,'(F20.0)',err=102)this%destd
1691CASE(opttype_darr)
1692 CALL delete(this%destdarr) ! delete default values
1693 CALL init(arrparser, optarg)
1694 DO WHILE(.NOT.csv_record_end(arrparser))
1695 CALL csv_record_getfield(arrparser, dbuff)
1696 CALL insert(this%destdarr, dbuff)
1697 ENDDO
1698 CALL packarray(this%destdarr)
1699 CALL delete(arrparser)
1700CASE(opttype_l)
1701 this%destl = .true.
1702CASE(opttype_count)
1703 this%destcount = this%destcount + 1
1704CASE(opttype_help)
1705 status = optionparser_help
1706 SELECT CASE(optarg) ! set help format
1707 CASE('md', 'markdown')
1708 this%helpformat = 1
1709 CASE('htmlform')
1710 this%helpformat = 2
1711 END SELECT
1712END SELECT
1713
1714RETURN
1715
1716100 status = optionparser_err
1717CALL l4f_log(l4f_error, &
1718 'in optionparser, argument '''//trim(optarg)//''' not valid as integer')
1719RETURN
1720102 status = optionparser_err
1721CALL l4f_log(l4f_error, &
1722 'in optionparser, argument '''//trim(optarg)//''' not valid as real')
1723RETURN
1724
1725END FUNCTION option_found
1726
1727
1728! Return a string which gives a short representation of the
1729! option \a this, without help message. The resulting string is quite
1730! long and it should be trimmed with the \a TRIM() intrinsic
1731! function.
1732FUNCTION option_format_opt(this) RESULT(format_opt)
1733TYPE(option),INTENT(in) :: this
1734
1735CHARACTER(len=100) :: format_opt
1736
1737CHARACTER(len=20) :: argname
1738
1739SELECT CASE(this%opttype)
1740CASE(opttype_c)
1741 argname = 'STRING'
1742CASE(opttype_i)
1743 argname = 'INT'
1744CASE(opttype_iarr)
1745 argname = 'INT[,INT...]'
1746CASE(opttype_r, opttype_d)
1747 argname = 'REAL'
1748CASE(opttype_rarr, opttype_darr)
1749 argname = 'REAL[,REAL...]'
1750CASE default
1751 argname = ''
1752END SELECT
1753
1754format_opt = ''
1755IF (this%short_opt /= '') THEN
1756 format_opt(len_trim(format_opt)+1:) = ' -'//this%short_opt
1757 IF (argname /= '') THEN
1758 format_opt(len_trim(format_opt)+1:) = ' '//trim(argname)
1759 ENDIF
1760ENDIF
1761IF (this%short_opt /= '' .AND. this%long_opt /= '') THEN
1762 format_opt(len_trim(format_opt)+1:) = ','
1763ENDIF
1764IF (this%long_opt /= '') THEN
1765 format_opt(len_trim(format_opt)+1:) = ' --'//this%long_opt
1766 IF (argname /= '') THEN
1767 format_opt(len_trim(format_opt)+1:) = '='//trim(argname)
1768 ENDIF
1769ENDIF
1770
1771END FUNCTION option_format_opt
1772
1773
1774! print on stdout a human-readable text representation of a single option
1775SUBROUTINE option_format_help(this, ncols)
1776TYPE(option),INTENT(in) :: this
1777INTEGER,INTENT(in) :: ncols
1778
1779INTEGER :: j
1780INTEGER, PARAMETER :: indent = 10
1781TYPE(line_split) :: help_line
1782
1783
1784IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
1785 IF (ALLOCATED(this%help_msg)) THEN
1786! help2man is quite picky about the treatment of arbitrary lines
1787! within options, the only universal way seems to be unindented lines
1788! with an empty line before and after
1789 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
1790 WRITE(*,'()')
1791 DO j = 1, line_split_get_nlines(help_line)
1792 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1793 ENDDO
1794 CALL delete(help_line)
1795 WRITE(*,'()')
1796 ENDIF
1797ELSE ! ordinary option
1798! print option brief representation
1799 WRITE(*,'(A)')trim(option_format_opt(this))
1800! print option help
1801 IF (ALLOCATED(this%help_msg)) THEN
1802 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
1803 DO j = 1, line_split_get_nlines(help_line)
1804 WRITE(*,'(T10,A)')trim(line_split_get_line(help_line,j))
1805 ENDDO
1806 CALL delete(help_line)
1807 ENDIF
1808ENDIF
1809
1810END SUBROUTINE option_format_help
1811
1812
1813! print on stdout a markdown representation of a single option
1814SUBROUTINE option_format_md(this, ncols)
1815TYPE(option),INTENT(in) :: this
1816INTEGER,INTENT(in) :: ncols
1817
1818INTEGER :: j
1819INTEGER, PARAMETER :: indent = 2
1820TYPE(line_split) :: help_line
1821
1822IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
1823 IF (ALLOCATED(this%help_msg)) THEN
1824 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
1825 WRITE(*,'()')
1826 DO j = 1, line_split_get_nlines(help_line)
1827 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1828 ENDDO
1829 CALL delete(help_line)
1830 WRITE(*,'()')
1831 ENDIF
1832ELSE ! ordinary option
1833! print option brief representation
1834 WRITE(*,'(''`'',A,''`'')')trim(option_format_opt(this))
1835! print option help
1836 IF (ALLOCATED(this%help_msg)) THEN
1837 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
1838 DO j = 1, line_split_get_nlines(help_line)
1839 WRITE(*,'(''> '',A)')trim(line_split_get_line(help_line,j))
1840 ENDDO
1841 CALL delete(help_line)
1842 WRITE(*,'()')
1843 ENDIF
1844ENDIF
1845
1846END SUBROUTINE option_format_md
1847
1848
1849! print on stdout an html form representation of a single option
1850SUBROUTINE option_format_htmlform(this)
1851TYPE(option),INTENT(in) :: this
1852
1853CHARACTER(len=80) :: opt_name, opt_id, opt_default ! check len of default
1854
1855IF (.NOT.c_e(this)) RETURN
1856IF (this%long_opt == '') THEN
1857 opt_name = this%short_opt
1858 opt_id = 'short_opt_'//this%short_opt
1859ELSE
1860 opt_name = this%long_opt
1861 opt_id = this%long_opt
1862ENDIF
1863
1864SELECT CASE(this%opttype)
1865CASE(opttype_c)
1866 CALL option_format_html_openspan('text')
1867
1868 IF (this%has_default .AND. ASSOCIATED(this%destc) .AND. this%destclen > 0) THEN
1869! opt_default = TRANSFER(this%destc(1:MIN(LEN(opt_default),this%destclen)), &
1870! opt_default) ! improve
1871 opt_default = ''
1872 WRITE(*,'(A)')' value="'//trim(opt_default)//'"'
1873 ENDIF
1874 CALL option_format_html_help()
1875 CALL option_format_html_closespan()
1876
1877CASE(opttype_i,opttype_r,opttype_d)
1878 CALL option_format_html_openspan('text')
1879 IF (this%has_default) THEN
1880 SELECT CASE(this%opttype)
1881 CASE(opttype_i)
1882 WRITE(*,'(3A)')' value="',t2c(this%desti),'"'
1883! todo CASE(opttype_iarr)
1884 CASE(opttype_r)
1885 WRITE(*,'(3A)')' value="',t2c(this%destr),'"'
1886 CASE(opttype_d)
1887 WRITE(*,'(3A)')' value="',t2c(this%destd),'"'
1888 END SELECT
1889 ENDIF
1890 CALL option_format_html_help()
1891 CALL option_format_html_closespan()
1892
1893! todo CASE(opttype_iarr)
1894
1895CASE(opttype_l)
1896 CALL option_format_html_openspan('checkbox')
1897 CALL option_format_html_help()
1898 CALL option_format_html_closespan()
1899
1900CASE(opttype_count)
1901 CALL option_format_html_openspan('number')
1902 CALL option_format_html_help()
1903 CALL option_format_html_closespan()
1904
1905CASE(opttype_sep)
1906END SELECT
1907
1908
1909CONTAINS
1910
1911SUBROUTINE option_format_html_openspan(formtype)
1912CHARACTER(len=*),INTENT(in) :: formtype
1913
1914WRITE(*,'(A)')'<span class="libsim_optbox" id="span_'//trim(opt_id)//'">'//trim(opt_name)//':'
1915! size=? maxlen=?
1916WRITE(*,'(A)')'<input class_"libsim_opt" id="'//trim(opt_id)//'" type="'//formtype// &
1917 '" name="'//trim(opt_id)//'" '
1918
1919END SUBROUTINE option_format_html_openspan
1920
1921SUBROUTINE option_format_html_closespan()
1922
1923WRITE(*,'(A)')'/></span>'
1924
1925END SUBROUTINE option_format_html_closespan
1926
1927SUBROUTINE option_format_html_help()
1928INTEGER :: j
1929TYPE(line_split) :: help_line
1930CHARACTER(len=20) :: form
1931
1932IF (ALLOCATED(this%help_msg)) THEN
1933 WRITE(*,'(A,$)')' title="'
1934
1935 help_line = line_split_new(cstr_to_fchar(this%help_msg), 80)
1936 form = '(A,'' '')'
1937 DO j = 1, line_split_get_nlines(help_line)
1938 IF (j == line_split_get_nlines(help_line)) form = '(A,''"'',$)'
1939 WRITE(*,form)trim(line_split_get_line(help_line,j)) ! lines should be properly quoted here
1940 ENDDO
1941
1942ENDIF
1943
1944END SUBROUTINE option_format_html_help
1945
1946END SUBROUTINE option_format_htmlform
1947
1948
1949FUNCTION option_c_e(this) RESULT(c_e)
1950TYPE(option),INTENT(in) :: this
1951
1952LOGICAL :: c_e
1953
1954c_e = this%long_opt /= ' ' .OR. this%short_opt /= ' '
1955
1956END FUNCTION option_c_e
1957
1958
1962FUNCTION optionparser_new(usage_msg, description_msg) RESULT(this)
1963CHARACTER(len=*), INTENT(in), OPTIONAL :: usage_msg
1964CHARACTER(len=*), INTENT(in), OPTIONAL :: description_msg
1965
1966TYPE(optionparser) :: this
1967
1968IF (PRESENT(usage_msg)) THEN
1969 CALL fchar_to_cstr_alloc(trim(usage_msg), this%usage_msg)
1970ELSE
1971 NULLIFY(this%usage_msg)
1972ENDIF
1973IF (PRESENT(description_msg)) THEN
1974 CALL fchar_to_cstr_alloc(trim(description_msg), this%description_msg)
1975ELSE
1976 NULLIFY(this%description_msg)
1977ENDIF
1978
1979END FUNCTION optionparser_new
1980
1981
1982SUBROUTINE optionparser_delete(this)
1983TYPE(optionparser),INTENT(inout) :: this
1984
1985IF (ASSOCIATED(this%usage_msg)) DEALLOCATE(this%usage_msg)
1986IF (ASSOCIATED(this%description_msg)) DEALLOCATE(this%description_msg)
1987CALL delete(this%options)
1988
1989END SUBROUTINE optionparser_delete
1990
1991
1999SUBROUTINE optionparser_add_c(this, short_opt, long_opt, dest, default, help, isopt)
2000TYPE(optionparser),INTENT(inout) :: this
2001CHARACTER(len=*),INTENT(in) :: short_opt
2002CHARACTER(len=*),INTENT(in) :: long_opt
2003CHARACTER(len=*),TARGET :: dest
2004CHARACTER(len=*),OPTIONAL :: default
2005CHARACTER(len=*),OPTIONAL :: help
2006LOGICAL,INTENT(in),OPTIONAL :: isopt
2007
2008CHARACTER(LEN=60) :: cdefault
2009INTEGER :: i
2010TYPE(option) :: myoption
2011
2012
2013IF (PRESENT(default)) THEN
2014 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2015ELSE
2016 cdefault = ''
2017ENDIF
2018
2019! common initialisation
2020myoption = option_new(short_opt, long_opt, cdefault, help)
2021IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2022
2023myoption%destc => dest(1:1)
2024myoption%destclen = len(dest) ! needed to avoid exceeding the length of dest
2025IF (PRESENT(default)) &
2026 CALL dirty_char_assignment(myoption%destc, myoption%destclen, default)
2027!IF (PRESENT(default)) myoption%destc(1:myoption%destclen) = default
2028myoption%opttype = opttype_c
2029IF (optio_log(isopt)) THEN
2030 myoption%need_arg = 1
2031ELSE
2032 myoption%need_arg = 2
2033ENDIF
2034
2035i = arrayof_option_append(this%options, myoption)
2036
2037END SUBROUTINE optionparser_add_c
2038
2039
2046SUBROUTINE optionparser_add_i(this, short_opt, long_opt, dest, default, help)
2047TYPE(optionparser),INTENT(inout) :: this
2048CHARACTER(len=*),INTENT(in) :: short_opt
2049CHARACTER(len=*),INTENT(in) :: long_opt
2050INTEGER,TARGET :: dest
2051INTEGER,OPTIONAL :: default
2052CHARACTER(len=*),OPTIONAL :: help
2053
2054CHARACTER(LEN=40) :: cdefault
2055INTEGER :: i
2056TYPE(option) :: myoption
2057
2058IF (PRESENT(default)) THEN
2059 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2060ELSE
2061 cdefault = ''
2062ENDIF
2063
2064! common initialisation
2065myoption = option_new(short_opt, long_opt, cdefault, help)
2066IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2067
2068myoption%desti => dest
2069IF (PRESENT(default)) myoption%desti = default
2070myoption%opttype = opttype_i
2071myoption%need_arg = 2
2072
2073i = arrayof_option_append(this%options, myoption)
2074
2075END SUBROUTINE optionparser_add_i
2076
2077
2087SUBROUTINE optionparser_add_iarray(this, short_opt, long_opt, dest, default, help)
2088TYPE(optionparser),INTENT(inout) :: this
2089CHARACTER(len=*),INTENT(in) :: short_opt
2090CHARACTER(len=*),INTENT(in) :: long_opt
2091TYPE(arrayof_integer),TARGET :: dest
2092INTEGER,OPTIONAL :: default(:)
2093CHARACTER(len=*),OPTIONAL :: help
2094
2095CHARACTER(LEN=40) :: cdefault
2096INTEGER :: i
2097TYPE(option) :: myoption
2098
2099cdefault = ''
2100IF (PRESENT(default)) THEN
2101 IF (SIZE(default) == 1) THEN
2102 cdefault = ' [default='//trim(to_char(default(1)))//']'
2103 ELSE IF (SIZE(default) > 1) THEN
2104 cdefault = ' [default='//trim(to_char(default(1)))//',...]'
2105 ENDIF
2106ENDIF
2107
2108! common initialisation
2109myoption = option_new(short_opt, long_opt, cdefault, help)
2110IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2111
2112myoption%destiarr => dest
2113IF (PRESENT(default)) THEN
2114 CALL insert(myoption%destiarr, default)
2115 CALL packarray(myoption%destiarr)
2116ENDIF
2117myoption%opttype = opttype_iarr
2118myoption%need_arg = 2
2119
2120i = arrayof_option_append(this%options, myoption)
2121
2122END SUBROUTINE optionparser_add_iarray
2123
2124
2131SUBROUTINE optionparser_add_r(this, short_opt, long_opt, dest, default, help)
2132TYPE(optionparser),INTENT(inout) :: this
2133CHARACTER(len=*),INTENT(in) :: short_opt
2134CHARACTER(len=*),INTENT(in) :: long_opt
2135REAL,TARGET :: dest
2136REAL,OPTIONAL :: default
2137CHARACTER(len=*),OPTIONAL :: help
2138
2139CHARACTER(LEN=40) :: cdefault
2140INTEGER :: i
2141TYPE(option) :: myoption
2142
2143IF (PRESENT(default)) THEN
2144 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2145ELSE
2146 cdefault = ''
2147ENDIF
2148
2149! common initialisation
2150myoption = option_new(short_opt, long_opt, cdefault, help)
2151IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2152
2153myoption%destr => dest
2154IF (PRESENT(default)) myoption%destr = default
2155myoption%opttype = opttype_r
2156myoption%need_arg = 2
2157
2158i = arrayof_option_append(this%options, myoption)
2159
2160END SUBROUTINE optionparser_add_r
2161
2162
2172SUBROUTINE optionparser_add_rarray(this, short_opt, long_opt, dest, default, help)
2173TYPE(optionparser),INTENT(inout) :: this
2174CHARACTER(len=*),INTENT(in) :: short_opt
2175CHARACTER(len=*),INTENT(in) :: long_opt
2176TYPE(arrayof_real),TARGET :: dest
2177REAL,OPTIONAL :: default(:)
2178CHARACTER(len=*),OPTIONAL :: help
2179
2180CHARACTER(LEN=40) :: cdefault
2181INTEGER :: i
2182TYPE(option) :: myoption
2183
2184cdefault = ''
2185IF (PRESENT(default)) THEN
2186 IF (SIZE(default) == 1) THEN
2187 cdefault = ' [default='//trim(to_char(default(1)))//']'
2188 ELSE IF (SIZE(default) > 1) THEN
2189 cdefault = ' [default='//trim(to_char(default(1)))//',...]'
2190 ENDIF
2191ENDIF
2192
2193! common initialisation
2194myoption = option_new(short_opt, long_opt, cdefault, help)
2195IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2196
2197myoption%destrarr => dest
2198IF (PRESENT(default)) THEN
2199 CALL insert(myoption%destrarr, default)
2200 CALL packarray(myoption%destrarr)
2201ENDIF
2202myoption%opttype = opttype_rarr
2203myoption%need_arg = 2
2204
2205i = arrayof_option_append(this%options, myoption)
2206
2207END SUBROUTINE optionparser_add_rarray
2208
2209
2216SUBROUTINE optionparser_add_d(this, short_opt, long_opt, dest, default, help)
2217TYPE(optionparser),INTENT(inout) :: this
2218CHARACTER(len=*),INTENT(in) :: short_opt
2219CHARACTER(len=*),INTENT(in) :: long_opt
2220DOUBLE PRECISION,TARGET :: dest
2221DOUBLE PRECISION,OPTIONAL :: default
2222CHARACTER(len=*),OPTIONAL :: help
2223
2224CHARACTER(LEN=40) :: cdefault
2225INTEGER :: i
2226TYPE(option) :: myoption
2227
2228IF (PRESENT(default)) THEN
2229 IF (c_e(default)) THEN
2230 cdefault = ' [default='//trim(adjustl(to_char(default,form='(G15.9)')))//']'
2231 ELSE
2232 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2233 ENDIF
2234ELSE
2235 cdefault = ''
2236ENDIF
2237
2238! common initialisation
2239myoption = option_new(short_opt, long_opt, cdefault, help)
2240IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2241
2242myoption%destd => dest
2243IF (PRESENT(default)) myoption%destd = default
2244myoption%opttype = opttype_d
2245myoption%need_arg = 2
2246
2247i = arrayof_option_append(this%options, myoption)
2248
2249END SUBROUTINE optionparser_add_d
2250
2251
2261SUBROUTINE optionparser_add_darray(this, short_opt, long_opt, dest, default, help)
2262TYPE(optionparser),INTENT(inout) :: this
2263CHARACTER(len=*),INTENT(in) :: short_opt
2264CHARACTER(len=*),INTENT(in) :: long_opt
2265TYPE(arrayof_doubleprecision),TARGET :: dest
2266DOUBLE PRECISION,OPTIONAL :: default(:)
2267CHARACTER(len=*),OPTIONAL :: help
2268
2269CHARACTER(LEN=40) :: cdefault
2270INTEGER :: i
2271TYPE(option) :: myoption
2272
2273cdefault = ''
2274IF (PRESENT(default)) THEN
2275 IF (SIZE(default) == 1) THEN
2276 cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//']'
2277 ELSE IF (SIZE(default) > 1) THEN
2278 cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//',...]'
2279 ENDIF
2280ENDIF
2281
2282! common initialisation
2283myoption = option_new(short_opt, long_opt, cdefault, help)
2284IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2285
2286myoption%destdarr => dest
2287IF (PRESENT(default)) THEN
2288 CALL insert(myoption%destdarr, default)
2289 CALL packarray(myoption%destdarr)
2290ENDIF
2291myoption%opttype = opttype_darr
2292myoption%need_arg = 2
2293
2294i = arrayof_option_append(this%options, myoption)
2295
2296END SUBROUTINE optionparser_add_darray
2297
2298
2305SUBROUTINE optionparser_add_l(this, short_opt, long_opt, dest, help)
2306TYPE(optionparser),INTENT(inout) :: this
2307CHARACTER(len=*),INTENT(in) :: short_opt
2308CHARACTER(len=*),INTENT(in) :: long_opt
2309LOGICAL,TARGET :: dest
2310CHARACTER(len=*),OPTIONAL :: help
2311
2312INTEGER :: i
2313TYPE(option) :: myoption
2314
2315! common initialisation
2316myoption = option_new(short_opt, long_opt, '', help)
2317IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2318
2319myoption%destl => dest
2320myoption%destl = .false. ! unconditionally set to false, option can only set it to true
2321myoption%opttype = opttype_l
2322myoption%need_arg = 0
2323
2324i = arrayof_option_append(this%options, myoption)
2325
2326END SUBROUTINE optionparser_add_l
2327
2328
2333SUBROUTINE optionparser_add_count(this, short_opt, long_opt, dest, start, help)
2334TYPE(optionparser),INTENT(inout) :: this
2335CHARACTER(len=*),INTENT(in) :: short_opt
2336CHARACTER(len=*),INTENT(in) :: long_opt
2337INTEGER,TARGET :: dest
2338INTEGER,OPTIONAL :: start
2339CHARACTER(len=*),OPTIONAL :: help
2340
2341INTEGER :: i
2342TYPE(option) :: myoption
2343
2344! common initialisation
2345myoption = option_new(short_opt, long_opt, '', help)
2346IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2347
2348myoption%destcount => dest
2349IF (PRESENT(start)) myoption%destcount = start
2350myoption%opttype = opttype_count
2351myoption%need_arg = 0
2352
2353i = arrayof_option_append(this%options, myoption)
2354
2355END SUBROUTINE optionparser_add_count
2356
2357
2372SUBROUTINE optionparser_add_help(this, short_opt, long_opt, help)
2373TYPE(optionparser),INTENT(inout) :: this
2374CHARACTER(len=*),INTENT(in) :: short_opt
2375CHARACTER(len=*),INTENT(in) :: long_opt
2376CHARACTER(len=*),OPTIONAL :: help
2377
2378INTEGER :: i
2379TYPE(option) :: myoption
2380
2381! common initialisation
2382myoption = option_new(short_opt, long_opt, '', help)
2383IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2384
2385myoption%opttype = opttype_help
2386myoption%need_arg = 1
2387
2388i = arrayof_option_append(this%options, myoption)
2389
2390END SUBROUTINE optionparser_add_help
2391
2392
2403SUBROUTINE optionparser_add_sep(this, help)
2404TYPE(optionparser),INTENT(inout) :: this
2405!CHARACTER(len=*),INTENT(in) :: short_opt !< the short option (may be empty)
2406!CHARACTER(len=*),INTENT(in) :: long_opt !< the long option (may be empty)
2407CHARACTER(len=*) :: help
2408
2409INTEGER :: i
2410TYPE(option) :: myoption
2411
2412! common initialisation
2413myoption = option_new('_', '_', '', help)
2414IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2415
2416myoption%opttype = opttype_sep
2417myoption%need_arg = 0
2418
2419i = arrayof_option_append(this%options, myoption)
2420
2421END SUBROUTINE optionparser_add_sep
2422
2423
2433SUBROUTINE optionparser_parse(this, nextarg, status)
2434TYPE(optionparser),INTENT(inout) :: this
2435INTEGER,INTENT(out) :: nextarg
2436INTEGER,INTENT(out) :: status
2437
2438INTEGER :: i, j, endopt, indeq, iargc
2439CHARACTER(len=16384) :: arg, optarg
2440
2441status = optionparser_ok
2442i = 1
2443DO WHILE(i <= iargc())
2444 CALL getarg(i, arg)
2445 IF (arg == '--') THEN ! explicit end of options
2446 i = i + 1 ! skip present option (--)
2447 EXIT
2448 ELSE IF (arg == '-') THEN ! a single - is not an option
2449 EXIT
2450 ELSE IF (arg(1:2) == '--') THEN ! long option
2451 indeq = index(arg, '=')
2452 IF (indeq /= 0) THEN ! = present
2453 endopt = indeq - 1
2454 ELSE ! no =
2455 endopt = len_trim(arg)
2456 ENDIF
2457 find_longopt: DO j = 1, this%options%arraysize
2458 IF (this%options%array(j)%long_opt == arg(3:endopt)) THEN ! found option
2459 SELECT CASE(this%options%array(j)%need_arg)
2460 CASE(2) ! compulsory
2461 IF (indeq /= 0) THEN
2462 optarg = arg(indeq+1:)
2463 status = max(option_found(this%options%array(j), optarg), &
2464 status)
2465 ELSE
2466 IF (i < iargc()) THEN
2467 i=i+1
2468 CALL getarg(i, optarg)
2469 status = max(option_found(this%options%array(j), optarg), &
2470 status)
2471 ELSE
2472 status = optionparser_err
2473 CALL l4f_log(l4f_error, &
2474 'in optionparser, option '''//trim(arg)//''' requires an argument')
2475 ENDIF
2476 ENDIF
2477 CASE(1) ! optional
2478 IF (indeq /= 0) THEN
2479 optarg = arg(indeq+1:)
2480 ELSE
2481 IF (i < iargc()) THEN
2482 CALL getarg(i+1, optarg)
2483 IF (optarg(1:1) == '-') THEN
2484 optarg = cmiss ! refused
2485 ELSE
2486 i=i+1 ! accepted
2487 ENDIF
2488 ELSE
2489 optarg = cmiss ! refused
2490 ENDIF
2491 ENDIF
2492 status = max(option_found(this%options%array(j), optarg), &
2493 status)
2494 CASE(0)
2495 status = max(option_found(this%options%array(j)), &
2496 status)
2497 END SELECT
2498 EXIT find_longopt
2499 ENDIF
2500 ENDDO find_longopt
2501 IF (j > this%options%arraysize) THEN
2502 status = optionparser_err
2503 CALL l4f_log(l4f_error, &
2504 'in optionparser, option '''//trim(arg)//''' not valid')
2505 ENDIF
2506 ELSE IF (arg(1:1) == '-') THEN ! short option
2507 find_shortopt: DO j = 1, this%options%arraysize
2508 IF (this%options%array(j)%short_opt == arg(2:2)) THEN ! found option
2509 SELECT CASE(this%options%array(j)%need_arg)
2510 CASE(2) ! compulsory
2511 IF (len_trim(arg) > 2) THEN
2512 optarg = arg(3:)
2513 status = max(option_found(this%options%array(j), optarg), &
2514 status)
2515 ELSE
2516 IF (i < iargc()) THEN
2517 i=i+1
2518 CALL getarg(i, optarg)
2519 status = max(option_found(this%options%array(j), optarg), &
2520 status)
2521 ELSE
2522 status = optionparser_err
2523 CALL l4f_log(l4f_error, &
2524 'in optionparser, option '''//trim(arg)//''' requires an argument')
2525 ENDIF
2526 ENDIF
2527 CASE(1) ! optional
2528 IF (len_trim(arg) > 2) THEN
2529 optarg = arg(3:)
2530 ELSE
2531 IF (i < iargc()) THEN
2532 CALL getarg(i+1, optarg)
2533 IF (optarg(1:1) == '-') THEN
2534 optarg = cmiss ! refused
2535 ELSE
2536 i=i+1 ! accepted
2537 ENDIF
2538 ELSE
2539 optarg = cmiss ! refused
2540 ENDIF
2541 ENDIF
2542 status = max(option_found(this%options%array(j), optarg), &
2543 status)
2544 CASE(0)
2545 status = max(option_found(this%options%array(j)), &
2546 status)
2547 END SELECT
2548 EXIT find_shortopt
2549 ENDIF
2550 ENDDO find_shortopt
2551 IF (j > this%options%arraysize) THEN
2552 status = optionparser_err
2553 CALL l4f_log(l4f_error, &
2554 'in optionparser, option '''//trim(arg)//''' not valid')
2555 ENDIF
2556 ELSE ! unrecognized = end of options
2557 EXIT
2558 ENDIF
2559 i = i + 1
2560ENDDO
2561
2562nextarg = i
2563SELECT CASE(status)
2564CASE(optionparser_err, optionparser_help)
2565 CALL optionparser_printhelp(this)
2566END SELECT
2567
2568END SUBROUTINE optionparser_parse
2569
2570
2574SUBROUTINE optionparser_printhelp(this)
2575TYPE(optionparser),INTENT(in) :: this
2576
2577INTEGER :: i, form
2578
2579form = 0
2580DO i = 1, this%options%arraysize ! loop over options
2581 IF (this%options%array(i)%opttype == opttype_help) THEN
2582 form = this%options%array(i)%helpformat
2583 ENDIF
2584ENDDO
2585
2586SELECT CASE(form)
2587CASE(0)
2588 CALL optionparser_printhelptxt(this)
2589CASE(1)
2590 CALL optionparser_printhelpmd(this)
2591CASE(2)
2592 CALL optionparser_printhelphtmlform(this)
2593END SELECT
2594
2595END SUBROUTINE optionparser_printhelp
2596
2597
2601SUBROUTINE optionparser_printhelptxt(this)
2602TYPE(optionparser),INTENT(in) :: this
2603
2604INTEGER :: i, j, ncols
2605CHARACTER(len=80) :: buf
2606TYPE(line_split) :: help_line
2607
2608ncols = default_columns()
2609
2610! print usage message
2611IF (ASSOCIATED(this%usage_msg)) THEN
2612 help_line = line_split_new(cstr_to_fchar(this%usage_msg), ncols)
2613 DO j = 1, line_split_get_nlines(help_line)
2614 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2615 ENDDO
2616 CALL delete(help_line)
2617ELSE
2618 CALL getarg(0, buf)
2619 i = index(buf, '/', back=.true.) ! remove directory part
2620 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2621 WRITE(*,'(A)')'Usage: '//trim(buf(i+1:))//' [options] [arguments]'
2622ENDIF
2623
2624! print description message
2625IF (ASSOCIATED(this%description_msg)) THEN
2626 WRITE(*,'()')
2627 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2628 DO j = 1, line_split_get_nlines(help_line)
2629 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2630 ENDDO
2631 CALL delete(help_line)
2632ENDIF
2633
2634WRITE(*,'(/,A)')'Options:'
2635
2636DO i = 1, this%options%arraysize ! loop over options
2637 CALL option_format_help(this%options%array(i), ncols)
2638ENDDO
2639
2640END SUBROUTINE optionparser_printhelptxt
2641
2642
2646SUBROUTINE optionparser_printhelpmd(this)
2647TYPE(optionparser),INTENT(in) :: this
2648
2649INTEGER :: i, j, ncols
2650CHARACTER(len=80) :: buf
2651TYPE(line_split) :: help_line
2652
2653ncols = default_columns()
2654
2655! print usage message
2656WRITE(*,'(A)')'### Synopsis'
2657
2658IF (ASSOCIATED(this%usage_msg)) THEN
2659 help_line = line_split_new(mdquote_usage_msg(cstr_to_fchar(this%usage_msg)), ncols)
2660 DO j = 1, line_split_get_nlines(help_line)
2661 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2662 ENDDO
2663 CALL delete(help_line)
2664ELSE
2665 CALL getarg(0, buf)
2666 i = index(buf, '/', back=.true.) ! remove directory part
2667 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2668 WRITE(*,'(A)')'Usage: `'//trim(buf(i+1:))//' [options] [arguments]`'
2669ENDIF
2670
2671! print description message
2672IF (ASSOCIATED(this%description_msg)) THEN
2673 WRITE(*,'()')
2674 WRITE(*,'(A)')'### Description'
2675 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2676 DO j = 1, line_split_get_nlines(help_line)
2677 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2678 ENDDO
2679 CALL delete(help_line)
2680
2681ENDIF
2682
2683WRITE(*,'(/,A)')'### Options'
2684
2685DO i = 1, this%options%arraysize ! loop over options
2686 CALL option_format_md(this%options%array(i), ncols)
2687ENDDO
2688
2689CONTAINS
2690
2691FUNCTION mdquote_usage_msg(usage_msg)
2692CHARACTER(len=*),INTENT(in) :: usage_msg
2693
2694CHARACTER(len=LEN(usage_msg)+2) :: mdquote_usage_msg
2695INTEGER :: colon
2696
2697colon = index(usage_msg, ':') ! typically 'Usage: cp [options] origin destination'
2698IF (colon > 0 .AND. colon < len(usage_msg)-1) THEN
2699 mdquote_usage_msg = usage_msg(:colon+1)//'`'//usage_msg(colon+2:)//'`'
2700ELSE
2701 mdquote_usage_msg = usage_msg
2702ENDIF
2703
2704END FUNCTION mdquote_usage_msg
2705
2706END SUBROUTINE optionparser_printhelpmd
2707
2711SUBROUTINE optionparser_printhelphtmlform(this)
2712TYPE(optionparser),INTENT(in) :: this
2713
2714INTEGER :: i
2715
2716DO i = 1, this%options%arraysize ! loop over options
2717 CALL option_format_htmlform(this%options%array(i))
2718ENDDO
2719
2720WRITE(*,'(A)')'<input class="libsim_sub" type="submit" value="runprogram" />'
2721
2722END SUBROUTINE optionparser_printhelphtmlform
2723
2724
2725SUBROUTINE optionparser_make_completion(this)
2726TYPE(optionparser),INTENT(in) :: this
2727
2728INTEGER :: i
2729CHARACTER(len=512) :: buf
2730
2731CALL getarg(0, buf)
2732
2733WRITE(*,'(A/A/A)')'_'//trim(buf)//'()','{','local cur'
2734
2735WRITE(*,'(A/A/A/A)')'COMPREPLY=()','cur=${COMP_WORDS[COMP_CWORD]}', &
2736 'case "$cur" in','-*)'
2737
2738!-*)
2739! COMPREPLY=( $( compgen -W
2740DO i = 1, this%options%arraysize ! loop over options
2741 IF (this%options%array(i)%need_arg == 2) THEN
2742 ENDIF
2743ENDDO
2744
2745WRITE(*,'(A/A/A)')'esac','return 0','}'
2746
2747END SUBROUTINE optionparser_make_completion
2748
2749
2750SUBROUTINE dirty_char_assignment(destc, destclen, src)
2751USE kinds
2752IMPLICIT NONE
2753
2754CHARACTER(len=1) :: destc(*)
2755CHARACTER(len=*) :: src
2756INTEGER :: destclen
2757
2758INTEGER :: i
2759
2760DO i = 1, min(destclen, len(src))
2761 destc(i) = src(i:i)
2762ENDDO
2763DO i = len(src)+1, destclen
2764 destc(i) = ' '
2765ENDDO
2766
2767END SUBROUTINE dirty_char_assignment
2768
2769END 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.