libsim  Versione7.1.6
log4fortran.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.
15 
16 ! You should have received a copy of the GNU General Public License
17 ! along with this program. If not, see <http://www.gnu.org/licenses/>.
18 #include "config.h"
19 
23 
113 MODULE log4fortran
114 USE iso_c_binding
115 IMPLICIT NONE
116 
117 INTEGER(kind=c_int),PARAMETER :: l4f_fatal = 000
118 INTEGER(kind=c_int),PARAMETER :: l4f_alert = 100
119 INTEGER(kind=c_int),PARAMETER :: l4f_crit = 200
120 INTEGER(kind=c_int),PARAMETER :: l4f_error = 300
121 INTEGER(kind=c_int),PARAMETER :: l4f_warn = 400
122 INTEGER(kind=c_int),PARAMETER :: l4f_notice = 500
123 INTEGER(kind=c_int),PARAMETER :: l4f_info = 600
124 INTEGER(kind=c_int),PARAMETER :: l4f_debug = 700
125 INTEGER(kind=c_int),PARAMETER :: l4f_trace = 800
126 INTEGER(kind=c_int),PARAMETER :: l4f_notset = 900
127 INTEGER(kind=c_int),PARAMETER :: l4f_unknown = 1000
128 
129 
132 INTEGER(kind=c_int),PUBLIC :: l4f_priority=l4f_notice
133 
137 type,bind(c) :: l4f_handle
138  PRIVATE
139  TYPE(c_ptr) :: ptr = c_null_ptr
140 END TYPE l4f_handle
141 
142 #ifdef HAVE_LIBLOG4C
143 
144 TYPE(l4f_handle),SAVE :: l4f_global_default
145 
146 ! emulation of old cnf behavior returning integer instead of pointer
147 #undef ARRAYOF_ORIGEQ
148 #undef ARRAYOF_ORIGTYPE
149 #undef ARRAYOF_TYPE
150 #define ARRAYOF_ORIGTYPE TYPE(l4f_handle)
151 #define ARRAYOF_TYPE arrayof_l4f_handle
152 #include "arrayof_pre_nodoc.F90"
153 
154 TYPE(arrayof_l4f_handle) :: l4f_global_ptr
155 
157 INTERFACE
158  FUNCTION l4f_init() BIND(C,name='log4c_init')
159  import
160  INTEGER(kind=c_int) :: l4f_init
161  END FUNCTION l4f_init
162 END INTERFACE
163 
166 INTERFACE
167  FUNCTION l4f_category_get_c(a_name) BIND(C,name='log4c_category_get')
168  import
169  CHARACTER(kind=c_char),INTENT(in) :: a_name(*)
171  END FUNCTION l4f_category_get_c
172 END INTERFACE
173 
174 !! Delete a logging category. It can receive a C pointer or a
175 !! legacy integer value.
176 INTERFACE l4f_category_delete
177 ! SUBROUTINE l4f_category_delete_c(a_category) BIND(C,name='log4c_category_delete')
178 ! IMPORT
179 ! TYPE(l4f_handle),VALUE :: a_category !< category as C native pointer
180 ! END SUBROUTINE l4f_category_delete_c
181  MODULE PROCEDURE l4f_category_delete_legacy, l4f_category_delete_f
182 END INTERFACE
183 ! this function has been disabled because aftere deleting a category
184 ! the following log4c_fini fails with a double free, we must
185 ! understand the log4c docs
186 
187 INTERFACE
188  SUBROUTINE l4f_category_log_c(a_category, a_priority, a_format) BIND(C,name='log4c_category_log_c')
189  import
190  TYPE(l4f_handle),value :: a_category
191  INTEGER(kind=c_int),value :: a_priority
192 ! TYPE(c_ptr),VALUE :: locinfo !< not used
193  CHARACTER(kind=c_char),INTENT(in) :: a_format(*)
194  ! TYPE(c_ptr),VALUE :: a_args
195  END SUBROUTINE l4f_category_log_c
196 END INTERFACE
197 
200 INTERFACE l4f_category_log
201  MODULE PROCEDURE l4f_category_log_f, l4f_category_log_legacy
202 END INTERFACE l4f_category_log
203 
205 INTERFACE l4f_category_exist
206  MODULE PROCEDURE l4f_category_exist_f, l4f_category_exist_legacy
207 END INTERFACE l4f_category_exist
208 
210 INTERFACE
211  FUNCTION l4f_fini() BIND(C,name='log4c_fini')
212  import
213  INTEGER(kind=c_int) :: l4f_fini
214  END FUNCTION l4f_fini
215 END INTERFACE
216 
218 !interface
219 !CHARACTER(len=12) FUNCTION l4f_msg(a_priority)
220 !integer,intent(in):: a_priority !< category name
221 !end function l4f_msg
222 !end interface
223 
224 #else
225 
226 CHARACTER(len=510),PRIVATE:: dummy_a_name
227 
228 #endif
229 
230 PRIVATE
231 PUBLIC l4f_fatal, l4f_alert, l4f_crit, l4f_error, l4f_warn, l4f_notice, &
232  l4f_info, l4f_debug, l4f_trace, l4f_notset, l4f_unknown
233 PUBLIC l4f_init, l4f_category_get, l4f_category_delete, l4f_category_log, &
234  l4f_log, l4f_category_exist, l4f_fini
235 PUBLIC l4f_launcher
236 
237 CONTAINS
238 
243 SUBROUTINE l4f_launcher(a_name, a_name_force, a_name_append)
244 CHARACTER(len=*),INTENT(out) :: a_name
245 CHARACTER(len=*),INTENT(in),OPTIONAL :: a_name_force
246 CHARACTER(len=*),INTENT(in),OPTIONAL :: a_name_append
247 
248 INTEGER :: tarray(8)
249 CHARACTER(len=255) :: log4_application_name,log4_application_id,arg
250 CHARACTER(len=255),SAVE :: a_name_save=""
251 
252 IF (present(a_name_force))THEN
253  a_name=a_name_force
254 ELSE IF (a_name_save /= "")THEN
255  a_name=a_name_save
256 ELSE
257 
258  CALL date_and_time(values=tarray)
259  CALL getarg(0, arg)
260  CALL getenv("LOG4_APPLICATION_NAME", log4_application_name)
261  CALL getenv("LOG4_APPLICATION_ID", log4_application_id)
262 
263  IF (log4_application_name == "" .AND. log4_application_id == "") THEN
264  WRITE(a_name,"(a,a,8i5,a)")trim(arg),"[",tarray,"]"
265  ELSE
266  a_name = trim(log4_application_name)//"["//trim(log4_application_id)//"]"
267  END IF
268 
269 END IF
270 
271 a_name_save=a_name
272 
273 IF (present(a_name_append)) THEN
274  a_name=trim(a_name)//"."//trim(a_name_append)
275 END IF
276 
277 END SUBROUTINE l4f_launcher
278 
279 #ifndef HAVE_LIBLOG4C
280 ! definisce delle dummy routine
281 
283 integer function l4f_init()
284 
285 character(len=10)::priority
286 integer :: iostat
287 
288 call getenv("LOG4C_PRIORITY",priority)
289 if (priority=="") then
290  l4f_priority = l4f_notice
291 else
292  read(priority,*,iostat=iostat)l4f_priority
293 end if
294 
295 if (iostat /= 0) then
296  l4f_priority = l4f_notice
297 end if
299 l4f_init = 0
300 
301 end function l4f_init
305 integer function l4f_category_get (a_name)
306 character (len=*),intent(in) :: a_name
308 dummy_a_name = a_name
309 l4f_category_get = 1
311 end function l4f_category_get
313 
315 subroutine l4f_category_delete(a_category)
316 integer,intent(in):: a_category
318 if (a_category == 1) dummy_a_name = ""
319 
320 end subroutine l4f_category_delete
321 
324 subroutine l4f_category_log (a_category,a_priority,a_format)
325 integer,intent(in):: a_category
326 integer,intent(in):: a_priority
327 character(len=*),intent(in):: a_format
328 
329 if (a_category == 1 .and. a_priority <= l4f_priority) then
330  write(*,*)"[dummy] ",l4f_msg(a_priority),trim(dummy_a_name)," - ",trim(a_format)
331 end if
332 
333 end subroutine l4f_category_log
334 
335 
337 subroutine l4f_log (a_priority,a_format)
338 integer,intent(in):: a_priority
339 character(len=*),intent(in):: a_format
340 
341 if ( a_priority <= l4f_priority) then
342  write(*,*)"[_default] ",l4f_msg(a_priority),trim(dummy_a_name)," - ",trim(a_format)
343 end if
344 
345 end subroutine l4f_log
346 
347 
349 logical function l4f_category_exist (a_category)
350 integer,intent(in):: a_category
351 
352 if (a_category == 1) then
353  l4f_category_exist= .true.
354 else
355  l4f_category_exist= .false.
356 end if
357 
358 end function l4f_category_exist
359 
360 
362 integer function l4f_fini()
363 
364 l4f_fini= 0
365 
366 end function l4f_fini
367 
369 character(len=12) function l4f_msg(a_priority)
370 
371 integer,intent(in):: a_priority
372 
373 write(l4f_msg,*)a_priority
374 
375 if (a_priority == l4f_fatal) l4f_msg="FATAL"
376 if (a_priority == l4f_alert) l4f_msg="ALERT"
377 if (a_priority == l4f_crit) l4f_msg="CRIT"
378 if (a_priority == l4f_error) l4f_msg="ERROR"
379 if (a_priority == l4f_warn) l4f_msg="WARN"
380 if (a_priority == l4f_notice) l4f_msg="NOTICE"
381 if (a_priority == l4f_info) l4f_msg="INFO"
382 if (a_priority == l4f_debug) l4f_msg="DEBUG"
383 if (a_priority == l4f_trace) l4f_msg="TRACE"
384 if (a_priority == l4f_notset) l4f_msg="NOTSET"
385 if (a_priority == l4f_unknown) l4f_msg="UNKNOWN"
386 
387 end function l4f_msg
388 
389 #else
390 
391 #include "arrayof_post_nodoc.F90"
392 
396 FUNCTION l4f_category_get(a_name) RESULT(handle)
397 CHARACTER(kind=c_char,len=*),INTENT(in) :: a_name
398 INTEGER :: handle
399 
400 INTEGER :: i
401 
402 DO i = 1, l4f_global_ptr%arraysize ! look first for a hole
403  IF (.NOT.l4f_category_exist(l4f_global_ptr%array(i))) THEN
404  l4f_global_ptr%array(i) = l4f_category_get_c(trim(a_name)//char(0))
405  handle = i
406  RETURN
407  ENDIF
408 ENDDO
409 
410 handle = append(l4f_global_ptr, l4f_category_get_c(trim(a_name)//char(0)))
411 
412 END FUNCTION l4f_category_get
413 
414 
418 FUNCTION l4f_category_get_handle(a_name) RESULT(handle)
419 CHARACTER(kind=c_char,len=*),INTENT(in) :: a_name
420 type(l4f_handle) :: handle
422 handle = l4f_category_get_c(trim(a_name)//char(0))
423 
424 END FUNCTION l4f_category_get_handle
425 
426 
428 SUBROUTINE l4f_category_delete_legacy(a_category)
429 INTEGER,INTENT(in) :: a_category
430 
431 IF (a_category <= 0 .OR. a_category > l4f_global_ptr%arraysize) RETURN
432 IF (a_category == l4f_global_ptr%arraysize) THEN
433  CALL remove(l4f_global_ptr, pos=a_category)
434 ELSE
435  l4f_global_ptr%array(a_category)%ptr = c_null_ptr
436 ENDIF
437 
438 END SUBROUTINE l4f_category_delete_legacy
439 
440 
442 SUBROUTINE l4f_category_delete_f(a_category)
443 TYPE(l4f_handle),INTENT(inout) :: a_category
444 
445 a_category%ptr = c_null_ptr ! is it necessary?
446 
447 END SUBROUTINE l4f_category_delete_f
448 
449 
452 SUBROUTINE l4f_category_log_f(a_category, a_priority, a_format)
453 TYPE(l4f_handle),INTENT(in) :: a_category
454 INTEGER(kind=c_int),INTENT(in) :: a_priority
455 CHARACTER(len=*),INTENT(in) :: a_format
456 
457 CALL l4f_category_log_c(a_category, a_priority, trim(a_format)//char(0))
458 
459 END SUBROUTINE l4f_category_log_f
460 
461 
465 SUBROUTINE l4f_category_log_legacy(a_category, a_priority, a_format)
466 INTEGER(kind=c_int),INTENT(in) :: a_category
467 INTEGER(kind=c_int),INTENT(in) :: a_priority
468 CHARACTER(len=*),INTENT(in) :: a_format
469 
470 CALL l4f_category_log_c(l4f_global_ptr%array(a_category), a_priority, trim(a_format)//char(0))
471 
472 END SUBROUTINE l4f_category_log_legacy
473 
474 
477 SUBROUTINE l4f_log(a_priority, a_format)
478 INTEGER(kind=c_int),INTENT(in) :: a_priority
479 CHARACTER(len=*),INTENT(in) :: a_format
480 
481 INTEGER :: i
482 
483 IF (.NOT.l4f_category_exist(l4f_global_default)) THEN
484  i = l4f_init()
485  l4f_global_default = l4f_category_get_handle('_default')
486 ENDIF
487 CALL l4f_category_log(l4f_global_default, a_priority, a_format)
488 
489 END SUBROUTINE l4f_log
490 
491 
494 FUNCTION l4f_category_exist_f(a_category) RESULT(exist)
495 TYPE(l4f_handle),INTENT(in) :: a_category
496 LOGICAL :: exist
498 exist = c_associated(a_category%ptr)
499 
500 END FUNCTION l4f_category_exist_f
501 
506 FUNCTION l4f_category_exist_legacy(a_category) RESULT(exist)
507 INTEGER,INTENT(in):: a_category
508 LOGICAL :: exist
509 
510 IF (a_category <= 0 .OR. a_category > l4f_global_ptr%arraysize) THEN
511  exist = .false.
512 ELSE
513  exist = l4f_category_exist(l4f_global_ptr%array(a_category))
514 ENDIF
515 
516 END FUNCTION l4f_category_exist_legacy
517 
518 
519 #endif
520 
521 end module log4fortran
Initialize a logging category.
Return true if the corresponding category handle exists.
log4fortran destructor
classe per la gestione del logging
Global log4fortran constructor.
Emit log message for a category with specific priority.

Generated with Doxygen.