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