libsim Versione 7.2.0

◆ l4f_category_exist_f()

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

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

Parametri
[in]a_categorycategory

Definizione alla linea 861 del file log4fortran.F90.

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