libsim  Versione 7.1.7
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 
26 MODULE optionparser_class
27 USE log4fortran
28 USE err_handling
29 USE kinds
33 IMPLICIT NONE
34 
35 
36 ! private class
37 TYPE 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(:)
56 END 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 
144 TYPE optionparser
145  PRIVATE
146  INTEGER(kind=int_b),POINTER :: usage_msg(:), description_msg(:)
147  TYPE(arrayof_option) :: options
148  LOGICAL :: httpmode=.false.
149 END TYPE optionparser
150 
151 
155 INTERFACE 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
159 END INTERFACE
160 
161 INTERFACE c_e
162  MODULE PROCEDURE option_c_e
163 END INTERFACE
164 
172 INTERFACE delete
173  MODULE PROCEDURE optionparser_delete!?, option_delete
174 END INTERFACE
175 
176 
177 INTEGER,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 
182 INTEGER,PARAMETER :: optionparser_ok = 0
183 INTEGER,PARAMETER :: optionparser_help = 1
184 INTEGER,PARAMETER :: optionparser_err = 2
185 
186 
187 PRIVATE
188 PUBLIC 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 
194 CONTAINS
195 
196 #include "arrayof_post_nodoc.F90"
197 
198 ! Constructor for the option class
199 FUNCTION option_new(short_opt, long_opt, default, help) RESULT(this)
200 CHARACTER(len=*),INTENT(in) :: short_opt
201 CHARACTER(len=*),INTENT(in) :: long_opt
202 CHARACTER(len=*),INTENT(in) :: default
203 CHARACTER(len=*),OPTIONAL :: help
204 TYPE(option) :: this
205 
206 IF (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
215 ENDIF
216 
217 this%short_opt = short_opt
218 this%long_opt = long_opt
219 IF (PRESENT(help)) THEN
220  this%help_msg = fchar_to_cstr(trim(help)//trim(default)) ! f2003 automatic alloc
221 ENDIF
222 this%has_default = (len_trim(default) > 0)
223 
224 END FUNCTION option_new
225 
226 
227 ! Destructor for the \a option class, the memory associated with
228 ! the object is freed.
229 SUBROUTINE option_delete(this)
230 TYPE(option),INTENT(inout) :: this ! object to destroy
231 
232 IF (ALLOCATED(this%help_msg)) DEALLOCATE(this%help_msg)
233 NULLIFY(this%destc)
234 NULLIFY(this%desti)
235 NULLIFY(this%destr)
236 NULLIFY(this%destd)
237 NULLIFY(this%destl)
238 NULLIFY(this%destcount)
239 
240 END SUBROUTINE option_delete
241 
242 
243 FUNCTION option_found(this, optarg) RESULT(status)
244 TYPE(option),INTENT(inout) :: this
245 CHARACTER(len=*),INTENT(in),OPTIONAL :: optarg
246 INTEGER :: status
247 
248 TYPE(csv_record) :: arrparser
249 INTEGER :: ibuff
250 REAL :: rbuff
251 DOUBLE PRECISION :: dbuff
252 
253 status = optionparser_ok
254 
255 SELECT CASE(this%opttype)
256 CASE(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
263 CASE(opttype_i)
264  READ(optarg,'(I12)',err=100)this%desti
265 CASE(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)
274 CASE(opttype_r)
275  READ(optarg,'(F20.0)',err=102)this%destr
276 CASE(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)
285 CASE(opttype_d)
286  READ(optarg,'(F20.0)',err=102)this%destd
287 CASE(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)
296 CASE(opttype_l)
297  this%destl = .true.
298 CASE(opttype_count)
299  this%destcount = this%destcount + 1
300 CASE(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
308 END SELECT
309 
310 RETURN
311 
312 100 status = optionparser_err
313 CALL l4f_log(l4f_error, &
314  'in optionparser, argument '''//trim(optarg)//''' not valid as integer')
315 RETURN
316 102 status = optionparser_err
317 CALL l4f_log(l4f_error, &
318  'in optionparser, argument '''//trim(optarg)//''' not valid as real')
319 RETURN
320 
321 END 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.
328 FUNCTION option_format_opt(this) RESULT(format_opt)
329 TYPE(option),INTENT(in) :: this
330 
331 CHARACTER(len=100) :: format_opt
332 
333 CHARACTER(len=20) :: argname
334 
335 SELECT CASE(this%opttype)
336 CASE(opttype_c)
337  argname = 'STRING'
338 CASE(opttype_i)
339  argname = 'INT'
340 CASE(opttype_iarr)
341  argname = 'INT[,INT...]'
342 CASE(opttype_r, opttype_d)
343  argname = 'REAL'
344 CASE(opttype_rarr, opttype_darr)
345  argname = 'REAL[,REAL...]'
346 CASE default
347  argname = ''
348 END SELECT
349 
350 format_opt = ''
351 IF (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
356 ENDIF
357 IF (this%short_opt /= '' .AND. this%long_opt /= '') THEN
358  format_opt(len_trim(format_opt)+1:) = ','
359 ENDIF
360 IF (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
365 ENDIF
366 
367 END FUNCTION option_format_opt
368 
369 
370 ! print on stdout a human-readable text representation of a single option
371 SUBROUTINE option_format_help(this, ncols)
372 TYPE(option),INTENT(in) :: this
373 INTEGER,INTENT(in) :: ncols
374 
375 INTEGER :: j
376 INTEGER, PARAMETER :: indent = 10
377 TYPE(line_split) :: help_line
378 
379 
380 IF (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
393 ELSE ! 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
404 ENDIF
405 
406 END SUBROUTINE option_format_help
407 
408 
409 ! print on stdout a markdown representation of a single option
410 SUBROUTINE option_format_md(this, ncols)
411 TYPE(option),INTENT(in) :: this
412 INTEGER,INTENT(in) :: ncols
413 
414 INTEGER :: j
415 INTEGER, PARAMETER :: indent = 2
416 TYPE(line_split) :: help_line
417 
418 IF (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
428 ELSE ! 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
440 ENDIF
441 
442 END SUBROUTINE option_format_md
443 
444 
445 ! print on stdout an html form representation of a single option
446 SUBROUTINE option_format_htmlform(this)
447 TYPE(option),INTENT(in) :: this
448 
449 CHARACTER(len=80) :: opt_name, opt_id, opt_default ! check len of default
450 
451 IF (.NOT.c_e(this)) RETURN
452 IF (this%long_opt == '') THEN
453  opt_name = this%short_opt
454  opt_id = 'short_opt_'//this%short_opt
455 ELSE
456  opt_name = this%long_opt
457  opt_id = this%long_opt
458 ENDIF
459 
460 SELECT CASE(this%opttype)
461 CASE(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 
473 CASE(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 
491 CASE(opttype_l)
492  CALL option_format_html_openspan('checkbox')
493  CALL option_format_html_help()
494  CALL option_format_html_closespan()
495 
496 CASE(opttype_count)
497  CALL option_format_html_openspan('number')
498  CALL option_format_html_help()
499  CALL option_format_html_closespan()
500 
501 CASE(opttype_sep)
502 END SELECT
503 
504 
505 CONTAINS
506 
507 SUBROUTINE option_format_html_openspan(formtype)
508 CHARACTER(len=*),INTENT(in) :: formtype
509 
510 WRITE(*,'(A)')'<span class="libsim_optbox" id="span_'//trim(opt_id)//'">'//trim(opt_name)//':'
511 ! size=? maxlen=?
512 WRITE(*,'(A)')'<input class_"libsim_opt" id="'//trim(opt_id)//'" type="'//formtype// &
513  '" name="'//trim(opt_id)//'" '
514 
515 END SUBROUTINE option_format_html_openspan
516 
517 SUBROUTINE option_format_html_closespan()
518 
519 WRITE(*,'(A)')'/></span>'
520 
521 END SUBROUTINE option_format_html_closespan
522 
523 SUBROUTINE option_format_html_help()
524 INTEGER :: j
525 TYPE(line_split) :: help_line
526 CHARACTER(len=20) :: form
527 
528 IF (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 
538 ENDIF
539 
540 END SUBROUTINE option_format_html_help
541 
542 END SUBROUTINE option_format_htmlform
543 
544 
545 FUNCTION option_c_e(this) RESULT(c_e)
546 TYPE(option),INTENT(in) :: this
547 
548 LOGICAL :: c_e
549 
550 c_e = this%long_opt /= ' ' .OR. this%short_opt /= ' '
551 
552 END FUNCTION option_c_e
553 
554 
558 FUNCTION optionparser_new(usage_msg, description_msg) RESULT(this)
559 CHARACTER(len=*), INTENT(in), OPTIONAL :: usage_msg
560 CHARACTER(len=*), INTENT(in), OPTIONAL :: description_msg
561 
562 TYPE(optionparser) :: this
563 
564 IF (PRESENT(usage_msg)) THEN
565  CALL fchar_to_cstr_alloc(trim(usage_msg), this%usage_msg)
566 ELSE
567  NULLIFY(this%usage_msg)
568 ENDIF
569 IF (PRESENT(description_msg)) THEN
570  CALL fchar_to_cstr_alloc(trim(description_msg), this%description_msg)
571 ELSE
572  NULLIFY(this%description_msg)
573 ENDIF
574 
575 END FUNCTION optionparser_new
576 
577 
578 SUBROUTINE optionparser_delete(this)
579 TYPE(optionparser),INTENT(inout) :: this
580 
581 IF (ASSOCIATED(this%usage_msg)) DEALLOCATE(this%usage_msg)
582 IF (ASSOCIATED(this%description_msg)) DEALLOCATE(this%description_msg)
583 CALL delete(this%options)
584 
585 END SUBROUTINE optionparser_delete
586 
587 
595 SUBROUTINE optionparser_add_c(this, short_opt, long_opt, dest, default, help, isopt)
596 TYPE(optionparser),INTENT(inout) :: this
597 CHARACTER(len=*),INTENT(in) :: short_opt
598 CHARACTER(len=*),INTENT(in) :: long_opt
599 CHARACTER(len=*),TARGET :: dest
600 CHARACTER(len=*),OPTIONAL :: default
601 CHARACTER(len=*),OPTIONAL :: help
602 LOGICAL,INTENT(in),OPTIONAL :: isopt
603 
604 CHARACTER(LEN=60) :: cdefault
605 INTEGER :: i
606 TYPE(option) :: myoption
607 
608 
609 IF (PRESENT(default)) THEN
610  cdefault = ' [default='//t2c(default, 'MISSING')//']'
611 ELSE
612  cdefault = ''
613 ENDIF
614 
615 ! common initialisation
616 myoption = option_new(short_opt, long_opt, cdefault, help)
617 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
618 
619 myoption%destc => dest(1:1)
620 myoption%destclen = len(dest) ! needed to avoid exceeding the length of dest
621 IF (PRESENT(default)) &
622  CALL dirty_char_assignment(myoption%destc, myoption%destclen, default)
623 !IF (PRESENT(default)) myoption%destc(1:myoption%destclen) = default
624 myoption%opttype = opttype_c
625 IF (optio_log(isopt)) THEN
626  myoption%need_arg = 1
627 ELSE
628  myoption%need_arg = 2
629 ENDIF
630 
631 i = arrayof_option_append(this%options, myoption)
632 
633 END SUBROUTINE optionparser_add_c
634 
635 
642 SUBROUTINE optionparser_add_i(this, short_opt, long_opt, dest, default, help)
643 TYPE(optionparser),INTENT(inout) :: this
644 CHARACTER(len=*),INTENT(in) :: short_opt
645 CHARACTER(len=*),INTENT(in) :: long_opt
646 INTEGER,TARGET :: dest
647 INTEGER,OPTIONAL :: default
648 CHARACTER(len=*),OPTIONAL :: help
649 
650 CHARACTER(LEN=40) :: cdefault
651 INTEGER :: i
652 TYPE(option) :: myoption
653 
654 IF (PRESENT(default)) THEN
655  cdefault = ' [default='//t2c(default, 'MISSING')//']'
656 ELSE
657  cdefault = ''
658 ENDIF
659 
660 ! common initialisation
661 myoption = option_new(short_opt, long_opt, cdefault, help)
662 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
663 
664 myoption%desti => dest
665 IF (PRESENT(default)) myoption%desti = default
666 myoption%opttype = opttype_i
667 myoption%need_arg = 2
668 
669 i = arrayof_option_append(this%options, myoption)
670 
671 END SUBROUTINE optionparser_add_i
672 
673 
683 SUBROUTINE optionparser_add_iarray(this, short_opt, long_opt, dest, default, help)
684 TYPE(optionparser),INTENT(inout) :: this
685 CHARACTER(len=*),INTENT(in) :: short_opt
686 CHARACTER(len=*),INTENT(in) :: long_opt
687 TYPE(arrayof_integer),TARGET :: dest
688 INTEGER,OPTIONAL :: default(:)
689 CHARACTER(len=*),OPTIONAL :: help
690 
691 CHARACTER(LEN=40) :: cdefault
692 INTEGER :: i
693 TYPE(option) :: myoption
694 
695 cdefault = ''
696 IF (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
702 ENDIF
703 
704 ! common initialisation
705 myoption = option_new(short_opt, long_opt, cdefault, help)
706 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
707 
708 myoption%destiarr => dest
709 IF (PRESENT(default)) THEN
710  CALL insert(myoption%destiarr, default)
711  CALL packarray(myoption%destiarr)
712 ENDIF
713 myoption%opttype = opttype_iarr
714 myoption%need_arg = 2
715 
716 i = arrayof_option_append(this%options, myoption)
717 
718 END SUBROUTINE optionparser_add_iarray
719 
720 
727 SUBROUTINE optionparser_add_r(this, short_opt, long_opt, dest, default, help)
728 TYPE(optionparser),INTENT(inout) :: this
729 CHARACTER(len=*),INTENT(in) :: short_opt
730 CHARACTER(len=*),INTENT(in) :: long_opt
731 REAL,TARGET :: dest
732 REAL,OPTIONAL :: default
733 CHARACTER(len=*),OPTIONAL :: help
734 
735 CHARACTER(LEN=40) :: cdefault
736 INTEGER :: i
737 TYPE(option) :: myoption
738 
739 IF (PRESENT(default)) THEN
740  cdefault = ' [default='//t2c(default, 'MISSING')//']'
741 ELSE
742  cdefault = ''
743 ENDIF
744 
745 ! common initialisation
746 myoption = option_new(short_opt, long_opt, cdefault, help)
747 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
748 
749 myoption%destr => dest
750 IF (PRESENT(default)) myoption%destr = default
751 myoption%opttype = opttype_r
752 myoption%need_arg = 2
753 
754 i = arrayof_option_append(this%options, myoption)
755 
756 END SUBROUTINE optionparser_add_r
757 
758 
768 SUBROUTINE optionparser_add_rarray(this, short_opt, long_opt, dest, default, help)
769 TYPE(optionparser),INTENT(inout) :: this
770 CHARACTER(len=*),INTENT(in) :: short_opt
771 CHARACTER(len=*),INTENT(in) :: long_opt
772 TYPE(arrayof_real),TARGET :: dest
773 REAL,OPTIONAL :: default(:)
774 CHARACTER(len=*),OPTIONAL :: help
775 
776 CHARACTER(LEN=40) :: cdefault
777 INTEGER :: i
778 TYPE(option) :: myoption
779 
780 cdefault = ''
781 IF (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
787 ENDIF
788 
789 ! common initialisation
790 myoption = option_new(short_opt, long_opt, cdefault, help)
791 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
792 
793 myoption%destrarr => dest
794 IF (PRESENT(default)) THEN
795  CALL insert(myoption%destrarr, default)
796  CALL packarray(myoption%destrarr)
797 ENDIF
798 myoption%opttype = opttype_rarr
799 myoption%need_arg = 2
800 
801 i = arrayof_option_append(this%options, myoption)
802 
803 END SUBROUTINE optionparser_add_rarray
804 
805 
812 SUBROUTINE optionparser_add_d(this, short_opt, long_opt, dest, default, help)
813 TYPE(optionparser),INTENT(inout) :: this
814 CHARACTER(len=*),INTENT(in) :: short_opt
815 CHARACTER(len=*),INTENT(in) :: long_opt
816 DOUBLE PRECISION,TARGET :: dest
817 DOUBLE PRECISION,OPTIONAL :: default
818 CHARACTER(len=*),OPTIONAL :: help
819 
820 CHARACTER(LEN=40) :: cdefault
821 INTEGER :: i
822 TYPE(option) :: myoption
823 
824 IF (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
830 ELSE
831  cdefault = ''
832 ENDIF
833 
834 ! common initialisation
835 myoption = option_new(short_opt, long_opt, cdefault, help)
836 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
837 
838 myoption%destd => dest
839 IF (PRESENT(default)) myoption%destd = default
840 myoption%opttype = opttype_d
841 myoption%need_arg = 2
842 
843 i = arrayof_option_append(this%options, myoption)
844 
845 END SUBROUTINE optionparser_add_d
846 
847 
857 SUBROUTINE optionparser_add_darray(this, short_opt, long_opt, dest, default, help)
858 TYPE(optionparser),INTENT(inout) :: this
859 CHARACTER(len=*),INTENT(in) :: short_opt
860 CHARACTER(len=*),INTENT(in) :: long_opt
861 TYPE(arrayof_doubleprecision),TARGET :: dest
862 DOUBLE PRECISION,OPTIONAL :: default(:)
863 CHARACTER(len=*),OPTIONAL :: help
864 
865 CHARACTER(LEN=40) :: cdefault
866 INTEGER :: i
867 TYPE(option) :: myoption
868 
869 cdefault = ''
870 IF (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
876 ENDIF
877 
878 ! common initialisation
879 myoption = option_new(short_opt, long_opt, cdefault, help)
880 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
881 
882 myoption%destdarr => dest
883 IF (PRESENT(default)) THEN
884  CALL insert(myoption%destdarr, default)
885  CALL packarray(myoption%destdarr)
886 ENDIF
887 myoption%opttype = opttype_darr
888 myoption%need_arg = 2
889 
890 i = arrayof_option_append(this%options, myoption)
891 
892 END SUBROUTINE optionparser_add_darray
893 
894 
901 SUBROUTINE optionparser_add_l(this, short_opt, long_opt, dest, help)
902 TYPE(optionparser),INTENT(inout) :: this
903 CHARACTER(len=*),INTENT(in) :: short_opt
904 CHARACTER(len=*),INTENT(in) :: long_opt
905 LOGICAL,TARGET :: dest
906 CHARACTER(len=*),OPTIONAL :: help
907 
908 INTEGER :: i
909 TYPE(option) :: myoption
910 
911 ! common initialisation
912 myoption = option_new(short_opt, long_opt, '', help)
913 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
914 
915 myoption%destl => dest
916 myoption%destl = .false. ! unconditionally set to false, option can only set it to true
917 myoption%opttype = opttype_l
918 myoption%need_arg = 0
919 
920 i = arrayof_option_append(this%options, myoption)
921 
922 END SUBROUTINE optionparser_add_l
923 
924 
929 SUBROUTINE optionparser_add_count(this, short_opt, long_opt, dest, start, help)
930 TYPE(optionparser),INTENT(inout) :: this
931 CHARACTER(len=*),INTENT(in) :: short_opt
932 CHARACTER(len=*),INTENT(in) :: long_opt
933 INTEGER,TARGET :: dest
934 INTEGER,OPTIONAL :: start
935 CHARACTER(len=*),OPTIONAL :: help
936 
937 INTEGER :: i
938 TYPE(option) :: myoption
939 
940 ! common initialisation
941 myoption = option_new(short_opt, long_opt, '', help)
942 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
943 
944 myoption%destcount => dest
945 IF (PRESENT(start)) myoption%destcount = start
946 myoption%opttype = opttype_count
947 myoption%need_arg = 0
948 
949 i = arrayof_option_append(this%options, myoption)
950 
951 END SUBROUTINE optionparser_add_count
952 
953 
968 SUBROUTINE optionparser_add_help(this, short_opt, long_opt, help)
969 TYPE(optionparser),INTENT(inout) :: this
970 CHARACTER(len=*),INTENT(in) :: short_opt
971 CHARACTER(len=*),INTENT(in) :: long_opt
972 CHARACTER(len=*),OPTIONAL :: help
973 
974 INTEGER :: i
975 TYPE(option) :: myoption
976 
977 ! common initialisation
978 myoption = option_new(short_opt, long_opt, '', help)
979 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
980 
981 myoption%opttype = opttype_help
982 myoption%need_arg = 1
983 
984 i = arrayof_option_append(this%options, myoption)
985 
986 END SUBROUTINE optionparser_add_help
987 
988 
999 SUBROUTINE optionparser_add_sep(this, help)
1000 TYPE(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)
1003 CHARACTER(len=*) :: help
1004 
1005 INTEGER :: i
1006 TYPE(option) :: myoption
1007 
1008 ! common initialisation
1009 myoption = option_new('_', '_', '', help)
1010 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
1011 
1012 myoption%opttype = opttype_sep
1013 myoption%need_arg = 0
1014 
1015 i = arrayof_option_append(this%options, myoption)
1016 
1017 END SUBROUTINE optionparser_add_sep
1018 
1019 
1029 SUBROUTINE optionparser_parse(this, nextarg, status)
1030 TYPE(optionparser),INTENT(inout) :: this
1031 INTEGER,INTENT(out) :: nextarg
1032 INTEGER,INTENT(out) :: status
1033 
1034 INTEGER :: i, j, endopt, indeq, iargc
1035 CHARACTER(len=16384) :: arg, optarg
1036 
1037 status = optionparser_ok
1038 i = 1
1039 DO 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
1156 ENDDO
1157 
1158 nextarg = i
1159 SELECT CASE(status)
1160 CASE(optionparser_err, optionparser_help)
1161  CALL optionparser_printhelp(this)
1162 END SELECT
1163 
1164 END SUBROUTINE optionparser_parse
1165 
1166 
1170 SUBROUTINE optionparser_printhelp(this)
1171 TYPE(optionparser),INTENT(in) :: this
1172 
1173 INTEGER :: i, form
1174 
1175 form = 0
1176 DO 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
1180 ENDDO
1181 
1182 SELECT CASE(form)
1183 CASE(0)
1184  CALL optionparser_printhelptxt(this)
1185 CASE(1)
1186  CALL optionparser_printhelpmd(this)
1187 CASE(2)
1188  CALL optionparser_printhelphtmlform(this)
1189 END SELECT
1190 
1191 END SUBROUTINE optionparser_printhelp
1192 
1193 
1197 SUBROUTINE optionparser_printhelptxt(this)
1198 TYPE(optionparser),INTENT(in) :: this
1199 
1200 INTEGER :: i, j, ncols
1201 CHARACTER(len=80) :: buf
1202 TYPE(line_split) :: help_line
1203 
1204 ncols = default_columns()
1205 
1206 ! print usage message
1207 IF (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)
1213 ELSE
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]'
1218 ENDIF
1219 
1220 ! print description message
1221 IF (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)
1228 ENDIF
1229 
1230 WRITE(*,'(/,A)')'Options:'
1231 
1232 DO i = 1, this%options%arraysize ! loop over options
1233  CALL option_format_help(this%options%array(i), ncols)
1234 ENDDO
1235 
1236 END SUBROUTINE optionparser_printhelptxt
1237 
1238 
1242 SUBROUTINE optionparser_printhelpmd(this)
1243 TYPE(optionparser),INTENT(in) :: this
1244 
1245 INTEGER :: i, j, ncols
1246 CHARACTER(len=80) :: buf
1247 TYPE(line_split) :: help_line
1248 
1249 ncols = default_columns()
1250 
1251 ! print usage message
1252 WRITE(*,'(A)')'### Synopsis'
1253 
1254 IF (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)
1260 ELSE
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]`'
1265 ENDIF
1266 
1267 ! print description message
1268 IF (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 
1277 ENDIF
1278 
1279 WRITE(*,'(/,A)')'### Options'
1280 
1281 DO i = 1, this%options%arraysize ! loop over options
1282  CALL option_format_md(this%options%array(i), ncols)
1283 ENDDO
1284 
1285 CONTAINS
1286 
1287 FUNCTION mdquote_usage_msg(usage_msg)
1288 CHARACTER(len=*),INTENT(in) :: usage_msg
1289 
1290 CHARACTER(len=LEN(usage_msg)+2) :: mdquote_usage_msg
1291 INTEGER :: colon
1292 
1293 colon = index(usage_msg, ':') ! typically 'Usage: cp [options] origin destination'
1294 IF (colon > 0 .AND. colon < len(usage_msg)-1) THEN
1295  mdquote_usage_msg = usage_msg(:colon+1)//'`'//usage_msg(colon+2:)//'`'
1296 ELSE
1297  mdquote_usage_msg = usage_msg
1298 ENDIF
1299 
1300 END FUNCTION mdquote_usage_msg
1301 
1302 END SUBROUTINE optionparser_printhelpmd
1303 
1307 SUBROUTINE optionparser_printhelphtmlform(this)
1308 TYPE(optionparser),INTENT(in) :: this
1309 
1310 INTEGER :: i
1311 
1312 DO i = 1, this%options%arraysize ! loop over options
1313  CALL option_format_htmlform(this%options%array(i))
1314 ENDDO
1316 WRITE(*,'(A)')'<input class="libsim_sub" type="submit" value="runprogram" />'
1317 
1318 END SUBROUTINE optionparser_printhelphtmlform
1319 
1320 
1321 SUBROUTINE optionparser_make_completion(this)
1322 TYPE(optionparser),INTENT(in) :: this
1323 
1324 INTEGER :: i
1325 CHARACTER(len=512) :: buf
1326 
1327 CALL getarg(0, buf)
1328 
1329 WRITE(*,'(A/A/A)')'_'//trim(buf)//'()','{','local cur'
1330 
1331 WRITE(*,'(A/A/A/A)')'COMPREPLY=()','cur=${COMP_WORDS[COMP_CWORD]}', &
1332  'case "$cur" in','-*)'
1333 
1334 !-*)
1335 ! COMPREPLY=( $( compgen -W
1336 DO i = 1, this%options%arraysize ! loop over options
1337  IF (this%options%array(i)%need_arg == 2) THEN
1338  ENDIF
1339 ENDDO
1340 
1341 WRITE(*,'(A/A/A)')'esac','return 0','}'
1342 
1343 END SUBROUTINE optionparser_make_completion
1344 
1345 
1346 SUBROUTINE dirty_char_assignment(destc, destclen, src)
1347 USE kinds
1348 IMPLICIT NONE
1349 
1350 CHARACTER(len=1) :: destc(*)
1351 CHARACTER(len=*) :: src
1352 INTEGER :: destclen
1353 
1354 INTEGER :: i
1355 
1356 DO i = 1, min(destclen, len(src))
1357  destc(i) = src(i:i)
1358 ENDDO
1359 DO i = len(src)+1, destclen
1360  destc(i) = ' '
1361 ENDDO
1362 
1363 END SUBROUTINE dirty_char_assignment
1364 
1365 END MODULE optionparser_class
Set of functions that return a trimmed CHARACTER representation of the input variable.
Set of functions that return a CHARACTER representation of the input variable.
Methods for successively obtaining the fields of a csv_record object.
Constructor for the class csv_record.
Index method.
Destructor for the optionparser class.
Add a new option of a specific type.
This module defines usefull general purpose function and subroutine.
Utilities for CHARACTER variables.
Gestione degli errori.
Utilities for managing files.
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:251
classe per la gestione del logging
Module for parsing command-line optons.
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...
This class allows to parse the command-line options of a program in an object-oriented way,...

Generated with Doxygen.