Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
1188 lines (1157 sloc) 39.3 KB
(*
The Haxe Compiler
Copyright (C) 2005-2016 Haxe Foundation
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*)
open Swf
open As3
open As3hl
open Genswf9
open Type
open Common
open Ast
let rec make_tpath = function
| HMPath (pack,name) ->
let pdyn = ref false in
let pack, name = match pack, name with
| [], "void" -> [], "Void"
| [], "int" -> [], "Int"
| [], "uint" -> [], "UInt"
| [], "Number" -> [], "Float"
| [], "Boolean" -> [], "Bool"
| [], "Object" -> ["flash";"utils"], "Object"
| [], "Function" -> ["flash";"utils"], "Function"
| [], "Class" | [],"Array" -> pdyn := true; pack, name
| [], "Error" -> ["flash";"errors"], "Error"
| [] , "XML" -> ["flash";"xml"], "XML"
| [] , "XMLList" -> ["flash";"xml"], "XMLList"
| [] , "QName" -> ["flash";"utils"], "QName"
| [] , "Namespace" -> ["flash";"utils"], "Namespace"
| [] , "RegExp" -> ["flash";"utils"], "RegExp"
| ["__AS3__";"vec"] , "Vector" -> ["flash"], "Vector"
| _ -> pack, name
in
{
tpackage = pack;
tname = name;
tparams = if !pdyn then [TPType (CTPath { tpackage = []; tname = "Dynamic"; tparams = []; tsub = None; })] else[];
tsub = None;
}
| HMName (id,ns) ->
{
tpackage = (match ns with
| HNInternal (Some ns) -> ExtString.String.nsplit ns "."
| HNPrivate (Some ns) ->
(try
let file, line = ExtString.String.split ns ".as$" in
[file ^ "_" ^ line]
with _ ->
[])
| _ -> []);
tname = id;
tparams = [];
tsub = None;
}
| HMNSAny (id) ->
{
tpackage = [];
tname = id;
tparams = [];
tsub = None;
}
| HMMultiName _ ->
assert false
| HMRuntimeName _ ->
assert false
| HMRuntimeNameLate ->
assert false
| HMMultiNameLate _ ->
assert false
| HMAttrib _ ->
assert false
| HMAny ->
assert false
| HMParams (t,params) ->
let params = List.map (fun t -> TPType (CTPath (make_tpath t))) params in
{ (make_tpath t) with tparams = params }
let make_param cl p =
{ tpackage = fst cl; tname = snd cl; tparams = [TPType (CTPath { tpackage = fst p; tname = snd p; tparams = []; tsub = None })]; tsub = None }
let make_topt = function
| None -> { tpackage = []; tname = "Dynamic"; tparams = []; tsub = None }
| Some t -> make_tpath t
let make_type t = CTPath (make_topt t)
let make_dyn_type t =
match make_topt t with
| { tpackage = ["flash";"utils"]; tname = ("Object"|"Function") } -> make_type None
| o -> CTPath o
let is_valid_path com pack name =
let rec loop = function
| [] ->
false
| load :: l ->
match load (pack,name) Ast.null_pos with
| None -> loop l
| Some (file,(_,a)) -> true
in
let file = Printf.sprintf "%s/%s.hx" (String.concat "/" pack) name in
loop com.load_extern_type || (try ignore(Common.find_file com file); true with Not_found -> false)
let build_class com c file =
let path = make_tpath c.hlc_name in
let pos = { pfile = file ^ "@" ^ s_type_path (path.tpackage,path.tname); pmin = 0; pmax = 0 } in
match path with
| { tpackage = ["flash";"utils"]; tname = ("Object"|"Function") } ->
let inf = {
d_name = path.tname;
d_doc = None;
d_params = [];
d_meta = [];
d_flags = [];
d_data = CTPath { tpackage = []; tname = "Dynamic"; tparams = []; tsub = None; };
} in
(path.tpackage, [(ETypedef inf,pos)])
| _ ->
(* make flags *)
let flags = [HExtern] in
let flags = if c.hlc_interface then HInterface :: flags else flags in
let flags = (match c.hlc_super with
| None | Some (HMPath ([],"Object")) -> flags
| Some (HMPath ([],"Function")) -> flags (* found in AIR SDK *)
| Some s -> HExtends (make_tpath s) :: flags
) in
let flags = List.map (fun i ->
let i = (match i with
| HMMultiName (Some id,ns) ->
let rec loop = function
| [] -> HMPath ([],id)
| HNPublic (Some ns) :: _ when is_valid_path com (ExtString.String.nsplit ns ".") id -> HMPath (ExtString.String.nsplit ns ".",id)
| _ :: l -> loop l
in
loop ns
| HMPath _ -> i
| _ -> assert false
) in
if c.hlc_interface then HExtends (make_tpath i) else HImplements (make_tpath i)
) (Array.to_list c.hlc_implements) @ flags in
let flags = if c.hlc_sealed || Common.defined com Define.FlashStrict then flags else HImplements (make_tpath (HMPath ([],"Dynamic"))) :: flags in
(* make fields *)
let getters = Hashtbl.create 0 in
let setters = Hashtbl.create 0 in
let override = Hashtbl.create 0 in
let is_xml = (match path.tpackage, path.tname with
| ["flash";"xml"], ("XML" | "XMLList") -> true
| _ -> false
) in
let make_field stat acc f =
let meta = ref [] in
let flags = (match f.hlf_name with
| HMPath _ -> [APublic]
| HMName (_,ns) ->
(match ns with
| HNPrivate _ | HNNamespace "http://www.adobe.com/2006/flex/mx/internal" -> []
| HNNamespace ns ->
if not (c.hlc_interface || is_xml) then meta := (Meta.Ns,[String ns]) :: !meta;
[APublic]
| HNExplicit _ | HNInternal _ | HNPublic _ ->
[APublic]
| HNStaticProtected _ | HNProtected _ ->
meta := (Meta.Protected,[]) :: !meta;
[APrivate])
| _ -> []
) in
if flags = [] then acc else
let flags = if stat then AStatic :: flags else flags in
let name = (make_tpath f.hlf_name).tname in
let mk_meta() =
List.map (fun (s,cl) -> s, List.map (fun c -> EConst c,pos) cl, pos) (!meta)
in
let cf = {
cff_name = name;
cff_doc = None;
cff_pos = pos;
cff_meta = mk_meta();
cff_access = flags;
cff_kind = FVar (None,None);
} in
match f.hlf_kind with
| HFVar v ->
if v.hlv_const then
cf.cff_kind <- FProp ("default","never",Some (make_type v.hlv_type),None)
else
cf.cff_kind <- FVar (Some (make_dyn_type v.hlv_type),None);
cf :: acc
| HFMethod m when m.hlm_override ->
Hashtbl.add override (name,stat) ();
acc
| HFMethod m ->
(match m.hlm_kind with
| MK3Normal ->
let t = m.hlm_type in
let p = ref 0 and pn = ref 0 in
let make_type = if stat || name = "new" then make_dyn_type else make_type in
let args = List.map (fun at ->
let aname = (match t.hlmt_pnames with
| None -> incr pn; "p" ^ string_of_int !pn
| Some l ->
match List.nth l !p with
| None -> incr pn; "p" ^ string_of_int !pn
| Some i -> i
) in
let opt_val = (match t.hlmt_dparams with
| None -> None
| Some l ->
try
Some (List.nth l (!p - List.length t.hlmt_args + List.length l))
with
_ -> None
) in
incr p;
let t = make_type at in
let is_opt = ref false in
let def_val = match opt_val with
| None -> None
| Some v ->
let v = (match v with
| HVNone | HVNull | HVNamespace _ | HVString _ ->
is_opt := true;
None
| HVBool b ->
Some (Ident (if b then "true" else "false"))
| HVInt i | HVUInt i ->
Some (Int (Int32.to_string i))
| HVFloat f ->
Some (Float (float_repres f))
) in
match v with
| None -> None
| Some v ->
(* add for --gen-hx-classes generation *)
meta := (Meta.DefParam,[String aname;v]) :: !meta;
Some (EConst v,pos)
in
(aname,!is_opt,Some t,def_val)
) t.hlmt_args in
let args = if t.hlmt_var_args then
args @ List.map (fun _ -> incr pn; ("p" ^ string_of_int !pn,true,Some (make_type None),None)) [1;2;3;4;5]
else args in
let f = {
f_params = [];
f_args = args;
f_type = Some (make_type t.hlmt_ret);
f_expr = None;
} in
cf.cff_meta <- mk_meta();
cf.cff_kind <- FFun f;
cf :: acc
| MK3Getter ->
Hashtbl.add getters (name,stat) m.hlm_type.hlmt_ret;
acc
| MK3Setter ->
Hashtbl.add setters (name,stat) (match m.hlm_type.hlmt_args with [t] -> t | _ -> assert false);
acc
)
| _ -> acc
in
let fields = if c.hlc_interface then [] else make_field false [] {
hlf_name = HMPath ([],"new");
hlf_slot = 0;
hlf_metas = None;
hlf_kind = HFMethod {
hlm_type = { c.hlc_construct with hlmt_ret = Some (HMPath ([],"void")) };
hlm_final = false;
hlm_override = false;
hlm_kind = MK3Normal
}
} in
let fields = Array.fold_left (make_field false) fields c.hlc_fields in
let fields = Array.fold_left (make_field true) fields c.hlc_static_fields in
let make_get_set name stat tget tset =
let get, set, t = (match tget, tset with
| None, None -> assert false
| Some t, None -> true, false, t
| None, Some t -> false, true, t
| Some t1, Some t2 -> true, true, (if t1 <> t2 then None else t1)
) in
let t = if name = "endian" then Some (HMPath (["flash";"utils"],"Endian")) else t in
let flags = [APublic] in
let flags = if stat then AStatic :: flags else flags in
{
cff_name = name;
cff_pos = pos;
cff_doc = None;
cff_access = flags;
cff_meta = [];
cff_kind = if get && set then FVar (Some (make_dyn_type t), None) else FProp ((if get then "default" else "never"),(if set then "default" else "never"),Some (make_dyn_type t),None);
}
in
let fields = Hashtbl.fold (fun (name,stat) t acc ->
if Hashtbl.mem override (name,stat) then acc else
make_get_set name stat (Some t) (try Some (Hashtbl.find setters (name,stat)) with Not_found -> None) :: acc
) getters fields in
let fields = Hashtbl.fold (fun (name,stat) t acc ->
if Hashtbl.mem getters (name,stat) || Hashtbl.mem override (name,stat) then
acc
else
make_get_set name stat None (Some t) :: acc
) setters fields in
try
(*
If the class only contains static String constants, make it an enum
*)
let real_type = ref "" in
let rec loop = function
| [] -> []
| f :: l ->
match f.cff_kind with
| FVar (Some (CTPath { tpackage = []; tname = ("String" | "Int" | "UInt") as tname }),None) when List.mem AStatic f.cff_access ->
if !real_type = "" then real_type := tname else if !real_type <> tname then raise Exit;
{
ec_name = f.cff_name;
ec_pos = pos;
ec_args = [];
ec_params = [];
ec_meta = [];
ec_doc = None;
ec_type = None;
} :: loop l
| FFun { f_args = [] } when f.cff_name = "new" -> loop l
| _ -> raise Exit
in
List.iter (function HExtends _ | HImplements _ -> raise Exit | _ -> ()) flags;
let constr = loop fields in
let name = "fakeEnum:" ^ String.concat "." (path.tpackage @ [path.tname]) in
if not (Common.raw_defined com name) then raise Exit;
let enum_data = {
d_name = path.tname;
d_doc = None;
d_params = [];
d_meta = [(Meta.FakeEnum,[EConst (Ident !real_type),pos],pos)];
d_flags = [EExtern];
d_data = constr;
} in
(path.tpackage, [(EEnum enum_data,pos)])
with Exit ->
let class_data = {
d_name = path.tname;
d_doc = None;
d_params = [];
d_meta = if c.hlc_final && List.exists (fun f -> f.cff_name <> "new" && not (List.mem AStatic f.cff_access)) fields then [Meta.Final,[],pos] else [];
d_flags = flags;
d_data = fields;
} in
(path.tpackage, [(EClass class_data,pos)])
let extract_data (_,tags) =
let t = Common.timer "read swf" in
let h = Hashtbl.create 0 in
let rec loop_field f =
match f.hlf_kind with
| HFClass c ->
let path = make_tpath f.hlf_name in
(match path with
| { tpackage = []; tname = "Float" | "Bool" | "Int" | "UInt" | "Dynamic" } -> ()
| { tpackage = _; tname = "MethodClosure" } -> ()
| _ -> Hashtbl.add h (path.tpackage,path.tname) c)
| _ -> ()
in
List.iter (fun t ->
match t.tdata with
| TActionScript3 (_,as3) ->
List.iter (fun i -> Array.iter loop_field i.hls_fields) (As3hlparse.parse as3)
| _ -> ()
) tags;
t();
h
let remove_debug_infos as3 =
let hl = As3hlparse.parse as3 in
let methods = Hashtbl.create 0 in
let rec loop_field f =
{ f with hlf_kind = (match f.hlf_kind with
| HFMethod m -> HFMethod { m with hlm_type = loop_method m.hlm_type }
| HFFunction f -> HFFunction (loop_method f)
| HFVar v -> HFVar v
| HFClass c -> HFClass (loop_class c))
}
and loop_class c =
(* mutate in order to preserve sharing *)
c.hlc_construct <- loop_method c.hlc_construct;
c.hlc_fields <- Array.map loop_field c.hlc_fields;
c.hlc_static_construct <- loop_method c.hlc_static_construct;
c.hlc_static_fields <- Array.map loop_field c.hlc_static_fields;
c
and loop_static s =
{
hls_method = loop_method s.hls_method;
hls_fields = Array.map loop_field s.hls_fields;
}
and loop_method m =
try
Hashtbl.find methods m.hlmt_index
with Not_found ->
let m2 = { m with hlmt_debug_name = None; hlmt_pnames = None } in
Hashtbl.add methods m.hlmt_index m2;
m2.hlmt_function <- (match m.hlmt_function with None -> None | Some f -> Some (loop_function f));
m2
and loop_function f =
let cur = ref 0 in
let positions = MultiArray.map (fun op ->
let p = !cur in
(match op with
| HDebugReg _ | HDebugLine _ | HDebugFile _ | HBreakPointLine _ | HTimestamp -> ()
| _ -> incr cur);
p
) f.hlf_code in
MultiArray.add positions (!cur);
let code = MultiArray.create() in
MultiArray.iteri (fun pos op ->
match op with
| HDebugReg _ | HDebugLine _ | HDebugFile _ | HBreakPointLine _ | HTimestamp -> ()
| _ ->
let p delta =
MultiArray.get positions (pos + delta) - MultiArray.length code
in
let op = (match op with
| HJump (j,delta) -> HJump (j, p delta)
| HSwitch (d,deltas) -> HSwitch (p d,List.map p deltas)
| HFunction m -> HFunction (loop_method m)
| HCallStatic (m,args) -> HCallStatic (loop_method m,args)
| HClassDef c -> HClassDef c (* mutated *)
| _ -> op) in
MultiArray.add code op
) f.hlf_code;
f.hlf_code <- code;
f.hlf_trys <- Array.map (fun t ->
{
t with
hltc_start = MultiArray.get positions t.hltc_start;
hltc_end = MultiArray.get positions t.hltc_end;
hltc_handle = MultiArray.get positions t.hltc_handle;
}
) f.hlf_trys;
f
in
As3hlparse.flatten (List.map loop_static hl)
let parse_swf com file =
let t = Common.timer "read swf" in
let is_swc = file_extension file = "swc" || file_extension file = "ane" in
let file = (try Common.find_file com file with Not_found -> failwith ((if is_swc then "SWC" else "SWF") ^ " Library not found : " ^ file)) in
let ch = if is_swc then begin
let zip = Zip.open_in file in
try
let entry = Zip.find_entry zip "library.swf" in
let ch = IO.input_string (Zip.read_entry zip entry) in
Zip.close_in zip;
ch
with _ ->
Zip.close_in zip;
failwith ("The input swc " ^ file ^ " is corrupted")
end else
IO.input_channel (open_in_bin file)
in
let h, tags = try
Swf.parse ch
with Out_of_memory ->
failwith ("Out of memory while parsing " ^ file)
| _ ->
failwith ("The input swf " ^ file ^ " is corrupted")
in
IO.close_in ch;
List.iter (fun t ->
match t.tdata with
| TActionScript3 (id,as3) when not com.debug && com.display = DMNone ->
t.tdata <- TActionScript3 (id,remove_debug_infos as3)
| _ -> ()
) tags;
t();
(h,tags)
let add_swf_lib com file extern =
let swf_data = ref None in
let swf_classes = ref None in
let getSWF = (fun() ->
match !swf_data with
| None ->
let d = parse_swf com file in
swf_data := Some d;
d
| Some d -> d
) in
let extract = (fun() ->
match !swf_classes with
| None ->
let d = extract_data (getSWF()) in
swf_classes := Some d;
d
| Some d -> d
) in
let build cl p =
match (try Some (Hashtbl.find (extract()) cl) with Not_found -> None) with
| None -> None
| Some c -> Some (file, build_class com c file)
in
com.load_extern_type <- com.load_extern_type @ [build];
if not extern then com.swf_libs <- (file,getSWF,extract) :: com.swf_libs
(* ------------------------------- *)
let tag ?(ext=false) d = {
tid = 0;
textended = ext;
tdata = d;
}
let convert_header com (w,h,fps,bg) =
let high = (max w h) * 20 in
let rec loop b =
if 1 lsl b > high then b else loop (b + 1)
in
let bits = loop 0 in
{
h_version = Common.flash_version_tag com.flash_version;
h_size = {
rect_nbits = bits + 1;
left = 0;
top = 0;
right = w * 20;
bottom = h * 20;
};
h_frame_count = 1;
h_fps = to_float16 (if fps > 127.0 then 127.0 else fps);
h_compressed = not (Common.defined com Define.NoSwfCompress);
} , bg
let default_header com =
convert_header com (400,300,30.,0xFFFFFF)
type dependency_kind =
| DKInherit
| DKExpr
| DKType
let build_dependencies t =
let h = ref PMap.empty in
let add_path p k =
h := PMap.add (p,k) () !h;
in
let rec add_type_rec l t =
if List.memq t l then () else
match t with
| TEnum (e,pl) ->
add_path e.e_path DKType;
List.iter (add_type_rec (t::l)) pl;
| TInst (c,pl) ->
(match c.cl_kind with KTypeParameter _ -> () | _ -> add_path c.cl_path DKType);
List.iter (add_type_rec (t::l)) pl;
| TAbstract (a,pl) ->
if Meta.has Meta.CoreType a.a_meta then
add_path a.a_path DKType;
List.iter (add_type_rec (t::l)) pl;
| TFun (pl,t2) ->
List.iter (fun (_,_,t2) -> add_type_rec (t::l) t2) pl;
add_type_rec (t::l) t2;
| TAnon a ->
PMap.iter (fun _ f -> add_type_rec (t::l) f.cf_type) a.a_fields
| TDynamic t2 ->
add_type_rec (t::l) t2;
| TLazy f ->
add_type_rec l ((!f)())
| TMono r ->
(match !r with
| None -> ()
| Some t -> add_type_rec l t)
| TType (tt,pl) ->
add_type_rec (t::l) tt.t_type;
List.iter (add_type_rec (t::l)) pl
and add_type t =
add_type_rec [] t
and add_expr e =
match e.eexpr with
| TTypeExpr t -> add_path (Type.t_path t) DKExpr
| TNew (c,pl,el) ->
add_path c.cl_path DKExpr;
List.iter add_type pl;
List.iter add_expr el;
| TFunction f ->
List.iter (fun (v,_) -> add_type v.v_type) f.tf_args;
add_type f.tf_type;
add_expr f.tf_expr;
| TFor (v,e1,e2) ->
add_type v.v_type;
add_expr e1;
add_expr e2;
| TVar (v,eo) ->
add_type v.v_type;
begin match eo with
| None -> ()
| Some e -> add_expr e
end
| _ ->
Type.iter add_expr e
and add_field f =
add_type f.cf_type;
match f.cf_expr with
| None -> ()
| Some e -> add_expr e
in
let add_inherit (c,pl) =
add_path c.cl_path DKInherit;
List.iter add_type pl;
in
(match t with
| TClassDecl c when not c.cl_extern ->
List.iter add_field c.cl_ordered_fields;
List.iter add_field c.cl_ordered_statics;
(match c.cl_constructor with
| None -> ()
| Some f ->
add_field f;
if c.cl_path <> (["flash"],"Boot") then add_path (["flash"],"Boot") DKExpr;
);
(match c.cl_init with
| None -> ()
| Some e -> add_expr e);
(match c.cl_super with
| None -> add_path ([],"Object") DKInherit;
| Some x -> add_inherit x);
List.iter (fun (_,t) ->
(* add type-parameters constraints dependencies *)
match follow t with
| TInst (c,_) -> List.iter add_inherit c.cl_implements
| _ -> ()
) c.cl_params;
List.iter add_inherit c.cl_implements;
| TEnumDecl e when not e.e_extern ->
PMap.iter (fun _ f -> add_type f.ef_type) e.e_constrs;
| _ -> ());
h := PMap.remove (([],"Int"),DKType) (!h);
h := PMap.remove (([],"Int"),DKExpr) (!h);
h := PMap.remove (([],"Void"),DKType) (!h);
PMap.foldi (fun (c,k) () acc -> (c,k) :: acc) (!h) []
let build_swc_catalog com types =
let node x att l =
Xml.Element (x,att,l)
in
let make_path t sep =
let path, name = t_path t in
String.concat sep (path @ [name])
in
let make_id path =
match Genswf9.real_path path with
| [],n -> n
| l,n -> (String.concat "." l) ^ ":" ^ n
in
let build_script t =
let deps = build_dependencies t in
node "script" [("name",make_path t "/");("mod","0")] ([
node "def" ["id",make_id (t_path t)] [];
node "dep" [("id","AS3");("type","n")] [];
] @ List.map (fun (p,k) ->
let t = (match k with
| DKInherit -> "i"
| DKExpr -> (match p with "flash" :: _ :: _ , _ -> "i" | _ -> "e")
| DKType -> "s"
) in
node "dep" [("id",make_id p);("type",t)] []
) deps)
in
let x = node "swc" ["xmlns","http://www.adobe.com/flash/swccatalog/9"] [
node "versions" [] [
node "swc" ["version","1.2"] [];
node "haxe" ["version",Printf.sprintf "%d.%.2d" (com.version/10000) (com.version mod 10000)] [];
];
node "features" [] [
node "feature-script-deps" [] [];
node "feature-files" [] [];
];
node "libraries" [] [
node "library" ["path","library.swf"] (List.map build_script types)
];
node "files" [] [];
] in
"<?xml version=\"1.0\" encoding =\"utf-8\"?>\n" ^ Xml.to_string_fmt x
let remove_classes toremove lib hcl =
let lib = lib() in
match !toremove with
| [] -> lib
| _ ->
let hcl = hcl() in
match List.filter (fun c -> Hashtbl.mem hcl c) (!toremove) with
| [] -> lib
| classes ->
let rec tags = function
| [] -> []
| t :: l ->
match t.tdata with
| TActionScript3 (h,data) ->
let data = As3hlparse.parse data in
let rec loop f =
match f.hlf_kind with
| HFClass _ ->
let path = make_tpath f.hlf_name in
not (List.mem (path.tpackage,path.tname) classes)
| _ -> true
in
let data = List.map (fun s -> { s with hls_fields = Array.of_list (List.filter loop (Array.to_list s.hls_fields)) }) data in
let data = List.filter (fun s -> Array.length s.hls_fields > 0) data in
(if data = [] then
tags l
else
{ t with tdata = TActionScript3 (h,As3hlparse.flatten data) } :: tags l)
| _ ->
t :: tags l
in
toremove := List.filter (fun p -> not (List.mem p classes)) !toremove;
fst lib, tags (snd lib)
type file_format =
| BJPG
| BPNG
| BGIF
| SWAV
| SMP3
let detect_format data p =
match (try data.[0],data.[1],data.[2] with _ -> '\x00','\x00','\x00') with
| '\xFF', '\xD8', _ -> BJPG
| '\x89', 'P', 'N' -> BPNG
| 'R', 'I', 'F' -> SWAV
| 'I', 'D', '3' -> SMP3
| '\xFF', i, _ when (int_of_char i) land 0xE2 = 0xE2 -> SMP3
| 'G', 'I', 'F' -> BGIF
| _ ->
error "Unknown file format" p
open TTFData
let build_swf9 com file swc =
let boot_name = if swc <> None || Common.defined com Define.HaxeBoot then "haxe" else "boot_" ^ (String.sub (Digest.to_hex (Digest.string (Filename.basename file))) 0 4) in
let code = Genswf9.generate com boot_name in
let code = (match swc with
| Some cat ->
cat := build_swc_catalog com (List.map (fun (t,_,_) -> t) code);
List.map (fun (t,m,f) ->
let path = (match t_path t with
| [], name -> name
| path, name -> String.concat "/" path ^ "/" ^ name
) in
let init = {
hls_method = m;
hls_fields = [|f|];
} in
tag (TActionScript3 (Some (1,path),As3hlparse.flatten [init]))
) code
| None ->
let inits = List.map (fun (_,m,f) ->
{
hls_method = m;
hls_fields = [|f|];
}
) code in
[tag (TActionScript3 ((if Common.defined com Define.SwfUseDoAbc then Some(1,boot_name) else None), As3hlparse.flatten inits))]
) in
let cid = ref 0 in
let classes = ref [{ f9_cid = None; f9_classname = boot_name }] in
let res = Hashtbl.fold (fun name data acc ->
incr cid;
classes := { f9_cid = Some !cid; f9_classname = s_type_path (Genswf9.resource_path name) } :: !classes;
tag (TBinaryData (!cid,data)) :: acc
) com.resources [] in
let load_file_data file p =
let file = try Common.find_file com file with Not_found -> file in
if String.length file > 5 && String.sub file 0 5 = "data:" then
String.sub file 5 (String.length file - 5)
else
(try Std.input_file ~bin:true file with Invalid_argument("String.create") -> error "File is too big (max 16MB allowed)" p | _ -> error "File not found" p)
in
let bmp = List.fold_left (fun acc t ->
match t with
| TClassDecl c ->
let rec loop = function
| [] -> acc
| (Meta.Font,(EConst (String file),p) :: args,_) :: l ->
let file = try Common.find_file com file with Not_found -> file in
let ch = try open_in_bin file with _ -> error "File not found" p in
let ttf = try TTFParser.parse ch with e -> error ("Error while parsing font " ^ file ^ " : " ^ Printexc.to_string e) p in
close_in ch;
let get_string e = match fst e with
| EConst (String s) -> Some s
| _ -> raise Not_found
in
let ttf_config = {
ttfc_range_str = "";
ttfc_font_name = None;
} in
begin match args with
| (EConst (String str),_) :: _ -> ttf_config.ttfc_range_str <- str;
| _ -> ()
end;
begin match args with
| _ :: [e] ->
begin match fst e with
| EObjectDecl fl ->
begin try ttf_config.ttfc_font_name <- get_string (List.assoc "fontName" fl)
with Not_found -> () end
| _ ->
()
end
| _ ->
()
end;
let ttf_swf = TTFSwfWriter.to_swf ttf ttf_config in
let ch = IO.output_string () in
let b = IO.output_bits ch in
TTFSwfWriter.write_font2 ch b ttf_swf;
let data = IO.close_out ch in
incr cid;
classes := { f9_cid = Some !cid; f9_classname = s_type_path c.cl_path } :: !classes;
tag (TFont3 {
cd_id = !cid;
cd_data = data;
}) :: loop l
| (Meta.Bitmap,[EConst (String file),p],_) :: l ->
let data = load_file_data file p in
incr cid;
classes := { f9_cid = Some !cid; f9_classname = s_type_path c.cl_path } :: !classes;
let raw() =
tag (TBitsJPEG2 { bd_id = !cid; bd_data = data; bd_table = None; bd_alpha = None; bd_deblock = Some 0 })
in
let t = (match detect_format data p with
| BPNG ->
(*
There is a bug in Flash PNG decoder for 24-bits PNGs : Color such has 0xFF00FF is decoded as 0xFE00FE.
In that particular case, we will then embed the decoded PNG bytes instead.
*)
(try
let png = Png.parse (IO.input_string data) in
let h = Png.header png in
(match h.Png.png_color with
| Png.ClTrueColor (Png.TBits8,Png.NoAlpha) ->
if h.Png.png_width * h.Png.png_height * 4 > Sys.max_string_length then begin
com.warning "Flash will loose some color information for this file, add alpha channel to preserve it" p;
raise Exit;
end;
let data = Extc.unzip (Png.data png) in
let raw_data = Png.filter png data in
let cmp_data = Extc.zip raw_data in
tag ~ext:true (TBitsLossless2 { bll_id = !cid; bll_format = 5; bll_width = h.Png.png_width; bll_height = h.Png.png_height; bll_data = cmp_data })
| _ -> raw())
with Exit ->
raw()
| _ ->
com.error ("Failed to decode this PNG " ^ file) p;
raw();
)
| _ -> raw()
) in
t :: loop l
| (Meta.Bitmap,[EConst (String dfile),p1;EConst (String afile),p2],_) :: l ->
let ddata = load_file_data dfile p1 in
let adata = load_file_data afile p2 in
(match detect_format ddata p1 with
| BJPG -> ()
| _ -> error "RGB channel must be a JPG file" p1);
(match detect_format adata p2 with
| BPNG -> ()
| _ -> error "Alpha channel must be a PNG file" p2);
let png = Png.parse (IO.input_string adata) in
let h = Png.header png in
let amask = (match h.Png.png_color with
| Png.ClTrueColor (Png.TBits8,Png.HaveAlpha) ->
let data = Extc.unzip (Png.data png) in
let raw_data = Png.filter png data in
let alpha = String.make (h.Png.png_width * h.Png.png_height) '\000' in
for i = 0 to String.length alpha do
String.unsafe_set alpha i (String.unsafe_get raw_data (i lsl 2));
done;
Extc.zip alpha
| _ -> error "PNG file must contain 8 bit alpha channel" p2
) in
incr cid;
classes := { f9_cid = Some !cid; f9_classname = s_type_path c.cl_path } :: !classes;
tag (TBitsJPEG3 { bd_id = !cid; bd_data = ddata; bd_table = None; bd_alpha = Some amask; bd_deblock = Some 0 }) :: loop l
| (Meta.File,[EConst (String file),p],_) :: l ->
let data = load_file_data file p in
incr cid;
classes := { f9_cid = Some !cid; f9_classname = s_type_path c.cl_path } :: !classes;
tag (TBinaryData (!cid,data)) :: loop l
| (Meta.Sound,[EConst (String file),p],_) :: l ->
let data = load_file_data file p in
let make_flags fmt mono freq bits =
let fbits = (match freq with 5512 when fmt <> 2 -> 0 | 11025 -> 1 | 22050 -> 2 | 44100 -> 3 | _ -> failwith ("Unsupported frequency " ^ string_of_int freq)) in
let bbits = (match bits with 8 -> 0 | 16 -> 1 | _ -> failwith ("Unsupported bits " ^ string_of_int bits)) in
(fmt lsl 4) lor (fbits lsl 2) lor (bbits lsl 1) lor (if mono then 0 else 1)
in
let flags, samples, data = (match detect_format data p with
| SWAV ->
(try
let i = IO.input_string data in
if IO.nread i 4 <> "RIFF" then raise Exit;
ignore(IO.nread i 4); (* size *)
if IO.nread i 4 <> "WAVE" || IO.nread i 4 <> "fmt " then raise Exit;
let chunk_size = IO.read_i32 i in
if not (chunk_size = 0x10 || chunk_size = 0x12 || chunk_size = 0x40) then failwith ("Unsupported chunk size " ^ string_of_int chunk_size);
if IO.read_ui16 i <> 1 then failwith "Not a PCM file";
let chan = IO.read_ui16 i in
if chan > 2 then failwith "Too many channels";
let freq = IO.read_i32 i in
ignore(IO.read_i32 i);
ignore(IO.read_i16 i);
let bits = IO.read_ui16 i in
if chunk_size <> 0x10 then ignore(IO.nread i (chunk_size - 0x10));
if IO.nread i 4 <> "data" then raise Exit;
let data_size = IO.read_i32 i in
let data = IO.nread i data_size in
make_flags 0 (chan = 1) freq bits, (data_size * 8 / (chan * bits)), data
with Exit | IO.No_more_input | IO.Overflow _ ->
error "Invalid WAV file" p
| Failure msg ->
error ("Invalid WAV file (" ^ msg ^ ")") p
)
| SMP3 ->
(try
let sampling = ref 0 in
let mono = ref false in
let samples = ref 0 in
let i = IO.input_string data in
let rec read_frame() =
match (try IO.read_byte i with IO.No_more_input -> -1) with
| -1 ->
()
| 0x49 ->
(* ID3 *)
if IO.nread i 2 <> "D3" then raise Exit;
ignore(IO.read_ui16 i); (* version *)
ignore(IO.read_byte i); (* flags *)
let size = IO.read_byte i land 0x7F in
let size = size lsl 7 lor (IO.read_byte i land 0x7F) in
let size = size lsl 7 lor (IO.read_byte i land 0x7F) in
let size = size lsl 7 lor (IO.read_byte i land 0x7F) in
ignore(IO.nread i size); (* id3 data *)
read_frame()
| 0x54 ->
(* TAG and TAG+ *)
if IO.nread i 3 = "AG+" then ignore(IO.nread i 223) else ignore(IO.nread i 124);
read_frame()
| 0xFF ->
let infos = IO.read_byte i in
let ver = (infos lsr 3) land 3 in
sampling := [|11025;0;22050;44100|].(ver);
let layer = (infos lsr 1) land 3 in
let bits = IO.read_byte i in
let bitrate = (if ver = 3 then [|0;32;40;48;56;64;80;96;112;128;160;192;224;256;320;-1|] else [|0;8;16;24;32;40;48;56;64;80;96;112;128;144;160;-1|]).(bits lsr 4) in
let srate = [|
[|11025;12000;8000;-1|];
[|-1;-1;-1;-1|];
[|22050;24000;16000;-1|];
[|44100;48000;32000;-1|];
|].(ver).((bits lsr 2) land 3) in
let pad = (bits lsr 1) land 1 in
mono := (IO.read_byte i) lsr 6 = 3;
let bpp = (if ver = 3 then 144 else 72) in
let size = ((bpp * bitrate * 1000) / srate) + pad - 4 in
ignore(IO.nread i size);
samples := !samples + (if layer = 3 then 384 else 1152);
read_frame()
| _ ->
raise Exit
in
read_frame();
make_flags 2 !mono !sampling 16, (!samples), ("\x00\x00" ^ data)
with Exit | IO.No_more_input | IO.Overflow _ ->
error "Invalid MP3 file" p
| Failure msg ->
error ("Invalid MP3 file (" ^ msg ^ ")") p
)
| _ ->
error "Sound extension not supported (only WAV or MP3)" p
) in
incr cid;
classes := { f9_cid = Some !cid; f9_classname = s_type_path c.cl_path } :: !classes;
tag (TSound { so_id = !cid; so_flags = flags; so_samples = samples; so_data = data }) :: loop l
| _ :: l -> loop l
in
loop c.cl_meta
| _ -> acc
) [] com.types in
let clips = [tag (TF9Classes (List.rev !classes))] in
res @ bmp @ code @ clips
let merge com file priority (h1,tags1) (h2,tags2) =
(* prioritize header+bgcolor for first swf *)
let header = if priority then { h2 with h_version = max h2.h_version (Common.flash_version_tag com.flash_version) } else h1 in
let tags1 = if priority then List.filter (function { tdata = TSetBgColor _ } -> false | _ -> true) tags1 else tags1 in
(* remove unused tags *)
let use_stage = priority && Common.defined com Define.FlashUseStage in
let classes = ref [] in
let nframe = ref 0 in
let tags2 = List.filter (fun t ->
match t.tdata with
| TPlaceObject2 _
| TPlaceObject3 _
| TRemoveObject2 _
| TRemoveObject _ -> use_stage
| TShowFrame -> incr nframe; use_stage
| TFilesAttributes _ | TEnableDebugger2 _ | TScenes _ -> false
| TMetaData _ -> not (Common.defined com Define.SwfMetadata)
| TSetBgColor _ -> priority
| TExport el when !nframe = 0 && com.flash_version >= 9. ->
let el = List.filter (fun e ->
let path = parse_path e.exp_name in
let b = List.exists (fun t -> t_path t = path) com.types in
if not b && fst path = [] then List.iter (fun t ->
if snd (t_path t) = snd path then error ("Linkage name '" ^ snd path ^ "' in '" ^ file ^ "' should be '" ^ s_type_path (t_path t) ^"'") (t_infos t).mt_pos;
) com.types;
b
) el in
classes := !classes @ List.map (fun e -> { f9_cid = Some e.exp_id; f9_classname = e.exp_name }) el;
false
| TF9Classes el when !nframe = 0 ->
classes := !classes @ List.filter (fun e -> e.f9_cid <> None) el;
false
| _ -> true
) tags2 in
(* rebuild character ids *)
let max_id = ref (-1) in
List.iter (SwfParser.scan (fun id -> if id > !max_id then max_id := id; id) (fun id -> id)) tags1;
incr max_id;
let rec loop t =
SwfParser.scan (fun id -> id + !max_id) (fun id -> id + !max_id) t;
match t.tdata with
| TClip c -> List.iter loop c.c_tags
| _ -> ()
in
List.iter loop tags2;
let classes = List.map (fun e -> match e.f9_cid with None -> e | Some id -> { e with f9_cid = Some (id + !max_id) }) !classes in
(* merge timelines *)
let rec loop l1 l2 =
match l1, l2 with
| ({ tdata = TSetBgColor _ } as t) :: l1, _
| ({ tdata = TEnableDebugger2 _ } as t) :: l1, _
| ({ tdata = TFilesAttributes _ } as t) :: l1, _ ->
t :: loop l1 l2
| _, ({ tdata = TSetBgColor _ } as t) :: l2 ->
t :: loop l1 l2
| { tdata = TShowFrame } :: l1, { tdata = TShowFrame } :: l2 ->
tag TShowFrame :: loop l1 l2
| { tdata = TF9Classes el } :: l1, _ ->
(* merge all classes together *)
tag (TF9Classes (classes @ el)) :: loop l1 l2
| x :: l1, { tdata = TShowFrame } :: _ ->
(* wait until we finish frame on other swf *)
x :: loop l1 l2
| _ , x :: l2 ->
x :: loop l1 l2
| x :: l1, [] ->
x :: loop l1 l2
| [], [] ->
[]
in
let tags = loop tags1 tags2 in
header, tags
let generate swf_header com =
let swc = if Common.defined com Define.Swc then Some (ref "") else None in
let file , codeclip = (try let f , c = ExtString.String.split com.file "@" in f, Some c with _ -> com.file , None) in
(* list exports *)
let exports = Hashtbl.create 0 in
let toremove = ref [] in
List.iter (fun (file,lib,_) ->
let _, tags = lib() in
List.iter (fun t ->
match t.tdata with
| TExport l -> List.iter (fun e -> Hashtbl.add exports e.exp_name ()) l
| TF9Classes el ->
List.iter (fun e ->
if e.f9_cid <> None then List.iter (fun t ->
let extern = (match t with
| TClassDecl c -> c.cl_extern
| TEnumDecl e -> e.e_extern
| TAbstractDecl a -> false
| TTypeDecl t -> false
) in
if not extern && s_type_path (t_path t) = e.f9_classname then
match t with
| TClassDecl c ->
if Meta.has Meta.Bind c.cl_meta then
toremove := (t_path t) :: !toremove
else
error ("Class already exists in '" ^ file ^ "', use @:bind to redefine it") (t_infos t).mt_pos
| _ ->
error ("Invalid redefinition of class defined in '" ^ file ^ "'") (t_infos t).mt_pos
) com.types;
) el
| _ -> ()
) tags;
) com.swf_libs;
(* build haxe swf *)
let tags = build_swf9 com file swc in
let header, bg = (match swf_header with None -> default_header com | Some h -> convert_header com h) in
let bg = tag (TSetBgColor { cr = bg lsr 16; cg = (bg lsr 8) land 0xFF; cb = bg land 0xFF }) in
let scene = tag ~ext:true (TScenes ([(0,"Scene1")],[])) in
let swf_debug_password = try
Digest.to_hex(Digest.string (Common.defined_value com Define.SwfDebugPassword))
with Not_found ->
""
in
let debug = (if Common.defined com Define.Fdb then [tag (TEnableDebugger2 (0, swf_debug_password))] else []) in
let meta_data =
try
let file = Common.defined_value com Define.SwfMetadata in
let file = try Common.find_file com file with Not_found -> file in
let data = try Std.input_file ~bin:true file with Sys_error _ -> failwith ("Metadata resource file not found : " ^ file) in
[tag(TMetaData (data))]
with Not_found ->
[]
in
let fattr = (if com.flash_version < 8. then [] else
[tag (TFilesAttributes {
fa_network = Common.defined com Define.NetworkSandbox;
fa_as3 = true;
fa_metadata = meta_data <> [];
fa_gpu = com.flash_version > 9. && Common.defined com Define.SwfGpu;
fa_direct_blt = com.flash_version > 9. && Common.defined com Define.SwfDirectBlit;
})]
) in
let fattr = if Common.defined com Define.AdvancedTelemetry then fattr @ [tag (TUnknown (0x5D,"\x00\x00"))] else fattr in
let swf_script_limits = try
let s = Common.defined_value com Define.SwfScriptTimeout in
let i = try int_of_string s with _ -> error "Argument to swf_script_timeout must be an integer" Ast.null_pos in
[tag(TScriptLimits (256, if i < 0 then 0 else if i > 65535 then 65535 else i))]
with Not_found ->
[]
in
let swf = header, fattr @ meta_data @ bg :: scene :: debug @ swf_script_limits @ tags @ [tag TShowFrame] in
(* merge swf libraries *)
let priority = ref (swf_header = None) in
let swf = List.fold_left (fun swf (file,lib,cl) ->
let swf = merge com file !priority swf (remove_classes toremove lib cl) in
priority := false;
swf
) swf com.swf_libs in
let swf = match swf with
| header,tags when Common.defined com Define.SwfPreloaderFrame ->
let rec loop l =
match l with
| ({tdata = TFilesAttributes _ | TUnknown (0x5D,"\x00\x00") | TMetaData _ | TSetBgColor _ | TEnableDebugger2 _ | TScriptLimits _} as t) :: l -> t :: loop l
| t :: l -> tag TShowFrame :: t :: l
| [] -> []
in
{header with h_frame_count = header.h_frame_count + 1},loop tags
| _ -> swf in
(* write swf/swc *)
let t = Common.timer "write swf" in
let level = (try int_of_string (Common.defined_value com Define.SwfCompressLevel) with Not_found -> 9) in
SwfParser.init Extc.input_zip (Extc.output_zip ~level);
(match swc with
| Some cat ->
let ch = IO.output_strings() in
Swf.write ch swf;
let swf = IO.close_out ch in
let z = Zip.open_out file in
Zip.add_entry (!cat) z "catalog.xml";
Zip.add_entry (match swf with [s] -> s | _ -> failwith "SWF too big for SWC") z ~level:0 "library.swf";
Zip.close_out z
| None ->
let ch = IO.output_channel (open_out_bin file) in
Swf.write ch swf;
IO.close_out ch;
);
t()
;;
SwfParser.init Extc.input_zip Extc.output_zip;
Swf.warnings := false;
Jump to Line
Something went wrong with that request. Please try again.