drive.ml

   1 let drive_tbl = Array.create (Char.code 'z' - Char.code 'a' + 1) None
   2
   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)
  14   in
  15      lazy (loop 0)
  16
  17 let get_root () =
  18   Lazy.force_val root
  19
  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 ->
  37                     s
  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);
  53                       r
  54             else
  55               begin
  56                 prerr_string "Drive.subst bogus drive ";
  57                 prerr_endline (String.escaped s);
  58                 s
  59               end
  60         else
  61           begin
  62             prerr_string "Drive.subst no slash ";
  63             prerr_endline (String.escaped s);
  64             s
  65           end
  66       else
  67         s
  68     else
  69       s
  70
  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)
  86
  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
 103   in
 104
 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
 114     in
 115       drive_tbl.(i) <- Some drive_path
 116   in
 117
 118   let rec loop () =
 119     let opt_s =
 120       try
 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
 127     in
 128       match opt_s with
 129         | None ->
 130             ()
 131         | Some s ->
 132             begin
 133               match get_path_drive s with
 134                 | Some c ->
 135                     let opt_target =
 136                       try
 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
 144                     in
 145                       Utils.some_action (put_drive c) () opt_target
 146
 147                 | None ->
 148                     ()
 149             end;
 150             loop ()
 151   in
 152     try
 153       loop ()
 154     with
 155       | exn ->
 156           process_exn "Drive.process_dosdevices(loop:?)" exn
 157
 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 =
 170       try
 171         Some (Unix.opendir dir_path)
 172       with
 173         | exn ->
 174             process_exn "Drive.init" exn;
 175             None
 176     in
 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
 183               try
 184                 Unix.closedir dir
 185               with
 186                 | exn ->
 187                     process_exn "Drive.init" exn;
 188             end