[Unison-hackers] [unison-svn] r427 - in trunk/src: . system system/win
vouillon@seas.upenn.edu
vouillon at seas.upenn.edu
Thu Apr 1 15:52:57 EDT 2010
Author: vouillon
Date: 2010-04-01 15:52:57 -0400 (Thu, 01 Apr 2010)
New Revision: 427
Modified:
trunk/src/.depend
trunk/src/RECENTNEWS
trunk/src/files.ml
trunk/src/fingerprint.ml
trunk/src/fs.ml
trunk/src/fs.mli
trunk/src/mkProjectInfo.ml
trunk/src/os.ml
trunk/src/path.ml
trunk/src/system/system_generic.ml
trunk/src/system/system_intf.ml
trunk/src/system/system_win.ml
trunk/src/system/win/system_impl.ml
trunk/src/test.ml
trunk/src/uigtk2.ml
trunk/src/update.ml
Log:
* Remove '.' entries in paths.; do not allow '..'.
* Some clean-up
Modified: trunk/src/.depend
===================================================================
--- trunk/src/.depend 2010-03-29 22:03:43 UTC (rev 426)
+++ trunk/src/.depend 2010-04-01 19:52:57 UTC (rev 427)
@@ -8,7 +8,8 @@
copy.cmi: uutil.cmi props.cmi path.cmi osx.cmi os.cmi lwt/lwt.cmi fspath.cmi \
fileinfo.cmi common.cmi
external.cmi: lwt/lwt.cmi
-fileinfo.cmi: system.cmi props.cmi path.cmi osx.cmi fspath.cmi
+fileinfo.cmi: system.cmi props.cmi ubase/prefs.cmi path.cmi osx.cmi \
+ fspath.cmi
files.cmi: uutil.cmi system.cmi props.cmi path.cmi lwt/lwt_util.cmi \
lwt/lwt.cmi common.cmi
fileutil.cmi:
@@ -280,15 +281,15 @@
update.cmo: xferhint.cmi uutil.cmi ubase/util.cmi tree.cmi ubase/trace.cmi \
system.cmi ubase/safelist.cmi remote.cmi props.cmi ubase/proplist.cmi \
ubase/prefs.cmi pred.cmi path.cmi osx.cmi os.cmi name.cmi ubase/myMap.cmi \
- lwt/lwt_unix.cmi lwt/lwt.cmi lock.cmi globals.cmi fspath.cmi fs.cmi \
- fpcache.cmi fingerprint.cmi fileinfo.cmi common.cmi case.cmi update.cmi
+ lwt/lwt_unix.cmi lwt/lwt.cmi lock.cmi globals.cmi fspath.cmi fpcache.cmi \
+ fingerprint.cmi fileinfo.cmi common.cmi case.cmi update.cmi
update.cmx: xferhint.cmx uutil.cmx ubase/util.cmx tree.cmx ubase/trace.cmx \
system.cmx ubase/safelist.cmx remote.cmx props.cmx ubase/proplist.cmx \
ubase/prefs.cmx pred.cmx path.cmx osx.cmx os.cmx name.cmx ubase/myMap.cmx \
- lwt/lwt_unix.cmx lwt/lwt.cmx lock.cmx globals.cmx fspath.cmx fs.cmx \
- fpcache.cmx fingerprint.cmx fileinfo.cmx common.cmx case.cmx update.cmi
-uutil.cmo: ubase/util.cmi ubase/trace.cmi ubase/projectInfo.cmo uutil.cmi
-uutil.cmx: ubase/util.cmx ubase/trace.cmx ubase/projectInfo.cmx uutil.cmi
+ lwt/lwt_unix.cmx lwt/lwt.cmx lock.cmx globals.cmx fspath.cmx fpcache.cmx \
+ fingerprint.cmx fileinfo.cmx common.cmx case.cmx update.cmi
+uutil.cmo: ubase/util.cmi ubase/trace.cmi uutil.cmi
+uutil.cmx: ubase/util.cmx ubase/trace.cmx uutil.cmi
xferhint.cmo: ubase/util.cmi ubase/trace.cmi ubase/prefs.cmi path.cmi os.cmi \
fspath.cmi xferhint.cmi
xferhint.cmx: ubase/util.cmx ubase/trace.cmx ubase/prefs.cmx path.cmx os.cmx \
@@ -305,16 +306,14 @@
system/system_generic.cmx:
system/system_intf.cmo:
system/system_intf.cmx:
-system/system_win.cmo: unicode.cmi ubase/rx.cmi
-system/system_win.cmx: unicode.cmx ubase/rx.cmx
+system/system_win.cmo: unicode.cmi system/system_generic.cmo ubase/rx.cmi
+system/system_win.cmx: unicode.cmx system/system_generic.cmx ubase/rx.cmx
ubase/myMap.cmo: ubase/myMap.cmi
ubase/myMap.cmx: ubase/myMap.cmi
ubase/prefs.cmo: ubase/util.cmi ubase/uarg.cmi system.cmi ubase/safelist.cmi \
ubase/prefs.cmi
ubase/prefs.cmx: ubase/util.cmx ubase/uarg.cmx system.cmx ubase/safelist.cmx \
ubase/prefs.cmi
-ubase/projectInfo.cmo:
-ubase/projectInfo.cmx:
ubase/proplist.cmo: ubase/util.cmi ubase/proplist.cmi
ubase/proplist.cmx: ubase/util.cmx ubase/proplist.cmi
ubase/rx.cmo: ubase/rx.cmi
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2010-03-29 22:03:43 UTC (rev 426)
+++ trunk/src/RECENTNEWS 2010-04-01 19:52:57 UTC (rev 427)
@@ -1,5 +1,11 @@
CHANGES FROM VERSION 2.40.16
+* Remove '.' entries in paths.; do not allow '..'.
+* Some clean-up
+
+-------------------------------
+CHANGES FROM VERSION 2.40.16
+
* Fix Not_found error when no archives are found (recently introduced bug).
-------------------------------
Modified: trunk/src/files.ml
===================================================================
--- trunk/src/files.ml 2010-03-29 22:03:43 UTC (rev 426)
+++ trunk/src/files.ml 2010-04-01 19:52:57 UTC (rev 427)
@@ -675,9 +675,9 @@
let dirh = System.opendir dir in
let files = ref [] in
begin try
- while true do files := System.readdir dirh :: !files done
+ while true do files := dirh.System.readdir () :: !files done
with End_of_file ->
- System.closedir dirh
+ dirh.System.closedir ()
end;
Sort.list (<) !files
Modified: trunk/src/fingerprint.ml
===================================================================
--- trunk/src/fingerprint.ml 2010-03-29 22:03:43 UTC (rev 426)
+++ trunk/src/fingerprint.ml 2010-04-01 19:52:57 UTC (rev 427)
@@ -26,7 +26,7 @@
let f = Fspath.concat fspath path in
Util.convertUnixErrorsToTransient
("digesting " ^ Fspath.toPrintString f)
- (fun () -> Fs.digestFile f)
+ (fun () -> Fs.fingerprint f)
let maxLength = Uutil.Filesize.ofInt max_int
let subfile path offset len =
Modified: trunk/src/fs.ml
===================================================================
--- trunk/src/fs.ml 2010-03-29 22:03:43 UTC (rev 426)
+++ trunk/src/fs.ml 2010-04-01 19:52:57 UTC (rev 427)
@@ -19,6 +19,7 @@
type fspath = Fspath.t
type dir_handle = System.dir_handle
+ = { readdir : unit -> string; closedir : unit -> unit }
let symlink l f = System.symlink l (Fspath.toString f)
@@ -44,12 +45,8 @@
let openfile f flags perms = System.openfile (Fspath.toString f) flags perms
-let opendir f = System.opendir (Fspath.toString f)
+let opendir f : dir_handle = System.opendir (Fspath.toString f)
-let readdir = System.readdir
-
-let closedir = System.closedir
-
let open_in_gen flags mode f =
System.open_in_gen flags mode (Fspath.toString f)
@@ -68,11 +65,7 @@
(****)
-let digestFile f =
- let ic = open_in_bin f in
- let d = Digest.channel ic (-1) in
- close_in ic;
- d
+let fingerprint f = System.fingerprint (Fspath.toString f)
let canSetTime f = System.canSetTime (Fspath.toString f)
let hasInodeNumbers () = System.hasInodeNumbers ()
Modified: trunk/src/fs.mli
===================================================================
--- trunk/src/fs.mli 2010-03-29 22:03:43 UTC (rev 426)
+++ trunk/src/fs.mli 2010-04-01 19:52:57 UTC (rev 427)
@@ -5,6 +5,4 @@
include System_intf.Core with type fspath = Fspath.t
-val digestFile : Fspath.t -> string
-
val setUnicodeEncoding : bool -> unit
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2010-03-29 22:03:43 UTC (rev 426)
+++ trunk/src/mkProjectInfo.ml 2010-04-01 19:52:57 UTC (rev 427)
@@ -106,3 +106,5 @@
+
+
Modified: trunk/src/os.ml
===================================================================
--- trunk/src/os.ml 2010-03-29 22:03:43 UTC (rev 426)
+++ trunk/src/os.ml 2010-04-01 19:52:57 UTC (rev 427)
@@ -61,7 +61,7 @@
"scanning directory"
(fun () ->
let rec loop children directory =
- let newFile = try Fs.readdir directory with End_of_file -> "" in
+ let newFile = try directory.Fs.readdir () with End_of_file -> "" in
if newFile = "" then children else
let newChildren =
if newFile = "." || newFile = ".." then
@@ -85,11 +85,11 @@
Some directory ->
begin try
let result = loop [] directory in
- Fs.closedir directory;
+ directory.Fs.closedir ();
result
with Unix.Unix_error _ as e ->
begin try
- Fs.closedir directory
+ directory.Fs.closedir ()
with Unix.Unix_error _ -> () end;
raise e
end
Modified: trunk/src/path.ml
===================================================================
--- trunk/src/path.ml 2010-03-29 22:03:43 UTC (rev 426)
+++ trunk/src/path.ml 2010-04-01 19:52:57 UTC (rev 427)
@@ -146,6 +146,7 @@
loop "c:/foo" -> ["c:"; "foo"]
*)
let fromString str =
+ let str0 = str in
let str = if Util.osType = `Win32 then Fileutil.backslashes2forwardslashes str else str in
if is_absolute str then
raise (Util.Transient
@@ -156,14 +157,25 @@
try
let pos = String.index str pathSeparatorChar in
let name1 = String.sub str 0 pos in
+ if name1 = ".." then
+ raise (Util.Transient
+ (Printf.sprintf
+ "Reference to parent directory '..' not allowed \
+ in path '%s'" str0));
let str_res =
String.sub str (pos + 1) (String.length str - pos - 1) in
- if pos = 0 then begin
+ if pos = 0 || name1 = "." then begin
loop p str_res
end else
loop (child p (Name.fromString name1)) str_res
with
- Not_found -> child p (Name.fromString str)
+ Not_found ->
+ if str = ".." then
+ raise (Util.Transient
+ (Printf.sprintf
+ "Reference to parent directory '..' not allowed \
+ in path '%s'" str0));
+ if str = "." then p else child p (Name.fromString str)
| Invalid_argument _ ->
raise(Invalid_argument "Path.fromString") in
loop empty str
Modified: trunk/src/system/system_generic.ml
===================================================================
--- trunk/src/system/system_generic.ml 2010-03-29 22:03:43 UTC (rev 426)
+++ trunk/src/system/system_generic.ml 2010-04-01 19:52:57 UTC (rev 427)
@@ -34,7 +34,7 @@
(****)
-type dir_handle = Unix.dir_handle
+type dir_handle = { readdir : unit -> string; closedir : unit -> unit }
let stat = Unix.LargeFile.stat
let lstat = Unix.LargeFile.lstat
@@ -49,7 +49,11 @@
let utimes = Unix.utimes
let link = Unix.link
let openfile = Unix.openfile
-let opendir = Unix.opendir
+let opendir f =
+ let h = Unix.opendir f in
+ { readdir = (fun () -> Unix.readdir h);
+ closedir = (fun () -> Unix.closedir h) }
+
let readdir = Unix.readdir
let closedir = Unix.closedir
let readlink = Unix.readlink
@@ -107,3 +111,11 @@
Unix.tcsetattr Unix.stdin Unix.TCSANOW newState);
startReading = (fun () -> ());
stopReading = (fun () -> ()) }
+
+(****)
+
+let fingerprint f =
+ let ic = open_in_bin f in
+ let d = Digest.channel ic (-1) in
+ close_in ic;
+ d
Modified: trunk/src/system/system_intf.ml
===================================================================
--- trunk/src/system/system_intf.ml 2010-03-29 22:03:43 UTC (rev 426)
+++ trunk/src/system/system_intf.ml 2010-04-01 19:52:57 UTC (rev 427)
@@ -18,7 +18,7 @@
module type Core = sig
type fspath
-type dir_handle
+type dir_handle = { readdir : unit -> string; closedir : unit -> unit }
val symlink : string -> fspath -> unit
val readlink : fspath -> string
@@ -32,8 +32,6 @@
val stat : fspath -> Unix.LargeFile.stats
val lstat : fspath -> Unix.LargeFile.stats
val opendir : fspath -> dir_handle
-val readdir : dir_handle -> string
-val closedir : dir_handle -> unit
val openfile :
fspath -> Unix.open_flag list -> Unix.file_perm -> Unix.file_descr
@@ -42,10 +40,10 @@
val open_out_gen : open_flag list -> int -> fspath -> out_channel
val open_in_bin : fspath -> in_channel
val file_exists : fspath -> bool
+val fingerprint : fspath -> Digest.t
(****)
-
val canSetTime : fspath -> bool
val hasInodeNumbers : unit -> bool
Modified: trunk/src/system/system_win.ml
===================================================================
--- trunk/src/system/system_win.ml 2010-03-29 22:03:43 UTC (rev 426)
+++ trunk/src/system/system_win.ml 2010-04-01 19:52:57 UTC (rev 427)
@@ -97,9 +97,8 @@
(****)
type dir_entry = Dir_empty | Dir_read of string | Dir_toread
-type dir_handle = Unix.dir_handle
-type dir_handle' =
- { handle : int; mutable entry_read: dir_entry }
+type dir_handle = System_generic.dir_handle
+ = { readdir : unit -> string; closedir : unit -> unit }
external stat_impl : string -> string -> Unix.LargeFile.stats = "win_stat"
external rmdir_impl : string -> string -> unit = "win_rmdir"
@@ -143,28 +142,27 @@
let badFileRx = Rx.rx ".*[?*].*"
-let ud : dir_handle' -> dir_handle = Obj.magic
-let du : dir_handle -> dir_handle' = Obj.magic
-
let opendir d =
if Rx.match_string badFileRx d then
raise (Unix.Unix_error (Unix.ENOENT, "opendir", d));
- try
- let (first_entry, handle) = findfirst (epath (fspathConcat d "*")) in
- ud { handle = handle; entry_read = Dir_read first_entry }
- with End_of_file ->
- ud { handle = 0; entry_read = Dir_empty }
-let readdir d =
- let d = du d in
- match d.entry_read with
- Dir_empty -> raise End_of_file
- | Dir_read name -> d.entry_read <- Dir_toread; path8 name
- | Dir_toread -> path8 (findnext d.handle)
-let closedir d =
- let d = du d in
- match d.entry_read with
- Dir_empty -> ()
- | _ -> findclose d.handle
+ let (handle, entry_read) =
+ try
+ let (first_entry, handle) = findfirst (epath (fspathConcat d "*")) in
+ (handle, ref (Dir_read first_entry))
+ with End_of_file ->
+ (0, ref Dir_empty)
+ in
+ { readdir =
+ (fun () ->
+ match !entry_read with
+ Dir_empty -> raise End_of_file
+ | Dir_read name -> entry_read := Dir_toread; path8 name
+ | Dir_toread -> path8 (findnext handle));
+ closedir =
+ (fun () ->
+ match !entry_read with
+ Dir_empty -> ()
+ | _ -> findclose handle) }
let rec conv_flags fl =
match fl with
@@ -338,4 +336,12 @@
startReading = (fun () -> setConsoleMode 0x18);
stopReading = (fun () -> setConsoleMode 0x19) }
+(****)
+
+let fingerprint f =
+ let ic = open_in_bin f in
+ let d = Digest.channel ic (-1) in
+ close_in ic;
+ d
+
end
Modified: trunk/src/system/win/system_impl.ml
===================================================================
--- trunk/src/system/win/system_impl.ml 2010-03-29 22:03:43 UTC (rev 426)
+++ trunk/src/system/win/system_impl.ml 2010-04-01 19:52:57 UTC (rev 427)
@@ -35,7 +35,8 @@
let fspathConcat v1 v2 = c2 W.fspathConcat G.fspathConcat v1 v2
let fspathDirname v = c1 W.fspathDirname G.fspathDirname v
- type dir_handle = Unix.dir_handle
+ type dir_handle = G.dir_handle
+ = { readdir : unit -> string; closedir : unit -> unit }
let symlink v1 v2 = c2 W.symlink G.symlink v1 v2
let readlink v = c1 W.readlink G.readlink v
@@ -49,14 +50,13 @@
let stat v = c1 W.stat G.stat v
let lstat v = c1 W.lstat G.lstat v
let opendir v = c1 W.opendir G.opendir v
- let readdir v = c1 W.readdir G.readdir v
- let closedir v = c1 W.closedir G.closedir v
let openfile v1 v2 v3 = c3 W.openfile G.openfile v1 v2 v3
let open_in_gen v1 v2 v3 = c3 W.open_in_gen G.open_in_gen v1 v2 v3
let open_out_gen v1 v2 v3 = c3 W.open_out_gen G.open_out_gen v1 v2 v3
let getcwd v = c1 W.getcwd G.getcwd v
let chdir v = c1 W.chdir G.chdir v
let readlink v = c1 W.readlink G.readlink v
+ let fingerprint v = c1 W.fingerprint G.fingerprint v
let canSetTime v = c1 W.canSetTime G.canSetTime v
let hasInodeNumbers v = c1 W.hasInodeNumbers G.hasInodeNumbers v
Modified: trunk/src/test.ml
===================================================================
--- trunk/src/test.ml 2010-03-29 22:03:43 UTC (rev 426)
+++ trunk/src/test.ml 2010-04-01 19:52:57 UTC (rev 427)
@@ -30,7 +30,7 @@
if s.Unix.LargeFile.st_kind = Unix.S_DIR then begin
let handle = Fs.opendir d in
let rec loop () =
- let r = try Some(Fs.readdir handle) with End_of_file -> None in
+ let r = try Some(handle.Fs.readdir ()) with End_of_file -> None in
match r with
| Some f ->
if f="." || f=".." then loop ()
@@ -39,7 +39,7 @@
loop ()
end
| None ->
- Fs.closedir handle;
+ handle.Fs.closedir ();
Fs.rmdir d
in loop ()
end else
@@ -88,13 +88,13 @@
let d = Fs.opendir d in
let rec do_read acc =
try
- (match (Fs.readdir d) with
+ (match (d.Fs.readdir ()) with
| s when Safelist.mem s ignored -> do_read acc
| f -> do_read (f :: acc))
with End_of_file -> acc
in
let files = do_read [] in
- Fs.closedir d;
+ d.Fs.closedir ();
files
let extend p file = Fspath.concat p (Path.fromString file)
Modified: trunk/src/uigtk2.ml
===================================================================
--- trunk/src/uigtk2.ml 2010-03-29 22:03:43 UTC (rev 426)
+++ trunk/src/uigtk2.ml 2010-04-01 19:52:57 UTC (rev 427)
@@ -1447,7 +1447,7 @@
GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT
~text:"Select the following option if one of your \
directory is on a FAT partition. This is typically \
- the case for a USB key."
+ the case for a USB stick."
~packing:(vb#pack ~expand:false) ()
in
adjustSize fatLabel;
Modified: trunk/src/update.ml
===================================================================
--- trunk/src/update.ml 2010-03-29 22:03:43 UTC (rev 426)
+++ trunk/src/update.ml 2010-04-01 19:52:57 UTC (rev 427)
@@ -703,7 +703,7 @@
(* If the archive is not in a stable state, we need to
perform archive recovery. So, the optimistic loading
fails. *)
- Sys.file_exists newArcName
+ System.file_exists (Os.fileInUnisonDir newArcName)
||
let (lockFilename, _) = archiveName fspath Lock in
let lockFile = Os.fileInUnisonDir lockFilename in
@@ -944,7 +944,7 @@
"The archive file is missing on some hosts.";
"For safety, the remaining copies should be deleted."]
@ whatToDo @
- ["Please delete archive files as appropriate and try again\n";
+ ["Please delete archive files as appropriate and try again";
"or invoke Unison with -ignorearchives flag."]))))
else begin
foundArchives := false;
More information about the Unison-hackers
mailing list