libsim Versione 7.2.1
optionparser_class.F90
1! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2! authors:
3! Davide Cesari <dcesari@arpa.emr.it>
4! Paolo Patruno <ppatruno@arpa.emr.it>
5
6! This program is free software; you can redistribute it and/or
7! modify it under the terms of the GNU General Public License as
8! published by the Free Software Foundation; either version 2 of
9! the License, or (at your option) any later version.
10
11! This program is distributed in the hope that it will be useful,
12! but WITHOUT ANY WARRANTY; without even the implied warranty of
13! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14! GNU General Public License for more details.
24#include "config.h"
25
29USE kinds
33IMPLICIT NONE
34
35
36! private class
37TYPE option
38 CHARACTER(len=1) :: short_opt=''
39 CHARACTER(len=80) :: long_opt=''
40 INTEGER :: opttype=-1
41 INTEGER :: need_arg=0 ! 0=no, 1=optional, 2=yes, was .FALSE.
42 LOGICAL :: has_default=.false.
43 CHARACTER(len=1),POINTER :: destc=>null()
44 INTEGER :: destclen=0
45 INTEGER :: helpformat=0 ! 0=txt, 1=markdown, 2=htmlform, improve!
46 INTEGER,POINTER :: desti=>null()
47 TYPE(arrayof_integer),POINTER :: destiarr=>null()
48 REAL,POINTER :: destr=>null()
49 TYPE(arrayof_real),POINTER :: destrarr=>null()
50 DOUBLE PRECISION, POINTER :: destd=>null()
51 TYPE(arrayof_doubleprecision),POINTER :: destdarr=>null()
52 LOGICAL,POINTER :: destl=>null()
53 TYPE(arrayof_logical),POINTER :: destlarr=>null()
54 INTEGER,POINTER :: destcount=>null()
55 INTEGER(kind=int_b),ALLOCATABLE :: help_msg(:)
56END TYPE option
57
58#define ARRAYOF_ORIGTYPE TYPE(option)
59#define ARRAYOF_TYPE arrayof_option
60#define ARRAYOF_ORIGDESTRUCTOR(x) CALL option_delete(x)
61#define ARRAYOF_PRIVATE 1
62#include "arrayof_pre_nodoc.F90"
63! from arrayof
64!PUBLIC insert, append, remove, packarray
65!PUBLIC insert_unique, append_unique
66
144TYPE optionparser
145 PRIVATE
146 INTEGER(kind=int_b),POINTER :: usage_msg(:), description_msg(:)
147 TYPE(arrayof_option) :: options
148 LOGICAL :: httpmode=.false.
149END TYPE optionparser
150
151
155INTERFACE optionparser_add
156 MODULE PROCEDURE optionparser_add_c, optionparser_add_i, optionparser_add_r, &
157 optionparser_add_d, optionparser_add_l, &
158 optionparser_add_iarray, optionparser_add_rarray, optionparser_add_darray
159END INTERFACE
160
161INTERFACE c_e
162 MODULE PROCEDURE option_c_e
163END INTERFACE
164
172INTERFACE delete
173 MODULE PROCEDURE optionparser_delete!?, option_delete
174END INTERFACE
175
176
177INTEGER,PARAMETER :: opttype_c = 1, opttype_i = 2, opttype_r = 3, &
178 opttype_d = 4, opttype_l = 5, opttype_count = 6, opttype_help = 7, &
179 opttype_sep = 8, opttype_carr = 11, opttype_iarr = 12, opttype_rarr = 13, &
180 opttype_darr = 14, opttype_larr = 15
181
182INTEGER,PARAMETER :: optionparser_ok = 0
183INTEGER,PARAMETER :: optionparser_help = 1
184INTEGER,PARAMETER :: optionparser_err = 2
185
186
187PRIVATE
188PUBLIC optionparser, optionparser_new, delete, optionparser_add, &
189 optionparser_add_count, optionparser_add_help, optionparser_add_sep, &
190 optionparser_parse, optionparser_printhelp, &
191 optionparser_ok, optionparser_help, optionparser_err
192
193
194CONTAINS
195
196#include "arrayof_post_nodoc.F90"
197
198! Constructor for the option class
199FUNCTION option_new(short_opt, long_opt, default, help) RESULT(this)
200CHARACTER(len=*),INTENT(in) :: short_opt
201CHARACTER(len=*),INTENT(in) :: long_opt
202CHARACTER(len=*),INTENT(in) :: default
203CHARACTER(len=*),OPTIONAL :: help
204TYPE(option) :: this
205
206IF (short_opt == '' .AND. long_opt == '') THEN
207#ifdef DEBUG
208! programmer error condition, option empty
209 CALL l4f_log(l4f_error, 'in optionparser, both short and long options empty')
210 CALL raise_fatal_error()
211#else
212 CALL l4f_log(l4f_warn, 'in optionparser, both short and long options empty')
213#endif
214 RETURN
215ENDIF
216
217this%short_opt = short_opt
218this%long_opt = long_opt
219IF (PRESENT(help)) THEN
220 this%help_msg = fchar_to_cstr(trim(help)//trim(default)) ! f2003 automatic alloc
221ENDIF
222this%has_default = (len_trim(default) > 0)
223
224END FUNCTION option_new
225
226
227! Destructor for the \a option class, the memory associated with
228! the object is freed.
229SUBROUTINE option_delete(this)
230TYPE(option),INTENT(inout) :: this ! object to destroy
231
232IF (ALLOCATED(this%help_msg)) DEALLOCATE(this%help_msg)
233NULLIFY(this%destc)
234NULLIFY(this%desti)
235NULLIFY(this%destr)
236NULLIFY(this%destd)
237NULLIFY(this%destl)
238NULLIFY(this%destcount)
239
240END SUBROUTINE option_delete
241
242
243FUNCTION option_found(this, optarg) RESULT(status)
244TYPE(option),INTENT(inout) :: this
245CHARACTER(len=*),INTENT(in),OPTIONAL :: optarg
246INTEGER :: status
247
248TYPE(csv_record) :: arrparser
249INTEGER :: ibuff
250REAL :: rbuff
251DOUBLE PRECISION :: dbuff
252
253status = optionparser_ok
254
255SELECT CASE(this%opttype)
256CASE(opttype_c)
257 CALL dirty_char_assignment(this%destc, this%destclen, trim(optarg))
258! this%destc(1:this%destclen) = optarg
259 IF (len_trim(optarg) > this%destclen) THEN
260 CALL l4f_log(l4f_warn, &
261 'in optionparser, argument '''//trim(optarg)//''' too long, truncated')
262 ENDIF
263CASE(opttype_i)
264 READ(optarg,'(I12)',err=100)this%desti
265CASE(opttype_iarr)
266 CALL delete(this%destiarr) ! delete default values
267 CALL init(arrparser, optarg)
268 DO WHILE(.NOT.csv_record_end(arrparser))
269 CALL csv_record_getfield(arrparser, ibuff)
270 CALL insert(this%destiarr, ibuff)
271 ENDDO
272 CALL packarray(this%destiarr)
273 CALL delete(arrparser)
274CASE(opttype_r)
275 READ(optarg,'(F20.0)',err=102)this%destr
276CASE(opttype_rarr)
277 CALL delete(this%destrarr) ! delete default values
278 CALL init(arrparser, optarg)
279 DO WHILE(.NOT.csv_record_end(arrparser))
280 CALL csv_record_getfield(arrparser, rbuff)
281 CALL insert(this%destrarr, rbuff)
282 ENDDO
283 CALL packarray(this%destrarr)
284 CALL delete(arrparser)
285CASE(opttype_d)
286 READ(optarg,'(F20.0)',err=102)this%destd
287CASE(opttype_darr)
288 CALL delete(this%destdarr) ! delete default values
289 CALL init(arrparser, optarg)
290 DO WHILE(.NOT.csv_record_end(arrparser))
291 CALL csv_record_getfield(arrparser, dbuff)
292 CALL insert(this%destdarr, dbuff)
293 ENDDO
294 CALL packarray(this%destdarr)
295 CALL delete(arrparser)
296CASE(opttype_l)
297 this%destl = .true.
298CASE(opttype_count)
299 this%destcount = this%destcount + 1
300CASE(opttype_help)
301 status = optionparser_help
302 SELECT CASE(optarg) ! set help format
303 CASE('md', 'markdown')
304 this%helpformat = 1
305 CASE('htmlform')
306 this%helpformat = 2
307 END SELECT
308END SELECT
309
310RETURN
311
312100 status = optionparser_err
313CALL l4f_log(l4f_error, &
314 'in optionparser, argument '''//trim(optarg)//''' not valid as integer')
315RETURN
316102 status = optionparser_err
317CALL l4f_log(l4f_error, &
318 'in optionparser, argument '''//trim(optarg)//''' not valid as real')
319RETURN
320
321END FUNCTION option_found
322
323
324! Return a string which gives a short representation of the
325! option \a this, without help message. The resulting string is quite
326! long and it should be trimmed with the \a TRIM() intrinsic
327! function.
328FUNCTION option_format_opt(this) RESULT(format_opt)
329TYPE(option),INTENT(in) :: this
330
331CHARACTER(len=100) :: format_opt
332
333CHARACTER(len=20) :: argname
334
335SELECT CASE(this%opttype)
336CASE(opttype_c)
337 argname = 'STRING'
338CASE(opttype_i)
339 argname = 'INT'
340CASE(opttype_iarr)
341 argname = 'INT[,INT...]'
342CASE(opttype_r, opttype_d)
343 argname = 'REAL'
344CASE(opttype_rarr, opttype_darr)
345 argname = 'REAL[,REAL...]'
346CASE default
347 argname = ''
348END SELECT
349
350format_opt = ''
351IF (this%short_opt /= '') THEN
352 format_opt(len_trim(format_opt)+1:) = ' -'//this%short_opt
353 IF (argname /= '') THEN
354 format_opt(len_trim(format_opt)+1:) = ' '//trim(argname)
355 ENDIF
356ENDIF
357IF (this%short_opt /= '' .AND. this%long_opt /= '') THEN
358 format_opt(len_trim(format_opt)+1:) = ','
359ENDIF
360IF (this%long_opt /= '') THEN
361 format_opt(len_trim(format_opt)+1:) = ' --'//this%long_opt
362 IF (argname /= '') THEN
363 format_opt(len_trim(format_opt)+1:) = '='//trim(argname)
364 ENDIF
365ENDIF
366
367END FUNCTION option_format_opt
368
369
370! print on stdout a human-readable text representation of a single option
371SUBROUTINE option_format_help(this, ncols)
372TYPE(option),INTENT(in) :: this
373INTEGER,INTENT(in) :: ncols
374
375INTEGER :: j
376INTEGER, PARAMETER :: indent = 10
377TYPE(line_split) :: help_line
378
379
380IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
381 IF (ALLOCATED(this%help_msg)) THEN
382! help2man is quite picky about the treatment of arbitrary lines
383! within options, the only universal way seems to be unindented lines
384! with an empty line before and after
385 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
386 WRITE(*,'()')
387 DO j = 1, line_split_get_nlines(help_line)
388 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
389 ENDDO
390 CALL delete(help_line)
391 WRITE(*,'()')
392 ENDIF
393ELSE ! ordinary option
394! print option brief representation
395 WRITE(*,'(A)')trim(option_format_opt(this))
396! print option help
397 IF (ALLOCATED(this%help_msg)) THEN
398 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
399 DO j = 1, line_split_get_nlines(help_line)
400 WRITE(*,'(T10,A)')trim(line_split_get_line(help_line,j))
401 ENDDO
402 CALL delete(help_line)
403 ENDIF
404ENDIF
405
406END SUBROUTINE option_format_help
407
408
409! print on stdout a markdown representation of a single option
410SUBROUTINE option_format_md(this, ncols)
411TYPE(option),INTENT(in) :: this
412INTEGER,INTENT(in) :: ncols
413
414INTEGER :: j
415INTEGER, PARAMETER :: indent = 2
416TYPE(line_split) :: help_line
417
418IF (this%opttype == opttype_sep) THEN ! special treatment for separator type
419 IF (ALLOCATED(this%help_msg)) THEN
420 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols)
421 WRITE(*,'()')
422 DO j = 1, line_split_get_nlines(help_line)
423 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
424 ENDDO
425 CALL delete(help_line)
426 WRITE(*,'()')
427 ENDIF
428ELSE ! ordinary option
429! print option brief representation
430 WRITE(*,'(''`'',A,''`'')')trim(option_format_opt(this))
431! print option help
432 IF (ALLOCATED(this%help_msg)) THEN
433 help_line = line_split_new(cstr_to_fchar(this%help_msg), ncols-indent)
434 DO j = 1, line_split_get_nlines(help_line)
435 WRITE(*,'(''> '',A)')trim(line_split_get_line(help_line,j))
436 ENDDO
437 CALL delete(help_line)
438 WRITE(*,'()')
439 ENDIF
440ENDIF
442END SUBROUTINE option_format_md
443
444
445! print on stdout an html form representation of a single option
446SUBROUTINE option_format_htmlform(this)
447TYPE(option),INTENT(in) :: this
448
449CHARACTER(len=80) :: opt_name, opt_id, opt_default ! check len of default
450
451IF (.NOT.c_e(this)) RETURN
452IF (this%long_opt == '') THEN
453 opt_name = this%short_opt
454 opt_id = 'short_opt_'//this%short_opt
455ELSE
456 opt_name = this%long_opt
457 opt_id = this%long_opt
458ENDIF
459
460SELECT CASE(this%opttype)
461CASE(opttype_c)
462 CALL option_format_html_openspan('text')
463
464 IF (this%has_default .AND. ASSOCIATED(this%destc) .AND. this%destclen > 0) THEN
465! opt_default = TRANSFER(this%destc(1:MIN(LEN(opt_default),this%destclen)), &
466! opt_default) ! improve
467 opt_default = ''
468 WRITE(*,'(A)')' value="'//trim(opt_default)//'"'
469 ENDIF
470 CALL option_format_html_help()
471 CALL option_format_html_closespan()
472
473CASE(opttype_i,opttype_r,opttype_d)
474 CALL option_format_html_openspan('text')
475 IF (this%has_default) THEN
476 SELECT CASE(this%opttype)
477 CASE(opttype_i)
478 WRITE(*,'(3A)')' value="',t2c(this%desti),'"'
479! todo CASE(opttype_iarr)
480 CASE(opttype_r)
481 WRITE(*,'(3A)')' value="',t2c(this%destr),'"'
482 CASE(opttype_d)
483 WRITE(*,'(3A)')' value="',t2c(this%destd),'"'
484 END SELECT
485 ENDIF
486 CALL option_format_html_help()
487 CALL option_format_html_closespan()
488
489! todo CASE(opttype_iarr)
490
491CASE(opttype_l)
492 CALL option_format_html_openspan('checkbox')
493 CALL option_format_html_help()
494 CALL option_format_html_closespan()
495
496CASE(opttype_count)
497 CALL option_format_html_openspan('number')
498 CALL option_format_html_help()
499 CALL option_format_html_closespan()
500
501CASE(opttype_sep)
502END SELECT
503
504
505CONTAINS
506
507SUBROUTINE option_format_html_openspan(formtype)
508CHARACTER(len=*),INTENT(in) :: formtype
509
510WRITE(*,'(A)')'<span class="libsim_optbox" id="span_'//trim(opt_id)//'">'//trim(opt_name)//':'
511! size=? maxlen=?
512WRITE(*,'(A)')'<input class_"libsim_opt" id="'//trim(opt_id)//'" type="'//formtype// &
513 '" name="'//trim(opt_id)//'" '
514
515END SUBROUTINE option_format_html_openspan
516
517SUBROUTINE option_format_html_closespan()
518
519WRITE(*,'(A)')'/></span>'
520
521END SUBROUTINE option_format_html_closespan
522
523SUBROUTINE option_format_html_help()
524INTEGER :: j
525TYPE(line_split) :: help_line
526CHARACTER(len=20) :: form
527
528IF (ALLOCATED(this%help_msg)) THEN
529 WRITE(*,'(A,$)')' title="'
530
531 help_line = line_split_new(cstr_to_fchar(this%help_msg), 80)
532 form = '(A,'' '')'
533 DO j = 1, line_split_get_nlines(help_line)
534 IF (j == line_split_get_nlines(help_line)) form = '(A,''"'',$)'
535 WRITE(*,form)trim(line_split_get_line(help_line,j)) ! lines should be properly quoted here
536 ENDDO
537
538ENDIF
539
540END SUBROUTINE option_format_html_help
541
542END SUBROUTINE option_format_htmlform
543
544
545FUNCTION option_c_e(this) RESULT(c_e)
546TYPE(option),INTENT(in) :: this
547
548LOGICAL :: c_e
549
550c_e = this%long_opt /= ' ' .OR. this%short_opt /= ' '
551
552END FUNCTION option_c_e
553
554
558FUNCTION optionparser_new(usage_msg, description_msg) RESULT(this)
559CHARACTER(len=*), INTENT(in), OPTIONAL :: usage_msg
560CHARACTER(len=*), INTENT(in), OPTIONAL :: description_msg
561
562TYPE(optionparser) :: this
563
564IF (PRESENT(usage_msg)) THEN
565 CALL fchar_to_cstr_alloc(trim(usage_msg), this%usage_msg)
566ELSE
567 NULLIFY(this%usage_msg)
568ENDIF
569IF (PRESENT(description_msg)) THEN
570 CALL fchar_to_cstr_alloc(trim(description_msg), this%description_msg)
571ELSE
572 NULLIFY(this%description_msg)
573ENDIF
574
575END FUNCTION optionparser_new
576
577
578SUBROUTINE optionparser_delete(this)
579TYPE(optionparser),INTENT(inout) :: this
580
581IF (ASSOCIATED(this%usage_msg)) DEALLOCATE(this%usage_msg)
582IF (ASSOCIATED(this%description_msg)) DEALLOCATE(this%description_msg)
583CALL delete(this%options)
584
585END SUBROUTINE optionparser_delete
586
587
595SUBROUTINE optionparser_add_c(this, short_opt, long_opt, dest, default, help, isopt)
596TYPE(optionparser),INTENT(inout) :: this
597CHARACTER(len=*),INTENT(in) :: short_opt
598CHARACTER(len=*),INTENT(in) :: long_opt
599CHARACTER(len=*),TARGET :: dest
600CHARACTER(len=*),OPTIONAL :: default
601CHARACTER(len=*),OPTIONAL :: help
602LOGICAL,INTENT(in),OPTIONAL :: isopt
603
604CHARACTER(LEN=60) :: cdefault
605INTEGER :: i
606TYPE(option) :: myoption
607
608
609IF (PRESENT(default)) THEN
610 cdefault = ' [default='//t2c(default, 'MISSING')//']'
611ELSE
612 cdefault = ''
613ENDIF
614
615! common initialisation
616myoption = option_new(short_opt, long_opt, cdefault, help)
617IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
618
619myoption%destc => dest(1:1)
620myoption%destclen = len(dest) ! needed to avoid exceeding the length of dest
621IF (PRESENT(default)) &
622 CALL dirty_char_assignment(myoption%destc, myoption%destclen, default)
623!IF (PRESENT(default)) myoption%destc(1:myoption%destclen) = default
624myoption%opttype = opttype_c
625IF (optio_log(isopt)) THEN
626 myoption%need_arg = 1
627ELSE
628 myoption%need_arg = 2
629ENDIF
630
631i = arrayof_option_append(this%options, myoption)
632
633END SUBROUTINE optionparser_add_c
634
635
642SUBROUTINE optionparser_add_i(this, short_opt, long_opt, dest, default, help)
643TYPE(optionparser),INTENT(inout) :: this
644CHARACTER(len=*),INTENT(in) :: short_opt
645CHARACTER(len=*),INTENT(in) :: long_opt
646INTEGER,TARGET :: dest
647INTEGER,OPTIONAL :: default
648CHARACTER(len=*),OPTIONAL :: help
649
650CHARACTER(LEN=40) :: cdefault
651INTEGER :: i
652TYPE(option) :: myoption
653
654IF (PRESENT(default)) THEN
655 cdefault = ' [default='//t2c(default, 'MISSING')//']'
656ELSE
657 cdefault = ''
658ENDIF
659
660! common initialisation
661myoption = option_new(short_opt, long_opt, cdefault, help)
662IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
663
664myoption%desti => dest
665IF (PRESENT(default)) myoption%desti = default
666myoption%opttype = opttype_i
667myoption%need_arg = 2
668
669i = arrayof_option_append(this%options, myoption)
670
671END SUBROUTINE optionparser_add_i
672
673
683SUBROUTINE optionparser_add_iarray(this, short_opt, long_opt, dest, default, help)
684TYPE(optionparser),INTENT(inout) :: this
685CHARACTER(len=*),INTENT(in) :: short_opt
686CHARACTER(len=*),INTENT(in) :: long_opt
687TYPE(arrayof_integer),TARGET :: dest
688INTEGER,OPTIONAL :: default(:)
689CHARACTER(len=*),OPTIONAL :: help
690
691CHARACTER(LEN=40) :: cdefault
692INTEGER :: i
693TYPE(option) :: myoption
694
695cdefault = ''
696IF (PRESENT(default)) THEN
697 IF (SIZE(default) == 1) THEN
698 cdefault = ' [default='//trim(to_char(default(1)))//']'
699 ELSE IF (SIZE(default) > 1) THEN
700 cdefault = ' [default='//trim(to_char(default(1)))//',...]'
701 ENDIF
702ENDIF
703
704! common initialisation
705myoption = option_new(short_opt, long_opt, cdefault, help)
706IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
707
708myoption%destiarr => dest
709IF (PRESENT(default)) THEN
710 CALL insert(myoption%destiarr, default)
711 CALL packarray(myoption%destiarr)
712ENDIF
713myoption%opttype = opttype_iarr
714myoption%need_arg = 2
715
716i = arrayof_option_append(this%options, myoption)
717
718END SUBROUTINE optionparser_add_iarray
719
720
727SUBROUTINE optionparser_add_r(this, short_opt, long_opt, dest, default, help)
728TYPE(optionparser),INTENT(inout) :: this
729CHARACTER(len=*),INTENT(in) :: short_opt
730CHARACTER(len=*),INTENT(in) :: long_opt
731REAL,TARGET :: dest
732REAL,OPTIONAL :: default
733CHARACTER(len=*),OPTIONAL :: help
734
735CHARACTER(LEN=40) :: cdefault
736INTEGER :: i
737TYPE(option) :: myoption
738
739IF (PRESENT(default)) THEN
740 cdefault = ' [default='//t2c(default, 'MISSING')//']'
741ELSE
742 cdefault = ''
743ENDIF
744
745! common initialisation
746myoption = option_new(short_opt, long_opt, cdefault, help)
747IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
748
749myoption%destr => dest
750IF (PRESENT(default)) myoption%destr = default
751myoption%opttype = opttype_r
752myoption%need_arg = 2
753
754i = arrayof_option_append(this%options, myoption)
755
756END SUBROUTINE optionparser_add_r
757
758
768SUBROUTINE optionparser_add_rarray(this, short_opt, long_opt, dest, default, help)
769TYPE(optionparser),INTENT(inout) :: this
770CHARACTER(len=*),INTENT(in) :: short_opt
771CHARACTER(len=*),INTENT(in) :: long_opt
772TYPE(arrayof_real),TARGET :: dest
773REAL,OPTIONAL :: default(:)
774CHARACTER(len=*),OPTIONAL :: help
775
776CHARACTER(LEN=40) :: cdefault
777INTEGER :: i
778TYPE(option) :: myoption
779
780cdefault = ''
781IF (PRESENT(default)) THEN
782 IF (SIZE(default) == 1) THEN
783 cdefault = ' [default='//trim(to_char(default(1)))//']'
784 ELSE IF (SIZE(default) > 1) THEN
785 cdefault = ' [default='//trim(to_char(default(1)))//',...]'
786 ENDIF
787ENDIF
788
789! common initialisation
790myoption = option_new(short_opt, long_opt, cdefault, help)
791IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
792
793myoption%destrarr => dest
794IF (PRESENT(default)) THEN
795 CALL insert(myoption%destrarr, default)
796 CALL packarray(myoption%destrarr)
797ENDIF
798myoption%opttype = opttype_rarr
799myoption%need_arg = 2
800
801i = arrayof_option_append(this%options, myoption)
802
803END SUBROUTINE optionparser_add_rarray
804
805
812SUBROUTINE optionparser_add_d(this, short_opt, long_opt, dest, default, help)
813TYPE(optionparser),INTENT(inout) :: this
814CHARACTER(len=*),INTENT(in) :: short_opt
815CHARACTER(len=*),INTENT(in) :: long_opt
816DOUBLE PRECISION,TARGET :: dest
817DOUBLE PRECISION,OPTIONAL :: default
818CHARACTER(len=*),OPTIONAL :: help
819
820CHARACTER(LEN=40) :: cdefault
821INTEGER :: i
822TYPE(option) :: myoption
823
824IF (PRESENT(default)) THEN
825 IF (c_e(default)) THEN
826 cdefault = ' [default='//trim(adjustl(to_char(default,form='(G15.9)')))//']'
827 ELSE
828 cdefault = ' [default='//t2c(default, 'MISSING')//']'
829 ENDIF
830ELSE
831 cdefault = ''
832ENDIF
833
834! common initialisation
835myoption = option_new(short_opt, long_opt, cdefault, help)
836IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
837
838myoption%destd => dest
839IF (PRESENT(default)) myoption%destd = default
840myoption%opttype = opttype_d
841myoption%need_arg = 2
842
843i = arrayof_option_append(this%options, myoption)
844
845END SUBROUTINE optionparser_add_d
846
847
857SUBROUTINE optionparser_add_darray(this, short_opt, long_opt, dest, default, help)
858TYPE(optionparser),INTENT(inout) :: this
859CHARACTER(len=*),INTENT(in) :: short_opt
860CHARACTER(len=*),INTENT(in) :: long_opt
861TYPE(arrayof_doubleprecision),TARGET :: dest
862DOUBLE PRECISION,OPTIONAL :: default(:)
863CHARACTER(len=*),OPTIONAL :: help
864
865CHARACTER(LEN=40) :: cdefault
866INTEGER :: i
867TYPE(option) :: myoption
868
869cdefault = ''
870IF (PRESENT(default)) THEN
871 IF (SIZE(default) == 1) THEN
872 cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//']'
873 ELSE IF (SIZE(default) > 1) THEN
874 cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//',...]'
875 ENDIF
876ENDIF
877
878! common initialisation
879myoption = option_new(short_opt, long_opt, cdefault, help)
880IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
881
882myoption%destdarr => dest
883IF (PRESENT(default)) THEN
884 CALL insert(myoption%destdarr, default)
885 CALL packarray(myoption%destdarr)
886ENDIF
887myoption%opttype = opttype_darr
888myoption%need_arg = 2
889
890i = arrayof_option_append(this%options, myoption)
891
892END SUBROUTINE optionparser_add_darray
893
894
901SUBROUTINE optionparser_add_l(this, short_opt, long_opt, dest, help)
902TYPE(optionparser),INTENT(inout) :: this
903CHARACTER(len=*),INTENT(in) :: short_opt
904CHARACTER(len=*),INTENT(in) :: long_opt
905LOGICAL,TARGET :: dest
906CHARACTER(len=*),OPTIONAL :: help
907
908INTEGER :: i
909TYPE(option) :: myoption
910
911! common initialisation
912myoption = option_new(short_opt, long_opt, '', help)
913IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
914
915myoption%destl => dest
916myoption%destl = .false. ! unconditionally set to false, option can only set it to true
917myoption%opttype = opttype_l
918myoption%need_arg = 0
919
920i = arrayof_option_append(this%options, myoption)
921
922END SUBROUTINE optionparser_add_l
923
924
929SUBROUTINE optionparser_add_count(this, short_opt, long_opt, dest, start, help)
930TYPE(optionparser),INTENT(inout) :: this
931CHARACTER(len=*),INTENT(in) :: short_opt
932CHARACTER(len=*),INTENT(in) :: long_opt
933INTEGER,TARGET :: dest
934INTEGER,OPTIONAL :: start
935CHARACTER(len=*),OPTIONAL :: help
936
937INTEGER :: i
938TYPE(option) :: myoption
939
940! common initialisation
941myoption = option_new(short_opt, long_opt, '', help)
942IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
943
944myoption%destcount => dest
945IF (PRESENT(start)) myoption%destcount = start
946myoption%opttype = opttype_count
947myoption%need_arg = 0
948
949i = arrayof_option_append(this%options, myoption)
950
951END SUBROUTINE optionparser_add_count
952
953
968SUBROUTINE optionparser_add_help(this, short_opt, long_opt, help)
969TYPE(optionparser),INTENT(inout) :: this
970CHARACTER(len=*),INTENT(in) :: short_opt
971CHARACTER(len=*),INTENT(in) :: long_opt
972CHARACTER(len=*),OPTIONAL :: help
973
974INTEGER :: i
975TYPE(option) :: myoption
976
977! common initialisation
978myoption = option_new(short_opt, long_opt, '', help)
979IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
980
981myoption%opttype = opttype_help
982myoption%need_arg = 1
983
984i = arrayof_option_append(this%options, myoption)
985
986END SUBROUTINE optionparser_add_help
987
988
999SUBROUTINE optionparser_add_sep(this, help)
1000TYPE(optionparser),INTENT(inout) :: this
1001!CHARACTER(len=*),INTENT(in) :: short_opt !< the short option (may be empty)
1002!CHARACTER(len=*),INTENT(in) :: long_opt !< the long option (may be empty)
1003CHARACTER(len=*) :: help
1004
1005INTEGER :: i
1006TYPE(option) :: myoption
1007
1008! common initialisation
1009myoption = option_new('_', '_', '', help)
1010IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
1011
1012myoption%opttype = opttype_sep
1013myoption%need_arg = 0
1014
1015i = arrayof_option_append(this%options, myoption)
1016
1017END SUBROUTINE optionparser_add_sep
1018
1019
1029SUBROUTINE optionparser_parse(this, nextarg, status)
1030TYPE(optionparser),INTENT(inout) :: this
1031INTEGER,INTENT(out) :: nextarg
1032INTEGER,INTENT(out) :: status
1033
1034INTEGER :: i, j, endopt, indeq, iargc
1035CHARACTER(len=16384) :: arg, optarg
1036
1037status = optionparser_ok
1038i = 1
1039DO WHILE(i <= iargc())
1040 CALL getarg(i, arg)
1041 IF (arg == '--') THEN ! explicit end of options
1042 i = i + 1 ! skip present option (--)
1043 EXIT
1044 ELSE IF (arg == '-') THEN ! a single - is not an option
1045 EXIT
1046 ELSE IF (arg(1:2) == '--') THEN ! long option
1047 indeq = index(arg, '=')
1048 IF (indeq /= 0) THEN ! = present
1049 endopt = indeq - 1
1050 ELSE ! no =
1051 endopt = len_trim(arg)
1052 ENDIF
1053 find_longopt: DO j = 1, this%options%arraysize
1054 IF (this%options%array(j)%long_opt == arg(3:endopt)) THEN ! found option
1055 SELECT CASE(this%options%array(j)%need_arg)
1056 CASE(2) ! compulsory
1057 IF (indeq /= 0) THEN
1058 optarg = arg(indeq+1:)
1059 status = max(option_found(this%options%array(j), optarg), &
1060 status)
1061 ELSE
1062 IF (i < iargc()) THEN
1063 i=i+1
1064 CALL getarg(i, optarg)
1065 status = max(option_found(this%options%array(j), optarg), &
1066 status)
1067 ELSE
1068 status = optionparser_err
1069 CALL l4f_log(l4f_error, &
1070 'in optionparser, option '''//trim(arg)//''' requires an argument')
1071 ENDIF
1072 ENDIF
1073 CASE(1) ! optional
1074 IF (indeq /= 0) THEN
1075 optarg = arg(indeq+1:)
1076 ELSE
1077 IF (i < iargc()) THEN
1078 CALL getarg(i+1, optarg)
1079 IF (optarg(1:1) == '-') THEN
1080 optarg = cmiss ! refused
1081 ELSE
1082 i=i+1 ! accepted
1083 ENDIF
1084 ELSE
1085 optarg = cmiss ! refused
1086 ENDIF
1087 ENDIF
1088 status = max(option_found(this%options%array(j), optarg), &
1089 status)
1090 CASE(0)
1091 status = max(option_found(this%options%array(j)), &
1092 status)
1093 END SELECT
1094 EXIT find_longopt
1095 ENDIF
1096 ENDDO find_longopt
1097 IF (j > this%options%arraysize) THEN
1098 status = optionparser_err
1099 CALL l4f_log(l4f_error, &
1100 'in optionparser, option '''//trim(arg)//''' not valid')
1101 ENDIF
1102 ELSE IF (arg(1:1) == '-') THEN ! short option
1103 find_shortopt: DO j = 1, this%options%arraysize
1104 IF (this%options%array(j)%short_opt == arg(2:2)) THEN ! found option
1105 SELECT CASE(this%options%array(j)%need_arg)
1106 CASE(2) ! compulsory
1107 IF (len_trim(arg) > 2) THEN
1108 optarg = arg(3:)
1109 status = max(option_found(this%options%array(j), optarg), &
1110 status)
1111 ELSE
1112 IF (i < iargc()) THEN
1113 i=i+1
1114 CALL getarg(i, optarg)
1115 status = max(option_found(this%options%array(j), optarg), &
1116 status)
1117 ELSE
1118 status = optionparser_err
1119 CALL l4f_log(l4f_error, &
1120 'in optionparser, option '''//trim(arg)//''' requires an argument')
1121 ENDIF
1122 ENDIF
1123 CASE(1) ! optional
1124 IF (len_trim(arg) > 2) THEN
1125 optarg = arg(3:)
1126 ELSE
1127 IF (i < iargc()) THEN
1128 CALL getarg(i+1, optarg)
1129 IF (optarg(1:1) == '-') THEN
1130 optarg = cmiss ! refused
1131 ELSE
1132 i=i+1 ! accepted
1133 ENDIF
1134 ELSE
1135 optarg = cmiss ! refused
1136 ENDIF
1137 ENDIF
1138 status = max(option_found(this%options%array(j), optarg), &
1139 status)
1140 CASE(0)
1141 status = max(option_found(this%options%array(j)), &
1142 status)
1143 END SELECT
1144 EXIT find_shortopt
1145 ENDIF
1146 ENDDO find_shortopt
1147 IF (j > this%options%arraysize) THEN
1148 status = optionparser_err
1149 CALL l4f_log(l4f_error, &
1150 'in optionparser, option '''//trim(arg)//''' not valid')
1151 ENDIF
1152 ELSE ! unrecognized = end of options
1153 EXIT
1154 ENDIF
1155 i = i + 1
1156ENDDO
1157
1158nextarg = i
1159SELECT CASE(status)
1160CASE(optionparser_err, optionparser_help)
1161 CALL optionparser_printhelp(this)
1162END SELECT
1163
1164END SUBROUTINE optionparser_parse
1165
1166
1170SUBROUTINE optionparser_printhelp(this)
1171TYPE(optionparser),INTENT(in) :: this
1172
1173INTEGER :: i, form
1174
1175form = 0
1176DO i = 1, this%options%arraysize ! loop over options
1177 IF (this%options%array(i)%opttype == opttype_help) THEN
1178 form = this%options%array(i)%helpformat
1179 ENDIF
1180ENDDO
1181
1182SELECT CASE(form)
1183CASE(0)
1184 CALL optionparser_printhelptxt(this)
1185CASE(1)
1186 CALL optionparser_printhelpmd(this)
1187CASE(2)
1188 CALL optionparser_printhelphtmlform(this)
1189END SELECT
1190
1191END SUBROUTINE optionparser_printhelp
1192
1193
1197SUBROUTINE optionparser_printhelptxt(this)
1198TYPE(optionparser),INTENT(in) :: this
1199
1200INTEGER :: i, j, ncols
1201CHARACTER(len=80) :: buf
1202TYPE(line_split) :: help_line
1203
1204ncols = default_columns()
1205
1206! print usage message
1207IF (ASSOCIATED(this%usage_msg)) THEN
1208 help_line = line_split_new(cstr_to_fchar(this%usage_msg), ncols)
1209 DO j = 1, line_split_get_nlines(help_line)
1210 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1211 ENDDO
1212 CALL delete(help_line)
1213ELSE
1214 CALL getarg(0, buf)
1215 i = index(buf, '/', back=.true.) ! remove directory part
1216 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
1217 WRITE(*,'(A)')'Usage: '//trim(buf(i+1:))//' [options] [arguments]'
1218ENDIF
1219
1220! print description message
1221IF (ASSOCIATED(this%description_msg)) THEN
1222 WRITE(*,'()')
1223 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
1224 DO j = 1, line_split_get_nlines(help_line)
1225 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1226 ENDDO
1227 CALL delete(help_line)
1228ENDIF
1229
1230WRITE(*,'(/,A)')'Options:'
1231
1232DO i = 1, this%options%arraysize ! loop over options
1233 CALL option_format_help(this%options%array(i), ncols)
1234ENDDO
1235
1236END SUBROUTINE optionparser_printhelptxt
1237
1238
1242SUBROUTINE optionparser_printhelpmd(this)
1243TYPE(optionparser),INTENT(in) :: this
1244
1245INTEGER :: i, j, ncols
1246CHARACTER(len=80) :: buf
1247TYPE(line_split) :: help_line
1248
1249ncols = default_columns()
1250
1251! print usage message
1252WRITE(*,'(A)')'### Synopsis'
1253
1254IF (ASSOCIATED(this%usage_msg)) THEN
1255 help_line = line_split_new(mdquote_usage_msg(cstr_to_fchar(this%usage_msg)), ncols)
1256 DO j = 1, line_split_get_nlines(help_line)
1257 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1258 ENDDO
1259 CALL delete(help_line)
1260ELSE
1261 CALL getarg(0, buf)
1262 i = index(buf, '/', back=.true.) ! remove directory part
1263 IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
1264 WRITE(*,'(A)')'Usage: `'//trim(buf(i+1:))//' [options] [arguments]`'
1265ENDIF
1266
1267! print description message
1268IF (ASSOCIATED(this%description_msg)) THEN
1269 WRITE(*,'()')
1270 WRITE(*,'(A)')'### Description'
1271 help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
1272 DO j = 1, line_split_get_nlines(help_line)
1273 WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1274 ENDDO
1275 CALL delete(help_line)
1276
1277ENDIF
1278
1279WRITE(*,'(/,A)')'### Options'
1280
1281DO i = 1, this%options%arraysize ! loop over options
1282 CALL option_format_md(this%options%array(i), ncols)
1283ENDDO
1284
1285CONTAINS
1286
1287FUNCTION mdquote_usage_msg(usage_msg)
1288CHARACTER(len=*),INTENT(in) :: usage_msg
1289
1290CHARACTER(len=LEN(usage_msg)+2) :: mdquote_usage_msg
1291INTEGER :: colon
1292
1293colon = index(usage_msg, ':') ! typically 'Usage: cp [options] origin destination'
1294IF (colon > 0 .AND. colon < len(usage_msg)-1) THEN
1295 mdquote_usage_msg = usage_msg(:colon+1)//'`'//usage_msg(colon+2:)//'`'
1296ELSE
1297 mdquote_usage_msg = usage_msg
1298ENDIF
1299
1300END FUNCTION mdquote_usage_msg
1301
1302END SUBROUTINE optionparser_printhelpmd
1303
1307SUBROUTINE optionparser_printhelphtmlform(this)
1308TYPE(optionparser),INTENT(in) :: this
1310INTEGER :: i
1311
1312DO i = 1, this%options%arraysize ! loop over options
1313 CALL option_format_htmlform(this%options%array(i))
1314ENDDO
1315
1316WRITE(*,'(A)')'<input class="libsim_sub" type="submit" value="runprogram" />'
1317
1318END SUBROUTINE optionparser_printhelphtmlform
1319
1320
1321SUBROUTINE optionparser_make_completion(this)
1322TYPE(optionparser),INTENT(in) :: this
1323
1324INTEGER :: i
1325CHARACTER(len=512) :: buf
1326
1327CALL getarg(0, buf)
1328
1329WRITE(*,'(A/A/A)')'_'//trim(buf)//'()','{','local cur'
1330
1331WRITE(*,'(A/A/A/A)')'COMPREPLY=()','cur=${COMP_WORDS[COMP_CWORD]}', &
1332 'case "$cur" in','-*)'
1333
1334!-*)
1335! COMPREPLY=( $( compgen -W
1336DO i = 1, this%options%arraysize ! loop over options
1337 IF (this%options%array(i)%need_arg == 2) THEN
1338 ENDIF
1339ENDDO
1340
1341WRITE(*,'(A/A/A)')'esac','return 0','}'
1342
1343END SUBROUTINE optionparser_make_completion
1344
1345
1346SUBROUTINE dirty_char_assignment(destc, destclen, src)
1347USE kinds
1348IMPLICIT NONE
1349
1350CHARACTER(len=1) :: destc(*)
1351CHARACTER(len=*) :: src
1352INTEGER :: destclen
1353
1354INTEGER :: i
1355
1356DO i = 1, min(destclen, len(src))
1357 destc(i) = src(i:i)
1358ENDDO
1359DO i = len(src)+1, destclen
1360 destc(i) = ' '
1361ENDDO
1362
1363END SUBROUTINE dirty_char_assignment
1364
1365END 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.
Derived type defining a dynamically extensible array of DOUBLEPRECISION elements.
Derived type defining a dynamically extensible array of INTEGER elements.
Derived type defining a dynamically extensible array of REAL elements.
Class that allows splitting a long line into shorter lines of equal length at the occurrence of a spe...
Class for interpreting the records of a csv file.
This class allows to parse the command-line options of a program in an object-oriented way,...

Generated with Doxygen.