libsim Versione 7.1.11

◆ l4f_category_exist_f()

logical function l4f_category_exist_f ( type(l4f_handle), intent(in)  a_category)
private

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

Parametri
[in]a_categorycategory

Definizione alla linea 867 del file log4fortran.F90.

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