From 40b77489b026728d9b0054f1f62fa279f565bbd2 Mon Sep 17 00:00:00 2001 From: mzp Date: Wed, 7 Oct 2009 06:46:43 +0900 Subject: [PATCH 1/1] add `Size to swfBaseOut --- swflib/.gitignore | 3 ++- swflib/swfBaseOut.ml | 26 +++++++++++++++++++++----- swflib/swfBaseOut.mli | 12 +++++++++--- swflib/swfBaseOutTest.ml | 6 +++++- swflib/swfOut.ml | 16 +++++++--------- swflib/swfOut.mli | 2 +- swflib/swfOutTest.ml | 9 ++++++--- 7 files changed, 51 insertions(+), 23 deletions(-) diff --git a/swflib/.gitignore b/swflib/.gitignore index 9f7b560..d21b9e4 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 -- 2.11.0