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     | x :: ".." :: 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 rec 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 filename = String.copy filename in
 120   let len = String.length filename in
 121   for i = 0 to len - 1 do
 122     if filename.[i] = '\\' then filename.[i] <- '/';
 123   done;
 124   let filename =
 125     if len > 2 && filename.[1]  = ':' &&
 126       match filename.[0] with
 127         'a' .. 'z' | 'A' .. 'Z' -> true
 128       | _ -> false then
 129       Printf.sprintf "%s/%s" (String.sub filename 0 2)
 130       (String.sub filename 2 (len-2))
 131     else 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 fs 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 = String.copy filename in
 146     for i = 0 to String.length filename - 1 do
 147       if p s.[i] then s.[i] <- '_'
 148     done;
 149     s in
 150
 151   (* remove all illegal characters at the beginning of filename *)
 152   let trim_left p filename =
 153     let len = String.length filename in
 154     let left =
 155       let rec aux i =
 156         if i < len && p filename.[i] then aux (i+1) else i in
 157       aux 0 in
 158     if left = 0 then filename
 159     else
 160       String.sub filename left (len - left) in
 161
 162   (* remove all illegal characters at the end of filename *)
 163   let trim_right p filename =
 164     let len = String.length filename in
 165     let right =
 166       let rec aux i =
 167         if i > 0 && p filename.[i-1] then aux (i-1) else i in
 168       aux len in
 169     if right = len then filename
 170     else
 171       String.sub filename 0 right in
 172
 173   let minimal_filter c =
 174     match c with
 175       | '/' | '\\' | '<' | '>' | '"' -> true
 176       | _ -> false in
 177
 178   let posix_compliant name =
 179     escape_chars minimal_filter name in
 180
 181   let windows_compliant name =
 182     (* http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/creating__deleting__and_maintaining_files.asp *)
 183     let windows_filter c =
 184       minimal_filter c ||
 185         match c with
 186           | '*' | '?' | '|' | ':' | '"' -> true
 187           | _ -> false in
 188
 189     (* Windows has additional restrictions:
 190        - filenames cannot start with a '.'
 191        - filenames cannot end with '.' or space *)
 192     let name = trim_left (fun c -> c = '.') name in
 193     let name = trim_right (fun c -> c = '.' || c = ' ') name in
 194     escape_chars windows_filter name in
 195
 196   let macosx_compliant name =
 197   (* ':' is directory seperator on Mac OS X: http://www.comentum.com/File-Systems-HFS-FAT-UFS.html *)
 198     let macosx_filter c =
 199       minimal_filter c || c = ':' in
 200     escape_chars macosx_filter name in
 201
 202   let sys_checked_name =
 203     if Autoconf.windows then
 204       windows_compliant name
 205     else if Autoconf.system = "macos" then
 206       macosx_compliant name
 207     else
 208       posix_compliant name in
 209
 210   let fs_checked_name =
 211     let remove_last_spaces s =
 212       let len = String.length s in
 213       let rec aux n =
 214         if n = 0 then n
 215         else
 216           let n1 = n - 1 in
 217           if s.[n1] = ' ' then aux n1
 218           else n in
 219       let last_space = aux len in
 220       if last_space = len then s
 221       else String.sub s 0 last_space
 222     in
 223 (* FAT filesystems do not allow files with space as last char *)
 224     match fs with
 225       "msdos" -> remove_last_spaces sys_checked_name
 226     | _ -> sys_checked_name in
 227
 228   let length_checked_name =
 229     if namemax < 1 || String.length sys_checked_name < namemax then
 230       fs_checked_name
 231     else
 232       let ext = extension fs_checked_name in
 233         if String.length ext > namemax then
 234           String.sub fs_checked_name 0 namemax
 235         else
 236           String.sub fs_checked_name 0 (namemax - (String.length ext)) ^ ext
 237   in
 238   length_checked_name
 239
 240 let temp_dir_name () =
 241   try
 242     Sys.getenv "MLDONKEY_TEMP"
 243   with Not_found ->
 244 (* kept for compatibility with Filename.temp_dir_name, this code
 245    is never reached because $MLDONKEY_TEMP is filled in commonOptions.ml *)
 246   match Sys.os_type with
 247     | "Unix" | "Cygwin" ->
 248       (try Sys.getenv "TMPDIR" with Not_found -> "/tmp")
 249     | _ ->
 250       (try Sys.getenv "TEMP" with Not_found -> ".")
 251
 252 (* this code is copied from Ocaml stdlib/filename.ml but
 253    extended to respect runtime changes to $MLDONKEY_TEMP,
 254    Ocaml uses variable $TMPDIR/$TEMP instead *)
 255 external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
 256 external close_desc: int -> unit = "caml_sys_close"
 257
 258 let prng = Random.State.make_self_init ();;
 259
 260 let temp_file_name prefix suffix =
 261   let rnd = (Random.State.bits prng) land 0xFFFFFF in
 262   Filename.concat (temp_dir_name ()) (Printf.sprintf "%s%06x%s" prefix rnd suffix)
 263
 264 let temp_file prefix suffix =
 265   let rec try_name counter =
 266     let name = temp_file_name prefix suffix in
 267     try
 268       close_desc (open_desc name [Open_wronly; Open_creat; Open_excl] 0o600);
 269       name
 270     with Sys_error _ as e ->
 271       if counter >= 1000 then raise e else try_name (counter + 1)
 272   in try_name 0
 273
 274 let _ = (* some assertions on these functions *)
 275   assert (basename "c:\\Program Files\\Toto history.exe" = "Toto history.exe");
 276   assert (path_of_filename
 277       "c:\\Program Files\\Toto history.exe" =
 278     [ "c:"; "Program Files"; "Toto history.exe"] );
 279   assert (path_of_filename
 280       "/home/bidule/mldonkey folder/toto" =
 281     [ "home"; "bidule"; "mldonkey folder"; "toto"] );
 282   assert (path_of_filename
 283       "/home//bidule" = ["home"; "bidule"])
 284