libsim Versione 7.2.1
|
◆ l4f_category_get()
Initialize a logging category. This is the Fortran legacy version that receives a Fortran character argument and returns an integer.
Definizione alla linea 763 del file log4fortran.F90. 764! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
765! authors:
766! Davide Cesari <dcesari@arpa.emr.it>
767! Paolo Patruno <ppatruno@arpa.emr.it>
768
769! This program is free software; you can redistribute it and/or
770! modify it under the terms of the GNU General Public License as
771! published by the Free Software Foundation; either version 2 of
772! the License, or (at your option) any later version.
773
774! This program is distributed in the hope that it will be useful,
775! but WITHOUT ANY WARRANTY; without even the implied warranty of
776! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
777! GNU General Public License for more details.
778
779! You should have received a copy of the GNU General Public License
780! along with this program. If not, see <http://www.gnu.org/licenses/>.
781#include "config.h"
782
786
877USE iso_c_binding
878IMPLICIT NONE
879
880INTEGER(kind=c_int),PARAMETER :: L4F_FATAL = 000
881INTEGER(kind=c_int),PARAMETER :: L4F_ALERT = 100
882INTEGER(kind=c_int),PARAMETER :: L4F_CRIT = 200
883INTEGER(kind=c_int),PARAMETER :: L4F_ERROR = 300
884INTEGER(kind=c_int),PARAMETER :: L4F_WARN = 400
885INTEGER(kind=c_int),PARAMETER :: L4F_NOTICE = 500
886INTEGER(kind=c_int),PARAMETER :: L4F_INFO = 600
887INTEGER(kind=c_int),PARAMETER :: L4F_DEBUG = 700
888INTEGER(kind=c_int),PARAMETER :: L4F_TRACE = 800
889INTEGER(kind=c_int),PARAMETER :: L4F_NOTSET = 900
890INTEGER(kind=c_int),PARAMETER :: L4F_UNKNOWN = 1000
891
895INTEGER(kind=c_int),PUBLIC :: l4f_priority=l4f_notice
896
900TYPE,BIND(C) :: l4f_handle
901 PRIVATE
902 TYPE(c_ptr) :: ptr = c_null_ptr
904
905#ifdef HAVE_LIBLOG4C
906
907TYPE(l4f_handle),SAVE :: l4f_global_default
908
909! emulation of old cnf behavior returning integer instead of pointer
910#undef ARRAYOF_ORIGEQ
911#undef ARRAYOF_ORIGTYPE
912#undef ARRAYOF_TYPE
913#define ARRAYOF_ORIGTYPE TYPE(l4f_handle)
914#define ARRAYOF_TYPE arrayof_l4f_handle
915#include "arrayof_pre_nodoc.F90"
916
917TYPE(arrayof_l4f_handle) :: l4f_global_ptr
918
920INTERFACE
922 IMPORT
923 INTEGER(kind=c_int) :: l4f_init
925END INTERFACE
926
929INTERFACE
931 IMPORT
932 CHARACTER(kind=c_char),INTENT(in) :: a_name(*)
933 TYPE(l4f_handle) :: l4f_category_get_c
935END INTERFACE
936
937!! Delete a logging category. It can receive a C pointer or a
938!! legacy integer value.
939INTERFACE l4f_category_delete
940! SUBROUTINE l4f_category_delete_c(a_category) BIND(C,name='log4c_category_delete')
941! IMPORT
942! TYPE(l4f_handle),VALUE :: a_category !< category as C native pointer
943! END SUBROUTINE l4f_category_delete_c
944 MODULE PROCEDURE l4f_category_delete_legacy, l4f_category_delete_f
945END INTERFACE
946! this function has been disabled because aftere deleting a category
947! the following log4c_fini fails with a double free, we must
948! understand the log4c docs
949
950INTERFACE
951 SUBROUTINE l4f_category_log_c(a_category, a_priority, a_format) bind(C,name='log4c_category_log_c')
952 IMPORT
953 TYPE(l4f_handle),VALUE :: a_category
954 INTEGER(kind=c_int),VALUE :: a_priority
955! TYPE(c_ptr),VALUE :: locinfo !< not used
956 CHARACTER(kind=c_char),INTENT(in) :: a_format(*)
957 ! TYPE(c_ptr),VALUE :: a_args
958 END SUBROUTINE l4f_category_log_c
959END INTERFACE
960
964 MODULE PROCEDURE l4f_category_log_f, l4f_category_log_legacy
966
969 MODULE PROCEDURE l4f_category_exist_f, l4f_category_exist_legacy
971
973INTERFACE
975 IMPORT
976 INTEGER(kind=c_int) :: l4f_fini
978END INTERFACE
979
981!interface
982!CHARACTER(len=12) FUNCTION l4f_msg(a_priority)
983!integer,intent(in):: a_priority !< category name
984!end function l4f_msg
985!end interface
986
987#else
988
989CHARACTER(len=510),PRIVATE:: dummy_a_name
990
991#endif
992
993PRIVATE
994PUBLIC l4f_fatal, l4f_alert, l4f_crit, l4f_error, l4f_warn, l4f_notice, &
995 l4f_info, l4f_debug, l4f_trace, l4f_notset, l4f_unknown
998PUBLIC l4f_launcher
999
1000CONTAINS
1001
1006SUBROUTINE l4f_launcher(a_name, a_name_force, a_name_append)
1007CHARACTER(len=*),INTENT(out) :: a_name
1008CHARACTER(len=*),INTENT(in),OPTIONAL :: a_name_force
1009CHARACTER(len=*),INTENT(in),OPTIONAL :: a_name_append
1010
1011INTEGER :: tarray(8)
1012CHARACTER(len=255) :: LOG4_APPLICATION_NAME,LOG4_APPLICATION_ID,arg
1013CHARACTER(len=255),SAVE :: a_name_save=""
1014
1015IF (PRESENT(a_name_force))THEN
1016 a_name=a_name_force
1017ELSE IF (a_name_save /= "")THEN
1018 a_name=a_name_save
1019ELSE
1020
1021 CALL date_and_time(values=tarray)
1022 CALL getarg(0, arg)
1023 CALL getenv("LOG4_APPLICATION_NAME", log4_application_name)
1024 CALL getenv("LOG4_APPLICATION_ID", log4_application_id)
1025
1026 IF (log4_application_name == "" .AND. log4_application_id == "") THEN
1027 WRITE(a_name,"(a,a,8i5,a)")trim(arg),"[",tarray,"]"
1028 ELSE
1029 a_name = trim(log4_application_name)//"["//trim(log4_application_id)//"]"
1030 END IF
1031
1032END IF
1033
1034a_name_save=a_name
1035
1036IF (PRESENT(a_name_append)) THEN
1037 a_name=trim(a_name)//"."//trim(a_name_append)
1038END IF
1039
1040END SUBROUTINE l4f_launcher
1041
1042#ifndef HAVE_LIBLOG4C
1043! definisce delle dummy routine
1044
1047
1048character(len=10)::priority
1049integer :: iostat
1050
1051call getenv("LOG4C_PRIORITY",priority)
1052if (priority=="") then
1053 l4f_priority = l4f_notice
1054else
1055 read(priority,*,iostat=iostat)l4f_priority
1056end if
1057
1058if (iostat /= 0) then
1059 l4f_priority = l4f_notice
1060end if
1061
1062l4f_init = 0
1063
1065
1066
1068integer function l4f_category_get (a_name)
1069character (len=*),intent(in) :: a_name
1070
1071dummy_a_name = a_name
1072l4f_category_get = 1
1073
1074end function l4f_category_get
1075
1076
1078subroutine l4f_category_delete(a_category)
1079integer,intent(in):: a_category
1080
1081if (a_category == 1) dummy_a_name = ""
1082
1083end subroutine l4f_category_delete
1084
1085
1088integer,intent(in):: a_category
1089integer,intent(in):: a_priority
1090character(len=*),intent(in):: a_format
1091
1092if (a_category == 1 .and. a_priority <= l4f_priority) then
1093 write(*,*)"[dummy] ",l4f_msg(a_priority),trim(dummy_a_name)," - ",trim(a_format)
1094end if
1095
1097
1098
1100subroutine l4f_log (a_priority,a_format)
1101integer,intent(in):: a_priority
1102character(len=*),intent(in):: a_format
1103
1104if ( a_priority <= l4f_priority) then
1105 write(*,*)"[_default] ",l4f_msg(a_priority),trim(dummy_a_name)," - ",trim(a_format)
1106end if
1107
1108end subroutine l4f_log
1109
1110
1113integer,intent(in):: a_category
1114
1115if (a_category == 1) then
1116 l4f_category_exist= .true.
1117else
1118 l4f_category_exist= .false.
1119end if
1120
1122
1123
1126
1127l4f_fini= 0
1128
1130
1132character(len=12) function l4f_msg(a_priority)
1133
1134integer,intent(in):: a_priority
1135
1136write(l4f_msg,*)a_priority
1137
1138if (a_priority == l4f_fatal) l4f_msg="FATAL"
1139if (a_priority == l4f_alert) l4f_msg="ALERT"
1140if (a_priority == l4f_crit) l4f_msg="CRIT"
1141if (a_priority == l4f_error) l4f_msg="ERROR"
1142if (a_priority == l4f_warn) l4f_msg="WARN"
1143if (a_priority == l4f_notice) l4f_msg="NOTICE"
1144if (a_priority == l4f_info) l4f_msg="INFO"
1145if (a_priority == l4f_debug) l4f_msg="DEBUG"
1146if (a_priority == l4f_trace) l4f_msg="TRACE"
1147if (a_priority == l4f_notset) l4f_msg="NOTSET"
1148if (a_priority == l4f_unknown) l4f_msg="UNKNOWN"
1149
1150end function l4f_msg
1151
1152#else
1153
1154#include "arrayof_post_nodoc.F90"
1155
1159FUNCTION l4f_category_get(a_name) RESULT(handle)
1160CHARACTER(kind=c_char,len=*),INTENT(in) :: a_name
1161INTEGER :: handle
1162
1163INTEGER :: i
1164
1165DO i = 1, l4f_global_ptr%arraysize ! look first for a hole
1167 l4f_global_ptr%array(i) = l4f_category_get_c(trim(a_name)//char(0))
1168 handle = i
1169 RETURN
1170 ENDIF
1171ENDDO
1172
1173handle = append(l4f_global_ptr, l4f_category_get_c(trim(a_name)//char(0)))
1174
1175END FUNCTION l4f_category_get
1176
1177
1181FUNCTION l4f_category_get_handle(a_name) RESULT(handle)
1182CHARACTER(kind=c_char,len=*),INTENT(in) :: a_name
1183TYPE(l4f_handle) :: handle
1184
1185handle = l4f_category_get_c(trim(a_name)//char(0))
1186
1187END FUNCTION l4f_category_get_handle
1188
1189
1191SUBROUTINE l4f_category_delete_legacy(a_category)
1192INTEGER,INTENT(in) :: a_category
1193
1194IF (a_category <= 0 .OR. a_category > l4f_global_ptr%arraysize) RETURN
1195IF (a_category == l4f_global_ptr%arraysize) THEN
1196 CALL remove(l4f_global_ptr, pos=a_category)
1197ELSE
1198 l4f_global_ptr%array(a_category)%ptr = c_null_ptr
1199ENDIF
1200
1201END SUBROUTINE l4f_category_delete_legacy
1202
1203
1205SUBROUTINE l4f_category_delete_f(a_category)
1206TYPE(l4f_handle),INTENT(inout) :: a_category
1207
1208a_category%ptr = c_null_ptr ! is it necessary?
1209
1210END SUBROUTINE l4f_category_delete_f
1211
1212
1215SUBROUTINE l4f_category_log_f(a_category, a_priority, a_format)
1216TYPE(l4f_handle),INTENT(in) :: a_category
1217INTEGER(kind=c_int),INTENT(in) :: a_priority
1218CHARACTER(len=*),INTENT(in) :: a_format
1219
1220CALL l4f_category_log_c(a_category, a_priority, trim(a_format)//char(0))
1221
1222END SUBROUTINE l4f_category_log_f
1223
1224
1228SUBROUTINE l4f_category_log_legacy(a_category, a_priority, a_format)
1229INTEGER(kind=c_int),INTENT(in) :: a_category
1230INTEGER(kind=c_int),INTENT(in) :: a_priority
1231CHARACTER(len=*),INTENT(in) :: a_format
1232
1233CALL l4f_category_log_c(l4f_global_ptr%array(a_category), a_priority, trim(a_format)//char(0))
1234
1235END SUBROUTINE l4f_category_log_legacy
1236
1237
1240SUBROUTINE l4f_log(a_priority, a_format)
1241INTEGER(kind=c_int),INTENT(in) :: a_priority
1242CHARACTER(len=*),INTENT(in) :: a_format
1243
1244INTEGER :: i
1245
1247 i = l4f_init()
1248 l4f_global_default = l4f_category_get_handle('_default')
1249ENDIF
1251
1252END SUBROUTINE l4f_log
1253
1254
1257FUNCTION l4f_category_exist_f(a_category) RESULT(exist)
1258TYPE(l4f_handle),INTENT(in) :: a_category
1259LOGICAL :: exist
1260
1261exist = c_associated(a_category%ptr)
1262
1263END FUNCTION l4f_category_exist_f
1264
1269FUNCTION l4f_category_exist_legacy(a_category) RESULT(exist)
1270INTEGER,INTENT(in):: a_category
1271LOGICAL :: exist
1272
1273IF (a_category <= 0 .OR. a_category > l4f_global_ptr%arraysize) THEN
1274 exist = .false.
1275ELSE
1276 exist = l4f_category_exist(l4f_global_ptr%array(a_category))
1277ENDIF
1278
1279END FUNCTION l4f_category_exist_legacy
1280
1281
1282#endif
1283
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 |