libsim Versione 7.1.11

◆ l4f_log()

subroutine, public l4f_log ( integer(kind=c_int), intent(in)  a_priority,
character(len=*), intent(in)  a_format 
)

Emit log message without category with specific priority.

Fortran version that receives a Fortran character argument.

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

Definizione alla linea 850 del file log4fortran.F90.

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