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