libsim Versione 7.2.1

◆ 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 )
private

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

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