add `Size to swfBaseOut

diff --git a/swflib/.gitignore b/swflib/.gitignore
index 9f7b560..d21b9e4 100644 (file)
--- a/swflib/.gitignore
+++ b/swflib/.gitignore
@@ -2,4 +2,5 @@ gen_inst
 gen_typemap
 lowInst.ml
 highInst.ml
-*.h
\ No newline at end of file
+*.h
+tagOut.ml
\ No newline at end of file

diff --git a/swflib/swfBaseOut.ml b/swflib/swfBaseOut.ml
index 748d4b7..c094231 100644 (file)
--- a/swflib/swfBaseOut.ml
+++ b/swflib/swfBaseOut.ml
@@ -29,11 +29,14 @@ type compose = [
 | `RGBA    of int * int * int * int
 ]
 
+type s = [ byte | compose ]
+
 type backpatch = [
   `Ui32Size
+| `Size    of (int -> s list) * s list
 ]
 
-type t = [ byte | compose | backpatch ]
+type t = [ s | backpatch ]
 
 let rec g_si mask shift n value =
   unfold begin fun (n,value) ->
@@ -94,7 +97,7 @@ let to_int : byte -> int list = function
       List.fold_left ~f:bits ~init:BitsOut.empty xs
       +> BitsOut.to_list
 
-let to_byte = function
+let to_byte : compose -> byte list = function
     `Fixed x ->
       let int =
        floor x in
@@ -126,7 +129,12 @@ let to_byte = function
   | `RGBA(r,g,b,a) ->
       [`Ui8 r; `Ui8 g; `Ui8 b; `Ui8 a]
 
-let backpatch xs =
+let int_of_compose x =
+  match x with
+      #compose as c -> HList.concat_map to_int @@ to_byte c
+    | #byte    as b -> to_int b
+
+let backpatch (xs : [byte | backpatch] list) : int list =
   let (f,size) =
     List.fold_right xs ~init:(const [],0) ~f:begin fun x (f,size) ->
       match x with
@@ -141,14 +149,22 @@ let backpatch xs =
              (* same as Ui30 *)
              size + 4 in
              ((fun size -> to_int (`Ui32 (Int32.of_int size)) @ f size), size')
+       | `Size(g, xs) ->
+           let ints =
+             HList.concat_map int_of_compose xs in
+           let size' =
+             size + List.length ints in
+           let i =
+             HList.concat_map int_of_compose @@ g size' in
+             ((fun ctx -> i @ ints @ f ctx), List.length i + size')
     end in
     f size
 
-let rec to_list (xs : t list) =
+let rec to_list xs =
   xs
   +> HList.concat_map begin function
       #byte      as b  -> [b]
-    | #compose   as c  -> to_byte c
+    | #compose   as c  -> (to_byte c :> [ byte | backpatch] list )
     | #backpatch as bp -> [bp]
   end
   +> backpatch

diff --git a/swflib/swfBaseOut.mli b/swflib/swfBaseOut.mli
index 6aa679e..4b2c280 100644 (file)
--- a/swflib/swfBaseOut.mli
+++ b/swflib/swfBaseOut.mli
@@ -2,7 +2,7 @@ type bit =
     SB of int * int
   | UB of int * int
 
-type t = [
+type s = [
   `Si8     of int
 | `Si16    of int
 | `Si24    of int
@@ -12,16 +12,22 @@ type t = [
 | `Ui24    of int
 | `Ui32    of int32
 | `Ui64    of int64
+| `EUi32   of int32
+| `Bits    of bit list
 | `Fixed   of float
 | `Fixed8  of float
 | `Float32 of float
 | `Float64 of float
-| `EUi32   of int32
-| `Bits    of bit list
 | `Rect    of int*int*int*int
 | `RGB     of int * int * int
 | `RGBA    of int * int * int * int
+]
+
+type backpatch = [
 | `Ui32Size
+| `Size    of (int -> s list) * s list
 ]
 
+type t = [ s | backpatch ]
+
 val to_list : t list -> int list

diff --git a/swflib/swfBaseOutTest.ml b/swflib/swfBaseOutTest.ml
index 606d069..6987953 100644 (file)
--- a/swflib/swfBaseOutTest.ml
+++ b/swflib/swfBaseOutTest.ml
@@ -109,10 +109,14 @@ let _ = begin "swfBaseOut.ml" >::: [
     ok_b [ `Bits [UB(5,2);  SB(2,0);    SB(2,0);    SB(2,1);   SB(2,1)]]    @@ [`Rect (0,0,1,1)];
     ok_b [ `Bits [UB(5,11); SB(11,127); SB(11,260); SB(11,15); SB(11,514)]] @@ [`Rect (127,260,15,514)]
   end;
-  "size" >:: begin fun () ->
+  "whole size" >:: begin fun () ->
     ok_b [`Ui32 4l] [`Ui32Size];
     ok_b [`Ui32 6l; `EUi32 0xFFl] [`Ui32Size;  `EUi32 0xFFl;];
   end;
+  "size" >:: begin fun () ->
+    ok_b [`Ui8 2; `Ui8 0; `Ui8 0]   [`Size ((fun n -> [`Ui8 n]),[`Ui8 0; `Ui8 0])];
+    ok_b [`Ui32 6l; `Ui8 0; `Ui8 0] [`Ui32Size; `Size ((fun _ -> [`Ui8 0;`Ui8 0]),[])]
+  end;
   "rgb" >:: begin fun () ->
     ok_b [`Ui8 1; `Ui8 2; `Ui8 3] [`RGB (1,2,3)];
     ok_b [`Ui8 1; `Ui8 2; `Ui8 3; `Ui8 4] [`RGBA (1,2,3,4)]

diff --git a/swflib/swfOut.ml b/swflib/swfOut.ml
index 43d799a..401d9d0 100644 (file)
--- a/swflib/swfOut.ml
+++ b/swflib/swfOut.ml
@@ -3,7 +3,7 @@ open SwfType
 
 module type TagType = sig
   type t
-  val to_base : t -> int * SwfBaseOut.t list
+  val to_base : t -> int * SwfBaseOut.s list
 end
 
 module Make(Tag : TagType) = struct
@@ -15,17 +15,15 @@ module Make(Tag : TagType) = struct
 
   let of_tag tag =
     let make_type t size =
-      `Ui16 ((t lsl 6) lor size) in
-    let tag,data' =
-      Tag.to_base tag in
-    let size =
-      List.length @@ SwfBaseOut.to_list data' in
       if size < 0x3F then
-       make_type tag size :: data'
+       [`Ui16 ((t lsl 6) lor size)]
       else
-       make_type tag 0x3F :: `Si32 (Int32.of_int size) :: data'
+       [`Ui16 ((t lsl 6) lor 0x3F); `Si32 (Int32.of_int size)] in
+    let t,data' =
+      Tag.to_base tag in
+      [`Size(make_type t, data')]
 
-  let to_base t = [
+  let to_base t : SwfBaseOut.t list = [
     (* signature *)
     char 'F'; char 'W'; char 'S';
     (* version *)

diff --git a/swflib/swfOut.mli b/swflib/swfOut.mli
index efd3a96..d832780 100644 (file)
--- a/swflib/swfOut.mli
+++ b/swflib/swfOut.mli
@@ -1,6 +1,6 @@
 module type TagType = sig
   type t
-  val to_base : t -> int * SwfBaseOut.t list
+  val to_base : t -> int * SwfBaseOut.s list
 end
 
 

diff --git a/swflib/swfOutTest.ml b/swflib/swfOutTest.ml
index e3e3529..ff940e0 100644 (file)
--- a/swflib/swfOutTest.ml
+++ b/swflib/swfOutTest.ml
@@ -3,7 +3,7 @@ open SwfType
 open OUnit
 
 module M = SwfOut.Make(struct
-                        type t = int * SwfBaseOut.t list
+                        type t = int * SwfBaseOut.s list
                         let to_base x = x
                       end)
 open M
@@ -14,6 +14,9 @@ let char c =
 let ok ?msg f x y =
   assert_equal ?msg y (f x)
 
+let ok_b ?msg f x y =
+  assert_equal ?msg (SwfBaseOut.to_list y) (SwfBaseOut.to_list (f x))
+
 let _ = begin "swfOut.ml" >::: [
   "header" >:: begin fun () ->
     let swf = {
@@ -39,10 +42,10 @@ let _ = begin "swfOut.ml" >::: [
       ]
   end;
   "tag" >:: begin fun () ->
-    ok ~msg:"size < 64" of_tag (1, [`Ui8 1;`Ui8 2; `Ui8 3])
+    ok_b ~msg:"size < 64" of_tag (1, [`Ui8 1;`Ui8 2; `Ui8 3])
       [ `Ui16 0b0000000001_000011; `Ui8 1; `Ui8 2; `Ui8 3 ];
     (* size >= 64*)
-    ok ~msg:"size > 64" of_tag (1, HList.replicate 64 (`Ui8 1)) @@
+    ok_b ~msg:"size > 64" of_tag (1, HList.replicate 64 (`Ui8 1)) @@
       [ `Ui16 0b0000000001_111111; `Si32 64l ] @ HList.replicate 64 (`Ui8 1)
   end
 ] end +> run_test_tt_main