libsim Versione 7.1.11

◆ l4f_category_exist_legacy()

logical function l4f_category_exist_legacy ( integer, intent(in)  a_category)

Return true if the corresponding category handle exists (is associated with a category).

Legacy Fortran version that receives an integer instead of a C pointer.

Parametri
[in]a_categorycategory

Definizione alla linea 879 del file log4fortran.F90.

880! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
881! authors:
882! Davide Cesari <dcesari@arpa.emr.it>
883! Paolo Patruno <ppatruno@arpa.emr.it>
884
885! This program is free software; you can redistribute it and/or
886! modify it under the terms of the GNU General Public License as
887! published by the Free Software Foundation; either version 2 of
888! the License, or (at your option) any later version.
889
890! This program is distributed in the hope that it will be useful,
891! but WITHOUT ANY WARRANTY; without even the implied warranty of
892! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
893! GNU General Public License for more details.
894
895! You should have received a copy of the GNU General Public License
896! along with this program. If not, see <http://www.gnu.org/licenses/>.
897#include "config.h"
898
902
992MODULE log4fortran
993USE iso_c_binding
994IMPLICIT NONE
995
996INTEGER(kind=c_int),PARAMETER :: L4F_FATAL = 000
997INTEGER(kind=c_int),PARAMETER :: L4F_ALERT = 100
998INTEGER(kind=c_int),PARAMETER :: L4F_CRIT = 200
999INTEGER(kind=c_int),PARAMETER :: L4F_ERROR = 300
1000INTEGER(kind=c_int),PARAMETER :: L4F_WARN = 400
1001INTEGER(kind=c_int),PARAMETER :: L4F_NOTICE = 500
1002INTEGER(kind=c_int),PARAMETER :: L4F_INFO = 600
1003INTEGER(kind=c_int),PARAMETER :: L4F_DEBUG = 700
1004INTEGER(kind=c_int),PARAMETER :: L4F_TRACE = 800
1005INTEGER(kind=c_int),PARAMETER :: L4F_NOTSET = 900
1006INTEGER(kind=c_int),PARAMETER :: L4F_UNKNOWN = 1000
1007
1011INTEGER(kind=c_int),PUBLIC :: l4f_priority=l4f_notice
1012
1016TYPE,BIND(C) :: l4f_handle
1017 PRIVATE
1018 TYPE(c_ptr) :: ptr = c_null_ptr
1019END TYPE l4f_handle
1020
1021#ifdef HAVE_LIBLOG4C
1022
1023TYPE(l4f_handle),SAVE :: l4f_global_default
1024
1025! emulation of old cnf behavior returning integer instead of pointer
1026#undef ARRAYOF_ORIGEQ
1027#undef ARRAYOF_ORIGTYPE
1028#undef ARRAYOF_TYPE
1029#define ARRAYOF_ORIGTYPE TYPE(l4f_handle)
1030#define ARRAYOF_TYPE arrayof_l4f_handle
1031#include "arrayof_pre_nodoc.F90"
1032
1033TYPE(arrayof_l4f_handle) :: l4f_global_ptr
1034
1036INTERFACE
1037 FUNCTION l4f_init() bind(C,name='log4c_init')
1038 IMPORT
1039 INTEGER(kind=c_int) :: l4f_init
1040 END FUNCTION l4f_init
1041END INTERFACE
1042
1045INTERFACE
1046 FUNCTION l4f_category_get_c(a_name) bind(C,name='log4c_category_get')
1047 IMPORT
1048 CHARACTER(kind=c_char),INTENT(in) :: a_name(*)
1049 TYPE(l4f_handle) :: l4f_category_get_c
1050 END FUNCTION l4f_category_get_c
1051END INTERFACE
1052
1053!! Delete a logging category. It can receive a C pointer or a
1054!! legacy integer value.
1055INTERFACE l4f_category_delete
1056! SUBROUTINE l4f_category_delete_c(a_category) BIND(C,name='log4c_category_delete')
1057! IMPORT
1058! TYPE(l4f_handle),VALUE :: a_category !< category as C native pointer
1059! END SUBROUTINE l4f_category_delete_c
1060 MODULE PROCEDURE l4f_category_delete_legacy, l4f_category_delete_f
1061END INTERFACE
1062! this function has been disabled because aftere deleting a category
1063! the following log4c_fini fails with a double free, we must
1064! understand the log4c docs
1065
1066INTERFACE
1067 SUBROUTINE l4f_category_log_c(a_category, a_priority, a_format) bind(C,name='log4c_category_log_c')
1068 IMPORT
1069 TYPE(l4f_handle),VALUE :: a_category
1070 INTEGER(kind=c_int),VALUE :: a_priority
1071! TYPE(c_ptr),VALUE :: locinfo !< not used
1072 CHARACTER(kind=c_char),INTENT(in) :: a_format(*)
1073 ! TYPE(c_ptr),VALUE :: a_args
1074 END SUBROUTINE l4f_category_log_c
1075END INTERFACE
1076
1079INTERFACE l4f_category_log
1080 MODULE PROCEDURE l4f_category_log_f, l4f_category_log_legacy
1081END INTERFACE l4f_category_log
1082
1084INTERFACE l4f_category_exist
1085 MODULE PROCEDURE l4f_category_exist_f, l4f_category_exist_legacy
1086END INTERFACE l4f_category_exist
1087
1089INTERFACE
1090 FUNCTION l4f_fini() bind(C,name='log4c_fini')
1091 IMPORT
1092 INTEGER(kind=c_int) :: l4f_fini
1093 END FUNCTION l4f_fini
1094END INTERFACE
1095
1097!interface
1098!CHARACTER(len=12) FUNCTION l4f_msg(a_priority)
1099!integer,intent(in):: a_priority !< category name
1100!end function l4f_msg
1101!end interface
1102
1103#else
1104
1105CHARACTER(len=510),PRIVATE:: dummy_a_name
1106
1107#endif
1108
1109PRIVATE
1110PUBLIC l4f_fatal, l4f_alert, l4f_crit, l4f_error, l4f_warn, l4f_notice, &
1111 l4f_info, l4f_debug, l4f_trace, l4f_notset, l4f_unknown
1112PUBLIC l4f_init, l4f_category_get, l4f_category_delete, l4f_category_log, &
1114PUBLIC l4f_launcher
1115
1116CONTAINS
1117
1122SUBROUTINE l4f_launcher(a_name, a_name_force, a_name_append)
1123CHARACTER(len=*),INTENT(out) :: a_name
1124CHARACTER(len=*),INTENT(in),OPTIONAL :: a_name_force
1125CHARACTER(len=*),INTENT(in),OPTIONAL :: a_name_append
1126
1127INTEGER :: tarray(8)
1128CHARACTER(len=255) :: LOG4_APPLICATION_NAME,LOG4_APPLICATION_ID,arg
1129CHARACTER(len=255),SAVE :: a_name_save=""
1130
1131IF (PRESENT(a_name_force))THEN
1132 a_name=a_name_force
1133ELSE IF (a_name_save /= "")THEN
1134 a_name=a_name_save
1135ELSE
1136
1137 CALL date_and_time(values=tarray)
1138 CALL getarg(0, arg)
1139 CALL getenv("LOG4_APPLICATION_NAME", log4_application_name)
1140 CALL getenv("LOG4_APPLICATION_ID", log4_application_id)
1141
1142 IF (log4_application_name == "" .AND. log4_application_id == "") THEN
1143 WRITE(a_name,"(a,a,8i5,a)")trim(arg),"[",tarray,"]"
1144 ELSE
1145 a_name = trim(log4_application_name)//"["//trim(log4_application_id)//"]"
1146 END IF
1147
1148END IF
1149
1150a_name_save=a_name
1151
1152IF (PRESENT(a_name_append)) THEN
1153 a_name=trim(a_name)//"."//trim(a_name_append)
1154END IF
1155
1156END SUBROUTINE l4f_launcher
1157
1158#ifndef HAVE_LIBLOG4C
1159! definisce delle dummy routine
1160
1162integer function l4f_init()
1163
1164character(len=10)::priority
1165integer :: iostat
1166
1167call getenv("LOG4C_PRIORITY",priority)
1168if (priority=="") then
1169 l4f_priority = l4f_notice
1170else
1171 read(priority,*,iostat=iostat)l4f_priority
1172end if
1173
1174if (iostat /= 0) then
1175 l4f_priority = l4f_notice
1176end if
1177
1178l4f_init = 0
1179
1180end function l4f_init
1181
1182
1184integer function l4f_category_get (a_name)
1185character (len=*),intent(in) :: a_name
1186
1187dummy_a_name = a_name
1188l4f_category_get = 1
1189
1190end function l4f_category_get
1191
1192
1194subroutine l4f_category_delete(a_category)
1195integer,intent(in):: a_category
1196
1197if (a_category == 1) dummy_a_name = ""
1198
1199end subroutine l4f_category_delete
1200
1201
1203subroutine l4f_category_log (a_category,a_priority,a_format)
1204integer,intent(in):: a_category
1205integer,intent(in):: a_priority
1206character(len=*),intent(in):: a_format
1207
1208if (a_category == 1 .and. a_priority <= l4f_priority) then
1209 write(*,*)"[dummy] ",l4f_msg(a_priority),trim(dummy_a_name)," - ",trim(a_format)
1210end if
1211
1212end subroutine l4f_category_log
1213
1214
1216subroutine l4f_log (a_priority,a_format)
1217integer,intent(in):: a_priority
1218character(len=*),intent(in):: a_format
1219
1220if ( a_priority <= l4f_priority) then
1221 write(*,*)"[_default] ",l4f_msg(a_priority),trim(dummy_a_name)," - ",trim(a_format)
1222end if
1223
1224end subroutine l4f_log
1225
1226
1228logical function l4f_category_exist (a_category)
1229integer,intent(in):: a_category
1230
1231if (a_category == 1) then
1232 l4f_category_exist= .true.
1233else
1234 l4f_category_exist= .false.
1235end if
1236
1237end function l4f_category_exist
1238
1239
1241integer function l4f_fini()
1242
1243l4f_fini= 0
1244
1245end function l4f_fini
1246
1248character(len=12) function l4f_msg(a_priority)
1249
1250integer,intent(in):: a_priority
1251
1252write(l4f_msg,*)a_priority
1253
1254if (a_priority == l4f_fatal) l4f_msg="FATAL"
1255if (a_priority == l4f_alert) l4f_msg="ALERT"
1256if (a_priority == l4f_crit) l4f_msg="CRIT"
1257if (a_priority == l4f_error) l4f_msg="ERROR"
1258if (a_priority == l4f_warn) l4f_msg="WARN"
1259if (a_priority == l4f_notice) l4f_msg="NOTICE"
1260if (a_priority == l4f_info) l4f_msg="INFO"
1261if (a_priority == l4f_debug) l4f_msg="DEBUG"
1262if (a_priority == l4f_trace) l4f_msg="TRACE"
1263if (a_priority == l4f_notset) l4f_msg="NOTSET"
1264if (a_priority == l4f_unknown) l4f_msg="UNKNOWN"
1265
1266end function l4f_msg
1267
1268#else
1269
1270#include "arrayof_post_nodoc.F90"
1271
1275FUNCTION l4f_category_get(a_name) RESULT(handle)
1276CHARACTER(kind=c_char,len=*),INTENT(in) :: a_name
1277INTEGER :: handle
1278
1279INTEGER :: i
1280
1281DO i = 1, l4f_global_ptr%arraysize ! look first for a hole
1282 IF (.NOT.l4f_category_exist(l4f_global_ptr%array(i))) THEN
1283 l4f_global_ptr%array(i) = l4f_category_get_c(trim(a_name)//char(0))
1284 handle = i
1285 RETURN
1286 ENDIF
1287ENDDO
1288
1289handle = append(l4f_global_ptr, l4f_category_get_c(trim(a_name)//char(0)))
1290
1291END FUNCTION l4f_category_get
1292
1293
1297FUNCTION l4f_category_get_handle(a_name) RESULT(handle)
1298CHARACTER(kind=c_char,len=*),INTENT(in) :: a_name
1299TYPE(l4f_handle) :: handle
1300
1301handle = l4f_category_get_c(trim(a_name)//char(0))
1302
1303END FUNCTION l4f_category_get_handle
1304
1305
1307SUBROUTINE l4f_category_delete_legacy(a_category)
1308INTEGER,INTENT(in) :: a_category
1309
1310IF (a_category <= 0 .OR. a_category > l4f_global_ptr%arraysize) RETURN
1311IF (a_category == l4f_global_ptr%arraysize) THEN
1312 CALL remove(l4f_global_ptr, pos=a_category)
1313ELSE
1314 l4f_global_ptr%array(a_category)%ptr = c_null_ptr
1315ENDIF
1316
1317END SUBROUTINE l4f_category_delete_legacy
1318
1319
1321SUBROUTINE l4f_category_delete_f(a_category)
1322TYPE(l4f_handle),INTENT(inout) :: a_category
1323
1324a_category%ptr = c_null_ptr ! is it necessary?
1325
1326END SUBROUTINE l4f_category_delete_f
1327
1328
1331SUBROUTINE l4f_category_log_f(a_category, a_priority, a_format)
1332TYPE(l4f_handle),INTENT(in) :: a_category
1333INTEGER(kind=c_int),INTENT(in) :: a_priority
1334CHARACTER(len=*),INTENT(in) :: a_format
1335
1336CALL l4f_category_log_c(a_category, a_priority, trim(a_format)//char(0))
1337
1338END SUBROUTINE l4f_category_log_f
1339
1340
1344SUBROUTINE l4f_category_log_legacy(a_category, a_priority, a_format)
1345INTEGER(kind=c_int),INTENT(in) :: a_category
1346INTEGER(kind=c_int),INTENT(in) :: a_priority
1347CHARACTER(len=*),INTENT(in) :: a_format
1348
1349CALL l4f_category_log_c(l4f_global_ptr%array(a_category), a_priority, trim(a_format)//char(0))
1350
1351END SUBROUTINE l4f_category_log_legacy
1352
1353
1356SUBROUTINE l4f_log(a_priority, a_format)
1357INTEGER(kind=c_int),INTENT(in) :: a_priority
1358CHARACTER(len=*),INTENT(in) :: a_format
1359
1360INTEGER :: i
1361
1362IF (.NOT.l4f_category_exist(l4f_global_default)) THEN
1363 i = l4f_init()
1364 l4f_global_default = l4f_category_get_handle('_default')
1365ENDIF
1366CALL l4f_category_log(l4f_global_default, a_priority, a_format)
1367
1368END SUBROUTINE l4f_log
1369
1370
1373FUNCTION l4f_category_exist_f(a_category) RESULT(exist)
1374TYPE(l4f_handle),INTENT(in) :: a_category
1375LOGICAL :: exist
1376
1377exist = c_associated(a_category%ptr)
1378
1379END FUNCTION l4f_category_exist_f
1380
1385FUNCTION l4f_category_exist_legacy(a_category) RESULT(exist)
1386INTEGER,INTENT(in):: a_category
1387LOGICAL :: exist
1388
1389IF (a_category <= 0 .OR. a_category > l4f_global_ptr%arraysize) THEN
1390 exist = .false.
1391ELSE
1392 exist = l4f_category_exist(l4f_global_ptr%array(a_category))
1393ENDIF
1394
1395END FUNCTION l4f_category_exist_legacy
1396
1397
1398#endif
1399
1400end 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.