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