@ -244,10 +244,9 @@ module IssuesCsv = struct
Io_infer . Xml . tag_key Io_infer . Xml . tag_qualifier_tags Io_infer . Xml . tag_hash " bug_id "
" always_report " " advice "
(* * Write bug report in csv format * )
let pp_issues_of_error_log fmt error_filter _ proc_loc_opt procname err_log =
let pp_issue fmt error_filter procname proc_loc_opt ( key : Errlog . err_key )
( err_data : Errlog . err_data ) =
let pp x = F . fprintf fmt x in
let pp_row ( key : Errlog . err_key ) ( err_data : Errlog . err_data ) =
let source_file =
match proc_loc_opt with
| Some proc_loc
@ -304,8 +303,10 @@ module IssuesCsv = struct
(* bug id *)
pp " \" %s \" , " always_report ;
pp " \" %s \" @ \n " err_advice_string
in
Errlog . iter pp_row err_log
(* * Write bug report in csv format *)
let pp_issues_of_error_log fmt error_filter _ proc_loc_opt procname err_log =
Errlog . iter ( pp_issue fmt error_filter procname proc_loc_opt ) err_log
end
let potential_exception_message = " potential exception at line "
@ -319,10 +320,9 @@ module IssuesJson = struct
let pp_json_close fmt () = F . fprintf fmt " ]@ \n @? "
(* * Write bug report in JSON format * )
let pp_issues_of_error_log fmt error_filter _ proc_loc_opt procname err_log =
let pp_issue fmt error_filter procname proc_loc_opt ( key : Errlog . err_key )
( err_data : Errlog . err_data ) =
let pp x = F . fprintf fmt x in
let pp_row ( key : Errlog . err_key ) ( err_data : Errlog . err_data ) =
let source_file , procedure_start_line =
match proc_loc_opt with
| Some proc_loc
@ -384,8 +384,7 @@ module IssuesJson = struct
; key = err_data . node_id_key . node_key
; qualifier_tags = Localise . Tags . tag_value_records_of_tags key . err_desc . tags
; hash =
get_bug_hash kind bug_type procedure_id file err_data . node_id_key . node_key
key . err_desc
get_bug_hash kind bug_type procedure_id file err_data . node_id_key . node_key key . err_desc
; dotty = error_desc_to_dotty_string key . err_desc
; infer_source_loc = json_ml_loc
; bug_type_hum = key . err_name . IssueType . hum
@ -395,8 +394,10 @@ module IssuesJson = struct
in
if not ! is_first_item then pp " , " else is_first_item := false ;
pp " %s@? " ( Jsonbug_j . string_of_jsonbug bug )
in
Errlog . iter pp_row err_log
(* * Write bug report in JSON format *)
let pp_issues_of_error_log fmt error_filter _ proc_loc_opt procname err_log =
Errlog . iter ( pp_issue fmt error_filter procname proc_loc_opt ) err_log
end
let pp_custom_of_report fmt report fields =
@ -462,9 +463,7 @@ let tests_jsonbug_compare bug1 bug2 =
( bug2 . file , bug2 . procedure , bug2 . line - bug2 . procedure_start_line , bug2 . bug_type , bug2 . hash )
module IssuesTxt = struct
(* * Write bug report in text format *)
let pp_issues_of_error_log fmt error_filter _ proc_loc_opt _ err_log =
let pp_row ( key : Errlog . err_key ) ( err_data : Errlog . err_data ) =
let pp_issue fmt error_filter proc_loc_opt ( key : Errlog . err_key ) ( err_data : Errlog . err_data ) =
let source_file =
match proc_loc_opt with
| Some proc_loc
@ -475,8 +474,10 @@ module IssuesTxt = struct
if key . in_footprint && error_filter source_file key . err_desc key . err_name then
Exceptions . pp_err ~ node_key : err_data . node_id_key . node_key err_data . loc key . err_kind
key . err_name key . err_desc None fmt ()
in
Errlog . iter pp_row err_log
(* * Write bug report in text format *)
let pp_issues_of_error_log fmt error_filter _ proc_loc_opt _ err_log =
Errlog . iter ( pp_issue fmt error_filter proc_loc_opt ) err_log
end
let pp_text_of_report fmt report =
@ -735,6 +736,20 @@ type report_kind = Issues | Procs | Stats | Calls | Summary [@@deriving compare]
type bug_format_kind = Json | Csv | Tests | Text | Latex [ @@ deriving compare ]
let pp_issue_in_format ( format_kind , ( outf : Utils . outfile ) ) error_filter
( procname , procname_loc , err_key , err_data ) =
match format_kind with
| Csv
-> IssuesCsv . pp_issue outf . fmt error_filter procname ( Some procname_loc ) err_key err_data
| Json
-> IssuesJson . pp_issue outf . fmt error_filter procname ( Some procname_loc ) err_key err_data
| Latex
-> L . ( die InternalError ) " Printing issues in latex is not implemented "
| Tests
-> L . ( die InternalError ) " Print issues as tests is not implemented "
| Text
-> IssuesTxt . pp_issue outf . fmt error_filter ( Some procname_loc ) err_key err_data
let pp_issues_in_format ( format_kind , ( outf : Utils . outfile ) ) =
match format_kind with
| Json
@ -782,11 +797,13 @@ let pp_issues_of_error_log error_filter linereader proc_loc_opt procname err_log
in
List . iter ~ f : pp_issues_in_format bug_format_list
let pp_issues error_filter linereader summary bug_format_list =
let collect_issues summary issues_acc =
let err_log = summary . Specs . attributes . ProcAttributes . err_log in
let procname = Specs . get_proc_name summary in
let loc = summary . Specs . attributes . ProcAttributes . loc in
pp_issues_of_error_log error_filter linereader ( Some loc ) procname err_log bug_format_list
let proc_loc = summary . Specs . attributes . ProcAttributes . loc in
Errlog . fold
( fun err_key err_data acc -> ( procname , proc_loc , err_key , err_data ) :: acc )
err_log issues_acc
let pp_procs summary procs_format_list =
let pp_procs_in_format format =
@ -820,11 +837,9 @@ let pp_summary summary fname summary_format_list =
Summary . print_summary_dot_svg summary fname
let pp_summary_by_report_kind formats_by_report_kind summary fname error_filter linereader stats
file =
file issues_acc =
let pp_summary_by_report_kind ( report_kind , format_list ) =
match ( report_kind , format_list ) with
| Issues , _ :: _
-> pp_issues error_filter linereader summary format_list
| Procs , _ :: _
-> pp_procs summary format_list
| Stats , _ :: _
@ -836,7 +851,7 @@ let pp_summary_by_report_kind formats_by_report_kind summary fname error_filter
| _
-> ()
in
List . iter ~ f : pp_summary_by_report_kind formats_by_report_kind
List . iter ~ f : pp_summary_by_report_kind formats_by_report_kind ; collect_issues summary issues_acc
let pp_json_report_by_report_kind formats_by_report_kind fname =
match Utils . read_file fname with
@ -888,15 +903,19 @@ let pp_lint_issues filters formats_by_report_kind linereader procname error_log
pp_lint_issues_by_report_kind formats_by_report_kind error_filter linereader procname error_log
(* * Process a summary *)
let process_summary filters formats_by_report_kind linereader stats ( fname , summary ) =
let process_summary filters formats_by_report_kind linereader stats fname summary issues_acc =
let file = summary . Specs . attributes . ProcAttributes . loc . Location . file in
let proc_name = Specs . get_proc_name summary in
let error_filter = error_filter filters proc_name in
let pp_simple_saved = ! Config . pp_simple in
Config . pp_simple := true ;
pp_summary_by_report_kind formats_by_report_kind summary fname error_filter linereader stats file ;
let issues_acc' =
pp_summary_by_report_kind formats_by_report_kind summary fname error_filter linereader stats
file issues_acc
in
if Config . precondition_stats then PreconditionStats . do_summary proc_name summary ;
Config . pp_simple := pp_simple_saved
Config . pp_simple := pp_simple_saved ;
issues_acc'
module AnalysisResults = struct
type t = ( string * Specs . summary ) list
@ -1070,33 +1089,43 @@ let finalize_and_close_files format_list_by_kind stats pdflatex =
in
List . iter ~ f : close_files_of_report_kind format_list_by_kind
let pp_summary_and_issues formats_by_report_kind =
let pp_summary_and_issues formats_by_report_kind issue_formats =
let pdflatex fname = ignore ( Sys . command ( " pdflatex " ^ fname ) ) in
let stats = Stats . create () in
let linereader = Printer . LineReader . create () in
let filters = Inferconfig . create_filters Config . analyzer in
let iterate_summaries = AnalysisResults . get_summary_iterator () in
iterate_summaries ( process_summary filters formats_by_report_kind linereader stats ) ;
let all_issues = ref [] in
iterate_summaries ( fun ( filename , summary ) ->
all_issues
:= process_summary filters formats_by_report_kind linereader stats filename summary
! all_issues ) ;
List . iter
~ f : ( fun ( procname , _ , _ , _ as issue ) ->
let error_filter = error_filter filters procname in
List . iter
~ f : ( fun issue_format -> pp_issue_in_format issue_format error_filter issue )
issue_formats )
( List . rev ! all_issues ) ;
if Config . precondition_stats then PreconditionStats . pp_stats () ;
LintIssues . load_issues_to_errlog_map Config . lint_issues_dir_name ;
Typ . Procname . Map . iter ( pp_lint_issues filters formats_by_report_kind linereader )
! LintIssues . errLogMap ;
finalize_and_close_files formats_by_report_kind stats pdflatex
let print_issues formats_by_report_kind =
init_files formats_by_report_kind ;
match Config . from_json_report with
| Some fname
-> pp_json_report_by_report_kind formats_by_report_kind fname
| None
-> pp_summary_and_issues formats_by_report_kind
let main ~ report_csv ~ report_json =
let issue_formats = init_issues_format_list report_csv report_json in
let formats_by_report_kind =
[ ( Issues , i nit_i ssues _format_li st report_csv report_json )
[ ( Issues , issue_formats )
; ( Procs , init_procs_format_list () )
; ( Calls , init_calls_format_list () )
; ( Stats , init_stats_format_list () )
; ( Summary , init_summary_format_list () ) ]
in
register_perf_stats_report () ; print_issues formats_by_report_kind
register_perf_stats_report () ;
init_files formats_by_report_kind ;
match Config . from_json_report with
| Some fname
-> pp_json_report_by_report_kind formats_by_report_kind fname
| None
-> pp_summary_and_issues formats_by_report_kind issue_formats