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

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

open FileUtilTOUCH

open FileUtilRM

open FileUtilSTAT

open FileUtilUMASK

open FileUtilMKDIR

open FileUtilCHMOD

open FileUtilTEST

exception CpError of string

exception CpSkip

type cp_error =

  [ `CannotChmodDstDir of filename * exn

  | `CannotCopyDir of filename

  | `CannotCopyFilesToFile of filename list * filename

  | `CannotCreateDir of filename * exn

  | `CannotListSrcDir of filename * exn

  | `CannotOpenDstFile of filename * exn

  | `CannotOpenSrcFile of filename * exn

  | `CannotRemoveDstFile of filename * exn

  | `DstDirNotDir of filename

  | `ErrorRead of filename * exn

  | `ErrorWrite of filename * exn

  | `Exc of exn

  | `NoSourceFile of filename

  | `PartialWrite of filename * int * int

  | `SameFile of filename * filename

  | `UnhandledType of filename * kind ]

let same_file st1 st2 =

  st1.device = st2.device && st1.inode = st2.inode

let cp

    ?(follow=Skip)

    ?(force=Force)

    ?(recurse=false)

    ?(preserve=false)

    ?(error=(fun str _ -> raise (CpError str)))

    fln_src_lst

    fln_dst =

  let herror, _ =

    let spf fmt = Printf.sprintf fmt in

    let exs () e =

      match e with

      | Unix.Unix_error(err, _, _) -> Unix.error_message err

      | e -> Printexc.to_string e

    in

    handle_error_gen "cp" error

      (function

       | `CannotRemoveDstFile(fn_dst, e) ->

           spf "Cannot remove destination file '%s': %a." fn_dst exs e

       | `CannotOpenDstFile(fn_dst, e) ->

           spf "Cannot open destination file '%s': %a." fn_dst exs e

       | `CannotOpenSrcFile(fn_src, e) ->

           spf "Cannot open source file '%s': %a." fn_src exs e

       | `ErrorRead(fn_src, e) ->

           spf "Error reading file '%s': %a." fn_src exs e

       | `ErrorWrite(fn_dst, e) ->

           spf "Error writing file '%s': %a." fn_dst exs e

       | `PartialWrite(fn_dst, read, written) ->

           spf

             "Partial write to file '%s': %d read, %d written."

             fn_dst

             read

             written

       | `CannotCopyDir fn_src ->

           spf "Cannot copy directory '%s' recursively." fn_src

       | `DstDirNotDir fn_dst ->

           spf "Destination '%s' is not a directory." fn_dst

       | `CannotCreateDir(fn_dst, e) ->

           spf "Cannot create directory '%s': %a." fn_dst exs e

       | `CannotListSrcDir(fn_src, e) ->

           spf "Cannot list directory '%s': %a." fn_src exs e

       | `CannotChmodDstDir(fn_dst, e) ->

           spf "'Cannot chmod directory %s': %a." fn_dst exs e

       | `NoSourceFile fn_src ->

           spf "Source file '%s' doesn't exist." fn_src

       | `SameFile(fn_src, fn_dst) ->

           spf "'%s' and '%s' are the same file." fn_src fn_dst

       | `UnhandledType(fn_src, _) ->

           spf "Cannot handle the type of kind for file '%s'." fn_src

       | `CannotCopyFilesToFile(fn_src_lst, fn_dst) ->

           spf "Cannot copy a list of files to another file '%s'." fn_dst

       | #exc -> "")

  in

  let handle_error e =

    herror ~fatal:false e;

    raise CpSkip

  in

  let handle_exception f a h =

    try

      f a

    with e ->

      herror ~fatal:false (h e);

      raise CpSkip

  in

  let copy_time_props st_src fln_dst =

    if preserve then begin

      touch

        ~time:(Touch_timestamp st_src.modification_time)

        ~mtime:true

        ~create:false

        fln_dst;

      touch

        ~time:(Touch_timestamp st_src.access_time)

        ~atime:true

        ~create:false

        fln_dst;

    end

  in

  let buffer = Bytes.make 1024 ' ' in

  let cp_file st_src dst_exists fn_src fn_dst =

    let mode = int_of_permission st_src.permission in

    (* POSIX conditions: *)

    (* 3a *)

    let fd_dst =

      (* 3ai *)

      if dst_exists && doit force fn_dst then begin

        try

          (* 3aii *)

          Unix.openfile fn_dst [Unix.O_WRONLY; Unix.O_TRUNC] mode

        with _ ->

          (* 3aii *)

          handle_exception

            (fun lst -> rm lst) [fn_dst]

            (fun e -> `CannotRemoveDstFile(fn_dst, e));

          handle_exception

            (Unix.openfile fn_dst [Unix.O_WRONLY; Unix.O_CREAT]) mode

            (fun e -> `CannotOpenDstFile(fn_dst, e))

      end else if not dst_exists then begin

        handle_exception

          (Unix.openfile fn_dst [Unix.O_WRONLY; Unix.O_CREAT]) mode

          (fun e -> `CannotOpenDstFile(fn_dst, e))

      end else begin

        raise CpSkip

      end

    in

    let read = ref 0 in

      try

        let fd_src =

          handle_exception

            (Unix.openfile fn_src [Unix.O_RDONLY]) 0o600

            (fun e -> `CannotOpenSrcFile(fn_src, e))

        in

          try

            while (read :=

                   handle_exception

                     (Unix.read fd_src buffer 0) (Bytes.length buffer)

                     (fun e -> `ErrorRead(fn_src, e));

                   !read <> 0) do

              let written =

                handle_exception

                  (Unix.write fd_dst buffer 0) !read

                  (fun e -> `ErrorWrite(fn_dst, e))

              in

                if written != !read then

                  handle_error (`PartialWrite(fn_src, !read, written))

            done;

            Unix.close fd_src;

            Unix.close fd_dst;

            copy_time_props st_src fn_dst

          with e ->

            Unix.close fd_src;

            raise e

      with e ->

        Unix.close fd_dst;

        raise e

  in

  let cp_symlink fn_src fn_dst =

    (* No Unix.lutimes to set time of the symlink. *)

    Unix.symlink (Unix.readlink fn_src) fn_dst

  in

  let rec cp_dir st_src dst_exists fn_src fn_dst =

    (* 2a *)

    if not recurse then begin

      handle_error (`CannotCopyDir fn_src)

    (* 2d, 2c *)

    end else if dst_exists && (stat fn_dst).kind <> Dir then begin

      handle_error (`DstDirNotDir fn_dst)

    end else begin

      (* 2e *)

      let dst_created =

        if not dst_exists then begin

          let mode =

            let src_mode = int_of_permission st_src.permission in

            let dst_mode =

              if preserve then src_mode else umask_apply src_mode

            in

              `Octal (dst_mode lor 0o0700)

          in

            handle_exception

              (fun fn -> mkdir ~mode fn) fn_dst

              (fun e -> `CannotCreateDir(fn_dst, e));

            true

        end else begin

          false

        end

      in

        (* 2f *)

        Array.iter

          (fun bn ->

             if not (is_current bn || is_parent bn) then

               cp_one (concat fn_src bn) (concat fn_dst bn))

          (handle_exception

             Sys.readdir fn_src

             (fun e -> `CannotListSrcDir(fn_src, e)));

        (* 2g *)

        if dst_created then begin

          let mode =

            let src_mode = int_of_permission st_src.permission in

              `Octal (if preserve then src_mode else umask_apply src_mode)

          in

            handle_exception

              (chmod mode) [fn_dst]

              (fun e -> `CannotChmodDstDir(fn_dst, e));

            copy_time_props st_src fn_dst

        end

    end

  and cp_one fn_src fn_dst =

    let st_src, st_src_deref =

      (* Check existence of source files. *)

      if test_exists fn_src then begin

        let st = stat fn_src in

        if st.kind = Symlink && not recurse then begin

          st, stat ~dereference:true fn_src

        end else begin

          st, st

        end

      end else begin

        handle_error (`NoSourceFile fn_src)

      end

    in

    let same_file, dst_exists =

      (* Test if fn_dst exists and if it is the same file as fn_src. *)

      try

        same_file st_src (stat fn_dst), true

      with FileDoesntExist _ ->

        false, false

    in

      if same_file then begin

        handle_error (`SameFile(fn_src, fn_dst))

      end;

      try

        match st_src.kind with

          | Dir -> cp_dir st_src dst_exists fn_src fn_dst

          | File -> cp_file st_src dst_exists fn_src fn_dst

          | Symlink ->

            if st_src_deref.kind = Dir || recurse then

              cp_symlink fn_src fn_dst

            else

              cp_file st_src_deref dst_exists fn_src fn_dst

          | Fifo | Dev_char | Dev_block | Socket ->

              handle_error (`UnhandledType(fn_src, st_src.kind))

      with CpSkip ->

        ()

  in

    if test Is_dir fln_dst then

      List.iter

        (fun fn_src ->

           cp_one fn_src (concat fln_dst (basename fn_src)))

        fln_src_lst

    else if List.length fln_src_lst <= 1 then

      List.iter

        (fun fn_src -> cp_one fn_src fln_dst)

        fln_src_lst

    else

      handle_error (`CannotCopyFilesToFile(fln_src_lst, fln_dst))