diff options
Diffstat (limited to 'perl_checker.src')
| -rw-r--r-- | perl_checker.src/common.ml | 56 | ||||
| -rw-r--r-- | perl_checker.src/common.mli | 7 | ||||
| -rw-r--r-- | perl_checker.src/global_checks.ml | 81 | ||||
| -rw-r--r-- | perl_checker.src/global_checks.mli | 18 | ||||
| -rw-r--r-- | perl_checker.src/perl_checker.ml | 108 | ||||
| -rw-r--r-- | perl_checker.src/tree.ml | 50 | ||||
| -rw-r--r-- | perl_checker.src/tree.mli | 12 |
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 |