Source file ZipFile.ml

exception ZipError of string * string

let () =
  Callback.register_exception "MlFront_ZipFile.ZipFile.ZipError"
    (ZipError ("", ""))

external mlfront_zipfile_unzip :
  (string -> int -> int -> unit) option -> string -> string -> unit
  = "mlfront_zipfile_unzip"

external mlfront_zipfile_zip :
  bool -> char -> (string -> bool) option -> string -> string -> unit
  = "mlfront_zipfile_zip"

external mlfront_zipfile_addfile : bool -> char -> string -> string -> unit
  = "mlfront_zipfile_addfile"

external mlfront_zipfile_deletefile : string -> string -> unit
  = "mlfront_zipfile_deletefile"

let unzip_exn ?on_entry ~srczip ~destdir () =
  mlfront_zipfile_unzip on_entry srczip destdir

type writeinfo = { cwd : string; abs_destzip : string; write_mode : char }

let get_writeinfo ~destzip =
  let cwd = Sys.getcwd () in
  let write_mode =
    if Sys.file_exists destzip then
      (* zero-byte zip files are a signal that a prior zip operation failed.
         recreate the zero-byte zip files rather than append since append
         requires a valid zipfile. *)
      let { st_size; _ } : Unix.LargeFile.stats = Unix.LargeFile.stat destzip in
      if st_size = 0L then 'w' else 'a'
    else 'w'
  in
  let abs_destzip =
    if Filename.is_relative destzip then Filename.concat cwd destzip
    else destzip
  in
  { cwd; abs_destzip; write_mode }

let normalize s =
  if String.ends_with ~suffix:"/" s then String.sub s 0 (String.length s - 1)
  else s

let thread_unsafe_within_dir ~cwd dir f =
  Sys.chdir dir;
  Fun.protect ~finally:(fun () -> Sys.chdir cwd) (fun () -> f ())

let zip_exn ?verbose ?filter ?subpath ~destzip ~srcdir () =
  let { cwd; abs_destzip; write_mode } = get_writeinfo ~destzip in
  let verbose = if verbose = Some () then true else false in
  thread_unsafe_within_dir ~cwd srcdir (fun () ->
      match subpath with
      | None -> mlfront_zipfile_zip verbose write_mode filter abs_destzip "."
      | Some subpath ->
          mlfront_zipfile_zip verbose write_mode filter abs_destzip
            (normalize subpath))

let zip_add_file_exn ?verbose ~destzip ~srcdir s =
  let { cwd; abs_destzip; write_mode } = get_writeinfo ~destzip in
  let verbose = if verbose = Some () then true else false in
  thread_unsafe_within_dir ~cwd srcdir (fun () ->
      mlfront_zipfile_addfile verbose write_mode abs_destzip (normalize s))

let zip_delete_file_exn ~destzip s = mlfront_zipfile_deletefile destzip s