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