libsim Versione 7.2.4

◆ l4f_category_delete_legacy()

subroutine l4f_category_delete_legacy ( integer, intent(in) a_category)
private

Delete a logging category.

Legacy version with an integer argument.

Parametri
[in]a_categorycategory as an integer

Definizione alla linea 795 del file log4fortran.F90.

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