diff options
Diffstat (limited to 'perl_checker.src/tree.ml')
| -rw-r--r-- | perl_checker.src/tree.ml | 35 |
1 files changed, 17 insertions, 18 deletions
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 |