diff options
author | Pascal Rigaux <pixel@mandriva.com> | 2004-11-10 09:07:48 +0000 |
---|---|---|
committer | Pascal Rigaux <pixel@mandriva.com> | 2004-11-10 09:07:48 +0000 |
commit | 2e8ce2010f213d7c5110f7b052f1301440e9f663 (patch) | |
tree | b6bba578f0fe4919752dcf213ee3d20ea5e46679 | |
parent | 19223c94b1e66d368510b0a51846cd81ff274578 (diff) | |
download | perl_checker-2e8ce2010f213d7c5110f7b052f1301440e9f663.tar perl_checker-2e8ce2010f213d7c5110f7b052f1301440e9f663.tar.gz perl_checker-2e8ce2010f213d7c5110f7b052f1301440e9f663.tar.bz2 perl_checker-2e8ce2010f213d7c5110f7b052f1301440e9f663.tar.xz perl_checker-2e8ce2010f213d7c5110f7b052f1301440e9f663.zip |
allow disabling warnings on command-line (and have various warnings level)
-rw-r--r-- | perl_checker.src/Makefile | 2 | ||||
-rw-r--r-- | perl_checker.src/common.ml | 11 | ||||
-rw-r--r-- | perl_checker.src/common.mli | 3 | ||||
-rw-r--r-- | perl_checker.src/flags.ml | 37 | ||||
-rw-r--r-- | perl_checker.src/flags.mli | 18 | ||||
-rw-r--r-- | perl_checker.src/global_checks.ml | 48 | ||||
-rw-r--r-- | perl_checker.src/lexer.mll | 40 | ||||
-rw-r--r-- | perl_checker.src/parser.mly | 26 | ||||
-rw-r--r-- | perl_checker.src/parser_helper.ml | 227 | ||||
-rw-r--r-- | perl_checker.src/parser_helper.mli | 31 | ||||
-rw-r--r-- | perl_checker.src/perl_checker.ml | 43 | ||||
-rw-r--r-- | perl_checker.src/test/syntax_restrictions.t | 2 | ||||
-rw-r--r-- | perl_checker.src/tree.ml | 35 | ||||
-rw-r--r-- | perl_checker.src/tree.mli | 3 | ||||
-rw-r--r-- | perl_checker.src/types.mli | 17 |
15 files changed, 319 insertions, 224 deletions
diff --git a/perl_checker.src/Makefile b/perl_checker.src/Makefile index b639e6c..22a45a6 100644 --- a/perl_checker.src/Makefile +++ b/perl_checker.src/Makefile @@ -4,7 +4,7 @@ YFLAGS = -v TRASH = parser.output perl_checker.html TAGS RESULT = perl_checker BCSUFFIX = _debug -SOURCES = build.ml common.ml flags.ml config_file.ml types.mli info.ml parser_helper.ml parser.mly lexer.mll tree.ml global_checks.ml perl_checker.ml +SOURCES = types.mli build.ml common.ml flags.ml config_file.ml info.ml parser_helper.ml parser.mly lexer.mll tree.ml global_checks.ml perl_checker.ml LIBS = unix VENDORLIB = $(shell dirname `pwd`) DEBUG = 1 diff --git a/perl_checker.src/common.ml b/perl_checker.src/common.ml index 8a0d27e..dd2f6b1 100644 --- a/perl_checker.src/common.ml +++ b/perl_checker.src/common.ml @@ -228,6 +228,13 @@ let rec lfix_point f e = if e = e' then e :: lfix_point f e' else [e] *) +let fluid_let ref value f = + let previous_val = !ref in + ref := value ; + let v = f() in + ref := previous_val ; + v + let do0_withenv doit f env l = let r_env = ref env in doit (fun e -> r_env := f !r_env e) l ; @@ -882,9 +889,7 @@ let rec updir dir nb = let (string_of_ref : 'a ref -> string) = fun r -> Printf.sprintf "0x%x" (Obj.magic r : int) -let print_endline_flush_quiet = ref false -let print_endline_flush s = if not !print_endline_flush_quiet then (print_endline s ; flush stdout) -let print_endline_flush_always s = print_endline s ; flush stdout +let print_endline_flush s = print_endline s ; flush stdout let is_int n = n = floor n diff --git a/perl_checker.src/common.mli b/perl_checker.src/common.mli index 17b0ca5..86a13cd 100644 --- a/perl_checker.src/common.mli +++ b/perl_checker.src/common.mli @@ -52,6 +52,7 @@ val fix_point : ('a -> 'a) -> 'a -> 'a val fix_point_withenv : ('a -> 'b -> 'b * 'a) -> 'a -> 'b -> 'b * 'a val fix_point_ : int -> ('a -> 'a) -> 'a -> 'a * int val group_by_2 : 'a list -> ('a * 'a) list +val fluid_let : 'a ref -> 'a -> (unit -> 'b) -> 'b val do0_withenv : (('a -> unit) -> 'b -> 'c) -> ('d -> 'a -> 'd) -> 'd -> 'b -> 'd val do0_withenv2 : @@ -219,9 +220,7 @@ val expand_symlinks : string -> string val mtime : string -> float val updir : string -> int -> string val string_of_ref : 'a ref -> string -val print_endline_flush_quiet : bool ref val print_endline_flush : string -> unit -val print_endline_flush_always : string -> unit val is_int : float -> bool val compare_lists : ('a -> 'b -> int) -> 'a list -> 'b list -> int val compare_best : int -> int -> int diff --git a/perl_checker.src/flags.ml b/perl_checker.src/flags.ml index fdedc95..187c140 100644 --- a/perl_checker.src/flags.ml +++ b/perl_checker.src/flags.ml @@ -1,8 +1,43 @@ open Common +open Types let verbose = ref false let quiet = ref false let generate_pot = ref false let expand_tabs = ref (Some 8) -let check_unused_global_vars = ref false let no_cache = ref false + +let check_unused_global_vars = ref false +let check_white_space = ref true +let check_suggest_simpler = ref true +let check_void = ref true +let check_context = ref true +let check_strange = ref true +let check_traps = ref true +let check_complex_expressions = ref true +let normalized_expressions = ref true +let check_help_perl_checker = ref true +let suggest_functional = ref true +let check_prototypes = ref true +let check_names = ref true +let check_import_export = ref true +let allow_MDK_Common = ref true + +let is_warning_type_set = function + | Warn_white_space -> !check_white_space + | Warn_suggest_simpler -> !check_suggest_simpler + | Warn_unused_global_vars -> !check_unused_global_vars + | Warn_void -> !check_void + | Warn_context -> !check_context + | Warn_strange -> !check_strange + | Warn_traps -> !check_traps + | Warn_complex_expressions -> !check_complex_expressions + | Warn_normalized_expressions -> !normalized_expressions + | Warn_suggest_functional -> !suggest_functional + | Warn_prototypes -> !check_prototypes + | Warn_names -> !check_names + | Warn_import_export -> !check_import_export + | Warn_MDK_Common -> !allow_MDK_Common + | Warn_help_perl_checker -> !check_help_perl_checker + +let are_warning_types_set l = not !quiet && List.for_all is_warning_type_set l diff --git a/perl_checker.src/flags.mli b/perl_checker.src/flags.mli index b3d8ffa..2dc3b26 100644 --- a/perl_checker.src/flags.mli +++ b/perl_checker.src/flags.mli @@ -2,5 +2,21 @@ val verbose : bool ref val quiet : bool ref val generate_pot : bool ref val expand_tabs : int option ref -val check_unused_global_vars : bool ref val no_cache : bool ref +val check_unused_global_vars : bool ref +val check_white_space : bool ref +val check_suggest_simpler : bool ref +val check_void : bool ref +val check_context : bool ref +val check_strange : bool ref +val check_traps : bool ref +val check_complex_expressions : bool ref +val normalized_expressions : bool ref +val check_help_perl_checker : bool ref +val suggest_functional : bool ref +val check_prototypes : bool ref +val check_names : bool ref +val check_import_export : bool ref +val allow_MDK_Common : bool ref +val is_warning_type_set : Types.warning -> bool +val are_warning_types_set : Types.warning list -> bool diff --git a/perl_checker.src/global_checks.ml b/perl_checker.src/global_checks.ml index 5875dce..7b24d50 100644 --- a/perl_checker.src/global_checks.ml +++ b/perl_checker.src/global_checks.ml @@ -36,7 +36,7 @@ let rec get_imported state current_package (package_name, (imports, pos)) = try sndter3 (List.assoc var (get_imports state package_used)) with Not_found -> - warn_with_pos pos (sprintf "name %s is not defined in package %s" (variable2s var) package_name) ; + warn_with_pos [Warn_import_export] pos (sprintf "name %s is not defined in package %s" (variable2s var) package_name) ; ref Access_various, None in var, (package_name, b, prototype) @@ -59,12 +59,12 @@ let rec get_imported state current_package (package_name, (imports, pos)) = | I_raw, tag -> (try List.assoc tag exports.export_tags - with Not_found -> warn_with_pos pos (sprintf "package %s doesn't export tag %s" package_name tag) ; []) + with Not_found -> warn_with_pos [Warn_import_export] pos (sprintf "package %s doesn't export tag %s" package_name tag) ; []) | variable -> if List.mem variable exports.export_ok || List.mem variable exports.export_auto then [ variable ] else - (warn_with_pos pos (sprintf "package %s doesn't export %s" package_name (variable2s variable)) ; []) + (warn_with_pos [Warn_import_export] pos (sprintf "package %s doesn't export %s" package_name (variable2s variable)) ; []) ) l in List.map get_var_by_name imports_vars @@ -99,8 +99,8 @@ let check_para_comply_with_prototype para proto = | None -> () | Some(pos, para) -> match do_para_comply_with_prototype para proto with - | -1 -> warn_with_pos pos "not enough parameters" - | 1 -> warn_with_pos pos "too many parameters" + | -1 -> warn_with_pos [Warn_prototypes] pos "not enough parameters" + | 1 -> warn_with_pos [Warn_prototypes] pos "too many parameters" | _ -> () let is_anonymous_variable_name s = String.length s > 1 && s.[0] = '_' @@ -192,18 +192,18 @@ let is_global_var context ident = let check_variable (context, var) vars para = match var with | Ident(_, s, pos) when context <> I_func && is_anonymous_variable_name s && s <> "__FILE__" && s <> "__LINE__" -> - warn_with_pos pos (sprintf "variable %s must not be used\n (variable with name _XXX are reserved for unused variables)" (variable2s(context, string_of_Ident var))) + warn_with_pos [Warn_normalized_expressions] pos (sprintf "variable %s must not be used\n (variable with name _XXX are reserved for unused variables)" (variable2s(context, string_of_Ident var))) | Ident(Some pkg, _, _) when uses_external_package pkg || List.mem pkg !ignored_packages -> () | Ident(None, ident, pos) -> if is_my_declared vars (context, ident) || is_our_declared vars (context, ident) || is_var_declared vars (context, ident) para || is_global_var context ident then () - else warn_with_pos pos (if context = I_func then "unknown function " ^ ident else "undeclared variable " ^ variable2s(context, ident)) + else warn_with_pos [Warn_names] pos (if context = I_func then "unknown function " ^ ident else "undeclared variable " ^ variable2s(context, ident)) | Ident(Some fq, name, pos) -> if (fq = "CORE") && is_global_var context name || is_global_var_declared vars (context, fq, name) para then () else if context = I_func then - warn_with_pos pos ("unknown function " ^ string_of_Ident var) + warn_with_pos [Warn_names] pos ("unknown function " ^ string_of_Ident var) else lpush vars.state.global_vars_used ((context, fq, name), pos) | _ -> () @@ -216,7 +216,7 @@ let declare_My vars (mys, pos) = ) mys in let l_pre = List.hd vars.my_vars in List.iter (fun v -> - if List.mem_assoc v l_pre then warn_with_pos pos (sprintf "redeclared variable %s" (variable2s v)) + if List.mem_assoc v l_pre then warn_with_pos [Warn_names] pos (sprintf "redeclared variable %s" (variable2s v)) ) l_new ; { vars with my_vars = (List.map (fun v -> v, (pos, ref Access_none, None)) l_new @ l_pre) :: List.tl vars.my_vars } @@ -225,7 +225,7 @@ let declare_Our vars (ours, pos) = | [] -> vars (* we're at the toplevel, already declared in vars_declared *) | l_pre :: other -> List.iter (fun v -> - if List.mem_assoc v l_pre && v <> (I_scalar, "_") then warn_with_pos pos (sprintf "redeclared variable %s" (variable2s v)) + if List.mem_assoc v l_pre && v <> (I_scalar, "_") then warn_with_pos [Warn_names] pos (sprintf "redeclared variable %s" (variable2s v)) ) ours ; { vars with our_vars = (List.map (fun v -> v, (pos, ref Access_none, None)) ours @ l_pre) :: other } @@ -246,11 +246,11 @@ let check_unused_local_variables vars = match s with | "BEGIN" | "END" | "DESTROY" -> () | "_" when context = I_array -> - warn_with_pos pos "if the function doesn't take any parameters, please use the empty prototype.\nexample \"sub foo() { ... }\"" + warn_with_pos [Warn_normalized_expressions] pos "if the function doesn't take any parameters, please use the empty prototype.\nexample \"sub foo() { ... }\"" | _ -> if s.[0] != '_' || s = "_" then let msg = if !used = Access_write_only then sprintf "variable %s assigned, but not read" else sprintf "unused variable %s" in - warn_with_pos pos (msg (variable2s v)) + warn_with_pos [Warn_names] pos (msg (variable2s v)) ) (List.hd vars.my_vars) let check_variables vars t = @@ -287,7 +287,7 @@ let check_variables vars t = (* special warning if @_ is unbound *) check_variable (I_func, ident) vars None ; if not (is_my_declared vars (I_array, "_")) then - warn_with_pos pos (sprintf "replace %s(@_) with &%s" (string_of_Ident ident) (string_of_Ident ident)) ; + warn_with_pos [Warn_suggest_simpler] pos (sprintf "replace %s(@_) with &%s" (string_of_Ident ident) (string_of_Ident ident)) ; Some vars | Call(Deref(I_func, Ident(None, "require", _)), [Ident _]) -> Some vars @@ -308,7 +308,7 @@ let check_variables vars t = let vars = check_variables_ vars l in let vars' = { vars with my_vars = [] :: vars.my_vars ; our_vars = [(I_scalar, "_"), (pos, ref Access_various, None)] :: vars.our_vars } in let vars' = check_variables_ vars' expr in - if List.hd(vars'.my_vars) <> [] then warn_with_pos pos "you can't declare variables in foreach infix"; + if List.hd(vars'.my_vars) <> [] then warn_with_pos [Warn_traps] pos "you can't declare variables in foreach postfix"; Some vars | Call_op("foreach my", [my; expr; Block block], _) -> @@ -379,7 +379,7 @@ let check_variables vars t = (* check e first *) let vars = check_variables_ vars e in List.iter (fun (context, var) -> - if non_scalar_context context then warn_with_pos pos (sprintf "%s takes all the arguments, %s is undef in any case" (variable2s (context, var)) (variable2s (last mys))) + if non_scalar_context context then warn_with_pos [Warn_prototypes] pos (sprintf "%s takes all the arguments, %s is undef in any case" (variable2s (context, var)) (variable2s (last mys))) ) (removelast mys) ; (* mys is never empty *) Some(declare_My_our vars (my_or_our, mys, pos)) @@ -387,7 +387,7 @@ let check_variables vars t = | Call_op(op, List (My_our _ :: _) :: _, pos) | Call_op(op, My_our _ :: _, pos) | Call_op(op, Call_op("local", _, _) :: _, pos) -> - if op <> "=" then warn_with_pos pos (sprintf "applying %s on a new initialized variable is wrong" op); + if op <> "=" then warn_with_pos [Warn_traps] pos (sprintf "applying %s on a new initialized variable is wrong" op); None | Call_op("=", [ Deref(context, (Ident _ as var)) ; para], _) -> @@ -429,8 +429,8 @@ let check_variables vars t = in (try if not (uses_external_package pkg || List.mem pkg !ignored_packages || search pkg || method_ = "bootstrap") then - warn_with_pos pos (sprintf "unknown method %s starting in package %s" method_ pkg); - with Not_found -> warn_with_pos pos (sprintf "unknown package %s" pkg)); + warn_with_pos [Warn_import_export] pos (sprintf "unknown method %s starting in package %s" method_ pkg); + with Not_found -> warn_with_pos [Warn_import_export] pos (sprintf "unknown package %s" pkg)); Some vars | Method_call(o, Raw_string(method_, pos), para) -> @@ -443,16 +443,16 @@ let check_variables vars t = match List.filter (fun (_, n) -> n = 0) l_and with | [] -> (match uniq (List.map snd l_and) with - | [-1] -> warn_with_pos pos "not enough parameters" - | [ 1] -> warn_with_pos pos "too many parameters" - | _ -> warn_with_pos pos "not enough or too many parameters") ; + | [-1] -> warn_with_pos [Warn_prototypes] pos "not enough parameters" + | [ 1] -> warn_with_pos [Warn_prototypes] pos "too many parameters" + | _ -> warn_with_pos [Warn_prototypes] pos "not enough or too many parameters") ; l_and | l -> l in List.iter (fun (used, _) -> used := Access_various) l_and with Not_found -> if not (List.mem method_ [ "isa"; "can" ]) then - warn_with_pos pos ("unknown method " ^ method_)) ; + warn_with_pos [Warn_names] pos ("unknown method " ^ method_)) ; Some vars | _ -> None @@ -462,7 +462,7 @@ let check_variables vars t = let check_tree state package = let vars = { my_vars = [[]]; our_vars = []; locally_imported = []; required_vars = []; current_package = package; state = state; is_toplevel = true; write_only = false } in - if !Flags.verbose then print_endline_flush_always ("checking package " ^ package.package_name) ; + if !Flags.verbose then print_endline_flush ("checking package " ^ package.package_name) ; let vars = check_variables vars package.body in check_unused_local_variables vars ; () @@ -501,7 +501,7 @@ let add_file_to_files per_files file = let check_unused_vars package = Hashtbl.iter (fun (context, name) (pos, is_used, _proto) -> if not (!is_used != Access_various || List.mem name ["BEGIN"; "END"; "DESTROY"; "ISA"; "AUTOLOAD"; "EXPORT"; "EXPORT_OK"; "EXPORT_TAGS"]) then - warn_with_pos pos (sprintf "unused %s%s::%s" (if context = I_func then "function " else "variable " ^ context2s context) package.package_name name) + warn_with_pos [Warn_unused_global_vars] pos (sprintf "unused %s%s::%s" (if context = I_func then "function " else "variable " ^ context2s context) package.package_name name) ) package.vars_declared let arrange_global_vars_declared global_vars_declared state = diff --git a/perl_checker.src/lexer.mll b/perl_checker.src/lexer.mll index 8d6714c..ebd183e 100644 --- a/perl_checker.src/lexer.mll +++ b/perl_checker.src/lexer.mll @@ -62,8 +62,8 @@ let pos lexbuf = lexeme_start lexbuf, lexeme_end lexbuf let pos2sfull_with start end_ = Info.pos2sfull (!current_file, start, end_) let pos2sfull lexbuf = pos2sfull_with (lexeme_start lexbuf) (lexeme_end lexbuf) -let warn_with_pos (start, end_) err = print_endline_flush (pos2sfull_with start end_ ^ err) -let warn lexbuf err = warn_with_pos (pos lexbuf) err +let warn_with_pos warn_types (start, end_) err = if Flags.are_warning_types_set warn_types then print_endline_flush (pos2sfull_with start end_ ^ err) +let warn warn_types lexbuf err = warn_with_pos warn_types (pos lexbuf) err let die lexbuf err = failwith (pos2sfull_with (lexeme_start lexbuf) (lexeme_end lexbuf) ^ err) let rec concat_bareword_paren accu = function @@ -81,7 +81,7 @@ let rec concat_bareword_paren accu = function | BAREWORD("N_", _) :: PAREN(_) :: _ -> concat_bareword_paren (e :: accu) l | _ -> - warn_with_pos pos "N(...) must follow the #-PO: comment, with nothing in between" ; + warn_with_pos [Warn_MDK_Common] pos "N(...) must follow the #-PO: comment, with nothing in between" ; concat_bareword_paren accu l) | [] -> List.rev accu | e :: l -> @@ -267,7 +267,7 @@ let current_string_start_line = ref 0 let die_in_string lexbuf err = failwith (pos2sfull_with !current_string_start_pos (lexeme_end lexbuf) ^ err) let warn_escape_unneeded lexbuf c = - let s = String.make 1 c in warn lexbuf ("you can replace \\" ^ s ^ " with " ^ s) + let s = String.make 1 c in warn [Warn_suggest_simpler] lexbuf ("you can replace \\" ^ s ^ " with " ^ s) let next_interpolated toks = let r = Stack.top building_current_string in Queue.push (!r, toks) (Stack.top building_current_interpolated_string) ; @@ -301,7 +301,7 @@ let ins_to_string t lexbuf = (match !string_escape_useful, s with | Right c, [ _, [] ] -> let s = String.make 1 c in - warn_with_pos pos ("you can replace \"xxx\\" ^ s ^ "xxx\" with 'xxx" ^ s ^ "xxx', that way you don't need to escape <" ^ s ^ ">") + warn_with_pos [Warn_suggest_simpler] pos ("you can replace \"xxx\\" ^ s ^ "xxx\" with 'xxx" ^ s ^ "xxx', that way you don't need to escape <" ^ s ^ ">") | _ -> if !string_quote_escape then let full_s = String.concat "" (List.map fst s) in @@ -311,7 +311,7 @@ let ins_to_string t lexbuf = if c = ')' then nb - 1 else nb ) 0 full_s in if nb = 0 then - warn_with_pos pos "you can replace \"xxx\\\"xxx\" with qq(xxx\"xxx), that way you don't need to escape <\">" + warn_with_pos [Warn_suggest_simpler] pos "you can replace \"xxx\\\"xxx\" with qq(xxx\"xxx), that way you don't need to escape <\">" ); not_ok_for_match := lexeme_end lexbuf; @@ -326,8 +326,8 @@ let next t lexbuf = next_s (lexeme lexbuf) t lexbuf let ins_re re_delimited_string lexbuf = let s, pos = ins re_delimited_string lexbuf in List.iter (fun (s, _) -> - if str_contains s "[^\\s]" then warn lexbuf "you can replace [^\\s] with \\S"; - if str_contains s "[^\\w]" then warn lexbuf "you can replace [^\\w] with \\W" + if str_contains s "[^\\s]" then warn [Warn_suggest_simpler] lexbuf "you can replace [^\\s] with \\S"; + if str_contains s "[^\\w]" then warn [Warn_suggest_simpler] lexbuf "you can replace [^\\w] with \\W" ) s ; s, pos @@ -404,8 +404,8 @@ let set_delimit_char lexbuf op = let c = lexeme_char lexbuf (String.length op) in delimit_char := c; match c with - | '@' -> warn lexbuf ("don't use " ^ op ^ "@...@, replace @ with / ! , or |") - | ':' -> warn lexbuf ("don't use " ^ op ^ ":...:, replace : with / ! , or |") + | '@' -> warn [Warn_complex_expressions] lexbuf ("don't use " ^ op ^ "@...@, replace @ with / ! , or |") + | ':' -> warn [Warn_complex_expressions] lexbuf ("don't use " ^ op ^ ":...:, replace : with / ! , or |") | _ -> () let set_delimit_char_open lexbuf op = @@ -417,9 +417,9 @@ let set_delimit_char_open lexbuf op = | _ -> internal_error "set_delimit_char_open" in if op = "qx" then - warn lexbuf (Printf.sprintf "don't use qx%c...%c, use `...` instead" char_open char_close) + warn [Warn_complex_expressions] lexbuf (Printf.sprintf "don't use qx%c...%c, use `...` instead" char_open char_close) else if char_open = '{' then - warn lexbuf ("don't use " ^ op ^ "{...}, use " ^ op ^ "(...) instead"); + warn [Warn_complex_expressions] lexbuf ("don't use " ^ op ^ "{...}, use " ^ op ^ "(...) instead"); delimit_char_open := char_open; delimit_char_close := char_close } @@ -498,7 +498,7 @@ rule token = parse | "=" | "+=" | "-=" | "*=" | ".=" | "|=" | "&=" | "^=" | "||=" | "&&=" { ASSIGN(lexeme lexbuf, pos lexbuf) } | "<<=" | ">>=" | "**=" { - warn lexbuf (Printf.sprintf "don't use \"%s\", use the expanded version instead" (lexeme lexbuf)) ; + warn [Warn_complex_expressions] lexbuf (Printf.sprintf "don't use \"%s\", use the expanded version instead" (lexeme lexbuf)) ; ASSIGN(lexeme lexbuf, pos lexbuf) } @@ -634,7 +634,7 @@ rule token = parse set_delimit_char lexbuf "qw" ; current_string_start_line := !current_file_current_line; let s, pos = raw_ins delimited_string lexbuf in - warn_with_pos pos (Printf.sprintf "don't use qw%c...%c, use qw(...) instead" !delimit_char !delimit_char) ; + warn_with_pos [Warn_complex_expressions] pos (Printf.sprintf "don't use qw%c...%c, use qw(...) instead" !delimit_char !delimit_char) ; QUOTEWORDS(s, pos) } @@ -918,7 +918,7 @@ and string_escape = parse | Qq -> if c <> !delimit_char_open && c <> !delimit_char_close then warn_escape_unneeded lexbuf c | Here_doc -> warn_escape_unneeded lexbuf c | Delimited -> if c = !delimit_char then - warn lexbuf ("change the delimit character " ^ String.make 1 !delimit_char ^ " to get rid of this escape") + warn [Warn_suggest_simpler] lexbuf ("change the delimit character " ^ String.make 1 !delimit_char ^ " to get rid of this escape") else warn_escape_unneeded lexbuf c); let s = if c = '"' then String.make 1 c else "\\" ^ String.make 1 c in next_s s (Stack.pop next_rule) lexbuf @@ -938,7 +938,7 @@ and re_string_escape = parse | _ { let c = lexeme_char lexbuf 0 in if c = !delimit_char then - warn lexbuf ("change the delimit character " ^ String.make 1 !delimit_char ^ " to get rid of this escape") + warn [Warn_suggest_simpler] lexbuf ("change the delimit character " ^ String.make 1 !delimit_char ^ " to get rid of this escape") else warn_escape_unneeded lexbuf c ; next_s ("\\" ^ lexeme lexbuf) (Stack.pop next_rule) lexbuf } @@ -956,7 +956,7 @@ and string_interpolate_scalar = parse | ident "->"? '{' | '"' { putback lexbuf 1; next_s "$" (Stack.pop next_rule) lexbuf } | eof { next_s "$" (Stack.pop next_rule) lexbuf } -| _ { warn lexbuf (Printf.sprintf "weird \"%s\" in string" (lexeme lexbuf)); next_s ("$" ^ lexeme lexbuf) (Stack.pop next_rule) lexbuf } +| _ { warn [Warn_strange] lexbuf (Printf.sprintf "weird \"%s\" in string" (lexeme lexbuf)); next_s ("$" ^ lexeme lexbuf) (Stack.pop next_rule) lexbuf } and delimited_string_interpolate_scalar = parse (* needed for delimited string like m!foo$! where $! should not be taken as is... *) | '$' ident @@ -978,7 +978,7 @@ and delimited_string_interpolate_scalar = parse (* needed for delimited string l | eof { next_s "$" (Stack.pop next_rule) lexbuf } | _ { let c = lexeme_char lexbuf 0 in - if c <> !delimit_char && c <> '|' && c<>')' && c<>'/' && c<>' ' then warn lexbuf (Printf.sprintf "weird \"%s\" in string" (lexeme lexbuf)); + if c <> !delimit_char && c <> '|' && c<>')' && c<>'/' && c<>' ' then warn [Warn_strange] lexbuf (Printf.sprintf "weird \"%s\" in string" (lexeme lexbuf)); putback lexbuf 1; next_s "$" (Stack.pop next_rule) lexbuf } @@ -991,7 +991,7 @@ and string_interpolate_array = parse | [ '@' '*' '<' '>' ']' '.' '(' ' ' ] { next_s ("@" ^ lexeme lexbuf) (Stack.pop next_rule) lexbuf } | '"' { putback lexbuf 1; next_s "@" (Stack.pop next_rule) lexbuf } | eof { next_s "@" (Stack.pop next_rule) lexbuf } -| _ { warn lexbuf (Printf.sprintf "weird \"%s\" in string" (lexeme lexbuf)); next_s ("@" ^ lexeme lexbuf) (Stack.pop next_rule) lexbuf } +| _ { warn [Warn_strange] lexbuf (Printf.sprintf "weird \"%s\" in string" (lexeme lexbuf)); next_s ("@" ^ lexeme lexbuf) (Stack.pop next_rule) lexbuf } and delimited_string_interpolate_array = parse | '$' ident @@ -1003,7 +1003,7 @@ and delimited_string_interpolate_array = parse | eof { next_s "@" (Stack.pop next_rule) lexbuf } | _ { let c = lexeme_char lexbuf 0 in - if c <> !delimit_char then warn lexbuf (Printf.sprintf "weird \"%s\" in string" (lexeme lexbuf)); + if c <> !delimit_char then warn [Warn_strange] lexbuf (Printf.sprintf "weird \"%s\" in string" (lexeme lexbuf)); putback lexbuf 1; next_s "@" (Stack.pop next_rule) lexbuf } diff --git a/perl_checker.src/parser.mly b/perl_checker.src/parser.mly index 4b3f70c..88dca94 100644 --- a/perl_checker.src/parser.mly +++ b/perl_checker.src/parser.mly @@ -156,7 +156,7 @@ sideff: /* An expression which may have a side-effect */ decl: | FORMAT BAREWORD ASSIGN {to_Call_op M_none "format" [Raw_string($2.any, get_pos $2) ; to_String false (new_1esp (fst $1.any) $1)] $1 $3} | FORMAT ASSIGN {new_esp M_none Too_complex $1 $2} -| func_decl semi_colon {if snd $1.any = None then die_rule "there is no need to pre-declare in Perl!" else (warn_rule "please don't use prototype pre-declaration" ; new_esp M_special Too_complex $1 $2) } +| func_decl semi_colon {if snd $1.any = None then die_rule "there is no need to pre-declare in Perl!" else (warn_rule [Warn_normalized_expressions] "please don't use prototype pre-declaration" ; new_esp M_special Too_complex $1 $2) } | func_decl BRACKET BRACKET_END {sp_n($2); sp_0_or_cr($3); let name, proto = $1.any in new_esp M_none (sub_declaration (name, proto) [] Real_sub_declaration) $1 $3} | func_decl BRACKET lines BRACKET_END {sp_n($2); check_block_sub $3 $4; new_esp M_none (sub_declaration $1.any $3.any Real_sub_declaration) $1 $4} | func_decl BRACKET BRACKET expr BRACKET_END BRACKET_END {sp_n($2); sp_p($3); sp_p($4); sp_p($5); sp_p($6); new_esp M_none (sub_declaration $1.any [hash_ref $4] Real_sub_declaration) $1 $6} @@ -182,7 +182,7 @@ use_revision: func_decl: | SUB word { new_esp M_none ($2.any, None) $1 $2} -| SUB BAREWORD_PAREN PAREN PAREN_END { warn_rule "remove carriage return between \"sub\" and the function name"; new_esp M_none (Ident(None, $2.any, get_pos $2), Some "") $1 $4 } +| SUB BAREWORD_PAREN PAREN PAREN_END { warn_rule [Warn_white_space] "remove carriage return between \"sub\" and the function name"; new_esp M_none (Ident(None, $2.any, get_pos $2), Some "") $1 $4 } | FUNC_DECL_WITH_PROTO {new_1esp (Ident(fst3 $1.any, snd3 $1.any, get_pos $1), Some (ter3 $1.any)) $1 } listexpr: /* Basic list expressions */ @@ -242,15 +242,15 @@ term: | term PATTERN_MATCH PATTERN_SUBST {sp_n($2); sp_p($3); check_unneeded_var_dollar_s ($1); to_Call_op_ (M_mixed[M_none; M_int]) P_expr "s///" ($1.any.expr :: from_PATTERN_SUBST $3) $1 $3} | term PATTERN_MATCH_NOT PATTERN_SUBST {die_with_rawpos $2.pos "use =~ instead of !~ and negate the return value"} -| term PATTERN_MATCH QR_PATTERN {warn $3.pos "use m/.../ or /.../ instead of qr/.../ when you do a pattern matching"; to_Call_op_ M_array P_expr "m//" ($1.any.expr :: from_PATTERN $3) $1 $3} -| term PATTERN_MATCH_NOT QR_PATTERN {warn $3.pos "use m/.../ or /.../ instead of qr/.../ when you do a pattern matching"; to_Call_op_ M_int P_expr "!m//" ($1.any.expr :: from_PATTERN $3) $1 $3} +| term PATTERN_MATCH QR_PATTERN {warn [Warn_traps] $3.pos "use m/.../ or /.../ instead of qr/.../ when you do a pattern matching"; to_Call_op_ M_array P_expr "m//" ($1.any.expr :: from_PATTERN $3) $1 $3} +| term PATTERN_MATCH_NOT QR_PATTERN {warn [Warn_traps] $3.pos "use m/.../ or /.../ instead of qr/.../ when you do a pattern matching"; to_Call_op_ M_int P_expr "!m//" ($1.any.expr :: from_PATTERN $3) $1 $3} | term PATTERN_MATCH scalar { new_pesp M_array P_expr (Call(Too_complex, [$1.any.expr ; $3.any ])) $1 $3} | term PATTERN_MATCH_NOT scalar { new_pesp M_int P_expr (Call(Too_complex, [$1.any.expr ; $3.any ])) $1 $3} -| term PATTERN_MATCH RAW_STRING {warn $3.pos "use a regexp, not a string"; to_Call_op_ M_array P_expr "m//" [ $1.any.expr; to_Raw_string $3 ] $1 $3} -| term PATTERN_MATCH_NOT RAW_STRING {warn $3.pos "use a regexp, not a string"; to_Call_op_ M_int P_expr "!m//" [ $1.any.expr; to_Raw_string $3 ] $1 $3} -| term PATTERN_MATCH STRING {warn $3.pos "use a regexp, not a string"; to_Call_op_ M_array P_expr "m//" [ $1.any.expr; to_String false $3 ] $1 $3} -| term PATTERN_MATCH_NOT STRING {warn $3.pos "use a regexp, not a string"; to_Call_op_ M_int P_expr "!m//" [ $1.any.expr; to_String false $3 ] $1 $3} +| term PATTERN_MATCH RAW_STRING {warn [Warn_complex_expressions] $3.pos "use a regexp, not a string"; to_Call_op_ M_array P_expr "m//" [ $1.any.expr; to_Raw_string $3 ] $1 $3} +| term PATTERN_MATCH_NOT RAW_STRING {warn [Warn_complex_expressions] $3.pos "use a regexp, not a string"; to_Call_op_ M_int P_expr "!m//" [ $1.any.expr; to_Raw_string $3 ] $1 $3} +| term PATTERN_MATCH STRING {warn [Warn_complex_expressions] $3.pos "use a regexp, not a string"; to_Call_op_ M_array P_expr "m//" [ $1.any.expr; to_String false $3 ] $1 $3} +| term PATTERN_MATCH_NOT STRING {warn [Warn_complex_expressions] $3.pos "use a regexp, not a string"; to_Call_op_ M_int P_expr "!m//" [ $1.any.expr; to_String false $3 ] $1 $3} | term QUESTION_MARK term COLON term {sp_p($2); sp_p($3); sp_p($4); sp_p($5); mcontext_check M_bool $1; to_Call_op_ (mcontext_merge $3.mcontext $5.mcontext) P_ternary "?:" (check_ternary_paras(prio_lo P_ternary $1, prio_lo_after P_ternary $3, prio_lo_after P_ternary $5)) $1 $5} @@ -263,13 +263,13 @@ term: sp_0($2); match $1.any with | "+" -> - warn_rule "don't use unary +" ; + warn_rule [Warn_normalized_expressions] "don't use unary +" ; to_Call_op_ (mcontext_float_or_int [$2.mcontext]) P_tight "+ unary" [$2.any.expr] $1 $2 | "-" -> (match $2.any.expr with | Ident(_, _, pos) when $2.spaces = Space_0 -> let s = "-" ^ string_of_Ident $2.any.expr in - warn_rule (Printf.sprintf "don't use %s, use '%s' instead" s s); + warn_rule [Warn_complex_expressions] (Printf.sprintf "don't use %s, use '%s' instead" s s); new_pesp M_string P_tok (Raw_string(s, pos)) $1 $2 | _ -> to_Call_op_ (mcontext_float_or_int [$2.mcontext]) P_tight "- unary" [$2.any.expr] $1 $2) | _ -> die_rule "syntax error" @@ -280,7 +280,7 @@ term: | DECR term {sp_0($2); mcontext_check M_int $2; to_Call_op_ (M_mixed [M_int ; M_none]) P_tight "--" [$2.any.expr] $1 $2} | term INCR {sp_0($2); mcontext_check M_int $1; to_Call_op_ (M_mixed [M_int ; M_none]) P_tight "++ post" [$1.any.expr] $1 $2} | term DECR {sp_0($2); mcontext_check M_int $1; to_Call_op_ (M_mixed [M_int ; M_none]) P_tight "-- post" [$1.any.expr] $1 $2} -| NOT argexpr {warn_rule "don't use \"not\", use \"!\" instead"; mcontext_check_unop_l M_bool $2; to_Call_op_ M_bool P_and "not" ($2.any.expr) $1 $2} +| NOT argexpr {warn_rule [Warn_normalized_expressions] "don't use \"not\", use \"!\" instead"; mcontext_check_unop_l M_bool $2; to_Call_op_ M_bool P_and "not" ($2.any.expr) $1 $2} /* Constructors for anonymous data */ @@ -340,7 +340,7 @@ term: | word BRACKET BRACKET expr BRACKET_END BRACKET_END listexpr %prec LSTOP {sp_n($2); sp_p($3); sp_p($4); sp_p($5); sp_p($6); new_pesp M_unknown (if $7.any.expr = [] then P_tok else P_call_no_paren) (call(Deref(I_func, $1.any), anonymous_sub None (new_esp (M_ref M_hash) [ hash_ref $4 ] $4 $4) :: $7.any.expr)) $1 $7} /* map { { foo } } @bar */ | word BRACKET BRACKET expr BRACKET_END semi_colon BRACKET_END listexpr %prec LSTOP {sp_n($2); sp_p($3); sp_p($4); sp_p($5); sp_p($7); new_pesp M_unknown (if $8.any.expr = [] then P_tok else P_call_no_paren) (call(Deref(I_func, $1.any), anonymous_sub None (new_esp (M_ref M_hash) [ hash_ref $4; Semi_colon ] $4 $4) :: $8.any.expr)) $1 $8} /* map { { foo }; } @bar */ -| term ARROW word_or_scalar parenthesized {sp_0($2); sp_0($3); sp_0($4); if $4.any.expr = [] then warn $4.pos "remove these unneeded parentheses"; new_pesp M_unknown P_tok (to_Method_call($1.any.expr, $3.any, $4.any.expr)) $1 $4} /* $foo->bar(list) */ +| term ARROW word_or_scalar parenthesized {sp_0($2); sp_0($3); sp_0($4); if $4.any.expr = [] then warn [Warn_suggest_simpler] $4.pos "remove these unneeded parentheses"; new_pesp M_unknown P_tok (to_Method_call($1.any.expr, $3.any, $4.any.expr)) $1 $4} /* $foo->bar(list) */ | term ARROW word_or_scalar {sp_0($2); sp_0($3); new_pesp M_unknown P_tok (to_Method_call($1.any.expr, $3.any, [])) $1 $3} /* $foo->bar */ | NEW word { sp_n($2); new_pesp (M_ref M_unknown) P_expr (to_Method_call ($2.any, Ident(None, "new", get_pos $1), [])) $1 $2} /* new Class */ @@ -405,7 +405,7 @@ restricted_subscripted: /* Some kind of subscripted expression */ | restricted_subscripted arrayref {sp_0($2); new_esp M_unknown_scalar (to_Deref_with(I_array, I_scalar, $1.any, only_one_array_ref $2)) $1 $2} /* $foo->[$bar][$baz] */ | restricted_subscripted parenthesized {sp_0($2); new_esp M_unknown (to_Deref_with(I_func , I_scalar, $1.any, List($2.any.expr))) $1 $2} /* $foo->{bar}(@args) */ -| restricted_subscripted ARROW word_or_scalar parenthesized {sp_0($2); sp_0($3); sp_0($4); if $4.any.expr = [] then warn $4.pos "remove these unneeded parentheses"; new_esp M_unknown (to_Method_call($1.any, $3.any, $4.any.expr)) $1 $4} /* $foo->bar(list) */ +| restricted_subscripted ARROW word_or_scalar parenthesized {sp_0($2); sp_0($3); sp_0($4); if $4.any.expr = [] then warn [Warn_suggest_simpler] $4.pos "remove these unneeded parentheses"; new_esp M_unknown (to_Method_call($1.any, $3.any, $4.any.expr)) $1 $4} /* $foo->bar(list) */ | restricted_subscripted ARROW word_or_scalar {sp_0($2); sp_0($3); new_esp M_unknown (to_Method_call($1.any, $3.any, [])) $1 $3} /* $foo->bar */ arrayref: diff --git a/perl_checker.src/parser_helper.ml b/perl_checker.src/parser_helper.ml index b4afdaf..bc22dd9 100644 --- a/perl_checker.src/parser_helper.ml +++ b/perl_checker.src/parser_helper.ml @@ -215,17 +215,16 @@ let rec get_pos_from_expr = function let msg_with_rawpos (start, end_) msg = Info.pos2sfull_current start end_ ^ msg let die_with_rawpos raw_pos msg = failwith (msg_with_rawpos raw_pos msg) -let warn raw_pos msg = print_endline_flush (msg_with_rawpos raw_pos msg) +let warn warn_types raw_pos msg = if Flags.are_warning_types_set warn_types then print_endline_flush (msg_with_rawpos raw_pos msg) let die_rule msg = die_with_rawpos (Parsing.symbol_start(), Parsing.symbol_end()) msg -let warn_rule msg = warn (Parsing.symbol_start(), Parsing.symbol_end()) msg -let debug msg = if true then print_endline_flush msg +let warn_rule warn_types msg = warn warn_types (Parsing.symbol_start(), Parsing.symbol_end()) msg -let warn_verb pos msg = if not !Flags.quiet then warn (pos, pos) msg -let warn_too_many_space start = warn_verb start "you should have only one space here" -let warn_no_space start = warn_verb start "you should have a space here" -let warn_cr start = warn_verb start "you should not have a carriage-return (\\n) here" -let warn_space start = warn_verb start "you should not have a space here" +let warn_verb warn_types pos msg = if not !Flags.quiet then warn warn_types (pos, pos) msg +let warn_too_many_space start = warn_verb [Warn_white_space] start "you should have only one space here" +let warn_no_space start = warn_verb [Warn_white_space] start "you should have a space here" +let warn_cr start = warn_verb [Warn_white_space] start "you should not have a carriage-return (\\n) here" +let warn_space start = warn_verb [Warn_white_space] start "you should not have a space here" let rec prio_less = function | P_none, _ | _, P_none -> internal_error "prio_less" @@ -285,13 +284,13 @@ let prio_lo_check pri_out pri_in pos expr = | P_paren pri_in' -> if pri_in' <> pri_out && prio_less(pri_in', pri_out) && not_complex (un_parenthesize expr) then - warn pos "unneeded parentheses" + warn [Warn_suggest_simpler] pos "unneeded parentheses" | _ -> ()) else (match expr with | Call_op ("print", [Deref (I_star, Ident (None, "STDOUT", _)); Deref(I_scalar, ident)], _) -> - warn pos (sprintf "use parentheses: replace \"print $%s ...\" with \"print($%s ...)\"" (string_of_Ident ident) (string_of_Ident ident)) - | _ -> warn pos "missing parentheses (needed for clarity)") + warn [Warn_traps] pos (sprintf "use parentheses: replace \"print $%s ...\" with \"print($%s ...)\"" (string_of_Ident ident) (string_of_Ident ident)) + | _ -> warn [Warn_traps] pos "missing parentheses (needed for clarity)") let prio_lo pri_out in_ = prio_lo_check pri_out in_.any.priority in_.pos in_.any.expr ; in_.any.expr @@ -347,7 +346,7 @@ let sp_cr esp = | Space_none -> () | Space_0 | Space_1 - | Space_n -> warn_verb (get_pos_start esp) "you should have a carriage-return (\\n) here" + | Space_n -> warn_verb [Warn_white_space] (get_pos_start esp) "you should have a carriage-return (\\n) here" | Space_cr -> () let sp_same esp1 esp2 = @@ -393,10 +392,10 @@ let word_alone esp = Deref(I_func, word) | "hex" | "ref" -> - warn_rule (sprintf "please use \"%s $_\" instead of \"%s\"" f f) ; + warn_rule [Warn_complex_expressions] (sprintf "please use \"%s $_\" instead of \"%s\"" f f) ; Call(Deref(I_func, word), [ Raw_string(" ", pos) ; var_dollar_ pos ]) | "time" | "wantarray" | "fork" | "getppid" | "arch" -> - warn_rule (sprintf "please use %s() instead of %s" f f) ; + warn_rule [Warn_complex_expressions] (sprintf "please use %s() instead of %s" f f) ; Deref(I_func, word) | _ -> word in @@ -429,9 +428,9 @@ let check_parenthesized_first_argexpr_with_Ident ident esp = | Ident(Some _, _, _) -> (match esp.any.expr with | [e] when is_parenthesized e -> () - | _ -> warn_rule "use parentheses around argument (otherwise it might cause syntax errors if the package is \"require\"d and not \"use\"d") + | _ -> warn_rule [Warn_suggest_simpler] "use parentheses around argument (otherwise it might cause syntax errors if the package is \"require\"d and not \"use\"d") | Ident(None, word, _) when List.mem word ["ref" ; "readlink"] -> - if esp.any.priority <> P_tok then warn_rule "use parentheses around argument" + if esp.any.priority <> P_tok then warn_rule [Warn_complex_expressions] "use parentheses around argument" | _ -> ()); check_parenthesized_first_argexpr (string_of_Ident ident) esp @@ -442,19 +441,19 @@ let check_hash_subscript esp = char_is_alpha s.[0] && (String.length s = 1 || string_forall_with char_is_alphanumerical_ 1 s) in match esp.any.expr with - | List [String ([(s, List [])], _)] when can_be_raw_string s -> warn esp.pos (sprintf "{\"%s\"} can be written {%s}" s s) - | List [Raw_string(s, _)] when can_be_raw_string s -> warn esp.pos (sprintf "{'%s'} can be written {%s}" s s) + | List [String ([(s, List [])], _)] when can_be_raw_string s -> warn [Warn_suggest_simpler] esp.pos (sprintf "{\"%s\"} can be written {%s}" s s) + | List [Raw_string(s, _)] when can_be_raw_string s -> warn [Warn_suggest_simpler] esp.pos (sprintf "{'%s'} can be written {%s}" s s) | _ -> () let check_arrow_needed esp1 esp2 = match esp1.any.expr with | Deref_with(I_array, I_scalar, List [List [Call _]], _) -> () (* "->" needed for (f())[0]->{XX} *) - | Deref_with _ -> warn esp2.pos "the arrow \"->\" is unneeded" + | Deref_with _ -> warn [Warn_suggest_simpler] esp2.pos "the arrow \"->\" is unneeded" | _ -> () let check_scalar_subscripted esp = match esp.any with - | Deref(I_scalar, Deref _) -> warn_rule "for complex dereferencing, use \"->\"" + | Deref(I_scalar, Deref _) -> warn_rule [Warn_complex_expressions] "for complex dereferencing, use \"->\"" | _ -> () let negatable_ops = collect (fun (a, b) -> [ a, b ; b, a ]) [ @@ -465,13 +464,13 @@ let negatable_ops = collect (fun (a, b) -> [ a, b ; b, a ]) [ let check_negatable_expr esp = match un_parenthesize_full esp.any.expr with | Call_op("m//", var :: _, _) when not (is_var_dollar_ var) -> - warn_rule "!($var =~ /.../) is better written $var !~ /.../" + warn_rule [Warn_suggest_simpler] "!($var =~ /.../) is better written $var !~ /.../" | Call_op("!m//", var :: _, _) when not (is_var_dollar_ var) -> - warn_rule "!($var !~ /.../) is better written $var =~ /.../" + warn_rule [Warn_suggest_simpler] "!($var !~ /.../) is better written $var =~ /.../" | Call_op(op, _, _) -> (try let neg_op = List.assoc op negatable_ops in - warn_rule (Printf.sprintf "!($foo %s $bar) is better written $foo %s $bar" op neg_op) + warn_rule [Warn_suggest_simpler] (Printf.sprintf "!($foo %s $bar) is better written $foo %s $bar" op neg_op) with Not_found -> ()) | _ -> () @@ -495,42 +494,42 @@ let check_ternary_paras(cond, a, b) = | e -> dont_need_short_circuit_rec e in let check_ternary_para = function - | List [] -> warn_rule "you may use if_() here\n beware that the short-circuit semantic of ?: is not kept\n if you want to keep the short-circuit behaviour, replace () with @{[]} and there will be no warning anymore" + | List [] -> warn_rule [Warn_suggest_simpler; Warn_MDK_Common] "you may use if_() here\n beware that the short-circuit semantic of ?: is not kept\n if you want to keep the short-circuit behaviour, replace () with @{[]} and there will be no warning anymore" | _ -> () in if dont_need_short_circuit a || is_same_fromparser cond a then check_ternary_para b; if dont_need_short_circuit b || is_same_fromparser cond b then check_ternary_para a; - if is_same_fromparser cond a && is_a_scalar a && is_a_scalar b then warn_rule "you can replace \"$foo ? $foo : $bar\" with \"$foo || $bar\""; + if is_same_fromparser cond a && is_a_scalar a && is_a_scalar b then warn_rule [Warn_suggest_simpler] "you can replace \"$foo ? $foo : $bar\" with \"$foo || $bar\""; [ cond; a; b ] let check_unneeded_var_dollar_ esp = - if is_var_dollar_ esp.any.expr then warn esp.pos "\"$_ =~ /regexp/\" can be written \"/regexp/\"" else - if is_var_number_match esp.any.expr then warn esp.pos "do not use the result of a match (eg: $1) to match another pattern" + if is_var_dollar_ esp.any.expr then warn [Warn_suggest_simpler] esp.pos "\"$_ =~ /regexp/\" can be written \"/regexp/\"" else + if is_var_number_match esp.any.expr then warn [Warn_complex_expressions] esp.pos "do not use the result of a match (eg: $1) to match another pattern" let check_unneeded_var_dollar_not esp = - if is_var_dollar_ esp.any.expr then warn esp.pos "\"$_ !~ /regexp/\" can be written \"!/regexp/\"" else - if is_var_number_match esp.any.expr then warn esp.pos "do not use the result of a match (eg: $1) to match another pattern" + if is_var_dollar_ esp.any.expr then warn [Warn_suggest_simpler] esp.pos "\"$_ !~ /regexp/\" can be written \"!/regexp/\"" else + if is_var_number_match esp.any.expr then warn [Warn_complex_expressions] esp.pos "do not use the result of a match (eg: $1) to match another pattern" let check_unneeded_var_dollar_s esp = let expr = esp.any.expr in - if is_var_dollar_ expr then warn esp.pos "\"$_ =~ s/regexp/.../\" can be written \"s/regexp/.../\"" else - if is_var_number_match expr then die_with_rawpos esp.pos "do not modify the result of a match (eg: $1)" else + if is_var_dollar_ expr then warn [Warn_suggest_simpler] esp.pos "\"$_ =~ s/regexp/.../\" can be written \"s/regexp/.../\"" else + if is_var_number_match expr then warn [Warn_traps] esp.pos "do not modify the result of a match (eg: $1)" else let expr = match expr with | List [List [Call_op("=", [ expr; _], _)]] -> expr (* check $xx in ($xx = ...) =~ ... *) | _ -> expr in - if is_a_string expr || not (is_a_scalar expr) then warn esp.pos "you can only use s/// on a variable" + if is_a_string expr || not (is_a_scalar expr) then warn [Warn_complex_expressions] esp.pos "you can only use s/// on a variable" let check_my esp = if esp.any <> "my" then die_rule "syntax error" -let check_foreach esp = if esp.any = "for" then warn esp.pos "write \"foreach\" instead of \"for\"" -let check_for esp = if esp.any = "foreach" then warn esp.pos "write \"for\" instead of \"foreach\"" +let check_foreach esp = if esp.any = "for" then warn [Warn_normalized_expressions] esp.pos "write \"foreach\" instead of \"for\"" +let check_for esp = if esp.any = "foreach" then warn [Warn_normalized_expressions] esp.pos "write \"for\" instead of \"foreach\"" let check_for_foreach esp arg = match arg.any.expr with | List [ Deref(I_scalar, _) ] -> - if esp.any = "foreach" then warn esp.pos "you are using the special fpons trick to locally set $_ with a value, for this please use \"for\" instead of \"foreach\"" + if esp.any = "foreach" then warn [Warn_normalized_expressions] esp.pos "you are using the special trick to locally set $_ with a value, for this please use \"for\" instead of \"foreach\"" | List [ Deref_with(context, I_scalar, _, _) ] when context <> I_func -> - if esp.any = "foreach" then warn esp.pos "you are using the special fpons trick to locally set $_ with a value, for this please use \"for\" instead of \"foreach\"" + if esp.any = "foreach" then warn [Warn_normalized_expressions] esp.pos "you are using the special trick to locally set $_ with a value, for this please use \"for\" instead of \"foreach\"" | List [ Deref(I_hash, _) ] -> - warn esp.pos "foreach with a hash is usually an error" + warn [Warn_traps] esp.pos "foreach with a hash is usually an error" | _ -> - if esp.any = "for" then warn esp.pos "write \"foreach\" instead of \"for\"" + if esp.any = "for" then warn [Warn_normalized_expressions] esp.pos "write \"foreach\" instead of \"for\"" let check_block_sub esp_lines esp_BRACKET_END = match esp_lines.any with @@ -541,7 +540,7 @@ let check_block_sub esp_lines esp_BRACKET_END = sp_p esp_BRACKET_END ; if esp_BRACKET_END.spaces <> Space_cr then - (if last l = Semi_colon then warn_verb (get_pos_end esp_lines) "spurious \";\" before closing block") + (if last l = Semi_colon then warn_verb [Warn_white_space] (get_pos_end esp_lines) "spurious \";\" before closing block") let check_block_ref esp_lines esp_BRACKET_END = let l = esp_lines.any in @@ -550,11 +549,11 @@ let check_block_ref esp_lines esp_BRACKET_END = else sp_same esp_lines esp_BRACKET_END ; if esp_BRACKET_END.spaces <> Space_cr then - (if l <> [] && last l = Semi_colon then warn_verb (get_pos_end esp_lines) "spurious \";\" before closing block") + (if l <> [] && last l = Semi_colon then warn_verb [Warn_white_space] (get_pos_end esp_lines) "spurious \";\" before closing block") let check_unless_else elsif else_ = - if elsif.any <> [] then warn elsif.pos "don't use \"elsif\" with \"unless\" (replace \"unless\" with \"if\")"; - if else_.any <> [] then warn else_.pos "don't use \"else\" with \"unless\" (replace \"unless\" with \"if\")" + if elsif.any <> [] then warn [Warn_complex_expressions] elsif.pos "don't use \"elsif\" with \"unless\" (replace \"unless\" with \"if\")"; + if else_.any <> [] then warn [Warn_complex_expressions] else_.pos "don't use \"else\" with \"unless\" (replace \"unless\" with \"if\")" let check_my_our_paren { any = ((comma_closed, _), l) } after_esp = (if l = [] then sp_0 else sp_1) after_esp ; @@ -566,7 +565,7 @@ let check_simple_pattern = function st.[0] = '^' && st.[String.length st - 1] = '$' then let st = skip_n_char_ 1 1 st in if string_forall_with char_is_alphanumerical_ 0 st then - warn_rule (sprintf "\"... =~ /^%s$/\" is better written \"... eq '%s'\"" st st) + warn_rule [Warn_suggest_simpler] (sprintf "\"... =~ /^%s$/\" is better written \"... eq '%s'\"" st st) | _ -> () let rec only_one esp = @@ -580,7 +579,7 @@ let only_one_array_ref esp = let e = only_one esp in (match e with | Call_op("last_array_index", [Deref(I_array, e)], _) -> - warn esp.pos (sprintf "you can replace $#%s with -1" (string_of_Ident e)) + warn [Warn_suggest_simpler] esp.pos (sprintf "you can replace $#%s with -1" (string_of_Ident e)) | _ -> ()); e @@ -610,7 +609,7 @@ let deref_raw context e = let fq, ident = split_name_or_fq_name s in Ident(fq, ident, pos) | Deref(I_scalar, (Ident _ as ident)) -> - warn_rule (sprintf "%s{$%s} can be written %s$%s" (context2s context) (string_of_Ident ident) (context2s context) (string_of_Ident ident)); + warn_rule [Warn_suggest_simpler] (sprintf "%s{$%s} can be written %s$%s" (context2s context) (string_of_Ident ident) (context2s context) (string_of_Ident ident)); e | _ -> e in Deref(context, e) @@ -623,7 +622,7 @@ let to_Method_call (object_, method_, para) = | Ident(Some _, _, _) -> Call(Deref(I_func, method_), maybe_to_Raw_string object_ :: para) | _ -> Method_call(maybe_to_Raw_string object_, maybe_to_Raw_string method_, para) let to_Deref_with(from_context, to_context, ref_, para) = - if is_not_a_scalar ref_ then warn_rule "bad deref"; + if is_not_a_scalar ref_ then warn_rule [] "bad deref"; Deref_with(from_context, to_context, ref_, para) @@ -660,73 +659,73 @@ let remove_call_with_same_para_special = function let check_My_under_condition msg = function | List [ My_our("my", _, _) ] -> - warn_rule "this is stupid" + warn_rule [Warn_traps] "this is stupid" | List [ Call_op("=", [ My_our("my", _, _); _ ], _) ] -> - warn_rule msg + warn_rule [Warn_traps] msg | _ -> () let cook_call_op op para pos = (match op with | "le" | "ge" | "eq" | "ne" | "gt" | "lt" | "cmp" -> if List.exists (function Num _ -> true | _ -> false) para then - warn_rule (sprintf "you should use a number operator, not the string operator \"%s\" (or replace the number with a string)" op) + warn_rule [Warn_traps] (sprintf "you should use a number operator, not the string operator \"%s\" (or replace the number with a string)" op) | "." -> if List.exists (function Call(Deref(I_func, Ident(None, "N_", _)), _) -> true | _ -> false) para then - warn_rule "N_(\"xxx\") . \"yyy\" is dumb since the string \"xxx\" will never get translated" + warn_rule [Warn_MDK_Common; Warn_traps] "N_(\"xxx\") . \"yyy\" is dumb since the string \"xxx\" will never get translated" | _ -> ()); (match op, para with | "if", List [Call_op ("=", [ _; e ], _)] :: _ when is_always_true e || is_always_false e -> - warn_rule "are you sure you did not mean \"==\" instead of \"=\"?" + warn_rule [Warn_traps] "are you sure you did not mean \"==\" instead of \"=\"?" | "foreach", [ _; Block [ expr ; Semi_colon ] ] | "foreach", [ _; Block [ expr ] ] -> (match expr with | Call_op("if infix", [ List [ Call(Deref(I_func, Ident(None, "push", _)), [ Deref(I_array, (Ident _ as l)) ; Deref(I_scalar, Ident(None, "_", _)) ]) ] ; _ ], _) -> let l = string_of_Ident l in - warn_rule (sprintf "use \"push @%s, grep { ... } ...\" instead of \"foreach (...) { push @%s, $_ if ... }\"\n or sometimes \"@%s = grep { ... } ...\"" l l l) + warn_rule [Warn_suggest_functional] (sprintf "use \"push @%s, grep { ... } ...\" instead of \"foreach (...) { push @%s, $_ if ... }\"\n or sometimes \"@%s = grep { ... } ...\"" l l l) | Call_op("if infix", [ List [ Call(Deref(I_func, Ident(None, "push", _)), [ Deref(I_array, (Ident _ as l)); _ ]) ] ; _ ], _) -> let l = string_of_Ident l in - warn_rule (sprintf "use \"push @%s, map { ... ? ... : () } ...\" instead of \"foreach (...) { push @%s, ... if ... }\"\n or sometimes \"@%s = map { ... ? ... : () } ...\"\n or sometimes \"@%s = map { if_(..., ...) } ...\"" l l l l) + warn_rule [Warn_suggest_functional] (sprintf "use \"push @%s, map { ... ? ... : () } ...\" instead of \"foreach (...) { push @%s, ... if ... }\"\n or sometimes \"@%s = map { ... ? ... : () } ...\"\n or sometimes \"@%s = map { if_(..., ...) } ...\"" l l l l) | List [ Call(Deref(I_func, Ident(None, "push", _)), [ Deref(I_array, (Ident _ as l)); _ ]) ] -> let l = string_of_Ident l in - warn_rule (sprintf "use \"push @%s, map { ... } ...\" instead of \"foreach (...) { push @%s, ... }\"\n or sometimes \"@%s = map { ... } ...\"" l l l) + warn_rule [Warn_suggest_functional] (sprintf "use \"push @%s, map { ... } ...\" instead of \"foreach (...) { push @%s, ... }\"\n or sometimes \"@%s = map { ... } ...\"" l l l) | _ -> ()) | "=", [My_our _; Ident(None, "undef", _)] -> - warn pos "no need to initialize variable, it's done by default" + warn [Warn_suggest_simpler] pos "no need to initialize variable, it's done by default" | "=", [My_our _; List[]] -> - if Info.is_on_same_line_current pos then warn pos "no need to initialize variables, it's done by default" + if Info.is_on_same_line_current pos then warn [Warn_suggest_simpler] pos "no need to initialize variables, it's done by default" | "=", [ Deref_with(I_array, I_scalar, id, Deref(I_array, id_)); _ ] when is_same_fromparser id id_ -> - warn_rule "\"$a[@a] = ...\" is better written \"push @a, ...\"" + warn_rule [Warn_suggest_simpler] "\"$a[@a] = ...\" is better written \"push @a, ...\"" | "=", [ Deref(I_star, String ([(sf1, List [])], _)); _ ] -> - warn_rule (sprintf "write *{'%s'} instead of *{\"%s\"}" sf1 sf1) + warn_rule [Warn_help_perl_checker] (sprintf "write *{'%s'} instead of *{\"%s\"}" sf1 sf1) | "||=", List [ List _ ] :: _ - | "&&=", List [ List _ ] :: _ -> warn_rule "remove the parentheses" + | "&&=", List [ List _ ] :: _ -> warn_rule [Warn_complex_expressions] "remove the parentheses" | "||=", e :: _ - | "&&=", e :: _ -> if is_not_a_scalar e then warn_rule (sprintf "\"%s\" is only useful with a scalar" op) + | "&&=", e :: _ -> if is_not_a_scalar e then warn_rule [Warn_traps] (sprintf "\"%s\" is only useful with a scalar" op) | "==", [Call_op("last_array_index", _, _); Num(n, _)] -> - warn_rule (sprintf "$#x == %s is better written @x == %d" n (1 + int_of_string n)) + warn_rule [Warn_suggest_simpler] (sprintf "$#x == %s is better written @x == %d" n (1 + int_of_string n)) | "==", [Call_op("last_array_index", _, _); Call_op("- unary", [Num (n, _)], _)] -> - warn_rule (sprintf "$#x == -%s is better written @x == %d" n (1 - int_of_string n)) + warn_rule [Warn_suggest_simpler] (sprintf "$#x == -%s is better written @x == %d" n (1 - int_of_string n)) - | "||", e :: _ when is_always_true e -> warn_rule "<constant> || ... is the same as <constant>" - | "&&", e :: _ when is_always_false e -> warn_rule "<constant> && ... is the same as <constant>" - | "||", e :: _ when is_always_false e -> warn_rule "<constant> || ... is the same as ..." - | "&&", e :: _ when is_always_true e -> warn_rule "<constant> && ... is the same as ..." + | "||", e :: _ when is_always_true e -> warn_rule [Warn_strange] "<constant> || ... is the same as <constant>" + | "&&", e :: _ when is_always_false e -> warn_rule [Warn_strange] "<constant> && ... is the same as <constant>" + | "||", e :: _ when is_always_false e -> warn_rule [Warn_strange] "<constant> || ... is the same as ..." + | "&&", e :: _ when is_always_true e -> warn_rule [Warn_strange] "<constant> && ... is the same as ..." - | "or", e :: _ when is_always_true (un_parenthesize_full e) -> warn_rule "<constant> or ... is the same as <constant>" - | "and", e :: _ when is_always_false (un_parenthesize_full e) -> warn_rule "<constant> and ... is the same as <constant>" - | "or", e :: _ when is_always_false (un_parenthesize_full e) -> warn_rule "<constant> or ... is the same as ..." - | "and", e :: _ when is_always_true (un_parenthesize_full e) -> warn_rule "<constant> and ... is the same as ..." + | "or", e :: _ when is_always_true (un_parenthesize_full e) -> warn_rule [Warn_strange] "<constant> or ... is the same as <constant>" + | "and", e :: _ when is_always_false (un_parenthesize_full e) -> warn_rule [Warn_strange] "<constant> and ... is the same as <constant>" + | "or", e :: _ when is_always_false (un_parenthesize_full e) -> warn_rule [Warn_strange] "<constant> or ... is the same as ..." + | "and", e :: _ when is_always_true (un_parenthesize_full e) -> warn_rule [Warn_strange] "<constant> and ... is the same as ..." | "or", [ List [ Deref(I_scalar, id) ]; List [ Call_op("=", [ Deref(I_scalar, id_); _], _) ] ] when is_same_fromparser id id_ -> - warn_rule "\"$foo or $foo = ...\" can be written \"$foo ||= ...\"" + warn_rule [Warn_suggest_simpler] "\"$foo or $foo = ...\" can be written \"$foo ||= ...\"" | "and", [ _cond ; expr ] -> check_My_under_condition "replace \"<cond> and my $foo = ...\" with \"my $foo = <cond> && ...\"" expr | "or", [ _cond ; expr ] -> check_My_under_condition "replace \"<cond> or my $foo = ...\" with \"my $foo = !<cond> && ...\"" expr @@ -736,11 +735,11 @@ let cook_call_op op para pos = match op, para with | "=", [ Deref(I_star, (Ident _ as f1)); Deref(I_star, (Ident _ as f2)) ] -> let s1, s2 = string_of_Ident f1, string_of_Ident f2 in - warn pos (sprintf "\"*%s = *%s\" is better written \"*%s = \\&%s\"" s1 s2 s1 s2) ; + warn [Warn_complex_expressions] pos (sprintf "\"*%s = *%s\" is better written \"*%s = \\&%s\"" s1 s2 s1 s2) ; sub_declaration (f1, None) [ call_with_same_para_special(Deref(I_func, f2)) ] Glob_assign | "=", [ Deref(I_star, Raw_string(sf1, pos_f1)); Deref(I_star, (Ident _ as f2)) ] -> let s2 = string_of_Ident f2 in - warn pos (sprintf "\"*{'%s'} = *%s\" is better written \"*{'%s'} = \\&%s\"" sf1 s2 sf1 s2) ; + warn [Warn_help_perl_checker] pos (sprintf "\"*{'%s'} = *%s\" is better written \"*{'%s'} = \\&%s\"" sf1 s2 sf1 s2) ; sub_declaration (Ident(None, sf1, pos_f1), None) [ call_with_same_para_special(Deref(I_func, f2)) ] Glob_assign | "=", [ Deref(I_star, (Ident _ as f1)); Ref(I_scalar, Deref(I_func, (Ident _ as f2))) ] -> @@ -760,7 +759,7 @@ let to_Call_op_ mcontext prio op para esp_start esp_end = let pos = raw_pos_range esp_start esp_end in new_any mcontext { priority = prio ; expr = cook_call_op op para pos } esp_start.spaces pos let to_Call_assign_op_ mcontext prio op left right esp_left esp_end = - if not (is_lvalue left) then warn esp_left.pos "invalid lvalue"; + if not (is_lvalue left) then warn [Warn_strange] esp_left.pos "invalid lvalue"; to_Call_op_ mcontext prio op [ left ; right ] esp_left esp_end let followed_by_comma expr true_comma = @@ -784,10 +783,10 @@ let check_format_a_la_printf s pos = | '%' -> contexts | 'd' -> M_int :: contexts | 's' | 'c' -> M_string :: contexts - | c -> warn (pos + i', pos + i') (sprintf "invalid command %%%c" c); contexts + | c -> warn [Warn_strange] (pos + i', pos + i') (sprintf "invalid command %%%c" c); contexts in check_format_a_la_printf_ contexts (i' + 2) - with Invalid_argument _ -> warn (pos + i', pos + i') "invalid command %" ; contexts + with Invalid_argument _ -> warn [Warn_strange] (pos + i', pos + i') "invalid command %" ; contexts with Not_found -> contexts in check_format_a_la_printf_ [] 0 @@ -851,18 +850,18 @@ let check_system_call = function let has_p = List.exists (str_begins_with "-p") l in let has_m = List.exists (str_begins_with "-m") l in if has_p && has_m then () - else if has_p then warn_rule "you can replace system(\"mkdir -p ...\") with mkdir_p(...)" - else if has_m then warn_rule "you can replace system(\"mkdir -m <mode> ...\") with mkdir(..., <mode>)" - else warn_rule "you can replace system(\"mkdir ...\") with mkdir(...)" + else if has_p then warn_rule [Warn_suggest_simpler; Warn_MDK_Common] "you can replace system(\"mkdir -p ...\") with mkdir_p(...)" + else if has_m then warn_rule [Warn_suggest_simpler; Warn_MDK_Common] "you can replace system(\"mkdir -m <mode> ...\") with mkdir(..., <mode>)" + else warn_rule [Warn_suggest_simpler; Warn_MDK_Common] "you can replace system(\"mkdir ...\") with mkdir(...)" | _ -> () let call_raw force_non_builtin_func (e, para) = let check_anonymous_block f = function | [ Anonymous_sub _ ; Deref (I_hash, _) ] -> - warn_rule ("a hash is not a valid parameter to function " ^ f) + warn_rule [Warn_strange] ("a hash is not a valid parameter to function " ^ f) | Anonymous_sub _ :: _ -> () - | _ -> warn_rule (sprintf "always use \"%s\" with a block (eg: %s { ... } @list)" f f) + | _ -> warn_rule [Warn_complex_expressions] (sprintf "always use \"%s\" with a block (eg: %s { ... } @list)" f f) in match e with @@ -870,21 +869,21 @@ let call_raw force_non_builtin_func (e, para) = (match f with | "join" -> (match un_parenthesize_full_l para with - | e :: _ when not (is_a_scalar e) -> warn_rule "first argument of join() must be a scalar"; - | [_] -> warn_rule "not enough parameters" - | [_; e] when is_a_scalar e -> warn_rule "join('...', $foo) is the same as $foo" + | e :: _ when not (is_a_scalar e) -> warn_rule [Warn_traps] "first argument of join() must be a scalar"; + | [_] -> warn_rule [Warn_traps] "not enough parameters" + | [_; e] when is_a_scalar e -> warn_rule [Warn_traps] "join('...', $foo) is the same as $foo" | _ -> ()) | "length" -> - if para = [] then warn_rule "length() with no parameter !?" else - if is_not_a_scalar (List.hd para) then warn_rule "never use \"length @l\", it returns the length of the string int(@l)" ; + if para = [] then warn_rule [Warn_complex_expressions] (sprintf "please use \"%s $_\" instead of \"%s\"" f f) else + if is_not_a_scalar (List.hd para) then warn_rule [Warn_traps] "never use \"length @l\", it returns the length of the string int(@l)" ; | "open" -> (match para with | [ List(Ident(None, name, _) :: _) ] | Ident(None, name, _) :: _ -> if not (List.mem name [ "STDIN" ; "STDOUT" ; "STDERR" ]) then - warn_rule (sprintf "use a scalar instead of a bareword (eg: occurrences of %s with $%s)" name name) + warn_rule [Warn_complex_expressions] (sprintf "use a scalar instead of a bareword (eg: occurrences of %s with $%s)" name name) | _ -> ()) | "N" | "N_" -> @@ -897,9 +896,9 @@ let call_raw force_non_builtin_func (e, para) = let contexts = check_format_a_la_printf s pos_offset in if f = "N" then if List.length para < List.length contexts then - warn_rule "not enough parameters" + warn_rule [Warn_traps; Warn_MDK_Common] "not enough parameters" else if List.length para > List.length contexts then - warn_rule "too many parameters" ; + warn_rule [Warn_traps; Warn_MDK_Common] "too many parameters" ; (*if String.contains s '\t' then warn_rule "tabulation in translated string must be written \\\\t";*) (*if count_matching_char s '\n' > 10 then warn_rule "long string";*) | [ List(String _ :: _) ] -> die_rule "don't use interpolated translated string, use %s or %d instead" @@ -907,7 +906,7 @@ let call_raw force_non_builtin_func (e, para) = | "if_" -> (match para with - | [ List [ _ ] ] -> warn_rule "not enough parameters"; + | [ List [ _ ] ] -> warn_rule [Warn_traps; Warn_MDK_Common] "not enough parameters"; | _ -> ()) | "map" -> @@ -915,15 +914,15 @@ let call_raw force_non_builtin_func (e, para) = | Anonymous_sub(None, Block [ List [ Call(Deref(I_func, Ident(None, "if_", _)), [ List [ _ ; Deref(I_scalar, Ident(None, "_", _)) ] ]) ] ], _) :: _ -> - warn_rule "you can replace \"map { if_(..., $_) }\" with \"grep { ... }\"" + warn_rule [Warn_suggest_simpler; Warn_MDK_Common] "you can replace \"map { if_(..., $_) }\" with \"grep { ... }\"" | _ -> check_anonymous_block f para) | "grep" -> (match para with | [ Anonymous_sub(None, Block [ List [ Call_op("not", [ Call(Deref(I_func, Ident(None, "member", _)), [ List(Deref(I_scalar, Ident(None, "_", _)) :: _) ]) ], _) ] ], _); _ ] -> - warn_rule "you can replace \"grep { !member($_, ...) } @l\" with \"difference2([ @l ], [ ... ])\"" + warn_rule [Warn_suggest_simpler; Warn_MDK_Common] "you can replace \"grep { !member($_, ...) } @l\" with \"difference2([ @l ], [ ... ])\"" | [ Anonymous_sub(None, Block [ List [ Call(Deref(I_func, Ident(None, "member", _)), [ List(Deref(I_scalar, Ident(None, "_", _)) :: _) ]) ] ], _); _ ] -> - warn_rule "you can replace \"grep { member($_, ...) } @l\" with \"intersection([ @l ], [ ... ])\"" + warn_rule [Warn_suggest_simpler; Warn_MDK_Common] "you can replace \"grep { member($_, ...) } @l\" with \"intersection([ @l ], [ ... ])\"" | _ -> check_anonymous_block f para) | "any" -> @@ -931,7 +930,7 @@ let call_raw force_non_builtin_func (e, para) = [Anonymous_sub (None, Block [ List [ Call_op("eq", [Deref(I_scalar, Ident(None, "_", _)); _ ], _) ] ], _); _ ] -> - warn_rule "you can replace \"any { $_ eq ... } @l\" with \"member(..., @l)\"" + warn_rule [Warn_suggest_simpler; Warn_MDK_Common] "you can replace \"any { $_ eq ... } @l\" with \"member(..., @l)\"" | _ -> check_anonymous_block f para) | "grep_index" | "map_index" | "partition" | "uniq_" @@ -943,7 +942,7 @@ let call_raw force_non_builtin_func (e, para) = | "member" -> (match para with [ List [ _; Call(Deref(I_func, Ident(None, "keys", _)), _) ] ] -> - warn_rule "you can replace \"member($xxx, keys %yyy)\" with \"exists $yyy{$xxx}\"" + warn_rule [Warn_suggest_simpler; Warn_MDK_Common] "you can replace \"member($xxx, keys %yyy)\" with \"exists $yyy{$xxx}\"" | _ -> ()) | "pop" | "shift" -> @@ -951,14 +950,14 @@ let call_raw force_non_builtin_func (e, para) = | [] | [ Deref(I_array, _) ] | [ List [ Deref(I_array, _) ] ] -> () - | _ -> warn_rule (f ^ " is expecting an array and nothing else")) + | _ -> warn_rule [Warn_traps] (f ^ " is expecting an array and nothing else")) | "push" | "unshift" -> (match para with | Deref(I_array, _) :: l | [ List (Deref(I_array, _) :: l) ] -> - if l = [] then warn_rule ("you must give some arguments to " ^ f) - | _ -> warn_rule (f ^ " is expecting an array")) + if l = [] then warn_rule [Warn_traps] ("you must give some arguments to " ^ f) + | _ -> warn_rule [Warn_traps] (f ^ " is expecting an array")) | "system" -> (match un_parenthesize_full_l para with @@ -967,7 +966,7 @@ let call_raw force_non_builtin_func (e, para) = | Some s -> if List.exists (String.contains s) [ '\'' ; char_quote ] && not (List.exists (String.contains s) [ '<' ; '>' ; '&' ; ';']) then - warn_rule "instead of quoting parameters you should give a list of arguments"; + warn_rule [Warn_complex_expressions] "instead of quoting parameters you should give a list of arguments"; check_system_call (split_at ' ' s) | None -> ()) | l -> @@ -1037,7 +1036,7 @@ let call_one_scalar_para { any = e ; pos = pos } para esp_start esp_end = if e = "shift" || e = "pop" then [] (* can't decide here *) else - (if not (List.mem e [ "length" ]) then warn_rule (sprintf "please use \"%s $_\" instead of \"%s\"" e e) ; + (if not (List.mem e [ "length" ]) then warn_rule [Warn_complex_expressions] (sprintf "please use \"%s $_\" instead of \"%s\"" e e) ; [var_dollar_ (raw_pos2pos pos)]) | _ -> para in @@ -1072,13 +1071,13 @@ let to_String parse strict { any = l ; pos = pos } = let l' = parse_interpolated parse l in (match l' with | [ "", List [Deref(I_scalar, Ident(None, ident, _))]] -> - if ident <> "!" && strict then warn pos (sprintf "%s is better written without the double quotes" (variable2s(I_scalar, ident))) + if ident <> "!" && strict then warn [Warn_suggest_simpler] pos (sprintf "%s is better written without the double quotes" (variable2s(I_scalar, ident))) | [ "", List [Deref(I_hash, _)]] -> - warn pos "don't use a hash in string context" + warn [Warn_traps] pos "don't use a hash in string context" | [ "", List [Deref(I_array, _)]] -> () | [("", _)] -> - if strict then warn pos "double quotes are unneeded" + if strict then warn [Warn_suggest_simpler] pos "double quotes are unneeded" | _ -> ()); String(l', raw_pos2pos pos) @@ -1087,9 +1086,9 @@ let from_PATTERN parse { any = (s, opts) ; pos = pos } = (match List.rev re with | (s, List []) :: _ -> if str_ends_with s ".*" then - warn_rule (sprintf "you can remove \"%s\" at the end of your regexp" ".*") + warn_rule [Warn_suggest_simpler] (sprintf "you can remove \"%s\" at the end of your regexp" ".*") else if str_ends_with s ".*$" then - warn_rule (sprintf "you can remove \"%s\" at the end of your regexp" ".*$") + warn_rule [Warn_suggest_simpler] (sprintf "you can remove \"%s\" at the end of your regexp" ".*$") | _ -> ()); let pattern = [ String(re, raw_pos2pos pos) ; Raw_string(opts, raw_pos2pos pos) ] in check_simple_pattern pattern; @@ -1213,7 +1212,7 @@ let mcontext_lmaybe esp = if esp.any = [] then [] else [esp.mcontext] let mcontext_check_raw wanted_mcontext mcontext = if not (mcontext_lower mcontext wanted_mcontext) then - warn_rule (sprintf "context %s is not compatible with context %s" (mcontext2s mcontext) (mcontext2s wanted_mcontext)) + warn_rule [Warn_context] (sprintf "context %s is not compatible with context %s" (mcontext2s mcontext) (mcontext2s wanted_mcontext)) let mcontext_check wanted_mcontext esp = (match wanted_mcontext with @@ -1221,7 +1220,7 @@ let mcontext_check wanted_mcontext esp = | _ -> match un_parenthesize_full esp.any.expr with | Call(Deref(I_func, Ident(None, "grep", _)), _) -> - warn_rule (if wanted_mcontext = M_bool then + warn_rule [Warn_suggest_simpler; Warn_help_perl_checker] (if wanted_mcontext = M_bool then "in boolean context, use \"any\" instead of \"grep\"" else "you may use \"find\" instead of \"grep\"") | _ -> ()); @@ -1231,7 +1230,7 @@ let mcontext_check_unop_l wanted_mcontext esp = mcontext_check wanted_mcontext { esp with any = { esp.any with expr = List esp.any.expr } } let mcontext_check_non_none esp = - if esp.mcontext = M_none then warn_rule "() context not accepted here" + if esp.mcontext = M_none then warn_rule [Warn_context] "() context not accepted here" let mcontext_check_none msg expr esp = let rec mcontext_check_none_rec msg expr = function @@ -1253,8 +1252,8 @@ let mcontext_check_none msg expr esp = match expr with | [List [Num("1", _)]; Semi_colon] -> () (* allow "1;" for package return value. It would be much better to check we are at toplevel, but hell i don't want to wire this information up to here *) | [List [Call_op ("<>", [Ident (None, "STDIN", _)], _)]; Semi_colon] -> () (* allow <STDIN> to ask "press return" *) - | [List [Call(Deref(I_func, Ident(None, "map", _)), _)]; Semi_colon] -> warn_rule "if you don't use the return value, use \"foreach\" instead of \"map\"" - | _ -> warn esp.pos msg + | [List [Call(Deref(I_func, Ident(None, "map", _)), _)]; Semi_colon] -> warn_rule [Warn_void] "if you don't use the return value, use \"foreach\" instead of \"map\"" + | _ -> warn [Warn_void] esp.pos msg in mcontext_check_none_rec msg expr esp.mcontext @@ -1298,7 +1297,7 @@ let call_op_if_infix left right esp_start esp_end = | List [Call_op("=", [Deref(context, _); _], _)], _ when non_scalar_context context -> () | List [Call_op("=", [v; _], _)], List [Call_op("not", [v'], _)] when is_same_fromparser v v' -> - warn_rule "\"$foo = ... if !$foo\" can be written \"$foo ||= ...\"" + warn_rule [Warn_suggest_simpler] "\"$foo = ... if !$foo\" can be written \"$foo ||= ...\"" | _ -> ()); mcontext_check_none "value is dropped" [left] esp_start; @@ -1313,12 +1312,12 @@ let call_op_unless_infix left right esp_start esp_end = (match left, right with | List [Call_op("=", [Deref(context, _); _], _)], _ when non_scalar_context context -> () | List [Call_op("=", [v; _], _)], List [v'] when is_same_fromparser v v' -> - warn_rule "\"$foo = ... unless $foo\" can be written \"$foo ||= ...\"" + warn_rule [Warn_suggest_simpler] "\"$foo = ... unless $foo\" can be written \"$foo ||= ...\"" | _ -> ()); (match right with | List [Call_op(op, _, _)] -> (match op with - | "&&" | "||" | "not" | "ne" | "?:" -> warn_rule "don't use \"unless\" when the condition is complex, use \"if\" instead" + | "&&" | "||" | "not" | "ne" | "?:" -> warn_rule [Warn_complex_expressions] "don't use \"unless\" when the condition is complex, use \"if\" instead" | _ -> ()); | _ -> ()); @@ -1337,7 +1336,7 @@ let symops pri para_context return_context op_str left op right = in if op_str <> "==" && op_str <> "!=" && para_context = M_float then (match un_parenthesize_full left.any.expr with - | Call_op("last_array_index", _, _) -> warn_rule "change your expression to use @xxx instead of $#xxx" + | Call_op("last_array_index", _, _) -> warn_rule [Warn_complex_expressions] "change your expression to use @xxx instead of $#xxx" | _ -> ()); if not skip_context_check then diff --git a/perl_checker.src/parser_helper.mli b/perl_checker.src/parser_helper.mli index ecd5095..952963a 100644 --- a/perl_checker.src/parser_helper.mli +++ b/perl_checker.src/parser_helper.mli @@ -57,11 +57,10 @@ val from_array : Types.fromparser Types.any_spaces_pos -> Types.fromparser val get_pos_from_expr : Types.fromparser -> Types.pos val msg_with_rawpos : int * int -> string -> string val die_with_rawpos : int * int -> string -> 'a -val warn : int * int -> string -> unit +val warn : Types.warning list -> int * int -> string -> unit val die_rule : string -> 'a -val warn_rule : string -> unit -val debug : string -> unit -val warn_verb : int -> string -> unit +val warn_rule : Types.warning list -> string -> unit +val warn_verb : Types.warning list -> int -> string -> unit val warn_too_many_space : int -> unit val warn_no_space : int -> unit val warn_cr : int -> unit @@ -167,6 +166,7 @@ val anonymous_sub : Types.fromparser list Types.any_spaces_pos -> Types.fromparser val call_with_same_para_special : Types.fromparser -> Types.fromparser val remove_call_with_same_para_special : Types.fromparser -> Types.fromparser +val check_My_under_condition : string -> Types.fromparser -> unit val cook_call_op : string -> Types.fromparser list -> int * int -> Types.fromparser val to_Call_op : @@ -199,6 +199,9 @@ val po_comments : string list ref val po_comment : string Types.any_spaces_pos -> unit val check_format_a_la_printf : string -> int -> Types.maybe_context list val generate_pot : string -> unit +val fake_string_from_String_l : (string * 'a) list -> string +val fake_string_option_from_expr : Types.fromparser -> string option +val check_system_call : string list -> unit val call_raw : bool -> Types.fromparser * Types.fromparser list -> Types.fromparser val call : Types.fromparser * Types.fromparser list -> Types.fromparser @@ -230,16 +233,6 @@ val call_one_scalar_para : 'a Types.any_spaces_pos -> 'b Types.any_spaces_pos -> Types.fromparser Types.prio_anyexpr Types.any_spaces_pos -val call_op_if_infix : - Types.fromparser -> - Types.fromparser -> - 'a Types.any_spaces_pos -> - 'b Types.any_spaces_pos -> Types.fromparser Types.any_spaces_pos -val call_op_unless_infix : - Types.fromparser -> - Types.fromparser -> - 'a Types.any_spaces_pos -> - 'b Types.any_spaces_pos -> Types.fromparser Types.any_spaces_pos val current_lexbuf : Lexing.lexbuf option ref val list2tokens : ((int * int) * 'a) list -> Lexing.lexbuf -> 'a val parse_tokens : @@ -292,6 +285,16 @@ val mcontext_op_assign : Types.maybe_context val mtuple_context_concat : Types.maybe_context -> Types.maybe_context -> Types.maybe_context +val call_op_if_infix : + Types.fromparser -> + Types.fromparser -> + 'a Types.any_spaces_pos -> + 'b Types.any_spaces_pos -> Types.fromparser Types.any_spaces_pos +val call_op_unless_infix : + Types.fromparser -> + Types.fromparser -> + 'a Types.any_spaces_pos -> + 'b Types.any_spaces_pos -> Types.fromparser Types.any_spaces_pos val symops : Types.priority -> Types.maybe_context -> diff --git a/perl_checker.src/perl_checker.ml b/perl_checker.src/perl_checker.ml index cc75816..98664e0 100644 --- a/perl_checker.src/perl_checker.ml +++ b/perl_checker.src/perl_checker.ml @@ -22,7 +22,7 @@ let set_basedir per_files file = let rec parse_file from_basedir require_name per_files file = try - if !Flags.verbose then print_endline_flush_always ("parsing " ^ file) ; + if !Flags.verbose then print_endline_flush ("parsing " ^ file) ; let build_time = Unix.time() in let command = match !Flags.expand_tabs with @@ -42,7 +42,7 @@ let rec parse_file from_basedir require_name per_files file = let required_packages = collect (fun package -> package.required_packages) per_file.packages in required_packages, per_files with Failure s -> ( - print_endline_flush_always s ; + print_endline_flush s ; exit 1 ) with @@ -67,7 +67,7 @@ and parse_package_if_needed per_files (package_name, pos) = | Some required_packages -> required_packages, per_files | None -> parse_file (dir = !basedir) (Some package_name) per_files file with Not_found -> - warn_with_pos_always pos (Printf.sprintf "can't find package %s" package_name) ; + 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 @@ -94,12 +94,33 @@ let parse_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)" ; - "--check-unused", Arg.Set Flags.check_unused_global_vars, " check unused global functions & variables" ; "--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, "" ; + "--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 [-v] [-q] <files>\nOptions are:" 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 @@ -110,10 +131,11 @@ let parse_options = if !Flags.generate_pot then Parser_helper.generate_pot !pot_file else ( - if !restrict_to_files then Common.print_endline_flush_quiet := true ; - let per_files, required_packages = parse_required_packages per_files [] required_packages in + 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 - if !restrict_to_files then Common.print_endline_flush_quiet := false ; write_packages_cache per_files !basedir ; @@ -133,7 +155,8 @@ let parse_options = 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 - get_vars_declaration global_vars_declared file_name pkg + 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 diff --git a/perl_checker.src/test/syntax_restrictions.t b/perl_checker.src/test/syntax_restrictions.t index 6641b7b..eb186d8 100644 --- a/perl_checker.src/test/syntax_restrictions.t +++ b/perl_checker.src/test/syntax_restrictions.t @@ -34,7 +34,7 @@ foreach ($xxx = 0; $xxx < 9; $xxx++) {} write "for" instead of "foreach" foreach $xxx (@l) {} don't use for without "my"ing the iteration variable -foreach ($xxx) {} you are using the special fpons trick to locally set $_ with a value, for this please use "for" instead of "foreach" +foreach ($xxx) {} you are using the special trick to locally set $_ with a value, for this please use "for" instead of "foreach" unless ($xxx) {} else {} don't use "else" with "unless" (replace "unless" with "if") diff --git a/perl_checker.src/tree.ml b/perl_checker.src/tree.ml index 2d630c1..dd62174 100644 --- a/perl_checker.src/tree.ml +++ b/perl_checker.src/tree.ml @@ -51,8 +51,7 @@ let ignore_package pkg = lpush ignored_packages pkg let die_with_pos pos msg = failwith (Info.pos2sfull pos ^ msg) -let warn_with_pos pos msg = print_endline_flush (Info.pos2sfull pos ^ msg) -let warn_with_pos_always pos msg = print_endline_flush_always (Info.pos2sfull pos ^ msg) +let warn_with_pos warn_types pos msg = if Flags.are_warning_types_set warn_types then print_endline_flush (Info.pos2sfull pos ^ msg) let s2context s = match s.[0] with @@ -77,13 +76,13 @@ let get_current_package t = in bundled_packages [] (string_of_Ident ident) [] body | _ -> - if str_ends_with !Info.current_file ".pm" then warn_with_pos (!Info.current_file, 0, 0) (sprintf "module %s does not have \"package xxxx;\" on its first line" (Info.absolute_file_to_file !Info.current_file)) ; + if str_ends_with !Info.current_file ".pm" then warn_with_pos [Warn_normalized_expressions] (!Info.current_file, 0, 0) (sprintf "module %s does not have \"package xxxx;\" on its first line" (Info.absolute_file_to_file !Info.current_file)) ; [ None, t ] let from_qw_raw = function | String([s, List []], pos) -> [ s, pos ] | String(_, pos) -> - warn_with_pos pos "not recognised yet" ; + warn_with_pos [] pos "not recognised yet" ; [] | Raw_string(s, pos) -> [ s, pos ] @@ -93,9 +92,9 @@ let from_qw_raw = function | String([s, List []], pos) | Raw_string(s, pos) -> Some(s, pos) | Ident(_, _, pos) as ident -> Some(string_of_Ident ident, pos) - | e -> warn_with_pos (get_pos_from_expr e) "not recognised yet"; None + | e -> warn_with_pos [] (get_pos_from_expr e) "not recognised yet"; None ) l)) [] - | e -> warn_with_pos (get_pos_from_expr e) "not recognised yet"; [] + | e -> warn_with_pos [] (get_pos_from_expr e) "not recognised yet"; [] let from_qw e = List.map (fun (s, pos) -> @@ -103,7 +102,7 @@ let from_qw e = let context = match context with | I_raw -> if s'.[0] = ':' then I_raw else I_func - | I_func -> warn_with_pos pos "weird, exported name with a function context especially given"; I_func + | I_func -> warn_with_pos [Warn_import_export] pos "weird, exported name with a function context especially given"; I_func | _ -> context in context, s' ) (from_qw_raw e) @@ -113,12 +112,12 @@ let get_exported t = match e with | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT", _)); Call _ ], pos) ] | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT")], _); Call _ ], pos) ] -> - if exports.special_export = None then warn_with_pos pos "unrecognised @EXPORT" ; + if exports.special_export = None then warn_with_pos [Warn_import_export] pos "unrecognised @EXPORT" ; exports | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT", _)); v ], pos)] | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT")], _); v ], pos)] -> - if exports.export_auto <> [] then warn_with_pos pos "weird, @EXPORT set twice" ; + if exports.export_auto <> [] then warn_with_pos [Warn_import_export] pos "weird, @EXPORT set twice" ; { exports with export_auto = from_qw v } | Perl_checker_comment("RE-EXPORT-ALL", _) -> { exports with special_export = Some Re_export_all } @@ -126,7 +125,7 @@ let get_exported t = | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT_OK", _)); v ], pos)] | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT_OK")], _); v ], pos)] -> - if exports.export_ok <> [] then warn_with_pos pos "weird, @EXPORT_OK set twice" ; + if exports.export_ok <> [] then warn_with_pos [Warn_import_export] pos "weird, @EXPORT_OK set twice" ; (match v with | Call(Deref(I_func, Ident(None, "map", _)), [ Anonymous_sub(_, Block [List [Deref(I_array, Deref(I_scalar, Ident (None, "_", _)))]], _); @@ -152,10 +151,10 @@ let get_exported t = ) (group_by_2 l) | _ -> raise Not_found in - if exports.export_tags <> [] then warn_with_pos pos "weird, %EXPORT_TAGS set twice" ; + if exports.export_tags <> [] then warn_with_pos [Warn_import_export] pos "weird, %EXPORT_TAGS set twice" ; { exports with export_tags = export_tags } with _ -> - warn_with_pos pos "unrecognised %EXPORT_TAGS" ; + warn_with_pos [Warn_import_export] pos "unrecognised %EXPORT_TAGS" ; exports) (* $EXPORT_TAGS{all} = [ map { @$_ } values %EXPORT_TAGS ]; *) @@ -280,8 +279,8 @@ let get_proto perl_proto body = map_option (fun (mys, pos, _) -> let scalars, others = break_at (fun (context, _) -> context <> I_scalar) mys in (match others with - | (I_array, _) :: _ :: _ -> warn_with_pos pos "an array must be the last variable in a prototype" - | (I_hash, _) :: _ :: _ -> warn_with_pos pos "an hash must be the last variable in a prototype" + | (I_array, _) :: _ :: _ -> warn_with_pos [Warn_prototypes] pos "an array must be the last variable in a prototype" + | (I_hash, _) :: _ :: _ -> warn_with_pos [Warn_prototypes] pos "an hash must be the last variable in a prototype" | _ -> ()); let is_optional (_, s) = String.length s > 2 && (s.[0] = 'o' || s.[0] = 'b') && s.[1] = '_' || @@ -289,7 +288,7 @@ let get_proto perl_proto body = in let must_have, optional = break_at is_optional scalars in if not (List.for_all is_optional optional) then - warn_with_pos pos "an non-optional argument must not follow an optional argument"; + warn_with_pos [Warn_prototypes] pos "an non-optional argument must not follow an optional argument"; let min = List.length must_have in { proto_nb_min = min; proto_nb_max = if others = [] then Some(min + List.length optional) else None } ) (has_proto perl_proto body) @@ -315,7 +314,7 @@ let get_vars_declaration global_vars_declared file_name package = | List [ Method_call(Raw_string(pkg, pos), Raw_string("bootstrap", _), _) ] -> if pkg <> package.package_name then - warn_with_pos pos "strange bootstrap (the package name is not the same as the current package)" + warn_with_pos [Warn_import_export] pos "strange bootstrap (the package name is not the same as the current package)" else if not (read_xs_extension_from_c global_vars_declared file_name package pos) then if not (read_xs_extension_from_so global_vars_declared package pos) then @@ -388,9 +387,9 @@ let get_global_info_from_package from_basedir require_name build_time t = let isa, exporter = get_isa t in (match exporter with | None -> - if exporting_something() then warn_with_pos (!Info.current_file, 0, 0) "you must have \"@ISA = qw(Exporter)\" to EXPORT something" + if exporting_something() then warn_with_pos [Warn_import_export] (!Info.current_file, 0, 0) "you must have \"@ISA = qw(Exporter)\" to EXPORT something" | Some pos -> - if not (exporting_something()) then warn_with_pos pos "Inheritating from Exporter without EXPORTing anything"); + if not (exporting_something()) then warn_with_pos [Warn_import_export] pos "Inheritating from Exporter without EXPORTing anything"); let uses = List.rev (get_uses t) in let required_packages = List.map (fun (s, (_, pos)) -> s, pos) uses in diff --git a/perl_checker.src/tree.mli b/perl_checker.src/tree.mli index 60edc37..3cdf219 100644 --- a/perl_checker.src/tree.mli +++ b/perl_checker.src/tree.mli @@ -51,8 +51,7 @@ val has_proto : string option -> fromparser -> ((context * string) list * pos * val get_vars_declaration : (context * string * string, pos * prototype option) Hashtbl.t -> string -> per_package -> unit val die_with_pos : string * int * int -> string -> 'a -val warn_with_pos : string * int * int -> string -> unit -val warn_with_pos_always : string * int * int -> string -> unit +val warn_with_pos : Types.warning list -> string * int * int -> string -> unit val fold_tree : ('a -> fromparser -> 'a option) -> 'a -> fromparser -> 'a val from_qw : fromparser -> (context * string) list diff --git a/perl_checker.src/types.mli b/perl_checker.src/types.mli index 0a5e62b..15f97cd 100644 --- a/perl_checker.src/types.mli +++ b/perl_checker.src/types.mli @@ -105,3 +105,20 @@ type 'a prio_anyexpr = { type prio_expr_spaces_pos = fromparser prio_anyexpr any_spaces_pos type prio_lexpr_spaces_pos = fromparser list prio_anyexpr any_spaces_pos + +type warning = + | Warn_white_space + | Warn_suggest_simpler + | Warn_unused_global_vars + | Warn_void + | Warn_context + | Warn_strange + | Warn_traps + | Warn_complex_expressions + | Warn_normalized_expressions + | Warn_suggest_functional + | Warn_prototypes + | Warn_import_export + | Warn_names + | Warn_MDK_Common + | Warn_help_perl_checker |