Initial .gitignore
[imt.git] / drive.ml
blob4f7ef53334d103906bb6644aceb3e8bde7b552d1
1 let drive_tbl = Array.create (Char.code 'z' - Char.code 'a' + 1) None
3 let root =
4 let rec loop i =
5 if i = Array.length drive_tbl
6 then
7 None
8 else
9 match drive_tbl.(i) with
10 | Some "" ->
11 Some (Char.chr (Char.code 'a' + i))
12 | _ ->
13 loop (succ i)
15 lazy (loop 0)
17 let get_root () =
18 Lazy.force_val root
20 let subst s =
21 let slen = String.length s in
22 if slen >= 3
23 then
24 if s.[1] = ':'
25 then
26 if s.[2] = '/'
27 then
28 let c = Char.lowercase s.[0] in
29 (* prerr_string "Drive "; *)
30 (* prerr_char c; *)
31 (* prerr_newline (); *)
32 let i = Char.code c - Char.code 'a' in
33 if i < Array.length drive_tbl
34 then
35 match drive_tbl.(i) with
36 | None ->
38 | Some d ->
39 let dlen = String.length d in
40 let r = String.create (slen - 2 + dlen) in
41 StringLabels.blit
42 ~src:d
43 ~src_pos:0
44 ~dst:r
45 ~dst_pos:0
46 ~len:dlen;
47 StringLabels.blit
48 ~src:s
49 ~src_pos:2
50 ~dst:r
51 ~dst_pos:dlen
52 ~len:(slen - 2);
54 else
55 begin
56 prerr_string "Drive.subst bogus drive ";
57 prerr_endline (String.escaped s);
59 end
60 else
61 begin
62 prerr_string "Drive.subst no slash ";
63 prerr_endline (String.escaped s);
65 end
66 else
68 else
71 let process_exn s = function
72 | Unix.Unix_error(code, fn_name, fn_arg) ->
73 prerr_string s;
74 prerr_string ": ";
75 prerr_string fn_name;
76 prerr_char '(';
77 if String.length fn_arg > 0
78 then
79 prerr_string fn_arg;
80 prerr_string "): ";
81 prerr_endline (Unix.error_message code)
82 | exn ->
83 prerr_string s;
84 prerr_string ": ";
85 prerr_endline (Printexc.to_string exn)
87 let process_dosdevices dir_path dir =
88 let get_path_drive win_path =
89 if String.length win_path = 2
90 then
91 if win_path.[1] = ':'
92 then
93 let c = Char.lowercase win_path.[0] in
94 if (c >= 'a' && c <= 'z')
95 then
96 Some c
97 else
98 None
99 else
100 None
101 else
102 None
105 let put_drive drive_letter unix_path =
106 let i = Char.code drive_letter - Char.code 'a' in
107 let l = String.length unix_path in
108 let drive_path =
109 if unix_path.[l - 1] = '/'
110 then
111 String.sub unix_path 0 (pred l)
112 else
113 unix_path
115 drive_tbl.(i) <- Some drive_path
118 let rec loop () =
119 let opt_s =
121 let s = Unix.readdir dir in
122 Some s
123 with
124 | End_of_file ->
125 (* prerr_endline "Drive(readdir): empty directory"; *)
126 None
128 match opt_s with
129 | None ->
131 | Some s ->
132 begin
133 match get_path_drive s with
134 | Some c ->
135 let opt_target =
137 Some (Unix.readlink (Filename.concat dir_path s))
138 with
139 | exn ->
140 process_exn
141 "Drive.process_dosdevices(loop:readlink)"
142 exn;
143 None
145 Utils.some_action (put_drive c) () opt_target
147 | None ->
149 end;
150 loop ()
153 loop ()
154 with
155 | exn ->
156 process_exn "Drive.process_dosdevices(loop:?)" exn
158 let init () =
159 if Wine.native
160 then
161 let _A = Char.code 'A' in
162 for i = 0 to pred (Array.length drive_tbl) do
163 let s = "_:" in
164 s.[0] <- Char.chr (i + _A);
165 drive_tbl.(i) <- Some s
166 done
167 else
168 let dir_path = Filename.concat Wine.root_path "dosdevices" in
169 let opt_dir =
171 Some (Unix.opendir dir_path)
172 with
173 | exn ->
174 process_exn "Drive.init" exn;
175 None
177 match opt_dir with
178 | None ->
179 prerr_endline "Can not establish drive mapping";
180 | Some dir ->
181 process_dosdevices dir_path dir;
182 begin
184 Unix.closedir dir
185 with
186 | exn ->
187 process_exn "Drive.init" exn;