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