libsim Versione 7.2.4

◆ l4f_category_delete_f()

subroutine l4f_category_delete_f ( type(l4f_handle), intent(inout) a_category)
private

Delete a logging category.

No-op version with a typed handle.

Parametri
[in,out]a_categorycategory as C native pointer

Definizione alla linea 809 del file log4fortran.F90.

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