swflib/swfBaseIn.ml

   1 open Base
   2
   3 let byte =
   4   Stream.next
   5
   6 let (++) x y =
   7   (x lsl 8) + y
   8
   9 let (+++) x y =
  10   Int32.add (Int32.shift_left x 8) y
  11
  12 let s_extend size d =
  13   let n =
  14     Sys.word_size - size - 1 in
  15     (d lsl n) asr n
  16
  17 let ui8 =
  18   parser [< n = byte >] ->
  19     n
  20
  21 let ui16 =
  22   parser [< x = byte; y = byte >] ->
  23     y ++ x
  24
  25 let ui24 =
  26   parser [< x = byte; y = byte; z = byte >] ->
  27     z ++ y ++ x
  28
  29 let ui32 =
  30   parser [< x = byte; y = byte; z = byte; w = byte >] ->
  31     List.fold_left (+++) 0l @@ List.map Int32.of_int [w;z;y;x]
  32
  33 let si8  s =  s_extend 8  @@ ui8 s
  34 let si16 s =  s_extend 16 @@ ui16 s
  35 let si24 s =  s_extend 24 @@ ui24 s
  36 let si32   =  ui32
  37
  38 let leq n stream =
  39   match Stream.peek stream with
  40       Some m when m <= n ->
  41         Stream.next stream
  42     | _ ->
  43         raise Stream.Failure
  44
  45 let rec read_u30 stream =
  46   let (+++) x y =
  47     Int32.logor (Int32.shift_left x 7) (Int32.logand y 0x7Fl) in
  48   match stream with parser
  49       [<n = leq 0x7F >] ->
  50         Int32.of_int n
  51     | [<n = byte>] ->
  52         read_u30 stream +++ Int32.of_int n
  53     | [<>] ->
  54         raise (Stream.Error "invalid format")
  55
  56 let eui32 = read_u30
  57
  58 let bits ~f s =
  59   f @@ BitsIn.of_stream s
  60
  61 let ub n bs =
  62   BitsIn.bits n bs
  63
  64 let sb n bs =
  65   s_extend n (ub n bs)
  66
  67 let fixed =
  68   parser [< decimal = float $ ui16; int = float $ ui16>] ->
  69     int +. (decimal /. float 0x1_00_00)
  70
  71 let fixed8 =
  72   parser [< decimal = float $ ui8; int = float $ ui8 >] ->
  73     int +. (decimal /. float 0x1_00)
  74
  75 let float32 =
  76   parser [< d = ui32 >] ->
  77     Int32.float_of_bits d
  78
  79 let float64 =
  80   open Int64 in
  81   parser [< x = of_int32 $ ui32; y = of_int32 $ ui32 >] ->
  82     float_of_bits @@ logor (shift_left y 32) x
  83
  84 let rect s = bits s ~f:begin parser
  85     [< n = ub 5; x_min = sb n; x_max = sb n; y_min = sb n; y_max = sb n>] ->
  86       (x_min, x_max, y_min, y_max)
  87 end