libsim Versione 7.2.1

◆ l4f_category_get_handle()

type(l4f_handle) function l4f_category_get_handle ( character(kind=c_char,len=*), intent(in)  a_name)
private

Initialize a logging category.

This is the Fortran version that receives a Fortran character argument and returns a typed handle.

Parametri
[in]a_namecategory name

Definizione alla linea 785 del file log4fortran.F90.

786! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
787! authors:
788! Davide Cesari <dcesari@arpa.emr.it>
789! Paolo Patruno <ppatruno@arpa.emr.it>
790
791! This program is free software; you can redistribute it and/or
792! modify it under the terms of the GNU General Public License as
793! published by the Free Software Foundation; either version 2 of
794! the License, or (at your option) any later version.
795
796! This program is distributed in the hope that it will be useful,
797! but WITHOUT ANY WARRANTY; without even the implied warranty of
798! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
799! GNU General Public License for more details.
800
801! You should have received a copy of the GNU General Public License
802! along with this program. If not, see <http://www.gnu.org/licenses/>.
803#include "config.h"
804
808
898MODULE log4fortran
899USE iso_c_binding
900IMPLICIT NONE
901
902INTEGER(kind=c_int),PARAMETER :: L4F_FATAL = 000
903INTEGER(kind=c_int),PARAMETER :: L4F_ALERT = 100
904INTEGER(kind=c_int),PARAMETER :: L4F_CRIT = 200
905INTEGER(kind=c_int),PARAMETER :: L4F_ERROR = 300
906INTEGER(kind=c_int),PARAMETER :: L4F_WARN = 400
907INTEGER(kind=c_int),PARAMETER :: L4F_NOTICE = 500
908INTEGER(kind=c_int),PARAMETER :: L4F_INFO = 600
909INTEGER(kind=c_int),PARAMETER :: L4F_DEBUG = 700
910INTEGER(kind=c_int),PARAMETER :: L4F_TRACE = 800
911INTEGER(kind=c_int),PARAMETER :: L4F_NOTSET = 900
912INTEGER(kind=c_int),PARAMETER :: L4F_UNKNOWN = 1000
913
917INTEGER(kind=c_int),PUBLIC :: l4f_priority=l4f_notice
918
922TYPE,BIND(C) :: l4f_handle
923 PRIVATE
924 TYPE(c_ptr) :: ptr = c_null_ptr
925END TYPE l4f_handle
926
927#ifdef HAVE_LIBLOG4C
928
929TYPE(l4f_handle),SAVE :: l4f_global_default
930
931! emulation of old cnf behavior returning integer instead of pointer
932#undef ARRAYOF_ORIGEQ
933#undef ARRAYOF_ORIGTYPE
934#undef ARRAYOF_TYPE
935#define ARRAYOF_ORIGTYPE TYPE(l4f_handle)
936#define ARRAYOF_TYPE arrayof_l4f_handle
937#include "arrayof_pre_nodoc.F90"
938
939TYPE(arrayof_l4f_handle) :: l4f_global_ptr
940
942INTERFACE
943 FUNCTION l4f_init() bind(C,name='log4c_init')
944 IMPORT
945 INTEGER(kind=c_int) :: l4f_init
946 END FUNCTION l4f_init
947END INTERFACE
948
951INTERFACE
952 FUNCTION l4f_category_get_c(a_name) bind(C,name='log4c_category_get')
953 IMPORT
954 CHARACTER(kind=c_char),INTENT(in) :: a_name(*)
955 TYPE(l4f_handle) :: l4f_category_get_c
956 END FUNCTION l4f_category_get_c
957END INTERFACE
958
959!! Delete a logging category. It can receive a C pointer or a
960!! legacy integer value.
961INTERFACE l4f_category_delete
962! SUBROUTINE l4f_category_delete_c(a_category) BIND(C,name='log4c_category_delete')
963! IMPORT
964! TYPE(l4f_handle),VALUE :: a_category !< category as C native pointer
965! END SUBROUTINE l4f_category_delete_c
966 MODULE PROCEDURE l4f_category_delete_legacy, l4f_category_delete_f
967END INTERFACE
968! this function has been disabled because aftere deleting a category
969! the following log4c_fini fails with a double free, we must
970! understand the log4c docs
971
972INTERFACE
973 SUBROUTINE l4f_category_log_c(a_category, a_priority, a_format) bind(C,name='log4c_category_log_c')
974 IMPORT
975 TYPE(l4f_handle),VALUE :: a_category
976 INTEGER(kind=c_int),VALUE :: a_priority
977! TYPE(c_ptr),VALUE :: locinfo !< not used
978 CHARACTER(kind=c_char),INTENT(in) :: a_format(*)
979 ! TYPE(c_ptr),VALUE :: a_args
980 END SUBROUTINE l4f_category_log_c
981END INTERFACE
982
985INTERFACE l4f_category_log
986 MODULE PROCEDURE l4f_category_log_f, l4f_category_log_legacy
987END INTERFACE l4f_category_log
988
990INTERFACE l4f_category_exist
991 MODULE PROCEDURE l4f_category_exist_f, l4f_category_exist_legacy
992END INTERFACE l4f_category_exist
993
995INTERFACE
996 FUNCTION l4f_fini() bind(C,name='log4c_fini')
997 IMPORT
998 INTEGER(kind=c_int) :: l4f_fini
999 END FUNCTION l4f_fini
1000END INTERFACE
1001
1003!interface
1004!CHARACTER(len=12) FUNCTION l4f_msg(a_priority)
1005!integer,intent(in):: a_priority !< category name
1006!end function l4f_msg
1007!end interface
1008
1009#else
1010
1011CHARACTER(len=510),PRIVATE:: dummy_a_name
1012
1013#endif
1014
1015PRIVATE
1016PUBLIC l4f_fatal, l4f_alert, l4f_crit, l4f_error, l4f_warn, l4f_notice, &
1017 l4f_info, l4f_debug, l4f_trace, l4f_notset, l4f_unknown
1018PUBLIC l4f_init, l4f_category_get, l4f_category_delete, l4f_category_log, &
1020PUBLIC l4f_launcher
1021
1022CONTAINS
1023
1028SUBROUTINE l4f_launcher(a_name, a_name_force, a_name_append)
1029CHARACTER(len=*),INTENT(out) :: a_name
1030CHARACTER(len=*),INTENT(in),OPTIONAL :: a_name_force
1031CHARACTER(len=*),INTENT(in),OPTIONAL :: a_name_append
1032
1033INTEGER :: tarray(8)
1034CHARACTER(len=255) :: LOG4_APPLICATION_NAME,LOG4_APPLICATION_ID,arg
1035CHARACTER(len=255),SAVE :: a_name_save=""
1036
1037IF (PRESENT(a_name_force))THEN
1038 a_name=a_name_force
1039ELSE IF (a_name_save /= "")THEN
1040 a_name=a_name_save
1041ELSE
1042
1043 CALL date_and_time(values=tarray)
1044 CALL getarg(0, arg)
1045 CALL getenv("LOG4_APPLICATION_NAME", log4_application_name)
1046 CALL getenv("LOG4_APPLICATION_ID", log4_application_id)
1047
1048 IF (log4_application_name == "" .AND. log4_application_id == "") THEN
1049 WRITE(a_name,"(a,a,8i5,a)")trim(arg),"[",tarray,"]"
1050 ELSE
1051 a_name = trim(log4_application_name)//"["//trim(log4_application_id)//"]"
1052 END IF
1053
1054END IF
1055
1056a_name_save=a_name
1057
1058IF (PRESENT(a_name_append)) THEN
1059 a_name=trim(a_name)//"."//trim(a_name_append)
1060END IF
1061
1062END SUBROUTINE l4f_launcher
1063
1064#ifndef HAVE_LIBLOG4C
1065! definisce delle dummy routine
1066
1068integer function l4f_init()
1069
1070character(len=10)::priority
1071integer :: iostat
1072
1073call getenv("LOG4C_PRIORITY",priority)
1074if (priority=="") then
1075 l4f_priority = l4f_notice
1076else
1077 read(priority,*,iostat=iostat)l4f_priority
1078end if
1079
1080if (iostat /= 0) then
1081 l4f_priority = l4f_notice
1082end if
1083
1084l4f_init = 0
1085
1086end function l4f_init
1087
1088
1090integer function l4f_category_get (a_name)
1091character (len=*),intent(in) :: a_name
1092
1093dummy_a_name = a_name
1094l4f_category_get = 1
1095
1096end function l4f_category_get
1097
1098
1100subroutine l4f_category_delete(a_category)
1101integer,intent(in):: a_category
1102
1103if (a_category == 1) dummy_a_name = ""
1104
1105end subroutine l4f_category_delete
1106
1107
1109subroutine l4f_category_log (a_category,a_priority,a_format)
1110integer,intent(in):: a_category
1111integer,intent(in):: a_priority
1112character(len=*),intent(in):: a_format
1113
1114if (a_category == 1 .and. a_priority <= l4f_priority) then
1115 write(*,*)"[dummy] ",l4f_msg(a_priority),trim(dummy_a_name)," - ",trim(a_format)
1116end if
1117
1118end subroutine l4f_category_log
1119
1120
1122subroutine l4f_log (a_priority,a_format)
1123integer,intent(in):: a_priority
1124character(len=*),intent(in):: a_format
1125
1126if ( a_priority <= l4f_priority) then
1127 write(*,*)"[_default] ",l4f_msg(a_priority),trim(dummy_a_name)," - ",trim(a_format)
1128end if
1129
1130end subroutine l4f_log
1131
1132
1134logical function l4f_category_exist (a_category)
1135integer,intent(in):: a_category
1136
1137if (a_category == 1) then
1138 l4f_category_exist= .true.
1139else
1140 l4f_category_exist= .false.
1141end if
1142
1143end function l4f_category_exist
1144
1145
1147integer function l4f_fini()
1148
1149l4f_fini= 0
1150
1151end function l4f_fini
1152
1154character(len=12) function l4f_msg(a_priority)
1155
1156integer,intent(in):: a_priority
1157
1158write(l4f_msg,*)a_priority
1159
1160if (a_priority == l4f_fatal) l4f_msg="FATAL"
1161if (a_priority == l4f_alert) l4f_msg="ALERT"
1162if (a_priority == l4f_crit) l4f_msg="CRIT"
1163if (a_priority == l4f_error) l4f_msg="ERROR"
1164if (a_priority == l4f_warn) l4f_msg="WARN"
1165if (a_priority == l4f_notice) l4f_msg="NOTICE"
1166if (a_priority == l4f_info) l4f_msg="INFO"
1167if (a_priority == l4f_debug) l4f_msg="DEBUG"
1168if (a_priority == l4f_trace) l4f_msg="TRACE"
1169if (a_priority == l4f_notset) l4f_msg="NOTSET"
1170if (a_priority == l4f_unknown) l4f_msg="UNKNOWN"
1171
1172end function l4f_msg
1173
1174#else
1175
1176#include "arrayof_post_nodoc.F90"
1177
1181FUNCTION l4f_category_get(a_name) RESULT(handle)
1182CHARACTER(kind=c_char,len=*),INTENT(in) :: a_name
1183INTEGER :: handle
1184
1185INTEGER :: i
1186
1187DO i = 1, l4f_global_ptr%arraysize ! look first for a hole
1188 IF (.NOT.l4f_category_exist(l4f_global_ptr%array(i))) THEN
1189 l4f_global_ptr%array(i) = l4f_category_get_c(trim(a_name)//char(0))
1190 handle = i
1191 RETURN
1192 ENDIF
1193ENDDO
1194
1195handle = append(l4f_global_ptr, l4f_category_get_c(trim(a_name)//char(0)))
1196
1197END FUNCTION l4f_category_get
1198
1199
1203FUNCTION l4f_category_get_handle(a_name) RESULT(handle)
1204CHARACTER(kind=c_char,len=*),INTENT(in) :: a_name
1205TYPE(l4f_handle) :: handle
1206
1207handle = l4f_category_get_c(trim(a_name)//char(0))
1208
1209END FUNCTION l4f_category_get_handle
1210
1211
1213SUBROUTINE l4f_category_delete_legacy(a_category)
1214INTEGER,INTENT(in) :: a_category
1215
1216IF (a_category <= 0 .OR. a_category > l4f_global_ptr%arraysize) RETURN
1217IF (a_category == l4f_global_ptr%arraysize) THEN
1218 CALL remove(l4f_global_ptr, pos=a_category)
1219ELSE
1220 l4f_global_ptr%array(a_category)%ptr = c_null_ptr
1221ENDIF
1222
1223END SUBROUTINE l4f_category_delete_legacy
1224
1225
1227SUBROUTINE l4f_category_delete_f(a_category)
1228TYPE(l4f_handle),INTENT(inout) :: a_category
1229
1230a_category%ptr = c_null_ptr ! is it necessary?
1231
1232END SUBROUTINE l4f_category_delete_f
1233
1234
1237SUBROUTINE l4f_category_log_f(a_category, a_priority, a_format)
1238TYPE(l4f_handle),INTENT(in) :: a_category
1239INTEGER(kind=c_int),INTENT(in) :: a_priority
1240CHARACTER(len=*),INTENT(in) :: a_format
1241
1242CALL l4f_category_log_c(a_category, a_priority, trim(a_format)//char(0))
1243
1244END SUBROUTINE l4f_category_log_f
1245
1246
1250SUBROUTINE l4f_category_log_legacy(a_category, a_priority, a_format)
1251INTEGER(kind=c_int),INTENT(in) :: a_category
1252INTEGER(kind=c_int),INTENT(in) :: a_priority
1253CHARACTER(len=*),INTENT(in) :: a_format
1254
1255CALL l4f_category_log_c(l4f_global_ptr%array(a_category), a_priority, trim(a_format)//char(0))
1256
1257END SUBROUTINE l4f_category_log_legacy
1258
1259
1262SUBROUTINE l4f_log(a_priority, a_format)
1263INTEGER(kind=c_int),INTENT(in) :: a_priority
1264CHARACTER(len=*),INTENT(in) :: a_format
1265
1266INTEGER :: i
1267
1268IF (.NOT.l4f_category_exist(l4f_global_default)) THEN
1269 i = l4f_init()
1270 l4f_global_default = l4f_category_get_handle('_default')
1271ENDIF
1272CALL l4f_category_log(l4f_global_default, a_priority, a_format)
1273
1274END SUBROUTINE l4f_log
1275
1276
1279FUNCTION l4f_category_exist_f(a_category) RESULT(exist)
1280TYPE(l4f_handle),INTENT(in) :: a_category
1281LOGICAL :: exist
1282
1283exist = c_associated(a_category%ptr)
1284
1285END FUNCTION l4f_category_exist_f
1286
1291FUNCTION l4f_category_exist_legacy(a_category) RESULT(exist)
1292INTEGER,INTENT(in):: a_category
1293LOGICAL :: exist
1294
1295IF (a_category <= 0 .OR. a_category > l4f_global_ptr%arraysize) THEN
1296 exist = .false.
1297ELSE
1298 exist = l4f_category_exist(l4f_global_ptr%array(a_category))
1299ENDIF
1300
1301END FUNCTION l4f_category_exist_legacy
1302
1303
1304#endif
1305
1306end 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.