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 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
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
Gzip.close_in fn f
56 let tryopen_write_gzip ?level fn f
=
57 tryopen (Gzip.open_out ?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
63 let list_directory filename
=
65 tryopen_dir filename
(fun dir
->
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
74 with End_of_file
-> ());
77 let iter_directory f dirname
=
78 tryopen_dir dirname
(fun dir
->
81 let file = readdir dir
in
82 if file <> "." && file <> ".." then
83 f
(Filename.concat dirname
file)
85 with End_of_file
-> ())
87 let is_directory filename
=
88 try let s = Unix.LargeFile.stat filename
in s.LargeFile.st_kind
= S_DIR
with _
-> false
90 let is_link filename
=
91 try let s = Unix.LargeFile.lstat filename
in s.LargeFile.st_kind
= S_LNK
with _
-> false
97 lprintf_nl
"warning: chmod failed on %s: %s" f
(Printexc2.to_string e
)
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
)
107 tryopen_dir dir ignore
109 | Unix.Unix_error
(EACCES
, _
, _
) ->
110 lprintf_nl
"access denied for directory %s" dir
;
112 | Unix.Unix_error
(ENOENT
, _
, _
) ->
113 lprintf_nl
"directory %s not found, orphaned link?" dir
;
116 lprintf_nl
"error %s for directory %s" (Printexc2.to_string e
) dir
;
119 let predir = Filename.dirname dir
in
120 if predir <> dir
then safe_mkdir predir;
124 Unix.Unix_error
(EEXIST
, _
, _
) -> ()
125 | e
-> lprintf_nl
"error %s for directory %s" (Printexc2.to_string e
) dir
; exit
73
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"; *)
133 let nwrite = Unix.write fd
s pos len
in
134 if nwrite = 0 then raise End_of_file
else
136 really_write fd
s (pos
+ nwrite) (len
- nwrite)
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
142 really_read fd
s (pos
+ nread) (len
- nread)
144 let copy oldname newname
=
145 tryopen_read_bin oldname
(fun ic
->
147 try Some
(Unix.LargeFile.fstat
(Unix.descr_of_in_channel ic
)) with _
-> None
149 tryopen_write_bin newname
(fun oc
->
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;
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
176 copy oldname newname
;
184 external c_seek64
: Unix.file_descr
-> int64
-> Unix.seek_command
-> int64
=
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 =
191 external c_getdtablesize
: unit -> int = "ml_getdtablesize"
192 external c_sizeofoff_t
: unit -> int = "ml_sizeofoff_t"
194 external endianness
: unit -> string = "ml_check_endianness"
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
208 let s = String.create
7 in
210 s.[i
] <- char_of_int
(97 + Random.int 26)
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)))
224 | Unix.Unix_error
(Unix.EACCES
, _
, _
) ->
225 lprintf_nl
"can not create files in directory %s, check rights..." dirname
;
227 | Unix.Unix_error
(Unix.ENOENT
, _
, _
) ->
232 lprintf_nl
"%s does not exist and can not be created, exiting..." dirname
;
234 | Unix.Unix_error
(error
, func
, what
) ->
235 lprintf_nl
"%s(%s) : %s for directory %s" func what
(error_message error
) dirname
;
238 lprintf_nl
"%s for directory %s" (Printexc2.to_string e
) dirname
;
241 (** The resource type to query or set with [getrlimit] or [setrlimit] *)
242 type rlimit_resource
= RLIMIT_CPU
(** CPU time in seconds *)
243 | RLIMIT_FSIZE
(** Maximum file size *)
244 | RLIMIT_DATA
(** Max data size *)
245 | RLIMIT_STACK
(** Max stack size *)
246 | RLIMIT_CORE
(** Max core file size *)
247 | RLIMIT_RSS
(** Max resident set size *)
248 | RLIMIT_NPROF
(** Max number of processes *)
249 | RLIMIT_NOFILE
(** Max number of open files *)
250 | RLIMIT_MEMLOCK
(** Max locked-in-memory address space *)
251 | RLIMIT_AS
(** Address space limit *)
263 external getrlimit
: rlimit_resource
-> rlimit
= "ml_getrlimit"
264 external setrlimit
: rlimit_resource
-> rlimit
-> unit = "ml_setrlimit"
266 let ml_getrlimit resource
=
269 with _
-> dummy_rlimit
271 let ml_setrlimit resource
n =
277 setrlimit resource
new_rlimit
280 external fsync
: Unix.file_descr
-> unit = "ml_fsync"