uimacbridge.ml (27992B)
1 (* ML side of a bridge to C for the Mac GUI *) 2 3 open Common;; 4 open Lwt;; 5 6 let debug = Trace.debug "startup" 7 8 let unisonNonGuiStartup() = begin 9 (* If there's no GUI, don't print progress in the GUI *) 10 Uutil.setProgressPrinter (fun _ _ _ -> ()); 11 Main.nonGuiStartup() (* If this returns the GUI should be started *) 12 end;; 13 Callback.register "unisonNonGuiStartup" unisonNonGuiStartup;; 14 15 type stateItem = { mutable ri : reconItem; 16 mutable bytesTransferred : Uutil.Filesize.t; 17 mutable bytesToTransfer : Uutil.Filesize.t; 18 mutable whatHappened : Util.confirmation option; 19 mutable statusMessage : string option };; 20 let theState = ref [| |];; 21 let unsynchronizedPaths = ref None;; 22 23 let unisonDirectory() = Util.unisonDir 24 ;; 25 Callback.register "unisonDirectory" unisonDirectory;; 26 27 (* Global progress indicator, similar to uigtk2.m; *) 28 external displayGlobalProgress : float -> unit = "displayGlobalProgress";; 29 30 let totalBytesToTransfer = ref Uutil.Filesize.zero;; 31 let totalBytesTransferred = ref Uutil.Filesize.zero;; 32 33 let lastFrac = ref 0.;; 34 let showGlobalProgress b = 35 (* Concatenate the new message *) 36 totalBytesTransferred := Uutil.Filesize.add !totalBytesTransferred b; 37 let v = 38 if !totalBytesToTransfer = Uutil.Filesize.dummy then 0. 39 else if !totalBytesToTransfer = Uutil.Filesize.zero then 100. 40 else (Uutil.Filesize.percentageOfTotalSize 41 !totalBytesTransferred !totalBytesToTransfer) 42 in 43 if v = 0. || abs_float (v -. !lastFrac) > 1. then begin 44 lastFrac := v; 45 displayGlobalProgress v 46 end;; 47 48 let initGlobalProgress b = 49 totalBytesToTransfer := b; 50 totalBytesTransferred := Uutil.Filesize.zero; 51 displayGlobalProgress 0.;; 52 53 (* Defined in Bridge.m, used to redisplay the table 54 when the status for a row changes *) 55 external bridgeThreadWait : int -> unit = "bridgeThreadWait";; 56 57 (* Defined in MyController.m, used to redisplay the table 58 when the status for a row changes *) 59 external displayStatus : string -> unit = "displayStatus";; 60 let displayStatus s = displayStatus (Unicode.protect s);; 61 62 (* 63 Called to create callback threads which wait on the C side for callbacks. 64 (We create three just for good measure...) 65 66 FIXME: the thread created by Thread.create doesn't run even if we yield -- 67 we have to join. At that point we actually do get a different pthread, but 68 we've caused the calling thread to block (forever). As a result, this call 69 never returns. 70 *) 71 let callbackThreadCreate() = 72 let tCode () = 73 bridgeThreadWait 1; 74 in ignore (Thread.create tCode ()); ignore (Thread.create tCode ()); 75 let tid = Thread.create tCode () 76 in Thread.join tid; 77 ;; 78 Callback.register "callbackThreadCreate" callbackThreadCreate;; 79 80 (* Defined in MyController.m; display the error message and exit *) 81 external displayFatalError : string -> unit = "fatalError";; 82 83 let fatalError message = 84 let () = 85 try Trace.log (message ^ "\n") 86 with Util.Fatal _ -> () in (* Can't allow fatal errors in fatal error handler *) 87 displayFatalError message 88 89 (* Defined in MyController.m; display the warning and ask whether to 90 exit or proceed *) 91 external displayWarnPanel : string -> bool = "warnPanel";; 92 93 let setWarnPrinter() = 94 Util.warnPrinter := 95 Some(fun s -> 96 Trace.log ("Warning: " ^ s ^ "\n"); 97 if not (Prefs.read Globals.batch) then begin 98 if (displayWarnPanel s) then begin 99 Lwt_unix.run (Update.unlockArchives ()); 100 exit Uicommon.fatalExit 101 end 102 end) 103 104 let doInOtherThread f = 105 Thread.create 106 (fun () -> 107 try 108 f () 109 with 110 Util.Transient s | Util.Fatal s -> fatalError s 111 | exn -> fatalError (Uicommon.exn2string exn)) 112 () 113 114 (* Defined in MyController.m, used to redisplay the table 115 when the status for a row changes *) 116 external reloadTable : int -> unit = "reloadTable";; 117 (* from uigtk2 *) 118 let showProgress i bytes dbg = 119 (* Trace.status "showProgress"; *) 120 let i = Uutil.File.toLine i in 121 let item = !theState.(i) in 122 item.bytesTransferred <- Uutil.Filesize.add item.bytesTransferred bytes; 123 let b = item.bytesTransferred in 124 let len = item.bytesToTransfer in 125 let newstatus = 126 if b = Uutil.Filesize.zero || len = Uutil.Filesize.zero then "start " 127 else if len = Uutil.Filesize.zero then 128 Printf.sprintf "%5s " (Uutil.Filesize.toString b) 129 else Util.percent2string (Uutil.Filesize.percentageOfTotalSize b len) in 130 let oldstatus = item.statusMessage in 131 item.statusMessage <- Some newstatus; 132 showGlobalProgress bytes; 133 (* FIX: No status window in Mac version, see GTK version for how to do it *) 134 if oldstatus <> Some newstatus then reloadTable i;; 135 136 let unisonGetVersion() = Uutil.myVersion 137 ;; 138 Callback.register "unisonGetVersion" unisonGetVersion;; 139 140 (* snippets from Uicommon, duplicated for now *) 141 (* BCP: Duplicating this is a really bad idea!!! *) 142 143 (* First initialization sequence *) 144 (* Returns a string option: command line profile, if any *) 145 let unisonInit0() = 146 ignore (Gc.set {(Gc.get ()) with Gc.max_overhead = 150}); 147 (* Display status in GUI instead of on stderr *) 148 let formatStatus major minor = (Util.padto 30 (major ^ " ")) ^ minor in 149 Trace.messageDisplayer := displayStatus; 150 Trace.statusFormatter := formatStatus; 151 Trace.sendLogMsgsToStderr := false; 152 (* Display progress in GUI *) 153 Uutil.setProgressPrinter showProgress; 154 (* Initialise global progress so progress bar is not updated *) 155 initGlobalProgress Uutil.Filesize.dummy; 156 (* Make sure we have a directory for archives and profiles *) 157 Os.createUnisonDir(); 158 (* Extract any command line profile or roots *) 159 let clprofile = ref None in 160 begin 161 try 162 let args = Prefs.scanCmdLine Uicommon.usageMsg in 163 match Util.StringMap.find "rest" args with 164 [] -> () 165 | [profile] -> clprofile := Some profile 166 | [root2;root1] -> Globals.setRawRoots [root1;root2] 167 | [root2;root1;profile] -> 168 Globals.setRawRoots [root1;root2]; 169 clprofile := Some profile 170 | _ -> 171 (Printf.eprintf 172 "%s was invoked incorrectly (too many roots)" Uutil.myName; 173 exit 1) 174 with Not_found -> () 175 end; 176 (* Print header for debugging output *) 177 debug (fun() -> 178 Printf.eprintf "%s, version %s\n\n" Uutil.myName Uutil.myVersion); 179 debug (fun() -> Util.msg "initializing UI"); 180 debug (fun () -> 181 (match !clprofile with 182 None -> Util.msg "No profile given on command line" 183 | Some s -> Printf.eprintf "Profile '%s' given on command line" s); 184 (match Globals.rawRoots() with 185 [] -> Util.msg "No roots given on command line" 186 | [root1;root2] -> 187 Printf.eprintf "Roots '%s' and '%s' given on command line" 188 root1 root2 189 | _ -> assert false)); 190 begin match !clprofile with 191 None -> () 192 | Some n -> 193 let f = Prefs.profilePathname n in 194 if not(System.file_exists f) 195 then (Printf.eprintf "Profile %s does not exist" 196 f; 197 exit 1) 198 end; 199 !clprofile 200 ;; 201 Callback.register "unisonInit0" unisonInit0;; 202 203 (* Utility function to tell the UI whether roots were set *) 204 205 let areRootsSet () = 206 match Globals.rawRoots() with 207 | [] -> false 208 | _ -> true 209 ;; 210 Callback.register "areRootsSet" areRootsSet;; 211 212 (* Utility function to tell the UI whether -batch is set *) 213 214 let isBatchSet () = 215 Prefs.read Globals.batch 216 ;; 217 Callback.register "isBatchSet" isBatchSet;; 218 219 (* The first time we load preferences, we also read the command line 220 arguments; if we re-load prefs (because the user selected a new profile) 221 we ignore the command line *) 222 let firstTime = ref(true) 223 224 (* After figuring out the profile name. If the profileName is the empty 225 string, it means that only the roots were specified on the command 226 line *) 227 let do_unisonInit1 profileName = 228 (* Load the profile and command-line arguments *) 229 (* Restore prefs to their default values, if necessary *) 230 if not !firstTime then Prefs.resetToDefaults(); 231 unsynchronizedPaths := None; 232 233 if profileName <> "" then begin 234 (* Tell the preferences module the name of the profile *) 235 Prefs.profileName := Some(profileName); 236 237 (* If the profile does not exist, create an empty one (this should only 238 happen if the profile is 'default', since otherwise we will already 239 have checked that the named one exists). *) 240 if not(System.file_exists (Prefs.profilePathname profileName)) then 241 Prefs.addComment "Unison preferences file"; 242 243 (* Load the profile *) 244 (Trace.debug "" (fun() -> Util.msg "about to load prefs"); 245 Prefs.loadTheFile()) 246 end; 247 248 (* Parse the command line. This will temporarily override 249 settings from the profile. *) 250 if !firstTime then begin 251 Trace.debug "" (fun() -> Util.msg "about to parse command line"); 252 Prefs.parseCmdLine Uicommon.usageMsg; 253 end; 254 255 firstTime := false; 256 257 (* Print the preference settings *) 258 Trace.debug "" (fun() -> Prefs.dumpPrefsToStderr() ); 259 260 (* FIX: if no roots, ask the user *) 261 262 Recon.checkThatPreferredRootIsValid(); 263 264 let localRoots,remoteRoots = 265 Safelist.partition 266 (function Clroot.ConnectLocal _ -> true | _ -> false) 267 (Globals.parsedClRawRoots ()) in 268 269 match remoteRoots with 270 [r] -> 271 (* FIX: tell the user the next step (contacting server) might 272 take a while *) 273 Remote.openConnectionStart r 274 | _::_::_ -> 275 raise(Util.Fatal "cannot synchronize more than one remote root"); 276 | _ -> None 277 ;; 278 external unisonInit1Complete : Remote.preconnection option -> unit = "unisonInit1Complete";; 279 280 (* Do this in another thread and return immedidately to free up main thread in cocoa *) 281 let unisonInit1 profileName = 282 doInOtherThread 283 (fun () -> 284 let r = do_unisonInit1 profileName in 285 unisonInit1Complete r) 286 ;; 287 Callback.register "unisonInit1" unisonInit1;; 288 Callback.register "openConnectionPrompt" Remote.openConnectionPrompt;; 289 Callback.register "openConnectionReply" Remote.openConnectionReply;; 290 Callback.register "openConnectionEnd" Remote.openConnectionEnd;; 291 Callback.register "openConnectionCancel" Remote.openConnectionCancel;; 292 293 let commitUpdates () = 294 Trace.status "Updating synchronizer state"; 295 let t = Trace.startTimer "Updating synchronizer state" in 296 Update.commitUpdates(); 297 Trace.showTimer t 298 299 let do_unisonInit2 () = 300 (* Canonize the names of the roots and install them in Globals. *) 301 Globals.installRoots2(); 302 303 (* If both roots are local, disable the xferhint table to save time *) 304 begin match Globals.roots() with 305 ((Local,_),(Local,_)) -> Prefs.set Xferhint.xferbycopying false 306 | _ -> () 307 end; 308 309 (* If no paths were specified, then synchronize the whole replicas *) 310 if Prefs.read Globals.paths = [] then Prefs.set Globals.paths [Path.empty]; 311 312 (* Expand any "wildcard" paths [with final component *] *) 313 Globals.expandWildcardPaths(); 314 315 Update.storeRootsName (); 316 317 Trace.debug "" 318 (fun() -> 319 Printf.eprintf "Roots: \n"; 320 Safelist.iter (fun clr -> Printf.eprintf " %s\n" clr) 321 (Globals.rawRoots ()); 322 Printf.eprintf " i.e. \n"; 323 Safelist.iter (fun clr -> Printf.eprintf " %s\n" 324 (Clroot.clroot2string (Clroot.parseRoot clr))) 325 (Globals.rawRoots ()); 326 Printf.eprintf " i.e. (in canonical order)\n"; 327 Safelist.iter (fun r -> 328 Printf.eprintf " %s\n" (root2string r)) 329 (Globals.rootsInCanonicalOrder()); 330 Printf.eprintf "\n" 331 ); 332 333 (* Install the warning panel, hopefully it's not too late *) 334 setWarnPrinter(); 335 336 Lwt_unix.run 337 (Uicommon.validateAndFixupPrefs () >>= 338 Globals.propagatePrefs); 339 340 (* Initializes some backups stuff according to the preferences just loaded from the profile. 341 Important to do it here, after prefs are propagated, because the function will also be 342 run on the server, if any. Also, this should be done each time a profile is reloaded 343 on this side, that's why it's here. *) 344 Stasher.initBackups (); 345 346 (* Turn on GC messages, if the '-debug gc' flag was provided *) 347 if Trace.enabled "gc" then Gc.set {(Gc.get ()) with Gc.verbose = 0x3F}; 348 349 (* BCPFIX: Should/can this be done earlier?? *) 350 Files.processCommitLogs(); 351 352 (* from Uigtk2 *) 353 (* detect updates and reconcile *) 354 let _ = Globals.roots () in 355 let t = Trace.startTimer "Checking for updates" in 356 let findUpdates () = 357 Trace.status "Looking for changes"; 358 let updates = Update.findUpdates ~wantWatcher:true !unsynchronizedPaths in 359 Trace.showTimer t; 360 updates in 361 let reconcile updates = Recon.reconcileAll updates in 362 let (reconItemList, thereAreEqualUpdates, dangerousPaths) = 363 reconcile (findUpdates ()) in 364 if not !Update.foundArchives then commitUpdates (); 365 if reconItemList = [] then begin 366 if !Update.foundArchives then commitUpdates (); 367 if thereAreEqualUpdates then 368 Trace.status 369 "Replicas have been changed only in identical ways since last sync" 370 else 371 Trace.status "Everything is up to date" 372 end else 373 Trace.status "Check and/or adjust selected actions; then press Go"; 374 Trace.status (Printf.sprintf "There are %d reconitems" (Safelist.length reconItemList)); 375 let stateItemList = 376 Safelist.map 377 (fun ri -> { ri = ri; 378 bytesTransferred = Uutil.Filesize.zero; 379 bytesToTransfer = Uutil.Filesize.zero; 380 whatHappened = None; statusMessage = None }) 381 reconItemList in 382 theState := Array.of_list stateItemList; 383 unsynchronizedPaths := 384 Some (Safelist.map (fun ri -> ri.path1) reconItemList, []); 385 if dangerousPaths <> [] then begin 386 Prefs.set Globals.batch false; 387 Util.warn (Uicommon.dangerousPathMsg dangerousPaths) 388 end; 389 !theState 390 ;; 391 392 external unisonInit2Complete : stateItem array -> unit = "unisonInit2Complete";; 393 394 (* Do this in another thread and return immedidately to free up main thread in cocoa *) 395 let unisonInit2 () = 396 doInOtherThread 397 (fun () -> 398 let r = do_unisonInit2 () in 399 unisonInit2Complete r) 400 ;; 401 Callback.register "unisonInit2" unisonInit2;; 402 403 let unisonRiToDetails ri = 404 Unicode.protect 405 (match ri.whatHappened with 406 Some (Util.Failed s) -> 407 Path.toString ri.ri.path1 ^ "\n" ^ s 408 | _ -> 409 Path.toString ri.ri.path1 ^ "\n" ^ 410 Uicommon.details2string ri.ri " ");; 411 Callback.register "unisonRiToDetails" unisonRiToDetails;; 412 413 let unisonRiToPath ri = Unicode.protect (Path.toString ri.ri.path1);; 414 Callback.register "unisonRiToPath" unisonRiToPath;; 415 416 let rcToString rc = 417 match rc.status with 418 `Deleted -> "Deleted" 419 | `Modified -> "Modified" 420 | `PropsChanged -> "PropsChanged" 421 | `Created -> "Created" 422 | `Unchanged -> "";; 423 let unisonRiToLeft ri = 424 match ri.ri.replicas with 425 Problem _ -> "" 426 | Different {rc1 = rc} -> rcToString rc;; 427 Callback.register "unisonRiToLeft" unisonRiToLeft;; 428 let unisonRiToRight ri = 429 match ri.ri.replicas with 430 Problem _ -> "" 431 | Different {rc2 = rc} -> rcToString rc;; 432 Callback.register "unisonRiToRight" unisonRiToRight;; 433 434 let unisonRiToFileSize ri = 435 Uutil.Filesize.toFloat (riLength ri.ri);; 436 Callback.register "unisonRiToFileSize" unisonRiToFileSize;; 437 438 let unisonRiToFileType ri = 439 riFileType ri.ri;; 440 Callback.register "unisonRiToFileType" unisonRiToFileType;; 441 442 let direction2niceString = function (* from Uicommon where it's not exported *) 443 Conflict _ -> "<-?->" 444 | Replica1ToReplica2 -> "---->" 445 | Replica2ToReplica1 -> "<----" 446 | Merge -> "<-M->" 447 let unisonRiToDirection ri = 448 match ri.ri.replicas with 449 Problem _ -> "XXXXX" 450 | Different diff -> direction2niceString diff.direction;; 451 Callback.register "unisonRiToDirection" unisonRiToDirection;; 452 453 let unisonRiSetLeft ri = 454 match ri.ri.replicas with 455 Problem _ -> () 456 | Different diff -> diff.direction <- Replica2ToReplica1;; 457 Callback.register "unisonRiSetLeft" unisonRiSetLeft;; 458 let unisonRiSetRight ri = 459 match ri.ri.replicas with 460 Problem _ -> () 461 | Different diff -> diff.direction <- Replica1ToReplica2;; 462 Callback.register "unisonRiSetRight" unisonRiSetRight;; 463 let unisonRiSetConflict ri = 464 match ri.ri.replicas with 465 Problem _ -> () 466 | Different diff -> diff.direction <- Conflict "skip requested";; 467 Callback.register "unisonRiSetConflict" unisonRiSetConflict;; 468 let unisonRiSetMerge ri = 469 match ri.ri.replicas with 470 Problem _ -> () 471 | Different diff -> diff.direction <- Merge;; 472 Callback.register "unisonRiSetMerge" unisonRiSetMerge;; 473 let unisonRiForceOlder ri = 474 Recon.setDirection ri.ri `Older `Force;; 475 Callback.register "unisonRiForceOlder" unisonRiForceOlder;; 476 let unisonRiForceNewer ri = 477 Recon.setDirection ri.ri `Newer `Force;; 478 Callback.register "unisonRiForceNewer" unisonRiForceNewer;; 479 480 let unisonRiToProgress ri = 481 match (ri.statusMessage, ri.whatHappened,ri.ri.replicas) with 482 (None,None,_) -> "" 483 | (Some s,None,_) -> Unicode.protect s 484 | (_,_,Different {direction = Conflict "files differed"}) -> "" 485 | (_,_,Problem _) -> "" 486 | (_,Some Util.Succeeded,_) -> "done" 487 | (_,Some (Util.Failed s),_) -> "FAILED";; 488 Callback.register "unisonRiToProgress" unisonRiToProgress;; 489 490 let unisonRiToBytesTransferred ri = 491 Uutil.Filesize.toFloat ri.bytesTransferred;; 492 Callback.register "unisonRiToBytesTransferred" unisonRiToBytesTransferred;; 493 494 (* --------------------------------------------------- *) 495 496 (* Defined in MyController.m, used to show diffs *) 497 external displayDiff : string -> string -> unit = "displayDiff";; 498 external displayDiffErr : string -> unit = "displayDiffErr";; 499 let displayDiff title text = 500 displayDiff (Unicode.protect title) (Unicode.protect text);; 501 let displayDiffErr err = displayDiffErr (Unicode.protect err) 502 503 (* If only properties have changed, we can't diff or merge. 504 'Can't diff' is produced (uicommon.ml) if diff is attempted 505 when either side has PropsChanged *) 506 let filesAreDifferent status1 status2 = 507 match status1, status2 with 508 `PropsChanged, `Unchanged -> false 509 | `Unchanged, `PropsChanged -> false 510 | `PropsChanged, `PropsChanged -> false 511 | _, _ -> true;; 512 513 (* check precondition for diff; used to disable diff button *) 514 let canDiff ri = 515 match ri.ri.replicas with 516 Problem _ -> false 517 | Different {rc1 = {typ = `FILE; status = status1}; 518 rc2 = {typ = `FILE; status = status2}} -> 519 filesAreDifferent status1 status2 520 | Different _ -> false;; 521 Callback.register "canDiff" canDiff;; 522 523 (* from Uicommon *) 524 (* precondition: uc = File (Updates(_, ..) on both sides *) 525 let showDiffs ri printer errprinter id = 526 match ri.replicas with 527 Problem _ -> 528 errprinter 529 "Can't diff files: there was a problem during update detection" 530 | Different 531 {rc1 = {typ = `FILE; status = status1; ui = ui1}; 532 rc2 = {typ = `FILE; status = status2; ui = ui2}} -> 533 if filesAreDifferent status1 status2 then 534 (let (root1,root2) = Globals.roots() in 535 begin 536 try Files.diff root1 ri.path1 ui1 root2 ri.path2 ui2 printer id 537 with Util.Transient e -> errprinter e 538 end) 539 | Different _ -> 540 errprinter "Can't diff: path doesn't refer to a file in both replicas" 541 542 let runShowDiffs ri i = 543 let file = Uutil.File.ofLine i in 544 showDiffs ri.ri displayDiff displayDiffErr file;; 545 Callback.register "runShowDiffs" runShowDiffs;; 546 547 (* --------------------------------------------------- *) 548 549 let do_unisonSynchronize () = 550 if Array.length !theState = 0 then 551 Trace.status "Nothing to synchronize" 552 else begin 553 Trace.status "Propagating changes"; 554 Uicommon.transportStart (); 555 let totalLength = 556 Array.fold_left 557 (fun l si -> 558 si.bytesTransferred <- Uutil.Filesize.zero; 559 let len = 560 if si.whatHappened = None then Common.riLength si.ri else 561 Uutil.Filesize.zero 562 in 563 si.bytesToTransfer <- len; 564 Uutil.Filesize.add l len) 565 Uutil.Filesize.zero !theState in 566 initGlobalProgress totalLength; 567 let t = Trace.startTimer "Propagating changes" in 568 let uiWrapper i theSI = 569 match theSI.whatHappened with 570 None -> 571 catch (fun () -> 572 Transport.transportItem 573 theSI.ri (Uutil.File.ofLine i) 574 (fun title text -> 575 debug (fun () -> Util.msg "MERGE '%s': '%s'" 576 title text); 577 displayDiff title text; true) 578 >>= (fun () -> 579 return Util.Succeeded)) 580 (fun e -> 581 match e with 582 Util.Transient s -> 583 return (Util.Failed s) 584 | _ -> 585 fail e) 586 >>= (fun res -> 587 let rem = 588 Uutil.Filesize.sub 589 theSI.bytesToTransfer theSI.bytesTransferred 590 in 591 if rem <> Uutil.Filesize.zero then 592 showProgress (Uutil.File.ofLine i) rem "done"; 593 theSI.whatHappened <- Some res; 594 return ()) 595 | Some _ -> 596 return () (* Already processed this one (e.g. merged it) *) 597 in 598 Uicommon.transportItems !theState (fun {ri; _} -> not (Common.isDeletion ri)) uiWrapper; 599 Uicommon.transportItems !theState (fun {ri; _} -> Common.isDeletion ri) uiWrapper; 600 Uicommon.transportFinish (); 601 Trace.showTimer t; 602 commitUpdates (); 603 604 let failureList = 605 Array.fold_right 606 (fun si l -> 607 match si.whatHappened with 608 Some (Util.Failed err) -> 609 (si, [err], "transport failure") :: l 610 | _ -> 611 l) 612 !theState [] 613 in 614 let failureCount = List.length failureList in 615 let failures = 616 if failureCount = 0 then [] else 617 [Printf.sprintf "%d failure%s" 618 failureCount (if failureCount = 1 then "" else "s")] 619 in 620 let partialList = 621 Array.fold_right 622 (fun si l -> 623 match si.whatHappened with 624 Some Util.Succeeded 625 when partiallyProblematic si.ri && 626 not (problematic si.ri) -> 627 let errs = 628 match si.ri.replicas with 629 Different diff -> diff.errors1 @ diff.errors2 630 | _ -> assert false 631 in 632 (si, errs, 633 "partial transfer (errors during update detection)") :: l 634 | _ -> 635 l) 636 !theState [] 637 in 638 let partialCount = List.length partialList in 639 let partials = 640 if partialCount = 0 then [] else 641 [Printf.sprintf "%d partially transferred" partialCount] 642 in 643 let skippedList = 644 Array.fold_right 645 (fun si l -> 646 match si.ri.replicas with 647 Problem err -> 648 (si, [err], "error during update detection") :: l 649 | Different diff when (isConflict diff.direction) -> 650 (si, [], 651 if (isConflict diff.default_direction) then 652 "conflict" 653 else "skipped") :: l 654 | _ -> 655 l) 656 !theState [] 657 in 658 let skippedCount = List.length skippedList in 659 let skipped = 660 if skippedCount = 0 then [] else 661 [Printf.sprintf "%d skipped" skippedCount] 662 in 663 unsynchronizedPaths := 664 Some (Safelist.map (fun (si, _, _) -> si.ri.path1) 665 (failureList @ partialList @ skippedList), 666 []); 667 Trace.status 668 (Printf.sprintf "Synchronization complete %s" 669 (String.concat ", " (failures @ partials @ skipped))); 670 initGlobalProgress Uutil.Filesize.dummy; 671 end;; 672 external syncComplete : unit -> unit = "syncComplete";; 673 674 (* Do this in another thread and return immedidately to free up main thread in cocoa *) 675 let unisonSynchronize () = 676 doInOtherThread 677 (fun () -> 678 do_unisonSynchronize (); 679 syncComplete ()) 680 ;; 681 Callback.register "unisonSynchronize" unisonSynchronize;; 682 683 let unisonIgnorePath pathString = 684 Uicommon.addIgnorePattern (Uicommon.ignorePath (Path.fromString pathString));; 685 let unisonIgnoreExt pathString = 686 Uicommon.addIgnorePattern (Uicommon.ignoreExt (Path.fromString pathString));; 687 let unisonIgnoreName pathString = 688 Uicommon.addIgnorePattern (Uicommon.ignoreName (Path.fromString pathString));; 689 Callback.register "unisonIgnorePath" unisonIgnorePath;; 690 Callback.register "unisonIgnoreExt" unisonIgnoreExt;; 691 Callback.register "unisonIgnoreName" unisonIgnoreName;; 692 693 (* Update the state to take into account ignore patterns. 694 Return the new index of the first state item that is 695 not ignored starting at old index i. 696 *) 697 let unisonUpdateForIgnore i = 698 let l = ref [] in 699 let num = ref(-1) in 700 let newI = ref None in 701 (* FIX: we should actually test whether any prefix is now ignored *) 702 let keep s = not (Globals.shouldIgnore s.ri.path1) in 703 for j = 0 to (Array.length !theState - 1) do 704 let s = !theState.(j) in 705 if keep s then begin 706 l := s :: !l; 707 num := !num + 1; 708 if (j>=i && !newI=None) then newI := Some !num 709 end 710 done; 711 theState := Array.of_list (Safelist.rev !l); 712 match !newI with None -> (Array.length !theState - 1) 713 | Some i' -> i';; 714 Callback.register "unisonUpdateForIgnore" unisonUpdateForIgnore;; 715 716 let unisonState () = !theState;; 717 Callback.register "unisonState" unisonState;; 718 719 (* from Uicommon *) 720 let roots2niceStrings length = function 721 (Local,fspath1), (Local,fspath2) -> 722 let name1, name2 = Fspath.differentSuffix fspath1 fspath2 in 723 (Util.truncateString name1 length, Util.truncateString name2 length) 724 | (Local,fspath1), (Remote host, fspath2) -> 725 (Util.truncateString "local" length, Util.truncateString host length) 726 | (Remote host, fspath1), (Local,fspath2) -> 727 (Util.truncateString host length, Util.truncateString "local" length) 728 | _ -> assert false (* BOGUS? *);; 729 let unisonFirstRootString() = 730 let replica1, replica2 = roots2niceStrings 32 (Globals.roots()) in 731 Unicode.protect replica1;; 732 let unisonSecondRootString() = 733 let replica1, replica2 = roots2niceStrings 32 (Globals.roots()) in 734 Unicode.protect replica2;; 735 Callback.register "unisonFirstRootString" unisonFirstRootString;; 736 Callback.register "unisonSecondRootString" unisonSecondRootString;; 737 738 739 (* Note, this returns whether the files conflict, NOT whether 740 the current setting is Conflict *) 741 let unisonRiIsConflict ri = 742 match ri.ri.replicas with 743 | Different {default_direction = Conflict "files differ"} -> true 744 | _ -> false;; 745 Callback.register "unisonRiIsConflict" unisonRiIsConflict;; 746 747 (* Test whether reconItem's current state is different from 748 Unison's recommendation. Used to colour arrows in 749 the reconItems table *) 750 let changedFromDefault ri = 751 match ri.ri.replicas with 752 Different diff -> diff.direction <> diff.default_direction 753 | _ -> false;; 754 Callback.register "changedFromDefault" changedFromDefault;; 755 756 let unisonRiRevert ri = 757 match ri.ri.replicas with 758 | Different diff -> diff.direction <- diff.default_direction 759 | _ -> ();; 760 Callback.register "unisonRiRevert" unisonRiRevert;; 761 762 let unisonProfileInit (profileName:string) (r1:string) (r2:string) = 763 Prefs.resetToDefaults(); 764 Prefs.profileName := Some(profileName); 765 Prefs.addComment "Unison preferences file"; (* Creates the file, assumes it doesn't exist *) 766 ignore (Prefs.add "root" r1); 767 ignore (Prefs.add "root" r2);; 768 Callback.register "unisonProfileInit" unisonProfileInit;; 769 770 Callback.register "unisonPasswordMsg" Terminal.password;; 771 Callback.register "unisonPassphraseMsg" Terminal.passphrase;; 772 Callback.register "unisonAuthenticityMsg" Terminal.authenticity;; 773 774 let unisonExnInfo e = 775 match e with 776 Util.Fatal s -> Printf.sprintf "Fatal error: %s" s 777 | Invalid_argument s -> Printf.sprintf "Invalid argument: %s" s 778 | Unix.Unix_error(ue,s1,s2) -> 779 Printf.sprintf "Unix error(%s,%s,%s)" (Unix.error_message ue) s1 s2 780 | _ -> Printexc.to_string e;; 781 Callback.register "unisonExnInfo" 782 (fun e -> Unicode.protect (unisonExnInfo e));;