libsim Versione 7.2.4

◆ optionparser_add_count()

subroutine, public optionparser_add_count ( type(optionparser), intent(inout) this,
character(len=*), intent(in) short_opt,
character(len=*), intent(in) long_opt,
integer, target dest,
integer, optional start,
character(len=*), optional help )

Add a new counter option, without optional argument.

When parsing will be performed, the provided destination will be incremented by one, starting from start, each time the requested option is encountered.

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
startinitial value for dest
helpthe help message that will be formatted and pretty-printed on screen

Definizione alla linea 1426 del file optionparser_class.F90.

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