src/utils/cdk/unix2.ml

   1 (* Copyright 2001, 2002 b8_bavard, b8_fee_carabine, INRIA *)
   2 (*
   3     This file is part of mldonkey.
   4
   5     mldonkey is free software; you can redistribute it and/or modify
   6     it under the terms of the GNU General Public License as published by
   7     the Free Software Foundation; either version 2 of the License, or
   8     (at your option) any later version.
   9
  10     mldonkey is distributed in the hope that it will be useful,
  11     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13     GNU General Public License for more details.
  14
  15     You should have received a copy of the GNU General Public License
  16     along with mldonkey; if not, write to the Free Software
  17     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18 *)
  19
  20 open Printf2
  21 open Unix
  22
  23 let tryopen openf closef filename f =
  24   let descr = openf filename in
  25   let result =
  26     try
  27       f descr
  28     with e ->
  29       (try closef descr with _ -> ());
  30       raise e in
  31   closef descr;
  32   result
  33
  34 let exn_drop f x = try f x with _ -> ()
  35 let with_remove fn f = tryopen (fun fn -> fn) (fun fn -> exn_drop Sys.remove fn) fn f
  36
  37 let tryopen_read fn f = tryopen open_in close_in fn f
  38 let tryopen_write fn f = tryopen open_out close_out fn f
  39 let tryopen_read_bin fn f = tryopen open_in_bin close_in fn f
  40 let tryopen_write_bin fn f = tryopen open_out_bin close_out fn f
  41 let tryopen_read_gen fn flags perm f =
  42   tryopen (open_in_gen flags perm) close_in fn f
  43 let tryopen_write_gen fn flags perm f =
  44   tryopen (open_out_gen flags perm) close_out fn f
  45 let tryopen_openfile fn flags perm f =
  46   tryopen (fun fn -> Unix.openfile fn flags perm) Unix.close fn f
  47 let tryopen_dir dir f = tryopen opendir closedir dir f
  48 let tryopen_read_zip fn f = tryopen Zip.open_in Zip.close_in fn f
  49 let tryopen_write_zip fn f = tryopen Zip.open_out Zip.close_out fn f
  50 let tryopen_read_tar fn f =
  51   tryopen Tar.open_in Tar.close_in fn f
  52 let tryopen_write_tar ?compress fn f =
  53   tryopen (Tar.open_out ?compress) Tar.close_out fn f
  54 let tryopen_read_gzip fn f =
  55   tryopen Gzip.open_in_file Gzip.close_in fn f
  56 let tryopen_write_gzip ?level fn f =
  57   tryopen (Gzip.open_out_file ?level) Gzip.close_out fn f
  58 let tryopen_umask temp_umask f =
  59   (* Unix.umask is not implemented on MinGW *)
  60   let safe_umask umask = try Unix.umask umask with Invalid_argument _ -> 0 in
  61   tryopen safe_umask (fun oldumask -> ignore(safe_umask oldumask)) temp_umask f
  62
  63 let list_directory filename =
  64   let list = ref [] in
  65   tryopen_dir filename (fun dir ->
  66     try
  67       while true do
  68         let file = readdir dir in
  69         if file <> "." && file <> ".." &&
  70           not (file = ".DS_Store" || String2.check_prefix file "._" ||
  71                file = "Thumbs.db" || file = "desktop.ini") then
  72             list := file :: !list
  73       done
  74     with End_of_file -> ());
  75   !list
  76
  77 let iter_directory f dirname =
  78   tryopen_dir dirname (fun dir ->
  79     try
  80       while true do
  81         let file = readdir dir in
  82         if file <> "." && file <> ".." then
  83           f (Filename.concat dirname file)
  84       done
  85     with End_of_file -> ())
  86
  87 let is_directory filename =
  88   try let s = Unix.LargeFile.stat filename in s.LargeFile.st_kind = S_DIR with _ -> false
  89
  90 let is_link filename =
  91   try let s = Unix.LargeFile.lstat filename in s.LargeFile.st_kind = S_LNK with _ -> false
  92
  93 let chmod f o =
  94   try
  95     Unix.chmod f o
  96   with e ->
  97     lprintf_nl "warning: chmod failed on %s: %s" f (Printexc2.to_string e)
  98
  99 let rec safe_mkdir ?(mode = 0o775) dir =
 100   if Sys.file_exists dir then begin
 101     if not (is_directory dir) then
 102       failwith (Printf.sprintf "%s already exists but is not a directory" dir)
 103   end
 104   else
 105     if is_link dir then
 106       try
 107         tryopen_dir dir ignore
 108       with
 109         | Unix.Unix_error (EACCES, _, _) ->
 110             lprintf_nl "access denied for directory %s" dir;
 111             exit 73
 112         | Unix.Unix_error (ENOENT, _, _) ->
 113             lprintf_nl "directory %s not found, orphaned link?" dir;
 114             exit 73
 115         | e ->
 116             lprintf_nl "error %s for directory %s" (Printexc2.to_string e) dir;
 117             exit 73
 118     else
 119       let predir = Filename.dirname dir in
 120       if predir <> dir then safe_mkdir predir;
 121       try
 122         Unix.mkdir dir mode
 123       with
 124         Unix.Unix_error (EEXIST, _, _) -> ()
 125       | e -> lprintf_nl "error %s for directory %s" (Printexc2.to_string e) dir; exit 73
 126
 127 (* same as in downloadClient.ml *)
 128 let rec really_write fd s pos len =
 129   if len = 0 then begin
 130 (*      lprintf "really_write 0 BYTES !!!!!!!!!\n";  *)
 131       raise End_of_file
 132     end else
 133   let nwrite = Unix.write fd s pos len in
 134   if nwrite = 0 then raise End_of_file else
 135   if nwrite < len then
 136     really_write fd s (pos + nwrite) (len - nwrite)
 137
 138 let rec really_read fd s pos len =
 139   let nread = Unix.read fd s pos len in
 140   if nread = 0 then raise End_of_file else
 141   if nread < len then
 142     really_read fd s (pos + nread) (len - nread)
 143
 144 let copy oldname newname =
 145   tryopen_read_bin oldname (fun ic ->
 146     let stats =
 147       try Some (Unix.LargeFile.fstat (Unix.descr_of_in_channel ic)) with _ -> None
 148     in
 149     tryopen_write_bin newname (fun oc ->
 150       (match stats with
 151       | None -> ()
 152       | Some stats ->
 153       let descr = Unix.descr_of_out_channel oc in
 154       (try Unix.fchown descr stats.Unix.LargeFile.st_uid stats.Unix.LargeFile.st_gid
 155        with e -> lprintf_nl "copy: failed to preserve owner");
 156       (try Unix.fchmod descr stats.Unix.LargeFile.st_perm
 157        with e -> lprintf_nl "copy: failed to preserve mode"));
 158       let buffer_len = 8192 in
 159       let buffer = String.create buffer_len in
 160       let rec copy_file () =
 161         let n = input ic buffer 0 buffer_len in
 162         if n = 0 then () else begin
 163           output oc buffer 0 n;
 164           copy_file ()
 165         end in
 166       copy_file ()))
 167
 168 let rename oldname newname =
 169   if oldname <> newname then
 170   try Unix.rename oldname newname with
 171     Unix_error(EXDEV,_,_) ->
 172 (* renaming is not enough, we must COPY *)
 173       lprintf_nl "COPY %s TO %s" oldname newname;
 174       let copied = ref false in
 175       try
 176         copy oldname newname;
 177         copied := true;
 178         Sys.remove oldname
 179       with
 180         e ->
 181           if not !copied then
 182             Sys.remove newname
 183
 184 external c_seek64 : Unix.file_descr -> int64 -> Unix.seek_command -> int64 =
 185   "unix_lseek_64"
 186 external c_getsize64 : string -> int64 = "ml_getsize64"
 187 external c_getfdsize64 : Unix.file_descr -> int64 = "ml_getfdsize64"
 188 (* c_ftruncate64 sets size, optionally using a sparse file *)
 189 external c_ftruncate64 : Unix.file_descr -> int64 -> bool -> unit =
 190   "mld_ftruncate_64"
 191 external c_getdtablesize : unit -> int = "ml_getdtablesize"
 192 external c_sizeofoff_t : unit -> int = "ml_sizeofoff_t"
 193
 194 external endianness : unit -> string = "ml_check_endianness"
 195
 196 let rec remove_all_directory dirname =
 197   let files = list_directory dirname in
 198   List.iter (fun file ->
 199       let filename = Filename.concat dirname file in
 200       if is_directory filename then
 201         remove_all_directory filename
 202       else
 203         Sys.remove filename
 204   ) files;
 205   Unix.rmdir dirname
 206
 207 let random () =
 208   let s = String.create 7 in
 209   for i = 0 to 6 do
 210     s.[i] <- char_of_int (97 + Random.int 26)
 211   done;
 212   s
 213
 214 let can_write_to_directory dirname =
 215   let temp_file = Filename.concat dirname "tmp_" ^ random () ^ "_mld.tmp" in
 216   let check () = with_remove temp_file (fun _ ->
 217     tryopen_openfile temp_file [O_WRONLY; O_CREAT] 0o600 (fun fd ->
 218       let test_string = "mldonkey accesstest - this file can be deleted\n" in
 219       really_write fd test_string 0 (String.length test_string)))
 220   in
 221   try
 222     check ()
 223   with
 224   | Unix.Unix_error (Unix.EACCES, _, _) ->
 225       lprintf_nl "can not create files in directory %s, check rights..." dirname;
 226       exit 73
 227   | Unix.Unix_error (Unix.ENOSPC,_,_) ->
 228       lprintf_nl "directory %s is full..." dirname;
 229   | Unix.Unix_error (Unix.ENOENT, _, _) ->
 230       (try
 231         safe_mkdir dirname;
 232         check ()
 233       with _ ->
 234         lprintf_nl "%s does not exist and can not be created,  exiting..." dirname;
 235         exit 73)
 236   | Unix.Unix_error (error, func, what) ->
 237       lprintf_nl "%s(%s) : %s for directory %s" func what (error_message error) dirname;
 238       exit 73
 239   | e ->
 240       lprintf_nl "%s for directory %s" (Printexc2.to_string e) dirname;
 241       exit 73
 242
 243 (** The resource type to query or set with [getrlimit] or [setrlimit] *)
 244 type rlimit_resource = RLIMIT_CPU (** CPU time in seconds *)
 245                        | RLIMIT_FSIZE (** Maximum file size *)
 246                        | RLIMIT_DATA (** Max data size *)
 247                        | RLIMIT_STACK (** Max stack size *)
 248                        | RLIMIT_CORE (** Max core file size *)
 249                        | RLIMIT_RSS (** Max resident set size *)
 250                        | RLIMIT_NPROF (** Max number of processes *)
 251                        | RLIMIT_NOFILE (** Max number of open files *)
 252                        | RLIMIT_MEMLOCK (** Max locked-in-memory address space *)
 253                        | RLIMIT_AS (** Address space limit *)
 254
 255 type rlimit = {
 256   rlim_cur: int;
 257   rlim_max: int
 258 }
 259
 260 let dummy_rlimit = {
 261   rlim_cur = -1;
 262   rlim_max = -1
 263 }
 264
 265 external getrlimit: rlimit_resource -> rlimit = "ml_getrlimit"
 266 external setrlimit: rlimit_resource -> rlimit -> unit = "ml_setrlimit"
 267
 268 let ml_getrlimit resource =
 269   try
 270     getrlimit resource
 271   with _ -> dummy_rlimit
 272
 273 let ml_setrlimit resource n =
 274   let new_rlimit = {
 275     rlim_cur = n;
 276     rlim_max = n
 277   } in
 278   try
 279     setrlimit resource new_rlimit
 280   with _ -> ()
 281
 282 external fsync : Unix.file_descr -> unit = "ml_fsync"
 283