diff options
Diffstat (limited to 'perl_checker.src/tree.ml')
| -rw-r--r-- | perl_checker.src/tree.ml | 443 |
1 files changed, 0 insertions, 443 deletions
diff --git a/perl_checker.src/tree.ml b/perl_checker.src/tree.ml deleted file mode 100644 index 16fd0e4..0000000 --- a/perl_checker.src/tree.ml +++ /dev/null @@ -1,443 +0,0 @@ -open Types -open Common -open Printf -open Config_file -open Parser_helper - -type special_export = Re_export_all | Fake_export_all - -type exports = { - export_ok : (context * string) list ; - export_auto : (context * string) list ; - export_tags : (string * (context * string) list) list ; - special_export : special_export option ; - } - -type uses = (string * ((context * string) list option * pos)) list - -type prototype = { - proto_nb_min : int ; - proto_nb_max : int option ; - } - -type variable_used = Access_none | Access_write_only | Access_various - -type per_package = { - package_name : string ; has_package_name : bool ; - vars_declared : (context * string, pos * variable_used ref * prototype option) Hashtbl.t; - imported : ((context * string) * (string * variable_used ref * prototype option)) list option ref; - exports : exports ; - uses : uses ; - 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 : float ; - packages : per_package list ; - from_basedir : bool ; - } - -let anonymous_package_count = ref 0 -let empty_exports = { export_ok = []; export_auto = []; export_tags = []; special_export = None } -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); - lpush ignored_packages pkg - -let die_with_pos pos msg = failwith (Info.pos2sfull pos ^ msg) -let warn_with_pos warn_types pos msg = if Flags.are_warning_types_set warn_types then print_endline_flush (Info.pos2sfull pos ^ msg) - -let s2context s = - match s.[0] with - | '$' -> I_scalar, skip_n_char 1 s - | '%' -> I_hash , skip_n_char 1 s - | '@' -> I_array , skip_n_char 1 s - | '&' -> I_func , skip_n_char 1 s - | '*' -> I_star , skip_n_char 1 s - | _ -> I_raw, s - - -let get_current_package t = - match t with - | Package(Ident _ as ident) :: body -> - let rec bundled_packages packages current_package found_body = function - | [] -> List.rev ((Some current_package, List.rev found_body) :: packages) - | Package(Ident _ as ident) :: body -> - let packages = (Some current_package, List.rev found_body) :: packages in - bundled_packages packages (string_of_fromparser ident) [] body - | instr :: body -> - bundled_packages packages current_package (instr :: found_body) body - in - bundled_packages [] (string_of_fromparser ident) [] body - | _ -> - if str_ends_with !Info.current_file ".pm" then warn_with_pos [Warn_normalized_expressions] (!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 - | String([s, List []], pos) -> [ s, pos ] - | String(_, pos) -> - warn_with_pos [] pos "not recognised yet" ; - [] - | Raw_string(s, pos) -> - [ s, pos ] - | List [] -> [] - | List [ List l ] -> - some_or (l_option2option_l (List.map (function - | String([s, List []], pos) - | Raw_string(s, pos) -> Some(s, pos) - | Ident(_, _, pos) as ident -> Some(string_of_fromparser ident, pos) - | e -> warn_with_pos [] (get_pos_from_expr e) "not recognised yet"; None - ) l)) [] - | e -> warn_with_pos [] (get_pos_from_expr e) "not recognised yet"; [] - -let from_qw e = - List.map (fun (s, pos) -> - let context, s' = s2context s in - let context = - match context with - | I_raw -> if s'.[0] = ':' then I_raw else I_func - | I_func -> warn_with_pos [Warn_import_export] pos "weird, exported name with a function context especially given"; I_func - | _ -> context - in context, s' - ) (from_qw_raw e) - -let get_exported t = - List.fold_left (fun exports e -> - match e with - | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT", _)); Call _ ], pos) ] - | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT")], _); Call _ ], pos) ] -> - if exports.special_export = None then warn_with_pos [Warn_import_export] pos "unrecognised @EXPORT" ; - exports - - | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT", _)); v ], pos)] - | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT")], _); v ], pos)] -> - if exports.export_auto <> [] then warn_with_pos [Warn_import_export] pos "weird, @EXPORT set twice" ; - { exports with export_auto = from_qw v } - - | Perl_checker_comment("RE-EXPORT-ALL", _) -> { exports with special_export = Some Re_export_all } - | Perl_checker_comment("EXPORT-ALL", _) -> { exports with special_export = Some Fake_export_all } - - | List [ Call_op("=", [ Deref(I_array, Ident(None, "EXPORT_OK", _)); v ], pos)] - | List [ Call_op("=", [ My_our("our", [(I_array, "EXPORT_OK")], _); v ], pos)] -> - if exports.export_ok <> [] then warn_with_pos [Warn_import_export] pos "weird, @EXPORT_OK set twice" ; - (match v with - | Call(Deref(I_func, Ident(None, "map", _)), - [ Anonymous_sub(_, Block [List [Deref(I_array, Deref(I_scalar, Ident (None, "_", _)))]], _); - Call(Deref(I_func, Ident(None, "values", _)), [ Deref(I_hash, Ident(None, "EXPORT_TAGS", _))])]) -> - { exports with export_ok = collect snd exports.export_tags } - | _ -> { exports with export_ok = from_qw v }) - - | List [ Call_op("=", [ Deref(I_hash, Ident(None, "EXPORT_TAGS", _)); v ], pos)] - | List [ Call_op("=", [ My_our("our", [(I_hash, "EXPORT_TAGS")], _); v ], pos)] -> - (try - let export_tags = - match v with - | List [ List l ] -> - List.map (function - | Raw_string(tag, _), Ref(I_array, List [List [v]]) -> - let para = - match v with - | Deref(I_array, Ident(None, "EXPORT_OK", _)) -> exports.export_ok - | _ -> from_qw v - in - ":" ^ tag, para - | _ -> raise Not_found - ) (group_by_2 l) - | _ -> raise Not_found - in - if exports.export_tags <> [] then warn_with_pos [Warn_import_export] pos "weird, %EXPORT_TAGS set twice" ; - { exports with export_tags = export_tags } - with _ -> - warn_with_pos [Warn_import_export] pos "unrecognised %EXPORT_TAGS" ; - exports) - - (* $EXPORT_TAGS{all} = [ map { @$_ } values %EXPORT_TAGS ]; *) - | List [Call_op("=", [ - Deref_with(I_hash, I_scalar, Ident(None, "EXPORT_TAGS", _), Raw_string("all", _)); - Ref(I_array, - List[List[ - Call(Deref(I_func, Ident(None, "map", _)), - [Anonymous_sub(_, Block [List [Deref(I_array, Deref(I_scalar, Ident(None, "_", _)))]], _); - Call(Deref(I_func, Ident(None, "values", _)), [Deref(I_hash, Ident(None, "EXPORT_TAGS", _))])]) - ]]) - ], _)] -> - { exports with export_tags = (":all", collect snd exports.export_tags) :: exports.export_tags } - - | List (My_our _ :: _) -> - let _,_ = e,e in - exports - | _ -> exports - ) empty_exports t - -let uses_external_package = function - | "vars" | "Exporter" | "diagnostics" | "strict" | "warnings" | "lib" | "POSIX" | "Gtk" | "Storable" - | "Config" | "Socket" | "IO::Socket" | "DynaLoader" | "Data::Dumper" | "Time::localtime" | "Expect" -> true - | _ -> false - -let get_uses t = - List.fold_left (fun uses e -> - match e with - | Use(Ident(None, "lib", _), [libs]) -> - use_lib := List.map Info.file_to_absolute_file (List.map snd (from_qw libs)) @ !use_lib ; - uses - | Use(Ident(None, "base", _), classes) -> - let l = List.map (fun (pkg, pos) -> (pkg, (None, pos))) (collect from_qw_raw classes) in - l @ uses - | Use(Ident(_, _, pos) as pkg, l) -> - let package = string_of_fromparser pkg in - if uses_external_package package then - uses - else - let para = match l with - | [] -> None - | [ Num(_, _) ] -> None (* don't care about the version number *) - | _ -> Some(collect from_qw l) - in - (package, (para, pos)) :: uses - | _ -> uses - ) [] t - -let get_isa t = - List.fold_left (fun (isa, exporter) e -> - match e with - | Use(Ident(None, "base", pos), classes) -> - if isa <> None || exporter <> None then die_with_pos pos "\"use base\" and \"@ISA\" must be used once only"; - Some (collect from_qw_raw classes), None - | List [ Call_op("=", [ Deref(I_array, Ident(None, "ISA", pos)) ; classes ], _) ] - | List [ Call_op("=", [ My_our("our", [ I_array, "ISA" ], pos) ; classes ], _) ] -> - if isa <> None || exporter <> None then die_with_pos pos "\"use base\" and \"@ISA\" must be used once only"; - let special, l = List.partition (fun (s, _) -> s = "DynaLoader" || s = "Exporter") (from_qw_raw classes) in - let exporter = if List.mem_assoc "Exporter" special then Some pos else None in - let isa = if l = [] && special <> [] then None else Some l in - isa, exporter - | _ -> isa, exporter - ) (None, None) t - -let read_xs_extension_from_c global_vars_declared file_name package pos = - try - 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 - (try - let offset = strstr s prefix + String.length prefix in - let end_ = String.index_from s offset '"' in - let ident = String.sub s offset (end_ - offset) in - match split_name_or_fq_name ident with - | None, ident -> Hashtbl.replace package.vars_declared (I_func, ident) (pos, ref Access_none, None) - | Some fq, ident -> - let fq = package.package_name ^ "::" ^ fq in - Hashtbl.replace global_vars_declared (I_func, fq, ident) (pos, None) - 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 - -let findfile dirs f = List.find (fun dir -> Sys.file_exists (dir ^ "/" ^ f)) dirs - -let read_xs_extension_from_so global_vars_declared package pos = - try - let splitted = split_at2 ':'':' package.package_name in - let rel_file = String.concat "/" ("auto" :: splitted @ [ last splitted ]) ^ ".so" in - let so = (findfile !use_lib rel_file) ^ "/" ^ rel_file in - let channel = Unix.open_process_in (Printf.sprintf "nm --defined-only -D \"%s\"" so) in - if !Flags.verbose then print_endline_flush (sprintf "using shared-object symbols from %s" so) ; - fold_lines (fun () s -> - let s = skip_n_char 11 s in - if str_begins_with "XS_" s then - let s = skip_n_char 3 s in - let len = String.length s in - let rec find_package_name accu i = - try - let i' = String.index_from s i '_' in - let accu = String.sub s i (i'-i) :: accu in - if i' + 1 < len && s.[i'+1] = '_' then - find_package_name accu (i' + 2) - else - List.rev accu, skip_n_char (i'+1) s - with Not_found -> List.rev accu, skip_n_char i s - in - let fq, name = find_package_name [] 0 in - Hashtbl.replace global_vars_declared (I_func, String.concat "::" fq, name) (pos, None) - ) () channel; - if not Build.debugging then ignore (Unix.close_process_in channel) ; - true - with Not_found -> false - -let has_proto perl_proto body = - match perl_proto with - | Some "" -> Some([], raw_pos2pos bpos, [body]) - | _ -> - match body with - | Block [] -> - Some([ I_array, "_empty" ], raw_pos2pos bpos, []) - | Block (List [Call_op ("=", [My_our ("my", mys, mys_pos); Deref(I_array, Ident(None, "_", _))], _pos)] :: body) -> - Some(mys, mys_pos, body) - | _ -> None - -let get_proto perl_proto body = - map_option (fun (mys, pos, _) -> - let scalars, others = break_at (fun (context, _) -> context <> I_scalar) mys in - (match others with - | (I_array, _) :: _ :: _ -> warn_with_pos [Warn_prototypes] pos "an array must be the last variable in a prototype" - | (I_hash, _) :: _ :: _ -> warn_with_pos [Warn_prototypes] pos "an hash must be the last variable in a prototype" - | _ -> ()); - let is_optional (_, s) = - String.length s > 2 && (s.[0] = 'o' || s.[0] = 'b') && s.[1] = '_' || - String.length s > 3 && s.[0] = '_' && (s.[1] = 'o' || s.[1] = 'b') && s.[2] = '_' - in - let must_have, optional = break_at is_optional scalars in - if not (List.for_all is_optional optional) then - warn_with_pos [Warn_prototypes] pos "an non-optional argument must not follow an optional argument"; - let min = List.length must_have in - { 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 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 Access_none, get_proto perl_proto body) - | Sub_declaration(Ident(Some fq, name, pos), perl_proto, body, _) -> - Hashtbl.replace global_vars_declared (I_func, fq, name) (pos, get_proto perl_proto body) - - | List [ Call_op("=", [My_our("our", ours, pos); _], _) ] - | List [ Call_op("=", [My_our("local", ([ I_scalar, "_" ] as ours), pos); _], _) ] - | List [ My_our("our", ours, pos) ] - | My_our("our", ours, pos) -> - List.iter (fun (context, name) -> Hashtbl.replace package.vars_declared (context, name) (pos, ref Access_none, None)) ours - - | Use(Ident(None, "vars", pos), [ours]) -> - List.iter (fun (context, name) -> Hashtbl.replace package.vars_declared (context, name) (pos, ref Access_none, None)) (from_qw ours) - | Use(Ident(None, "vars", pos), _) -> - die_with_pos pos "usage: use vars qw($var func)" - - | List [ Method_call(Raw_string(pkg, pos), Raw_string("bootstrap", _), _) ] -> - if pkg <> package.package_name then - warn_with_pos [Warn_import_export] 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 file_name package pos) then - if not (read_xs_extension_from_so global_vars_declared package pos) then - ignore_package pkg - | _ -> () - ) package.body - -let rec fold_tree f env e = - match f env e with - | Some env -> env - | None -> - match e with - | Anonymous_sub(_, e', _) - | Ref(_, e') - | Deref(_, e') - -> fold_tree f env e' - - | Diamond(e') - -> fold_tree_option f env e' - - | String(l, _) - -> List.fold_left (fun env (_, e) -> fold_tree f env e) env l - - | Sub_declaration(e1, _, e2, _) - | Deref_with(_, _, e1, e2) - -> - let env = fold_tree f env e1 in - let env = fold_tree f env e2 in - env - - | Use(_, l) - | List l - | Block l - | Call_op(_, l, _) - -> List.fold_left (fold_tree f) env l - - | Call(e', l) - -> - let env = fold_tree f env e' in - List.fold_left (fold_tree f) env l - - | Method_call(e1, e2, l) - -> - let env = fold_tree f env e1 in - let env = fold_tree f env e2 in - List.fold_left (fold_tree f) env l - - | _ -> env - -and fold_tree_option f env = function - | None -> env - | Some e -> fold_tree f env e - - -let get_global_info_from_package from_basedir require_name build_time t = - let current_packages = get_current_package t in - 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 - - let package_name = - match current_package with - | None -> - if exporting_something() then - die_with_pos (!Info.current_file, 0, 0) "file with no package name wants to export!" - else - (incr anonymous_package_count ; sprintf "anonymous%d" !anonymous_package_count) - | Some name -> name - in - let isa, exporter = get_isa t in - (match exporter with - | None -> - if exporting_something() then warn_with_pos [Warn_import_export] (!Info.current_file, 0, 0) "you must have \"@ISA = qw(Exporter)\" to EXPORT something" - | Some pos -> - if not (exporting_something()) then warn_with_pos [Warn_import_export] pos "Inheritating from Exporter without EXPORTing anything"); - - let uses = List.rev (get_uses t) in - let required_packages = List.map (fun (s, (_, pos)) -> s, pos) uses in - let required_packages = List.fold_left (fold_tree (fun l -> - function - | Perl_checker_comment(s, pos) when str_begins_with "require " s -> - Some((skip_n_char 8 s, pos) :: l) - | Call(Deref(I_func, Ident (None, "require", pos)), [Ident _ as pkg]) -> - let package = string_of_fromparser pkg in - if uses_external_package package then None else Some((package, pos) :: l) - | Call(Deref(I_func, Ident (None, "require", pos)), [Raw_string(pkg, _)]) - when not (String.contains pkg '/') && Filename.check_suffix pkg ".pm" -> - let package = Filename.chop_suffix pkg ".pm" in - if uses_external_package package then None else Some((package, pos) :: l) - | _ -> None) - ) required_packages t in - { - package_name = package_name; - has_package_name = current_package <> None ; - exports = exports ; - imported = ref None ; - vars_declared = Hashtbl.create 16 ; - uses = uses ; - required_packages = required_packages ; - body = t ; - isa = isa ; - } - ) 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 ; - } - |