libsim Versione 7.2.0
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
113MODULE log4fortran
114USE iso_c_binding
115IMPLICIT NONE
116
117INTEGER(kind=c_int),PARAMETER :: L4F_FATAL = 000
118INTEGER(kind=c_int),PARAMETER :: L4F_ALERT = 100
119INTEGER(kind=c_int),PARAMETER :: L4F_CRIT = 200
120INTEGER(kind=c_int),PARAMETER :: L4F_ERROR = 300
121INTEGER(kind=c_int),PARAMETER :: L4F_WARN = 400
122INTEGER(kind=c_int),PARAMETER :: L4F_NOTICE = 500
123INTEGER(kind=c_int),PARAMETER :: L4F_INFO = 600
124INTEGER(kind=c_int),PARAMETER :: L4F_DEBUG = 700
125INTEGER(kind=c_int),PARAMETER :: L4F_TRACE = 800
126INTEGER(kind=c_int),PARAMETER :: L4F_NOTSET = 900
127INTEGER(kind=c_int),PARAMETER :: L4F_UNKNOWN = 1000
128
132INTEGER(kind=c_int),PUBLIC :: l4f_priority=l4f_notice
133
137TYPE,BIND(C) :: l4f_handle
138 PRIVATE
139 TYPE(c_ptr) :: ptr = c_null_ptr
140END TYPE l4f_handle
141
142#ifdef HAVE_LIBLOG4C
143
144TYPE(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
154TYPE(arrayof_l4f_handle) :: l4f_global_ptr
155
157INTERFACE
158 FUNCTION l4f_init() bind(C,name='log4c_init')
159 IMPORT
160 INTEGER(kind=c_int) :: l4f_init
161 END FUNCTION l4f_init
162END INTERFACE
163
166INTERFACE
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(*)
170 TYPE(l4f_handle) :: l4f_category_get_c
171 END FUNCTION l4f_category_get_c
172END INTERFACE
173
174!! Delete a logging category. It can receive a C pointer or a
175!! legacy integer value.
176INTERFACE 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
182END 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
187INTERFACE
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
196END INTERFACE
197
200INTERFACE l4f_category_log
201 MODULE PROCEDURE l4f_category_log_f, l4f_category_log_legacy
202END INTERFACE l4f_category_log
203
205INTERFACE l4f_category_exist
206 MODULE PROCEDURE l4f_category_exist_f, l4f_category_exist_legacy
207END INTERFACE l4f_category_exist
208
210INTERFACE
211 FUNCTION l4f_fini() bind(C,name='log4c_fini')
212 IMPORT
213 INTEGER(kind=c_int) :: l4f_fini
214 END FUNCTION l4f_fini
215END 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
226CHARACTER(len=510),PRIVATE:: dummy_a_name
227
228#endif
229
230PRIVATE
231PUBLIC l4f_fatal, l4f_alert, l4f_crit, l4f_error, l4f_warn, l4f_notice, &
232 l4f_info, l4f_debug, l4f_trace, l4f_notset, l4f_unknown
233PUBLIC l4f_init, l4f_category_get, l4f_category_delete, l4f_category_log, &
235PUBLIC l4f_launcher
236
237CONTAINS
238
243SUBROUTINE l4f_launcher(a_name, a_name_force, a_name_append)
244CHARACTER(len=*),INTENT(out) :: a_name
245CHARACTER(len=*),INTENT(in),OPTIONAL :: a_name_force
246CHARACTER(len=*),INTENT(in),OPTIONAL :: a_name_append
247
248INTEGER :: tarray(8)
249CHARACTER(len=255) :: LOG4_APPLICATION_NAME,LOG4_APPLICATION_ID,arg
250CHARACTER(len=255),SAVE :: a_name_save=""
251
252IF (PRESENT(a_name_force))THEN
253 a_name=a_name_force
254ELSE IF (a_name_save /= "")THEN
255 a_name=a_name_save
256ELSE
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
269END IF
270
271a_name_save=a_name
272
273IF (PRESENT(a_name_append)) THEN
274 a_name=trim(a_name)//"."//trim(a_name_append)
275END IF
276
277END SUBROUTINE l4f_launcher
278
279#ifndef HAVE_LIBLOG4C
280! definisce delle dummy routine
281
283integer function l4f_init()
284
285character(len=10)::priority
286integer :: iostat
287
288call getenv("LOG4C_PRIORITY",priority)
289if (priority=="") then
290 l4f_priority = l4f_notice
291else
292 read(priority,*,iostat=iostat)l4f_priority
293end if
294
295if (iostat /= 0) then
296 l4f_priority = l4f_notice
297end if
298
299l4f_init = 0
300
301end function l4f_init
302
303
305integer function l4f_category_get (a_name)
306character (len=*),intent(in) :: a_name
308dummy_a_name = a_name
309l4f_category_get = 1
311end function l4f_category_get
315subroutine l4f_category_delete(a_category)
316integer,intent(in):: a_category
317
318if (a_category == 1) dummy_a_name = ""
319
320end subroutine l4f_category_delete
321
322
324subroutine l4f_category_log (a_category,a_priority,a_format)
325integer,intent(in):: a_category
326integer,intent(in):: a_priority
327character(len=*),intent(in):: a_format
328
329if (a_category == 1 .and. a_priority <= l4f_priority) then
330 write(*,*)"[dummy] ",l4f_msg(a_priority),trim(dummy_a_name)," - ",trim(a_format)
331end if
332
333end subroutine l4f_category_log
334
335
337subroutine l4f_log (a_priority,a_format)
338integer,intent(in):: a_priority
339character(len=*),intent(in):: a_format
340
341if ( a_priority <= l4f_priority) then
342 write(*,*)"[_default] ",l4f_msg(a_priority),trim(dummy_a_name)," - ",trim(a_format)
343end if
344
345end subroutine l4f_log
346
347
349logical function l4f_category_exist (a_category)
350integer,intent(in):: a_category
351
352if (a_category == 1) then
353 l4f_category_exist= .true.
354else
355 l4f_category_exist= .false.
356end if
357
358end function l4f_category_exist
359
360
362integer function l4f_fini()
363
364l4f_fini= 0
365
366end function l4f_fini
367
369character(len=12) function l4f_msg(a_priority)
370
371integer,intent(in):: a_priority
372
373write(l4f_msg,*)a_priority
374
375if (a_priority == l4f_fatal) l4f_msg="FATAL"
376if (a_priority == l4f_alert) l4f_msg="ALERT"
377if (a_priority == l4f_crit) l4f_msg="CRIT"
378if (a_priority == l4f_error) l4f_msg="ERROR"
379if (a_priority == l4f_warn) l4f_msg="WARN"
380if (a_priority == l4f_notice) l4f_msg="NOTICE"
381if (a_priority == l4f_info) l4f_msg="INFO"
382if (a_priority == l4f_debug) l4f_msg="DEBUG"
383if (a_priority == l4f_trace) l4f_msg="TRACE"
384if (a_priority == l4f_notset) l4f_msg="NOTSET"
385if (a_priority == l4f_unknown) l4f_msg="UNKNOWN"
386
387end function l4f_msg
388
389#else
390
391#include "arrayof_post_nodoc.F90"
392
396FUNCTION l4f_category_get(a_name) RESULT(handle)
397CHARACTER(kind=c_char,len=*),INTENT(in) :: a_name
398INTEGER :: handle
399
400INTEGER :: i
401
402DO 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
408ENDDO
409
410handle = append(l4f_global_ptr, l4f_category_get_c(trim(a_name)//char(0)))
411
412END FUNCTION l4f_category_get
413
414
418FUNCTION l4f_category_get_handle(a_name) RESULT(handle)
419CHARACTER(kind=c_char,len=*),INTENT(in) :: a_name
420TYPE(l4f_handle) :: handle
421
422handle = l4f_category_get_c(trim(a_name)//char(0))
423
424END FUNCTION l4f_category_get_handle
425
426
428SUBROUTINE l4f_category_delete_legacy(a_category)
429INTEGER,INTENT(in) :: a_category
430
431IF (a_category <= 0 .OR. a_category > l4f_global_ptr%arraysize) RETURN
432IF (a_category == l4f_global_ptr%arraysize) THEN
433 CALL remove(l4f_global_ptr, pos=a_category)
434ELSE
435 l4f_global_ptr%array(a_category)%ptr = c_null_ptr
436ENDIF
437
438END SUBROUTINE l4f_category_delete_legacy
439
440
442SUBROUTINE l4f_category_delete_f(a_category)
443TYPE(l4f_handle),INTENT(inout) :: a_category
444
445a_category%ptr = c_null_ptr ! is it necessary?
446
447END SUBROUTINE l4f_category_delete_f
448
449
452SUBROUTINE l4f_category_log_f(a_category, a_priority, a_format)
453TYPE(l4f_handle),INTENT(in) :: a_category
454INTEGER(kind=c_int),INTENT(in) :: a_priority
455CHARACTER(len=*),INTENT(in) :: a_format
456
457CALL l4f_category_log_c(a_category, a_priority, trim(a_format)//char(0))
458
459END SUBROUTINE l4f_category_log_f
460
461
465SUBROUTINE l4f_category_log_legacy(a_category, a_priority, a_format)
466INTEGER(kind=c_int),INTENT(in) :: a_category
467INTEGER(kind=c_int),INTENT(in) :: a_priority
468CHARACTER(len=*),INTENT(in) :: a_format
469
470CALL l4f_category_log_c(l4f_global_ptr%array(a_category), a_priority, trim(a_format)//char(0))
471
472END SUBROUTINE l4f_category_log_legacy
473
474
477SUBROUTINE l4f_log(a_priority, a_format)
478INTEGER(kind=c_int),INTENT(in) :: a_priority
479CHARACTER(len=*),INTENT(in) :: a_format
480
481INTEGER :: i
482
483IF (.NOT.l4f_category_exist(l4f_global_default)) THEN
484 i = l4f_init()
485 l4f_global_default = l4f_category_get_handle('_default')
486ENDIF
487CALL l4f_category_log(l4f_global_default, a_priority, a_format)
488
489END SUBROUTINE l4f_log
490
491
494FUNCTION l4f_category_exist_f(a_category) RESULT(exist)
495TYPE(l4f_handle),INTENT(in) :: a_category
496LOGICAL :: exist
497
498exist = c_associated(a_category%ptr)
499
500END FUNCTION l4f_category_exist_f
501
506FUNCTION l4f_category_exist_legacy(a_category) RESULT(exist)
507INTEGER,INTENT(in):: a_category
508LOGICAL :: exist
509
510IF (a_category <= 0 .OR. a_category > l4f_global_ptr%arraysize) THEN
511 exist = .false.
512ELSE
513 exist = l4f_category_exist(l4f_global_ptr%array(a_category))
514ENDIF
515
516END FUNCTION l4f_category_exist_legacy
517
518
519#endif
520
521end module log4fortran
Return true if the corresponding category handle exists.
Initialize a logging category.
Emit log message for a category with specific priority.
log4fortran destructor
Global log4fortran constructor.
classe per la gestione del logging

Generated with Doxygen.