src/utils/cdk/filename2.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 String2
  21
  22
  23 let win32 = Sys.os_type = "Win32"
  24 let slash = if win32 then '\\' else '/'
  25 let slash_s = String.make 1 slash
  26
  27 let normalize filename =
  28   let l = split filename slash in
  29   let is_absolute = match l with
  30       "" :: _ -> true
  31     | _ -> false
  32   in
  33   let rec iter l =
  34     match l with
  35       [] -> [], false
  36     | "" :: l -> iter l
  37     | "." :: l -> iter l
  38     | ".." :: l -> let l,_ = iter l in ("..":: l), false
  39     | _ :: ".." :: l ->
  40         let l,_ = iter l in l, true
  41     | x :: l ->
  42         let l, redo = iter l in if redo then iter (x :: l) else (x :: l), false
  43   in
  44   let l, _ = iter l in
  45   let l =
  46     if is_absolute then
  47       let rec iter_abs l =
  48         match l with
  49           ".." :: l -> iter_abs l
  50         | _ -> l
  51       in
  52       "" :: (iter_abs l)
  53     else l
  54   in
  55   let file = match l with
  56       [] -> "."
  57     | [""] -> slash_s
  58     | _ -> unsplit l slash
  59   in
  60 (*  if file <> filename then begin
  61       lprintf "[%s] normalized to [%s]" filename file; lprint_newline ();
  62     end; *)
  63   file
  64 ;;
  65
  66 let dirname name =
  67   let name = normalize name in
  68   try
  69     match String.rindex name slash with
  70       0 -> slash_s
  71     | n -> String.sub name 0 n
  72   with Not_found -> "."
  73
  74 let last_extension file =
  75   try
  76     let pos = String.rindex file '.' in
  77     let pos2 = try String.rindex file slash with Not_found -> 0 in
  78     if pos < pos2 then raise Not_found;
  79     String2.after file pos
  80   with Not_found -> ""
  81
  82 let last_extension2 file =
  83   try
  84     let pos = String.rindex file '.' in
  85     let pos2 = try String.rindex file slash with Not_found -> 0 in
  86     if pos < pos2 then raise Not_found;
  87     String2.after file (pos + 1)
  88   with Not_found -> ""
  89
  90 let extension file =
  91   try
  92     let pos2 = try String.rindex file slash with _ -> 0 in
  93     let pos = String.index_from file pos2 '.' in
  94     let len = String.length file in
  95     String.sub file pos (len -pos)
  96   with _ -> ""
  97
  98 let extensions file =
  99   let ext = extension file in
 100   let len = String.length ext in
 101   if len > 0 then
 102     String2.split_simplify (String.sub ext 1 (len-1)) '.'
 103   else []
 104
 105 let from_strings = ref []
 106 let to_strings = ref []
 107
 108 let register_conversions from_string to_string =
 109   from_strings := from_string :: !from_strings;
 110   to_strings := to_string :: !to_strings
 111
 112 let from_string filename =
 113   List.fold_left (fun file f -> f file) filename !from_strings
 114
 115 let to_string filename =
 116   List.fold_left (fun file f -> f file) filename !to_strings
 117
 118 let path_of_filename filename =
 119   let len = String.length filename in
 120   let filename = Bytes.of_string filename in
 121   for i = 0 to len - 1 do
 122     if Bytes.get filename i = '\\' then Bytes.set filename i '/';
 123   done;
 124   let filename =
 125     if len > 2 && Bytes.get filename 1 = ':' &&
 126       match Bytes.get filename 0 with
 127         'a' .. 'z' | 'A' .. 'Z' -> true
 128       | _ -> false then
 129       Printf.sprintf "%s/%s" (Bytes.sub_string filename 0 2)
 130       (Bytes.sub_string filename 2 (len-2))
 131     else Bytes.unsafe_to_string filename
 132   in
 133   split_simplify filename '/'
 134
 135 let basename filename =
 136   let rec iter list name =
 137     match list with [] -> name | name :: tail -> iter tail name
 138   in
 139   iter (path_of_filename filename) filename
 140
 141 let filesystem_compliant name fstype namemax =
 142   (* replace all illegal characters with a valid one.
 143      assumes all filesystems accept '_'s in filenames *)
 144   let escape_chars p filename =
 145     let s = Bytes.of_string filename in
 146     for i = 0 to String.length filename - 1 do
 147       if p (Bytes.get s i) then Bytes.set s i '_'
 148     done;
 149     Bytes.unsafe_to_string s
 150   in
 151
 152   (* remove all illegal characters at the beginning of filename *)
 153   let trim_left p filename =
 154     let len = String.length filename in
 155     let left =
 156       let rec aux i =
 157         if i < len && p filename.[i] then aux (i+1) else i in
 158       aux 0 in
 159     if left = 0 then filename
 160     else
 161       String.sub filename left (len - left) in
 162
 163   (* remove all illegal characters at the end of filename *)
 164   let trim_right p filename =
 165     let len = String.length filename in
 166     let right =
 167       let rec aux i =
 168         if i > 0 && p filename.[i-1] then aux (i-1) else i in
 169       aux len in
 170     if right = len then filename
 171     else
 172       String.sub filename 0 right in
 173
 174   let minimal_filter c =
 175     match c with
 176       | '/' | '\\' | '<' | '>' | '"' -> true
 177       | _ -> false in
 178
 179   let posix_compliant name =
 180     escape_chars minimal_filter name in
 181
 182   let windows_compliant name =
 183     (* http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/creating__deleting__and_maintaining_files.asp *)
 184     let windows_filter c =
 185       minimal_filter c ||
 186         match c with
 187           | '*' | '?' | '|' | ':' | '"' -> true
 188           | _ -> false in
 189
 190     (* Windows has additional restrictions:
 191        - filenames cannot start with a '.'
 192        - filenames cannot end with '.' or space *)
 193     let name = trim_left (fun c -> c = '.') name in
 194     let name = trim_right (fun c -> c = '.' || c = ' ') name in
 195     escape_chars windows_filter name in
 196
 197   let macosx_compliant name =
 198   (* ':' is directory seperator on Mac OS X: http://www.comentum.com/File-Systems-HFS-FAT-UFS.html *)
 199     let macosx_filter c =
 200       minimal_filter c || c = ':' in
 201     escape_chars macosx_filter name in
 202
 203   let sys_checked_name =
 204     match fstype with
 205     | `Win -> windows_compliant name
 206     | `Mac -> macosx_compliant name
 207     | `Posix
 208     | `Unknown -> posix_compliant name
 209   in
 210
 211   let fs_checked_name =
 212     let remove_last_spaces s =
 213       let len = String.length s in
 214       let rec aux n =
 215         if n = 0 then n
 216         else
 217           let n1 = n - 1 in
 218           if s.[n1] = ' ' then aux n1
 219           else n in
 220       let last_space = aux len in
 221       if last_space = len then s
 222       else String.sub s 0 last_space
 223     in
 224 (* FAT filesystems do not allow files with space as last char *)
 225     match fstype with
 226     | `Win -> remove_last_spaces sys_checked_name
 227     | _ -> sys_checked_name
 228   in
 229
 230   let length_checked_name =
 231     if namemax < 1 || String.length sys_checked_name < namemax then
 232       fs_checked_name
 233     else
 234       let ext = extension fs_checked_name in
 235         if String.length ext > namemax then
 236           String.sub fs_checked_name 0 namemax
 237         else
 238           String.sub fs_checked_name 0 (namemax - (String.length ext)) ^ ext
 239   in
 240   length_checked_name
 241
 242 let temp_dir_name () =
 243   try
 244     Sys.getenv "MLDONKEY_TEMP"
 245   with Not_found ->
 246 (* kept for compatibility with Filename.temp_dir_name, this code
 247    is never reached because $MLDONKEY_TEMP is filled in commonOptions.ml *)
 248   match Sys.os_type with
 249     | "Unix" | "Cygwin" ->
 250       (try Sys.getenv "TMPDIR" with Not_found -> "/tmp")
 251     | _ ->
 252       (try Sys.getenv "TEMP" with Not_found -> ".")
 253
 254 (* this code is copied from OCaml stdlib/filename.ml but
 255    extended to respect runtime changes to $MLDONKEY_TEMP,
 256    OCaml uses variable $TMPDIR/$TEMP instead *)
 257 external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
 258 external close_desc: int -> unit = "caml_sys_close"
 259
 260 let prng = Random.State.make_self_init ();;
 261
 262 let temp_file_name prefix suffix =
 263   let rnd = (Random.State.bits prng) land 0xFFFFFF in
 264   Filename.concat (temp_dir_name ()) (Printf.sprintf "%s%06x%s" prefix rnd suffix)
 265
 266 let temp_file prefix suffix =
 267   let rec try_name counter =
 268     let name = temp_file_name prefix suffix in
 269     try
 270       close_desc (open_desc name [Open_wronly; Open_creat; Open_excl] 0o600);
 271       name
 272     with Sys_error _ as e ->
 273       if counter >= 1000 then raise e else try_name (counter + 1)
 274   in try_name 0
 275
 276 let _ = (* some assertions on these functions *)
 277   assert (basename "c:\\Program Files\\Toto history.exe" = "Toto history.exe");
 278   assert (path_of_filename
 279       "c:\\Program Files\\Toto history.exe" =
 280     [ "c:"; "Program Files"; "Toto history.exe"] );
 281   assert (path_of_filename
 282       "/home/bidule/mldonkey folder/toto" =
 283     [ "home"; "bidule"; "mldonkey folder"; "toto"] );
 284   assert (path_of_filename
 285       "/home//bidule" = ["home"; "bidule"])
 286