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