(*
* Haxe Compiler
* Copyright (c)2005-2008 Nicolas Cannasse
*
* 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
open Printf
open Genswf
open Common
type context = {
com : Common.context;
mutable messages : string list;
mutable params : string list;
mutable has_next : bool;
mutable has_error : bool;
}
exception Abort
exception Completion of string
let version = 208
let measure_times = ref false
let prompt = ref false
let start_time = ref (get_time())
let executable_path() =
Extc.executable_path()
let normalize_path p =
let l = String.length p in
if l = 0 then
"./"
else match p.[l-1] with
| '\\' | '/' -> p
| _ -> p ^ "/"
let format msg p =
if p = Ast.null_pos then
msg
else begin
let error_printer file line = sprintf "%s:%d:" file line in
let epos = Lexer.get_error_pos error_printer p in
let msg = String.concat ("\n" ^ epos ^ " : ") (ExtString.String.nsplit msg "\n") in
sprintf "%s : %s" epos msg
end
let message ctx msg p =
ctx.messages <- format msg p :: ctx.messages
let error ctx msg p =
message ctx msg p;
ctx.has_error <- true
let htmlescape s =
let s = String.concat "<" (ExtString.String.nsplit s "<") in
let s = String.concat ">" (ExtString.String.nsplit s ">") in
s
let complete_fields fields =
let b = Buffer.create 0 in
Buffer.add_string b "\n";
List.iter (fun (n,t,d) ->
Buffer.add_string b (Printf.sprintf "%s%s\n" n (htmlescape t) (htmlescape d))
) (List.sort (fun (a,_,_) (b,_,_) -> compare a b) fields);
Buffer.add_string b "
\n";
raise (Completion (Buffer.contents b))
let file_extension f =
let cl = ExtString.String.nsplit f "." in
match List.rev cl with
| [] -> ""
| x :: _ -> x
let make_path f =
let f = String.concat "/" (ExtString.String.nsplit f "\\") in
let cl = ExtString.String.nsplit f "." in
let cl = (match List.rev cl with
| ["hx";path] -> ExtString.String.nsplit path "/"
| _ -> cl
) in
let error() = failwith ("Invalid class name " ^ f) in
let invalid_char x =
for i = 1 to String.length x - 1 do
match x.[i] with
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> ()
| _ -> error()
done;
false
in
let rec loop = function
| [] -> error()
| [x] -> if String.length x = 0 || not (x.[0] = '_' || (x.[0] >= 'A' && x.[0] <= 'Z')) || invalid_char x then error() else [] , x
| x :: l ->
if String.length x = 0 || x.[0] < 'a' || x.[0] > 'z' || invalid_char x then error() else
let path , name = loop l in
x :: path , name
in
loop cl
let unique l =
let rec _unique = function
| [] -> []
| x1 :: x2 :: l when x1 = x2 -> _unique (x2 :: l)
| x :: l -> x :: _unique l
in
_unique (List.sort compare l)
let rec read_type_path com p =
let classes = ref [] in
let packages = ref [] in
let p = (match p with
| x :: l ->
(try
match PMap.find x com.package_rules with
| Directory d -> d :: l
| Remap s -> s :: l
| _ -> p
with
Not_found -> p)
| _ -> p
) in
List.iter (fun path ->
let dir = path ^ String.concat "/" p in
let r = (try Sys.readdir dir with _ -> [||]) in
Array.iter (fun f ->
if (try (Unix.stat (dir ^ "/" ^ f)).Unix.st_kind = Unix.S_DIR with _ -> false) then begin
if f.[0] >= 'a' && f.[0] <= 'z' then begin
if p = ["."] then
match read_type_path com [f] with
| [] , [] -> ()
| _ ->
try
match PMap.find f com.package_rules with
| Forbidden -> ()
| Remap f -> packages := f :: !packages
| Directory _ -> raise Not_found
with Not_found ->
packages := f :: !packages
else
packages := f :: !packages
end;
end else if file_extension f = "hx" then begin
let c = Filename.chop_extension f in
if String.length c < 2 || String.sub c (String.length c - 2) 2 <> "__" then classes := c :: !classes;
end;
) r;
) com.class_path;
List.iter (fun (_,_,extract) ->
Hashtbl.iter (fun (path,name) _ ->
if path = p then classes := name :: !classes else
let rec loop p1 p2 =
match p1, p2 with
| [], _ -> ()
| x :: _, [] -> packages := x :: !packages
| a :: p1, b :: p2 -> if a = b then loop p1 p2
in
loop path p
) (extract());
) com.swf_libs;
unique !packages, unique !classes
let delete_file f = try Sys.remove f with _ -> ()
let expand_env path =
let r = Str.regexp "%\\([A-Za-z0-9_]+\\)%" in
Str.global_substitute r (fun s -> try Sys.getenv (Str.matched_group 1 s) with Not_found -> "") path
let unquote v =
let len = String.length v in
if len > 0 && v.[0] = '"' && v.[len - 1] = '"' then String.sub v 1 (len - 2) else v
let parse_hxml_data data =
let lines = Str.split (Str.regexp "[\r\n]+") data in
List.concat (List.map (fun l ->
let l = unquote (expand_env (ExtString.String.strip l)) in
if l = "" || l.[0] = '#' then
[]
else if l.[0] = '-' then
try
let a, b = ExtString.String.split l " " in
[unquote a; unquote (ExtString.String.strip b)]
with
_ -> [l]
else
[l]
) lines)
let parse_hxml file =
let ch = IO.input_channel (try open_in_bin file with _ -> failwith ("File not found " ^ file)) in
let data = IO.read_all ch in
IO.close_in ch;
parse_hxml_data data
let lookup_classes com fpath =
let spath = String.lowercase fpath in
let rec loop = function
| [] -> []
| cp :: l ->
let cp = (if cp = "" then "./" else cp) in
let c = normalize_path (Common.get_full_path cp) in
let clen = String.length c in
if clen < String.length fpath && String.sub spath 0 clen = String.lowercase c then begin
let path = String.sub fpath clen (String.length fpath - clen) in
(try [make_path path] with _ -> loop l)
end else
loop l
in
loop com.class_path
let add_swf_lib com file =
let swf_data = ref None in
let swf_classes = ref None in
let getSWF = (fun() ->
match !swf_data with
| None ->
let d = Genswf.parse_swf com file in
swf_data := Some d;
d
| Some d -> d
) in
let extract = (fun() ->
match !swf_classes with
| None ->
let d = Genswf.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 (Genswf.build_class com c file)
in
com.load_extern_type <- com.load_extern_type @ [build];
com.swf_libs <- (file,getSWF,extract) :: com.swf_libs
let add_libs com libs =
let call_haxelib() =
let t = Common.timer "haxelib" in
let cmd = "haxelib path " ^ String.concat " " libs in
let p = Unix.open_process_in cmd in
let lines = Std.input_list p in
let ret = Unix.close_process_in p in
if ret <> Unix.WEXITED 0 then failwith (String.concat "\n" lines);
t();
lines
in
match libs with
| [] -> ()
| _ ->
let lines = match !Common.global_cache with
| Some cache ->
(try
(* if we are compiling, really call haxelib since library path might have changed *)
if not com.display then raise Not_found;
Hashtbl.find cache.cached_haxelib libs
with Not_found ->
let lines = call_haxelib() in
Hashtbl.replace cache.cached_haxelib libs lines;
lines)
| _ -> call_haxelib()
in
let lines = List.fold_left (fun acc l ->
let p = String.length l - 1 in
let l = (if l.[p] = '\r' then String.sub l 0 p else l) in
match (if p > 3 then String.sub l 0 3 else "") with
| "-D " ->
Common.define com (String.sub l 3 (String.length l - 3));
acc
| "-L " ->
com.neko_libs <- String.sub l 3 (String.length l - 3) :: com.neko_libs;
acc
| _ ->
l :: acc
) [] lines in
com.class_path <- lines @ com.class_path
let create_context params =
{
com = Common.create version;
params = params;
messages = [];
has_next = false;
has_error = false;
}
let setup_cache rcom cache =
Common.global_cache := Some cache;
Typeload.parse_hook := (fun com file p ->
let sign = (match com.defines_signature with
| Some s -> s
| None ->
let s = Digest.string (String.concat "@" (PMap.foldi (fun k _ acc -> k :: acc) com.defines [])) in
com.defines_signature <- Some s;
s
) in
let ffile = Common.get_full_path file in
let ftime = try (Unix.stat ffile).Unix.st_mtime with _ -> 0. in
let fkey = ffile ^ "!" ^ sign in
try
let time, data = Hashtbl.find cache.cached_files fkey in
if time <> ftime then raise Not_found;
data
with Not_found ->
let data = Typeload.parse_file com file p in
if rcom.verbose && not com.verbose then print_endline ("Parsed " ^ ffile);
Hashtbl.replace cache.cached_files fkey (ftime,data);
data
)
let default_flush ctx =
List.iter prerr_endline (List.rev ctx.messages);
if ctx.has_error && !prompt then begin
print_endline "Press enter to exit...";
ignore(read_line());
end;
if ctx.has_error then exit 1
let rec process_params flush acc = function
| [] ->
let ctx = create_context (List.rev acc) in
init flush ctx;
flush ctx
| "--next" :: l ->
let ctx = create_context (List.rev acc) in
ctx.has_next <- true;
init flush ctx;
flush ctx;
process_params flush [] l
| "--cwd" :: dir :: l ->
(* we need to change it immediately since it will affect hxml loading *)
(try Unix.chdir dir with _ -> ());
process_params flush (dir :: "--cwd" :: acc) l
| arg :: l ->
match List.rev (ExtString.String.nsplit arg ".") with
| "hxml" :: _ -> process_params flush acc (parse_hxml arg @ l)
| _ -> process_params flush (arg :: acc) l
and wait_loop com host port =
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
(try Unix.bind sock (Unix.ADDR_INET (Unix.inet_addr_of_string host,port)) with _ -> failwith ("Couldn't wait on " ^ host ^ ":" ^ string_of_int port));
Unix.listen sock 10;
Sys.catch_break false;
let verbose = com.verbose in
if verbose then print_endline ("Waiting on " ^ host ^ ":" ^ string_of_int port);
let bufsize = 1024 in
let tmp = String.create bufsize in
setup_cache com (Common.create_cache());
while true do
let sin, _ = Unix.accept sock in
let t0 = get_time() in
Unix.set_nonblock sin;
if verbose then print_endline "Client connected";
let b = Buffer.create 0 in
let rec read_loop() =
try
let r = Unix.recv sin tmp 0 bufsize [] in
if verbose then Printf.printf "Reading %d bytes\n" r;
Buffer.add_substring b tmp 0 r;
if r > 0 && tmp.[r-1] = '\000' then Buffer.sub b 0 (Buffer.length b - 1) else read_loop();
with Unix.Unix_error((Unix.EWOULDBLOCK|Unix.EAGAIN),_,_) ->
if verbose then print_endline "Waiting for data...";
ignore(Unix.select [] [] [] 0.1);
read_loop()
in
let send str =
let rec loop pos len =
if len = 0 then
()
else
let s = Unix.send sin str pos len [] in
loop (pos + s) (len - s)
in
loop 0 (String.length str)
in
let flush ctx =
List.iter (fun s -> send (s ^ "\n")) (List.rev ctx.messages)
in
(try
let data = parse_hxml_data (read_loop()) in
Unix.clear_nonblock sin;
if verbose then print_endline ("Processing Arguments [" ^ String.concat "," data ^ "]");
(try
Common.display_default := false;
Parser.resume_display := Ast.null_pos;
measure_times := false;
start_time := get_time();
process_params flush [] data
with Completion str ->
if verbose then print_endline ("Completion Response =\n" ^ str);
send str
);
if verbose then Printf.printf "Time spent : %.3fs\n" (get_time() -. t0);
with Unix.Unix_error _ ->
if verbose then print_endline "Connection Aborted");
if verbose then print_endline "Closing connection";
Unix.close sin;
done
and init flush ctx =
let usage = Printf.sprintf
"haXe Compiler %d.%.2d - (c)2005-2011 Motion-Twin\n Usage : haxe%s -main [-swf|-js|-neko|-php|-cpp|-as3]