Source file find.ml

(*********************************************************************************)
(*                Chamo                                                          *)
(*                                                                               *)
(*    Copyright (C) 2003-2021 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    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                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** *)

open Unix

type filter =
  | Maxdepth of int
  | Type of Unix.file_kind
  | Follow
  | Regexp of Str.regexp
  | Atime of interval
  | Predicate of (string -> bool)
  and interval =
  Le of int | Eq of int | Ge of int

type mode =
  | Ignore
  | Stderr
  | Failure
  | Custom of (Unix.error * string * string -> unit)

(* To memorize visited inodes *)
type inode = int * int
let inode st = st.st_dev, st.st_ino

(* parameters driving the find *)
type status =
  { maxdepth : int;
    follow : bool;
    filters : (string -> stats -> bool) list;
    stat_function : string -> stats;
    action : string -> unit;
    handler : (error * string * string -> unit)
  }

exception Hide of exn
  (* Used to hide user-level errors, so that they are not trapped by the library *)

let hide_exn f x = try f x with exn -> raise (Hide exn)
let reveal_exn f x = try f x with Hide exn -> raise exn

let stderr_handler (e, b, c) =
        prerr_endline ("find: " ^ c ^": " ^ (error_message e))
let ignore_handler _ = ()
let failure_handler (e,b,c) = raise (Hide (Unix_error (e, b, c)))
let handler = function
| Stderr -> stderr_handler
| Ignore -> ignore_handler
| Failure -> failure_handler
| Custom h -> hide_exn h

(* handlers of errors during the call. *)
let treat_unix_error h f x =
  try f x with  Unix_error (e, b, c) ->  h (e, b, c)

let default_status =
  { follow = false;
    maxdepth = max_int;
    filters = [];
    stat_function = lstat;
    action = prerr_endline;
    handler = handler Stderr;
  }

let add_filter status f = { status with filters = f :: status.filters }

let seconds_in_a_day = 86400.

exception Find of string

let parse_option status = function
| Maxdepth n ->
    { status with maxdepth = n }
| Type k ->
    add_filter status
      (fun name stat -> stat.st_kind = k)
| Follow ->
    { status with follow = true }
| Regexp exp ->
    add_filter status
      (fun name stat ->
         Str.string_match exp name 0 &&
           Str.match_beginning () = 0 &&
           Str.match_end () = String.length name
      )
| Atime n ->
    let min, max =
      match n with
      | Eq d when d > 0 ->
          float d *. seconds_in_a_day, float (d-1) *. seconds_in_a_day
      | Le d when d > 0 ->
          min_float, float (d-1) *. seconds_in_a_day
      | Le d when d > 0 ->
          min_float, float (d-1) *. seconds_in_a_day
      | Ge d when d > 0 ->
          float (d) *. seconds_in_a_day, max_float
      | _ -> raise (Find "Ill_formed argument")
    in
    let now = time() in
    add_filter status
      (fun name stat ->
         let time = now -. stat.st_atime in min <= time && time <= max)
| Predicate f ->
    add_filter status (fun name stat -> f name)

let parse_options options =
  List.fold_left parse_option default_status options

let filter_all filename filestat filters =
  List.for_all (fun f -> f filename filestat) filters

let iter_dir f d =
  let dir_handle = opendir d in
  try while true do f (readdir dir_handle) done with
    End_of_file -> closedir dir_handle
  | x -> closedir dir_handle; raise x

let rec find_rec status visited depth filename =
  let find() =
    let filestat =
      if status.follow then stat filename else status.stat_function filename in
    let id = filestat.st_dev, filestat.st_ino in
    if filter_all filename filestat status.filters then status.action filename;
    if filestat.st_kind = S_DIR && depth < status.maxdepth &&
      (not status.follow || not (List.mem id visited))
    then
      let process_child child =
        if (child <> Filename.current_dir_name &&
           child <> Filename.parent_dir_name) then
          let child_name = Filename.concat filename child in
          let visited = if status.follow then id :: visited else visited in
          find_rec status visited (depth+1) child_name
      in
      (* process_child is recursively protected from errors *)
      iter_dir process_child filename
  in
  treat_unix_error status.handler find ()

let find_entry status filename = find_rec status [] 0 filename

let find mode filenames options action =
  let status =
    { (parse_options options) with
      handler = handler mode;
      action = hide_exn action }
  in
  reveal_exn (List.iter (find_entry status)) filenames

let find_list mode filenames options =
  let l = ref [] in
  find mode filenames options (fun s -> l := s :: !l);
  List.rev !l