libsim Versione 7.2.1

◆ 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 
)

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 832 del file log4fortran.F90.

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