(******************************************************************************)

(*  ocaml-fileutils: files and filenames common operations                    *)

(*                                                                            *)

(*  Copyright (C) 2003-2014, Sylvain Le Gall                                  *)

(*                                                                            *)

(*  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, with the OCaml static compilation         *)

(*  exception.                                                                *)

(*                                                                            *)

(*  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 file         *)

(*  COPYING 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., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA             *)

(******************************************************************************)

open FileUtilTypes

open FilePath

open FileUtilMisc

open FileUtilSize

open FileUtilSTAT

let compile_filter ?(match_compile=(fun s fn -> s = fn)) flt =

  let cflt =

    let rec cc =

      function

      | True                   -> `Val true

      | False                  -> `Val false

      | Is_dev_block           -> `Stat (`Kind Dev_block)

      | Is_dev_char            -> `Stat (`Kind Dev_char)

      | Is_dir                 -> `Stat (`Kind Dir)

      | Is_file                -> `Stat (`Kind File)

      | Is_socket              -> `Stat (`Kind Socket)

      | Is_pipe                -> `Stat (`Kind Fifo)

      | Is_link                -> `Is_link

      | Is_set_group_ID        -> `Stat `Is_set_group_ID

      | Has_sticky_bit         -> `Stat `Has_sticky_bit

      | Has_set_user_ID        -> `Stat `Has_set_user_ID

      | Is_readable            -> `Stat `Is_readable

      | Is_writeable           -> `Stat `Is_writeable

      | Is_exec                -> `Stat `Is_exec

      | Size_not_null          -> `Stat (`Size (`Bigger, B 0L))

      | Size_bigger_than sz    -> `Stat (`Size (`Bigger, sz))

      | Size_smaller_than sz   -> `Stat (`Size (`Smaller, sz))

      | Size_equal_to sz       -> `Stat (`Size (`Equal, sz))

      | Size_fuzzy_equal_to sz -> `Stat (`Size (`FuzzyEqual, sz))

      | Is_owned_by_user_ID ->

          `Stat (`Is_owned_by_user_ID (Unix.geteuid ()))

      | Is_owned_by_group_ID ->

          `Stat (`Is_owned_by_group_ID (Unix.getegid ()))

      | Exists                 -> `Stat `Exists

      | Is_newer_than fn1      -> `Stat (`Newer (stat fn1).modification_time)

      | Is_older_than fn1      -> `Stat (`Older (stat fn1).modification_time)

      | Is_newer_than_date(dt) -> `Stat (`Newer dt)

      | Is_older_than_date(dt) -> `Stat (`Older dt)

      | Has_extension ext      -> `Has_extension ext

      | Has_no_extension       -> `Has_no_extension

      | Is_current_dir         -> `Is_current_dir

      | Is_parent_dir          -> `Is_parent_dir

      | Basename_is s          -> `Basename_is s

      | Dirname_is s           -> `Dirname_is s

      | Custom f               -> `Custom f

      | Match str              -> `Custom (match_compile str)

      | And(flt1, flt2) ->

          begin

            match cc flt1, cc flt2 with

              | `Val true, cflt | cflt, `Val true -> cflt

              | `Val false, _ | _,  `Val false -> `Val false

              | cflt1, cflt2 -> `And (cflt1, cflt2)

          end

      | Or(flt1, flt2) ->

          begin

            match cc flt1, cc flt2 with

              | `Val true, _ | _, `Val true -> `Val true

              | `Val false, cflt | cflt,  `Val false -> cflt

              | cflt1, cflt2 -> `Or (cflt1, cflt2)

          end

      | Not flt ->

          begin

            match cc flt with

              | `Val b -> `Val (not b)

              | cflt -> `Not cflt

          end

    in

    cc flt

  in

  let need_statL, need_stat =

    let rec dfs =

      function

        | `Val _ | `Has_extension _ | `Has_no_extension | `Is_current_dir

        | `Is_parent_dir | `Basename_is _ | `Dirname_is _

        | `Custom _ ->

            false, false

        | `Stat _ ->

            true, false

        | `Is_link ->

            false, true

        | `And (cflt1, cflt2) | `Or (cflt1, cflt2) ->

            let need_stat1, need_statL1 = dfs cflt1 in

            let need_stat2, need_statL2 = dfs cflt2 in

              need_stat1 || need_stat2, need_statL1 || need_statL2

        | `Not cflt ->

            dfs cflt

    in

      dfs cflt

  in

    (* Compiled function to return. *)

    fun ?st_opt ?stL_opt fn ->

      let st_opt =

        if need_stat && st_opt = None then begin

          try

            match stL_opt with

              | Some st when not st.is_link -> stL_opt

              | _ -> Some (stat fn)

          with FileDoesntExist _ ->

            None

        end else

          st_opt

      in

      let stL_opt =

        if need_statL && stL_opt = None then begin

          try

            match st_opt with

              | Some st when not st.is_link -> st_opt

              | _ -> Some (stat ~dereference:true fn)

          with FileDoesntExist _ ->

            None

        end else

          stL_opt

      in

      let rec eval =

        function

        | `Val b -> b

        | `Has_extension ext ->

            begin

              try

                check_extension fn ext

              with FilePath.NoExtension _ ->

                false

            end

        | `Has_no_extension ->

            begin

              try

                let _str: filename = chop_extension fn in

                  false

              with FilePath.NoExtension _ ->

                true

            end

        | `Is_current_dir -> is_current (basename fn)

        | `Is_parent_dir -> is_parent (basename fn)

        | `Basename_is bn -> (FilePath.compare (basename fn) bn) = 0

        | `Dirname_is dn -> (FilePath.compare (dirname fn) dn) = 0

        | `Custom f -> f fn

        | `Stat e ->

            begin

              match stL_opt, e with

              | Some _, `Exists -> true

              | Some stL, `Kind knd -> stL.kind = knd

              | Some stL, `Is_set_group_ID -> stL.permission.group.sticky

              | Some stL, `Has_sticky_bit -> stL.permission.other.sticky

              | Some stL, `Has_set_user_ID -> stL.permission.user.sticky

              | Some stL, `Size (cmp, sz) ->

                  begin

                    let diff = size_compare stL.size sz in

                      match cmp with

                      | `Bigger -> diff > 0

                      | `Smaller -> diff < 0

                      | `Equal -> diff = 0

                      | `FuzzyEqual ->

                          (size_compare ~fuzzy:true stL.size sz) = 0

                  end

              | Some stL, `Is_owned_by_user_ID uid -> uid = stL.owner

              | Some stL, `Is_owned_by_group_ID gid -> gid = stL.group_owner

              | Some stL, `Is_readable ->

                  let perm = stL.permission in

                    perm.user.read || perm.group.read || perm.other.read

              | Some stL, `Is_writeable ->

                  let perm = stL.permission in

                    perm.user.write || perm.group.write || perm.other.write

              | Some stL, `Is_exec ->

                  let perm = stL.permission in

                    perm.user.exec || perm.group.exec || perm.other.exec

              | Some stL, `Newer dt -> stL.modification_time > dt

              | Some stL, `Older dt -> stL.modification_time < dt

              | None, _ -> false

            end

        | `Is_link ->

            begin

              match st_opt with

                | Some st -> st.is_link

                | None -> false

            end

        | `And (cflt1, cflt2) -> (eval cflt1) && (eval cflt2)

        | `Or (cflt1, cflt2) -> (eval cflt1) || (eval cflt2)

        | `Not cflt -> not (eval cflt)

      in

      eval cflt

let test ?match_compile tst =

  let ctst = compile_filter ?match_compile tst in

  fun fln -> ctst (solve_dirname fln)

let filter flt lst = List.filter (test flt) lst

let test_exists = test (Or(Exists, Is_link))