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