add tag type

diff --git a/swflib/tagIn.ml b/swflib/tagIn.ml
index 406c95d..a578d1e 100644 (file)
--- a/swflib/tagIn.ml
+++ b/swflib/tagIn.ml
@@ -1,11 +1,97 @@
 open Base
 open SwfBaseIn
 
-let of_base tag stream =
-  match tag with
-      0 ->
-       `End
-    | 9 ->
-       `SetBackgroundColor (rgb stream)
+let stream tag s =
+  Stream.from begin function
+      0 -> Some tag
     | _ ->
-       failwith "of_base"
+       try
+         Some (Stream.next s)
+       with _ ->
+         None
+  end
+
+let tag n stream =
+  match Stream.peek stream with
+      Some m when m = n ->
+       Stream.next stream
+    | _ ->
+       raise Stream.Failure
+
+let option f stream =
+  try
+    Some (f stream)
+  with Stream.Failure ->
+    None
+
+let rec repeat n f stream =
+  if n = 0 then
+    []
+  else
+    match stream with parser
+       [<c = f>] ->
+         c::repeat (n-1) f stream
+      | [<>] ->
+         raise (Stream.Error "invalid format")
+
+let repeat_l n f stream =
+  repeat (Int32.to_int n) f stream
+
+
+let pair f g = parser
+    [< x = f; y = g >] ->
+      (x,y)
+
+let alist = parser
+    [< count = ui16; xs = repeat count (pair ui16 str) >] ->
+      xs
+
+let bit_bool n s =
+  ub n s = 1
+
+let read = parser
+    [< _ = tag 0 >]->
+      `End
+  | [< _ = tag 9; c = rgb >]->
+      `SetBackgroundColor c
+  | [< _ = tag 43; name = str; anchor = option (tag 1) >] ->
+      `FrameLabel (name,anchor <> None)
+  | [< _ = tag 24 >] ->
+      `Protect
+  | [< _ = tag 56; xs = alist >] ->
+      `ExportAssets xs
+  | [< _ = tag 57; url = str; xs = alist >] ->
+      `ImportAssets (url,xs)
+  | [< _ = tag 58; passwd = str >] ->
+      `EnableDebugger passwd
+  | [< _ = tag 64; _ = ui16; passwd = str >] ->
+      `EnableDebugger2 passwd
+  | [< _ = tag 65; max_rec = ui16; timeout = ui16 >] ->
+      `ScriptLimits (max_rec, timeout)
+  | [< _ = tag 66; depth = ui16; index = ui16 >] ->
+      `SetTabIndex (depth, index)
+  | [< _ = tag 69; (is_metadata, is_as3, use_network) = bits ~f:parser
+          [< _ = ub 3; is_metadata = bit_bool 1; is_as3 = bit_bool 1; _ = ub 2; use_network = bit_bool 1; _ = ub 24 >] ->
+            (is_metadata, is_as3, use_network) >] ->
+      open TagType in
+      `FileAttributes { is_metadata; is_as3; use_network }
+  | [< _ = tag 71; url = str; _ = ui8; _ = ui8; xs = alist >] ->
+      `ImportAssets2 (url,xs)
+  | [< _ = tag 76; xs = alist >] ->
+      `SymbolClass xs
+  | [< _ = tag 77; s = str >] ->
+      `Metadata s
+  | [< _ = tag 78; id = ui16; (left,right,top,bottom) = rect >] ->
+      open SwfType in
+      `DefineScalingGrid (id, {left;right;top;bottom})
+  | [< _ = tag 86;
+       scene_count = eui32; xs = repeat_l scene_count (pair eui32 str);
+       frame_count = eui32; ys = repeat_l frame_count (pair eui32 str); >] ->
+      `DefineSceneAndFrameLabelData (xs, ys)
+  | [< _ = tag 1 >] ->
+      `ShowFrame
+  | [<>] ->
+      failwith "unknown tag"
+
+let of_base tag s =
+  read @@ stream tag s

diff --git a/swflib/tagInTest.ml b/swflib/tagInTest.ml
index 16536cb..64b0cc5 100644 (file)
--- a/swflib/tagInTest.ml
+++ b/swflib/tagInTest.ml
@@ -12,5 +12,15 @@ let _ = begin "tagIn.ml" >::: [
   end;
   "SetBackgroundColor" >:: begin fun () ->
     ok (`SetBackgroundColor (0,1,2)) 9 [`RGB(0,1,2)]
+  end;
+  "FrameLabel" >:: begin fun ()->
+    ok (`FrameLabel ("foo",false)) 43 [`Str "foo"];
+    ok (`FrameLabel ("foo",true))  43 [`Str "foo"; `Ui8 1]
+  end;
+  "FileAttributes" >:: begin fun () ->
+    open SwfBaseOut in
+    ok (`FileAttributes { TagType.is_metadata=true; is_as3=true; use_network=true}) 69 [
+      `Bits [ UB(3,0); UB(1,1); UB(1,1); UB(2,0); UB(1,1); UB(24,0)]
+    ]
   end
 ] end +> run_test_tt_main

diff --git a/swflib/tagOut.ml b/swflib/tagOut.ml
index 954c729..4fc77a3 100644 (file)
--- a/swflib/tagOut.ml
+++ b/swflib/tagOut.ml
@@ -14,12 +14,12 @@ let tag id body =
   (id,body)
 
 let to_base : TagType.t -> int*SwfBaseOut.s list = function
-    `PlaceObject (id,depth,matrix) ->
+(*    `PlaceObject (id,depth,matrix) ->
       tag 4 [
        `Ui16 id;
        `Ui16 depth;
        `Matrix matrix
-      ]
+      ]*)
   | `FrameLabel (name,anchor) ->
       if anchor then
        tag 43 [`Str name; `Ui8 1]
@@ -33,7 +33,7 @@ let to_base : TagType.t -> int*SwfBaseOut.s list = function
       tag 56 @@ alist xs
   | `ImportAssets (url, xs) ->
       tag 57 @@ (`Str url)::alist xs
-  | `EnableDebuger passwd ->
+  | `EnableDebugger passwd ->
       tag 58 [`Str passwd]
   | `EnableDebugger2 passwd ->
       tag 64 [`Ui16 0; `Str passwd]
@@ -61,12 +61,12 @@ let to_base : TagType.t -> int*SwfBaseOut.s list = function
       tag 76 @@ alist xs
   | `Metadata xml ->
       tag 77 [`Str xml]
-  | `DefineScalingGrid {left;right;top;bottom} ->
-      tag 78 [`Rect (left,right,top,bottom)]
+  | `DefineScalingGrid (id, {left;right;top;bottom}) ->
+      tag 78 [`Ui16 id; `Rect (left,right,top,bottom)]
   | `DefineSceneAndFrameLabelData (scenes, frames) ->
       let bytes xs =
        (`EUi32 (Int32.of_int @@ List.length xs))::
-         HList.concat_map (fun (x,y) -> [`EUi32 (Int32.of_int x); `Str y]) xs in
+         HList.concat_map (fun (x,y) -> [`EUi32 x; `Str y]) xs in
       tag 86 @@ List.concat [
        bytes scenes;
        bytes frames;

diff --git a/swflib/tagType.ml b/swflib/tagType.ml
index 4ad7f61..81357e3 100644 (file)
--- a/swflib/tagType.ml
+++ b/swflib/tagType.ml
@@ -7,13 +7,13 @@ type file_attrs = {
 type alist = (int * string) list
 
 type t = [
-| `PlaceObject of int * int * SwfType.matrix
+(*| `PlaceObject of int * int * SwfType.matrix*)
 | `FrameLabel of string * bool
 | `Protect
 | `End
 | `ExportAssets of alist
 | `ImportAssets of string * alist
-| `EnableDebuger of string
+| `EnableDebugger of string
 | `EnableDebugger2 of string
 | `ScriptLimits of int * int
 | `SetTabIndex of int * int
@@ -21,8 +21,8 @@ type t = [
 | `ImportAssets2 of string * alist
 | `SymbolClass of alist
 | `Metadata of string
-| `DefineScalingGrid of SwfType.rect
-| `DefineSceneAndFrameLabelData of (int * string) list * (int * string) list
+| `DefineScalingGrid of int * SwfType.rect
+| `DefineSceneAndFrameLabelData of (int32 * string) list * (int32 * string) list
 | `ShowFrame
 | `SetBackgroundColor of int * int * int
 | `DoABC of bool * string * int list