1 (* Copyright 2001, 2002 b8_bavard, b8_fee_carabine, INRIA *)
3 This file is part of mldonkey.
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.
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.
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
23 let tryopen openf closef filename f
=
24 let descr = openf filename
in
29 (try closef
descr with _
-> ());
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
62 let list_directory filename
=
64 tryopen_dir filename
(fun dir
->
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
73 with End_of_file
-> ());
76 let iter_directory f dirname
=
77 tryopen_dir dirname
(fun dir
->
80 let file = readdir dir
in
81 if file <> "." && file <> ".." then
82 f
(Filename.concat dirname
file)
84 with End_of_file
-> ())
86 let is_directory filename
=
87 try let s = Unix.LargeFile.stat filename
in s.LargeFile.st_kind
= S_DIR
with _
-> false
89 let is_link filename
=
90 try let s = Unix.LargeFile.lstat filename
in s.LargeFile.st_kind
= S_LNK
with _
-> false
96 lprintf_nl
"warning: chmod failed on %s: %s" f
(Printexc2.to_string e
)
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
)
106 tryopen_dir dir ignore
108 | Unix.Unix_error
(EACCES
, _
, _
) ->
109 lprintf_nl
"access denied for directory %s" dir
;
111 | Unix.Unix_error
(ENOENT
, _
, _
) ->
112 lprintf_nl
"directory %s not found, orphaned link?" dir
;
115 lprintf_nl
"error %s for directory %s" (Printexc2.to_string e
) dir
;
118 let predir = Filename.dirname dir
in
119 if predir <> dir
then safe_mkdir predir;
123 Unix.Unix_error
(EEXIST
, _
, _
) -> ()
124 | e
-> lprintf_nl
"error %s for directory %s" (Printexc2.to_string e
) dir
; exit
73
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"; *)
132 let nwrite = Unix.write fd
s pos len
in
133 if nwrite = 0 then raise End_of_file
else
135 really_write fd
s (pos
+ nwrite) (len
- nwrite)
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
141 really_read fd
s (pos
+ nread) (len
- nread)
143 let copy oldname newname
=
144 tryopen_read_bin oldname
(fun ic
->
146 try Some
(Unix.LargeFile.fstat
(Unix.descr_of_in_channel ic
)) with _
-> None
148 tryopen_write_bin newname
(fun oc
->
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;
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
175 copy oldname newname
;
183 external c_seek64
: Unix.file_descr
-> int64
-> Unix.seek_command
-> int64
=
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 =
190 external c_getdtablesize
: unit -> int = "ml_getdtablesize"
191 external c_sizeofoff_t
: unit -> int = "ml_sizeofoff_t"
193 external endianness
: unit -> string = "ml_check_endianness"
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
207 let s = String.create
7 in
209 s.[i
] <- char_of_int
(97 + Random.int 26)
213 let can_write_to_directory dirname
=
214 let temp_file = Filename.concat dirname
"tmp_" ^
random () ^
"_mld.tmp" in
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))
223 | Unix.Unix_error
(Unix.EACCES
, _
, _
) ->
224 lprintf_nl
"can not create files in directory %s, check rights..." dirname
;
226 | Unix.Unix_error
(Unix.ENOENT
, _
, _
) ->
231 lprintf_nl
"%s does not exist and can not be created, exiting..." dirname
;
233 | Unix.Unix_error
(error
, func
, what
) ->
234 lprintf_nl
"%s(%s) : %s for directory %s" func what
(error_message error
) dirname
;
237 lprintf_nl
"%s for directory %s" (Printexc2.to_string e
) dirname
;
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 *)
262 external getrlimit
: rlimit_resource
-> rlimit
= "ml_getrlimit"
263 external setrlimit
: rlimit_resource
-> rlimit
-> unit = "ml_setrlimit"
265 let ml_getrlimit resource
=
268 with _
-> dummy_rlimit
270 let ml_setrlimit resource
n =
276 setrlimit resource
new_rlimit
279 external fsync
: Unix.file_descr
-> unit = "ml_fsync"