libsim Versione 7.1.11

◆ l4f_category_log_f()

subroutine l4f_category_log_f ( type(l4f_handle), 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.

Fortran version that receives a Fortran character argument.

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

Definizione alla linea 825 del file log4fortran.F90.

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