- perl_checker: print on stdout, not stderr

- perl_checker: add option --restrict-to-files (mainly for perl_checko the Clean Keeper)

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 ;