(* Copyright 2008 Jaap BOENDER and the MANCOOSI Project.

This file is part of Dose2.

Dose2 is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

Dose2 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 Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>. *)

open Napkin

let comma_rex = Pcre.regexp ",";;

let starts_with (haystack: string) (needle: string): bool =
	if String.length needle > String.length haystack then false
	else let len = String.length needle in
		String.sub haystack 0 len = needle;;

let ends_with (haystack: string) (needle: string): bool =
	if String.length needle > String.length haystack then false
	else let len = String.length needle in
		String.sub haystack (String.length haystack - len) len = needle;;

let rec split_version (v: string) (nb: int): int32 list * int =
let alphas = "abcdefghijklmnopqrstuvwxyz" in
let isdigit c = String.contains "0123456789" c in
let isalpha c = String.contains alphas c in
begin
	let vl = String.lowercase v in
	if vl = "" then
		([], nb)
	else
	begin
		(* digits *)
		if isdigit vl.[0] then
			Scanf.sscanf vl "%lu%s@\n" (fun i r ->
				let (res, new_nb) = split_version r nb in (i::res, new_nb))
		(* modifiers *)
		else if starts_with vl "alpha" then
			let (res, new_nb) = split_version (String.sub vl 5 (String.length vl - 5)) nb in	
				(-3l::res, new_nb)
		else if starts_with vl "beta" then
			let (res, new_nb) = split_version (String.sub vl 4 (String.length vl - 4)) nb in	
				(-2l::res, new_nb)
		else if starts_with vl "pre" then
			let (res, new_nb) = split_version (String.sub vl 3 (String.length vl - 3)) nb in	
				(-1l::res, new_nb)
		else if starts_with vl "rc" then
			let (res, new_nb) = split_version (String.sub vl 2 (String.length vl - 2)) nb in	
				(-1l::res, new_nb)
		else if starts_with vl "pl" then
			let (res, new_nb) = split_version (String.sub vl 2 (String.length vl - 2)) nb in	
				(0l::res, new_nb)
		else if starts_with vl "_" then
			let (res, new_nb) = split_version (String.sub vl 1 (String.length vl - 1)) nb in	
				(0l::res, new_nb)
		else if starts_with vl "." then
			let (res, new_nb) = split_version (String.sub vl 1 (String.length vl - 1)) nb in	
				(0l::res, new_nb)
		(* "nb" *)
		else if starts_with vl "nb" then 
			Scanf.sscanf vl "nb%d%s@\n" (fun new_nb r -> 
				let (res, newer_nb) = split_version r new_nb in
					(res, newer_nb))
		(* letter *)
		else if isalpha v.[0] then
			let (res, new_nb) = split_version (String.sub vl 1 (String.length vl -1)) nb in
				(0l::(Int32.of_int (String.index alphas v.[0]))::res, new_nb)
		else
			raise (Failure (Printf.sprintf "Unparseable version string %s" v))
	end
end;;

let rec compare_lists (l1: int32 list) (l2: int32 list): int =
begin
	match l1, l2 with
	| [], [] -> 0
	| [], _ -> -1
	| _, [] -> 1
	| h1::t1, h2::t2 -> let res = compare h1 h2 in 
			if res = 0 then compare_lists t1 t2 else res
end;;

let compare_versions (v1: string) (v2: string): int =
begin
	let (l1, nb1) = split_version v1 0
	and (l2, nb2) = split_version v2 0 in
 	let res = compare_lists l1 l2 in
	if res = 0 then compare nb1 nb2 else res
end;;

let read_summary_fields (channel: in_channel): (string, string) Hashtbl.t =
let fields = Hashtbl.create 10 in
let my_line = ref "" in
begin
	my_line := input_line channel;
	while !my_line <> ""
	do
		let equals = String.index !my_line '=' in
		let name = String.sub !my_line 0 equals
		and contents = String.sub !my_line (equals + 1) (String.length !my_line - equals - 1) in
		begin
			Hashtbl.add fields name contents;
			my_line := input_line channel
		end
	done;
	fields
end;;

let contains_one_of (s: string) (c: char list): bool =
let result = ref false in
begin
	for i = 0 to (String.length s - 1)
	do
		if List.mem s.[i] c then result := true
	done;
	!result
end;;

let rec uniq (x: 'a list): 'a list =
begin
  match x with
    [] -> []
  | y::ys ->
      begin
        match ys with
          [] -> [y]
        | z::zs -> if y = z then uniq ys else y::(uniq ys)
      end
end;;

let rec get_dependency_list (pat: string): (string, string, string) versioned list list =
(* This does a textual substitution of the alternative and then runs a pkg_match. *)
let rec alternative_match (pat: string): string list =
begin
	let sa = String.rindex pat '{' in
	let ea = String.index_from pat sa '}' in
	let to_sub = String.sub pat (sa+1) (ea-sa-1) in	
	let pre = String.sub pat 0 sa in
	let post = String.sub pat (ea+1) (String.length pat - ea - 1) in
	let alternatives = Pcre.split ~rex:comma_rex to_sub in
		List.flatten (List.map (fun a ->
			let new_pat = Printf.sprintf "%s%s%s" pre a post in
			if String.contains new_pat '{' then
				alternative_match new_pat
			else
				[new_pat]
		) alternatives)
end in
let dewey_match (pat: string) =
begin
	try
	begin
		let gtc = String.index pat '>' in
		let unit_name = String.sub pat 0 gtc in
		let v_str = if pat.[gtc+1] = '=' then String.sub pat (gtc+2) (String.length pat-gtc-2) else String.sub pat (gtc+1) (String.length pat-gtc-1) in
		try
			let ltc = String.index v_str '<' in
			let g_spec = String.sub v_str 0 ltc in
			[if v_str.[ltc+1] = '='
			then Unit_version (unit_name, Sel_LEQ (String.sub v_str (ltc+2) (String.length v_str-ltc-2)))
			else Unit_version (unit_name, Sel_LT (String.sub v_str (ltc+1) (String.length v_str-ltc-1)));
			if pat.[gtc+1] = '='
			then Unit_version (unit_name, Sel_GEQ g_spec)
			else Unit_version (unit_name, Sel_GT g_spec)]
		with Not_found -> if pat.[gtc+1] = '='
			then [Unit_version (unit_name, Sel_GEQ v_str)]
			else [Unit_version (unit_name, Sel_GT v_str)]
	end
	with Not_found ->
		let ltc = String.index pat '<' in
		let unit_name = String.sub pat 0 ltc in
			if pat.[ltc+1] = '='
			then [Unit_version (unit_name, Sel_LEQ (String.sub pat (ltc+2) (String.length pat-ltc-2)))]
			else [Unit_version (unit_name, Sel_LT (String.sub pat (ltc+1) (String.length pat-ltc-1)))]
end in
let glob_match pat =
begin
	[[Glob_pattern pat]]
end in
begin
	if pat = "" then
		[]
	else if String.contains pat '{' then
		List.flatten (List.map get_dependency_list (alternative_match pat))
	else if contains_one_of pat ['<'; '>'] then
		List.map (fun a -> [a]) (dewey_match pat)
	else if contains_one_of pat ['*'; '?'; '['; ']'] then
		glob_match pat
	else
	begin
		let dash = String.rindex pat '-' in
		[[Unit_version (String.sub pat 0 dash, Sel_EQ (String.sub pat (dash+1) (String.length pat-dash-1)))]]
	end
end;;

let get_dewey_int64 (fields: (string, string) Hashtbl.t) (name: string): int64 =
begin
	try
		Int64.of_string (Hashtbl.find fields name)
	with Not_found -> 0L	
end

let napkin_of_fields (fields: (string, string) Hashtbl.t): default_package =
begin
	let (pk_unit, pk_version) =
	try
		let pkgname = Hashtbl.find fields "PKGNAME" in
		let dash = String.rindex pkgname '-' in
			(String.sub pkgname 0 dash,
			String.sub pkgname (dash + 1) (String.length pkgname - dash - 1))
	with Not_found -> raise (Failure "Warning: package ignored because it has no name") in
	let pk_source = (pk_unit, pk_version) in
	let pk_architecture = 
	try
		Hashtbl.find fields "MACHINE_ARCH" 
	with Not_found -> (Printf.eprintf "Warning: package %s doesn't have an architecture, using 'any'\n%!" pk_unit; "any") in
	{ pk_extra = ();
	  pk_unit = pk_unit;
	  pk_version = pk_version;
	  pk_source = pk_source;
	  pk_architecture = pk_architecture;
	  pk_essential = false;
	  pk_build_essential = false;
	  pk_size = get_dewey_int64 fields "FILE_SIZE";
	  pk_installed_size = get_dewey_int64 fields "SIZE_PKG";
	  pk_provides = [];
	  pk_conflicts = List.flatten (List.flatten (List.map get_dependency_list (Hashtbl.find_all fields "CONFLICTS")));
	  pk_breaks = List.flatten (List.flatten (List.map get_dependency_list (Hashtbl.find_all fields "BREAKS")));
	  pk_replaces = [];
	  pk_depends = List.flatten (List.map get_dependency_list (Hashtbl.find_all fields "DEPENDS"));
	  pk_pre_depends = [];
	  pk_suggests = [];
	  pk_recommends = [];
	  pk_enhances = []
	}
end;;

(**
Read a pool (cache) file
@param filename File name
@return a list package metadata
*)
let read_summary_file (filename: string): default_package list =
let channel = open_in filename in
let packages = ref [] in
begin
	try
		while true
		do
			let fields = read_summary_fields channel in
			if Hashtbl.length fields = 0 then
			begin
				raise End_of_file
			end;
			packages := (napkin_of_fields fields)::!packages
		done;
		!packages
	with End_of_file -> !packages
end;;

type fnmatch_options =
  FNM_NOESCAPE
| FNM_PATHNAME
| FNM_PERIOD

external fnmatch: string -> string -> fnmatch_options list -> bool =
	"ocamlpkgsrc_fnmatch";;
