libsim Versione 7.2.1

◆ optionparser_parse()

subroutine, public optionparser_parse ( type(optionparser), intent(inout)  this,
integer, intent(out)  nextarg,
integer, intent(out)  status 
)

This method performs the parsing of the command-line options which have been previously added using the optionparser_add family of methods.

The destination variables set through the optionparser_add methods are assigned according to the options encountered on the command line. If any optional argument remains after interpretation of all command-line options, the index of the first of them is returned in nextarg, otherwise nextarg is equal to iargc() + 1. The status of the parsing process should be checked via the status argument.

Parametri
[in,out]thisoptionparser object with correctly initialised options
[out]nextargindex of the first optional argument after interpretation of all command-line options
[out]statusstatus of the parsing process, to be compared with the constants optionparser_ok, ecc.

Definizione alla linea 1526 del file optionparser_class.F90.

1527! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
1528! authors:
1529! Davide Cesari <dcesari@arpa.emr.it>
1530! Paolo Patruno <ppatruno@arpa.emr.it>
1531
1532! This program is free software; you can redistribute it and/or
1533! modify it under the terms of the GNU General Public License as
1534! published by the Free Software Foundation; either version 2 of
1535! the License, or (at your option) any later version.
1536
1537! This program is distributed in the hope that it will be useful,
1538! but WITHOUT ANY WARRANTY; without even the implied warranty of
1539! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1540! GNU General Public License for more details.
1550#include "config.h"
1551
1552MODULE optionparser_class
1553USE log4fortran
1554USE err_handling
1555USE kinds
1559IMPLICIT NONE
1560
1561
1562! private class
1563TYPE option
1564 CHARACTER(len=1) :: short_opt=''
1565 CHARACTER(len=80) :: long_opt=''
1566 INTEGER :: opttype=-1
1567 INTEGER :: need_arg=0 ! 0=no, 1=optional, 2=yes, was .FALSE.
1568 LOGICAL :: has_default=.false.
1569 CHARACTER(len=1),POINTER :: destc=>null()
1570 INTEGER :: destclen=0
1571 INTEGER :: helpformat=0 ! 0=txt, 1=markdown, 2=htmlform, improve!
1572 INTEGER,POINTER :: desti=>null()
1573 TYPE(arrayof_integer),POINTER :: destiarr=>null()
1574 REAL,POINTER :: destr=>null()
1575 TYPE(arrayof_real),POINTER :: destrarr=>null()
1576 DOUBLE PRECISION, POINTER :: destd=>null()
1577 TYPE(arrayof_doubleprecision),POINTER :: destdarr=>null()
1578 LOGICAL,POINTER :: destl=>null()
1579 TYPE(arrayof_logical),POINTER :: destlarr=>null()
1580 INTEGER,POINTER :: destcount=>null()
1581 INTEGER(kind=int_b),ALLOCATABLE :: help_msg(:)
1582END TYPE option
1583
1584#define ARRAYOF_ORIGTYPE TYPE(option)
1585#define ARRAYOF_TYPE arrayof_option
1586#define ARRAYOF_ORIGDESTRUCTOR(x) CALL option_delete(x)
1587#define ARRAYOF_PRIVATE 1
1588#include "arrayof_pre_nodoc.F90"
1589! from arrayof
1590!PUBLIC insert, append, remove, packarray
1591!PUBLIC insert_unique, append_unique
1592
1670TYPE optionparser
1671 PRIVATE
1672 INTEGER(kind=int_b),POINTER :: usage_msg(:), description_msg(:)
1673 TYPE(arrayof_option) :: options
1674 LOGICAL :: httpmode=.false.
1675END TYPE optionparser
1676
1677
1681INTERFACE optionparser_add
1682 MODULE PROCEDURE optionparser_add_c, optionparser_add_i, optionparser_add_r, &
1683 optionparser_add_d, optionparser_add_l, &
1684 optionparser_add_iarray, optionparser_add_rarray, optionparser_add_darray
1685END INTERFACE
1686
1687INTERFACE c_e
1688 MODULE PROCEDURE option_c_e
1689END INTERFACE
1690
1698INTERFACE delete
1699 MODULE PROCEDURE optionparser_delete!?, option_delete
1700END INTERFACE
1701
1702
1703INTEGER,PARAMETER :: opttype_c = 1, opttype_i = 2, opttype_r = 3, &
1704 opttype_d = 4, opttype_l = 5, opttype_count = 6, opttype_help = 7, &
1705 opttype_sep = 8, opttype_carr = 11, opttype_iarr = 12, opttype_rarr = 13, &
1706 opttype_darr = 14, opttype_larr = 15
1707
1708INTEGER,PARAMETER :: optionparser_ok = 0
1709INTEGER,PARAMETER :: optionparser_help = 1
1710INTEGER,PARAMETER :: optionparser_err = 2
1711
1712
1713PRIVATE
1714PUBLIC optionparser, optionparser_new, delete, optionparser_add, &
1715 optionparser_add_count, optionparser_add_help, optionparser_add_sep, &
1716 optionparser_parse, optionparser_printhelp, &
1717 optionparser_ok, optionparser_help, optionparser_err
1718
1719
1720CONTAINS
1721
1722#include "arrayof_post_nodoc.F90"
1723
1724! Constructor for the option class
1725FUNCTION option_new(short_opt, long_opt, default, help) RESULT(this)
1726CHARACTER(len=*),INTENT(in) :: short_opt
1727CHARACTER(len=*),INTENT(in) :: long_opt
1728CHARACTER(len=*),INTENT(in) :: default
1729CHARACTER(len=*),OPTIONAL :: help
1730TYPE(option) :: this
1731
1732IF (short_opt == '' .AND. long_opt == '') THEN
1733#ifdef DEBUG
1734! programmer error condition, option empty
1735 CALL l4f_log(l4f_error, 'in optionparser, both short and long options empty')
1736 CALL raise_fatal_error()
1737#else
1738 CALL l4f_log(l4f_warn, 'in optionparser, both short and long options empty')
1739#endif
1740 RETURN
1741ENDIF
1742
1743this%short_opt = short_opt
1744this%long_opt = long_opt
1745IF (PRESENT(help)) THEN
1746 this%help_msg = fchar_to_cstr(trim(help)//trim(default)) ! f2003 automatic alloc
1747ENDIF
1748this%has_default = (len_trim(default) > 0)
1749
1750END FUNCTION option_new
1751
1752
1753! Destructor for the \a option class, the memory associated with
1754! the object is freed.
1755SUBROUTINE option_delete(this)
1756TYPE(option),INTENT(inout) :: this ! object to destroy
1757
1758IF (ALLOCATED(this%help_msg)) DEALLOCATE(this%help_msg)
1759NULLIFY(this%destc)
1760NULLIFY(this%desti)
1761NULLIFY(this%destr)
1762NULLIFY(this%destd)
1763NULLIFY(this%destl)
1764NULLIFY(this%destcount)
1765
1766END SUBROUTINE option_delete
1767
1768
1769FUNCTION option_found(this, optarg) RESULT(status)
1770TYPE(option),INTENT(inout) :: this
1771CHARACTER(len=*),INTENT(in),OPTIONAL :: optarg
1772INTEGER :: status
1773
1774TYPE(csv_record) :: arrparser
1775INTEGER :: ibuff
1776REAL :: rbuff
1777DOUBLE PRECISION :: dbuff
1778
1779status = optionparser_ok
1780
1781SELECT CASE(this%opttype)
1782CASE(opttype_c)
1783 CALL dirty_char_assignment(this%destc, this%destclen, trim(optarg))
1784! this%destc(1:this%destclen) = optarg
1785 IF (len_trim(optarg) > this%destclen) THEN
1786 CALL l4f_log(l4f_warn, &
1787 'in optionparser, argument '''//trim(optarg)//''' too long, truncated')
1788 ENDIF
1789CASE(opttype_i)
1790 READ(optarg,'(I12)',err=100)this%desti
1791CASE(opttype_iarr)
1792 CALL delete(this%destiarr) ! delete default values
1793 CALL init(arrparser, optarg)
1794 DO WHILE(.NOT.csv_record_end(arrparser))
1795 CALL csv_record_getfield(arrparser, ibuff)
1796 CALL insert(this%destiarr, ibuff)
1797 ENDDO
1798 CALL packarray(this%destiarr)
1799 CALL delete(arrparser)
1800CASE(opttype_r)
1801 READ(optarg,'(F20.0)',err=102)this%destr
1802CASE(opttype_rarr)
1803 CALL delete(this%destrarr) ! delete default values
1804 CALL init(arrparser, optarg)
1805 DO WHILE(.NOT.csv_record_end(arrparser))
1806 CALL csv_record_getfield(arrparser, rbuff)
1807 CALL insert(this%destrarr, rbuff)
1808 ENDDO
1809 CALL packarray(this%destrarr)
1810 CALL delete(arrparser)
1811CASE(opttype_d)
1812 READ(optarg,'(F20.0)',err=102)this%destd
1813CASE(opttype_darr)
1814 CALL delete(this%destdarr) ! delete default values
1815 CALL init(arrparser, optarg)
1816 DO WHILE(.NOT.csv_record_end(arrparser))
1817 CALL csv_record_getfield(arrparser, dbuff)
1818 CALL insert(this%destdarr, dbuff)
1819 ENDDO
1820 CALL packarray(this%destdarr)
1821 CALL delete(arrparser)
1822CASE(opttype_l)
1823 this%destl = .true.
1824CASE(opttype_count)
1825 this%destcount = this%destcount + 1
1826CASE(opttype_help)
1827 status = optionparser_help
1828 SELECT CASE(optarg) ! set help format
1829 CASE('md', 'markdown')
1830 this%helpformat = 1
1831 CASE('htmlform')
1832 this%helpformat = 2
1833 END SELECT
1834END SELECT
1835
1836RETURN
1837
1838100 status = optionparser_err
1839CALL l4f_log(l4f_error, &
1840 'in optionparser, argument '''//trim(optarg)//''' not valid as integer')
1841RETURN
1842102 status = optionparser_err
1843CALL l4f_log(l4f_error, &
1844 'in optionparser, argument '''//trim(optarg)//''' not valid as real')
1845RETURN
1846
1847END FUNCTION option_found
1848
1849
1850! Return a string which gives a short representation of the
1851! option \a this, without help message. The resulting string is quite
1852! long and it should be trimmed with the \a TRIM() intrinsic
1853! function.
1854FUNCTION option_format_opt(this) RESULT(format_opt)
1855TYPE(option),INTENT(in) :: this
1856
1857CHARACTER(len=100) :: format_opt
1858
1859CHARACTER(len=20) :: argname
1860
1861SELECT CASE(this%opttype)
1862CASE(opttype_c)
1863 argname = 'STRING'
1864CASE(opttype_i)
1865 argname = 'INT'
1866CASE(opttype_iarr)
1867 argname = 'INT[,INT...]'
1868CASE(opttype_r, opttype_d)
1869 argname = 'REAL'
1870CASE(opttype_rarr, opttype_darr)
1871 argname = 'REAL[,REAL...]'
1872CASE default
1873 argname = ''
1874END SELECT
1875
1876format_opt = ''
1877IF (this%short_opt /= '') THEN
1878 format_opt(len_trim(format_opt)+1:) = ' -'//this%short_opt
1879 IF (argname /= '') THEN
1880 format_opt(len_trim(format_opt)+1:) = ' '//trim(argname)
1881 ENDIF
1882ENDIF
1883IF (this%short_opt /= '' .AND. this%long_opt /= '') THEN
1884 format_opt(len_trim(format_opt)+1:) = ','
1885ENDIF
1886IF (this%long_opt /= '') THEN
1887 format_opt(len_trim(format_opt)+1:) = ' --'//this%long_opt
1888 IF (argname /= '') THEN
1889 format_opt(len_trim(format_opt)+1:) = '='//trim(argname)
1890 ENDIF
1891ENDIF
1892
1893END FUNCTION option_format_opt
1894
1895
1896! print on stdout a human-readable text representation of a single option
1897SUBROUTINE option_format_help(this, ncols)
1898TYPE(option),INTENT(in) :: this
1899INTEGER,INTENT(in) :: ncols
1900
1901INTEGER :: j
1902INTEGER, PARAMETER :: indent = 10
1903TYPE(line_split) :: help_line
1904
1905
1906IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
1907 IF (ALLOCATED(this%help_msg)) THEN
1908! help2man is quite picky about the treatment of arbitrary lines
1909! within options, the only universal way seems to be unindented lines
1910! with an empty line before and after
1911 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
1912 WRITE(*,'()')
1913 DO j = 1, line_split_get_nlines(help_line)
1914 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1915 ENDDO
1916 CALL delete(help_line)
1917 WRITE(*,'()')
1918 ENDIF
1919ELSE ! ordinary option
1920! print option brief representation
1921 WRITE(*,'(A)')trim(option_format_opt(this))
1922! print option help
1923 IF (ALLOCATED(this%help_msg)) THEN
1924 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
1925 DO j = 1, line_split_get_nlines(help_line)
1926 WRITE(*,'(T10,A)')trim(line_split_get_line(help_line,j))
1927 ENDDO
1928 CALL delete(help_line)
1929 ENDIF
1930ENDIF
1931
1932END SUBROUTINE option_format_help
1933
1934
1935! print on stdout a markdown representation of a single option
1936SUBROUTINE option_format_md(this, ncols)
1937TYPE(option),INTENT(in) :: this
1938INTEGER,INTENT(in) :: ncols
1939
1940INTEGER :: j
1941INTEGER, PARAMETER :: indent = 2
1942TYPE(line_split) :: help_line
1943
1944IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
1945 IF (ALLOCATED(this%help_msg)) THEN
1946 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
1947 WRITE(*,'()')
1948 DO j = 1, line_split_get_nlines(help_line)
1949 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1950 ENDDO
1951 CALL delete(help_line)
1952 WRITE(*,'()')
1953 ENDIF
1954ELSE ! ordinary option
1955! print option brief representation
1956 WRITE(*,'(''`'',A,''`'')')trim(option_format_opt(this))
1957! print option help
1958 IF (ALLOCATED(this%help_msg)) THEN
1959 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
1960 DO j = 1, line_split_get_nlines(help_line)
1961 WRITE(*,'(''> '',A)')trim(line_split_get_line(help_line,j))
1962 ENDDO
1963 CALL delete(help_line)
1964 WRITE(*,'()')
1965 ENDIF
1966ENDIF
1967
1968END SUBROUTINE option_format_md
1969
1970
1971! print on stdout an html form representation of a single option
1972SUBROUTINE option_format_htmlform(this)
1973TYPE(option),INTENT(in) :: this
1974
1975CHARACTER(len=80) :: opt_name, opt_id, opt_default ! check len of default
1976
1977IF (.NOT.c_e(this)) RETURN
1978IF (this%long_opt == '') THEN
1979 opt_name = this%short_opt
1980 opt_id = 'short_opt_'//this%short_opt
1981ELSE
1982 opt_name = this%long_opt
1983 opt_id = this%long_opt
1984ENDIF
1985
1986SELECT CASE(this%opttype)
1987CASE(opttype_c)
1988 CALL option_format_html_openspan('text')
1989
1990 IF (this%has_default .AND. ASSOCIATED(this%destc) .AND. this%destclen > 0) THEN
1991! opt_default = TRANSFER(this%destc(1:MIN(LEN(opt_default),this%destclen)), &
1992! opt_default) ! improve
1993 opt_default = ''
1994 WRITE(*,'(A)')' value="'//trim(opt_default)//'"'
1995 ENDIF
1996 CALL option_format_html_help()
1997 CALL option_format_html_closespan()
1998
1999CASE(opttype_i,opttype_r,opttype_d)
2000 CALL option_format_html_openspan('text')
2001 IF (this%has_default) THEN
2002 SELECT CASE(this%opttype)
2003 CASE(opttype_i)
2004 WRITE(*,'(3A)')' value="',t2c(this%desti),'"'
2005! todo CASE(opttype_iarr)
2006 CASE(opttype_r)
2007 WRITE(*,'(3A)')' value="',t2c(this%destr),'"'
2008 CASE(opttype_d)
2009 WRITE(*,'(3A)')' value="',t2c(this%destd),'"'
2010 END SELECT
2011 ENDIF
2012 CALL option_format_html_help()
2013 CALL option_format_html_closespan()
2014
2015! todo CASE(opttype_iarr)
2016
2017CASE(opttype_l)
2018 CALL option_format_html_openspan('checkbox')
2019 CALL option_format_html_help()
2020 CALL option_format_html_closespan()
2021
2022CASE(opttype_count)
2023 CALL option_format_html_openspan('number')
2024 CALL option_format_html_help()
2025 CALL option_format_html_closespan()
2026
2027CASE(opttype_sep)
2028END SELECT
2029
2030
2031CONTAINS
2032
2033SUBROUTINE option_format_html_openspan(formtype)
2034CHARACTER(len=*),INTENT(in) :: formtype
2035
2036WRITE(*,'(A)')'<span class="libsim_optbox" id="span_'//trim(opt_id)//'">'//trim(opt_name)//':'
2037! size=? maxlen=?
2038WRITE(*,'(A)')'<input class_"libsim_opt" id="'//trim(opt_id)//'" type="'//formtype// &
2039 '" name="'//trim(opt_id)//'" '
2040
2041END SUBROUTINE option_format_html_openspan
2042
2043SUBROUTINE option_format_html_closespan()
2044
2045WRITE(*,'(A)')'/></span>'
2046
2047END SUBROUTINE option_format_html_closespan
2048
2049SUBROUTINE option_format_html_help()
2050INTEGER :: j
2051TYPE(line_split) :: help_line
2052CHARACTER(len=20) :: form
2053
2054IF (ALLOCATED(this%help_msg)) THEN
2055 WRITE(*,'(A,$)')' title="'
2056
2057 help_line = line_split_new(cstr_to_fchar(this%help_msg), 80)
2058 form = '(A,'' '')'
2059 DO j = 1, line_split_get_nlines(help_line)
2060 IF (j == line_split_get_nlines(help_line)) form = '(A,''"'',$)'
2061 WRITE(*,form)trim(line_split_get_line(help_line,j)) ! lines should be properly quoted here
2062 ENDDO
2063
2064ENDIF
2065
2066END SUBROUTINE option_format_html_help
2067
2068END SUBROUTINE option_format_htmlform
2069
2070
2071FUNCTION option_c_e(this) RESULT(c_e)
2072TYPE(option),INTENT(in) :: this
2073
2074LOGICAL :: c_e
2075
2076c_e = this%long_opt /= ' ' .OR. this%short_opt /= ' '
2077
2078END FUNCTION option_c_e
2079
2080
2084FUNCTION optionparser_new(usage_msg, description_msg) RESULT(this)
2085CHARACTER(len=*), INTENT(in), OPTIONAL :: usage_msg
2086CHARACTER(len=*), INTENT(in), OPTIONAL :: description_msg
2087
2088TYPE(optionparser) :: this
2089
2090IF (PRESENT(usage_msg)) THEN
2091 CALL fchar_to_cstr_alloc(trim(usage_msg), this%usage_msg)
2092ELSE
2093 NULLIFY(this%usage_msg)
2094ENDIF
2095IF (PRESENT(description_msg)) THEN
2096 CALL fchar_to_cstr_alloc(trim(description_msg), this%description_msg)
2097ELSE
2098 NULLIFY(this%description_msg)
2099ENDIF
2100
2101END FUNCTION optionparser_new
2102
2103
2104SUBROUTINE optionparser_delete(this)
2105TYPE(optionparser),INTENT(inout) :: this
2106
2107IF (ASSOCIATED(this%usage_msg)) DEALLOCATE(this%usage_msg)
2108IF (ASSOCIATED(this%description_msg)) DEALLOCATE(this%description_msg)
2109CALL delete(this%options)
2110
2111END SUBROUTINE optionparser_delete
2112
2113
2121SUBROUTINE optionparser_add_c(this, short_opt, long_opt, dest, default, help, isopt)
2122TYPE(optionparser),INTENT(inout) :: this
2123CHARACTER(len=*),INTENT(in) :: short_opt
2124CHARACTER(len=*),INTENT(in) :: long_opt
2125CHARACTER(len=*),TARGET :: dest
2126CHARACTER(len=*),OPTIONAL :: default
2127CHARACTER(len=*),OPTIONAL :: help
2128LOGICAL,INTENT(in),OPTIONAL :: isopt
2129
2130CHARACTER(LEN=60) :: cdefault
2131INTEGER :: i
2132TYPE(option) :: myoption
2133
2134
2135IF (PRESENT(default)) THEN
2136 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2137ELSE
2138 cdefault = ''
2139ENDIF
2140
2141! common initialisation
2142myoption = option_new(short_opt, long_opt, cdefault, help)
2143IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2144
2145myoption%destc => dest(1:1)
2146myoption%destclen = len(dest) ! needed to avoid exceeding the length of dest
2147IF (PRESENT(default)) &
2148 CALL dirty_char_assignment(myoption%destc, myoption%destclen, default)
2149!IF (PRESENT(default)) myoption%destc(1:myoption%destclen) = default
2150myoption%opttype = opttype_c
2151IF (optio_log(isopt)) THEN
2152 myoption%need_arg = 1
2153ELSE
2154 myoption%need_arg = 2
2155ENDIF
2156
2157i = arrayof_option_append(this%options, myoption)
2158
2159END SUBROUTINE optionparser_add_c
2160
2161
2168SUBROUTINE optionparser_add_i(this, short_opt, long_opt, dest, default, help)
2169TYPE(optionparser),INTENT(inout) :: this
2170CHARACTER(len=*),INTENT(in) :: short_opt
2171CHARACTER(len=*),INTENT(in) :: long_opt
2172INTEGER,TARGET :: dest
2173INTEGER,OPTIONAL :: default
2174CHARACTER(len=*),OPTIONAL :: help
2175
2176CHARACTER(LEN=40) :: cdefault
2177INTEGER :: i
2178TYPE(option) :: myoption
2179
2180IF (PRESENT(default)) THEN
2181 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2182ELSE
2183 cdefault = ''
2184ENDIF
2185
2186! common initialisation
2187myoption = option_new(short_opt, long_opt, cdefault, help)
2188IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2189
2190myoption%desti => dest
2191IF (PRESENT(default)) myoption%desti = default
2192myoption%opttype = opttype_i
2193myoption%need_arg = 2
2194
2195i = arrayof_option_append(this%options, myoption)
2196
2197END SUBROUTINE optionparser_add_i
2198
2199
2209SUBROUTINE optionparser_add_iarray(this, short_opt, long_opt, dest, default, help)
2210TYPE(optionparser),INTENT(inout) :: this
2211CHARACTER(len=*),INTENT(in) :: short_opt
2212CHARACTER(len=*),INTENT(in) :: long_opt
2213TYPE(arrayof_integer),TARGET :: dest
2214INTEGER,OPTIONAL :: default(:)
2215CHARACTER(len=*),OPTIONAL :: help
2216
2217CHARACTER(LEN=40) :: cdefault
2218INTEGER :: i
2219TYPE(option) :: myoption
2220
2221cdefault = ''
2222IF (PRESENT(default)) THEN
2223 IF (SIZE(default) == 1) THEN
2224 cdefault = ' [default='//trim(to_char(default(1)))//']'
2225 ELSE IF (SIZE(default) > 1) THEN
2226 cdefault = ' [default='//trim(to_char(default(1)))//',...]'
2227 ENDIF
2228ENDIF
2229
2230! common initialisation
2231myoption = option_new(short_opt, long_opt, cdefault, help)
2232IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2233
2234myoption%destiarr => dest
2235IF (PRESENT(default)) THEN
2236 CALL insert(myoption%destiarr, default)
2237 CALL packarray(myoption%destiarr)
2238ENDIF
2239myoption%opttype = opttype_iarr
2240myoption%need_arg = 2
2241
2242i = arrayof_option_append(this%options, myoption)
2243
2244END SUBROUTINE optionparser_add_iarray
2245
2246
2253SUBROUTINE optionparser_add_r(this, short_opt, long_opt, dest, default, help)
2254TYPE(optionparser),INTENT(inout) :: this
2255CHARACTER(len=*),INTENT(in) :: short_opt
2256CHARACTER(len=*),INTENT(in) :: long_opt
2257REAL,TARGET :: dest
2258REAL,OPTIONAL :: default
2259CHARACTER(len=*),OPTIONAL :: help
2260
2261CHARACTER(LEN=40) :: cdefault
2262INTEGER :: i
2263TYPE(option) :: myoption
2264
2265IF (PRESENT(default)) THEN
2266 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2267ELSE
2268 cdefault = ''
2269ENDIF
2270
2271! common initialisation
2272myoption = option_new(short_opt, long_opt, cdefault, help)
2273IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2274
2275myoption%destr => dest
2276IF (PRESENT(default)) myoption%destr = default
2277myoption%opttype = opttype_r
2278myoption%need_arg = 2
2279
2280i = arrayof_option_append(this%options, myoption)
2281
2282END SUBROUTINE optionparser_add_r
2283
2284
2294SUBROUTINE optionparser_add_rarray(this, short_opt, long_opt, dest, default, help)
2295TYPE(optionparser),INTENT(inout) :: this
2296CHARACTER(len=*),INTENT(in) :: short_opt
2297CHARACTER(len=*),INTENT(in) :: long_opt
2298TYPE(arrayof_real),TARGET :: dest
2299REAL,OPTIONAL :: default(:)
2300CHARACTER(len=*),OPTIONAL :: help
2301
2302CHARACTER(LEN=40) :: cdefault
2303INTEGER :: i
2304TYPE(option) :: myoption
2305
2306cdefault = ''
2307IF (PRESENT(default)) THEN
2308 IF (SIZE(default) == 1) THEN
2309 cdefault = ' [default='//trim(to_char(default(1)))//']'
2310 ELSE IF (SIZE(default) > 1) THEN
2311 cdefault = ' [default='//trim(to_char(default(1)))//',...]'
2312 ENDIF
2313ENDIF
2314
2315! common initialisation
2316myoption = option_new(short_opt, long_opt, cdefault, help)
2317IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2318
2319myoption%destrarr => dest
2320IF (PRESENT(default)) THEN
2321 CALL insert(myoption%destrarr, default)
2322 CALL packarray(myoption%destrarr)
2323ENDIF
2324myoption%opttype = opttype_rarr
2325myoption%need_arg = 2
2326
2327i = arrayof_option_append(this%options, myoption)
2328
2329END SUBROUTINE optionparser_add_rarray
2330
2331
2338SUBROUTINE optionparser_add_d(this, short_opt, long_opt, dest, default, help)
2339TYPE(optionparser),INTENT(inout) :: this
2340CHARACTER(len=*),INTENT(in) :: short_opt
2341CHARACTER(len=*),INTENT(in) :: long_opt
2342DOUBLE PRECISION,TARGET :: dest
2343DOUBLE PRECISION,OPTIONAL :: default
2344CHARACTER(len=*),OPTIONAL :: help
2345
2346CHARACTER(LEN=40) :: cdefault
2347INTEGER :: i
2348TYPE(option) :: myoption
2349
2350IF (PRESENT(default)) THEN
2351 IF (c_e(default)) THEN
2352 cdefault = ' [default='//trim(adjustl(to_char(default,form='(G15.9)')))//']'
2353 ELSE
2354 cdefault = ' [default='//t2c(default, 'MISSING')//']'
2355 ENDIF
2356ELSE
2357 cdefault = ''
2358ENDIF
2359
2360! common initialisation
2361myoption = option_new(short_opt, long_opt, cdefault, help)
2362IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2363
2364myoption%destd => dest
2365IF (PRESENT(default)) myoption%destd = default
2366myoption%opttype = opttype_d
2367myoption%need_arg = 2
2368
2369i = arrayof_option_append(this%options, myoption)
2370
2371END SUBROUTINE optionparser_add_d
2372
2373
2383SUBROUTINE optionparser_add_darray(this, short_opt, long_opt, dest, default, help)
2384TYPE(optionparser),INTENT(inout) :: this
2385CHARACTER(len=*),INTENT(in) :: short_opt
2386CHARACTER(len=*),INTENT(in) :: long_opt
2387TYPE(arrayof_doubleprecision),TARGET :: dest
2388DOUBLE PRECISION,OPTIONAL :: default(:)
2389CHARACTER(len=*),OPTIONAL :: help
2390
2391CHARACTER(LEN=40) :: cdefault
2392INTEGER :: i
2393TYPE(option) :: myoption
2394
2395cdefault = ''
2396IF (PRESENT(default)) THEN
2397 IF (SIZE(default) == 1) THEN
2398 cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//']'
2399 ELSE IF (SIZE(default) > 1) THEN
2400 cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//',...]'
2401 ENDIF
2402ENDIF
2403
2404! common initialisation
2405myoption = option_new(short_opt, long_opt, cdefault, help)
2406IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2407
2408myoption%destdarr => dest
2409IF (PRESENT(default)) THEN
2410 CALL insert(myoption%destdarr, default)
2411 CALL packarray(myoption%destdarr)
2412ENDIF
2413myoption%opttype = opttype_darr
2414myoption%need_arg = 2
2415
2416i = arrayof_option_append(this%options, myoption)
2417
2418END SUBROUTINE optionparser_add_darray
2419
2420
2427SUBROUTINE optionparser_add_l(this, short_opt, long_opt, dest, help)
2428TYPE(optionparser),INTENT(inout) :: this
2429CHARACTER(len=*),INTENT(in) :: short_opt
2430CHARACTER(len=*),INTENT(in) :: long_opt
2431LOGICAL,TARGET :: dest
2432CHARACTER(len=*),OPTIONAL :: help
2433
2434INTEGER :: i
2435TYPE(option) :: myoption
2436
2437! common initialisation
2438myoption = option_new(short_opt, long_opt, '', help)
2439IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2440
2441myoption%destl => dest
2442myoption%destl = .false. ! unconditionally set to false, option can only set it to true
2443myoption%opttype = opttype_l
2444myoption%need_arg = 0
2445
2446i = arrayof_option_append(this%options, myoption)
2447
2448END SUBROUTINE optionparser_add_l
2449
2450
2455SUBROUTINE optionparser_add_count(this, short_opt, long_opt, dest, start, help)
2456TYPE(optionparser),INTENT(inout) :: this
2457CHARACTER(len=*),INTENT(in) :: short_opt
2458CHARACTER(len=*),INTENT(in) :: long_opt
2459INTEGER,TARGET :: dest
2460INTEGER,OPTIONAL :: start
2461CHARACTER(len=*),OPTIONAL :: help
2462
2463INTEGER :: i
2464TYPE(option) :: myoption
2465
2466! common initialisation
2467myoption = option_new(short_opt, long_opt, '', help)
2468IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2469
2470myoption%destcount => dest
2471IF (PRESENT(start)) myoption%destcount = start
2472myoption%opttype = opttype_count
2473myoption%need_arg = 0
2474
2475i = arrayof_option_append(this%options, myoption)
2476
2477END SUBROUTINE optionparser_add_count
2478
2479
2494SUBROUTINE optionparser_add_help(this, short_opt, long_opt, help)
2495TYPE(optionparser),INTENT(inout) :: this
2496CHARACTER(len=*),INTENT(in) :: short_opt
2497CHARACTER(len=*),INTENT(in) :: long_opt
2498CHARACTER(len=*),OPTIONAL :: help
2499
2500INTEGER :: i
2501TYPE(option) :: myoption
2502
2503! common initialisation
2504myoption = option_new(short_opt, long_opt, '', help)
2505IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2506
2507myoption%opttype = opttype_help
2508myoption%need_arg = 1
2509
2510i = arrayof_option_append(this%options, myoption)
2511
2512END SUBROUTINE optionparser_add_help
2513
2514
2525SUBROUTINE optionparser_add_sep(this, help)
2526TYPE(optionparser),INTENT(inout) :: this
2527!CHARACTER(len=*),INTENT(in) :: short_opt !< the short option (may be empty)
2528!CHARACTER(len=*),INTENT(in) :: long_opt !< the long option (may be empty)
2529CHARACTER(len=*) :: help
2530
2531INTEGER :: i
2532TYPE(option) :: myoption
2533
2534! common initialisation
2535myoption = option_new('_', '_', '', help)
2536IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
2537
2538myoption%opttype = opttype_sep
2539myoption%need_arg = 0
2540
2541i = arrayof_option_append(this%options, myoption)
2542
2543END SUBROUTINE optionparser_add_sep
2544
2545
2555SUBROUTINE optionparser_parse(this, nextarg, status)
2556TYPE(optionparser),INTENT(inout) :: this
2557INTEGER,INTENT(out) :: nextarg
2558INTEGER,INTENT(out) :: status
2559
2560INTEGER :: i, j, endopt, indeq, iargc
2561CHARACTER(len=16384) :: arg, optarg
2562
2563status = optionparser_ok
2564i = 1
2565DO WHILE(i <= iargc())
2566 CALL getarg(i, arg)
2567 IF (arg == '--') THEN ! explicit end of options
2568 i = i + 1 ! skip present option (--)
2569 EXIT
2570 ELSE IF (arg == '-') THEN ! a single - is not an option
2571 EXIT
2572 ELSE IF (arg(1:2) == '--') THEN ! long option
2573 indeq = index(arg, '=')
2574 IF (indeq /= 0) THEN ! = present
2575 endopt = indeq - 1
2576 ELSE ! no =
2577 endopt = len_trim(arg)
2578 ENDIF
2579 find_longopt: DO j = 1, this%options%arraysize
2580 IF (this%options%array(j)%long_opt == arg(3:endopt)) THEN ! found option
2581 SELECT CASE(this%options%array(j)%need_arg)
2582 CASE(2) ! compulsory
2583 IF (indeq /= 0) THEN
2584 optarg = arg(indeq+1:)
2585 status = max(option_found(this%options%array(j), optarg), &
2586 status)
2587 ELSE
2588 IF (i < iargc()) THEN
2589 i=i+1
2590 CALL getarg(i, optarg)
2591 status = max(option_found(this%options%array(j), optarg), &
2592 status)
2593 ELSE
2594 status = optionparser_err
2595 CALL l4f_log(l4f_error, &
2596 'in optionparser, option '''//trim(arg)//''' requires an argument')
2597 ENDIF
2598 ENDIF
2599 CASE(1) ! optional
2600 IF (indeq /= 0) THEN
2601 optarg = arg(indeq+1:)
2602 ELSE
2603 IF (i < iargc()) THEN
2604 CALL getarg(i+1, optarg)
2605 IF (optarg(1:1) == '-') THEN
2606 optarg = cmiss ! refused
2607 ELSE
2608 i=i+1 ! accepted
2609 ENDIF
2610 ELSE
2611 optarg = cmiss ! refused
2612 ENDIF
2613 ENDIF
2614 status = max(option_found(this%options%array(j), optarg), &
2615 status)
2616 CASE(0)
2617 status = max(option_found(this%options%array(j)), &
2618 status)
2619 END SELECT
2620 EXIT find_longopt
2621 ENDIF
2622 ENDDO find_longopt
2623 IF (j > this%options%arraysize) THEN
2624 status = optionparser_err
2625 CALL l4f_log(l4f_error, &
2626 'in optionparser, option '''//trim(arg)//''' not valid')
2627 ENDIF
2628 ELSE IF (arg(1:1) == '-') THEN ! short option
2629 find_shortopt: DO j = 1, this%options%arraysize
2630 IF (this%options%array(j)%short_opt == arg(2:2)) THEN ! found option
2631 SELECT CASE(this%options%array(j)%need_arg)
2632 CASE(2) ! compulsory
2633 IF (len_trim(arg) > 2) THEN
2634 optarg = arg(3:)
2635 status = max(option_found(this%options%array(j), optarg), &
2636 status)
2637 ELSE
2638 IF (i < iargc()) THEN
2639 i=i+1
2640 CALL getarg(i, optarg)
2641 status = max(option_found(this%options%array(j), optarg), &
2642 status)
2643 ELSE
2644 status = optionparser_err
2645 CALL l4f_log(l4f_error, &
2646 'in optionparser, option '''//trim(arg)//''' requires an argument')
2647 ENDIF
2648 ENDIF
2649 CASE(1) ! optional
2650 IF (len_trim(arg) > 2) THEN
2651 optarg = arg(3:)
2652 ELSE
2653 IF (i < iargc()) THEN
2654 CALL getarg(i+1, optarg)
2655 IF (optarg(1:1) == '-') THEN
2656 optarg = cmiss ! refused
2657 ELSE
2658 i=i+1 ! accepted
2659 ENDIF
2660 ELSE
2661 optarg = cmiss ! refused
2662 ENDIF
2663 ENDIF
2664 status = max(option_found(this%options%array(j), optarg), &
2665 status)
2666 CASE(0)
2667 status = max(option_found(this%options%array(j)), &
2668 status)
2669 END SELECT
2670 EXIT find_shortopt
2671 ENDIF
2672 ENDDO find_shortopt
2673 IF (j > this%options%arraysize) THEN
2674 status = optionparser_err
2675 CALL l4f_log(l4f_error, &
2676 'in optionparser, option '''//trim(arg)//''' not valid')
2677 ENDIF
2678 ELSE ! unrecognized = end of options
2679 EXIT
2680 ENDIF
2681 i = i + 1
2682ENDDO
2683
2684nextarg = i
2685SELECT CASE(status)
2686CASE(optionparser_err, optionparser_help)
2687 CALL optionparser_printhelp(this)
2688END SELECT
2689
2690END SUBROUTINE optionparser_parse
2691
2692
2696SUBROUTINE optionparser_printhelp(this)
2697TYPE(optionparser),INTENT(in) :: this
2698
2699INTEGER :: i, form
2700
2701form = 0
2702DO i = 1, this%options%arraysize ! loop over options
2703 IF (this%options%array(i)%opttype == opttype_help) THEN
2704 form = this%options%array(i)%helpformat
2705 ENDIF
2706ENDDO
2707
2708SELECT CASE(form)
2709CASE(0)
2710 CALL optionparser_printhelptxt(this)
2711CASE(1)
2712 CALL optionparser_printhelpmd(this)
2713CASE(2)
2714 CALL optionparser_printhelphtmlform(this)
2715END SELECT
2716
2717END SUBROUTINE optionparser_printhelp
2718
2719
2723SUBROUTINE optionparser_printhelptxt(this)
2724TYPE(optionparser),INTENT(in) :: this
2725
2726INTEGER :: i, j, ncols
2727CHARACTER(len=80) :: buf
2728TYPE(line_split) :: help_line
2729
2730ncols = default_columns()
2731
2732! print usage message
2733IF (ASSOCIATED(this%usage_msg)) THEN
2734 help_line = line_split_new(cstr_to_fchar(this%usage_msg), ncols)
2735 DO j = 1, line_split_get_nlines(help_line)
2736 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2737 ENDDO
2738 CALL delete(help_line)
2739ELSE
2740 CALL getarg(0, buf)
2741 i = index(buf, '/', back=.true.) ! remove directory part
2742 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2743 WRITE(*,'(A)')'Usage: '//trim(buf(i+1:))//' [options] [arguments]'
2744ENDIF
2745
2746! print description message
2747IF (ASSOCIATED(this%description_msg)) THEN
2748 WRITE(*,'()')
2749 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2750 DO j = 1, line_split_get_nlines(help_line)
2751 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2752 ENDDO
2753 CALL delete(help_line)
2754ENDIF
2755
2756WRITE(*,'(/,A)')'Options:'
2757
2758DO i = 1, this%options%arraysize ! loop over options
2759 CALL option_format_help(this%options%array(i), ncols)
2760ENDDO
2761
2762END SUBROUTINE optionparser_printhelptxt
2763
2764
2768SUBROUTINE optionparser_printhelpmd(this)
2769TYPE(optionparser),INTENT(in) :: this
2770
2771INTEGER :: i, j, ncols
2772CHARACTER(len=80) :: buf
2773TYPE(line_split) :: help_line
2774
2775ncols = default_columns()
2776
2777! print usage message
2778WRITE(*,'(A)')'### Synopsis'
2779
2780IF (ASSOCIATED(this%usage_msg)) THEN
2781 help_line = line_split_new(mdquote_usage_msg(cstr_to_fchar(this%usage_msg)), ncols)
2782 DO j = 1, line_split_get_nlines(help_line)
2783 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2784 ENDDO
2785 CALL delete(help_line)
2786ELSE
2787 CALL getarg(0, buf)
2788 i = index(buf, '/', back=.true.) ! remove directory part
2789 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
2790 WRITE(*,'(A)')'Usage: `'//trim(buf(i+1:))//' [options] [arguments]`'
2791ENDIF
2792
2793! print description message
2794IF (ASSOCIATED(this%description_msg)) THEN
2795 WRITE(*,'()')
2796 WRITE(*,'(A)')'### Description'
2797 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
2798 DO j = 1, line_split_get_nlines(help_line)
2799 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
2800 ENDDO
2801 CALL delete(help_line)
2802
2803ENDIF
2804
2805WRITE(*,'(/,A)')'### Options'
2806
2807DO i = 1, this%options%arraysize ! loop over options
2808 CALL option_format_md(this%options%array(i), ncols)
2809ENDDO
2810
2811CONTAINS
2812
2813FUNCTION mdquote_usage_msg(usage_msg)
2814CHARACTER(len=*),INTENT(in) :: usage_msg
2815
2816CHARACTER(len=LEN(usage_msg)+2) :: mdquote_usage_msg
2817INTEGER :: colon
2818
2819colon = index(usage_msg, ':') ! typically 'Usage: cp [options] origin destination'
2820IF (colon > 0 .AND. colon < len(usage_msg)-1) THEN
2821 mdquote_usage_msg = usage_msg(:colon+1)//'`'//usage_msg(colon+2:)//'`'
2822ELSE
2823 mdquote_usage_msg = usage_msg
2824ENDIF
2825
2826END FUNCTION mdquote_usage_msg
2827
2828END SUBROUTINE optionparser_printhelpmd
2829
2833SUBROUTINE optionparser_printhelphtmlform(this)
2834TYPE(optionparser),INTENT(in) :: this
2835
2836INTEGER :: i
2837
2838DO i = 1, this%options%arraysize ! loop over options
2839 CALL option_format_htmlform(this%options%array(i))
2840ENDDO
2841
2842WRITE(*,'(A)')'<input class="libsim_sub" type="submit" value="runprogram" />'
2843
2844END SUBROUTINE optionparser_printhelphtmlform
2845
2846
2847SUBROUTINE optionparser_make_completion(this)
2848TYPE(optionparser),INTENT(in) :: this
2849
2850INTEGER :: i
2851CHARACTER(len=512) :: buf
2852
2853CALL getarg(0, buf)
2854
2855WRITE(*,'(A/A/A)')'_'//trim(buf)//'()','{','local cur'
2856
2857WRITE(*,'(A/A/A/A)')'COMPREPLY=()','cur=${COMP_WORDS[COMP_CWORD]}', &
2858 'case "$cur" in','-*)'
2859
2860!-*)
2861! COMPREPLY=( $( compgen -W
2862DO i = 1, this%options%arraysize ! loop over options
2863 IF (this%options%array(i)%need_arg == 2) THEN
2864 ENDIF
2865ENDDO
2866
2867WRITE(*,'(A/A/A)')'esac','return 0','}'
2868
2869END SUBROUTINE optionparser_make_completion
2870
2871
2872SUBROUTINE dirty_char_assignment(destc, destclen, src)
2873USE kinds
2874IMPLICIT NONE
2875
2876CHARACTER(len=1) :: destc(*)
2877CHARACTER(len=*) :: src
2878INTEGER :: destclen
2879
2880INTEGER :: i
2881
2882DO i = 1, min(destclen, len(src))
2883 destc(i) = src(i:i)
2884ENDDO
2885DO i = len(src)+1, destclen
2886 destc(i) = ' '
2887ENDDO
2888
2889END SUBROUTINE dirty_char_assignment
2890
2891END 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.