dups.ml

   1 open Printf
   2
   3 module Array = ArrayLabels
   4 module List  = ListLabels
   5 module StrSet= Set.Make(String)
   6 module Unix  = UnixLabels
   7
   8 module Stream : sig
   9   type 'a t
  10
  11   val create : (unit -> 'a option) -> 'a t
  12
  13   val iter : 'a t -> f:('a -> unit) -> unit
  14
  15   val concat : ('a t) list -> 'a t
  16 end = struct
  17   module S = Stream
  18
  19   type 'a t =
  20     ('a S.t) list
  21
  22   let create f =
  23     [S.from (fun _ -> f ())]
  24
  25   let iter t ~f =
  26     List.iter t ~f:(S.iter f)
  27
  28   let concat ts =
  29     List.concat ts
  30 end
  31
  32 module In_channel : sig
  33   val lines : in_channel -> string Stream.t
  34 end = struct
  35   let lines ic =
  36     Stream.create (fun () ->
  37       match input_line ic with
  38       | exception End_of_file ->
  39           None
  40       | line ->
  41           Some line
  42     )
  43 end
  44
  45 module Directory_tree : sig
  46   val find_files : string -> string Stream.t
  47 end = struct
  48   let find_files root =
  49     let dirs  = Queue.create () in
  50     let files = Queue.create () in
  51     let explore parent =
  52       Array.iter (Sys.readdir parent) ~f:(fun child ->
  53         let path = Filename.concat parent child in
  54         let {Unix.st_kind = file_kind; _} = Unix.lstat path in
  55         match file_kind with
  56         | Unix.S_REG ->
  57             Queue.add path files
  58         | Unix.S_DIR ->
  59             Queue.add path dirs
  60         | Unix.S_CHR
  61         | Unix.S_BLK
  62         | Unix.S_LNK
  63         | Unix.S_FIFO
  64         | Unix.S_SOCK ->
  65             ()
  66       )
  67     in
  68     explore root;
  69     let rec next () =
  70       match Queue.is_empty files, Queue.is_empty dirs with
  71       | false, _     -> Some (Queue.take files)
  72       | true , true  -> None
  73       | true , false ->
  74           explore (Queue.take dirs);
  75           next ()
  76     in
  77     Stream.create next
  78 end
  79
  80 type input =
  81   | Stdin
  82   | Directories of string list
  83
  84 type output =
  85   | Stdout
  86   | Directory of string
  87
  88 let make_input_stream = function
  89   | Stdin ->
  90       In_channel.lines stdin
  91   | Directories paths ->
  92       let paths = StrSet.elements (StrSet.of_list paths) in
  93       Stream.concat (List.map paths ~f:Directory_tree.find_files)
  94
  95 let make_output_fun = function
  96   | Stdout ->
  97       fun digest n_paths paths ->
  98         printf "%s %d\n%!" (Digest.to_hex digest) n_paths;
  99         List.iter (StrSet.elements paths) ~f:(printf "    %S\n%!")
 100   | Directory dir ->
 101       fun digest _ paths ->
 102         let digest = Digest.to_hex digest in
 103         let dir = Filename.concat dir (String.sub digest 0 2) in
 104         Unix.mkdir dir ~perm:0o700;
 105         let oc = open_out (Filename.concat dir digest) in
 106         List.iter (StrSet.elements paths) ~f:(fun path ->
 107           output_string oc (sprintf "%S\n%!" path)
 108         );
 109         close_out oc
 110
 111 let main input output ignore =
 112   let output = make_output_fun  output in
 113   let input  = make_input_stream input in
 114   let paths_by_digest = Hashtbl.create 1_000_000 in
 115   let path_count = ref 0 in
 116   let t0 = Sys.time () in
 117   let process path =
 118     try
 119       let digest = Digest.file path in
 120       let count, paths =
 121         match Hashtbl.find_opt paths_by_digest digest with
 122         | None ->
 123             (0, StrSet.empty)
 124         | Some (n, paths) ->
 125             (n, paths)
 126       in
 127       Hashtbl.replace paths_by_digest digest (count + 1, StrSet.add path paths)
 128     with Sys_error e ->
 129       eprintf "WARNING: Failed to process %S: %S\n%!" path e
 130   in
 131   Stream.iter input ~f:(fun path ->
 132     incr path_count;
 133     match ignore with
 134     | Some regexp when (Str.string_match regexp path 0) ->
 135         ()
 136     | Some _ | None ->
 137         process path
 138   );
 139   Hashtbl.iter (fun d (n, ps) -> if n > 1 then output d n ps) paths_by_digest;
 140   let t1 = Sys.time () in
 141   eprintf "Processed %d files in %f seconds.\n%!" !path_count (t1 -. t0)
 142
 143 let () =
 144   let input  = ref Stdin in
 145   let output = ref Stdout in
 146   let ignore = ref None in
 147   let assert_file_exists path =
 148     if Sys.file_exists path then
 149       ()
 150     else begin
 151       eprintf "File does not exist: %S\n%!" path;
 152       exit 1
 153     end
 154   in
 155   let assert_file_is_dir path =
 156     if Sys.is_directory path then
 157       ()
 158     else begin
 159       eprintf "File is not a directory: %S\n%!" path;
 160       exit 1
 161     end
 162   in
 163   let spec =
 164     [ ( "-out"
 165       , Arg.String (fun path ->
 166           assert_file_exists path;
 167           assert_file_is_dir path;
 168           output := Directory path
 169         )
 170       , " Output to this directory instead of stdout."
 171       )
 172     ; ( "-ignore"
 173       , Arg.String (fun regexp -> ignore := Some (Str.regexp regexp))
 174       , " Ignore file paths which match this regexp pattern (see Str module)."
 175       )
 176     ]
 177   in
 178   Arg.parse
 179     (Arg.align spec)
 180     (fun path ->
 181       assert_file_exists path;
 182       assert_file_is_dir path;
 183       match !input with
 184       | Stdin ->
 185           input := Directories [path]
 186       | Directories paths ->
 187           input := Directories (path :: paths)
 188     )
 189     "";
 190   main !input !output !ignore