summaryrefslogtreecommitdiffstats
path: root/perl_checker.src
diff options
context:
space:
mode:
authorPascal Rigaux <pixel@mandriva.com>2003-09-29 14:40:02 +0000
committerPascal Rigaux <pixel@mandriva.com>2003-09-29 14:40:02 +0000
commit9baac87147e46384da1f3a18ebf1363f21638ee9 (patch)
treefee424984969e93275502324f90774d0bc06922c /perl_checker.src
parentcc10af8042789097c52948fa329be7c432a4befd (diff)
downloadperl-MDK-Common-9baac87147e46384da1f3a18ebf1363f21638ee9.tar
perl-MDK-Common-9baac87147e46384da1f3a18ebf1363f21638ee9.tar.gz
perl-MDK-Common-9baac87147e46384da1f3a18ebf1363f21638ee9.tar.bz2
perl-MDK-Common-9baac87147e46384da1f3a18ebf1363f21638ee9.tar.xz
perl-MDK-Common-9baac87147e46384da1f3a18ebf1363f21638ee9.zip
re-organize to handle cleanly multi packages per file
=> fixes cache coherency
Diffstat (limited to 'perl_checker.src')
-rw-r--r--perl_checker.src/common.ml56
-rw-r--r--perl_checker.src/common.mli7
-rw-r--r--perl_checker.src/global_checks.ml81
-rw-r--r--perl_checker.src/global_checks.mli18
-rw-r--r--perl_checker.src/perl_checker.ml108
-rw-r--r--perl_checker.src/tree.ml50
-rw-r--r--perl_checker.src/tree.mli12
7 files changed, 202 insertions, 130 deletions
diff --git a/perl_checker.src/common.ml b/perl_checker.src/common.ml
index 7afbd00..9286857 100644
--- a/perl_checker.src/common.ml
+++ b/perl_checker.src/common.ml
@@ -752,16 +752,6 @@ let rec fold_lines f init chan =
with End_of_file -> init
let readlines chan = List.rev (fold_lines (fun l e -> e::l) [] chan)
-let rec updir dir nb =
- if nb = 0 then dir else
- match dir with
- | "." -> String.concat "/" (times ".." nb)
- | _ ->
- if Filename.basename dir = ".." then
- dir ^ "/" ^ String.concat "/" (times ".." nb)
- else
- updir (Filename.dirname dir) (nb-1)
-
let split_at c s =
let rec split_at_ accu i =
try
@@ -808,11 +798,57 @@ let to_CamelCase s_ =
) (0, "") (rev !l) in
Some (s' ^ String.sub s offset (String.length s - offset))
+let concat_symlink file link =
+ if str_begins_with link "..//" then (* ..//foo => /foo *)
+ skip_n_char 3 link
+ else
+ let file = if str_ends_with file "/" then chop file else file in (* s|/$|| *)
+ let rec reduce file link =
+ if str_begins_with link "../" then
+ let file = String.sub file 0 (String.rindex file '/') in (* s|/[^/]+$|| *)
+ reduce file (skip_n_char 3 link)
+ else
+ file ^ "/" ^ link
+ in
+ reduce file link
+
+let expand_symlinks file =
+ match split_at '/' file with
+ | "" :: l ->
+ let rec remove_dotdot accu nb = function
+ | [] -> if nb = 0 then accu else failwith "remove_dotdot"
+ | ".." :: l -> remove_dotdot accu (nb + 1) l
+ | e :: l -> if nb > 0 then remove_dotdot accu (nb - 1) l else remove_dotdot (e :: accu) nb l
+ in
+ let l = remove_dotdot [] 0 (List.rev l) in
+ List.fold_left (fun file piece ->
+ fix_point (fun file ->
+ try concat_symlink file ("../" ^ Unix.readlink file)
+ with _ -> file
+ ) (file ^ "/" ^ piece)) "" l
+ | _ -> internal_error (Printf.sprintf "expand_symlinks: %s is relative\n" file)
+
+let file_to_absolute_file file =
+ if file.[0] = '/' then file else expand_symlinks (Unix.getcwd() ^ "/" ^ file)
+
+let mtime f = int_of_float ((Unix.stat f).Unix.st_mtime)
+
+let rec updir dir nb =
+ if nb = 0 then dir else
+ match dir with
+ | "." -> String.concat "/" (times ".." nb)
+ | _ ->
+ if Filename.basename dir = ".." then
+ dir ^ "/" ^ String.concat "/" (times ".." nb)
+ else
+ updir (Filename.dirname dir) (nb-1)
+
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 print_endline_flush_always s = print_endline s ; flush stdout
let is_int n = n = floor n
diff --git a/perl_checker.src/common.mli b/perl_checker.src/common.mli
index d766b86..60f985e 100644
--- a/perl_checker.src/common.mli
+++ b/perl_checker.src/common.mli
@@ -205,14 +205,19 @@ val string_forall_with : (char -> bool) -> int -> string -> bool
val starts_with_non_lowercase : string -> bool
val fold_lines : ('a -> string -> 'a) -> 'a -> in_channel -> 'a
val readlines : in_channel -> string list
-val updir : string -> int -> string
val split_at : char -> string -> string list
val split_at2 : char -> char -> string -> string list
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
val print_endline_flush_quiet : bool ref
val print_endline_flush : string -> unit
+val print_endline_flush_always : 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/global_checks.ml b/perl_checker.src/global_checks.ml
index 9f32eaf..10450c5 100644
--- a/perl_checker.src/global_checks.ml
+++ b/perl_checker.src/global_checks.ml
@@ -6,9 +6,9 @@ open Parser_helper
open Tree
type state = {
- per_package : (string, per_package) Hashtbl.t ;
+ per_files : (string, per_file) Hashtbl.t ;
+ per_packages : (string, per_package) Hashtbl.t ;
methods : (string, (pos * bool ref * prototype option) list) Hashtbl.t ;
- global_vars_declared : (context * string * string, pos * prototype option) Hashtbl.t ;
global_vars_used : ((context * string * string) * pos) list ref ;
packages_being_classes : (string, unit) Hashtbl.t ;
}
@@ -25,7 +25,7 @@ type vars = {
let rec get_imported state current_package (package_name, (imports, pos)) =
try
- let package_used = Hashtbl.find state.per_package package_name in
+ let package_used = Hashtbl.find state.per_packages package_name in
let exports = package_used.exports in
let get_var_by_name var =
let (b, prototype) =
@@ -131,11 +131,10 @@ let is_var_declared vars var para =
is_var_declared_and_set vars.state vars.current_package var para
let is_global_var_declared vars (context, fq, name) para =
- Hashtbl.mem vars.state.global_vars_declared (context, fq, name) ||
- (try
- let package = Hashtbl.find vars.state.per_package fq in
+ try
+ let package = Hashtbl.find vars.state.per_packages fq in
is_var_declared_and_set vars.state package (context, name) para
- with Not_found -> false)
+ with Not_found -> false
let is_global_var context ident =
@@ -390,7 +389,7 @@ let check_variables vars t =
let rec search pkg =
if is_global_var_declared vars (I_func, pkg, method_) (Some(pos, [ List (class_ :: un_parenthesize_one_elt_List para) ])) then true
else
- let package = Hashtbl.find vars.state.per_package pkg in
+ let package = Hashtbl.find vars.state.per_packages pkg in
List.exists search (List.map fst (some_or package.isa []))
in
(try
@@ -428,33 +427,40 @@ let check_variables vars t =
let check_tree state package =
let vars = { my_vars = [[]]; our_vars = []; locally_imported = []; required_vars = []; current_package = package; state = state } in
+ if !Flags.verbose then print_endline_flush_always ("checking package " ^ package.package_name) ;
let _vars = check_variables vars package.body in
()
let add_package_to_state state package =
let package =
try
- let existing_package = Hashtbl.find state.per_package package.package_name in
+ let existing_package = Hashtbl.find state.per_packages package.package_name in
(*print_endline_flush (existing_package.file_name ^ " vs " ^ package.file_name); *)
let vars_declared = existing_package.vars_declared in
Hashtbl.iter (fun var pos -> Hashtbl.replace vars_declared var pos) package.vars_declared ;
- let p = if existing_package.build_time > package.build_time then existing_package else package in
- let p = { p with
+ let p = {
+ package_name = package.package_name ; has_package_name = package.has_package_name ;
isa = if existing_package.isa = None then package.isa else existing_package.isa ;
- body = (if existing_package.from_cache then [] else existing_package.body) @ package.body ;
- uses = (if existing_package.from_cache then [] else existing_package.uses) @ package.uses ;
+ body = existing_package.body @ package.body ;
+ uses = existing_package.uses @ package.uses ;
+ required_packages = existing_package.required_packages @ package.required_packages ;
vars_declared = vars_declared ;
- build_time = max existing_package.build_time package.build_time ;
+ imported =
+ ref (if !(existing_package.imported) = None && !(package.imported) = None then None else
+ Some (some_or !(existing_package.imported) [] @ some_or !(package.imported) [])) ;
exports = { export_ok = existing_package.exports.export_ok @ package.exports.export_ok ;
export_auto = existing_package.exports.export_auto @ package.exports.export_auto ;
export_tags = existing_package.exports.export_tags @ package.exports.export_tags ;
special_export = None }
} in
- Hashtbl.replace state.per_package package.package_name p ;
+ Hashtbl.replace state.per_packages package.package_name p ;
p
with Not_found -> package
in
- Hashtbl.replace state.per_package package.package_name package
+ Hashtbl.replace state.per_packages package.package_name package
+
+let add_file_to_files per_files file =
+ Hashtbl.replace per_files file.file_name file
let check_unused_vars package =
Hashtbl.iter (fun (context, name) (pos, is_used, _proto) ->
@@ -462,17 +468,15 @@ let check_unused_vars package =
warn_with_pos pos (sprintf "unused %s%s::%s" (if context = I_func then "function " else "variable " ^ context2s context) package.package_name name)
) package.vars_declared
-let arrange_global_vars_declared state =
- let h = Hashtbl.create 16 in
- Hashtbl.iter (fun (context, fq, name) (file, _, _ as pos, proto) ->
+let arrange_global_vars_declared global_vars_declared state =
+ Hashtbl.iter (fun (context, fq, name) (pos, proto) ->
let package =
try
- Hashtbl.find state.per_package fq
+ Hashtbl.find state.per_packages fq
with Not_found ->
(* creating a new shadow package *)
let package =
{
- file_name = file ;
package_name = fq;
has_package_name = true ;
exports = empty_exports ;
@@ -482,19 +486,15 @@ let arrange_global_vars_declared state =
required_packages = [] ;
body = [] ;
isa = None ;
- lines_starts = [] ;
- build_time = 0 ;
- from_cache = false ;
- from_basedir = false ;
} in
- Hashtbl.add state.per_package fq package ;
+ Hashtbl.add state.per_packages fq package ;
package
in
if not (Hashtbl.mem package.vars_declared (context, name)) then
Hashtbl.add package.vars_declared (context, name) (pos, ref false, proto)
(* otherwise dropping this second declaration *)
- ) state.global_vars_declared ;
- { state with global_vars_declared = h }
+ ) global_vars_declared ;
+ state
let get_methods_available state =
let classes = uniq (
@@ -505,10 +505,10 @@ let get_methods_available state =
| Some l ->
package :: List.map (fun (pkg, pos) ->
try
- Hashtbl.find state.per_package pkg
+ Hashtbl.find state.per_packages pkg
with Not_found -> die_with_pos pos ("bad package " ^ pkg)
) l
- ) state.per_package
+ ) state.per_packages
) in
List.iter (fun pkg ->
Hashtbl.replace state.packages_being_classes pkg.package_name () ;
@@ -521,11 +521,12 @@ let get_methods_available state =
state
-let default_state() = { per_package = Hashtbl.create 16; methods = Hashtbl.create 256 ; global_vars_declared = Hashtbl.create 256; global_vars_used = ref []; packages_being_classes = Hashtbl.create 16 }
+let default_per_files() = Hashtbl.create 16
+let default_state per_files = { per_files = per_files; per_packages = Hashtbl.create 16; methods = Hashtbl.create 256 ; global_vars_used = ref []; packages_being_classes = Hashtbl.create 16 }
let cache_cache = Hashtbl.create 16
-let read_packages_from_cache state dir =
+let read_packages_from_cache per_files dir =
if !Flags.no_cache || Hashtbl.mem cache_cache dir then () else
try
Hashtbl.add cache_cache dir ();
@@ -536,24 +537,22 @@ let read_packages_from_cache state dir =
let l = Marshal.from_channel fh in
close_in fh ;
- let l = List.filter (fun pkg -> not (Hashtbl.mem state.per_package pkg.package_name)) l in
+ let l = List.filter (fun file -> not (Hashtbl.mem per_files file.file_name) && file.build_time > mtime file.file_name) l in
- if !Flags.verbose then print_endline_flush (sprintf "using cached packages %s from %s" (String.concat " " (List.map (fun pkg -> pkg.package_name) l)) file) ;
+ if !Flags.verbose then print_endline_flush (sprintf "using cached files\n%sfrom %s" (String.concat "" (List.map (fun s -> " " ^ s ^ "\n") (List.sort compare (List.map (fun pkg -> pkg.file_name) l)))) file) ;
- List.iter (fun pkg ->
- Info.add_a_file pkg.file_name pkg.lines_starts ;
- add_package_to_state state { pkg with from_cache = true }
+ List.iter (fun file ->
+ Info.add_a_file file.file_name file.lines_starts ;
+ add_file_to_files per_files file
) l
with Sys_error _ -> ()
-let write_packages_cache state dir =
+let write_packages_cache per_files dir =
try
let file = dir ^ "/.perl_checker.cache" in
let fh = open_out file in
output_string fh ("perl_checker cache " ^ string_of_int Build.date ^ "\n") ;
- let l = List.filter (fun pkg -> pkg.has_package_name) (List.map (fun pkg -> { pkg with imported = ref None }) (hashtbl_values state.per_package)) in
- (*List.iter (fun pkg -> prerr_endline ("XXXX " ^ pkg.package_name ^ ": " ^ String.concat " " (List.map snd (hashtbl_keys pkg.vars_declared)))) l ;*)
- Marshal.to_channel fh l [] ;
+ Marshal.to_channel fh (List.filter (fun per_file -> per_file.require_name <> None) (hashtbl_values per_files)) [] ;
close_out fh ;
if !Flags.verbose then print_endline_flush ("saving cached packages in " ^ file)
with Sys_error _ -> ()
diff --git a/perl_checker.src/global_checks.mli b/perl_checker.src/global_checks.mli
index 6b25f73..2fe13a1 100644
--- a/perl_checker.src/global_checks.mli
+++ b/perl_checker.src/global_checks.mli
@@ -2,19 +2,21 @@ open Types
open Tree
type state = {
- per_package : (string, per_package) Hashtbl.t;
+ per_files : (string, per_file) Hashtbl.t ;
+ per_packages : (string, per_package) Hashtbl.t ;
methods : (string, (pos * bool ref * prototype option) list) Hashtbl.t ;
- global_vars_declared : (context * string * string, pos * prototype option) Hashtbl.t;
- global_vars_used : ((context * string * string) * pos) list ref;
+ global_vars_used : ((context * string * string) * pos) list ref ;
packages_being_classes : (string, unit) Hashtbl.t ;
- }
+ }
-val default_state : unit -> state
+val default_per_files : unit -> (string, per_file) Hashtbl.t
+val default_state : (string, per_file) Hashtbl.t -> state
val check_tree : state -> per_package -> unit
+val add_file_to_files : (string, per_file) Hashtbl.t -> per_file -> unit
val add_package_to_state : state -> per_package -> unit
val check_unused_vars : per_package -> unit
-val arrange_global_vars_declared : state -> state
+val arrange_global_vars_declared : (context * string * string, pos * Tree.prototype option) Hashtbl.t -> state -> state
val get_methods_available : state -> state
-val read_packages_from_cache : state -> string -> unit
-val write_packages_cache : state -> string -> unit
+val read_packages_from_cache : (string, per_file) Hashtbl.t -> string -> unit
+val write_packages_cache : (string, per_file) Hashtbl.t -> string -> unit
diff --git a/perl_checker.src/perl_checker.ml b/perl_checker.src/perl_checker.ml
index 52eaaf5..7aa1aff 100644
--- a/perl_checker.src/perl_checker.ml
+++ b/perl_checker.src/perl_checker.ml
@@ -10,21 +10,19 @@ let search_basedir file_name nb =
updir dir nb
let basedir = ref ""
-let set_basedir state package =
+let set_basedir per_files file =
if !basedir = "" then
- let nb = List.length (split_at2 ':'':' package.package_name) - 1 in
- let dir = search_basedir package.file_name nb in
+ let nb = List.length (split_at2 ':'':' (List.hd file.packages).package_name) - 1 in
+ let dir = search_basedir file.file_name nb in
lpush Tree.use_lib dir ;
Config_file.read_any dir 1 ;
- read_packages_from_cache state dir ;
+ read_packages_from_cache per_files dir ;
if !Flags.verbose then print_endline_flush ("basedir is " ^ dir);
basedir := dir
-let mtime f = int_of_float ((Unix.stat f).Unix.st_mtime)
-
-let rec parse_file from_basedir state file =
+let rec parse_file from_basedir require_name per_files file =
try
- if !Flags.verbose then print_endline_flush ("checking " ^ file) ;
+ if !Flags.verbose then print_endline_flush_always ("parsing " ^ file) ;
let build_time = int_of_float (Unix.time()) in
let command =
match !Flags.expand_tabs with
@@ -37,15 +35,12 @@ let rec parse_file from_basedir state file =
let tokens = Lexer.get_token Lexer.token lexbuf in
let _ = Unix.close_process_in channel in
let t = Parser_helper.parse_tokens Parser.prog tokens (Some lexbuf) in
- let packages = get_global_info_from_package from_basedir build_time t in
- let required_packages =
- collect (fun package ->
- get_vars_declaration state.global_vars_declared package ;
- Global_checks.add_package_to_state state package ;
- set_basedir state package ;
- package.required_packages
- ) packages in
- required_packages, state
+ let per_file = get_global_info_from_package from_basedir require_name build_time t in
+ set_basedir per_files per_file ;
+ Global_checks.add_file_to_files per_files per_file ;
+
+ let required_packages = collect (fun package -> package.required_packages) per_file.packages in
+ required_packages, per_files
with Failure s -> (
print_endline_flush s ;
exit 1
@@ -53,8 +48,8 @@ let rec parse_file from_basedir state file =
with
| Not_found -> internal_error "runaway Not_found"
-and parse_package_if_needed state (package_name, pos) =
- if List.mem package_name !Config_file.ignored_packages then [], state else
+and parse_package_if_needed per_files (package_name, pos) =
+ if List.mem package_name !Config_file.ignored_packages then [], per_files else
let splitted = split_at2 ':'':' package_name in
let rel_file = String.concat "/" splitted ^ ".pm" in
@@ -65,34 +60,24 @@ and parse_package_if_needed state (package_name, pos) =
Config_file.read_any (Filename.dirname file) (List.length splitted) ;
let already_done =
try
- let pkg = Hashtbl.find state.per_package package_name in
- if pkg.from_cache then
- if pkg.build_time > mtime file then (
- Hashtbl.replace state.per_package package_name { pkg with from_cache = false };
- (*print_endline_flush (package_name ^ " wants " ^ String.concat " " (List.map fst pkg.required_packages)) ; *)
- Some pkg.required_packages
- ) else (
- if !Flags.verbose then print_endline_flush (Printf.sprintf "cached version of %s is outdated, re-parsing" file);
- Hashtbl.remove state.per_package package_name ; (* so that check on file name below doesn't need to check from_cache *)
- None
- )
- else Some []
+ let per_file = Hashtbl.find per_files file in
+ Some (collect (fun pkg -> pkg.required_packages) per_file.packages)
with Not_found -> None in
match already_done with
- | Some required_packages -> required_packages, state
- | None ->
- if hashtbl_exists (fun _ pkg -> pkg.file_name = file) state.per_package
- then [], state (* already seen, it happens when many files have the same package_name *)
- else parse_file (dir = !basedir) state file
+ | Some required_packages -> required_packages, per_files
+ | None -> parse_file (dir = !basedir) (Some package_name) per_files file
with Not_found ->
warn_with_pos pos (Printf.sprintf "can't find package %s" package_name) ;
- [], state
+ [], per_files
-let rec parse_required_packages state = function
- | [] -> state
+let rec parse_required_packages state already_done = function
+ | [] -> state, already_done
| e :: l ->
- let el, state = parse_package_if_needed state e in
- parse_required_packages state (el @ l)
+ if List.mem e already_done then
+ parse_required_packages state already_done l
+ else
+ let el, state = parse_package_if_needed state e in
+ parse_required_packages state (e :: already_done) (el @ l)
let parse_options =
@@ -118,29 +103,54 @@ 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 required_packages, state = collect_withenv (parse_file true) (default_state()) 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
if !Flags.generate_pot then Parser_helper.generate_pot !pot_file else (
if !restrict_to_files then Common.print_endline_flush_quiet := true ;
- let state = parse_required_packages state required_packages in
+ let per_files, required_packages = parse_required_packages per_files [] required_packages in
+ let l_required_packages = List.map fst required_packages in
if !restrict_to_files then Common.print_endline_flush_quiet := false ;
- let state = arrange_global_vars_declared state in
+ write_packages_cache per_files !basedir ;
+
+ (* removing non needed files from per_files (those files come from the cache) *)
+ List.iter (fun k ->
+ let per_file = Hashtbl.find per_files k in
+ if not (per_file.require_name = None || List.mem (some per_file.require_name) l_required_packages) then
+ Hashtbl.remove per_files k
+ ) (hashtbl_keys per_files);
+
+ let state = default_state per_files in
+
+ Hashtbl.iter (fun _ per_file -> List.iter (add_package_to_state state) per_file.packages) per_files ;
- write_packages_cache state !basedir ;
+ let state =
+ let global_vars_declared = Hashtbl.create 16 in
+ let package_name_to_file_name = hashtbl_collect (fun _ per_file -> List.map (fun pkg -> pkg.package_name, per_file.file_name) per_file.packages) per_files in
+ Hashtbl.iter (fun _ pkg ->
+ let file_name = List.assoc pkg.package_name package_name_to_file_name in
+ get_vars_declaration global_vars_declared file_name pkg
+ ) state.per_packages ;
+ arrange_global_vars_declared global_vars_declared state
+ in
let state = Global_checks.get_methods_available state in
- let l = List.map snd (hashtbl_to_list state.per_package) in
- let l = List.filter (fun pkg -> not pkg.from_cache && pkg.from_basedir) l in
+ let l = hashtbl_values per_files in
+ let l = if !restrict_to_files then List.filter (fun file -> List.mem file.file_name files) l else l in
+
+ let l = uniq (collect (fun file -> List.map (fun pkg -> pkg.package_name) file.packages) l) in
+ let l = List.map (Hashtbl.find state.per_packages) l 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 !Config_file.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 (Global_checks.check_tree state) l;
+
if !Flags.check_unused_global_vars then List.iter Global_checks.check_unused_vars l
+
)
diff --git a/perl_checker.src/tree.ml b/perl_checker.src/tree.ml
index eabf553..e126808 100644
--- a/perl_checker.src/tree.ml
+++ b/perl_checker.src/tree.ml
@@ -21,18 +21,22 @@ type prototype = {
}
type per_package = {
- file_name : string ;
package_name : string ; has_package_name : bool ;
- vars_declared : (context * string, pos * bool ref * prototype option) Hashtbl.t ;
- imported : ((context * string) * (string * bool ref * prototype option)) list option ref ;
+ vars_declared : (context * string, pos * bool ref * prototype option) Hashtbl.t;
+ imported : ((context * string) * (string * bool ref * prototype option)) list option ref;
exports : exports ;
uses : uses ;
required_packages : (string * pos) list ;
- body : fromparser list ;
+ body : fromparser list;
isa : (string * pos) list option ;
+ }
+
+type per_file = {
+ file_name : string ;
+ require_name : string option ;
lines_starts : int list ;
build_time : int ;
- from_cache : bool ;
+ packages : per_package list ;
from_basedir : bool ;
}
@@ -204,9 +208,9 @@ let get_isa t =
| _ -> isa, exporter
) (None, None) t
-let read_xs_extension_from_c global_vars_declared package pos =
+let read_xs_extension_from_c global_vars_declared file_name package pos =
try
- let cfile = Filename.chop_extension package.file_name ^ ".c" in
+ let cfile = Filename.chop_extension file_name ^ ".c" in
let prefix = "newXS(\"" ^ package.package_name ^ "::" in
ignore (fold_lines (fun in_bootstrap s ->
if in_bootstrap then
@@ -222,6 +226,7 @@ let read_xs_extension_from_c global_vars_declared package pos =
with Not_found -> ());
in_bootstrap || str_contains s "XS_VERSION_BOOTCHECK"
) false (open_in cfile));
+ if !Flags.verbose then print_endline_flush (sprintf "using xs symbols from %s" cfile) ;
true
with Invalid_argument _ | Sys_error _ -> false
@@ -285,7 +290,7 @@ let get_proto perl_proto body =
{ proto_nb_min = min; proto_nb_max = if others = [] then Some(min + List.length optional) else None }
) (has_proto perl_proto body)
-let get_vars_declaration global_vars_declared package =
+let get_vars_declaration global_vars_declared file_name package =
List.iter (function
| Sub_declaration(Ident(None, name, pos), perl_proto, body, _) ->
Hashtbl.replace package.vars_declared (I_func, name) (pos, ref false, get_proto perl_proto body)
@@ -308,7 +313,7 @@ let get_vars_declaration global_vars_declared package =
if pkg <> package.package_name then
warn_with_pos 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 package pos) then
+ 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
ignore_package pkg
| _ -> ()
@@ -361,9 +366,9 @@ and fold_tree_option f env = function
| Some e -> fold_tree f env e
-let get_global_info_from_package from_basedir build_time t =
+let get_global_info_from_package from_basedir require_name build_time t =
let current_packages = get_current_package t in
- List.map (fun (current_package, t) ->
+ let packages = List.map (fun (current_package, t) ->
let exports = get_exported t in
let exporting_something() = exports.export_ok <> [] || exports.export_auto <> [] || exports.export_tags <> [] || exports.special_export = Some Re_export_all in
@@ -399,7 +404,6 @@ let get_global_info_from_package from_basedir build_time t =
| _ -> None)
) required_packages t in
{
- file_name = !Info.current_file ;
package_name = package_name;
has_package_name = current_package <> None ;
exports = exports ;
@@ -409,9 +413,21 @@ let get_global_info_from_package from_basedir build_time t =
required_packages = required_packages ;
body = t ;
isa = isa ;
- lines_starts = !Info.current_file_lines_starts ;
- build_time = build_time ;
- from_cache = false ;
- from_basedir = from_basedir ;
}
- ) current_packages
+ ) current_packages in
+
+ let require_name = match require_name with
+ | Some require_name -> Some require_name
+ | None -> match packages with
+ | [ pkg ] when pkg.has_package_name -> Some pkg.package_name
+ | _ -> None
+ in
+ {
+ file_name = !Info.current_file ;
+ require_name = require_name ;
+ lines_starts = !Info.current_file_lines_starts ;
+ build_time = build_time ;
+ packages = packages ;
+ from_basedir = from_basedir ;
+ }
+
diff --git a/perl_checker.src/tree.mli b/perl_checker.src/tree.mli
index 473ab39..fb449d5 100644
--- a/perl_checker.src/tree.mli
+++ b/perl_checker.src/tree.mli
@@ -18,7 +18,6 @@ type prototype = {
}
type per_package = {
- file_name : string ;
package_name : string ; has_package_name : bool ;
vars_declared : (context * string, pos * bool ref * prototype option) Hashtbl.t;
imported : ((context * string) * (string * bool ref * prototype option)) list option ref;
@@ -27,9 +26,14 @@ type per_package = {
required_packages : (string * pos) list ;
body : fromparser list;
isa : (string * pos) list option ;
+ }
+
+type per_file = {
+ file_name : string ;
+ require_name : string option ;
lines_starts : int list ;
build_time : int ;
- from_cache : bool ;
+ packages : per_package list ;
from_basedir : bool ;
}
@@ -39,10 +43,10 @@ val use_lib : string list ref
val uses_external_package : string -> bool
val findfile : string list -> string -> string
-val get_global_info_from_package : bool -> int -> fromparser list -> per_package list
+val get_global_info_from_package : bool -> string option -> int -> fromparser list -> per_file
val has_proto : string option -> fromparser -> ((context * string) list * pos * fromparser list) option
-val get_vars_declaration : (context * string * string, pos * prototype option) Hashtbl.t -> per_package -> unit
+val get_vars_declaration : (context * string * string, pos * prototype option) Hashtbl.t -> string -> per_package -> unit
val die_with_pos : string * int * int -> string -> 'a
val warn_with_pos : string * int * int -> string -> unit