libsim Versione 7.1.11
|
◆ l4f_category_get_handle()
Initialize a logging category. This is the Fortran version that receives a Fortran character argument and returns a typed handle.
Definizione alla linea 791 del file log4fortran.F90. 792! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
793! authors:
794! Davide Cesari <dcesari@arpa.emr.it>
795! Paolo Patruno <ppatruno@arpa.emr.it>
796
797! This program is free software; you can redistribute it and/or
798! modify it under the terms of the GNU General Public License as
799! published by the Free Software Foundation; either version 2 of
800! the License, or (at your option) any later version.
801
802! This program is distributed in the hope that it will be useful,
803! but WITHOUT ANY WARRANTY; without even the implied warranty of
804! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
805! GNU General Public License for more details.
806
807! You should have received a copy of the GNU General Public License
808! along with this program. If not, see <http://www.gnu.org/licenses/>.
809#include "config.h"
810
814
905USE iso_c_binding
906IMPLICIT NONE
907
908INTEGER(kind=c_int),PARAMETER :: L4F_FATAL = 000
909INTEGER(kind=c_int),PARAMETER :: L4F_ALERT = 100
910INTEGER(kind=c_int),PARAMETER :: L4F_CRIT = 200
911INTEGER(kind=c_int),PARAMETER :: L4F_ERROR = 300
912INTEGER(kind=c_int),PARAMETER :: L4F_WARN = 400
913INTEGER(kind=c_int),PARAMETER :: L4F_NOTICE = 500
914INTEGER(kind=c_int),PARAMETER :: L4F_INFO = 600
915INTEGER(kind=c_int),PARAMETER :: L4F_DEBUG = 700
916INTEGER(kind=c_int),PARAMETER :: L4F_TRACE = 800
917INTEGER(kind=c_int),PARAMETER :: L4F_NOTSET = 900
918INTEGER(kind=c_int),PARAMETER :: L4F_UNKNOWN = 1000
919
923INTEGER(kind=c_int),PUBLIC :: l4f_priority=l4f_notice
924
928TYPE,BIND(C) :: l4f_handle
929 PRIVATE
930 TYPE(c_ptr) :: ptr = c_null_ptr
932
933#ifdef HAVE_LIBLOG4C
934
935TYPE(l4f_handle),SAVE :: l4f_global_default
936
937! emulation of old cnf behavior returning integer instead of pointer
938#undef ARRAYOF_ORIGEQ
939#undef ARRAYOF_ORIGTYPE
940#undef ARRAYOF_TYPE
941#define ARRAYOF_ORIGTYPE TYPE(l4f_handle)
942#define ARRAYOF_TYPE arrayof_l4f_handle
943#include "arrayof_pre_nodoc.F90"
944
945TYPE(arrayof_l4f_handle) :: l4f_global_ptr
946
948INTERFACE
950 IMPORT
951 INTEGER(kind=c_int) :: l4f_init
953END INTERFACE
954
957INTERFACE
959 IMPORT
960 CHARACTER(kind=c_char),INTENT(in) :: a_name(*)
961 TYPE(l4f_handle) :: l4f_category_get_c
963END INTERFACE
964
965!! Delete a logging category. It can receive a C pointer or a
966!! legacy integer value.
967INTERFACE l4f_category_delete
968! SUBROUTINE l4f_category_delete_c(a_category) BIND(C,name='log4c_category_delete')
969! IMPORT
970! TYPE(l4f_handle),VALUE :: a_category !< category as C native pointer
971! END SUBROUTINE l4f_category_delete_c
972 MODULE PROCEDURE l4f_category_delete_legacy, l4f_category_delete_f
973END INTERFACE
974! this function has been disabled because aftere deleting a category
975! the following log4c_fini fails with a double free, we must
976! understand the log4c docs
977
978INTERFACE
979 SUBROUTINE l4f_category_log_c(a_category, a_priority, a_format) bind(C,name='log4c_category_log_c')
980 IMPORT
981 TYPE(l4f_handle),VALUE :: a_category
982 INTEGER(kind=c_int),VALUE :: a_priority
983! TYPE(c_ptr),VALUE :: locinfo !< not used
984 CHARACTER(kind=c_char),INTENT(in) :: a_format(*)
985 ! TYPE(c_ptr),VALUE :: a_args
986 END SUBROUTINE l4f_category_log_c
987END INTERFACE
988
992 MODULE PROCEDURE l4f_category_log_f, l4f_category_log_legacy
994
997 MODULE PROCEDURE l4f_category_exist_f, l4f_category_exist_legacy
999
1001INTERFACE
1003 IMPORT
1004 INTEGER(kind=c_int) :: l4f_fini
1006END INTERFACE
1007
1009!interface
1010!CHARACTER(len=12) FUNCTION l4f_msg(a_priority)
1011!integer,intent(in):: a_priority !< category name
1012!end function l4f_msg
1013!end interface
1014
1015#else
1016
1017CHARACTER(len=510),PRIVATE:: dummy_a_name
1018
1019#endif
1020
1021PRIVATE
1022PUBLIC l4f_fatal, l4f_alert, l4f_crit, l4f_error, l4f_warn, l4f_notice, &
1023 l4f_info, l4f_debug, l4f_trace, l4f_notset, l4f_unknown
1026PUBLIC l4f_launcher
1027
1028CONTAINS
1029
1034SUBROUTINE l4f_launcher(a_name, a_name_force, a_name_append)
1035CHARACTER(len=*),INTENT(out) :: a_name
1036CHARACTER(len=*),INTENT(in),OPTIONAL :: a_name_force
1037CHARACTER(len=*),INTENT(in),OPTIONAL :: a_name_append
1038
1039INTEGER :: tarray(8)
1040CHARACTER(len=255) :: LOG4_APPLICATION_NAME,LOG4_APPLICATION_ID,arg
1041CHARACTER(len=255),SAVE :: a_name_save=""
1042
1043IF (PRESENT(a_name_force))THEN
1044 a_name=a_name_force
1045ELSE IF (a_name_save /= "")THEN
1046 a_name=a_name_save
1047ELSE
1048
1049 CALL date_and_time(values=tarray)
1050 CALL getarg(0, arg)
1051 CALL getenv("LOG4_APPLICATION_NAME", log4_application_name)
1052 CALL getenv("LOG4_APPLICATION_ID", log4_application_id)
1053
1054 IF (log4_application_name == "" .AND. log4_application_id == "") THEN
1055 WRITE(a_name,"(a,a,8i5,a)")trim(arg),"[",tarray,"]"
1056 ELSE
1057 a_name = trim(log4_application_name)//"["//trim(log4_application_id)//"]"
1058 END IF
1059
1060END IF
1061
1062a_name_save=a_name
1063
1064IF (PRESENT(a_name_append)) THEN
1065 a_name=trim(a_name)//"."//trim(a_name_append)
1066END IF
1067
1068END SUBROUTINE l4f_launcher
1069
1070#ifndef HAVE_LIBLOG4C
1071! definisce delle dummy routine
1072
1075
1076character(len=10)::priority
1077integer :: iostat
1078
1079call getenv("LOG4C_PRIORITY",priority)
1080if (priority=="") then
1081 l4f_priority = l4f_notice
1082else
1083 read(priority,*,iostat=iostat)l4f_priority
1084end if
1085
1086if (iostat /= 0) then
1087 l4f_priority = l4f_notice
1088end if
1089
1090l4f_init = 0
1091
1093
1094
1096integer function l4f_category_get (a_name)
1097character (len=*),intent(in) :: a_name
1098
1099dummy_a_name = a_name
1100l4f_category_get = 1
1101
1102end function l4f_category_get
1103
1104
1106subroutine l4f_category_delete(a_category)
1107integer,intent(in):: a_category
1108
1109if (a_category == 1) dummy_a_name = ""
1110
1111end subroutine l4f_category_delete
1112
1113
1116integer,intent(in):: a_category
1117integer,intent(in):: a_priority
1118character(len=*),intent(in):: a_format
1119
1120if (a_category == 1 .and. a_priority <= l4f_priority) then
1121 write(*,*)"[dummy] ",l4f_msg(a_priority),trim(dummy_a_name)," - ",trim(a_format)
1122end if
1123
1125
1126
1128subroutine l4f_log (a_priority,a_format)
1129integer,intent(in):: a_priority
1130character(len=*),intent(in):: a_format
1131
1132if ( a_priority <= l4f_priority) then
1133 write(*,*)"[_default] ",l4f_msg(a_priority),trim(dummy_a_name)," - ",trim(a_format)
1134end if
1135
1136end subroutine l4f_log
1137
1138
1141integer,intent(in):: a_category
1142
1143if (a_category == 1) then
1144 l4f_category_exist= .true.
1145else
1146 l4f_category_exist= .false.
1147end if
1148
1150
1151
1154
1155l4f_fini= 0
1156
1158
1160character(len=12) function l4f_msg(a_priority)
1161
1162integer,intent(in):: a_priority
1163
1164write(l4f_msg,*)a_priority
1165
1166if (a_priority == l4f_fatal) l4f_msg="FATAL"
1167if (a_priority == l4f_alert) l4f_msg="ALERT"
1168if (a_priority == l4f_crit) l4f_msg="CRIT"
1169if (a_priority == l4f_error) l4f_msg="ERROR"
1170if (a_priority == l4f_warn) l4f_msg="WARN"
1171if (a_priority == l4f_notice) l4f_msg="NOTICE"
1172if (a_priority == l4f_info) l4f_msg="INFO"
1173if (a_priority == l4f_debug) l4f_msg="DEBUG"
1174if (a_priority == l4f_trace) l4f_msg="TRACE"
1175if (a_priority == l4f_notset) l4f_msg="NOTSET"
1176if (a_priority == l4f_unknown) l4f_msg="UNKNOWN"
1177
1178end function l4f_msg
1179
1180#else
1181
1182#include "arrayof_post_nodoc.F90"
1183
1187FUNCTION l4f_category_get(a_name) RESULT(handle)
1188CHARACTER(kind=c_char,len=*),INTENT(in) :: a_name
1189INTEGER :: handle
1190
1191INTEGER :: i
1192
1193DO i = 1, l4f_global_ptr%arraysize ! look first for a hole
1195 l4f_global_ptr%array(i) = l4f_category_get_c(trim(a_name)//char(0))
1196 handle = i
1197 RETURN
1198 ENDIF
1199ENDDO
1200
1201handle = append(l4f_global_ptr, l4f_category_get_c(trim(a_name)//char(0)))
1202
1203END FUNCTION l4f_category_get
1204
1205
1209FUNCTION l4f_category_get_handle(a_name) RESULT(handle)
1210CHARACTER(kind=c_char,len=*),INTENT(in) :: a_name
1211TYPE(l4f_handle) :: handle
1212
1213handle = l4f_category_get_c(trim(a_name)//char(0))
1214
1215END FUNCTION l4f_category_get_handle
1216
1217
1219SUBROUTINE l4f_category_delete_legacy(a_category)
1220INTEGER,INTENT(in) :: a_category
1221
1222IF (a_category <= 0 .OR. a_category > l4f_global_ptr%arraysize) RETURN
1223IF (a_category == l4f_global_ptr%arraysize) THEN
1224 CALL remove(l4f_global_ptr, pos=a_category)
1225ELSE
1226 l4f_global_ptr%array(a_category)%ptr = c_null_ptr
1227ENDIF
1228
1229END SUBROUTINE l4f_category_delete_legacy
1230
1231
1233SUBROUTINE l4f_category_delete_f(a_category)
1234TYPE(l4f_handle),INTENT(inout) :: a_category
1235
1236a_category%ptr = c_null_ptr ! is it necessary?
1237
1238END SUBROUTINE l4f_category_delete_f
1239
1240
1243SUBROUTINE l4f_category_log_f(a_category, a_priority, a_format)
1244TYPE(l4f_handle),INTENT(in) :: a_category
1245INTEGER(kind=c_int),INTENT(in) :: a_priority
1246CHARACTER(len=*),INTENT(in) :: a_format
1247
1248CALL l4f_category_log_c(a_category, a_priority, trim(a_format)//char(0))
1249
1250END SUBROUTINE l4f_category_log_f
1251
1252
1256SUBROUTINE l4f_category_log_legacy(a_category, a_priority, a_format)
1257INTEGER(kind=c_int),INTENT(in) :: a_category
1258INTEGER(kind=c_int),INTENT(in) :: a_priority
1259CHARACTER(len=*),INTENT(in) :: a_format
1260
1261CALL l4f_category_log_c(l4f_global_ptr%array(a_category), a_priority, trim(a_format)//char(0))
1262
1263END SUBROUTINE l4f_category_log_legacy
1264
1265
1268SUBROUTINE l4f_log(a_priority, a_format)
1269INTEGER(kind=c_int),INTENT(in) :: a_priority
1270CHARACTER(len=*),INTENT(in) :: a_format
1271
1272INTEGER :: i
1273
1275 i = l4f_init()
1276 l4f_global_default = l4f_category_get_handle('_default')
1277ENDIF
1279
1280END SUBROUTINE l4f_log
1281
1282
1285FUNCTION l4f_category_exist_f(a_category) RESULT(exist)
1286TYPE(l4f_handle),INTENT(in) :: a_category
1287LOGICAL :: exist
1288
1289exist = c_associated(a_category%ptr)
1290
1291END FUNCTION l4f_category_exist_f
1292
1297FUNCTION l4f_category_exist_legacy(a_category) RESULT(exist)
1298INTEGER,INTENT(in):: a_category
1299LOGICAL :: exist
1300
1301IF (a_category <= 0 .OR. a_category > l4f_global_ptr%arraysize) THEN
1302 exist = .false.
1303ELSE
1304 exist = l4f_category_exist(l4f_global_ptr%array(a_category))
1305ENDIF
1306
1307END FUNCTION l4f_category_exist_legacy
1308
1309
1310#endif
1311
Return true if the corresponding category handle exists. Definition: log4fortran.F90:468 Emit log message for a category with specific priority. Definition: log4fortran.F90:463 |