libsim  Versione6.3.0
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),POINTER :: help_msg(:)=>null()
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  CALL fchar_to_cstr_alloc(trim(help)//trim(default), this%help_msg)
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 (ASSOCIATED(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, optarg, len_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 (ASSOCIATED(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 (ASSOCIATED(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
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 (ASSOCIATED(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 (ASSOCIATED(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 (ASSOCIATED(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 ! this is needed in order to circumvent a bug in gfortran 4.1.2
620 ! in future replace with following line and erase dirty_char_pointer_set
621 CALL dirty_char_pointer_set(myoption%destc, dest(1:1))
622 !this%destc => dest!(1:1)
623 myoption%destclen = len(dest) ! needed to avoid exceeding the length of dest
624 IF (present(default)) &
625  CALL dirty_char_assignment(myoption%destc, myoption%destclen, default, len(default))
626 !IF (PRESENT(default)) myoption%destc(1:myoption%destclen) = default
627 myoption%opttype = opttype_c
628 IF (optio_log(isopt)) THEN
629  myoption%need_arg = 1
630 ELSE
631  myoption%need_arg = 2
632 ENDIF
633 
634 i = arrayof_option_append(this%options, myoption)
635 
636 END SUBROUTINE optionparser_add_c
637 
638 
645 SUBROUTINE optionparser_add_i(this, short_opt, long_opt, dest, default, help)
646 TYPE(optionparser),INTENT(inout) :: this
647 CHARACTER(len=*),INTENT(in) :: short_opt
648 CHARACTER(len=*),INTENT(in) :: long_opt
649 INTEGER,TARGET :: dest
650 INTEGER,OPTIONAL :: default
651 CHARACTER(len=*),OPTIONAL :: help
652 
653 CHARACTER(LEN=40) :: cdefault
654 INTEGER :: i
655 TYPE(option) :: myoption
656 
657 IF (present(default)) THEN
658  cdefault = ' [default='//t2c(default, 'MISSING')//']'
659 ELSE
660  cdefault = ''
661 ENDIF
662 
663 ! common initialisation
664 myoption = option_new(short_opt, long_opt, cdefault, help)
665 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
666 
667 myoption%desti => dest
668 IF (present(default)) myoption%desti = default
669 myoption%opttype = opttype_i
670 myoption%need_arg = 2
671 
672 i = arrayof_option_append(this%options, myoption)
673 
674 END SUBROUTINE optionparser_add_i
675 
676 
686 SUBROUTINE optionparser_add_iarray(this, short_opt, long_opt, dest, default, help)
687 TYPE(optionparser),INTENT(inout) :: this
688 CHARACTER(len=*),INTENT(in) :: short_opt
689 CHARACTER(len=*),INTENT(in) :: long_opt
690 TYPE(arrayof_integer),TARGET :: dest
691 INTEGER,OPTIONAL :: default(:)
692 CHARACTER(len=*),OPTIONAL :: help
693 
694 CHARACTER(LEN=40) :: cdefault
695 INTEGER :: i
696 TYPE(option) :: myoption
697 
698 cdefault = ''
699 IF (present(default)) THEN
700  IF (SIZE(default) == 1) THEN
701  cdefault = ' [default='//trim(to_char(default(1)))//']'
702  ELSE IF (SIZE(default) > 1) THEN
703  cdefault = ' [default='//trim(to_char(default(1)))//',...]'
704  ENDIF
705 ENDIF
706 
707 ! common initialisation
708 myoption = option_new(short_opt, long_opt, cdefault, help)
709 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
710 
711 myoption%destiarr => dest
712 IF (present(default)) THEN
713  CALL insert(myoption%destiarr, default)
714  CALL packarray(myoption%destiarr)
715 ENDIF
716 myoption%opttype = opttype_iarr
717 myoption%need_arg = 2
718 
719 i = arrayof_option_append(this%options, myoption)
720 
721 END SUBROUTINE optionparser_add_iarray
722 
723 
730 SUBROUTINE optionparser_add_r(this, short_opt, long_opt, dest, default, help)
731 TYPE(optionparser),INTENT(inout) :: this
732 CHARACTER(len=*),INTENT(in) :: short_opt
733 CHARACTER(len=*),INTENT(in) :: long_opt
734 REAL,TARGET :: dest
735 REAL,OPTIONAL :: default
736 CHARACTER(len=*),OPTIONAL :: help
737 
738 CHARACTER(LEN=40) :: cdefault
739 INTEGER :: i
740 TYPE(option) :: myoption
741 
742 IF (present(default)) THEN
743  cdefault = ' [default='//t2c(default, 'MISSING')//']'
744 ELSE
745  cdefault = ''
746 ENDIF
747 
748 ! common initialisation
749 myoption = option_new(short_opt, long_opt, cdefault, help)
750 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
751 
752 myoption%destr => dest
753 IF (present(default)) myoption%destr = default
754 myoption%opttype = opttype_r
755 myoption%need_arg = 2
756 
757 i = arrayof_option_append(this%options, myoption)
758 
759 END SUBROUTINE optionparser_add_r
760 
761 
771 SUBROUTINE optionparser_add_rarray(this, short_opt, long_opt, dest, default, help)
772 TYPE(optionparser),INTENT(inout) :: this
773 CHARACTER(len=*),INTENT(in) :: short_opt
774 CHARACTER(len=*),INTENT(in) :: long_opt
775 TYPE(arrayof_real),TARGET :: dest
776 REAL,OPTIONAL :: default(:)
777 CHARACTER(len=*),OPTIONAL :: help
778 
779 CHARACTER(LEN=40) :: cdefault
780 INTEGER :: i
781 TYPE(option) :: myoption
782 
783 cdefault = ''
784 IF (present(default)) THEN
785  IF (SIZE(default) == 1) THEN
786  cdefault = ' [default='//trim(to_char(default(1)))//']'
787  ELSE IF (SIZE(default) > 1) THEN
788  cdefault = ' [default='//trim(to_char(default(1)))//',...]'
789  ENDIF
790 ENDIF
791 
792 ! common initialisation
793 myoption = option_new(short_opt, long_opt, cdefault, help)
794 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
795 
796 myoption%destrarr => dest
797 IF (present(default)) THEN
798  CALL insert(myoption%destrarr, default)
799  CALL packarray(myoption%destrarr)
800 ENDIF
801 myoption%opttype = opttype_rarr
802 myoption%need_arg = 2
803 
804 i = arrayof_option_append(this%options, myoption)
805 
806 END SUBROUTINE optionparser_add_rarray
807 
808 
815 SUBROUTINE optionparser_add_d(this, short_opt, long_opt, dest, default, help)
816 TYPE(optionparser),INTENT(inout) :: this
817 CHARACTER(len=*),INTENT(in) :: short_opt
818 CHARACTER(len=*),INTENT(in) :: long_opt
819 DOUBLE PRECISION,TARGET :: dest
820 DOUBLE PRECISION,OPTIONAL :: default
821 CHARACTER(len=*),OPTIONAL :: help
822 
823 CHARACTER(LEN=40) :: cdefault
824 INTEGER :: i
825 TYPE(option) :: myoption
826 
827 IF (present(default)) THEN
828  IF (c_e(default)) THEN
829  cdefault = ' [default='//trim(adjustl(to_char(default,form='(G15.9)')))//']'
830  ELSE
831  cdefault = ' [default='//t2c(default, 'MISSING')//']'
832  ENDIF
833 ELSE
834  cdefault = ''
835 ENDIF
836 
837 ! common initialisation
838 myoption = option_new(short_opt, long_opt, cdefault, help)
839 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
840 
841 myoption%destd => dest
842 IF (present(default)) myoption%destd = default
843 myoption%opttype = opttype_d
844 myoption%need_arg = 2
845 
846 i = arrayof_option_append(this%options, myoption)
847 
848 END SUBROUTINE optionparser_add_d
849 
850 
860 SUBROUTINE optionparser_add_darray(this, short_opt, long_opt, dest, default, help)
861 TYPE(optionparser),INTENT(inout) :: this
862 CHARACTER(len=*),INTENT(in) :: short_opt
863 CHARACTER(len=*),INTENT(in) :: long_opt
864 TYPE(arrayof_doubleprecision),TARGET :: dest
865 DOUBLE PRECISION,OPTIONAL :: default(:)
866 CHARACTER(len=*),OPTIONAL :: help
867 
868 CHARACTER(LEN=40) :: cdefault
869 INTEGER :: i
870 TYPE(option) :: myoption
871 
872 cdefault = ''
873 IF (present(default)) THEN
874  IF (SIZE(default) == 1) THEN
875  cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//']'
876  ELSE IF (SIZE(default) > 1) THEN
877  cdefault = ' [default='//trim(adjustl(to_char(default(1),form='(G15.9)')))//',...]'
878  ENDIF
879 ENDIF
880 
881 ! common initialisation
882 myoption = option_new(short_opt, long_opt, cdefault, help)
883 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
884 
885 myoption%destdarr => dest
886 IF (present(default)) THEN
887  CALL insert(myoption%destdarr, default)
888  CALL packarray(myoption%destdarr)
889 ENDIF
890 myoption%opttype = opttype_darr
891 myoption%need_arg = 2
892 
893 i = arrayof_option_append(this%options, myoption)
894 
895 END SUBROUTINE optionparser_add_darray
896 
897 
904 SUBROUTINE optionparser_add_l(this, short_opt, long_opt, dest, help)
905 TYPE(optionparser),INTENT(inout) :: this
906 CHARACTER(len=*),INTENT(in) :: short_opt
907 CHARACTER(len=*),INTENT(in) :: long_opt
908 LOGICAL,TARGET :: dest
909 CHARACTER(len=*),OPTIONAL :: help
910 
911 INTEGER :: i
912 TYPE(option) :: myoption
913 
914 ! common initialisation
915 myoption = option_new(short_opt, long_opt, '', help)
916 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
917 
918 myoption%destl => dest
919 myoption%destl = .false. ! unconditionally set to false, option can only set it to true
920 myoption%opttype = opttype_l
921 myoption%need_arg = 0
922 
923 i = arrayof_option_append(this%options, myoption)
924 
925 END SUBROUTINE optionparser_add_l
926 
927 
932 SUBROUTINE optionparser_add_count(this, short_opt, long_opt, dest, start, help)
933 TYPE(optionparser),INTENT(inout) :: this
934 CHARACTER(len=*),INTENT(in) :: short_opt
935 CHARACTER(len=*),INTENT(in) :: long_opt
936 INTEGER,TARGET :: dest
937 INTEGER,OPTIONAL :: start
938 CHARACTER(len=*),OPTIONAL :: help
939 
940 INTEGER :: i
941 TYPE(option) :: myoption
942 
943 ! common initialisation
944 myoption = option_new(short_opt, long_opt, '', help)
945 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
946 
947 myoption%destcount => dest
948 IF (present(start)) myoption%destcount = start
949 myoption%opttype = opttype_count
950 myoption%need_arg = 0
951 
952 i = arrayof_option_append(this%options, myoption)
953 
954 END SUBROUTINE optionparser_add_count
955 
956 
971 SUBROUTINE optionparser_add_help(this, short_opt, long_opt, help)
972 TYPE(optionparser),INTENT(inout) :: this
973 CHARACTER(len=*),INTENT(in) :: short_opt
974 CHARACTER(len=*),INTENT(in) :: long_opt
975 CHARACTER(len=*),OPTIONAL :: help
976 
977 INTEGER :: i
978 TYPE(option) :: myoption
979 
980 ! common initialisation
981 myoption = option_new(short_opt, long_opt, '', help)
982 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
983 
984 myoption%opttype = opttype_help
985 myoption%need_arg = 1
986 
987 i = arrayof_option_append(this%options, myoption)
988 
989 END SUBROUTINE optionparser_add_help
990 
991 
1002 SUBROUTINE optionparser_add_sep(this, help)
1003 TYPE(optionparser),INTENT(inout) :: this
1004 !CHARACTER(len=*),INTENT(in) :: short_opt !< the short option (may be empty)
1005 !CHARACTER(len=*),INTENT(in) :: long_opt !< the long option (may be empty)
1006 CHARACTER(len=*) :: help
1007 
1008 INTEGER :: i
1009 TYPE(option) :: myoption
1010 
1011 ! common initialisation
1012 myoption = option_new('_', '_', '', help)
1013 IF (.NOT.c_e(myoption)) RETURN ! error in creating option, ignore it
1014 
1015 myoption%opttype = opttype_sep
1016 myoption%need_arg = 0
1017 
1018 i = arrayof_option_append(this%options, myoption)
1019 
1020 END SUBROUTINE optionparser_add_sep
1021 
1022 
1032 SUBROUTINE optionparser_parse(this, nextarg, status)
1033 TYPE(optionparser),INTENT(inout) :: this
1034 INTEGER,INTENT(out) :: nextarg
1035 INTEGER,INTENT(out) :: status
1036 
1037 INTEGER :: i, j, endopt, indeq, iargc
1038 CHARACTER(len=16384) :: arg, optarg
1039 
1040 status = optionparser_ok
1041 i = 1
1042 DO WHILE(i <= iargc())
1043  CALL getarg(i, arg)
1044  IF (arg == '--') THEN ! explicit end of options
1045  i = i + 1 ! skip present option (--)
1046  EXIT
1047  ELSE IF (arg == '-') THEN ! a single - is not an option
1048  EXIT
1049  ELSE IF (arg(1:2) == '--') THEN ! long option
1050  indeq = index(arg, '=')
1051  IF (indeq /= 0) THEN ! = present
1052  endopt = indeq - 1
1053  ELSE ! no =
1054  endopt = len_trim(arg)
1055  ENDIF
1056  find_longopt: DO j = 1, this%options%arraysize
1057  IF (this%options%array(j)%long_opt == arg(3:endopt)) THEN ! found option
1058  SELECT CASE(this%options%array(j)%need_arg)
1059  CASE(2) ! compulsory
1060  IF (indeq /= 0) THEN
1061  optarg = arg(indeq+1:)
1062  status = max(option_found(this%options%array(j), optarg), &
1063  status)
1064  ELSE
1065  IF (i < iargc()) THEN
1066  i=i+1
1067  CALL getarg(i, optarg)
1068  status = max(option_found(this%options%array(j), optarg), &
1069  status)
1070  ELSE
1071  status = optionparser_err
1072  CALL l4f_log(l4f_error, &
1073  'in optionparser, option '''//trim(arg)//''' requires an argument')
1074  ENDIF
1075  ENDIF
1076  CASE(1) ! optional
1077  IF (indeq /= 0) THEN
1078  optarg = arg(indeq+1:)
1079  ELSE
1080  IF (i < iargc()) THEN
1081  CALL getarg(i+1, optarg)
1082  IF (optarg(1:1) == '-') THEN
1083  optarg = cmiss ! refused
1084  ELSE
1085  i=i+1 ! accepted
1086  ENDIF
1087  ELSE
1088  optarg = cmiss ! refused
1089  ENDIF
1090  ENDIF
1091  status = max(option_found(this%options%array(j), optarg), &
1092  status)
1093  CASE(0)
1094  status = max(option_found(this%options%array(j)), &
1095  status)
1096  END SELECT
1097  EXIT find_longopt
1098  ENDIF
1099  ENDDO find_longopt
1100  IF (j > this%options%arraysize) THEN
1101  status = optionparser_err
1102  CALL l4f_log(l4f_error, &
1103  'in optionparser, option '''//trim(arg)//''' not valid')
1104  ENDIF
1105  ELSE IF (arg(1:1) == '-') THEN ! short option
1106  find_shortopt: DO j = 1, this%options%arraysize
1107  IF (this%options%array(j)%short_opt == arg(2:2)) THEN ! found option
1108  SELECT CASE(this%options%array(j)%need_arg)
1109  CASE(2) ! compulsory
1110  IF (len_trim(arg) > 2) THEN
1111  optarg = arg(3:)
1112  status = max(option_found(this%options%array(j), optarg), &
1113  status)
1114  ELSE
1115  IF (i < iargc()) THEN
1116  i=i+1
1117  CALL getarg(i, optarg)
1118  status = max(option_found(this%options%array(j), optarg), &
1119  status)
1120  ELSE
1121  status = optionparser_err
1122  CALL l4f_log(l4f_error, &
1123  'in optionparser, option '''//trim(arg)//''' requires an argument')
1124  ENDIF
1125  ENDIF
1126  CASE(1) ! optional
1127  IF (len_trim(arg) > 2) THEN
1128  optarg = arg(3:)
1129  ELSE
1130  IF (i < iargc()) THEN
1131  CALL getarg(i+1, optarg)
1132  IF (optarg(1:1) == '-') THEN
1133  optarg = cmiss ! refused
1134  ELSE
1135  i=i+1 ! accepted
1136  ENDIF
1137  ELSE
1138  optarg = cmiss ! refused
1139  ENDIF
1140  ENDIF
1141  status = max(option_found(this%options%array(j), optarg), &
1142  status)
1143  CASE(0)
1144  status = max(option_found(this%options%array(j)), &
1145  status)
1146  END SELECT
1147  EXIT find_shortopt
1148  ENDIF
1149  ENDDO find_shortopt
1150  IF (j > this%options%arraysize) THEN
1151  status = optionparser_err
1152  CALL l4f_log(l4f_error, &
1153  'in optionparser, option '''//trim(arg)//''' not valid')
1154  ENDIF
1155  ELSE ! unrecognized = end of options
1156  EXIT
1157  ENDIF
1158  i = i + 1
1159 ENDDO
1160 
1161 nextarg = i
1162 SELECT CASE(status)
1163 CASE(optionparser_err, optionparser_help)
1164  CALL optionparser_printhelp(this)
1165 END SELECT
1166 
1167 END SUBROUTINE optionparser_parse
1168 
1169 
1173 SUBROUTINE optionparser_printhelp(this)
1174 TYPE(optionparser),INTENT(in) :: this
1175 
1176 INTEGER :: i, form
1177 
1178 form = 0
1179 DO i = 1, this%options%arraysize ! loop over options
1180  IF (this%options%array(i)%opttype == opttype_help) THEN
1181  form = this%options%array(i)%helpformat
1182  ENDIF
1183 ENDDO
1184 
1185 SELECT CASE(form)
1186 CASE(0)
1187  CALL optionparser_printhelptxt(this)
1188 CASE(1)
1189  CALL optionparser_printhelpmd(this)
1190 CASE(2)
1191  CALL optionparser_printhelphtmlform(this)
1192 END SELECT
1193 
1194 END SUBROUTINE optionparser_printhelp
1195 
1196 
1200 SUBROUTINE optionparser_printhelptxt(this)
1201 TYPE(optionparser),INTENT(in) :: this
1202 
1203 INTEGER :: i, j, ncols
1204 CHARACTER(len=80) :: buf
1205 TYPE(line_split) :: help_line
1206 
1207 ncols = default_columns()
1208 
1209 ! print usage message
1210 IF (ASSOCIATED(this%usage_msg)) THEN
1211  help_line = line_split_new(cstr_to_fchar(this%usage_msg), ncols)
1212  DO j = 1, line_split_get_nlines(help_line)
1213  WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1214  ENDDO
1215  CALL delete(help_line)
1216 ELSE
1217  CALL getarg(0, buf)
1218  i = index(buf, '/', back=.true.) ! remove directory part
1219  IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
1220  WRITE(*,'(A)')'Usage: '//trim(buf(i+1:))//' [options] [arguments]'
1221 ENDIF
1222 
1223 ! print description message
1224 IF (ASSOCIATED(this%description_msg)) THEN
1225  WRITE(*,'()')
1226  help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
1227  DO j = 1, line_split_get_nlines(help_line)
1228  WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1229  ENDDO
1230  CALL delete(help_line)
1231 ENDIF
1232 
1233 WRITE(*,'(/,A)')'Options:'
1234 
1235 DO i = 1, this%options%arraysize ! loop over options
1236  CALL option_format_help(this%options%array(i), ncols)
1237 ENDDO
1238 
1239 END SUBROUTINE optionparser_printhelptxt
1240 
1241 
1245 SUBROUTINE optionparser_printhelpmd(this)
1246 TYPE(optionparser),INTENT(in) :: this
1247 
1248 INTEGER :: i, j, ncols
1249 CHARACTER(len=80) :: buf
1250 TYPE(line_split) :: help_line
1251 
1252 ncols = default_columns()
1253 
1254 ! print usage message
1255 WRITE(*,'(A)')'### Synopsis'
1256 
1257 IF (ASSOCIATED(this%usage_msg)) THEN
1258  help_line = line_split_new(mdquote_usage_msg(cstr_to_fchar(this%usage_msg)), ncols)
1259  DO j = 1, line_split_get_nlines(help_line)
1260  WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1261  ENDDO
1262  CALL delete(help_line)
1263 ELSE
1264  CALL getarg(0, buf)
1265  i = index(buf, '/', back=.true.) ! remove directory part
1266  IF (buf(i+1:i+3) == 'lt-') i = i + 3 ! remove automake prefix
1267  WRITE(*,'(A)')'Usage: `'//trim(buf(i+1:))//' [options] [arguments]`'
1268 ENDIF
1269 
1270 ! print description message
1271 IF (ASSOCIATED(this%description_msg)) THEN
1272  WRITE(*,'()')
1273  WRITE(*,'(A)')'### Description'
1274  help_line = line_split_new(cstr_to_fchar(this%description_msg), ncols)
1275  DO j = 1, line_split_get_nlines(help_line)
1276  WRITE(*,'(A)')trim(line_split_get_line(help_line,j))
1277  ENDDO
1278  CALL delete(help_line)
1279 
1280 ENDIF
1281 
1282 WRITE(*,'(/,A)')'### Options'
1283 
1284 DO i = 1, this%options%arraysize ! loop over options
1285  CALL option_format_md(this%options%array(i), ncols)
1286 ENDDO
1287 
1288 CONTAINS
1289 
1290 FUNCTION mdquote_usage_msg(usage_msg)
1291 CHARACTER(len=*),INTENT(in) :: usage_msg
1292 
1293 CHARACTER(len=LEN(usage_msg)+2) :: mdquote_usage_msg
1294 INTEGER :: colon
1295 
1296 colon = index(usage_msg, ':') ! typically 'Usage: cp [options] origin destination'
1297 IF (colon > 0 .AND. colon < len(usage_msg)-1) THEN
1298  mdquote_usage_msg = usage_msg(:colon+1)//'`'//usage_msg(colon+2:)//'`'
1299 ELSE
1300  mdquote_usage_msg = usage_msg
1301 ENDIF
1302 
1303 END FUNCTION mdquote_usage_msg
1304 
1305 END SUBROUTINE optionparser_printhelpmd
1306 
1310 SUBROUTINE optionparser_printhelphtmlform(this)
1311 TYPE(optionparser),INTENT(in) :: this
1312 
1313 INTEGER :: i
1314 
1315 DO i = 1, this%options%arraysize ! loop over options
1316  CALL option_format_htmlform(this%options%array(i))
1317 ENDDO
1319 WRITE(*,'(A)')'<input class="libsim_sub" type="submit" value="runprogram" />'
1320 
1321 END SUBROUTINE optionparser_printhelphtmlform
1322 
1323 
1324 SUBROUTINE optionparser_make_completion(this)
1325 TYPE(optionparser),INTENT(in) :: this
1326 
1327 INTEGER :: i
1328 CHARACTER(len=512) :: buf
1329 
1330 CALL getarg(0, buf)
1331 
1332 WRITE(*,'(A/A/A)')'_'//trim(buf)//'()','{','local cur'
1333 
1334 WRITE(*,'(A/A/A/A)')'COMPREPLY=()','cur=${COMP_WORDS[COMP_CWORD]}', &
1335  'case "$cur" in','-*)'
1336 
1337 !-*)
1338 ! COMPREPLY=( $( compgen -W
1339 DO i = 1, this%options%arraysize ! loop over options
1340  IF (this%options%array(i)%need_arg == 2) THEN
1341  ENDIF
1342 ENDDO
1343 
1344 WRITE(*,'(A/A/A)')'esac','return 0','}'
1345 
1346 END SUBROUTINE optionparser_make_completion
1347 
1348 
1349 
1350 SUBROUTINE dirty_char_pointer_set(from, to)
1351 CHARACTER(len=1),POINTER :: from
1352 CHARACTER(len=1),TARGET :: to
1353 from => to
1354 END SUBROUTINE dirty_char_pointer_set
1355 
1356 END MODULE optionparser_class
1357 
1358 
1359 SUBROUTINE dirty_char_assignment(destc, destclen, src, srclen)
1360 USE kinds
1361 IMPLICIT NONE
1362 
1363 INTEGER(kind=int_b) :: destc(*), src(*)
1364 INTEGER :: destclen, srclen
1365 
1366 INTEGER :: i
1367 
1368 DO i = 1, min(destclen, srclen)
1369  destc(i) = src(i)
1370 ENDDO
1371 DO i = srclen+1, destclen
1372  destc(i) = ichar(' ')
1373 ENDDO
1374 
1375 END SUBROUTINE dirty_char_assignment
1376 
Derived type defining a dynamically extensible array of INTEGER elements.
Functions that return a trimmed CHARACTER representation of the input variable.
Gestione degli errori.
Destructor for the optionparser class.
Derived type defining a dynamically extensible array of REAL elements.
Methods for successively obtaining the fields of a csv_record object.
Index method.
Derived type defining a dynamically extensible array of LOGICAL elements.
Module for parsing command-line optons.
Restituiscono il valore dell&#39;oggetto in forma di stringa stampabile.
Derived type defining a dynamically extensible array of DOUBLEPRECISION elements. ...
Costruttori per le classi datetime e timedelta.
Class for interpreting the records of a csv file.
classe per la gestione del logging
Utilities for CHARACTER variables.
Class that allows splitting a long line into shorter lines of equal length at the occurrence of a spe...
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:251
Utilities for managing files.
This module defines usefull general purpose function and subroutine.
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.