PR#5438: Use robocopy instead of cp on Windows

master_changes.md

@@ -337,6 +337,8 @@ users)
   * [BUG] Display correct exception backtrace on uncaught exception on Windows [#5216 @dra27]
   * Use grep -F instead of fgrep, as the latter is deprecated [#5309 @MisterDA]
   * Always open files with `O_SHARE_DELETE`, which eliminates unnecessary "access denied" errors in various situations on Windows. [#5435 @dra27]
+  * Use `Sys.rename` instead of `mv` [#5438 @dra27]
+  * Use `robocopy` instead of `cp` on Windows [#5438 @dra27]
 
 ## Internal: Windows
   * Support MSYS2: treat MSYS2 and Cygwin as equivalent [#4813 @jonahbeckford]

src/core/opamSystem.ml

@@ -254,13 +254,15 @@ let in_dir dir fn =
   with e ->
     OpamStd.Exn.finalise e reset_cwd
 
-let list kind dir =
+let with_path dir files = List.map (Filename.concat dir) files
+
+let list ?(map = with_path) kind dir =
   try
     in_dir dir (fun () ->
       let d = Sys.readdir (Sys.getcwd ()) in
       let d = Array.to_list d in
       let l = List.filter kind d in
-      List.map (Filename.concat dir) (List.sort compare l)
+      map dir (List.sort compare l)
     )
   with File_not_found _ -> []
 
@@ -575,11 +577,11 @@ let run_process
     | `Not_found -> command_not_found cmd
     | `Denied -> permission_denied cmd
 
-let command ?verbose ?env ?name ?metadata ?allow_stdin cmd =
+let command ?(success=raise_on_process_error) ?verbose ?env ?name ?metadata ?allow_stdin cmd =
   let name = log_file name in
   let r = run_process ?verbose ?env ~name ?metadata ?allow_stdin cmd in
   OpamProcess.cleanup r;
-  raise_on_process_error r
+  success r
 
 let commands ?verbose ?env ?name ?metadata ?(keep_going=false) commands =
   let name = log_file name in
@@ -633,6 +635,12 @@ let copy_file src dst =
   log "copy %s -> %s" src dst;
   copy_file_aux ~src ~dst ()
 
+let robocopy_success r =
+  let open OpamProcess in
+  (* XXX Comment this! *)
+  if r.r_code <> 0 && r.r_code <> 1 then
+    raise (Process_error r)
+
 let copy_dir src dst =
   (* MSYS2 requires special handling because its uses copying rather than
      symlinks for maximum portability on Windows. However copying a source
@@ -680,18 +688,36 @@ let copy_dir src dst =
        ([ "rsync"; "-a"; "--ignore-existing"; trailingslash_cygsrc; cygdest ]))
   else if Sys.file_exists dst then
     if Sys.is_directory dst then
-      match ls src with
+      let files =
+        (* XXX This mechanism isn't necessary - robocopy prefers not to have wildcards anyway *)
+        if Sys.win32 then
+          list ~map:(fun _ x -> x) (fun _ -> true) src
+        else
+          list (fun _ -> true) src in
+      match files with
       | [] -> ()
       | srcfiles ->
-        command ~verbose:(verbose_for_base_commands ())
-          ([ "cp"; "-PRp" ] @ srcfiles @ [ dst ])
+        if Sys.win32 then
+          (* XXX Apply the slightly strange quoting rules for robocopy here - trailing space, etc. *)
+          command ~success:robocopy_success ~verbose:(verbose_for_base_commands ())
+            (* How recent are /DCOPY:DATE and /SJ + /SL
+               XXX /SJ and /DCOPY:E are't present in 1809 / Server 2019 *)
+            ([ "robocopy"; "/E"; "/COPY:DAT"; "/SL"; (*"/SJ";*) "/DCOPY:DAT"; src; dst ])
+        else
+          command ~success:robocopy_success ~verbose:(verbose_for_base_commands ())
+            ([ "cp"; "-PRp" ] @ srcfiles @ [ dst ])
     else
       internal_error
         "Can not copy dir %s to %s, which is not a directory" src dst
   else
     (mkdir (Filename.dirname dst);
-     command ~verbose:(verbose_for_base_commands ())
-       [ "cp"; "-PRp"; src; dst ])
+     if Sys.win32 then
+       (* XXX Apply the slightly strange quoting rules for robocopy here - trailing space, etc. *)
+       command ~success:robocopy_success ~verbose:(verbose_for_base_commands ())
+         [ "robocopy"; "/E"; "/COPY:DAT"; "/SL"; (*"/SJ";*) "/DCOPY:DAT"; src; dst ]
+     else
+       command ~verbose:(verbose_for_base_commands ())
+         [ "cp"; "-PRp"; src; dst ])
 
 let mv_aux f src dst =
   if file_or_symlink_exists dst then remove_file dst;

src/core/opamSystem.mli

@@ -197,10 +197,10 @@ val get_cygpath_function: command:string -> (string -> string) lazy_t
 val get_cygpath_path_transform: (string -> string) lazy_t
 
 (** [command cmd] executes the command [cmd] in the correct OPAM
-    environment. *)
-val command: ?verbose:bool -> ?env:string array -> ?name:string ->
-  ?metadata:(string * string) list -> ?allow_stdin:bool ->
-  command -> unit
+    environment. [~success] defaults to {!raise_on_process_error} *)
+val command: ?success:(OpamProcess.result -> unit) -> ?verbose:bool ->
+  ?env:string array -> ?name:string -> ?metadata:(string * string) list ->
+  ?allow_stdin:bool -> command -> unit
 
 (** [commands cmds] executes the commands [cmds] in the correct OPAM
     environment. It stops whenever one command fails unless [keep_going] is set