habc-xml + swfmill is replaced by habc-link.
################################################
OCAMLINCLUDES += $(ROOT)
-.SUBDIRS: scm xml driver base lib camlp4 swflib link
+.SUBDIRS: scm driver base lib camlp4 swflib link
# ------------------------------
# all
-PROGRAM = $(CopyFrom scm/habc-scm$(EXE) xml/habc-xml$(EXE) driver/habc$(EXE) link/habc-link$(EXE))
+PROGRAM = $(CopyFrom scm/habc-scm$(EXE) driver/habc$(EXE) link/habc-link$(EXE))
all: config $(PROGRAM) lib
+++ /dev/null
-.omakedb
-.omakedb.lock
-*.omc
-*~
-*.cm[iox]
-*.o
-abc2xml
-runner
-*.opt
-*.run
-*.cm[ax]
-*.cmxa
-*.a
+++ /dev/null
-#use "topfind";;
-#load "camlp4o.cma";;
-#load "camlp4/pa_oo.cmo";;
-
-#require "oUnit";;
-#require "extlib";;
-#require "xml-light";;
-
-#load "base.cmo";;
-#load "parsec.cmo";;
-#load "byte.cmo";;
-#load "easyXml.cmo";;
-#load "disasm.cmo";;
-#load "abc.cmo";;
-#load "action.cmo";;
+++ /dev/null
-# ------------------------------
-# BUILD
-# ------------------------------
-# package
-OCAMLPACKS[] =
- extlib
- xml-light
- oUnit
- gz
-UseCamlp4(pa_oo)
-
-FILES[] =
- code
- easyXml
- swfmill
- parsec
- code
- $(ROOT)/swflib
- $(ROOT)/config
-
-OCAMLINCLUDES += $(ROOT)/base
-OCAML_LIBS += $(ROOT)/base/base
-
-PROGRAM = habc-xml
-
-OCamlProgram($(PROGRAM), main $(FILES))
-
-.DEFAULT: $(PROGRAM)
-
-# ------------------------------
-# Test
-# ------------------------------
-OUnitTest(swfmill,swfmill easyXml code parsec $(ROOT)/swflib)
-OUnitTest(code ,code easyXml)
-
-# ------------------------------
-# PHONY target
-# ------------------------------
-.PHONY: clean
-
-clean:
- ocaml-clean
-
+++ /dev/null
-habc-xml: XML dumper for Actionscript Bytecode 2
-================================================
-
-OVERVIEW
---------
-`habc-xml` is port of Happy ABC. This could dump Actionscript ByteCode(ABC) 2
-as XML.
-
-REQUIRES
---------
-
-* OCaml >= 3.10
-* omake
-* findlib
-* xml-light
-
-
-BUILD
------
-
- $ omake
- $ (omake check)
-
-
-LICENCE
--------
-This promgram is free software; you can distribute it and modify it under MIT Licence.
-
-
-AUTHOR
-------
-MIZUNO "mzp" Hiroki (mzp_at_happyabc.org)
-
+++ /dev/null
-open Base
-open EasyXml
-
-let label =
- function
- Left _ ->
- failwith "must not happen"
- | Right adr ->
- adr
-
-let op name =
- attr name []
-
-let op_a name attrs =
- attr name @@ List.map (fun (x,y) -> (x,string_of_int y)) attrs
-
-let op_i name attrs =
- attr name @@ List.map (fun (x,y) -> (x,string_of_int y)) attrs
-
-let to_xml = function
- `Add ->
- op "OpAdd"
- | `Add_i ->
- op "OpAddI"
- | `AsType index ->
- op_a "OpAsType" ["name",index]
- | `AsTypeLate ->
- op "OpAsTypeLate"
- | `BitAnd ->
- op "OpBitAnd"
- | `BitNot ->
- op "OpBitNot"
- | `BitOr ->
- op "OpBitOr"
- | `BitXor ->
- op "OpBitXor"
- | `Call argc ->
- op_a "OpCall" ["argc",argc]
- | `CallMethod (name,argc) ->
- op_a "OpCallMethod" ["name",name; "argc",argc]
- | `CallProperty (name,argc) ->
- op_a "OpCallProperty" ["name",name; "argc",argc]
- | `CallPropLex (name,argc) ->
- op_a "OpCallPropLex" ["name",name; "argc",argc]
- | `CallPropVoid (name,argc) ->
- op_a "OpCallPropVoid" ["name",name; "argc",argc]
- | `CallStatic (name,argc) ->
- op_a "OpCallStatic" ["name",name; "argc",argc]
- | `CallSuper (name,argc) ->
- op_a "OpCallSuper" ["name",name; "argc",argc]
- | `CallSuperVoid (name,argc) ->
- op_a "OpCallSuperVoid" ["name",name; "argc",argc]
- | `CheckFilter ->
- op "OpCheckFilter"
- | `Coerce ->
- op "OpCoerce"
- | `Coerce_a ->
- op "OpCoerceA"
- | `Coerce_s ->
- op "OpCoerceS"
- | `Construct argc ->
- op_a "OpConstruct" ["argc",argc]
- | `ConstructProp (name,argc) ->
- op_a "OpConstructProp" ["name",name; "argc",argc]
- | `ConstructSuper argc ->
- op_a "OpConstructSuper" ["argc",argc]
- | `Convert_b ->
- op "OpConvertB"
- | `Convert_i ->
- op "OpConvertI"
- | `Convert_d ->
- op "OpConvertD"
- | `Convert_o ->
- op "OpConvertO"
- | `Convert_u ->
- op "OpConvertU"
- | `Convert_s ->
- op "OpConvertS"
- | `Debug (unknown,name,reg,line)->
- attr "OpDebug" ["unknown", string_of_int unknown;
- "name" , Int32.to_string name;
- "reg" , string_of_int reg;
- "line" , Int32.to_string line]
- | `DebugFile file ->
- op_a "OpDebugFile" ["file",file]
- | `DebugLine line ->
- op_a "OpDebugLine" ["line",line]
- | `DecLocal address ->
- op_a "OpDecLocal" ["address",address]
- | `DecLocal_i address ->
- op_a "OpDecLocalI" ["address",address]
- | `Decrement ->
- op "OpDecrement"
- | `Decrement_i ->
- op "OpDecrementI"
- | `DeleteProperty name ->
- op_a "OpDeleteProperty" ["name",name]
- | `Divide ->
- op "OpDivide"
- | `Dup ->
- op "OpDup"
- | `Dxns name ->
- op_a "OpDXNs" ["name",name]
- | `DxnsLate ->
- op "OpDXNsLate"
- | `Equals ->
- op "OpEquals"
- | `Esc_xattr ->
- op "OpEscXattr"
- | `Esc_xelem ->
- op "OpEscXelem"
- | `FindProperty name ->
- op_a "OpFindProperty" ["name",name]
- | `FindPropStrict name ->
- op_a "OpFindPropStrict" ["name",name]
- | `GetDescendants name ->
- op_a "OpGetDescendants" ["name",name]
- | `GetGlobalScope ->
- op "OpGetGlobalScope"
- | `GetGlobalSlot slot_id ->
- op_a "OpGetGlobalSlot" ["soltID",slot_id]
- | `GetLex name ->
- op_a "OpGetLex" ["name",name]
- | `GetLocal address ->
- op_a "OpGetLocal" ["address",address]
- | `GetLocal_0 ->
- op "OpGetLocal0"
- | `GetLocal_1 ->
- op "OpGetLocal1"
- | `GetLocal_2 ->
- op "OpGetLocal2"
- | `GetLocal_3 ->
- op "OpGetLocal3"
- | `GetProperty name ->
- op_a "OpGetProperty" ["name",name]
- | `GetScopeObject scope_index ->
- attr "OpGetScopeObject" ["scopeIndex",string_of_int scope_index]
- | `GetSlot slot_id ->
- op_a "OpGetSlot" ["slotID",slot_id]
- | `GetSuper name ->
- op_a "OpGetSuper" ["name",name]
- | `GreaterEquals ->
- op "OpGreaterEquals"
- | `GreaterThan ->
- op "OpGreaterThan"
- | `HasNext ->
- op "OpHasNext"
- | `HasNext2 (object_reg,index_reg) ->
- op_a "OpHasNext2" ["object",object_reg;"index",index_reg]
- | `IfEq target ->
- op_i "OpIfEq" ["target",label target]
- | `IfFalse target ->
- op_i "OpIfFalse" ["target",label target]
- | `IfGe target ->
- op_i "OpIfGe" ["target",label target]
- | `IfGt target ->
- op_i "OpIfGt" ["target",label target]
- | `IfLe target ->
- op_i "OpIfLe" ["target",label target]
- | `IfLt target ->
- op_i "OpIfLt" ["target",label target]
- | `IfNge target ->
- op_i "OpIfNge" ["target",label target]
- | `IfNgt target ->
- op_i "OpIfNgt" ["target",label target]
- | `IfNle target ->
- op_i "OpIfNle" ["target",label target]
- | `IfNlt target ->
- op_i "OpIfNgt" ["target",label target]
- | `IfNe target ->
- op_i "OpIfNe" ["target",label target]
- | `IfStrictEq target ->
- op_i "OpIfStrictEq" ["target",label target]
- | `IfStrictNe target ->
- op_i "OpIfStrictNe" ["target",label target]
- | `IfTrue target ->
- op_i "OpIfTrue" ["target",label target]
- | `In ->
- op "OpIn"
- | `IncLocal address ->
- op_a "OpIncLocal" ["address",address]
- | `IncLocal_i address ->
- op_a "OpIncLocalI" ["address",address]
- | `Increment ->
- op "OpIncrement"
- | `Increment_i ->
- op "OpIncrementI"
- | `InitProperty name ->
- op_a "OpInitProperty" ["name",name]
- | `InstanceOf ->
- op "OpInstanceOf"
- | `IsType name ->
- op_a "OpIsType" ["name",name]
- | `IsTypeLate ->
- op "OpIsTypeLate"
- | `Jump target ->
- op_i "OpJump" ["target",label target]
- | `Kill address ->
- op_a "OpKill" ["address",address]
- | `Label _ ->
- op "OpLabel"
- | `LessEquals ->
- op "OpLessEquals"
- | `LessThan ->
- op "OpLessThan"
- | `LookupSwitch (default_target,target_table) ->
- element "OpLookupSwitch" ["defaultTarget",string_of_int default_target;
- "caseCount" ,string_of_int @@ List.length target_table]
- [elem "targetTable" @@ List.map (fun v -> attr "U30" ["value",string_of_int v]) target_table]
- | `LShift ->
- op "OpLShift"
- | `Modulo ->
- op "OpModulo"
- | `Multiply ->
- op "OpMultiply"
- | `Multiply_i ->
- op "OpMultiplyI"
- | `Negate ->
- op "OpNegate"
- | `Negate_i ->
- op "OpNegateI"
- | `NewActivation ->
- op "OpNewActivation"
- | `NewArray argc ->
- op_a "OpNewArray" ["argc",argc]
- | `NewCatch exceptionIndex ->
- op_a "OpNewCatch" ["exceptionIndex",exceptionIndex]
- | `NewClass classIndex ->
- op_a "OpNewClass" ["classIndex",classIndex]
- | `NewFunction index ->
- op_a "OpNewFunction" ["index",index]
- | `NewObject argc ->
- op_a "OpNewObject" ["argc",argc]
- | `NextName ->
- op "OpNextName"
- | `NextValue ->
- op "OpNextValue"
- | `Nop ->
- op "OpNop"
- | `Not ->
- op "OpNot"
- | `Pop ->
- op "OpPop"
- | `PopScope ->
- op "OpPopScope"
- | `PushByte byte ->
- attr "OpPushByte" ["value",string_of_int byte]
- | `PushDouble index ->
- op_a "OpPushDouble" ["index",index]
- | `PushFalse ->
- op "OpPushFalse"
- | `PushNaN ->
- op "OpPushNaN"
- | `PushInt index ->
- op_a "OpPushInt" ["index",index]
- | `PushNamespace index ->
- op_a "OpPushNamespace" ["index",index]
- | `PushNan ->
- op "OpPushNan"
- | `PushNull ->
- op "OpPushNull"
- | `PushScope ->
- op "OpPushScope"
- | `PushShort value ->
- op_a "OpPushShort" ["value",value]
- | `PushString index ->
- op_a "OpPushString" ["index",index]
- | `PushTrue ->
- op "OpPushTrue"
- | `PushUInt index ->
- op_a "OpPushUInt" ["index",index]
- | `PushUndefined ->
- op "OpPushUndefined"
- | `PushWith ->
- op "OpPushWith"
- | `ReturnValue ->
- op "OpReturnValue"
- | `ReturnVoid ->
- op "OpReturnVoid"
- | `RShift ->
- op "OpRShift"
- | `SetLocal address ->
- op_a "OpSetLocal" ["address",address]
- | `SetLocal_0 ->
- op "OpSetLocal0"
- | `SetLocal_1 ->
- op "OpSetLocal1"
- | `SetLocal_2 ->
- op "OpSetLocal2"
- | `SetLocal_3 ->
- op "OpSetLocal3"
- | `SetGlobalSlot slot_id ->
- op_a "OpSetGlobalSlot" ["slotID",slot_id]
- | `SetProperty name ->
- op_a "OpSetProperty" ["name",name]
- | `SetSlot slot_id ->
- op_a "OpSetSlot" ["slotID",slot_id]
- | `SetSuper name ->
- op_a "OpSetSuper" ["name",name]
- | `StrictEquals ->
- op "OpStrictEquals"
- | `Subtract ->
- op "OpSubtract"
- | `Subtract_i ->
- op "OpSubtractI"
- | `SubtractI ->
- op "OpSubtractI"
- | `Swap ->
- op "OpSwap"
- | `Throw ->
- op "OpThrow"
- | `TypeOf ->
- op "OpTypeOf"
- | `URShift ->
- op "OpURShift"
-
+++ /dev/null
-open Base
-open OUnit
-open EasyXml
-
-let ok x y =
- OUnit.assert_equal ~printer:Xml.to_string_fmt (normalize x) (normalize y)
-
-let _ =
- ("code module test" >::: [
- "add" >::
- (fun _ ->
- ok (elem "OpAdd" []) @@
- Code.to_xml `Add);
- "constructprop" >::
- (fun _ ->
- ok (attr "OpConstructProp" ["name","1";"argc","42"]) @@
- Code.to_xml (`ConstructProp (1,42)));
- "getlex" >::
- (fun _ ->
- ok (attr "OpGetLex" ["name","42"]) @@
- Code.to_xml (`GetLex 42))
- ]) +> run_test_tt_main
+++ /dev/null
-let element name attrs children =
- Xml.Element (name,attrs,children)
-
-let elem name children =
- element name [] children
-
-let attr name attrs =
- element name attrs []
-
-let pcdata x =
- Xml.PCData x
-
-
-let rec normalize =
- function
- Xml.Element (name,attrs,children) ->
- Xml.Element (name,
- List.sort (fun (a,_) (b,_) -> compare a b) attrs,
- List.map normalize children)
- | Xml.PCData _ as x ->
- x
+++ /dev/null
-open Base
-let _ =
- let argv =
- Array.to_list Sys.argv in
- match argv with
- _::xs ->
- xs +> List.iter (print_endline $
- Xml.to_string_fmt $
- Swfmill.to_xml $
- Swflib.Abc.read $
- Swflib.BytesIn.of_channel $
- open_in_bin)
- | [] ->
- failwith "must not happen"
+++ /dev/null
-open Base
-
-let fail () =
- raise Stream.Failure
-
-let rec times f =
- function
- 0 -> ()
- | n -> f () ;times f (n-1)
-
-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 string str stream =
- let cs =
- ExtString.String.explode str in
- let n =
- List.length cs in
- match Stream.npeek n stream with
- ys when cs = ys ->
- times (fun ()->Stream.junk stream) n;
- ys
- | _ ->
- fail ()
-
-let char c stream =
- match Stream.peek stream with
- Some x when x = c ->
- Stream.junk stream;
- x
- | _ ->
- fail ()
-
-let rec until c stream =
- match Stream.peek stream with
- Some x when x != c ->
- Stream.junk stream;
- x::(until c stream)
- | _ ->
- []
-
-let one_of str stream =
- match Stream.peek stream with
- Some c when String.contains str c ->
- Stream.next stream
- | _ ->
- fail ()
-
-let option f stream =
- try
- Some (f stream)
- with Stream.Failure ->
- None
-
-let (<|>) f g =
- parser
- [<e = f>] -> e
- | [<e = g>] -> e
-
-let rec many parse stream =
- match stream with parser
- [< e = parse; s>] -> e::many parse s
- | [<>] -> []
-
-let many1 parse stream =
- let x =
- parse stream in
- x::many parse stream
-
-let alpha stream =
- match Stream.peek stream with
- Some ('a'..'z') | Some ('A'..'Z') ->
- Stream.next stream
- | _ ->
- fail ()
-
-let digit stream =
- match Stream.peek stream with
- Some ('0'..'9') ->
- Stream.next stream
- | _ ->
- fail ()
-
-let try_ f stream =
- (*
- Use black-magic to save stream state
-
- from stream.ml:
- type 'a t = { count : int; data : 'a data }
- *)
- let t =
- Obj.repr stream in
- let count =
- Obj.field t 0 in
- let data =
- Obj.field t 1 in
- try
- f stream
- with Stream.Failure | Stream.Error _ ->
- Obj.set_field t 0 count;
- Obj.set_field t 1 data;
- fail ()
+++ /dev/null
-open Base
-open EasyXml
-open Swflib.AbcType
-
-let some x =
- match x with Some _ -> "1" | None -> "0"
-
-let bool x =
- if x then "1" else "0"
-
-let u30 x =
- attr "U30" ["value",string_of_int x]
-
-let value name x =
- attr name ["value",x]
-
-let index_attr name xs =
- attr name @@ List.map (fun (x,y) -> (x,string_of_int y)) xs
-
-let elem_with name f xs =
- elem name @@ List.map f xs
-
-let of_namespace ns =
- let make name index =
- element name ["index", string_of_int index] [] in
- match ns with
- Namespace name ->
- make "Namespace" name
- | PackageNamespace name ->
- make "PackageNamespace" name
- | PackageInternalNamespace name ->
- make "PackageInternalNamespace" name
- | ProtectedNamespace name ->
- make "ProtectedNamespace" name
- | ExplicitNamespace name ->
- make "ExplicitNamespace" name
- | StaticProtectedNamespace _ ->
- failwith "this namespace is not support."
- | PrivateNamespace name ->
- make "PrivateNamespace" name
-
-let of_ns_set ns_set =
- elem "namespaces" @@
- List.map u30 ns_set
-
-let of_multiname =
- function
- QName (ns,name) ->
- index_attr "QName" ["nameIndex",name; "namespaceIndex",ns]
- | QNameA (ns,name) ->
- index_attr "QNameA" ["namespaceIndex",ns; "nameIndex",name]
- | RTQName (name) ->
- index_attr "RTQName" ["nameIndex",name]
- | RTQNameA (name) ->
- index_attr "RTQNameA" ["nameIndex",name]
- | RTQNameL ->
- index_attr "RTQNameL" []
- | RTQNameLA ->
- index_attr "RTQNameLA" []
- | Multiname (name,ns_set) ->
- index_attr "Multiname" ["nameIndex",name; "namespaceSetIndex",ns_set]
- | MultinameA (name,ns_set) ->
- index_attr "MultinameA" ["nameIndex",name; "namespaceSetIndex",ns_set]
- | MultinameL ns_set ->
- index_attr "MultinameL" ["namespaceSetIndex",ns_set]
- | MultinameLA ns_set ->
- index_attr "MultinameLA" ["namespaceSetIndex",ns_set]
-
-let of_cpool cpool =
- elem "Constants"
- [
- elem "ints" @@ List.map u30 cpool.int;
- elem "uints" @@ List.map u30 cpool.uint;
- elem "doubles" @@ List.map (value "Double" $ string_of_float) cpool.double;
- elem "strings" @@ List.map (value "String2") cpool.string;
- elem "namespaces" @@ List.map of_namespace cpool.namespace;
- elem "namespaceSets" @@ List.map of_ns_set cpool.namespace_set;
- elem "multinames" @@ List.map of_multiname cpool.multiname
- ]
-
-let of_method_flags xs =
- List.map begin function
- NeedArguments ->
- ("needArguments" ,bool true)
- | NeedActivation ->
- ("needActivation",bool true)
- | NeedRest ->
- ("needRest" ,bool true)
- | SetDxns ->
- ("setSDXNs" ,bool true)
- | HasOptional _ ->
- ("hasOptional" ,bool true)
- | HasParamNames _ ->
- ("hasParamNames" ,bool true)
- end xs
-
-let of_methods xs =
- elem_with "methods"
- (fun m ->
- element "MethodInfo" (["retType" ,string_of_int m.return;
- "nameIndex" ,string_of_int m.method_name;
- "isExplicit" ,"0"] @
- of_method_flags m.method_flags)
- [elem "paramTypes" @@ List.map u30 m.params])
- xs
-
-let of_metadata xs =
- elem_with "metadata"
- (fun m ->
- element "MetadataInfo" ["nameIndex",string_of_int m.metadata_name]
- [elem "keys" @@ List.map (u30 $ fst) m.items;
- elem "values" @@ List.map (u30 $ snd) m.items ]) xs
-
-let of_trait {trait_name=name; data=data; trait_metadata=metadata } =
- let trait =
- match data with
- ClassTrait (slotID,classi) ->
- index_attr "Class" ["slotID",slotID;
- "classInfo",classi]
- | SlotTrait (id,name,vindex,kind) ->
- index_attr "Slot" @@ (
- ["slotID" ,id;
- "typeIndex" ,name;
- "valueIndex",vindex;
- ] @ match vindex with
- 0 -> [ ]
- | _ -> ["valueKind",kind])
- | ConstTrait (id,name,vindex,kind) ->
- index_attr "Slot" @@ (
- [
- "slotID" ,id;
- "typeIndex" ,name;
- "valueIndex",vindex;
- ] @ match vindex with
- 0 -> [ ]
- | _ -> ["valueKind", kind])
- | FunctionTrait (id,funi) ->
- index_attr "Function"
- ["slotID",id;
- "methodInfo",funi]
- | GetterTrait (id,methodi, _) ->
- index_attr "Getter" ["dispID",id;
- "methodInfo",methodi]
- | MethodTrait (id,methodi, _) ->
- index_attr "Method" ["dispID",id;
- "methodInfo",methodi]
- | SetterTrait (id,methodi, _) ->
- index_attr "Setter" ["dispID",id;
- "methodInfo",methodi] in
- let attrs =
- match data with
- | GetterTrait (_, _, attrs) | MethodTrait (_, _, attrs) | SetterTrait (_, _, attrs) ->
- attrs
- | SlotTrait _ | ConstTrait _ | FunctionTrait _ | ClassTrait _ ->
- []
- in
- element "TraitInfo" [ "nameIndex" ,string_of_int name;
- "hasMetadata",bool (metadata<>[]);
- "override" ,bool (List.mem ATTR_Override attrs);
- "final" ,bool (List.mem ATTR_Final attrs)] @@
- [elem "trait" [trait]]
-
-let of_instance_flags xs =
- HList.concat_map begin function
- Interface ->
- ["interface", bool true]
- | Final ->
- ["final", bool true]
- | Sealed ->
- ["sealed",bool true]
- | ProtectedNs ns ->
- ["isProtectedNs",bool true;
- "protectedNS" ,string_of_int ns]
- end xs
-
-let of_instances instances =
- elem_with "instances"
- (fun i ->
- element "InstanceInfo"
- (["nameIndex" ,string_of_int i.instance_name;
- "superIndex" ,string_of_int i.super_name;
- "iInitIndex" ,string_of_int i.iinit]
- @ of_instance_flags i.instance_flags)
- [elem "interfaces" @@ List.map u30 i.interfaces;
- elem "traits" @@ List.map of_trait i.instance_traits])
- instances
-
-let of_classes xs =
- elem_with "classes"
- (fun c ->
- element "ClassInfo"
- ["cInitIndex",string_of_int c.cinit]
- [elem "traits" @@ List.map of_trait c.class_traits]) xs
-
-let of_exception e =
- index_attr "Exception" [
- "tryStart",e.from_pos;
- "tryEnd" ,e.to_pos;
- "target" ,e.target;
- "type" ,e.exception_type;
- "name" ,e.var_name ]
-
-let of_method_bodies xs =
- elem_with "methodBodies"
- (fun m ->
- element "MethodBody" ["exceptionCount",string_of_int @@ List.length m.exceptions;
- "maxRegs" ,string_of_int m.local_count;
- "maxScope" ,string_of_int m.max_scope_depth;
- "maxStack" ,string_of_int m.max_stack;
- "methodInfo" ,string_of_int m.method_sig;
- "scopeDepth" ,string_of_int m.init_scope_depth]
- [elem_with "code" Code.to_xml m.code;
- elem_with "exceptions" of_exception m.exceptions;
- elem_with "traits" of_trait m.method_traits ]) xs
-
-
-let of_script scripts =
- elem_with "scripts"
- (fun s ->
- element "ScriptInfo" ["initIndex",string_of_int s.init] @@
- [elem_with "traits" of_trait s.script_traits] )
- scripts
-
-
-let of_abc abc =
- element "Action3"
- ["minorVersion",string_of_int Swflib.AbcIn.cMinorVersion;
- "majorVersion",string_of_int Swflib.AbcIn.cMajorVersion]
- [elem "constants" [of_cpool abc.cpool];
- of_methods abc.method_info;
- of_metadata abc.metadata;
- of_instances abc.instances;
- of_classes abc.classes;
- of_script abc.scripts;
- of_method_bodies abc.method_bodies]
-
-let to_xml =
- of_abc
-
-
+++ /dev/null
-open Base
-open OUnit
-open Xml
-open EasyXml
-open Swflib.AbcType
-
-let example name =
- let ch =
- open_in_bin @@ Printf.sprintf "example/%s.abc" name in
- Swflib.Abc.read @@ Swflib.BytesIn.of_channel ch
-
-let ok x y =
- OUnit.assert_equal ~printer:Xml.to_string_fmt (normalize x) (normalize y)
-
-let abc =
- example "hello"
-
-let cpool =
- Swfmill.of_cpool abc.cpool
-
-let methods =
- Swfmill.of_methods abc.method_info
-
-let metadata =
- Swfmill.of_metadata abc.metadata
-
-let instances =
- Swfmill.of_instances abc.instances
-
-let classes =
- Swfmill.of_classes abc.classes
-
-let scripts =
- Swfmill.of_script abc.scripts
-
-let method_bodies =
- Swfmill.of_method_bodies abc.method_bodies
-
-let _ =
- ("action module test" >::: [
- "constants" >::
- (fun () ->
- flip ok cpool @@ elem "Constants"
- [
- elem "ints" [];
- elem "uints" [];
- elem "doubles" [];
- elem "strings" [attr "String2" ["value",""];
- attr "String2" ["value","Hello,world!!"];
- attr "String2" ["value","print"] ];
- elem "namespaces" [attr "Namespace" ["index","1"]];
- elem "namespaceSets" [];
- elem "multinames" [attr "QName" ["namespaceIndex","1";"nameIndex","1"];
- attr "QName" ["namespaceIndex","1";"nameIndex","3"] ]
- ]
- );
- "method info" >::
- (fun _ ->
- flip ok methods @@ elem "methods" [
- element
- "MethodInfo"
- ["retType" ,"0";
- "nameIndex" ,"1";
- "isExplicit" ,"0"]
- [elem "paramTypes" []]
- ]
- );
- "metadata" >::
- (fun _ ->
- flip ok metadata @@ elem "metadata" []);
- "instances" >::
- (fun _ ->
- flip ok instances @@ elem "instances" []);
- "classes" >::
- (fun _ ->
- flip ok classes @@ elem "classes" []);
- "script" >::
- (fun _ ->
- flip ok scripts @@ elem "scripts" [
- element "ScriptInfo" ["initIndex","0"] [elem "traits" []]
- ]);
- "method body" >::
- (fun _ ->
- flip ok method_bodies @@ elem "methodBodies" [
- element "MethodBody" ["methodInfo" ,"0";
- "maxStack" ,"2";
- "maxRegs" ,"1";
- "scopeDepth" ,"0";
- "maxScope" ,"1";
- "exceptionCount","0"]
- [ elem "code" [
- attr "OpGetLocal0" [];
- attr "OpPushScope" [];
- attr "OpFindPropStrict" ["name","2"];
- attr "OpPushString" ["index","2"];
- attr "OpCallPropLex" ["name","2";"argc","1"];
- attr "OpPop" [];
- attr "OpReturnVoid" []; ];
- elem "exceptions" [];
- elem "traits" [] ]
- ]);
- ]) +> run_test_tt_main
+++ /dev/null
-open Base
-let ok x y =
- OUnit.assert_equal ~printer:Std.dump x y
-
-let example name =
- let ch =
- open_in_bin @@ Printf.sprintf "../example/%s.abc" name in
- Abc.of_stream @@ Byte.of_channel ch