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