From b57344b6f2527f13dfcf6452353f09c85faef940 Mon Sep 17 00:00:00 2001

From: "Richard W.M. Jones" <rjones@redhat.com>

Date: Tue, 29 May 2012 20:40:36 +0100

Subject: [PATCH 04/11] ocamlbyteinfo, ocamlplugininfo: Useful utilities from

 Debian, sent upstream.

See:

http://git.debian.org/?p=pkg-ocaml-maint/packages/ocaml.git;a=tree;f=debian/ocamlbyteinfo;hb=HEAD

---

 ocamlbyteinfo.ml   | 101 +++++++++++++++++++++++++++++++++++++++++++++++++

 ocamlplugininfo.ml | 109 +++++++++++++++++++++++++++++++++++++++++++++++++++++

 2 files changed, 210 insertions(+)

 create mode 100644 ocamlbyteinfo.ml

 create mode 100644 ocamlplugininfo.ml

diff --git a/ocamlbyteinfo.ml b/ocamlbyteinfo.ml

new file mode 100644

index 0000000..eb9a293

--- /dev/null

+++ b/ocamlbyteinfo.ml

@@ -0,0 +1,101 @@

+(***********************************************************************)

+(*                                                                     *)

+(*                           Objective Caml                            *)

+(*                                                                     *)

+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)

+(*                                                                     *)

+(*  Copyright 2009 Institut National de Recherche en Informatique et   *)

+(*  en Automatique.  All rights reserved.  This file is distributed    *)

+(*  under the terms of the GNU Library General Public License, with    *)

+(*  the special exception on linking described in file ../../LICENSE.  *)

+(*                                                                     *)

+(***********************************************************************)

+

+(* $Id$ *)

+

+(* Dumps a bytecode binary file *)

+

+open Sys

+open Dynlinkaux

+

+let input_stringlist ic len =

+  let get_string_list sect len =

+    let rec fold s e acc =

+      if e != len then

+        if sect.[e] = '\000' then

+          fold (e+1) (e+1) (String.sub sect s (e-s) :: acc)

+        else fold s (e+1) acc

+      else acc

+    in fold 0 0 []

+  in

+  let sect = String.create len in

+  let _ = really_input ic sect 0 len in

+  get_string_list sect len

+

+let print = Printf.printf

+let perr s =

+  Printf.eprintf "%s\n" s;

+  exit(1)

+let p_title title = print "%s:\n" title

+

+let p_section title format pdata = function

+  | [] -> ()

+  | l ->

+      p_title title;

+      List.iter

+        (fun (name, data) -> print format (pdata data) name)

+        l

+

+let p_list title format = function

+  | [] -> ()

+  | l ->

+      p_title title;

+      List.iter

+        (fun name -> print format name)

+        l

+

+let _ =

+  try

+    let input_name = Sys.argv.(1) in

+    let ic = open_in_bin input_name in

+    Bytesections.read_toc ic;

+    List.iter

+      (fun section ->

+         try

+           let len = Bytesections.seek_section ic section in

+           if len > 0 then match section with

+             | "CRCS" ->

+                 p_section

+                   "Imported Units"

+                   "\t%s\t%s\n"

+                   Digest.to_hex

+                   (input_value ic : (string * Digest.t) list)

+             | "DLLS" ->

+                 p_list

+                   "Used Dlls" "\t%s\n"

+                   (input_stringlist ic len)

+             | "DLPT" ->

+                 p_list

+                   "Additional Dll paths"

+                   "\t%s\n"

+                   (input_stringlist ic len)

+             | "PRIM" ->

+                 let prims = (input_stringlist ic len) in

+                 print "Uses unsafe features: ";

+                 begin match prims with

+                     [] -> print "no\n"

+                   | l  -> print "YES\n";

+                       p_list "Primitives declared in this module"

+                         "\t%s\n"

+                         l

+                 end

+             | _ -> ()

+         with Not_found | Failure _ | Invalid_argument _ -> ()

+      )

+      ["CRCS"; "DLLS"; "DLPT"; "PRIM"];

+    close_in ic

+  with

+    | Sys_error msg ->

+        perr msg

+    | Invalid_argument("index out of bounds") ->

+        perr (Printf.sprintf "Usage: %s filename" Sys.argv.(0))

diff --git a/ocamlplugininfo.ml b/ocamlplugininfo.ml

new file mode 100644

index 0000000..e28800f

--- /dev/null

+++ b/ocamlplugininfo.ml

@@ -0,0 +1,109 @@

+(***********************************************************************)

+(*                                                                     *)

+(*                           Objective Caml                            *)

+(*                                                                     *)

+(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)

+(*                                                                     *)

+(*  Copyright 2009 Institut National de Recherche en Informatique et   *)

+(*  en Automatique.  All rights reserved.  This file is distributed    *)

+(*  under the terms of the GNU Library General Public License, with    *)

+(*  the special exception on linking described in file ../../LICENSE.  *)

+(*                                                                     *)

+(***********************************************************************)

+

+(* $Id$ *)

+

+(* Dumps a .cmxs file *)

+

+open Natdynlink

+open Format

+

+let file =

+  try

+    Sys.argv.(1)

+  with _ -> begin

+    Printf.eprintf "Usage: %s file.cmxs\n" Sys.argv.(0);

+    exit(1)

+  end

+

+exception Abnormal_exit

+

+let error s e =

+  let eprint = Printf.eprintf in

+  let print_exc s = function

+    | End_of_file ->

+       eprint "%s: %s\n" s file

+    | Abnormal_exit ->

+        eprint "%s\n" s

+    | e -> eprint "%s\n" (Printexc.to_string e)

+  in

+    print_exc s e;

+    exit(1)

+

+let read_in command =

+  let cmd = Printf.sprintf command file in

+  let ic = Unix.open_process_in cmd in

+  try

+    let line = input_line ic in

+    begin match (Unix.close_process_in ic) with

+      | Unix.WEXITED 0 -> Str.split (Str.regexp "[ ]+") line

+      | Unix.WEXITED _  | Unix.WSIGNALED _ | Unix.WSTOPPED _ ->

+          error

+            (Printf.sprintf

+               "Command \"%s\" exited abnormally"

+               cmd

+            )

+            Abnormal_exit

+    end

+  with e -> error "File is empty" e

+

+let get_offset adr_off adr_sec =

+  try

+    let adr = List.nth adr_off 4 in

+    let off = List.nth adr_off 5 in

+    let sec = List.hd adr_sec in

+

+    let (!) x = Int64.of_string ("0x" ^ x) in

+    let (+) = Int64.add in

+    let (-) = Int64.sub in

+

+      Int64.to_int (!off + !sec - !adr)

+

+  with Failure _ | Invalid_argument _ ->

+    error

+      "Command output doesn't have the expected format"

+      Abnormal_exit

+

+let print_infos name crc defines cmi cmx =

+  let print_name_crc (name, crc) =

+    printf "@ %s (%s)" name (Digest.to_hex crc)

+  in

+  let pr_imports ppf imps = List.iter print_name_crc imps in

+  printf "Name: %s@." name;

+  printf "CRC of implementation: %s@." (Digest.to_hex crc);

+  printf "@[<hov 2>Globals defined:";

+  List.iter (fun s -> printf "@ %s" s) defines;

+  printf "@]@.";

+  printf "@[<v 2>Interfaces imported:%a@]@." pr_imports cmi;

+  printf "@[<v 2>Implementations imported:%a@]@." pr_imports cmx

+

+let _ =

+  let adr_off = read_in "objdump -h %s | grep ' .data '" in

+  let adr_sec = read_in "objdump -T %s | grep ' caml_plugin_header$'" in

+

+  let ic = open_in file in

+  let _ = seek_in ic (get_offset adr_off adr_sec) in

+  let header  = (input_value ic : Natdynlink.dynheader) in

+    if header.magic <> Natdynlink.dyn_magic_number then

+      raise(Error(Natdynlink.Not_a_bytecode_file file))

+    else begin

+      List.iter

+        (fun ui ->

+           print_infos

+             ui.name

+             ui.crc

+             ui.defines

+             ui.imports_cmi

+             ui.imports_cmx)

+        header.units

+    end

-- 

1.9.3