log4fortran.F90

! Copyright (C) 2010  ARPA-SIM <urpsim@smr.arpa.emr.it>
! authors:
! Davide Cesari <dcesari@arpa.emr.it>
! Paolo Patruno <ppatruno@arpa.emr.it>

! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License as
! published by the Free Software Foundation; either version 2 of 
! the License, or (at your option) any later version.

! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.

! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
#include "config.h"


MODULE log4fortran
USE iso_c_binding
IMPLICIT NONE

INTEGER(kind=c_int),PARAMETER :: L4F_FATAL    = 000
INTEGER(kind=c_int),PARAMETER :: L4F_ALERT    = 100
INTEGER(kind=c_int),PARAMETER :: L4F_CRIT     = 200
INTEGER(kind=c_int),PARAMETER :: L4F_ERROR    = 300
INTEGER(kind=c_int),PARAMETER :: L4F_WARN     = 400
INTEGER(kind=c_int),PARAMETER :: L4F_NOTICE   = 500
INTEGER(kind=c_int),PARAMETER :: L4F_INFO     = 600
INTEGER(kind=c_int),PARAMETER :: L4F_DEBUG    = 700
INTEGER(kind=c_int),PARAMETER :: L4F_TRACE    = 800
INTEGER(kind=c_int),PARAMETER :: L4F_NOTSET   = 900
INTEGER(kind=c_int),PARAMETER :: L4F_UNKNOWN  = 1000

INTEGER(kind=c_int),PUBLIC :: l4f_priority=l4f_notice

#ifdef HAVE_LIBLOG4C

TYPE,BIND(C) :: l4f_handle
  PRIVATE
  TYPE(c_ptr) :: ptr = c_null_ptr
END TYPE l4f_handle


TYPE(l4f_handle),SAVE :: l4f_global_default

#undef ARRAYOF_ORIGEQ
#undef ARRAYOF_ORIGTYPE
#undef ARRAYOF_TYPE
#define ARRAYOF_ORIGTYPE TYPE(l4f_handle)
#define ARRAYOF_TYPE arrayof_l4f_handle
#include "arrayof_pre_nodoc.F90"

TYPE(arrayof_l4f_handle) :: l4f_global_ptr

INTERFACE 
  FUNCTION l4f_init() bind(C,name='log4c_init')
  import
  INTEGER(kind=c_int) :: l4f_init
  END FUNCTION l4f_init
END INTERFACE

! Internal C interface not to be used by user Fortran code
INTERFACE
  FUNCTION l4f_category_get_c(a_name) bind(C,name='log4c_category_get')
  import
  CHARACTER(kind=c_char),INTENT(in) :: a_name(*)
  TYPE(l4f_handle) :: l4f_category_get_c
  END FUNCTION l4f_category_get_c
END INTERFACE

! Internal C interface not to be used by user Fortran code
! this function has been disabled because after deleting a category
! the following log4c_fini fails with a double free, we must
! understand the log4c docs
INTERFACE
  SUBROUTINE l4f_category_delete_c(a_category) bind(C,name='log4c_category_delete')
  import
  TYPE(l4f_handle),VALUE :: a_category
  END SUBROUTINE l4f_category_delete_c
END INTERFACE

!! Delete a logging category. It can receive a l4f_handle pointer or a
!! legacy integer value.
INTERFACE l4f_category_delete
  MODULE PROCEDURE l4f_category_delete_legacy, l4f_category_delete_f
END INTERFACE

! Internal C interface not to be used by user Fortran code
INTERFACE
  SUBROUTINE l4f_category_log_c(a_category, a_priority, a_format) bind(C,name='log4c_category_log_c')
  import
  TYPE(l4f_handle),VALUE :: a_category
  INTEGER(kind=c_int),VALUE :: a_priority
!  TYPE(c_ptr),VALUE :: locinfo !< not used
  CHARACTER(kind=c_char),INTENT(in) :: a_format(*)
 ! TYPE(c_ptr),VALUE :: a_args
  END SUBROUTINE l4f_category_log_c
END INTERFACE

INTERFACE l4f_category_log
  MODULE PROCEDURE l4f_category_log_f, l4f_category_log_legacy
END INTERFACE l4f_category_log

INTERFACE l4f_category_exist
  MODULE PROCEDURE l4f_category_exist_f, l4f_category_exist_legacy
END INTERFACE l4f_category_exist

INTERFACE
  FUNCTION l4f_fini() bind(C,name='log4c_fini')
  import
  INTEGER(kind=c_int) :: l4f_fini
  END FUNCTION l4f_fini
END INTERFACE

!interface
!CHARACTER(len=12) FUNCTION l4f_msg(a_priority)
!integer,intent(in):: a_priority !< category name
!end function l4f_msg
!end interface

#else

CHARACTER(len=510),PRIVATE:: dummy_a_name

TYPE :: l4f_handle
  PRIVATE
  INTEGER :: ptr = 0
END TYPE l4f_handle

#endif

PRIVATE
PUBLIC l4f_fatal, l4f_alert, l4f_crit, l4f_error, l4f_warn, l4f_notice, &
 l4f_info, l4f_debug, l4f_trace, l4f_notset, l4f_unknown
PUBLIC l4f_handle, l4f_init, l4f_category_get_handle, l4f_category_get, l4f_category_delete, l4f_category_log, &
 l4f_log, l4f_category_exist, l4f_fini
PUBLIC l4f_launcher

CONTAINS

SUBROUTINE l4f_launcher(a_name, a_name_force, a_name_append)
CHARACTER(len=*),INTENT(out) :: a_name
CHARACTER(len=*),INTENT(in),OPTIONAL :: a_name_force
CHARACTER(len=*),INTENT(in),OPTIONAL :: a_name_append

INTEGER :: tarray(8)
CHARACTER(len=255) :: LOG4_APPLICATION_NAME,LOG4_APPLICATION_ID,arg
CHARACTER(len=255),SAVE :: a_name_save=""

IF (PRESENT(a_name_force))THEN
  a_name=a_name_force
ELSE IF (a_name_save /= "")THEN
  a_name=a_name_save
ELSE
  
  CALL date_and_time(values=tarray)
  CALL getarg(0, arg)
  CALL getenv("LOG4_APPLICATION_NAME", log4_application_name)
  CALL getenv("LOG4_APPLICATION_ID", log4_application_id)
  
  IF (log4_application_name == "" .AND. log4_application_id == "") THEN
    WRITE(a_name,"(a,a,8i5,a)")trim(arg),"[",tarray,"]"
  ELSE
    a_name = trim(log4_application_name)//"["//trim(log4_application_id)//"]"
  END IF

END IF

a_name_save=a_name

IF (PRESENT(a_name_append)) THEN
  a_name=trim(a_name)//"."//trim(a_name_append)
END IF
  
END SUBROUTINE l4f_launcher

#ifndef HAVE_LIBLOG4C
! define dummy function to replace log4c interface

INTEGER FUNCTION l4f_init()
CHARACTER(len=10) :: priority
INTEGER :: iostat

CALL getenv("LOG4C_PRIORITY",priority)
IF (priority=="") THEN
  l4f_priority = l4f_notice
ELSE
  READ(priority,*,iostat=iostat)l4f_priority
END IF

IF (iostat /= 0) THEN
  l4f_priority = l4f_notice
END IF

l4f_init = 0

END FUNCTION l4f_init


FUNCTION l4f_category_get(a_name) RESULT(handle)
CHARACTER(len=*),INTENT(in) :: a_name

TYPE(l4f_handle) :: handle

handle%ptr = 1
dummy_a_name = a_name

END FUNCTION l4f_category_get


SUBROUTINE l4f_category_delete(a_category)
TYPE(l4f_handle),INTENT(in) :: a_category

a_category%ptr = 0
dummy_a_name = ""

END SUBROUTINE l4f_category_delete


SUBROUTINE l4f_category_log(a_category,a_priority,a_format)
TYPE(l4f_handle),INTENT(in) :: a_category
INTEGER,INTENT(in):: a_priority
CHARACTER(len=*),INTENT(in):: a_format

IF (a_category%ptr == 1 .AND. a_priority <= l4f_priority) THEN
  WRITE(*,*)"[dummy] ",l4f_msg(a_priority),trim(dummy_a_name)," - ",trim(a_format)
ENDIF

END SUBROUTINE l4f_category_log


SUBROUTINE l4f_log(a_priority,a_format)
INTEGER,INTENT(in):: a_priority
CHARACTER(len=*),INTENT(in):: a_format

IF (a_priority <= l4f_priority) THEN
  WRITE(*,*)"[_default] ",l4f_msg(a_priority),trim(dummy_a_name)," - ",trim(a_format)
ENDIF

END SUBROUTINE l4f_log


LOGICAL FUNCTION l4f_category_exist(a_category)
TYPE(l4f_handle),INTENT(in) :: a_category

l4f_category_exist = a_category%ptr == 1

END FUNCTION l4f_category_exist


INTEGER FUNCTION l4f_fini()

l4f_fini= 0

END FUNCTION l4f_fini

CHARACTER(len=12) FUNCTION l4f_msg(a_priority)
INTEGER,INTENT(in):: a_priority

write(l4f_msg,*)a_priority

if (a_priority == l4f_fatal)   l4f_msg="FATAL"
if (a_priority == l4f_alert)   l4f_msg="ALERT"
if (a_priority == l4f_crit)    l4f_msg="CRIT"
if (a_priority == l4f_error)   l4f_msg="ERROR"
if (a_priority == l4f_warn)    l4f_msg="WARN"
if (a_priority == l4f_notice)  l4f_msg="NOTICE"
if (a_priority == l4f_info)    l4f_msg="INFO"
if (a_priority == l4f_debug)   l4f_msg="DEBUG"
if (a_priority == l4f_trace)   l4f_msg="TRACE"
if (a_priority == l4f_notset)  l4f_msg="NOTSET"
if (a_priority == l4f_unknown) l4f_msg="UNKNOWN"

END FUNCTION l4f_msg

#else

#include "arrayof_post_nodoc.F90"

FUNCTION l4f_category_get(a_name) RESULT(handle)
CHARACTER(kind=c_char,len=*),INTENT(in) :: a_name
INTEGER :: handle

handle = append(l4f_global_ptr, l4f_category_get_c(trim(a_name)//char(0)))

END FUNCTION l4f_category_get


FUNCTION l4f_category_get_handle(a_name) RESULT(handle)
CHARACTER(kind=c_char,len=*),INTENT(in) :: a_name
TYPE(l4f_handle) :: handle

handle = l4f_category_get_c(trim(a_name)//char(0))

END FUNCTION l4f_category_get_handle


SUBROUTINE l4f_category_delete_legacy(a_category)
INTEGER,INTENT(in) :: a_category

IF (a_category <= 0 .OR. a_category > l4f_global_ptr%arraysize) RETURN
CALL remove(l4f_global_ptr, pos=a_category)

END SUBROUTINE l4f_category_delete_legacy


SUBROUTINE l4f_category_delete_f(a_category)
TYPE(l4f_handle),INTENT(inout) :: a_category

! hee the C function should be called, see comment above
! CALL l4f_category_delete_c(a_category)
a_category%ptr = c_null_ptr

END SUBROUTINE l4f_category_delete_f


SUBROUTINE l4f_category_log_f(a_category, a_priority, a_format)
TYPE(l4f_handle),INTENT(in) :: a_category
INTEGER(kind=c_int),INTENT(in) :: a_priority
CHARACTER(len=*),INTENT(in) :: a_format

CALL l4f_category_log_c(a_category, a_priority, trim(a_format)//char(0))

END SUBROUTINE l4f_category_log_f


SUBROUTINE l4f_category_log_legacy(a_category, a_priority, a_format)
INTEGER(kind=c_int),INTENT(in) :: a_category
INTEGER(kind=c_int),INTENT(in) :: a_priority
CHARACTER(len=*),INTENT(in) :: a_format

CALL l4f_category_log_c(l4f_global_ptr%array(a_category), l4f_warn, &
 'You are using the legacy log4fortran interface!'//char(0))
CALL l4f_category_log_c(l4f_global_ptr%array(a_category), l4f_warn, &
 'Please, upgrade your code by defining category as `TYPE(l4f_handle)`'//char(0))
CALL l4f_category_log_c(l4f_global_ptr%array(a_category), l4f_warn, &
 'and replacing `l4f_category_get` with `l4f_category_get_handle`'//char(0))
CALL l4f_category_log_c(l4f_global_ptr%array(a_category), a_priority, trim(a_format)//char(0))

END SUBROUTINE l4f_category_log_legacy


SUBROUTINE l4f_log(a_priority, a_format)
INTEGER(kind=c_int),INTENT(in) :: a_priority
CHARACTER(len=*),INTENT(in) :: a_format

INTEGER :: i

IF (.NOT.l4f_category_exist(l4f_global_default)) THEN
  i = l4f_init()
  l4f_global_default = l4f_category_get_handle('_default')
ENDIF
CALL l4f_category_log(l4f_global_default, a_priority, a_format)

END SUBROUTINE l4f_log


FUNCTION l4f_category_exist_f(a_category) RESULT(exist)
TYPE(l4f_handle),INTENT(in) :: a_category
LOGICAL :: exist

exist = c_associated(a_category%ptr)

END FUNCTION l4f_category_exist_f

FUNCTION l4f_category_exist_legacy(a_category) RESULT(exist)
INTEGER,INTENT(in):: a_category
LOGICAL :: exist

IF (a_category <= 0 .OR. a_category > l4f_global_ptr%arraysize) THEN
  exist = .false.
ELSE
  exist = l4f_category_exist(l4f_global_ptr%array(a_category))
ENDIF

END FUNCTION l4f_category_exist_legacy

#endif

END MODULE log4fortran