libsim Versione 7.1.11

◆ l4f_category_log_legacy()

subroutine l4f_category_log_legacy ( integer(kind=c_int), intent(in)  a_category,
integer(kind=c_int), intent(in)  a_priority,
character(len=*), intent(in)  a_format 
)
private

Emit log message for a category with specific priority.

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

Parametri
[in]a_categorycategory
[in]a_prioritypriority level
[in]a_formatmessage to emit

Definizione alla linea 838 del file log4fortran.F90.

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