summaryrefslogtreecommitdiffstats
path: root/perl_checker.src
diff options
context:
space:
mode:
Diffstat (limited to 'perl_checker.src')
-rw-r--r--perl_checker.src/Makefile2
-rw-r--r--perl_checker.src/common.ml11
-rw-r--r--perl_checker.src/common.mli3
-rw-r--r--perl_checker.src/flags.ml37
-rw-r--r--perl_checker.src/flags.mli18
-rw-r--r--perl_checker.src/global_checks.ml48
-rw-r--r--perl_checker.src/lexer.mll40
-rw-r--r--perl_checker.src/parser.mly26
-rw-r--r--perl_checker.src/parser_helper.ml227
-rw-r--r--perl_checker.src/parser_helper.mli31
-rw-r--r--perl_checker.src/perl_checker.ml43
-rw-r--r--perl_checker.src/test/syntax_restrictions.t2
-rw-r--r--perl_checker.src/tree.ml35
-rw-r--r--perl_checker.src/tree.mli3
-rw-r--r--perl_checker.src/types.mli17
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
generated by cgit v1.2.1 (git 2.21.0) at 2024-11-19 14:29:55 +0000