libsim Versione 7.1.11

◆ 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 801 del file log4fortran.F90.

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