xff.ml

   1 type offsets =
   2     { off1 : int
   3     ; symstrpos : int
   4     ; symstr : int
   5     ; sec : int
   6     ; sym : int
   7     ; off2 : int
   8     ; secstrpos : int
   9     ; secstr : int
  10     }
  11
  12 type section =
  13     { name : string
  14     ; len : int
  15     ; off : int
  16     }
  17
  18 type xff =
  19     { size : int
  20     ; entry : int
  21     ; offsets : offsets
  22     ; sections : section array
  23     }
  24
  25 let sbufplus sbuf pos =
  26   let s, pos' = sbuf in
  27   s, pos' + pos
  28 ;;
  29
  30 let sbufpos (_, pos) = pos;;
  31
  32 let sbufblt sbuf ~src_pos ~dst ~dst_pos ~len =
  33   let (src, pos) = sbuf in
  34   let src_pos = src_pos + pos in
  35   StringLabels.blit
  36     ~src
  37     ~dst
  38     ~src_pos
  39     ~dst_pos
  40     ~len
  41 ;;
  42
  43 let sbuferr sbuf pos msg =
  44   let p = sbufpos sbuf in
  45   let s = Printf.sprintf "%08x(%08x): %s" p (p+pos) msg in
  46   failwith s
  47 ;;
  48
  49 let r32 sbuf pos =
  50   let s, pos1 = sbuf in
  51   let rb pos2 = Char.code (String.get s (pos + pos1 + pos2)) in
  52   let w0 = (rb 0) lor ((rb 1) lsl 8)
  53   and w1 = (rb 2) lor ((rb 3) lsl 8) in
  54   let u = Int32.shift_left (Int32.of_int w1) 16
  55   and l = Int32.of_int w0 in
  56   Int32.logor u l
  57 ;;
  58
  59 let r16 sbuf pos =
  60   let s, pos1 = sbuf in
  61   let rb pos2 = Char.code (String.get s (pos + pos1 + pos2)) in
  62   (rb 0) lor ((rb 1) lsl 8)
  63 ;;
  64
  65 let r16s sbuf pos =
  66   let v = r16 sbuf pos in
  67   v - ((v land 0x8000) lsl 1)
  68 ;;
  69
  70 let rchar sbuf pos =
  71   let s, pos1 = sbuf in
  72   String.get s (pos + pos1)
  73 ;;
  74
  75 let r8 sbuf pos =
  76   let s, pos1 = sbuf in
  77   Char.code (String.get s (pos + pos1))
  78 ;;
  79
  80 let rint sbuf pos =
  81   let i32 = r32 sbuf pos in
  82   Int32.to_int i32
  83 ;;
  84
  85 let rfloat sbuf pos =
  86   let i32 = r32 sbuf pos in
  87   Int32.float_of_bits i32
  88 ;;
  89
  90 let checkc sbuf n c =
  91   let s, pos = sbuf in
  92   let c' = String.get s (pos+n) in
  93   c' = c
  94 ;;
  95
  96 let check32 sbuf n i32 =
  97   let i32' = r32 sbuf (n*4) in
  98   i32' = i32
  99 ;;
 100
 101 let checklist cf sbuf l =
 102   let rec f n = function
 103     | [] -> true
 104     | e :: rest when cf sbuf n e -> f (n+1) rest
 105     | _ -> false
 106   in
 107   f 0 l
 108 ;;
 109
 110 let checkstr cf sbuf s =
 111   let l = String.length s in
 112   let rec f = function
 113     | 0 -> true
 114     | n when cf sbuf (l-n) s.[l-n] -> f (n-1)
 115     | _ -> false
 116   in
 117   f l
 118 ;;
 119
 120 let cmp sbuf = function
 121   | `chars s -> checkstr checkc sbuf s
 122   | `dwords l -> checklist check32 sbuf l
 123 ;;
 124
 125 let rcstrtabent sbuf pos at =
 126   let (src, pos1) = sbuf in
 127   let begpos = pos1 + pos + at in
 128   let endpos = String.index_from src begpos '\000' in
 129   let len = endpos - begpos in
 130   let dst = String.create len in
 131   StringLabels.blit
 132     ~src
 133     ~dst
 134     ~src_pos:begpos
 135     ~dst_pos:0
 136     ~len
 137   ;
 138   dst
 139 ;;
 140
 141 let roffsets sbuf pos =
 142   let ri n = rint sbuf (pos + n*4) in
 143   { off1 = ri 0
 144   ; symstrpos = ri 1
 145   ; symstr = ri 2
 146   ; sec = ri 3
 147   ; sym = ri 4
 148   ; off2 = ri 5
 149   ; secstrpos = ri 6
 150   ; secstr = ri 7
 151   }
 152 ;;
 153
 154 let rstrpos sbuf pos count =
 155   let r n = rint sbuf (pos + n*4) in
 156   Array.init count r
 157 ;;
 158
 159 let rsection sbuf offs secstrpos index =
 160   let secpos = offs.sec + index*8*4 in
 161   let len = rint sbuf (secpos + 2*4)
 162   and off = rint sbuf (secpos + 7*4)
 163   and name = rcstrtabent sbuf offs.secstr (Array.get secstrpos index) in
 164   { name = name
 165   ; len = len
 166   ; off = off
 167   }
 168 ;;
 169
 170 let rxff ic =
 171   let s = String.create 0x50 in
 172   let sbuf = (s, 0) in
 173   let () = really_input ic s 0 0x50 in
 174   let rc n = String.get s n in
 175
 176   if rc 0 <> 'x' || rc 1 <> 'f' || rc 2 <> 'f' ||
 177     (let c = rc 3 in not (c == '2' || c == '\000'))
 178   then
 179     failwith "Not an xff"
 180   ;
 181
 182   let size = rint sbuf (5*4)
 183   and entry = rint sbuf (19*4)
 184   and seccount = rint sbuf (16*4) in
 185
 186   let sbuf =
 187     let s' = String.create size in
 188     let () = really_input ic s' 0x50 (size-0x50) in
 189     StringLabels.blit
 190       ~src:s
 191       ~src_pos:0
 192       ~dst:s'
 193       ~dst_pos:0
 194       ~len:0x50
 195     ;
 196     (s', 0)
 197   in
 198
 199   let offsets = roffsets sbuf 0x50 in
 200
 201   let secstrpos = rstrpos sbuf offsets.secstrpos seccount in
 202   let sections = Array.init seccount (fun n -> rsection sbuf offsets secstrpos n) in
 203   { size = size
 204   ; entry = entry
 205   ; offsets = offsets
 206   ; sections = sections
 207   }, sbuf
 208 ;;
 209
 210 let test path =
 211   let ic = open_in_bin path in
 212   let r = rxff ic in
 213   close_in ic;
 214   r
 215 ;;
 216
 217 let index_path = ref "index/index";;
 218 let base_path = ref None;;
 219
 220 let index =
 221   lazy
 222     (
 223       let ic = open_in_bin !index_path in
 224       let l = input_value ic in
 225       close_in ic;
 226       l
 227     )
 228 ;;
 229
 230 let test2 name =
 231   let (path, off, len) =
 232     let rec find = function
 233       | [] -> failwith ("can't find " ^ name)
 234       | (path, h) :: rest ->
 235           try
 236             let off, len = Hashtbl.find h name in
 237             path, off, len
 238           with Not_found ->
 239             find rest
 240     in
 241     find (Lazy.force index)
 242   in
 243   let path =
 244     match !base_path with
 245     | Some base -> Filename.concat base (Filename.basename path)
 246     | None -> path
 247   in
 248   if false then Format.eprintf "%s %s %08x %d@." name path off len;
 249   let ic = open_in_bin path in
 250   seek_in ic off;
 251   let (_, (s, _)) as r = rxff ic in
 252   close_in ic;
 253   Slice.add name s;
 254   r
 255 ;;