diff options
| -rw-r--r-- | perl_checker.src/common.ml | 3 | ||||
| -rw-r--r-- | perl_checker.src/common.mli | 2 | ||||
| -rw-r--r-- | perl_checker.src/parser_helper.ml | 6 | ||||
| -rw-r--r-- | perl_checker.src/perl_checker.ml | 17 | ||||
| -rw-r--r-- | perl_checker.src/tree.ml | 8 |
5 files changed, 24 insertions, 12 deletions
diff --git a/perl_checker.src/common.ml b/perl_checker.src/common.ml index 19aaa5f..a938ffb 100644 --- a/perl_checker.src/common.ml +++ b/perl_checker.src/common.ml @@ -780,6 +780,9 @@ let to_CamelCase s_ = 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 is_int n = n = floor n (* total order *) diff --git a/perl_checker.src/common.mli b/perl_checker.src/common.mli index 89e6d19..162b6bd 100644 --- a/perl_checker.src/common.mli +++ b/perl_checker.src/common.mli @@ -202,6 +202,8 @@ val split_at2 : char -> char -> string -> string list val words : string -> string list val to_CamelCase : string -> string option val string_of_ref : 'a ref -> string +val print_endline_flush_quiet : bool ref +val print_endline_flush : 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/parser_helper.ml b/perl_checker.src/parser_helper.ml index 0cea7e2..7f723a6 100644 --- a/perl_checker.src/parser_helper.ml +++ b/perl_checker.src/parser_helper.ml @@ -97,12 +97,12 @@ let from_array (e, _) = | _ -> internal_error "from_array" 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 = prerr_endline (msg_with_rawpos raw_pos 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 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 prerr_endline msg +let debug msg = if true then print_endline_flush 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" diff --git a/perl_checker.src/perl_checker.ml b/perl_checker.src/perl_checker.ml index dfa8061..9d88c6c 100644 --- a/perl_checker.src/perl_checker.ml +++ b/perl_checker.src/perl_checker.ml @@ -26,13 +26,13 @@ let findfile dirs f = List.find Sys.file_exists (List.map (fun dir -> dir ^ "/" let rec parse_file state file = try - if !Flags.verbose then prerr_endline ("checking " ^ file) ; + if !Flags.verbose then print_endline_flush ("checking " ^ file) ; let channel = Unix.open_process_in (Printf.sprintf "expand \"%s\"" file) in let lexbuf = Lexing.from_channel channel in try Info.start_a_new_file file ; let tokens = Lexer.get_token Lexer.token lexbuf in - (*let _ = Unix.close_process_in channel in*) + let _ = Unix.close_process_in channel in let t = Parser_helper.parse_tokens Parser.prog tokens (Some lexbuf) in let packages, required_packages = get_global_info_from_package t in List.fold_left (fun (required_packages, state) package -> @@ -41,7 +41,7 @@ let rec parse_file state file = List.map (fun (s, (_, pos)) -> s, pos) package.uses @ required_packages, state ) (required_packages, state) packages with Failure s -> ( - prerr_endline s ; + print_endline_flush s ; exit 1 ) with @@ -71,19 +71,26 @@ let rec parse_required_packages state = function let parse_options = let args_r = ref [] in + let restrict_to_files = ref false in let options = [ "-v", Arg.Set Flags.verbose, " be verbose" ; "-q", Arg.Set Flags.quiet, " be quiet" ; + "--restrict-to-files", Arg.Set restrict_to_files, " only display warnings concerning the file(s) given on command line" ; ] in let usage = "Usage: perl_checker [-v] [-q] <files>\nOptions are:" in Arg.parse options (lpush args_r) usage; - let args = if !args_r = [] then ["../t.pl"] else !args_r in - let required_packages, state = collect_withenv parse_file default_state args in + let files = if !args_r = [] then ["../t.pl"] else !args_r in + let required_packages, state = collect_withenv parse_file default_state files in + if !restrict_to_files then Common.print_endline_flush_quiet := true ; let state = parse_required_packages state required_packages in + if !restrict_to_files then Common.print_endline_flush_quiet := false ; let l = List.map snd state.per_package in (* HACK: skip ignored_packages. Some package may have appeared in ignored_packages due to the xs bootstrap hack *) let l = List.filter (fun pkg -> not (List.mem pkg.package_name !ignored_packages)) l in + + let l = if !restrict_to_files then List.filter (fun pkg -> List.mem pkg.file_name files) l else l in + List.iter (check_tree state) l diff --git a/perl_checker.src/tree.ml b/perl_checker.src/tree.ml index 420ed39..8cf6257 100644 --- a/perl_checker.src/tree.ml +++ b/perl_checker.src/tree.ml @@ -46,11 +46,11 @@ let ignored_packages = ref [] let use_lib = ref [] let ignore_package pkg = - if !Flags.verbose then prerr_endline ("ignoring package " ^ pkg); + if !Flags.verbose then print_endline_flush ("ignoring package " ^ pkg); lpush ignored_packages pkg let die_with_pos pos msg = failwith (Info.pos2sfull pos ^ msg) -let warn_with_pos pos msg = prerr_endline (Info.pos2sfull pos ^ msg) +let warn_with_pos pos msg = print_endline_flush (Info.pos2sfull pos ^ msg) let s2context s = match s.[0] with @@ -388,7 +388,7 @@ let is_global_var context ident = | "caller" | "chdir" | "chmod" | "chomp" | "chop" | "chown" | "chr" | "chroot" | "close" | "closedir" | "crypt" | "defined" | "delete" | "die" | "each" | "endpwent" | "eof" | "eval" | "exec" | "exists" | "exit" - | "fcntl" | "fileno" | "formline" | "fork" + | "fcntl" | "fileno" | "flock" | "formline" | "fork" | "gethostbyaddr" | "gethostbyname" | "getgrnam" | "getgrgid" | "getppid" | "getpwent" | "getpwnam" | "getpwuid" | "gmtime" | "goto" | "grep" | "hex" | "index" | "int" | "ioctl" | "join" | "keys" | "kill" | "last" | "lc" | "length" | "link" | "localtime" | "log" | "lstat" @@ -575,7 +575,7 @@ let add_package_to_state state package = let per_package = try update_assoc (fun existing_package -> - (*prerr_endline (existing_package.file_name ^ " vs " ^ package.file_name); *) + (*print_endline_flush (existing_package.file_name ^ " vs " ^ package.file_name); *) Hashtbl.iter (fun var pos -> Hashtbl.replace existing_package.vars_declared var pos) package.vars_declared ; { existing_package with body = existing_package.body @ package.body ; |