1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
open Types
open Common
open Tree
open Global_checks
let search_basedir file_name nb =
let dir = Filename.dirname file_name in
let config = Config_file.read dir in
let nb = some_or config.Config_file.basedir nb in
updir dir nb
let basedir = ref ""
let set_basedir per_files file =
if !basedir = "" then
let nb = List.length (split_at2 ':'':' (List.hd file.packages).package_name) - 1 in
let dir = search_basedir file.file_name nb in
lpush Tree.use_lib dir ;
Config_file.read_any dir 1 ;
read_packages_from_cache per_files dir ;
if !Flags.verbose then print_endline_flush ("basedir is " ^ dir);
basedir := dir
let rec parse_file from_basedir require_name per_files file =
try
if !Flags.verbose then print_endline_flush ("parsing " ^ file) ;
let build_time = Unix.time() in
let command =
match !Flags.expand_tabs with
| Some width -> "expand -t " ^ string_of_int width
| None -> "cat" in
let channel = Unix.open_process_in (Printf.sprintf "%s \"%s\"" command file) in
let lexbuf = Lexing.from_channel channel in
try
Info.start_a_new_file file ;
let tokens = Lexer.get_token Lexer.token lexbuf in
if not Build.debugging then ignore (Unix.close_process_in channel) ;
let t = Parser_helper.parse_tokens Parser.prog tokens (Some lexbuf) in
let per_file = get_global_info_from_package from_basedir require_name build_time t in
set_basedir per_files per_file ;
Global_checks.add_file_to_files per_files per_file ;
let required_packages = collect (fun package -> package.required_packages) per_file.packages in
required_packages, per_files
with Failure s -> (
print_endline_flush s ;
exit 1
)
with
| Not_found -> internal_error "runaway Not_found"
and parse_package_if_needed per_files (package_name, pos) =
if List.mem package_name !Config_file.ignored_packages then [], per_files else
let splitted = split_at2 ':'':' package_name in
let rel_file = String.concat "/" splitted ^ ".pm" in
(*print_endline_flush ("wondering about " ^ package_name) ;*)
try
let dir = findfile (Build.fake_packages_dir :: !use_lib) rel_file in
let file = Info.file_to_absolute_file (dir ^ "/" ^ rel_file) in
Config_file.read_any (Filename.dirname file) (List.length splitted) ;
let already_done =
try
let per_file = Hashtbl.find per_files file in
Some (collect (fun pkg -> pkg.required_packages) per_file.packages)
with Not_found -> None in
match already_done with
| Some required_packages -> required_packages, per_files
| None -> parse_file (dir = !basedir) (Some package_name) per_files file
with Not_found ->
print_endline_flush (Info.pos2sfull pos ^ Printf.sprintf "can't find package %s" package_name) ;
[], per_files
let rec parse_required_packages state already_done = function
| [] -> state, already_done
| e :: l ->
if List.mem e already_done then
parse_required_packages state already_done l
else
let el, state = parse_package_if_needed state e in
parse_required_packages state (e :: already_done) (el @ l)
let parse_options =
let args_r = ref [] in
let restrict_to_files = ref false in
let pot_file = ref "" in
let generate_pot_chosen file =
Flags.generate_pot := true ;
Flags.expand_tabs := None ;
pot_file := file
in
let options = [
"-v", Arg.Set Flags.verbose, " be verbose" ;
"-q", Arg.Set Flags.quiet, " be quiet" ;
"-t", Arg.Int (fun i -> Flags.expand_tabs := Some i), " set the tabulation width (default is 8)" ;
"--restrict-to-files", Arg.Set restrict_to_files, " only display warnings concerning the file(s) given on command line" ;
"--no-cache", Arg.Set Flags.no_cache, " do not use cache" ;
"--generate-pot", Arg.String generate_pot_chosen,
"\n" ;
"--check-unused-global-vars", Arg.Set Flags.check_unused_global_vars, " disable unused global functions & variables check" ^
"\nBasic warnings:";
"--no-check-white-space", Arg.Clear Flags.check_white_space, " disable white space check" ;
"--no-suggest-simpler", Arg.Clear Flags.check_suggest_simpler, " disable simpler code suggestion" ;
"--no-suggest-functional", Arg.Clear Flags.suggest_functional, " disable Functional Programming suggestions" ^
"\nNormalisation warnings:";
"--no-check-strange", Arg.Clear Flags.check_strange, " disable strange code check" ;
"--no-check-complex-expressions", Arg.Clear Flags.check_complex_expressions, " disable complex expressions check" ;
"--no-check-normalized-expressions", Arg.Clear Flags.normalized_expressions, " don't warn about non normalized expressions" ;
"--no-help-perl-checker", Arg.Clear Flags.check_help_perl_checker, " beware, perl_checker doesn't understand all perl expressions, so those warnings *are* important" ^
"\nCommon warnings:";
"--no-check-void", Arg.Clear Flags.check_void, " disable dropped value check" ;
"--no-check-names", Arg.Clear Flags.check_names, " disable variable & function usage check" ;
"--no-check-prototypes", Arg.Clear Flags.check_prototypes, " disable prototypes check" ;
"--no-check-import-export", Arg.Clear Flags.check_import_export, " disable inter modules check" ^
"\nImportant warnings:";
"--no-check-context", Arg.Clear Flags.check_context, " disable context check" ;
"--no-check-traps", Arg.Clear Flags.check_traps, " disable traps (errors) check" ^
"\n";
] in
let usage = "Usage: perl_checker [<options>] <files>\nOptions are:" in
Arg.parse options (lpush args_r) usage;
let files = if !args_r = [] && Build.debugging then ["../t.pl"] else !args_r in
let files = List.map Info.file_to_absolute_file files in
let required_packages, per_files = collect_withenv (parse_file true None) (default_per_files()) files in
let required_packages = uniq_ (fun (a,_) (b,_) -> a = b) required_packages in
if !Flags.generate_pot then Parser_helper.generate_pot !pot_file else (
let per_files, required_packages =
fluid_let Flags.quiet (!restrict_to_files || !Flags.quiet)
(fun () ->
parse_required_packages per_files [] required_packages) in
let l_required_packages = List.map fst required_packages in
write_packages_cache per_files !basedir ;
(* removing non needed files from per_files (those files come from the cache) *)
List.iter (fun k ->
let per_file = Hashtbl.find per_files k in
if per_file.require_name <> None && not (List.mem (some per_file.require_name) l_required_packages) && not (List.mem per_file.file_name files) then
Hashtbl.remove per_files k
) (hashtbl_keys per_files);
let state = default_state per_files in
Hashtbl.iter (fun _ per_file -> List.iter (add_package_to_state state) per_file.packages) per_files ;
let state =
let global_vars_declared = Hashtbl.create 16 in
let package_name_to_file_name = hashtbl_collect (fun _ per_file -> List.map (fun pkg -> pkg.package_name, per_file.file_name) per_file.packages) per_files in
Hashtbl.iter (fun _ pkg ->
let file_name = List.assoc pkg.package_name package_name_to_file_name in
fluid_let Flags.quiet (!restrict_to_files || !Flags.quiet)
(fun () -> get_vars_declaration global_vars_declared file_name pkg)
) state.per_packages ;
arrange_global_vars_declared global_vars_declared state
in
let state = Global_checks.get_methods_available state in
let l = hashtbl_values per_files in
let l = if !restrict_to_files then List.filter (fun file -> List.mem file.file_name files) l else l in
let l = uniq (collect (fun file -> List.map (fun pkg -> pkg.package_name) file.packages) l) in
let l = List.map (Hashtbl.find state.per_packages) l in
(* HACK: skip ignored_packages. Some package may have appeared in ignored_packages due to the xs bootstrap hack *)
let l = List.filter (fun pkg -> not (List.mem pkg.package_name !Config_file.ignored_packages)) l in
List.iter (Global_checks.check_tree state) l;
if !Flags.check_unused_global_vars then List.iter Global_checks.check_unused_vars l
)
|
