summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorPascal Rigaux <pixel@mandriva.com>2003-09-30 20:55:11 +0000
committerPascal Rigaux <pixel@mandriva.com>2003-09-30 20:55:11 +0000
commit8465c1513276ddfab59ed7578049cebf167b71fc (patch)
tree4ad27e47c238cd4c814e7d8d146fe5a2148effc9
parent98004c4ce6b1853dfd86c8060a049094afb4de93 (diff)
downloadperl-MDK-Common-8465c1513276ddfab59ed7578049cebf167b71fc.tar
perl-MDK-Common-8465c1513276ddfab59ed7578049cebf167b71fc.tar.gz
perl-MDK-Common-8465c1513276ddfab59ed7578049cebf167b71fc.tar.bz2
perl-MDK-Common-8465c1513276ddfab59ed7578049cebf167b71fc.tar.xz
perl-MDK-Common-8465c1513276ddfab59ed7578049cebf167b71fc.zip
display relative file names when nicer
-rw-r--r--perl_checker.src/common.ml17
-rw-r--r--perl_checker.src/common.mli2
-rw-r--r--perl_checker.src/info.ml28
-rw-r--r--perl_checker.src/info.mli2
-rw-r--r--perl_checker.src/perl_checker.ml2
-rw-r--r--perl_checker.src/tree.ml6
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) ->