helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/unison/uigtk.ml

   1 (* $Id$ *)
   2
   3 open Util
   4 open Os
   5 open Common
   6 open Uicommon
   7 open Printf
   8 open Trace
   9
  10 (**********************************************************************)
  11 (*                           GRAPHICAL INTERFACE                      *)
  12 (**********************************************************************)
  13
  14 module Private : Uicommon.UI = struct
  15
  16 open GMain
  17 open GdkKeysyms
  18
  19 let debugprogress = Trace.debug "progress"
  20
  21 (**********************************************************************)
  22 (* UI preferences                                                     *)
  23 (**********************************************************************)
  24
  25 let fontMonospaceMedium =
  26   if Sys.os_type = "Win32" then
  27     lazy (Gdk.Font.load "-*-Courier New-Medium-R-Normal--*-110-*-*-*-*-*-*")
  28   else
  29     lazy (Gdk.Font.load "-*-Clean-Medium-R-Normal--*-130-*-*-*-*-*-*")
  30 let fontMonospaceBold =
  31   if Sys.os_type = "Win32" then
  32     lazy (Gdk.Font.load "-*-Courier New-Bold-R-Normal--*-110-*-*-*-*-*-*")
  33   else
  34     lazy (Gdk.Font.load "-*-Courier-Bold-R-Normal--*-120-*-*-*-*-*-*")
  35
  36 (**********************************************************************)
  37 (* UI state variables                                                 *)
  38 (**********************************************************************)
  39
  40 type stateItem = { ri : reconItem;
  41                    mutable bytesTransferred : int;
  42                    mutable whatHappened : unit confirmation option }
  43 let theState = ref [||]
  44
  45 let current = ref None
  46
  47 let currentWindow = ref None
  48 let grabFocus t =
  49   match !currentWindow with
  50     Some w -> t#set_transient_for w;
  51               w#misc#set_sensitive false
  52   | None   -> ()
  53 let releaseFocus () =
  54   begin match !currentWindow with
  55     Some w -> w#misc#set_sensitive true
  56   | None   -> ()
  57   end
  58
  59 (**********************************************************************)
  60 (*                         Lock management                            *)
  61 (**********************************************************************)
  62
  63 let busy = ref false
  64
  65 let getLock f =
  66   if !busy then
  67     Trace.message "Synchronizer is busy, please wait..\n"
  68   else begin
  69     busy := true; f (); busy := false
  70   end
  71
  72 (**********************************************************************)
  73 (* Some widgets                                                       *)
  74 (**********************************************************************)
  75
  76 class scrolled_text ?editable ?word_wrap ?width ?height ?packing ?show
  77     () =
  78   let sw =
  79     GBin.scrolled_window ?width ?height ?packing ~show:false
  80       ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ()
  81   in
  82   let text = GEdit.text ?editable ?word_wrap ~packing:sw#add () in
  83   object
  84     inherit GObj.widget_full sw#as_widget
  85     method text = text
  86     method insert ?(font=fontMonospaceMedium) s =
  87       text#freeze ();
  88       text#delete_text ~start:0 ~stop:text#length;
  89       text#insert ~font:(Lazy.force font) s;
  90       text#thaw ()
  91     method show () = sw#misc#show ()
  92     initializer
  93       if show <> Some false then sw#misc#show ()
  94   end
  95
  96 let gtk_sync () = while Glib.Main.iteration false do () done
  97
  98 (**********************************************************************)
  99 (*                           YES OR NO FUNCTION                       *)
 100 (**********************************************************************)
 101 (* val yesOrNo : string -> string -> (unit -> unit) -> (unit -> unit) *)
 102 (*                      -> unit                                       *)
 103 (* Displays a window with two buttons : YES and NO                    *)
 104 (* yesOrNo title message yesFunction noFunction open the title        *)
 105 (* window in which is displayed message. yesFunction and noFunctions  *)
 106 (* are the functions associated two the two buttons                   *)
 107 (**********************************************************************)
 108 let yesOrNo ~title ~message ~yes:yesFunction ~no:noFunction =
 109   let t = GWindow.dialog ~title ~wm_name:title ~modal:true ~position:`CENTER () in
 110   grabFocus t;
 111   let theLabel = GMisc.label ~text:message
 112       ~packing:(t#vbox#pack ~padding:4) () in
 113   let yes = GButton.button ~label:"Yes" ~packing:t#action_area#add ()
 114   and no = GButton.button ~label:"No" ~packing:t#action_area#add () in
 115   no#grab_default ();
 116   ignore
 117     (yes#connect#clicked ~callback:(fun () -> t#destroy (); yesFunction ()));
 118   ignore
 119     (no#connect#clicked  ~callback:(fun () -> t#destroy (); noFunction ()));
 120   t#show ();
 121   ignore (t#connect#destroy ~callback:Main.quit);
 122   Main.main ();
 123   releaseFocus ()
 124
 125 (**********************************************************************)
 126 (*                         SAFE EXIT FUNCTION                         *)
 127 (**********************************************************************)
 128
 129 (* Avoid recursive invocations of the function below
 130    (a window receives delete events even when it is not sensitive) *)
 131 let inExit = ref false
 132
 133 let safeExit () =
 134   if not !inExit then begin
 135     inExit := true;
 136     if not !busy then exit 0 else
 137     yesOrNo ~title:"Premature exit"
 138       ~message:"Unison is working, exit anyway ?"
 139       ~yes:(fun () -> exit 0) ~no:(fun () -> ());
 140     inExit := false
 141   end
 142
 143 (**********************************************************************)
 144 (* okBox: Display a message in a window and wait for the user         *)
 145 (* to hit the "OK" button.                                            *)
 146 (**********************************************************************)
 147 let okBox ~title ~message =
 148   let t = GWindow.dialog ~title ~wm_name:title ~modal:true ~position:`CENTER () in
 149   grabFocus t;
 150   let theLabel = GMisc.label ~text:message
 151       ~packing:(t#vbox#pack ~padding:4) () in
 152   let ok = GButton.button ~label:"OK" ~packing:t#action_area#add () in
 153   ok#grab_default ();
 154   ignore (ok#connect#clicked ~callback:(fun () -> t#destroy()));
 155   t#show ();
 156   (* Do nothing until user destroys window *)
 157   ignore (t#connect#destroy ~callback:Main.quit);
 158   Main.main ();
 159   releaseFocus ()
 160
 161 (**********************************************************************)
 162 (* warnBox: Display a warning message in a window and wait for the    *)
 163 (* user to hit "OK" or "Exit".                                        *)
 164 (**********************************************************************)
 165 let warnBox ~title ~message =
 166   inExit := true;
 167   let t = GWindow.dialog ~title ~wm_name:title ~modal:true ~position:`CENTER () in
 168   grabFocus t;
 169   let theLabel =
 170     GMisc.label ~text:message
 171       ~packing:(t#vbox#pack ~padding:4) () in
 172   let ok = GButton.button ~label:"OK" ~packing:t#action_area#add () in
 173   ok#grab_default ();
 174   ignore (ok#connect#clicked ~callback:(fun () -> t#destroy()));
 175   let exi = GButton.button ~label:"Exit" ~packing:t#action_area#add () in
 176   ignore (exi#connect#clicked ~callback:(fun () -> exit 0));
 177   t#show ();
 178   (* Do nothing until user destroys window *)
 179   ignore (t#connect#destroy ~callback:Main.quit);
 180   Main.main ();
 181   releaseFocus ();
 182   inExit := false
 183
 184 (**********************************************************************)
 185 (* Standard file dialog                                               *)
 186 (**********************************************************************)
 187 let file_dialog ~title ~callback ?filename () =
 188   let sel = GWindow.file_selection ~title ~modal:true ?filename () in
 189   grabFocus sel;
 190   ignore (sel#cancel_button#connect#clicked ~callback:sel#destroy);
 191   ignore (sel#ok_button#connect#clicked ~callback:
 192             (fun () ->
 193                let name = sel#get_filename in
 194                sel#destroy ();
 195                callback name));
 196   sel#show ();
 197   Main.main ();
 198   releaseFocus ()
 199
 200 (**********************************************************************)
 201 (* The root selection dialog                                          *)
 202 (**********************************************************************)
 203 let rootSelect cont =
 204   let t = GWindow.dialog ~title:"Root selection" ~wm_name:"Root selection"
 205       ~modal:true ~allow_grow:true () in
 206   t#misc#grab_focus ();
 207
 208   let makeGetRoot title =
 209     let fr =
 210       GBin.frame ~label:title ~border_width:2 ~packing:(t#vbox#add) () in
 211
 212     let vb = GPack.vbox ~border_width:4 ~packing:fr#add () in
 213
 214     let f = GPack.vbox ~packing:(vb#add) () in
 215     let f0 = GPack.hbox ~spacing:4 ~packing:f#add () in
 216     ignore (GMisc.label ~text:"Host:" ~packing:f0#pack ());
 217     let localB = GButton.radio_button ~packing:f0#pack
 218         ~label:"Local" () in
 219     let remoteB = GButton.radio_button ~group:localB#group
 220         ~packing:f0#pack ~label:"Remote" () in
 221     let hostE = GEdit.entry ~packing:f0#add () in
 222     let f1 = GPack.hbox ~spacing:4 ~packing:f#add () in
 223     ignore (GMisc.label ~text:"File:" ~packing:f1#pack ());
 224     let fileE = GEdit.entry ~packing:f1#add () in
 225     let browseCommand() =
 226       file_dialog ~title:"Select a local file"
 227         ~callback:(fun file -> fileE#set_text file) ~filename:fileE#text ()
 228     in
 229     let b = GButton.button ~label:"Browse"
 230         ~packing:f1#pack () in
 231     ignore (b#connect#clicked ~callback:browseCommand);
 232     let varLocalRemote = ref (`Local : [`Local|`Remote]) in
 233     let localState() =
 234       varLocalRemote := `Local;
 235       hostE#misc#set_sensitive false;
 236       b#misc#set_sensitive true
 237     in
 238     let remoteState() =
 239       varLocalRemote := `Remote;
 240       hostE#misc#set_sensitive true;
 241       b#misc#set_sensitive false
 242     in
 243     ignore (localB#connect#clicked ~callback:localState);
 244     ignore (remoteB#connect#clicked ~callback:remoteState);
 245     localState();
 246     let getRoot() =
 247       let filePart = fileE#text in
 248       let remoteHost = hostE#text in
 249       (* FIX: should do sanity checking here *)
 250       match !varLocalRemote with
 251         `Local -> filePart
 252       | `Remote -> "//"^remoteHost^"/"^filePart in
 253     getRoot
 254   in
 255
 256   let getRoot1 = makeGetRoot "Root 1" in
 257   let getRoot2 = makeGetRoot "Root 2" in
 258
 259   let f3 = t#action_area in
 260   let okCommand() =
 261     let root1 = getRoot1() in
 262     let root2 = getRoot2() in
 263     Prefs.setPref Uicommon.roots Prefs.TempSetting [root1;root2];
 264     t#destroy ();
 265     cont ()
 266   in
 267   let okButton = GButton.button ~label:"OK" ~packing:f3#add () in
 268   ignore (okButton#connect#clicked ~callback:okCommand);
 269   okButton#grab_default ();
 270   let cancelButton = GButton.button ~label:"Cancel" ~packing:f3#add () in
 271   ignore (cancelButton#connect#clicked ~callback:safeExit);
 272
 273   (* The profile editing dialog has been installed into the Gtk
 274      main interaction loop; wait until it completes. *)
 275   t#show ();
 276   ignore (t#connect#destroy ~callback:Main.quit);
 277   Main.main ()
 278
 279 (**********************************************************************)
 280 (* The root selection dialog                                          *)
 281 (**********************************************************************)
 282 let editProfile prof =
 283   (* FIX:
 284      Scan the profile (if it is defined)
 285      Extract the roots
 286      Modifications
 287      Save with new roots *)
 288   let t = GWindow.dialog ~title:"Edit profile" ~wm_name:"Edit profile"
 289       ~modal:true ~allow_grow:true () in
 290   t#misc#grab_focus ();
 291
 292   let vb = GPack.vbox ~border_width:4 ~packing:t#vbox#add () in
 293
 294   let makeGetRoot() =
 295     let f = GPack.vbox ~packing:(vb#pack ~expand:true ~padding:4) () in
 296     let f0 = GPack.hbox ~spacing:4 ~packing:f#add () in
 297     ignore (GMisc.label ~text:"Host:" ~packing:f0#pack ());
 298     let localB = GButton.radio_button ~packing:f0#pack ~label:"Local" () in
 299     let remoteB = GButton.radio_button ~group:localB#group
 300         ~packing:f0#pack ~label:"Remote" () in
 301     let hostE = GEdit.entry ~packing:f0#add () in
 302     let f1 = GPack.hbox ~spacing:4 ~packing:f#add () in
 303     ignore (GMisc.label ~text:"File:" ~packing:f1#pack ());
 304     let fileE = GEdit.entry ~packing:f1#add () in
 305     let browseCommand() =
 306       file_dialog ~title:"Select a local file"
 307         ~callback:(fun file -> fileE#set_text file) ()
 308     in
 309     let b = GButton.button ~label:"Browse" ~packing:f1#pack () in
 310     ignore (b#connect#clicked ~callback:browseCommand);
 311     let varLocalRemote = ref (`Local : [`Local|`Remote]) in
 312     let localState() =
 313       varLocalRemote := `Local;
 314       hostE#set_editable false;
 315       b#misc#set_state `NORMAL
 316     in
 317     let remoteState() =
 318       varLocalRemote := `Remote;
 319       hostE#set_editable true;
 320       b#misc#set_state `INSENSITIVE
 321     in
 322     ignore (localB#connect#clicked ~callback:localState);
 323     ignore (remoteB#connect#clicked ~callback:remoteState);
 324     localState();
 325     let getRoot() =
 326       let filePart = fileE#text in
 327       let remoteHost = hostE#text in
 328       (* FIX: should do sanity checking here *)
 329       match !varLocalRemote with
 330         `Local -> filePart
 331       | `Remote -> "//"^remoteHost^"/"^filePart in
 332     getRoot
 333   in
 334
 335
 336   ignore (GMisc.label ~text:"Root 1:" ~xalign:0.
 337             ~packing:(vb#pack ~expand:true ~padding:4) ());
 338   let getRoot1 = makeGetRoot() in
 339
 340   ignore (GMisc.label ~text:"Root 2:" ~xalign:0.
 341             ~packing:(vb#pack ~expand:true ~padding:4) ());
 342   let getRoot2 = makeGetRoot() in
 343
 344   let f3 = t#action_area in
 345   let okCommand() =
 346     let root1 = getRoot1() in
 347     let root2 = getRoot2() in
 348     Prefs.setPref Uicommon.roots Prefs.PermanentSetting [root1;root2];
 349     Globals.savePrefs();
 350     t#destroy () in
 351   let okButton = GButton.button ~label:"OK" ~packing:f3#add () in
 352   ignore (okButton#connect#clicked ~callback:okCommand);
 353   let cancelCommand() =
 354     t#destroy ()
 355   in
 356   let cancelButton = GButton.button ~label:"Cancel" ~packing:f3#add () in
 357   ignore (cancelButton#connect#clicked ~callback:cancelCommand);
 358
 359   (* The profile editing dialog has been installed into the Gtk
 360      main interaction loop; wait until it completes. *)
 361   t#show ();
 362   ignore (t#connect#destroy ~callback:Main.quit);
 363   Main.main ()
 364
 365 (**********************************************************************)
 366 (*                        Documentation window                        *)
 367 (**********************************************************************)
 368 let documentation sect =
 369   let title = "Documentation" in
 370   let t = GWindow.dialog ~title ~wm_name:title () in
 371   let t_dismiss =
 372     GButton.button ~label:"dismiss" ~packing:t#action_area#add () in
 373   t_dismiss#grab_default ();
 374   let dismiss () = t#destroy () in
 375   ignore (t_dismiss#connect#clicked ~callback:dismiss);
 376   ignore (t#event#connect#delete ~callback:(fun _ -> dismiss (); true));
 377
 378   let (name, docstr) = List.assoc sect Strings.docs in
 379   let hb = GPack.hbox ~packing:(t#vbox#pack ~expand:false ~padding:2) () in
 380   let optionmenu =
 381     GMenu.option_menu ~packing:(hb#pack ~fill:false) () in
 382
 383   let charW = Gdk.Font.char_width (Lazy.force fontMonospaceMedium) 'M' in
 384   let charH = 16 in
 385   let t_text =
 386     new scrolled_text ~editable:false
 387       ~width:(charW * 80) ~height:(charH * 20) ~packing:t#vbox#add ()
 388   in
 389   t_text#insert docstr;
 390
 391   let sect_idx = ref 0 in
 392   let idx = ref 0 in
 393   let menu = GMenu.menu () in
 394   let addDocSection (shortname, (name, docstr)) =
 395     if shortname <> "" && name <> "" then begin
 396       if shortname = sect then sect_idx := !idx;
 397       incr idx;
 398       let item = GMenu.menu_item ~label:name ~packing:menu#append () in
 399       ignore
 400         (item#connect#activate ~callback:(fun () -> t_text#insert docstr))
 401     end
 402   in
 403   Safelist.iter addDocSection Strings.docs;
 404   optionmenu#set_menu menu;
 405   optionmenu#set_history !sect_idx;
 406
 407   t#show ()
 408
 409 (**********************************************************************)
 410 (* The profile selection dialog                                       *)
 411 (**********************************************************************)
 412 let profileSelect cont =
 413 (* FIX:
 414   - Choix du profil par defaut
 415 *)
 416   let profilesAndRoots =
 417     ref
 418       (Safelist.map
 419          (fun f ->
 420             let filename = fspath2string (Os.fileInUnisonDir f) in
 421             let roots =
 422               Safelist.map snd
 423                 (Safelist.filter (fun (n, v) -> n = "root")
 424                    (Prefs.scanPreferencesFile filename))
 425             in
 426             (Filename.chop_suffix f ".prf", roots))
 427          (Files.ls (fspath2string Os.synchronizerFspath) "*.prf")) in
 428
 429   (* The selected profile *)
 430   let selection = ref None in
 431
 432   (* Build the dialog *)
 433   let t = GWindow.dialog ~title:"Profiles" ~wm_name:"Profiles" () in
 434
 435   let okCommand() =
 436     match !selection with
 437       Some profile ->
 438         Globals.prefsFileName := profile ^ ".prf";
 439         currentWindow := None;
 440         t#destroy ();
 441         cont ()
 442     | _ ->
 443         ()
 444   in
 445   let okButton = GButton.button ~label:"OK" ~packing:t#action_area#add () in
 446   ignore (okButton#connect#clicked ~callback:okCommand);
 447   okButton#misc#set_sensitive false;
 448   okButton#grab_default ();
 449   let cancelCommand() = t#destroy (); Main.quit () in
 450   let cancelButton = GButton.button ~label:"Cancel"
 451       ~packing:t#action_area#add () in
 452   ignore (cancelButton#connect#clicked ~callback:cancelCommand);
 453   cancelButton#misc#set_can_default true;
 454
 455   let vb = t#vbox in
 456
 457   ignore (GMisc.label
 458             ~text:"Select an existing profile or create a new one"
 459             ~xpad:2 ~ypad:2 ~packing:vb#pack ());
 460
 461   let sw =
 462     GBin.scrolled_window ~packing:vb#add ~height:100
 463       ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
 464   in
 465   let lst = GList.clist ~selection_mode:`BROWSE ~packing:(sw#add) () in
 466   let fillLst default =
 467     lst#freeze ();
 468     lst#clear ();
 469     let selRow = ref 0 in
 470     let i = ref 0 in (* FIX: Work around a lablgtk bug *)
 471     Safelist.iter
 472       (fun (profile, roots) ->
 473          ignore (lst#append [profile]);
 474          if profile = default then selRow := !i;
 475          lst#set_row_data !i (profile, roots);
 476          incr i)
 477       (List.sort (fun (p, _) (p', _) -> compare p p') !profilesAndRoots);
 478     let r = lst#rows in
 479     let p = if r < 2 then 0. else float !selRow /. float (r - 1) in
 480     lst#scroll_vertical `JUMP p;
 481     lst#thaw ()
 482   in
 483   let tbl =
 484     GPack.table ~rows:2 ~columns:2 ~packing:vb#pack ()
 485   in
 486   tbl#misc#set_sensitive false;
 487   ignore (GMisc.label ~text:"Root 1:" ~xpad:2
 488             ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ());
 489   ignore (GMisc.label ~text:"Root 2:" ~xpad:2
 490             ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ());
 491   let root1 =
 492     GEdit.entry ~packing:(tbl#attach ~left:1 ~top:0) ~editable:false () in
 493   let root2 =
 494     GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1) ~editable:false () in
 495   root1#misc#set_can_focus false;
 496   root2#misc#set_can_focus false;
 497   let hb =
 498     GPack.hbox ~border_width:2 ~spacing:2 ~packing:(vb#pack ~expand:false) ()
 499   in
 500   let nw =
 501     GButton.button ~label:"Create new profile"
 502       ~packing:hb#pack () in
 503   ignore (nw#connect#clicked ~callback:(fun () ->
 504     let t =
 505       GWindow.dialog ~title:"New profile" ~wm_name:"New profile" ~modal:true ()
 506     in
 507     let vb = GPack.vbox ~border_width:4 ~packing:t#vbox#add () in
 508     let f = GPack.vbox ~packing:(vb#pack ~expand:true ~padding:4) () in
 509     let f0 = GPack.hbox ~spacing:4 ~packing:f#add () in
 510     ignore (GMisc.label ~text:"Profile name:"
 511               ~packing:f0#pack ());
 512     let prof = GEdit.entry ~packing:f0#add () in
 513     prof#misc#grab_focus ();
 514
 515     let exit () = t#destroy (); Main.quit () in
 516     ignore (t#event#connect#delete ~callback:(fun _ -> exit (); true));
 517
 518     let f3 = t#action_area in
 519     let okCommand () =
 520       let profile = prof#text in
 521       if profile <> "" then
 522         let file = profile ^ ".prf" in
 523         let fspath = Os.fileInUnisonDir file in
 524         let filename = fspath2string fspath in
 525         if Sys.file_exists filename then
 526           okBox (myName ^ " error")
 527             ("Profile \""
 528              ^ profile
 529              ^ "\" already exists!\nPlease select another name.")
 530         else
 531           (* Make an empty file *)
 532           let ch =
 533             open_out_gen
 534               [Open_wronly; Open_creat; Open_trunc] 0o600 filename in
 535           close_out ch;
 536           profilesAndRoots := (profile, [])::!profilesAndRoots;
 537           fillLst profile;
 538           exit ()
 539     in
 540     let okButton = GButton.button ~label:"OK" ~packing:f3#add () in
 541     ignore (okButton#connect#clicked ~callback:okCommand);
 542     okButton#grab_default ();
 543     let cancelButton = GButton.button ~label:"Cancel" ~packing:f3#add () in
 544     ignore (cancelButton#connect#clicked ~callback:exit);
 545
 546     t#show ();
 547     grabFocus t;
 548     Main.main ();
 549     releaseFocus ()));
 550   let ed =
 551     GButton.button ~label:"Edit" (*~packing:(hb#pack ~expand:false)*) () in
 552   let sd =
 553     GButton.button ~label:"Set default" (*~packing:(hb#pack ~expand:false)*) ()
 554   in
 555   let hlp =
 556     GButton.button ~label:"Help"
 557       ~packing:(hb#pack ~expand:false ~from:`END) () in
 558   ignore (hlp#connect#clicked ~callback:(fun () -> documentation "tutorial"));
 559
 560   ignore (lst#connect#unselect_row ~callback:(fun _ _ _ ->
 561     root1#set_text ""; root2#set_text "";
 562     selection := None;
 563     tbl#misc#set_sensitive false;
 564     okButton#misc#set_sensitive false;
 565     ed#misc#set_sensitive false;
 566     sd#misc#set_sensitive false));
 567   ignore (lst#connect#select_row ~callback:(fun i _ _ ->
 568     (* Inserting the first row trigger the signal, even before the row
 569        data is set. So, we need to catch the corresponding exception *)
 570     try
 571       let (profile, roots) = lst#get_row_data i in
 572       selection := Some profile;
 573       begin match roots with
 574         [r1; r2] -> root1#set_text r1; root2#set_text r2;
 575                     tbl#misc#set_sensitive true
 576       | _        -> root1#set_text ""; root2#set_text "";
 577                     tbl#misc#set_sensitive false
 578       end;
 579       okButton#misc#set_sensitive true;
 580       ed#misc#set_sensitive true;
 581       sd#misc#set_sensitive true
 582     with Gpointer.Null -> ()));
 583   ignore (lst#event#connect#button_press ~callback:(fun ev ->
 584     match GdkEvent.get_type ev with
 585       `TWO_BUTTON_PRESS ->
 586         okCommand ();
 587         true
 588     | _ ->
 589         false));
 590   fillLst "default";
 591   lst#misc#grab_focus ();
 592   currentWindow := Some (t :> GWindow.window);
 593   ignore (t#event#connect#delete ~callback:(fun _ -> Main.quit (); true));
 594   t#show ()
 595
 596 (**********************************************************************)
 597 (* Function to display a message in a new window                      *)
 598 (**********************************************************************)
 599 let messageBox ~title ?(label = "Dismiss") ?(action = fun t -> t#destroy)
 600     ?(modal = false) message =
 601   let t = GWindow.dialog ~title ~wm_name:title ~modal ~position:`CENTER () in
 602   let t_dismiss = GButton.button ~label ~packing:t#action_area#add () in
 603   t_dismiss#grab_default ();
 604   ignore (t_dismiss#connect#clicked ~callback:(action t));
 605   let charW = Gdk.Font.char_width (Lazy.force fontMonospaceMedium) 'M' in
 606   let charH = 16 in
 607   let t_text =
 608     new scrolled_text ~editable:false
 609       ~width:(charW * 80) ~height:(charH * 20) ~packing:t#vbox#add ()
 610   in
 611   t_text#insert message;
 612   ignore (t#event#connect#delete ~callback:(fun _ -> action t (); true));
 613   t#show ();
 614   if modal then begin
 615     grabFocus t;
 616     Main.main ();
 617     releaseFocus ()
 618   end
 619
 620 (**********************************************************************)
 621 (* Fatal error handling                                               *)
 622 (**********************************************************************)
 623 let fatalError =
 624   messageBox ~title:"Fatal Error" ~label:"Exit" ~modal:true
 625     ~action:(fun t () -> exit 1)
 626
 627
 628 (**********************************************************************)
 629 (*                      Toplevel window                               *)
 630 (**********************************************************************)
 631 let createToplevelWindow () =
 632   let toplevelWindow = GWindow.window ~wm_name:myName () in
 633   let toplevelVBox = GPack.vbox ~packing:toplevelWindow#add () in
 634
 635   (**********************************************************************)
 636   (* Groups of same sensitivity                                         *)
 637   (**********************************************************************)
 638   let grAction = ref [] in
 639   let grDiff = ref [] in
 640   let grProceed = ref [] in
 641   let grRestart = ref [] in
 642   let grAdd gr w = gr := w#misc::!gr in
 643   let grSet gr st = List.iter (fun x -> x#set_sensitive st) !gr in
 644
 645   (**********************************************************************)
 646   (* Create the menu bar                                                *)
 647   (**********************************************************************)
 648   let menuBar =
 649     GMenu.menu_bar ~border_width:2 ~packing:toplevelVBox#pack ()
 650   in
 651   let menus = new GMenu.factory ~accel_modi:[] menuBar in
 652   let accel_group = menus#accel_group in
 653   toplevelWindow#add_accel_group accel_group;
 654   let add_submenu ?(modi=[]) ~label () =
 655     new GMenu.factory ~accel_group ~accel_modi:modi (menus#add_submenu label)
 656   in
 657
 658   (**********************************************************************)
 659   (* Create the menus                                                   *)
 660   (**********************************************************************)
 661   let fileMenu = add_submenu ~label:"Synchronization" ()
 662   and actionsMenu = add_submenu ~label:"Actions" ()
 663   and ignoreMenu = add_submenu ~modi:[`SHIFT] ~label:"Ignore" ()
 664   and helpMenu = add_submenu ~label:"Help" () in
 665
 666   (**********************************************************************)
 667   (* Create the main window                                             *)
 668   (**********************************************************************)
 669   let mainWindow =
 670     let sw =
 671       GBin.scrolled_window ~packing:(toplevelVBox#add)
 672         ~height:(Prefs.readPref mainWindowHeight * 12)
 673         ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
 674     in
 675     GList.clist
 676       ~columns:5 ~titles_show:true ~selection_mode:`BROWSE ~packing:sw#add ()
 677   in
 678   mainWindow#misc#grab_focus ();
 679   (* FIX: roots2string should return a pair *)
 680   let s = roots2string () in
 681   Array.iteri
 682     (fun i data ->
 683        mainWindow#set_column
 684          ~title_active:false ~auto_resize:true ~title:data i)
 685     [| " " ^ String.sub s ~pos:0 ~len:12 ^ " "; "  Action  ";
 686        " " ^ String.sub s ~pos:15 ~len:12 ^ " "; "  Status  "; " Path" |];
 687   let status_width =
 688     let font = mainWindow#misc#style#font in
 689     4 + max (Gdk.Font.string_width font "working")
 690             (Gdk.Font.string_width font "skipped")
 691   in
 692   mainWindow#set_column ~justification:`CENTER 1;
 693   mainWindow#set_column
 694     ~justification:`CENTER ~auto_resize:false ~width:status_width 3;
 695
 696   (**********************************************************************)
 697   (* Create the details window                                          *)
 698   (**********************************************************************)
 699
 700   let charW = Gdk.Font.char_width (Lazy.force fontMonospaceMedium) 'M' in
 701   let charH = if Sys.os_type = "Win32" then 20 else 16 in
 702
 703   let detailsWindow =
 704     let sw =
 705       GBin.scrolled_window ~packing:(toplevelVBox#pack ~expand:false)
 706         ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
 707     in
 708     GEdit.text ~editable:false ~height:(3 * charH) ~width: (96 * charW)
 709       ~line_wrap:false ~packing:sw#add () in
 710   detailsWindow#misc#set_can_focus false;
 711   let style = detailsWindow#misc#style#copy in
 712   style#set_font (Lazy.force fontMonospaceMedium);
 713   detailsWindow#misc#set_style style;
 714   let updateButtons () =
 715     match !current with
 716       None ->
 717         grSet grAction false;
 718         grSet grDiff false
 719     | Some row ->
 720         let (activate1, activate2) =
 721           match !theState.(row).whatHappened, !theState.(row).ri.replicas with
 722             Some _, _                                    -> (false, false)
 723           | None,   Different((FILE,_, _),(FILE,_, _),_) -> (true, true)
 724           | None,   _                                    -> (true, false)
 725         in
 726         grSet grAction activate1;
 727         grSet grDiff activate2
 728   in
 729
 730   let makeRowVisible row =
 731     if mainWindow#row_is_visible row <> `FULL then begin
 732       let adj = mainWindow#vadjustment in
 733       let current = adj#value
 734       and upper = adj#upper and lower = adj#lower in
 735       let v =
 736         float row /. float (mainWindow#rows + 1) *. (upper-.lower) +. lower
 737       in
 738       adj#set_value (min v (upper -. adj#page_size))
 739     end
 740   in
 741
 742   let updateDetails () =
 743     detailsWindow#freeze ();
 744     detailsWindow#delete_text ~start:0 ~stop:detailsWindow#length;
 745     begin match !current with
 746       None ->
 747         ()
 748     | Some row ->
 749         makeRowVisible row;
 750         let details =
 751           match !theState.(row).whatHappened with
 752             None -> details2string !theState.(row).ri "  "
 753           | Some(Succeeded(_)) -> details2string !theState.(row).ri "  "
 754           | Some(Failed(s)) -> s in
 755         detailsWindow#insert (path2string !theState.(row).ri.path);
 756         detailsWindow#insert "\n";
 757         detailsWindow#insert details
 758     end;
 759     (* Display text *)
 760     detailsWindow#thaw ();
 761     updateButtons ()
 762   in
 763
 764   (**********************************************************************)
 765   (*                       CREATE THE STATUS WINDOW                     *)
 766   (**********************************************************************)
 767
 768   let statusWindow =
 769     GMisc.statusbar ~packing:toplevelVBox#pack () in
 770   let statusContext = statusWindow#new_context ~name:"status" in
 771   ignore (statusContext#push "");
 772
 773   let displayStatus s1 s2 =
 774     Threads.do_on_main_thread (fun () ->
 775       (* Concatenate the new message *)
 776       let m =
 777         s1 ^ (String.make (max 2 (30 - String.length s1)) ' ') ^ s2 in
 778       statusContext#pop ();
 779       ignore (statusContext#push m);
 780       (* Force message to be displayed immediately *)
 781       gtk_sync ())
 782   in
 783
 784   (* Tell the Trace module about the status printer *)
 785   Trace.statusPrinter := Some displayStatus;
 786
 787   (**********************************************************************)
 788   (*            FUNCTIONS USED TO PRINT IN THE MAIN WINDOW              *)
 789   (**********************************************************************)
 790
 791   let select i =
 792     let r = mainWindow#rows in
 793     let p = if r < 2 then 0. else (float i +. 0.5) /. float (r - 1) in
 794     mainWindow#scroll_vertical `JUMP (min p 1.)
 795   in
 796
 797   ignore (mainWindow#connect#unselect_row ~callback:
 798       (fun ~row ~column ~event -> current := None; updateDetails ()));
 799   ignore (mainWindow#connect#select_row ~callback:
 800       (fun ~row ~column ~event -> current := Some row; updateDetails ()));
 801
 802   let nextInteresting () =
 803     let l = Array.length !theState in
 804     let start = match !current with Some i -> i + 1 | None -> 0 in
 805     let rec loop i =
 806       if i < l then
 807         match !theState.(i).ri.replicas with
 808           Different (_, _, dir)
 809               when not (Prefs.readPref auto) || !dir = Conflict ->
 810             select i
 811         | _ ->
 812             loop (i + 1)
 813     in
 814     loop start
 815   in
 816   let selectSomethingIfPossible () =
 817     if !current=None then nextInteresting ()
 818   in
 819
 820   let columnsOf i =
 821     let oldPath = if i = 0 then emptypath else !theState.(i-1).ri.path in
 822     let status =
 823       match !theState.(i).whatHappened with
 824         None -> "      "
 825       | Some conf ->
 826           match !theState.(i).ri.replicas with
 827             Different(_,_,{contents=Conflict}) | Problem _ ->
 828               "      "
 829           | _ ->
 830               match conf with
 831                 Succeeded _ -> "done  "
 832               | Failed _    -> "failed"
 833     in
 834     let s = reconItem2string oldPath !theState.(i).ri status in
 835     (* FIX: This is ugly *)
 836     (String.sub s ~pos:0 ~len:8,
 837      String.sub s ~pos:9 ~len:5,
 838      String.sub s ~pos:15 ~len:8,
 839      String.sub s ~pos:25 ~len:6,
 840      String.sub s ~pos:32 ~len:(String.length s - 32))
 841   in
 842
 843   let rightArrow =
 844     GDraw.pixmap_from_xpm_d ~window:toplevelWindow ~data:Pixmaps.copyAB () in
 845   let leftArrow =
 846     GDraw.pixmap_from_xpm_d ~window:toplevelWindow ~data:Pixmaps.copyBA () in
 847   let rightArrowBlack =
 848     GDraw.pixmap_from_xpm_d
 849       ~window:toplevelWindow ~data:Pixmaps.copyABblack () in
 850   let leftArrowBlack =
 851     GDraw.pixmap_from_xpm_d
 852       ~window:toplevelWindow ~data:Pixmaps.copyBAblack () in
 853   let ignoreAct =
 854     GDraw.pixmap_from_xpm_d ~window:toplevelWindow ~data:Pixmaps.ignore () in
 855   let doneIcon =
 856     GDraw.pixmap_from_xpm_d ~window:toplevelWindow ~data:Pixmaps.success () in
 857   let failedIcon =
 858     GDraw.pixmap_from_xpm_d ~window:toplevelWindow ~data:Pixmaps.failure () in
 859
 860   let displayArrow i action =
 861     match action with
 862       "<-?->" -> mainWindow#set_cell ~pixmap:ignoreAct i 1
 863     | "---->" -> mainWindow#set_cell ~pixmap:rightArrow i 1
 864     | "<----" -> mainWindow#set_cell ~pixmap:leftArrow i 1
 865     | "error" -> mainWindow#set_cell ~pixmap:failedIcon i 1
 866     |    _    -> assert false
 867   in
 868
 869   let displayStatusIcon i status =
 870     match status with
 871     | "failed" -> mainWindow#set_cell ~pixmap:failedIcon i 3
 872     | "done  " -> mainWindow#set_cell ~pixmap:doneIcon i 3
 873     | _        -> mainWindow#set_cell ~text:status i 3
 874   in
 875
 876   let displayMain() =
 877     mainWindow#freeze ();
 878     mainWindow#clear ();
 879     for i = 0 to Array.length !theState - 1 do
 880       let (r1, action, r2, status, path) = columnsOf i in
 881       ignore (mainWindow#append [ r1; ""; r2; status; path ]);
 882       displayArrow i action
 883     done;
 884     selectSomethingIfPossible ();
 885     begin match !current with Some idx -> select idx | None -> () end;
 886     mainWindow#thaw ();
 887     updateDetails ()
 888   in
 889
 890   let redisplay i =
 891     let (r1, action, r2, status, path) = columnsOf i in
 892     mainWindow#freeze ();
 893     mainWindow#set_cell ~text:r1     i 0;
 894     displayArrow i action;
 895     mainWindow#set_cell ~text:r2     i 2;
 896     displayStatusIcon i status;
 897     mainWindow#set_cell ~text:path   i 4;
 898     if status = " failed " then mainWindow#set_row ~foreground:(`NAME"red") i;
 899     mainWindow#thaw ();
 900     if !current = Some i then updateDetails ();
 901     updateButtons ()
 902   in
 903
 904   let showProgress i bytes =
 905     !theState.(i).bytesTransferred <- !theState.(i).bytesTransferred + bytes;
 906     let b = !theState.(i).bytesTransferred in
 907     let len = Common.riLength !theState.(i).ri in
 908     let newstatus =
 909       if b=0 || len = 0 then "working "
 910       else if len = 0 then sprintf "%8d" b
 911       else
 912         let percentage = (int_of_float ((float b) *. 100.0 /. (float len))) in
 913         if percentage > 100 then
 914           debugprogress (fun() -> errmsg "Progress amount miscalculated for %s\n"
 915                                     (path2string (!theState.(i).ri.path)));
 916         sprintf "  %3d%%  " (max 100 percentage) in
 917     Threads.do_on_main_thread (fun () ->
 918       mainWindow#set_cell ~text:newstatus i 3;
 919       gtk_sync ())
 920   in
 921
 922   (* Install showProgress so that we get called back by low-level
 923      file transfer stuff *)
 924   Util.progressPrinter := Some(showProgress);
 925
 926   (* Apply new ignore patterns to the current state, expecting that the
 927      number of reconitems will grow smaller. Adjust the display, being
 928      careful to keep the cursor as near as possible to its position
 929      before the new ignore patterns take effect. *)
 930   let ignoreAndRedisplay () =
 931     let lst = Array.to_list !theState in
 932     (* FIX: we should actually test whether any prefix is now ignored *)
 933     let keep sI = not (Pred.test Globals.ignore (path2string sI.ri.path)) in
 934     begin match !current with
 935       None ->
 936         theState := Array.of_list (Safelist.filter keep lst)
 937     | Some index ->
 938         let i = ref index in
 939         let l = ref [] in
 940         Array.iteri
 941           (fun j sI -> if keep sI then l := sI::!l
 942                        else if j < !i then decr i)
 943           !theState;
 944         current := if !l = [] then None else Some !i;
 945         theState := Array.of_list (Safelist.rev !l)
 946     end;
 947     displayMain();
 948   in
 949
 950   (**********************************************************************)
 951   (*                         FUNCTION DETECT UPDATES                    *)
 952   (**********************************************************************)
 953
 954   let detectUpdatesAndReconcile () =
 955     grSet grAction false;
 956     grSet grDiff false;
 957     grSet grProceed false;
 958     grSet grRestart false;
 959
 960     let (r1,r2) = Globals.getReplicaRoots () in
 961     let t = Trace.startTimer "Checking for updates" in
 962     let findUpdates () =
 963       let updates = Update.findUpdates () in
 964       Trace.showTimer t;
 965       updates
 966     in
 967     let reconcile updates =
 968       let t = Trace.startTimer "Reconciling" in
 969       Recon.reconcileAll updates
 970     in
 971     let reconItemList = reconcile (findUpdates ()) in
 972     Trace.showTimer t;
 973     if reconItemList = [] then
 974       Trace.status "Everything is up to date"
 975     else
 976       Trace.status ("Check and/or adjust selected actions; "
 977                     ^ "then press Proceed");
 978     theState :=
 979       Array.of_list
 980          (Safelist.map
 981             (fun ri -> { ri = ri; bytesTransferred = 0; whatHappened = None })
 982             reconItemList);
 983     current := None;
 984     displayMain();
 985     grSet grProceed (Array.length !theState > 0);
 986     grSet grRestart true
 987   in
 988
 989   (**********************************************************************)
 990   (* The ignore dialog                                                  *)
 991   (**********************************************************************)
 992
 993   let ignoreDialog () =
 994     let t = GWindow.dialog ~title: "Ignore" ~wm_name: "Ignore" () in
 995     let hbox = GPack.hbox ~packing:t#vbox#add () in
 996     let sb = GRange.scrollbar `VERTICAL
 997         ~packing:(hbox#pack ~from:`END) () in
 998     let regExpWindow =
 999       GList.clist ~columns:1 ~titles_show:false ~packing:hbox#add
1000         ~vadjustment:sb#adjustment ~width:400 ~height:150 () in
1001
1002     (* Local copy of the regular expressions; the global copy will
1003        not be changed until the Apply button is pressed *)
1004     let theRegexps = Pred.extern Globals.ignore in
1005     Safelist.iter (fun r -> ignore (regExpWindow#append [r])) theRegexps;
1006     let maybeGettingBigger = ref false in
1007     let maybeGettingSmaller = ref false in
1008     let selectedRow = ref None in
1009     ignore
1010       (regExpWindow#connect#select_row ~callback:
1011          (fun ~row ~column ~event -> selectedRow := Some row));
1012     ignore
1013       (regExpWindow#connect#unselect_row ~callback:
1014          (fun ~row ~column ~event -> selectedRow := None));
1015
1016     (* Configure the add frame *)
1017     let hbox = GPack.hbox ~spacing:4 ~packing:t#vbox#pack () in
1018     ignore (GMisc.label ~text: "Regular expression:"
1019               ~packing:(hbox#pack ~padding:2) ());
1020     let entry = GEdit.entry ~packing:hbox#add () in
1021     let add () =
1022       let theRegExp = entry#text in
1023       if theRegExp<>"" then begin
1024         entry#set_text "";
1025         regExpWindow#unselect_all ();
1026         ignore (regExpWindow#append [theRegExp]);
1027         maybeGettingSmaller := true
1028       end
1029     in
1030     let addButton = GButton.button ~label:"Add"
1031         ~packing:hbox#pack () in
1032     ignore (addButton#connect#clicked ~callback:add);
1033     ignore (entry#connect#activate ~callback:add);
1034     entry#misc#grab_focus ();
1035
1036     (* Configure the delete button *)
1037     let delete () =
1038       match !selectedRow with
1039         Some x ->
1040           (* After a deletion, updates must be detected again *)
1041           maybeGettingBigger := true;
1042           (* Delete xth regexp *)
1043           regExpWindow#unselect_all ();
1044           regExpWindow#remove ~row:x
1045       | None ->
1046           ()
1047     in
1048     let deleteButton = GButton.button ~label:"Delete"
1049         ~packing:hbox#pack () in
1050     ignore (deleteButton#connect#clicked ~callback:delete);
1051
1052     ignore
1053       (regExpWindow#event#connect#after#key_press ~callback:
1054          begin fun ev ->
1055            let key = GdkEvent.Key.keyval ev in
1056            if key = _Up || key = _Down || key = _Prior || key = _Next ||
1057            key = _Page_Up || key = _Page_Down then begin
1058              regExpWindow#select (regExpWindow#focus_row) 0;
1059              true
1060            end else if key = _Delete then begin
1061              delete (); true
1062            end else
1063              false
1064          end);
1065
1066     (* A function to refresh the state and ignore list *)
1067     let refresh () =
1068       let theRegexps = ref [] in
1069       for i = regExpWindow#rows - 1 downto 0 do
1070         theRegexps := regExpWindow#cell_text i 0 :: !theRegexps
1071       done;
1072       Pred.intern Globals.ignore (!theRegexps);
1073       if !maybeGettingBigger || !maybeGettingSmaller then begin
1074         Globals.savePrefs();
1075         Globals.propagatePrefs()
1076       end;
1077       if !maybeGettingBigger then detectUpdatesAndReconcile ()
1078       else if !maybeGettingSmaller then ignoreAndRedisplay();
1079       maybeGettingBigger := false;
1080       maybeGettingSmaller := false;
1081     in
1082
1083     (* Install the main buttons *)
1084     let applyButton =
1085       GButton.button ~label:"Apply" ~packing:t#action_area#add () in
1086     ignore (applyButton#connect#clicked ~callback:refresh);
1087     let cancelButton =
1088       GButton.button ~label:"Cancel" ~packing:t#action_area#add () in
1089     ignore (cancelButton#connect#clicked ~callback:(t#destroy));
1090     let okButton =
1091       GButton.button ~label:"OK" ~packing:t#action_area#add () in
1092     ignore
1093       (okButton#connect#clicked
1094          ~callback:(fun () -> refresh (); t#destroy ()));
1095     ignore (t#connect#destroy ~callback:Main.quit);
1096     grabFocus t;
1097     t#show ();
1098     Main.main ();
1099     releaseFocus ()
1100   in
1101
1102   (**********************************************************************)
1103   (* Add entries to the Help menu                                       *)
1104   (**********************************************************************)
1105   let addDocSection (shortname, (name, docstr)) =
1106     if shortname <> "" && name <> "" then
1107       ignore (helpMenu#add_item
1108                 ~callback:(fun () -> documentation shortname)
1109                 name)
1110   in
1111   Safelist.iter addDocSection Strings.docs;
1112
1113   (**********************************************************************)
1114   (* Add entries to the Ignore menu                                     *)
1115   (**********************************************************************)
1116   let addRegExpByPath pathfunc =
1117     match !current with
1118       Some i ->
1119         addIgnorePattern (pathfunc !theState.(i).ri.path);
1120         ignoreAndRedisplay ()
1121     | None ->
1122         ()
1123   in
1124   grAdd grAction
1125     (ignoreMenu#add_item ~key:_i
1126        ~callback:(fun () -> getLock (fun () -> addRegExpByPath ignorePath))
1127        "Ignore this file permanently");
1128   grAdd grAction
1129     (ignoreMenu#add_item ~key:_E
1130        ~callback:(fun () -> getLock (fun () -> addRegExpByPath ignoreExt))
1131        "Ignore files with this extension");
1132   grAdd grAction
1133     (ignoreMenu#add_item ~key:_N
1134        ~callback:(fun () -> getLock (fun () -> addRegExpByPath ignoreName))
1135        "Ignore files with this name");
1136
1137 (*
1138   grAdd grRestart
1139     (ignoreMenu#add_item ~callback:
1140        (fun () -> getLock ignoreDialog) "Edit ignore patterns");
1141 *)
1142
1143   (**********************************************************************)
1144   (*                       MAIN FUNCTION : SYNCHRONIZE                  *)
1145   (**********************************************************************)
1146   let synchronize () =
1147     if Array.length !theState = 0 then
1148       Trace.status "Nothing to synchronize"
1149     else begin
1150       grSet grAction false;
1151       grSet grDiff false;
1152       grSet grProceed false;
1153       grSet grRestart false;
1154
1155       Trace.status "Propagating changes";
1156       let t = Trace.startTimer "Propagating changes" in
1157       let (start, wait) = Threads.thread_maker () in
1158       let background = let i = 55000 in `RGB (i, i, i) in
1159       let finish i =
1160         redisplay i;
1161         mainWindow#set_row ~background:`WHITE i;
1162         gtk_sync ()
1163       in
1164       for i = 0 to Array.length !theState - 1 do
1165         let theSI = !theState.(i) in
1166         assert (theSI.whatHappened = None);
1167         start
1168           (fun () ->
1169              Threads.do_on_main_thread (fun () ->
1170                mainWindow#set_row ~background i;
1171                makeRowVisible i);
1172              theSI.whatHappened <- Some (Transport.transportItem theSI.ri i);
1173              i)
1174           finish
1175       done;
1176       wait finish;
1177
1178       Trace.showTimer t;
1179       Trace.status "Updating synchronizer state";
1180       let t = Trace.startTimer "Updating synchronizer state" in
1181       Update.commitUpdates();
1182       Trace.showTimer t;
1183       Trace.status "Synchronization complete";
1184
1185       grSet grRestart true
1186     end
1187   in
1188
1189   (**********************************************************************)
1190   (*                  CREATE THE ACTION BAR                             *)
1191   (**********************************************************************)
1192   let actionBar =
1193     GButton.toolbar
1194       ~orientation:`HORIZONTAL ~tooltips:true ~space_size:10
1195       ~packing:toplevelVBox#pack () in
1196
1197   (**********************************************************************)
1198   (*         CREATE AND CONFIGURE THE QUIT BUTTON                       *)
1199   (**********************************************************************)
1200   actionBar#insert_space ();
1201   ignore (actionBar#insert_button ~text:"Quit" ~callback:safeExit ());
1202
1203   (**********************************************************************)
1204   (*         CREATE AND CONFIGURE THE PROCEED BUTTON                    *)
1205   (**********************************************************************)
1206   actionBar#insert_space ();
1207   grAdd grProceed
1208     (actionBar#insert_button ~text:"Proceed"
1209        (* tooltip:"Proceed with displayed actions" *)
1210        ~callback:(fun () ->
1211                     getLock synchronize) ());
1212
1213   (**********************************************************************)
1214   (*           CREATE AND CONFIGURE THE RESCAN BUTTON                   *)
1215   (**********************************************************************)
1216   let detectCmdName = "Restart" in
1217   let detectCmd () =
1218     getLock detectUpdatesAndReconcile;
1219     if Prefs.readPref batch then begin
1220       Prefs.setPref batch Prefs.TempSetting false; synchronize()
1221     end
1222   in
1223   actionBar#insert_space ();
1224   grAdd grRestart
1225     (actionBar#insert_button ~text:detectCmdName ~callback:detectCmd ());
1226
1227   (**********************************************************************)
1228   (* Buttons for <--, -->, Skip                                         *)
1229   (**********************************************************************)
1230   let doAction f =
1231     match !current with
1232       Some i ->
1233         let theSI = !theState.(i) in
1234         begin match theSI.whatHappened, theSI.ri.replicas with
1235           None, Different(_, _, dir) ->
1236             f dir;
1237             redisplay i;
1238             nextInteresting ()
1239         | _ ->
1240             ()
1241         end
1242     | None ->
1243         ()
1244   in
1245   let leftAction     _ = doAction (fun dir -> dir := Replica2ToReplica1) in
1246   let rightAction    _ = doAction (fun dir -> dir := Replica1ToReplica2) in
1247   let questionAction _ = doAction (fun dir -> dir := Conflict) in
1248
1249   (**********************************************************************)
1250   (*             CREATE AND CONFIGURE THE DIFF BUTTON and KEY           *)
1251   (**********************************************************************)
1252   let diffCmd () =
1253     match !current with
1254       Some i ->
1255         getLock (fun () ->
1256           showDiffs !theState.(i).ri
1257             (fun title text -> messageBox ~title text)
1258             Trace.status i)
1259     | None ->
1260         ()
1261   in
1262
1263   actionBar#insert_space ();
1264   grAdd grAction
1265     (actionBar#insert_button
1266        ~icon:((GMisc.pixmap leftArrowBlack ())#coerce)
1267        ~callback:leftAction ());
1268   actionBar#insert_space ();
1269   grAdd grAction
1270     (actionBar#insert_button
1271        ~icon:((GMisc.pixmap rightArrowBlack ())#coerce)
1272        ~callback:rightAction ());
1273   actionBar#insert_space ();
1274   grAdd grAction
1275     (actionBar#insert_button ~text:"Skip" ~callback:questionAction ());
1276   actionBar#insert_space ();
1277   grAdd grDiff (actionBar#insert_button ~text:"Diff" ~callback:diffCmd ());
1278
1279   (**********************************************************************)
1280   (* Configure keyboard commands                                        *)
1281   (**********************************************************************)
1282   ignore
1283     (mainWindow#event#connect#key_press ~callback:
1284        begin fun ev ->
1285          let key = GdkEvent.Key.keyval ev in
1286          if key = _Left then begin
1287            leftAction (); GtkSignal.stop_emit (); true
1288          end else if key = _Right then begin
1289            rightAction (); GtkSignal.stop_emit (); true
1290          end else
1291            false
1292        end);
1293
1294   (**********************************************************************)
1295   (* Add entries to the Action menu                                     *)
1296   (**********************************************************************)
1297   let (root1,root2) = Globals.getReplicaRoots () in
1298   let loc1 = root2hostname root1 in
1299   let loc2 = root2hostname root2 in
1300   let descr =
1301     if loc1 = loc2 then "left to right" else
1302     Printf.sprintf "from %s to %s" loc1 loc2
1303   in
1304   let left =
1305     actionsMenu#add_item ~key:_greater ~callback:rightAction
1306       ("Propagate " ^ descr) in
1307   grAdd grAction left;
1308   left#add_accelerator ~group:accel_group ~modi:[`SHIFT] _greater;
1309
1310   let descl =
1311     if loc1 = loc2 then "right to left" else
1312     Printf.sprintf "from %s to %s" loc2 loc1
1313   in
1314   let right =
1315     actionsMenu#add_item ~key:_less ~callback:leftAction
1316       ("Propagate " ^ descl) in
1317   grAdd grAction right;
1318   right#add_accelerator ~group:accel_group ~modi:[`SHIFT] _less;
1319
1320   grAdd grAction
1321     (actionsMenu#add_item ~key:_slash ~callback:questionAction
1322        "Do not propagate changes");
1323
1324   ignore (actionsMenu#add_separator ());
1325   grAdd grDiff (actionsMenu#add_item ~key:_d ~callback:diffCmd "Show diffs");
1326
1327   (**********************************************************************)
1328   (* Add commands to the Synchronization menu                           *)
1329   (**********************************************************************)
1330   grAdd grProceed
1331     (fileMenu#add_item ~key:_g
1332        ~callback:(fun () ->
1333                     getLock synchronize)
1334        "Proceed");
1335   grAdd grRestart (fileMenu#add_item ~key:_r ~callback:detectCmd detectCmdName);
1336   grAdd grRestart
1337     (fileMenu#add_item ~key:_a
1338        ~callback:(fun () ->
1339                     getLock detectUpdatesAndReconcile;
1340                     getLock synchronize)
1341        "Atomically detect updates and proceed");
1342   ignore (fileMenu#add_separator ());
1343   let cm =
1344     fileMenu#add_check_item ~active:(Prefs.readPref Transport.backups)
1345       ~callback:(fun b -> Prefs.setPref Transport.backups Prefs.TempSetting b)
1346       "Make backups"
1347   in
1348   cm#set_show_toggle true;
1349   grAdd grRestart cm;
1350   ignore (fileMenu#add_separator ());
1351   ignore (fileMenu#add_item ~key:_q ~callback:safeExit "Quit");
1352
1353   grSet grAction false;
1354   grSet grDiff false;
1355   grSet grProceed false;
1356   grSet grRestart false;
1357
1358   ignore (toplevelWindow#event#connect#delete ~callback:
1359             (fun _ -> safeExit (); true));
1360   toplevelWindow#show ();
1361   currentWindow := Some toplevelWindow;
1362   detectCmd ()
1363
1364 (**********************************************************************)
1365 (* Starting up...                                                     *)
1366 (**********************************************************************)
1367 let start _ =
1368   begin try
1369     (* Initialize the library *)
1370     ignore (Main.init ());
1371
1372     Util.warnPrinter := Some (warnBox "Warning");
1373     (* Ask the Remote module to call us back at regular intervals during
1374        long network operations. *)
1375     Threads.tickProc := Some gtk_sync;
1376
1377     (**********************************************************************)
1378     (* Set things up to initialize the client/server connection and       *)
1379     (* detect updates after the ui is displayed.                          *)
1380     (* This makes a difference when the replicas are large and it takes   *)
1381     (* a lot of time to detect updates.                                   *)
1382     (**********************************************************************)
1383     let msg = ref None in
1384     Uicommon.uiInit
1385       profileSelect
1386       rootSelect
1387       (fun () ->
1388          let w =
1389            GWindow.window ~kind:`TOPLEVEL ~position:`CENTER
1390              ~wm_name:"Unison" ~border_width:16 () in
1391          ignore (GMisc.label ~text: "Contacting server..."
1392                    ~packing:(w#add) ());
1393          w#show ();
1394          ignore (w#event#connect#delete ~callback:(fun _ -> exit 0));
1395          msg := Some w)
1396       (fun () ->
1397          begin match !msg with
1398            None   -> ()
1399          | Some w -> w#destroy ()
1400          end;
1401          createToplevelWindow ());
1402
1403     (**********************************************************************)
1404     (* Display the ui                                                     *)
1405     (**********************************************************************)
1406     ignore (Timeout.add 500 (fun _ -> true));
1407               (* Hack: this allows signals such as SIGINT to be
1408                  handled even when Gtk is waiting for events *)
1409     Main.main ()
1410   with exn ->
1411     fatalError (exn2string exn)
1412   end
1413
1414 end (* module Private *)
1415
1416 (**********************************************************************)
1417 (*                               MODULE MAIN                          *)
1418 (**********************************************************************)
1419
1420 module Body : Uicommon.UI = struct
1421
1422 let start = function
1423     Text -> Uitext.Body.start Text
1424   | Graphic -> Private.start Graphic
1425
1426 end (* module Body *)
1427
1428 (*
1429 FIX:
1430 - Édition (minimale) et création des profiles
1431 - Profile par défaut
1432 - Sanity checks pour "Root selection"
1433 - Edition du filtrage
1434 *)