10 (**********************************************************************)
11 (* GRAPHICAL INTERFACE *)
12 (**********************************************************************)
14 module Private : Uicommon.UI = struct
19 let debugprogress = Trace.debug "progress"
21 (**********************************************************************)
23 (**********************************************************************)
25 let fontMonospaceMedium =
26 if Sys.os_type = "Win32" then
27 lazy (Gdk.Font.load "-*-Courier New-Medium-R-Normal--*-110-*-*-*-*-*-*")
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-*-*-*-*-*-*")
34 lazy (Gdk.Font.load "-*-Courier-Bold-R-Normal--*-120-*-*-*-*-*-*")
36 (**********************************************************************)
37 (* UI state variables *)
38 (**********************************************************************)
40 type stateItem = { ri : reconItem;
41 mutable bytesTransferred : int;
42 mutable whatHappened : unit confirmation option }
43 let theState = ref [||]
45 let current = ref None
47 let currentWindow = ref None
49 match !currentWindow with
50 Some w -> t#set_transient_for w;
51 w#misc#set_sensitive false
54 begin match !currentWindow with
55 Some w -> w#misc#set_sensitive true
59 (**********************************************************************)
61 (**********************************************************************)
67 Trace.message "Synchronizer is busy, please wait..\n"
69 busy := true; f (); busy := false
72 (**********************************************************************)
74 (**********************************************************************)
76 class scrolled_text ?editable ?word_wrap ?width ?height ?packing ?show
79 GBin.scrolled_window ?width ?height ?packing ~show:false
80 ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC ()
82 let text = GEdit.text ?editable ?word_wrap ~packing:sw#add () in
84 inherit GObj.widget_full sw#as_widget
86 method insert ?(font=fontMonospaceMedium) s =
88 text#delete_text ~start:0 ~stop:text#length;
89 text#insert ~font:(Lazy.force font) s;
91 method show () = sw#misc#show ()
93 if show <> Some false then sw#misc#show ()
96 let gtk_sync () = while Glib.Main.iteration false do () done
98 (**********************************************************************)
99 (* YES OR NO FUNCTION *)
100 (**********************************************************************)
101 (* val yesOrNo : string -> string -> (unit -> unit) -> (unit -> 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
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
117 (yes#connect#clicked ~callback:(fun () -> t#destroy (); yesFunction ()));
119 (no#connect#clicked ~callback:(fun () -> t#destroy (); noFunction ()));
121 ignore (t#connect#destroy ~callback:Main.quit);
125 (**********************************************************************)
126 (* SAFE EXIT FUNCTION *)
127 (**********************************************************************)
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
134 if not !inExit then begin
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 () -> ());
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
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
154 ignore (ok#connect#clicked ~callback:(fun () -> t#destroy()));
156 (* Do nothing until user destroys window *)
157 ignore (t#connect#destroy ~callback:Main.quit);
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 =
167 let t = GWindow.dialog ~title ~wm_name:title ~modal:true ~position:`CENTER () in
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
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));
178 (* Do nothing until user destroys window *)
179 ignore (t#connect#destroy ~callback:Main.quit);
184 (**********************************************************************)
185 (* Standard file dialog *)
186 (**********************************************************************)
187 let file_dialog ~title ~callback ?filename () =
188 let sel = GWindow.file_selection ~title ~modal:true ?filename () in
190 ignore (sel#cancel_button#connect#clicked ~callback:sel#destroy);
191 ignore (sel#ok_button#connect#clicked ~callback:
193 let name = sel#get_filename in
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 ();
208 let makeGetRoot title =
210 GBin.frame ~label:title ~border_width:2 ~packing:(t#vbox#add) () in
212 let vb = GPack.vbox ~border_width:4 ~packing:fr#add () in
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
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 ()
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
234 varLocalRemote := `Local;
235 hostE#misc#set_sensitive false;
236 b#misc#set_sensitive true
239 varLocalRemote := `Remote;
240 hostE#misc#set_sensitive true;
241 b#misc#set_sensitive false
243 ignore (localB#connect#clicked ~callback:localState);
244 ignore (remoteB#connect#clicked ~callback:remoteState);
247 let filePart = fileE#text in
248 let remoteHost = hostE#text in
249 (* FIX: should do sanity checking here *)
250 match !varLocalRemote with
252 | `Remote -> "//"^remoteHost^"/"^filePart in
256 let getRoot1 = makeGetRoot "Root 1" in
257 let getRoot2 = makeGetRoot "Root 2" in
259 let f3 = t#action_area in
261 let root1 = getRoot1() in
262 let root2 = getRoot2() in
263 Prefs.setPref Uicommon.roots Prefs.TempSetting [root1;root2];
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);
273 (* The profile editing dialog has been installed into the Gtk
274 main interaction loop; wait until it completes. *)
276 ignore (t#connect#destroy ~callback:Main.quit);
279 (**********************************************************************)
280 (* The root selection dialog *)
281 (**********************************************************************)
282 let editProfile prof =
284 Scan the profile (if it is defined)
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 ();
292 let vb = GPack.vbox ~border_width:4 ~packing:t#vbox#add () in
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) ()
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
313 varLocalRemote := `Local;
314 hostE#set_editable false;
315 b#misc#set_state `NORMAL
318 varLocalRemote := `Remote;
319 hostE#set_editable true;
320 b#misc#set_state `INSENSITIVE
322 ignore (localB#connect#clicked ~callback:localState);
323 ignore (remoteB#connect#clicked ~callback:remoteState);
326 let filePart = fileE#text in
327 let remoteHost = hostE#text in
328 (* FIX: should do sanity checking here *)
329 match !varLocalRemote with
331 | `Remote -> "//"^remoteHost^"/"^filePart in
336 ignore (GMisc.label ~text:"Root 1:" ~xalign:0.
337 ~packing:(vb#pack ~expand:true ~padding:4) ());
338 let getRoot1 = makeGetRoot() in
340 ignore (GMisc.label ~text:"Root 2:" ~xalign:0.
341 ~packing:(vb#pack ~expand:true ~padding:4) ());
342 let getRoot2 = makeGetRoot() in
344 let f3 = t#action_area in
346 let root1 = getRoot1() in
347 let root2 = getRoot2() in
348 Prefs.setPref Uicommon.roots Prefs.PermanentSetting [root1;root2];
351 let okButton = GButton.button ~label:"OK" ~packing:f3#add () in
352 ignore (okButton#connect#clicked ~callback:okCommand);
353 let cancelCommand() =
356 let cancelButton = GButton.button ~label:"Cancel" ~packing:f3#add () in
357 ignore (cancelButton#connect#clicked ~callback:cancelCommand);
359 (* The profile editing dialog has been installed into the Gtk
360 main interaction loop; wait until it completes. *)
362 ignore (t#connect#destroy ~callback:Main.quit);
365 (**********************************************************************)
366 (* Documentation window *)
367 (**********************************************************************)
368 let documentation sect =
369 let title = "Documentation" in
370 let t = GWindow.dialog ~title ~wm_name:title () in
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));
378 let (name, docstr) = List.assoc sect Strings.docs in
379 let hb = GPack.hbox ~packing:(t#vbox#pack ~expand:false ~padding:2) () in
381 GMenu.option_menu ~packing:(hb#pack ~fill:false) () in
383 let charW = Gdk.Font.char_width (Lazy.force fontMonospaceMedium) 'M' in
386 new scrolled_text ~editable:false
387 ~width:(charW * 80) ~height:(charH * 20) ~packing:t#vbox#add ()
389 t_text#insert docstr;
391 let sect_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;
398 let item = GMenu.menu_item ~label:name ~packing:menu#append () in
400 (item#connect#activate ~callback:(fun () -> t_text#insert docstr))
403 Safelist.iter addDocSection Strings.docs;
404 optionmenu#set_menu menu;
405 optionmenu#set_history !sect_idx;
409 (**********************************************************************)
410 (* The profile selection dialog *)
411 (**********************************************************************)
412 let profileSelect cont =
414 - Choix du profil par defaut
416 let profilesAndRoots =
420 let filename = fspath2string (Os.fileInUnisonDir f) in
423 (Safelist.filter (fun (n, v) -> n = "root")
424 (Prefs.scanPreferencesFile filename))
426 (Filename.chop_suffix f ".prf", roots))
427 (Files.ls (fspath2string Os.synchronizerFspath) "*.prf")) in
429 (* The selected profile *)
430 let selection = ref None in
432 (* Build the dialog *)
433 let t = GWindow.dialog ~title:"Profiles" ~wm_name:"Profiles" () in
436 match !selection with
438 Globals.prefsFileName := profile ^ ".prf";
439 currentWindow := None;
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;
458 ~text:"Select an existing profile or create a new one"
459 ~xpad:2 ~ypad:2 ~packing:vb#pack ());
462 GBin.scrolled_window ~packing:vb#add ~height:100
463 ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
465 let lst = GList.clist ~selection_mode:`BROWSE ~packing:(sw#add) () in
466 let fillLst default =
469 let selRow = ref 0 in
470 let i = ref 0 in (* FIX: Work around a lablgtk bug *)
472 (fun (profile, roots) ->
473 ignore (lst#append [profile]);
474 if profile = default then selRow := !i;
475 lst#set_row_data !i (profile, roots);
477 (List.sort (fun (p, _) (p', _) -> compare p p') !profilesAndRoots);
479 let p = if r < 2 then 0. else float !selRow /. float (r - 1) in
480 lst#scroll_vertical `JUMP p;
484 GPack.table ~rows:2 ~columns:2 ~packing:vb#pack ()
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) ());
492 GEdit.entry ~packing:(tbl#attach ~left:1 ~top:0) ~editable:false () in
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;
498 GPack.hbox ~border_width:2 ~spacing:2 ~packing:(vb#pack ~expand:false) ()
501 GButton.button ~label:"Create new profile"
502 ~packing:hb#pack () in
503 ignore (nw#connect#clicked ~callback:(fun () ->
505 GWindow.dialog ~title:"New profile" ~wm_name:"New profile" ~modal:true ()
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 ();
515 let exit () = t#destroy (); Main.quit () in
516 ignore (t#event#connect#delete ~callback:(fun _ -> exit (); true));
518 let f3 = t#action_area in
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")
529 ^ "\" already exists!\nPlease select another name.")
531 (* Make an empty file *)
534 [Open_wronly; Open_creat; Open_trunc] 0o600 filename in
536 profilesAndRoots := (profile, [])::!profilesAndRoots;
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);
551 GButton.button ~label:"Edit" (*~packing:(hb#pack ~expand:false)*) () in
553 GButton.button ~label:"Set default" (*~packing:(hb#pack ~expand:false)*) ()
556 GButton.button ~label:"Help"
557 ~packing:(hb#pack ~expand:false ~from:`END) () in
558 ignore (hlp#connect#clicked ~callback:(fun () -> documentation "tutorial"));
560 ignore (lst#connect#unselect_row ~callback:(fun _ _ _ ->
561 root1#set_text ""; root2#set_text "";
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 *)
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
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
591 lst#misc#grab_focus ();
592 currentWindow := Some (t :> GWindow.window);
593 ignore (t#event#connect#delete ~callback:(fun _ -> Main.quit (); true));
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
608 new scrolled_text ~editable:false
609 ~width:(charW * 80) ~height:(charH * 20) ~packing:t#vbox#add ()
611 t_text#insert message;
612 ignore (t#event#connect#delete ~callback:(fun _ -> action t (); true));
620 (**********************************************************************)
621 (* Fatal error handling *)
622 (**********************************************************************)
624 messageBox ~title:"Fatal Error" ~label:"Exit" ~modal:true
625 ~action:(fun t () -> exit 1)
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
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
645 (**********************************************************************)
646 (* Create the menu bar *)
647 (**********************************************************************)
649 GMenu.menu_bar ~border_width:2 ~packing:toplevelVBox#pack ()
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)
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
666 (**********************************************************************)
667 (* Create the main window *)
668 (**********************************************************************)
671 GBin.scrolled_window ~packing:(toplevelVBox#add)
672 ~height:(Prefs.readPref mainWindowHeight * 12)
673 ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
676 ~columns:5 ~titles_show:true ~selection_mode:`BROWSE ~packing:sw#add ()
678 mainWindow#misc#grab_focus ();
679 (* FIX: roots2string should return a pair *)
680 let s = roots2string () in
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" |];
688 let font = mainWindow#misc#style#font in
689 4 + max (Gdk.Font.string_width font "working")
690 (Gdk.Font.string_width font "skipped")
692 mainWindow#set_column ~justification:`CENTER 1;
693 mainWindow#set_column
694 ~justification:`CENTER ~auto_resize:false ~width:status_width 3;
696 (**********************************************************************)
697 (* Create the details window *)
698 (**********************************************************************)
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
705 GBin.scrolled_window ~packing:(toplevelVBox#pack ~expand:false)
706 ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
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 () =
717 grSet grAction false;
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)
726 grSet grAction activate1;
727 grSet grDiff activate2
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
736 float row /. float (mainWindow#rows + 1) *. (upper-.lower) +. lower
738 adj#set_value (min v (upper -. adj#page_size))
742 let updateDetails () =
743 detailsWindow#freeze ();
744 detailsWindow#delete_text ~start:0 ~stop:detailsWindow#length;
745 begin match !current with
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
760 detailsWindow#thaw ();
764 (**********************************************************************)
765 (* CREATE THE STATUS WINDOW *)
766 (**********************************************************************)
769 GMisc.statusbar ~packing:toplevelVBox#pack () in
770 let statusContext = statusWindow#new_context ~name:"status" in
771 ignore (statusContext#push "");
773 let displayStatus s1 s2 =
774 Threads.do_on_main_thread (fun () ->
775 (* Concatenate the new message *)
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 *)
784 (* Tell the Trace module about the status printer *)
785 Trace.statusPrinter := Some displayStatus;
787 (**********************************************************************)
788 (* FUNCTIONS USED TO PRINT IN THE MAIN WINDOW *)
789 (**********************************************************************)
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.)
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 ()));
802 let nextInteresting () =
803 let l = Array.length !theState in
804 let start = match !current with Some i -> i + 1 | None -> 0 in
807 match !theState.(i).ri.replicas with
808 Different (_, _, dir)
809 when not (Prefs.readPref auto) || !dir = Conflict ->
816 let selectSomethingIfPossible () =
817 if !current=None then nextInteresting ()
821 let oldPath = if i = 0 then emptypath else !theState.(i-1).ri.path in
823 match !theState.(i).whatHappened with
826 match !theState.(i).ri.replicas with
827 Different(_,_,{contents=Conflict}) | Problem _ ->
831 Succeeded _ -> "done "
832 | Failed _ -> "failed"
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))
844 GDraw.pixmap_from_xpm_d ~window:toplevelWindow ~data:Pixmaps.copyAB () in
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
851 GDraw.pixmap_from_xpm_d
852 ~window:toplevelWindow ~data:Pixmaps.copyBAblack () in
854 GDraw.pixmap_from_xpm_d ~window:toplevelWindow ~data:Pixmaps.ignore () in
856 GDraw.pixmap_from_xpm_d ~window:toplevelWindow ~data:Pixmaps.success () in
858 GDraw.pixmap_from_xpm_d ~window:toplevelWindow ~data:Pixmaps.failure () in
860 let displayArrow i action =
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
869 let displayStatusIcon i status =
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
877 mainWindow#freeze ();
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
884 selectSomethingIfPossible ();
885 begin match !current with Some idx -> select idx | None -> () end;
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;
900 if !current = Some i then updateDetails ();
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
909 if b=0 || len = 0 then "working "
910 else if len = 0 then sprintf "%8d" b
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;
922 (* Install showProgress so that we get called back by low-level
923 file transfer stuff *)
924 Util.progressPrinter := Some(showProgress);
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
936 theState := Array.of_list (Safelist.filter keep lst)
941 (fun j sI -> if keep sI then l := sI::!l
942 else if j < !i then decr i)
944 current := if !l = [] then None else Some !i;
945 theState := Array.of_list (Safelist.rev !l)
950 (**********************************************************************)
951 (* FUNCTION DETECT UPDATES *)
952 (**********************************************************************)
954 let detectUpdatesAndReconcile () =
955 grSet grAction false;
957 grSet grProceed false;
958 grSet grRestart false;
960 let (r1,r2) = Globals.getReplicaRoots () in
961 let t = Trace.startTimer "Checking for updates" in
963 let updates = Update.findUpdates () in
967 let reconcile updates =
968 let t = Trace.startTimer "Reconciling" in
969 Recon.reconcileAll updates
971 let reconItemList = reconcile (findUpdates ()) in
973 if reconItemList = [] then
974 Trace.status "Everything is up to date"
976 Trace.status ("Check and/or adjust selected actions; "
977 ^ "then press Proceed");
981 (fun ri -> { ri = ri; bytesTransferred = 0; whatHappened = None })
985 grSet grProceed (Array.length !theState > 0);
989 (**********************************************************************)
990 (* The ignore dialog *)
991 (**********************************************************************)
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
999 GList.clist ~columns:1 ~titles_show:false ~packing:hbox#add
1000 ~vadjustment:sb#adjustment ~width:400 ~height:150 () in
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
1010 (regExpWindow#connect#select_row ~callback:
1011 (fun ~row ~column ~event -> selectedRow := Some row));
1013 (regExpWindow#connect#unselect_row ~callback:
1014 (fun ~row ~column ~event -> selectedRow := None));
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
1022 let theRegExp = entry#text in
1023 if theRegExp<>"" then begin
1025 regExpWindow#unselect_all ();
1026 ignore (regExpWindow#append [theRegExp]);
1027 maybeGettingSmaller := true
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 ();
1036 (* Configure the delete button *)
1038 match !selectedRow with
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
1048 let deleteButton = GButton.button ~label:"Delete"
1049 ~packing:hbox#pack () in
1050 ignore (deleteButton#connect#clicked ~callback:delete);
1053 (regExpWindow#event#connect#after#key_press ~callback:
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;
1060 end else if key = _Delete then begin
1066 (* A function to refresh the state and ignore list *)
1068 let theRegexps = ref [] in
1069 for i = regExpWindow#rows - 1 downto 0 do
1070 theRegexps := regExpWindow#cell_text i 0 :: !theRegexps
1072 Pred.intern Globals.ignore (!theRegexps);
1073 if !maybeGettingBigger || !maybeGettingSmaller then begin
1074 Globals.savePrefs();
1075 Globals.propagatePrefs()
1077 if !maybeGettingBigger then detectUpdatesAndReconcile ()
1078 else if !maybeGettingSmaller then ignoreAndRedisplay();
1079 maybeGettingBigger := false;
1080 maybeGettingSmaller := false;
1083 (* Install the main buttons *)
1085 GButton.button ~label:"Apply" ~packing:t#action_area#add () in
1086 ignore (applyButton#connect#clicked ~callback:refresh);
1088 GButton.button ~label:"Cancel" ~packing:t#action_area#add () in
1089 ignore (cancelButton#connect#clicked ~callback:(t#destroy));
1091 GButton.button ~label:"OK" ~packing:t#action_area#add () in
1093 (okButton#connect#clicked
1094 ~callback:(fun () -> refresh (); t#destroy ()));
1095 ignore (t#connect#destroy ~callback:Main.quit);
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)
1111 Safelist.iter addDocSection Strings.docs;
1113 (**********************************************************************)
1114 (* Add entries to the Ignore menu *)
1115 (**********************************************************************)
1116 let addRegExpByPath pathfunc =
1119 addIgnorePattern (pathfunc !theState.(i).ri.path);
1120 ignoreAndRedisplay ()
1125 (ignoreMenu#add_item ~key:_i
1126 ~callback:(fun () -> getLock (fun () -> addRegExpByPath ignorePath))
1127 "Ignore this file permanently");
1129 (ignoreMenu#add_item ~key:_E
1130 ~callback:(fun () -> getLock (fun () -> addRegExpByPath ignoreExt))
1131 "Ignore files with this extension");
1133 (ignoreMenu#add_item ~key:_N
1134 ~callback:(fun () -> getLock (fun () -> addRegExpByPath ignoreName))
1135 "Ignore files with this name");
1139 (ignoreMenu#add_item ~callback:
1140 (fun () -> getLock ignoreDialog) "Edit ignore patterns");
1143 (**********************************************************************)
1144 (* MAIN FUNCTION : SYNCHRONIZE *)
1145 (**********************************************************************)
1146 let synchronize () =
1147 if Array.length !theState = 0 then
1148 Trace.status "Nothing to synchronize"
1150 grSet grAction false;
1152 grSet grProceed false;
1153 grSet grRestart false;
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
1161 mainWindow#set_row ~background:`WHITE i;
1164 for i = 0 to Array.length !theState - 1 do
1165 let theSI = !theState.(i) in
1166 assert (theSI.whatHappened = None);
1169 Threads.do_on_main_thread (fun () ->
1170 mainWindow#set_row ~background i;
1172 theSI.whatHappened <- Some (Transport.transportItem theSI.ri i);
1179 Trace.status "Updating synchronizer state";
1180 let t = Trace.startTimer "Updating synchronizer state" in
1181 Update.commitUpdates();
1183 Trace.status "Synchronization complete";
1185 grSet grRestart true
1189 (**********************************************************************)
1190 (* CREATE THE ACTION BAR *)
1191 (**********************************************************************)
1194 ~orientation:`HORIZONTAL ~tooltips:true ~space_size:10
1195 ~packing:toplevelVBox#pack () in
1197 (**********************************************************************)
1198 (* CREATE AND CONFIGURE THE QUIT BUTTON *)
1199 (**********************************************************************)
1200 actionBar#insert_space ();
1201 ignore (actionBar#insert_button ~text:"Quit" ~callback:safeExit ());
1203 (**********************************************************************)
1204 (* CREATE AND CONFIGURE THE PROCEED BUTTON *)
1205 (**********************************************************************)
1206 actionBar#insert_space ();
1208 (actionBar#insert_button ~text:"Proceed"
1209 (* tooltip:"Proceed with displayed actions" *)
1210 ~callback:(fun () ->
1211 getLock synchronize) ());
1213 (**********************************************************************)
1214 (* CREATE AND CONFIGURE THE RESCAN BUTTON *)
1215 (**********************************************************************)
1216 let detectCmdName = "Restart" in
1218 getLock detectUpdatesAndReconcile;
1219 if Prefs.readPref batch then begin
1220 Prefs.setPref batch Prefs.TempSetting false; synchronize()
1223 actionBar#insert_space ();
1225 (actionBar#insert_button ~text:detectCmdName ~callback:detectCmd ());
1227 (**********************************************************************)
1228 (* Buttons for <--, -->, Skip *)
1229 (**********************************************************************)
1233 let theSI = !theState.(i) in
1234 begin match theSI.whatHappened, theSI.ri.replicas with
1235 None, Different(_, _, dir) ->
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
1249 (**********************************************************************)
1250 (* CREATE AND CONFIGURE THE DIFF BUTTON and KEY *)
1251 (**********************************************************************)
1256 showDiffs !theState.(i).ri
1257 (fun title text -> messageBox ~title text)
1263 actionBar#insert_space ();
1265 (actionBar#insert_button
1266 ~icon:((GMisc.pixmap leftArrowBlack ())#coerce)
1267 ~callback:leftAction ());
1268 actionBar#insert_space ();
1270 (actionBar#insert_button
1271 ~icon:((GMisc.pixmap rightArrowBlack ())#coerce)
1272 ~callback:rightAction ());
1273 actionBar#insert_space ();
1275 (actionBar#insert_button ~text:"Skip" ~callback:questionAction ());
1276 actionBar#insert_space ();
1277 grAdd grDiff (actionBar#insert_button ~text:"Diff" ~callback:diffCmd ());
1279 (**********************************************************************)
1280 (* Configure keyboard commands *)
1281 (**********************************************************************)
1283 (mainWindow#event#connect#key_press ~callback:
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
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
1301 if loc1 = loc2 then "left to right" else
1302 Printf.sprintf "from %s to %s" loc1 loc2
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;
1311 if loc1 = loc2 then "right to left" else
1312 Printf.sprintf "from %s to %s" loc2 loc1
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;
1321 (actionsMenu#add_item ~key:_slash ~callback:questionAction
1322 "Do not propagate changes");
1324 ignore (actionsMenu#add_separator ());
1325 grAdd grDiff (actionsMenu#add_item ~key:_d ~callback:diffCmd "Show diffs");
1327 (**********************************************************************)
1328 (* Add commands to the Synchronization menu *)
1329 (**********************************************************************)
1331 (fileMenu#add_item ~key:_g
1332 ~callback:(fun () ->
1333 getLock synchronize)
1335 grAdd grRestart (fileMenu#add_item ~key:_r ~callback:detectCmd detectCmdName);
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 ());
1344 fileMenu#add_check_item ~active:(Prefs.readPref Transport.backups)
1345 ~callback:(fun b -> Prefs.setPref Transport.backups Prefs.TempSetting b)
1348 cm#set_show_toggle true;
1350 ignore (fileMenu#add_separator ());
1351 ignore (fileMenu#add_item ~key:_q ~callback:safeExit "Quit");
1353 grSet grAction false;
1355 grSet grProceed false;
1356 grSet grRestart false;
1358 ignore (toplevelWindow#event#connect#delete ~callback:
1359 (fun _ -> safeExit (); true));
1360 toplevelWindow#show ();
1361 currentWindow := Some toplevelWindow;
1364 (**********************************************************************)
1365 (* Starting up... *)
1366 (**********************************************************************)
1369 (* Initialize the library *)
1370 ignore (Main.init ());
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;
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
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) ());
1394 ignore (w#event#connect#delete ~callback:(fun _ -> exit 0));
1397 begin match !msg with
1399 | Some w -> w#destroy ()
1401 createToplevelWindow ());
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 *)
1411 fatalError (exn2string exn)
1414 end (* module Private *)
1416 (**********************************************************************)
1418 (**********************************************************************)
1420 module Body : Uicommon.UI = struct
1422 let start = function
1423 Text -> Uitext.Body.start Text
1424 | Graphic -> Private.start Graphic
1426 end (* module Body *)
1430 - Édition (minimale) et création des profiles
1431 - Profile par défaut
1432 - Sanity checks pour "Root selection"
1433 - Edition du filtrage