libsim  Versione7.2.3
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
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
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)
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
1315 
1316 WRITE(*,'(A)')'<input class="libsim_sub" type="submit" value="runprogram" />'
1317 
1318 END SUBROUTINE optionparser_printhelphtmlform
1319 
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 
Derived type defining a dynamically extensible array of INTEGER elements.
Set of functions that return a trimmed CHARACTER representation of the input variable.
Destructor for the optionparser class.
Constructor for the class csv_record.
Module for parsing command-line optons.
Derived type defining a dynamically extensible array of REAL elements.
Utilities for managing files.
Methods for successively obtaining the fields of a csv_record object.
Index method.
Set of functions that return a CHARACTER representation of the input variable.
Derived type defining a dynamically extensible array of DOUBLEPRECISION elements. ...
Gestione degli errori.
This module defines usefull general purpose function and subroutine.
classe per la gestione del logging
Class that allows splitting a long line into shorter lines of equal length at the occurrence of a spe...
Utilities for CHARACTER variables.
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:255
Add a new option of a specific type.
This class allows to parse the command-line options of a program in an object-oriented way...

Generated with Doxygen.