(* Wildcard matching routines for ocaml
   Copyright (C) 2002,2003 Shawn Wagner <raevnos@pennmush.org>

   This library 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 2.1 of the License, or (at your option) any later version.
	 
   This library 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 library; if not, write to the Free Software
   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
*)

type m = Char of char | AnyOne | Star | Set of bool array | String of string
type t = {
  glob: m list;
  cs: bool;
}

let make_char c cs =
  if cs or CharExtras.to_lower c = CharExtras.to_upper c then
    Char c
  else 
    let v = Array.make 255 false in
      v.(Char.code (CharExtras.to_upper c)) <- true;
      v.(Char.code (CharExtras.to_lower c)) <- true;
      Set v

let set_char_from_str vec str n cs b =
  if cs or CharExtras.to_upper str.[n] = CharExtras.to_lower str.[n] then
    vec.(Char.code str.[n]) <- b
  else begin
    vec.(Char.code (CharExtras.to_upper str.[n])) <- b;
    vec.(Char.code (CharExtras.to_lower str.[n])) <- b
  end

let set_char vec code cs b =
  let c = Char.chr code in
  if cs or CharExtras.to_upper c = CharExtras.to_lower c then
    vec.(code) <- b
  else begin
    vec.(Char.code (CharExtras.to_upper c)) <- b;
    vec.(Char.code (CharExtras.to_lower c)) <- b
  end

let make_vec pat start stop cs def =
  let v = Array.make 255 def in
    set_char_from_str v pat start cs (not def);
    for n = start + 1 to stop - 1 do
      if pat.[n] = '-' then  (* Range! *)
	for i = Char.code pat.[n - 1] to Char.code pat.[n + 1] do
	  set_char v i cs (not def)
	done
      else 
	set_char_from_str v pat n cs (not def)
    done;
    set_char_from_str v pat stop cs (not def);
    Set v

(* Return the position of the closing ] in a character class. POSIX rules for escapes. *)
let find_close pat start =
  if pat.[start + 1] = ']' then
    String.index_from pat (start + 2) ']'
  else if pat.[start + 1] = '!' && pat.[start + 2] = ']' then
    String.index_from pat (start + 3) ']'
  else
    String.index_from pat start ']'
    
(* Compile a pattern string into a pattern list. A reversed list,
actually, but see below... *)
let rec do_compile pat pos len cs res =
  if pos >= len then res
  else if pat.[pos] = '\\' then
    do_compile pat (pos + 2) len cs (make_char pat.[pos + 1] cs :: res)
  else 
    match pat.[pos] with
      | '?' -> do_compile pat (pos + 1) len cs (AnyOne :: res)
      | '*' -> do_compile pat (pos + 1) len cs (Star :: res)
      | '[' -> 
	  let stop = find_close pat pos in
	    if pat.[pos + 1] = '!' then 
	      do_compile pat (stop + 1) len cs
		(make_vec pat (pos + 2) (stop - 1) cs true :: res)
	    else
	      do_compile pat (stop + 1) len cs
		(make_vec pat (pos + 1) (stop - 1) cs false :: res)
      | x -> do_compile pat (pos + 1) len cs (make_char x cs :: res)

(* Optimize away things like "foo*******" into "foo*", and get the
pattern list in the right order while we're at it. *)
let rec optimize_pattern pat res =
  match pat with
    | [] -> res
    | Char c1 :: Char c2 :: cdr -> 
	let s = String.create 2 in
	  s.[0] <- c2;
	  s.[1] <- c1;
	  optimize_pattern (String s :: cdr) res
    | String s :: Char c :: cdr ->
	let len = String.length s in
	let ns = String.create (len + 1) in
	  ns.[0] <- c;
	  String.blit s 0 ns 1 (String.length s);
	  optimize_pattern (String ns :: cdr) res
    | Star :: Star :: cdr -> optimize_pattern (Star :: cdr) res
    | cons :: cdr  -> optimize_pattern cdr (cons :: res)

let compile ?(cs:bool=true) pat =
  let p = do_compile pat 0 (String.length pat) cs [] in
    { glob = optimize_pattern p [];
      cs = cs;
    }

let rec do_match pat test pos len =
  match pat with
    | [] -> pos = len (* Exhausted the pattern *)
    | _ when pos >= len -> false
    | Star :: [] -> true (* Star at the end eats up the rest *)
    | String s :: Star :: [] ->  (* Optimize cases like "foo.*" *)
	if pos = 0 then
	  StrExtras.prefix s test
	else
	  StrExtras.match_substr s test pos
    | Star :: String s :: [] -> (* Optimize cases like *.c *)
	StrExtras.suffix s test
    | String s :: cdr -> (* Test for a sequence of multiple characters *)
	if StrExtras.match_substr s test pos then
	  do_match cdr test (pos + (String.length s)) len
	else
	  false
    | Char c :: cdr -> (* Test for a specific character *)
	if c = test.[pos] then
	  do_match cdr test (pos + 1) len
	else
	  false
    | AnyOne :: cdr -> (* Any single character *)
	if pos < len then
	  do_match cdr test (pos + 1) len
	else
	  false
    | Set set :: cdr -> (* A character class *)
	if set.(Char.code test.[pos]) then
	  do_match cdr test (pos + 1) len
	else
	  false
    | Star :: cdr -> (* As many characters as possible, but possibly 0 *)
	let tmp = ref (len - 1) and matched = ref false in
	  while !tmp >= pos && not !matched do 
	    if do_match cdr test !tmp  len then
	      matched := true
	    else
	      decr tmp 
	  done;
	  !matched	    

let exec pat test = do_match pat.glob test 0 (String.length test)

let quick ?(cs:bool=true) pat str = exec (compile ~cs pat) str

let case_sensitive pat = pat.cs

let escape pat =
  let len = (String.length pat) - 1 in
  let buf = Buffer.create len in
    for n = 0 to len do
      match pat.[n] with
	| '?' | '[' | ']' | '*' | '\\' as c ->
	    Buffer.add_char buf '\\';
	    Buffer.add_char buf c
	| c -> Buffer.add_char buf c
    done;
    Buffer.contents buf

type re_style = [ `PCRE | `Str ]

type range = Single of int | Range of int * int

let find_ranges bitvec =
  let n = ref 0 
  and res = ref [] 
  and len = Array.length bitvec in
    begin try 
      while !n < len do
	if bitvec.(!n) then begin
	  let next = ArrayExtras.find_index_from not bitvec !n in
	  let size = next - !n in
	    if size > 2 then 
	      res := (Range (!n, (next - 1))) :: !res
	    else if size = 2 then
	      res := Single !n :: Single (next - 1) :: !res
	    else 
	      res := Single !n :: !res;
	    n := next
	end else
	  incr n
      done
    with 
      | Not_found -> res := Single !n :: !res end;
    !res
      
let rec pcre_range buf r =
  match r with
    | Single i :: cdr -> Printf.bprintf buf "\\x%X" i; pcre_range buf cdr
    | Range (s, e) :: cdr ->
	Printf.bprintf buf "\\x%X-\\x%X" s e; pcre_range buf cdr
    | [] -> ()
    
let rec conv_pcre buf pat =
  match pat with
    | Char c :: cdr ->
	Printf.bprintf buf "\\x%X" (Char.code c); conv_pcre buf cdr
    | String s :: cdr -> Buffer.add_string buf (Pcre.quote s); conv_pcre buf cdr
    | AnyOne :: cdr -> Buffer.add_char buf '.';	conv_pcre buf cdr
    | Star :: cdr -> Buffer.add_string buf ".*"; conv_pcre buf cdr
    | Set chars :: cdr ->
	Buffer.add_char buf '[';
	pcre_range buf (find_ranges chars);
	Buffer.add_char buf ']';
	conv_pcre buf cdr
    | [] -> ()
	    
let convert_to_pcre glob =
  let buf = Buffer.create 64 in
    Buffer.add_char buf '^';
    if not glob.cs then Buffer.add_string buf "(?i:";
    conv_pcre buf glob.glob;
    if not glob.cs then Buffer.add_char buf ')';
    Buffer.add_char buf '$';
    Buffer.contents buf

(* Ripped out of str.ml *)
let quote_str s =
  let len = String.length s in
  let buf = String.create (2 * len) in
  let pos = ref 0 in
  for i = 0 to len - 1 do
    match s.[i] with
      '[' | ']' | '*' | '.' | '\\' | '?' | '+' | '^' | '$' as c ->
        buf.[!pos] <- '\\'; buf.[!pos + 1] <- c; pos := !pos + 2
    | c ->
        buf.[!pos] <- c; pos := !pos + 1
  done;
  String.sub buf 0 !pos

let rec conv_str buf pat =
  match pat with
    | Char c :: cdr ->
	Buffer.add_string buf (quote_str (String.make 1 c)); conv_str buf cdr
    | String s :: cdr -> Buffer.add_string buf (quote_str s); conv_str buf cdr
    | AnyOne :: cdr -> Buffer.add_char buf '.';	conv_str buf cdr
    | Star :: cdr -> Buffer.add_string buf ".*"; conv_str buf cdr
    | Set chars :: cdr ->
	let dash = Char.code '-' 
	and closebrace = Char.code ']'
	in
	  Buffer.add_char buf '[';
	  if chars.(closebrace) then
	    Buffer.add_char buf ']';
	  Array.iteri (fun i v ->
			 if v then 
			   if i <> dash && i <> closebrace then
			     Buffer.add_char buf (Char.chr i)
		      ) chars;
	  if chars.(dash) then
	    Buffer.add_char buf '-';
	  Buffer.add_char buf ']';
	  conv_str buf cdr
    | [] -> ()
    
let convert_to_str glob =
  let buf = Buffer.create 64 in
    Buffer.add_char buf '^';
    conv_str buf glob.glob;
    Buffer.add_char buf '$';
    Buffer.contents buf

let convert_to_re style glob =
  match style with
    | `PCRE -> convert_to_pcre glob
    | `Str -> convert_to_str glob

let regexp_of_glob ?(style=`PCRE) ?glob ?pat () =
  match glob, pat with
    | None, None -> invalid_arg "Glob.regexp_of_glob: No glob given"
    | Some g, _ -> convert_to_re style g
    | _, Some p -> convert_to_re style (compile p)