display relative file names when nicer

6 files changed, 42 insertions, 15 deletions

diff --git a/perl_checker.src/common.ml b/perl_checker.src/common.ml
index 6d5c79c..ee989dc 100644
--- a/perl_checker.src/common.ml
+++ b/perl_checker.src/common.ml
@@ -522,6 +522,14 @@ let hashtbl_exists f h =
     false
   with Found -> true
 
+let memoize f =
+  let hash = Hashtbl.create 16 in
+  fun k ->
+    try Hashtbl.find hash k
+    with Not_found ->
+      let v = f k in
+      Hashtbl.add hash k v ; v
+
 let array_shift a = Array.sub a 1 (Array.length a - 1)
 let array_last_n n a = 
   let len = Array.length a in
@@ -828,15 +836,6 @@ let expand_symlinks file =
         ) (file ^ "/" ^ piece)) "" l
   | _ -> internal_error (Printf.sprintf "expand_symlinks: %s is relative\n" file)
 
-let file_to_absolute_file file =
-  let abs_file = 
-    if file.[0] = '/' then file else 
-    let cwd = Unix.getcwd() in
-    if file = "." then cwd else cwd ^ "/" ^ file
-  in
-  expand_symlinks abs_file
-
-
 let mtime f = int_of_float ((Unix.stat f).Unix.st_mtime)
 
 let rec updir dir nb =
diff --git a/perl_checker.src/common.mli b/perl_checker.src/common.mli
index 60f985e..5702b1d 100644
--- a/perl_checker.src/common.mli
+++ b/perl_checker.src/common.mli
@@ -155,6 +155,7 @@ val hashtbl_keys : ('a, 'b) Hashtbl.t -> 'a list
 val hashtbl_to_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list
 val hashtbl_collect : ('a -> 'b -> 'c list) -> ('a, 'b) Hashtbl.t -> 'c list
 val hashtbl_exists : ('a -> 'b -> bool) -> ('a, 'b) Hashtbl.t -> bool
+val memoize : ('a -> 'a) -> 'a -> 'a
 val array_shift : 'a array -> 'a array
 val array_last_n : int -> 'a array -> 'a array
 val array_collect : ('a -> 'b list) -> 'a array -> 'b list
@@ -211,7 +212,6 @@ val words : string -> string list
 val to_CamelCase : string -> string option
 val concat_symlink : string -> string -> string
 val expand_symlinks : string -> string
-val file_to_absolute_file : string -> string
 val mtime : string -> int
 val updir : string -> int -> string
 val string_of_ref : 'a ref -> string
diff --git a/perl_checker.src/info.ml b/perl_checker.src/info.ml
index f64af7a..eb32142 100644
--- a/perl_checker.src/info.ml
+++ b/perl_checker.src/info.ml
@@ -17,6 +17,32 @@ let add_a_file file file_lines_starts = Hashtbl.replace lines_starts file file_l
 let get_lines_starts_for_file file =
   if file = !current_file then !current_file_lines_starts else Hashtbl.find lines_starts file
 
+let cwd = expand_symlinks (Unix.getcwd())
+
+let file_to_absolute_file file =
+  let abs_file = 
+    if file.[0] = '/' then file else 
+    if file = "." then cwd else cwd ^ "/" ^ file
+  in
+  expand_symlinks abs_file
+
+let absolute_file_to_file = 
+  let s1 = Filename.dirname cwd in
+  if String.length s1 < 4 then (fun x -> x) else
+  let s2 = Filename.dirname cwd in
+  let short_cwd = if String.length s2 < 4 then s1 else s2 in
+  memoize (fun abs_file ->
+    if str_begins_with abs_file (short_cwd ^ "/") then
+      let rec to_file rel cwd =
+	if str_begins_with abs_file (cwd ^ "/") then
+	  rel ^ skip_n_char_ (String.length cwd + 1) 0 abs_file
+	else
+	  to_file ("../" ^ rel) (Filename.dirname cwd)
+      in
+      to_file "" cwd  
+    else
+      abs_file)
+
 let raw_pos2raw_line file a =
   let starts = map_index (fun a b -> a,b) (rev (get_lines_starts_for_file file)) in
   let ((offset, line), _) = find (fun (_,(e,_)) -> e > a) (combine starts (tl starts @ [999999999, 999999999])) in
@@ -31,7 +57,7 @@ let pos2s (file, a, b) = sprintf "(%s, %d, %d)" file a b
 let pos2sfull pos = 
   try
     let (file, line, n1,n2) = pos2line pos in
-    sprintf "File \"%s\", line %d, character %d-%d\n" file (line + 1) n1 n2
+    sprintf "File \"%s\", line %d, character %d-%d\n" (absolute_file_to_file file) (line + 1) n1 n2
   with Not_found -> failwith ("bad position " ^ pos2s pos)
 
 let is_on_same_line file (a,b) =
diff --git a/perl_checker.src/info.mli b/perl_checker.src/info.mli
index cca0709..bd72bc7 100644
--- a/perl_checker.src/info.mli
+++ b/perl_checker.src/info.mli
@@ -5,6 +5,8 @@ val current_file : string ref
 val start_a_new_file : string -> unit
 val add_a_file : string -> int list -> unit
 val get_lines_starts_for_file : string -> int list
+val file_to_absolute_file : string -> string
+val absolute_file_to_file : string -> string
 val raw_pos2raw_line : string -> int -> int * int
 val pos2line : string * int * int -> string * int * int * int
 val pos2s : string * int * int -> string
diff --git a/perl_checker.src/perl_checker.ml b/perl_checker.src/perl_checker.ml
index 7aa1aff..114684e 100644
--- a/perl_checker.src/perl_checker.ml
+++ b/perl_checker.src/perl_checker.ml
@@ -103,7 +103,7 @@ let parse_options =
   Arg.parse options (lpush args_r) usage;
 
   let files = if !args_r = [] then ["../t.pl"] else !args_r in
-  let files = List.map file_to_absolute_file files in
+  let files = List.map Info.file_to_absolute_file files in
 
   let required_packages, per_files = collect_withenv (parse_file true None) (default_per_files()) files in
   let required_packages = uniq_ (fun (a,_) (b,_) -> a = b) required_packages in
diff --git a/perl_checker.src/tree.ml b/perl_checker.src/tree.ml
index 7126f91..ea61876 100644
--- a/perl_checker.src/tree.ml
+++ b/perl_checker.src/tree.ml
@@ -42,7 +42,7 @@ type per_file = {
 
 let anonymous_package_count = ref 0
 let empty_exports = { export_ok = []; export_auto = []; export_tags = []; special_export = None }
-let use_lib = ref (List.map file_to_absolute_file (readlines (Unix.open_process_in "perl -le 'print foreach @INC'")))
+let use_lib = ref (List.map Info.file_to_absolute_file (readlines (Unix.open_process_in "perl -le 'print foreach @INC'")))
 
 let ignore_package pkg = 
   if !Flags.verbose then print_endline_flush ("ignoring package " ^ pkg);
@@ -75,7 +75,7 @@ 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.current_file) ;
+      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)) ;
       [ None, t ]
 
 let from_qw_raw = function
@@ -185,7 +185,7 @@ let get_uses t =
   List.fold_left (fun uses e ->
     match e with
     | Use(Ident(None, "lib", _), [libs]) ->
-	use_lib := List.map file_to_absolute_file (List.map snd (from_qw libs)) @ !use_lib ;
+	use_lib := List.map Info.file_to_absolute_file (List.map snd (from_qw libs)) @ !use_lib ;
 	uses
     | Use(Ident _ as pkg, _) when uses_external_package (string_of_Ident pkg) -> uses
     | Use(Ident(_, _, pos) as ident, l) ->