From vouillon at seas.upenn.edu Mon Aug 3 13:09:46 2009 From: vouillon at seas.upenn.edu (vouillon@seas.upenn.edu) Date: Mon, 3 Aug 2009 13:09:46 -0400 Subject: [Unison-hackers] [unison-svn] r383 - in trunk/src: . ubase Message-ID: <200908031709.n73H9lvO023879@yaws.seas.upenn.edu> Author: vouillon Date: 2009-08-03 13:09:46 -0400 (Mon, 03 Aug 2009) New Revision: 383 Modified: trunk/src/RECENTNEWS trunk/src/copy.ml trunk/src/mkProjectInfo.ml trunk/src/pixmaps.ml trunk/src/ubase/util.ml trunk/src/uicommon.ml trunk/src/uigtk2.ml Log: * GTK UI: - pop up a summary window when the replicas are not fully synchronized after transport - always show the main window - put a white border around pixmaps (arrows, ...) for better contrast - allow simultaneous selection of several items - several other small tweaks... * Improved arguments to the external program used for copying large files Modified: trunk/src/RECENTNEWS =================================================================== --- trunk/src/RECENTNEWS 2009-07-30 16:58:35 UTC (rev 382) +++ trunk/src/RECENTNEWS 2009-08-03 17:09:46 UTC (rev 383) @@ -1,5 +1,19 @@ CHANGES FROM VERSION 2.37.5 +* GTK UI: + - pop up a summary window when the replicas are not fully + synchronized after transport + - always show the main window + - put a white border around pixmaps (arrows, ...) for better + contrast + - allow simultaneous selection of several items + - several other small tweaks... +* Improved arguments to the external program used for copying large + files + +------------------------------- +CHANGES FROM VERSION 2.37.5 + * Windows text UI: now put the console into UTF-8 output mode. This is the right thing to do when in Unicode mode, and is no worse than what we had previously otherwise (the console use some esoteric Modified: trunk/src/copy.ml =================================================================== --- trunk/src/copy.ml 2009-07-30 16:58:35 UTC (rev 382) +++ trunk/src/copy.ml 2009-08-03 17:09:46 UTC (rev 383) @@ -568,7 +568,7 @@ (****) let copyprog = - Prefs.createString "copyprog" "rsync --inplace --compress" + Prefs.createString "copyprog" "rsync --partial --inplace --compress" "!external program for copying large files" ("A string giving the name of an " ^ "external program that can be used to copy large files efficiently " @@ -577,7 +577,8 @@ ^ "options---most users should not need to change it.") let copyprogrest = - Prefs.createString "copyprogrest" "rsync --partial --inplace --compress" + Prefs.createString + "copyprogrest" "rsync --partial --append-verify --compress" "!variant of copyprog for resuming partial transfers" ("A variant of {\\tt copyprog} that names an external program " ^ "that should be used to continue the transfer of a large file " Modified: trunk/src/mkProjectInfo.ml =================================================================== --- trunk/src/mkProjectInfo.ml 2009-07-30 16:58:35 UTC (rev 382) +++ trunk/src/mkProjectInfo.ml 2009-08-03 17:09:46 UTC (rev 383) @@ -99,3 +99,4 @@ + Modified: trunk/src/pixmaps.ml =================================================================== --- trunk/src/pixmaps.ml 2009-07-30 16:58:35 UTC (rev 382) +++ trunk/src/pixmaps.ml 2009-08-03 17:09:46 UTC (rev 383) @@ -18,140 +18,147 @@ let copyAB color = [| (* width height num_colors chars_per_pixel *) -" 28 14 2 1"; +" 28 14 3 1"; (* colors *) ". c None"; "# c #" ^ color; +" c #ffffff"; (* pixels *) "............................"; "............................"; +"..................... ......"; +".................... # ....."; +"................... ### ..."; +". #### ."; +" ########################## "; +" ########################## "; +". #### ."; +"................... ### ..."; +".................... # ....."; +"..................... ......"; "............................"; -"......................#....."; -".....................###...."; -"......................####.."; -"..##########################"; -"..##########################"; -"......................####.."; -".....................###...."; -"......................#....."; -"............................"; -"............................"; "............................" |] let copyBA color = [| (* width height num_colors chars_per_pixel *) -" 28 14 2 1"; +" 28 14 3 1"; (* colors *) ". c None"; "# c #" ^ color; +" c #ffffff"; (* pixels *) "............................"; "............................"; +"...... ....................."; +"..... # ...................."; +"... ### ..................."; +". #### ."; +" ########################## "; +" ########################## "; +". #### ."; +"... ### ..................."; +"..... # ...................."; +"...... ....................."; "............................"; -".....#......................"; -"....###....................."; -"..####......................"; -"##########################.."; -"##########################.."; -"..####......................"; -"....###....................."; -".....#......................"; -"............................"; -"............................"; "............................" |] let mergeLogo color = [| (* width height num_colors chars_per_pixel *) -" 28 14 2 1"; +" 28 14 3 1"; (* colors *) ". c None"; "# c #" ^ color; +" c #ffffff"; (* pixels *) "............................"; -"............................"; -".........##......##........."; -".........###....###........."; -".........####..####........."; -".........##.####.##........."; -".........##..##..##........."; -".........##......##........."; -".........##......##........."; -".........##......##........."; -".........##......##........."; -".........##......##........."; -"............................"; +"......... ...... ........."; +"........ ## .... ## ........"; +"........ ### .. ### ........"; +"........ #### #### ........"; +"........ ## #### ## ........"; +"........ ## ## ## ........"; +"........ ## . . ## ........"; +"........ ## .... ## ........"; +"........ ## .... ## ........"; +"........ ## .... ## ........"; +"........ ## .... ## ........"; +"......... ...... ........."; "............................" |] let ignore color = [| (* width height num_colors chars_per_pixel *) -" 20 14 2 1"; +" 20 14 3 1"; (* colors *) " c None"; "* c #" ^ color; +". c #ffffff"; (* pixels *) -" "; -" ***** "; -" ** ** "; -" ** ** "; -" ** "; -" ** "; -" ** "; -" ** "; -" ** "; -" "; -" "; -" ** "; -" ** "; -" " +" ..... "; +" .*****. "; +" .**...**. "; +" .**. .**. "; +" .. .**. "; +" .**. "; +" .**. "; +" .**. "; +" .**. "; +" .. "; +" .. "; +" .**. "; +" .**. "; +" .. " |] let success = [| (* width height num_colors chars_per_pixel *) -" 20 14 2 1"; +" 20 14 3 1"; (* colors *) " c None"; "* c #00dd00"; +". c #ffffff"; (* pixels *) -" "; " "; -" *** "; -" ****** "; -" ***** * "; -" **** "; -" *** *** "; -" *** ** "; -" ****** "; -" *** "; -" ** "; -" ** "; -" * "; -" " +" ... "; +" ..***. "; +" .******. "; +" .*****.*. "; +" ... .****.. . "; +" .***. .***. "; +" .***.**.. "; +" .******. "; +" ..***. "; +" .**. "; +" .**. "; +" .*. "; +" . " |] let failure = [| (* width height num_colors chars_per_pixel *) -" 20 14 2 1"; +" 20 15 3 1"; (* colors *) " c None"; "* c #ff0000"; +". c #ffffff"; (* pixels *) -" * * "; -" *** ** "; -" *** *** "; -" ** ** "; -" ** ** "; -" ***** "; -" **** "; -" *** "; -" ***** "; -" ** ** "; -" ** ** "; -" ** *** "; -" *** ** "; -" *** " +" . .. "; +" .*. .**. "; +" .***. .***. "; +" .**. .***. "; +" .**..**. "; +" .*****. "; +" .****. "; +" .***. "; +" .*****. "; +" .**.**. "; +" .**. .**. "; +" .**. .***. "; +" .***. .**. "; +" .***. .. "; +" ... " |] Modified: trunk/src/ubase/util.ml =================================================================== --- trunk/src/ubase/util.ml 2009-07-30 16:58:35 UTC (rev 382) +++ trunk/src/ubase/util.ml 2009-08-03 17:09:46 UTC (rev 383) @@ -37,18 +37,9 @@ (* PRE-BUILT MAP AND SET MODULES *) (*****************************************************************************) -module StringMap = - Map.Make(struct - type t = string - let compare = compare - end) +module StringMap = Map.Make (String) +module StringSet = Set.Make (String) -module StringSet = - Set.Make(struct - type t = string - let compare = compare - end) - let stringSetFromList l = Safelist.fold_right StringSet.add l StringSet.empty Modified: trunk/src/uicommon.ml =================================================================== --- trunk/src/uicommon.ml 2009-07-30 16:58:35 UTC (rev 382) +++ trunk/src/uicommon.ml 2009-08-03 17:09:46 UTC (rev 383) @@ -55,6 +55,7 @@ ("Used to set the height (in lines) of the main window in the graphical " ^ "user interface.") +(*FIX: remove this option... *) let reuseToplevelWindows = Prefs.createBool "reusewindows" false "*reuse top-level windows instead of making new ones" "" @@ -551,7 +552,7 @@ (* The following step contacts the server, so warn the user it could take some time *) - if !firstTime && (not (Prefs.read contactquietly || Prefs.read Trace.terse)) then + if not (Prefs.read contactquietly || Prefs.read Trace.terse) then displayWaitMessage(); (* Canonize the names of the roots, sort them (with local roots first), Modified: trunk/src/uigtk2.ml =================================================================== --- trunk/src/uigtk2.ml 2009-07-30 16:58:35 UTC (rev 382) +++ trunk/src/uigtk2.ml 2009-08-03 17:09:46 UTC (rev 383) @@ -78,7 +78,9 @@ Font preferences **********************************************************************) -let fontMonospaceMediumPango = lazy (Pango.Font.from_string "monospace") +let fontMonospace = lazy (Pango.Font.from_string "monospace") +let fontBold = lazy (Pango.Font.from_string "bold") +let fontItalic = lazy (Pango.Font.from_string "italic") (********************************************************************** Unison icon @@ -105,23 +107,21 @@ mutable whatHappened : (Util.confirmation * string option) option} let theState = ref [||] -let current = ref None +module IntSet = Set.Make (struct type t = int let compare = compare end) -(* ---- *) +let current = ref IntSet.empty -let currentWindow = ref None +let currentRow () = + if IntSet.cardinal !current = 1 then Some (IntSet.choose !current) else None -let grabFocus t = - match !currentWindow with - Some w -> t#set_transient_for (w#as_window); - w#misc#set_sensitive false - | None -> () +(* ---- *) -let releaseFocus () = - begin match !currentWindow with - Some w -> w#misc#set_sensitive true - | None -> () - end +let theToplevelWindow = ref None +let setToplevelWindow w = theToplevelWindow := Some w +let toplevelWindow () = + match !theToplevelWindow with + Some w -> w + | None -> assert false (********************************************************************* Lock management @@ -251,23 +251,20 @@ USEFUL LOW-LEVEL WIDGETS **********************************************************************) -class scrolled_text - ?(font=fontMonospaceMediumPango) ?editable ?word_wrap +class scrolled_text ?editable ?shadow_type ?word_wrap ~width ~height ?packing ?show () = let sw = GBin.scrolled_window ?packing ~show:false - ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC () + ?shadow_type ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC () in let text = GText.view ?editable ~wrap_mode:`WORD ~packing:sw#add () in object inherit GObj.widget_full sw#as_widget method text = text - method insert ?(font=fontMonospaceMediumPango) s = - text#buffer#set_text s; + method insert s = text#buffer#set_text s; method show () = sw#misc#show () initializer - text#misc#modify_font (Lazy.force font); text#misc#set_size_chars ~height ~width (); if show <> Some false then sw#misc#show () end @@ -276,14 +273,12 @@ (* Display a message in a window and wait for the user to hit the button. *) -let okBox ~title ~typ ~message = +let okBox ~parent ~title ~typ ~message = let t = GWindow.message_dialog - ~title ~message_type:typ ~message ~modal:true + ~parent ~title ~message_type:typ ~message ~modal:true ~buttons:GWindow.Buttons.ok () in - grabFocus t; - ignore (t#run ()); t#destroy (); - releaseFocus () + ignore (t#run ()); t#destroy () (* ------ *) @@ -294,9 +289,9 @@ (* twoBox: Display a message in a window and wait for the user to hit one of two buttons. Return true if the first button is chosen, false if the second button is chosen. *) -let twoBox ~title ~message ~astock ~bstock = +let twoBox ~parent ~title ~message ~astock ~bstock = let t = - GWindow.dialog ~border_width:6 ~modal:true ~no_separator:true + GWindow.dialog ~parent ~border_width:6 ~modal:true ~no_separator:true ~allow_grow:false () in t#vbox#set_spacing 12; let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in @@ -309,9 +304,9 @@ t#add_button_stock bstock `NO; t#add_button_stock astock `YES; t#set_default_response `NO; - grabFocus t; t#show(); + t#show(); let res = t#run () in - t#destroy (); releaseFocus (); + t#destroy (); res = `YES (* ------ *) @@ -326,7 +321,7 @@ if not !inExit then begin inExit := true; if not !busy then exit 0 else - if twoBox ~title:"Premature exit" + if twoBox ~parent:(toplevelWindow ()) ~title:"Premature exit" ~message:"Unison is working, exit anyway ?" ~astock:`YES ~bstock:`NO then exit 0; @@ -342,8 +337,8 @@ if Prefs.read Globals.batch then begin (* In batch mode, just pop up a window and go ahead *) let t = - GWindow.dialog ~border_width:6 ~modal:true ~no_separator:true - ~allow_grow:false () in + GWindow.dialog ~parent:(toplevelWindow ()) + ~border_width:6 ~modal:true ~no_separator:true ~allow_grow:false () in t#vbox#set_spacing 12; let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in ignore (GMisc.image ~stock:`DIALOG_INFO ~icon_size:`DIALOG @@ -358,11 +353,83 @@ t#show () end else begin inExit := true; - let ok = twoBox ~title ~message ~astock:`OK ~bstock:`QUIT in + let ok = + twoBox ~parent:(toplevelWindow ()) ~title ~message + ~astock:`OK ~bstock:`QUIT in if not(ok) then doExit (); inExit := false end +(****) + +let accel_paths = Hashtbl.create 17 +let underscore_re = Str.regexp_string "_" +class ['a] gMenuFactory + ?(accel_group=GtkData.AccelGroup.create ()) + ?(accel_path="/") + ?(accel_modi=[`CONTROL]) + ?(accel_flags=[`VISIBLE]) (menu_shell : 'a) = + object (self) + val menu_shell : #GMenu.menu_shell = menu_shell + val group = accel_group + val m = accel_modi + val flags = (accel_flags:Gtk.Tags.accel_flag list) + val accel_path = accel_path + method menu = menu_shell + method accel_group = group + method accel_path = accel_path + method private bind + ?(modi=m) ?key ?callback label ?(name=label) (item : GMenu.menu_item) = + menu_shell#append item; + let accel_path = accel_path ^ name in + let accel_path = Str.global_replace underscore_re "" accel_path in + (* Default accel path value *) + if not (Hashtbl.mem accel_paths accel_path) then begin + Hashtbl.add accel_paths accel_path (); + GtkData.AccelMap.add_entry accel_path ?key ~modi + end; + (* Register this accel path *) + GtkBase.Widget.set_accel_path item#as_widget accel_path accel_group; + Gaux.may callback ~f:(fun callback -> item#connect#activate ~callback) + method add_item ?key ?modi ?callback ?submenu label = + let item = GMenu.menu_item ~use_mnemonic:true ~label () in + self#bind ?modi ?key ?callback label item; + Gaux.may (submenu : GMenu.menu option) ~f:item#set_submenu; + item + method add_image_item ?(image : GObj.widget option) + ?modi ?key ?callback ?stock ?name label = + let item = + GMenu.image_menu_item ~use_mnemonic:true ?image ~label ?stock () in + match stock with + | None -> + self#bind ?modi ?key ?callback label ?name + (item : GMenu.image_menu_item :> GMenu.menu_item); + item + | Some s -> + try + let st = GtkStock.Item.lookup s in + self#bind + ?modi ?key:(if st.GtkStock.keyval=0 then key else None) + ?callback label ?name + (item : GMenu.image_menu_item :> GMenu.menu_item); + item + with Not_found -> item + + method add_check_item ?active ?modi ?key ?callback label = + let item = GMenu.check_menu_item ~label ~use_mnemonic:true ?active () in + self#bind label ?modi ?key + ?callback:(Gaux.may_map callback ~f:(fun f () -> f item#active)) + (item : GMenu.check_menu_item :> GMenu.menu_item); + item + method add_separator () = GMenu.separator_item ~packing:menu_shell#append () + method add_submenu label = + let item = GMenu.menu_item ~use_mnemonic:true ~label () in + self#bind label item; + (GMenu.menu ~packing:item#set_submenu (), item) + method replace_submenu (item : GMenu.menu_item) = + GMenu.menu ~packing:item#set_submenu () +end + (********************************************************************** HIGHER-LEVEL WIDGETS ***********************************************************************) @@ -569,9 +636,8 @@ (****) (* Standard file dialog *) -let file_dialog ~title ~callback ?filename () = - let sel = GWindow.file_selection ~title ~modal:true ?filename () in - grabFocus sel; +let file_dialog ~parent ~title ~callback ?filename () = + let sel = GWindow.file_selection ~parent ~title ~modal:true ?filename () in ignore (sel#cancel_button#connect#clicked ~callback:sel#destroy); ignore (sel#ok_button#connect#clicked ~callback: (fun () -> @@ -580,8 +646,7 @@ callback name)); sel#show (); ignore (sel#connect#destroy ~callback:GMain.Main.quit); - GMain.Main.main (); - releaseFocus () + GMain.Main.main () (* ------ *) @@ -589,8 +654,8 @@ Trace.log (message ^ "\n"); let title = "Fatal error" in let t = - GWindow.dialog ~border_width:6 ~modal:true ~no_separator:true - ~allow_grow:false () in + GWindow.dialog ~parent:(toplevelWindow ()) + ~border_width:6 ~modal:true ~no_separator:true ~allow_grow:false () in t#vbox#set_spacing 12; let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in ignore (GMisc.image ~stock:`DIALOG_ERROR ~icon_size:`DIALOG @@ -602,7 +667,7 @@ ~line_wrap:true ~selectable:true ~yalign:0. ~packing:v1#add ()); t#add_button_stock `QUIT `QUIT; t#set_default_response `QUIT; - grabFocus t; t#show(); ignore (t#run ()); t#destroy (); releaseFocus (); + t#show(); ignore (t#run ()); t#destroy (); exit 1 (* ------ *) @@ -611,8 +676,8 @@ (* ------ *) -let getFirstRoot() = - let t = GWindow.dialog ~title:"Root selection" +let getFirstRoot () = + let t = GWindow.dialog ~parent:(toplevelWindow ()) ~title:"Root selection" ~modal:true ~allow_grow:true () in t#misc#grab_focus (); @@ -628,7 +693,7 @@ let fileE = GEdit.entry ~packing:f1#add () in fileE#misc#grab_focus (); let browseCommand() = - file_dialog ~title:"Select a local directory" + file_dialog ~parent:t ~title:"Select a local directory" ~callback:fileE#set_text ~filename:fileE#text () in let b = GButton.button ~label:"Browse" ~packing:(f1#pack ~expand:false) () in @@ -656,7 +721,7 @@ (* ------ *) let getSecondRoot () = - let t = GWindow.dialog ~title:"Root selection" + let t = GWindow.dialog ~parent:(toplevelWindow ()) ~title:"Root selection" ~modal:true ~allow_grow:true () in t#misc#grab_focus (); @@ -669,7 +734,7 @@ ~packing:(hb#pack ~expand:false ~padding:15) ()); let helpB = GButton.button ~stock:`HELP ~packing:hb#add () in ignore (helpB#connect#clicked - ~callback:(fun () -> okBox ~title:"Picking roots" ~typ:`INFO + ~callback:(fun () -> okBox ~parent:t ~title:"Picking roots" ~typ:`INFO ~message:helpmessage)); let result = ref None in @@ -681,7 +746,7 @@ let fileE = GEdit.entry ~packing:f1#add () in fileE#misc#grab_focus (); let browseCommand() = - file_dialog ~title:"Select a local directory" + file_dialog ~parent:t ~title:"Select a local directory" ~callback:fileE#set_text ~filename:fileE#text () in let b = GButton.button ~label:"Browse" ~packing:(f1#pack ~expand:false) () in @@ -761,11 +826,11 @@ t#destroy () with Failure "int_of_string" -> if portE#text="" then - okBox ~title:"Error" ~typ:`ERROR ~message:"Please enter a port" - else okBox ~title:"Error" ~typ:`ERROR + okBox ~parent:t ~title:"Error" ~typ:`ERROR ~message:"Please enter a port" + else okBox ~parent:t ~title:"Error" ~typ:`ERROR ~message:"The port you specify must be an integer" | _ -> - okBox ~title:"Error" ~typ:`ERROR + okBox ~parent:t ~title:"Error" ~typ:`ERROR ~message:"Something's wrong with the values you entered, try again" in let f3 = t#action_area in let quitButton = @@ -786,7 +851,8 @@ let getPassword rootName msg = let t = - GWindow.dialog ~title:"Unison: SSH connection" ~position:`CENTER + GWindow.dialog ~parent:(toplevelWindow ()) + ~title:"Unison: SSH connection" ~position:`CENTER ~no_separator:true ~modal:true ~allow_grow:false ~border_width:6 () in t#misc#grab_focus (); @@ -812,10 +878,10 @@ t#set_default_response `OK; ignore (passwordE#connect#activate ~callback:(fun _ -> t#response `OK)); - grabFocus t; t#show(); + t#show(); let res = t#run () in let pwd = passwordE#text in - t#destroy (); releaseFocus (); + t#destroy (); gtk_sync true; begin match res with `DELETE_EVENT | `QUIT -> safeExit (); "" @@ -883,23 +949,23 @@ || Util.startswith name Os.tempFilePrefix)) (Files.ls Os.unisonDir "*.prf"))) -let getProfile () = +let getProfile quit = (* The selected profile *) let result = ref None in (* Build the dialog *) - let t = GWindow.dialog ~title:"Profiles" ~width:400 () in + let t = + GWindow.dialog ~parent:(toplevelWindow ()) + ~title:"Profiles" ~modal:true ~width:400 () in - let cancelCommand _ = t#destroy (); exit 0 in - let cancelButton = GButton.button ~stock:`CANCEL + let cancelCommand _ = t#destroy (); result := None in + let cancelButton = GButton.button ~stock:(if quit then `QUIT else `CANCEL) ~packing:t#action_area#add () in ignore (cancelButton#connect#clicked ~callback:cancelCommand); - ignore (t#event#connect#delete ~callback:cancelCommand); + ignore (t#event#connect#delete ~callback:(fun _ -> cancelCommand (); true)); cancelButton#misc#set_can_default true; - let okCommand() = - currentWindow := None; - t#destroy () in + let okCommand() = t#destroy () in let okButton = GButton.button ~stock:`OK ~packing:t#action_area#add () in ignore (okButton#connect#clicked ~callback:okCommand); @@ -979,6 +1045,7 @@ let filename = Prefs.profilePathname profile in if System.file_exists filename then okBox + ~parent:t ~title:"Error" ~typ:`ERROR ~message:("Profile \"" ^ (transcodeFilename profile) @@ -999,9 +1066,7 @@ okButton#grab_default (); t#show (); - grabFocus t; - GMain.Main.main (); - releaseFocus ())); + GMain.Main.main ())); ignore (lst#connect#unselect_row ~callback:(fun ~row:_ ~column:_ ~event:_ -> root1#set_text ""; root2#set_text ""; @@ -1038,7 +1103,6 @@ fillLst "default"; select_row !selRow; lst#misc#grab_focus (); - currentWindow := Some (t :> GWindow.window_skel); ignore (t#connect#destroy ~callback:GMain.Main.quit); t#show (); GMain.Main.main (); @@ -1089,9 +1153,9 @@ (* ------ *) -let messageBox ~title ?(action = fun t -> t#destroy) ?(modal = false) message = +let messageBox ~title ?(action = fun t -> t#destroy) message = let utitle = transcode title in - let t = GWindow.dialog ~title:utitle ~modal ~position:`CENTER () in + let t = GWindow.dialog ~title:utitle ~position:`CENTER () in let t_dismiss = GButton.button ~stock:`CLOSE ~packing:t#action_area#add () in t_dismiss#grab_default (); ignore (t_dismiss#connect#clicked ~callback:(action t)); @@ -1101,20 +1165,16 @@ in t_text#insert message; ignore (t#event#connect#delete ~callback:(fun _ -> action t (); true)); - t#show (); - if modal then begin - grabFocus t; - GMain.Main.main (); - releaseFocus () - end + t#show () (* twoBoxAdvanced: Display a message in a window and wait for the user to hit one of two buttons. Return true if the first button is chosen, false if the second button is chosen. Also has a button for showing more details to the user in a messageBox dialog *) -let twoBoxAdvanced ~title ~message ~longtext ~advLabel ~astock ~bstock = +let twoBoxAdvanced + ~parent ~title ~message ~longtext ~advLabel ~astock ~bstock = let t = - GWindow.dialog ~border_width:6 ~modal:false ~no_separator:true + GWindow.dialog ~parent ~border_width:6 ~modal:true ~no_separator:true ~allow_grow:false () in t#vbox#set_spacing 12; let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in @@ -1126,7 +1186,7 @@ ~selectable:true ~yalign:0. ~packing:v1#add ()); t#add_button_stock `CANCEL `NO; let cmd () = - messageBox ~title:"Details" ~modal:false longtext + messageBox ~title:"Details" longtext in t#add_button advLabel `HELP; t#add_button_stock `APPLY `YES; @@ -1141,67 +1201,52 @@ in ignore (t#connect#response ~callback:setRes); ignore (t#connect#destroy ~callback:GMain.Main.quit); - grabFocus t; t#show(); + t#show(); GMain.Main.main(); - releaseFocus (); !res +let summaryBox ~parent ~title ~message ~f = + let t = + GWindow.dialog ~parent ~border_width:6 ~modal:true ~no_separator:true + ~allow_grow:false () in + t#vbox#set_spacing 12; + let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in + ignore (GMisc.image ~stock:`DIALOG_INFO ~icon_size:`DIALOG + ~yalign:0. ~packing:h1#pack ()); + let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in + ignore (GMisc.label + ~markup:(primaryText title ^ "\n\n" ^ escapeMarkup message) + ~selectable:true ~xalign:0. ~yalign:0. ~packing:v1#add ()); + let exp = GBin.expander ~spacing:12 ~label:"Show details" ~packing:v1#add () in + let t_text = + new scrolled_text ~editable:false ~shadow_type:`IN + ~width:60 ~height:10 ~packing:exp#add () + in + f (t_text#text); + t#add_button_stock `OK `OK; + t#set_default_response `OK; + let setRes signal = t#destroy () in + ignore (t#connect#response ~callback:setRes); + ignore (t#connect#destroy ~callback:GMain.Main.quit); + t#show(); + GMain.Main.main() (********************************************************************** TOP-LEVEL WINDOW **********************************************************************) -let myWindow = ref None +let displayWaitMessage () = Trace.status (Uicommon.contactingServerMsg ()) -let getMyWindow () = - if not (Prefs.read Uicommon.reuseToplevelWindows) then begin - (match !myWindow with Some(w) -> w#destroy() | None -> ()); - myWindow := None; - end; - let w = match !myWindow with - Some(w) -> - Safelist.iter w#remove w#children; - w - | None -> - (* Used to be ~position:`CENTER -- maybe that was better... *) - GWindow.window ~kind:`TOPLEVEL ~position:`CENTER - ~title:myNameCapitalized () in - myWindow := Some(w); - w#set_allow_grow true; - w - (* ------ *) -let displayWaitMessage () = - if not (Prefs.read Uicommon.contactquietly) then begin - (* FIX: should use a dialog *) - let w = getMyWindow() in - w#set_allow_grow false; - currentWindow := Some (w :> GWindow.window_skel); - let v = GPack.vbox ~packing:(w#add) ~border_width:2 () in - let bb = - GPack.button_box `HORIZONTAL ~layout:`END ~spacing:10 ~border_width:5 - ~packing:(v#pack ~fill:true ~from:`END) () in - let h1 = GPack.hbox ~border_width:12 ~spacing:12 ~packing:v#pack () in - ignore (GMisc.image ~stock:`DIALOG_INFO ~icon_size:`DIALOG - ~yalign:0. ~packing:h1#pack ()); - let m = - GMisc.label ~markup:(primaryText (Uicommon.contactingServerMsg())) - ~yalign:0. ~selectable:true ~packing:h1#add () in - m#misc#set_can_focus false; - let quit = GButton.button ~stock:`QUIT ~packing:bb#pack () in - quit#grab_default (); - ignore (quit#connect#clicked ~callback:safeExit); - ignore (w#event#connect#delete ~callback:(fun _ -> safeExit (); true)); - w#show() - end - -(* ------ *) - type status = NoStatus | Done | Failed -let rec createToplevelWindow () = - let toplevelWindow = getMyWindow() in +let createToplevelWindow () = + let toplevelWindow = + GWindow.window ~kind:`TOPLEVEL ~position:`CENTER + ~title:myNameCapitalized () + in + setToplevelWindow toplevelWindow; (* There is already a default icon under Windows, and transparent icons are not supported by all version of Windows *) if Util.osType <> `Win32 then toplevelWindow#set_icon (Some icon); @@ -1239,43 +1284,52 @@ let menuBar = GMenu.menu_bar ~border_width:0 ~packing:(topHBox#pack ~expand:true) () in - let menus = new GMenu.factory ~accel_modi:[] menuBar in + let menus = new gMenuFactory ~accel_modi:[] menuBar in let accel_group = menus#accel_group in toplevelWindow#add_accel_group accel_group; - let add_submenu ?(modi=[]) ~label () = - new GMenu.factory ~accel_group ~accel_modi:modi (menus#add_submenu label) + let add_submenu ?(modi=[]) label = + let (menu, item) = menus#add_submenu label in + (new gMenuFactory ~accel_group:(menus#accel_group) + ~accel_path:(menus#accel_path ^ label ^ "/") + ~accel_modi:modi menu, + item) in + let replace_submenu ?(modi=[]) label item = + let menu = menus#replace_submenu item in + new gMenuFactory ~accel_group:(menus#accel_group) + ~accel_path:(menus#accel_path ^ label ^ "/") + ~accel_modi:modi menu + in let profileLabel = GMisc.label ~text:"" ~packing:(topHBox#pack ~expand:false ~padding:2) () in - let displayNewProfileLabel p = + let displayNewProfileLabel () = + let p = match !Prefs.profileName with None -> "" | Some p -> p in let label = Prefs.read Uicommon.profileLabel in let s = - if p="" then "" - else if p="default" then label - else if label="" then p - else p ^ " (" ^ label ^ ")" in + match p, label with + "", _ -> "" + | _, "" -> p + | "default", _ -> label + | _ -> Format.sprintf "%s (%s)" p label + in toplevelWindow#set_title (if s = "" then myNameCapitalized else Format.sprintf "%s [%s]" myNameCapitalized s); - let s = if s="" then "" else "Profile: " ^ s in - profileLabel#set_text (transcodeFilename s) + let s = if s="" then "No profile" else "Profile: " ^ s in + profileLabel#set_text (transcode s) in + displayNewProfileLabel (); - begin match !Prefs.profileName with - None -> () - | Some(p) -> displayNewProfileLabel p - end; - (********************************************************************* Create the menus *********************************************************************) - let fileMenu = add_submenu ~label:"Synchronization" () - and actionsMenu = add_submenu ~label:"Actions" () - and ignoreMenu = add_submenu ~modi:[`SHIFT] ~label:"Ignore" () - and sortMenu = add_submenu ~label:"Sort" () - and helpMenu = add_submenu ~label:"Help" () in + let (fileMenu, _) = add_submenu "_Synchronization" in + let (actionMenu, actionItem) = add_submenu "_Actions" in + let (ignoreMenu, _) = add_submenu ~modi:[`SHIFT] "_Ignore" in + let (sortMenu, _) = add_submenu "S_ort" in + let (helpMenu, _) = add_submenu "_Help" in (********************************************************************* Action bar @@ -1298,8 +1352,7 @@ ~height:(Prefs.read Uicommon.mainWindowHeight * 12) ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in GList.clist ~columns:5 ~titles_show:true - ~selection_mode:`BROWSE ~packing:sw#add () in - mainWindow#misc#grab_focus (); + ~selection_mode:(*`BROWSE*)`MULTIPLE ~packing:sw#add () in (* let cols = new GTree.column_list in let c_replica1 = cols#add Gobject.Data.string in @@ -1342,9 +1395,7 @@ mainWindow#set_column ~justification:`CENTER (*~auto_resize:false ~width:status_width*) 3; - let setMainWindowColumnHeaders () = - (* FIX: roots2string should return a pair *) - let s = Uicommon.roots2string () in + let setMainWindowColumnHeaders s = Array.iteri (fun i data -> mainWindow#set_column @@ -1353,7 +1404,7 @@ " " ^ Unicode.protect (String.sub s 15 12) ^ " "; " Status "; " Path" |] in - setMainWindowColumnHeaders(); + setMainWindowColumnHeaders " "; (********************************************************************* Create the details window @@ -1361,7 +1412,7 @@ let showDetCommand () = let details = - match !current with + match currentRow () with None -> None | Some row -> @@ -1402,33 +1453,43 @@ ~shadow_type:`IN ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC () in let detailsWindow = - GText.view ~editable:false ~wrap_mode:`NONE ~packing:detailsWindowSW#add () + GText.view ~editable:false ~packing:detailsWindowSW#add () in - detailsWindow#misc#modify_font (Lazy.force fontMonospaceMediumPango); + let detailsWindowPath = detailsWindow#buffer#create_tag [] in + let detailsWindowInfo = + detailsWindow#buffer#create_tag [`FONT_DESC (Lazy.force fontMonospace)] in + let detailsWindowError = + detailsWindow#buffer#create_tag [`WRAP_MODE `WORD] in detailsWindow#misc#set_size_chars ~height:3 ~width:112 (); detailsWindow#misc#set_can_focus false; let updateButtons () = - match !current with - None -> - grSet grAction false; - grSet grDiff false; - grSet grDetail false - | Some row -> - let details = - begin match !theState.(row).ri.replicas with - Different diff -> diff.errors1 <> [] || diff.errors2 <> [] - | Problem _ -> true - end - || - begin match !theState.(row).whatHappened with - Some (Util.Failed _, _) -> true - | _ -> false - end - in - grSet grDetail details; - if not !busy then begin - let activateAction = !theState.(row).whatHappened = None in + if not !busy then + let actionPossible row = + let si = !theState.(row) in + match si.whatHappened, si.ri.replicas with + None, Different _ -> true + | _ -> false + in + match currentRow () with + None -> + grSet grAction (IntSet.exists actionPossible !current); + grSet grDiff false; + grSet grDetail false + | Some row -> + let details = + begin match !theState.(row).ri.replicas with + Different diff -> diff.errors1 <> [] || diff.errors2 <> [] + | Problem _ -> true + end + || + begin match !theState.(row).whatHappened with + Some (Util.Failed _, _) -> true + | _ -> false + end + in + grSet grDetail details; + let activateAction = actionPossible row in let activateDiff = activateAction && match !theState.(row).ri.replicas with @@ -1439,7 +1500,6 @@ in grSet grAction activateAction; grSet grDiff activateDiff - end; in let makeRowVisible row = @@ -1465,25 +1525,35 @@ *) let updateDetails () = - begin match !current with + begin match currentRow () with None -> detailsWindow#buffer#set_text "" | Some row -> makeRowVisible row; let (formated, details) = match !theState.(row).whatHappened with - None | Some(Util.Succeeded, _) -> - (true, Uicommon.details2string !theState.(row).ri " ") | Some(Util.Failed(s), _) -> (false, s) + | None | Some(Util.Succeeded, _) -> + match !theState.(row).ri.replicas with + Problem _ -> + (false, Uicommon.details2string !theState.(row).ri " ") + | Different _ -> + (true, Uicommon.details2string !theState.(row).ri " ") in let path = Path.toString !theState.(row).ri.path1 in - let txt = transcodeFilename path ^ "\n" ^ transcode details in - let len = String.length txt in - let txt = - if txt.[len - 1] = '\n' then String.sub txt 0 (len - 1) else txt in - detailsWindow#buffer#set_text txt; - detailsWindow#set_wrap_mode (if formated then `NONE else `WORD) + detailsWindow#buffer#set_text ""; + detailsWindow#buffer#insert ~tags:[detailsWindowPath] + (transcodeFilename path); + let len = String.length details in + let details = + if details.[len - 1] = '\n' then String.sub details 0 (len - 1) + else details + in + if details <> "" then + detailsWindow#buffer#insert + ~tags:[if formated then detailsWindowInfo else detailsWindowError] + ("\n" ^ transcode details) end; (* Display text *) updateButtons () in @@ -1524,19 +1594,55 @@ (********************************************************************* Functions used to print in the main window *********************************************************************) + let delayUpdates = ref false in + let hasFocus = ref false in let select i = - let r = mainWindow#rows in - let p = if r < 2 then 0. else (float i +. 0.5) /. float (r - 1) in - mainWindow#scroll_vertical `JUMP (min p 1.) + if !hasFocus then begin + (* If we have the focus, we move the focus row directely *) + let r = mainWindow#rows in + let p = if r < 2 then 0. else (float i +. 0.5) /. float (r - 1) in + mainWindow#scroll_vertical `JUMP (min p 1.); + if IntSet.is_empty !current then mainWindow#select i 0 + end else begin + (* If we don't have the focus, we just move the selection. + We delay updates to make sure not to change the button + states unnecessarily (which could result in a button + losing the focus). *) + delayUpdates := true; + mainWindow#unselect_all (); + mainWindow#select i 0; + delayUpdates := false; + updateDetails () + end in + ignore (mainWindow#event#connect#focus_in ~callback: + (fun _ -> + hasFocus := true; + (* Adjust the focus row. We cannot do it immediately, + otherwise the focus row is not drawn correctly. *) + ignore (GMain.Idle.add (fun () -> + begin match currentRow () with + Some i -> select i + | None -> () + end; + false)); + false)); + ignore (mainWindow#event#connect#focus_out ~callback: + (fun _ -> hasFocus := false; false)); ignore (mainWindow#connect#select_row ~callback: - (fun ~row ~column ~event -> current := Some row; updateDetails ())); + (fun ~row ~column ~event -> + current := IntSet.add row !current; + if not !delayUpdates then updateDetails ())); + ignore (mainWindow#connect#unselect_row ~callback: + (fun ~row ~column ~event -> + current := IntSet.remove row !current; + if not !delayUpdates then updateDetails ())); let nextInteresting () = let l = Array.length !theState in - let start = match !current with Some i -> i + 1 | None -> 0 in + let start = match currentRow () with Some i -> i + 1 | None -> 0 in let rec loop i = if i < l then match !theState.(i).ri.replicas with @@ -1547,7 +1653,7 @@ loop (i + 1) in loop start in let selectSomethingIfPossible () = - if !current=None then nextInteresting () in + if IntSet.is_empty !current then nextInteresting () in let columnsOf i = let oldPath = if i = 0 then Path.empty else !theState.(i-1).ri.path1 in @@ -1624,7 +1730,7 @@ (* The call to mainWindow#clear below side-effect current, so we save the current value before we clear out the main window and rebuild it. *) - let savedCurrent = !current in + let savedCurrent = currentRow () in mainWindow#freeze (); mainWindow#clear (); for i = Array.length !theState - 1 downto 0 do @@ -1643,11 +1749,12 @@ done; debug (fun()-> Util.msg "reset current to %s\n" (match savedCurrent with None->"None" | Some(i) -> string_of_int i)); - if savedCurrent <> None then current := savedCurrent; - selectSomethingIfPossible (); - begin match !current with Some idx -> select idx | None -> () end; + begin match savedCurrent with + None -> selectSomethingIfPossible () + | Some idx -> select idx + end; mainWindow#thaw (); - updateDetails (); + updateDetails (); (* Do we need this line? *) in let redisplay i = @@ -1663,8 +1770,10 @@ ~text:(transcodeFilename path ^ " [failed: click on this line for details]") i 4; (*mainWindow#thaw ();*) - if !current = Some i then updateDetails (); - updateButtons () in + if currentRow () = Some i then begin + updateDetails (); updateButtons () + end + in let fastRedisplay i = let (r1, action, r2, status, path) = columnsOf i in @@ -1673,7 +1782,7 @@ mainWindow#set_cell ~text:(transcodeFilename path ^ " [failed: click on this line for details]") i 4; - if !current = Some i then updateDetails (); + if currentRow () = Some i then updateDetails (); in let totalBytesToTransfer = ref Uutil.Filesize.zero in @@ -1729,7 +1838,13 @@ displayGlobalProgress v in + let root1IsLocal = ref true in + let root2IsLocal = ref true in + let initGlobalProgress b = + let (root1,root2) = Globals.roots () in + root1IsLocal := fst root1 = Local; + root2IsLocal := fst root2 = Local; totalBytesToTransfer := b; totalBytesTransferred := Uutil.Filesize.zero; t0 := Unix.gettimeofday (); t1 := !t0; @@ -1737,10 +1852,6 @@ displayGlobalProgress 0. in - let (root1,root2) = Globals.roots () in - let root1IsLocal = fst root1 = Local in - let root2IsLocal = fst root2 = Local in - let showProgress i bytes dbg = let i = Uutil.File.toLine i in let item = !theState.(i) in @@ -1762,12 +1873,12 @@ Different diff -> begin match diff.direction with Replica1ToReplica2 -> - if root2IsLocal then + if !root2IsLocal then clientWritten := !clientWritten +. Uutil.Filesize.toFloat bytes else serverWritten := !serverWritten +. Uutil.Filesize.toFloat bytes | Replica2ToReplica1 -> - if root1IsLocal then + if !root1IsLocal then clientWritten := !clientWritten +. Uutil.Filesize.toFloat bytes else serverWritten := !serverWritten +. Uutil.Filesize.toFloat bytes @@ -1792,9 +1903,10 @@ let lst = Array.to_list !theState in (* FIX: we should actually test whether any prefix is now ignored *) let keep sI = not (Globals.shouldIgnore sI.ri.path1) in - begin match !current with + begin match currentRow () with None -> - theState := Array.of_list (Safelist.filter keep lst) + theState := Array.of_list (Safelist.filter keep lst); + current := IntSet.empty | Some index -> let i = ref index in let l = ref [] in @@ -1803,13 +1915,14 @@ else if j < !i then decr i) !theState; theState := Array.of_list (Safelist.rev !l); - current := if !l = [] then None - else Some (min (!i) ((Array.length !theState) - 1)); + current := + if !l = [] then IntSet.empty + else IntSet.singleton (min (!i) ((Array.length !theState) - 1)) end; displayMain() in let sortAndRedisplay () = - current := None; + current := IntSet.empty; let compareRIs = Sortri.compareReconItems() in Array.stable_sort (fun si1 si2 -> compareRIs si1.ri si2.ri) !theState; displayMain() in @@ -1826,13 +1939,15 @@ Trace.showTimer t in - let detectUpdatesAndReconcile () = + let clearMainWindow () = grDisactivateAll (); - startStats (); - mainWindow#clear(); - detailsWindow#buffer#set_text ""; + detailsWindow#buffer#set_text "" + in + let detectUpdatesAndReconcile () = + clearMainWindow (); + startStats (); progressBarPulse := true; sync_action := Some (fun () -> progressBar#pulse ()); let findUpdates () = @@ -1866,7 +1981,7 @@ bytesToTransfer = Uutil.Filesize.zero; whatHappened = None }) reconItemList); - current := None; + current := IntSet.empty; displayMain(); progressBarPulse := false; sync_action := None; displayGlobalProgress 0.; stopStats (); @@ -1887,7 +2002,7 @@ if shortname = "about" then ignore (helpMenu#add_image_item ~stock:`ABOUT ~callback:(fun () -> documentation shortname) - ~label:name ()) + name) else if shortname <> "" && name <> "" then ignore (helpMenu#add_item ~callback:(fun () -> documentation shortname) @@ -1898,27 +2013,27 @@ Ignore menu *********************************************************************) let addRegExpByPath pathfunc = - match !current with - Some i -> - Uicommon.addIgnorePattern (pathfunc !theState.(i).ri.path1); - ignoreAndRedisplay () - | None -> - () in + Util.StringSet.iter (fun pat -> Uicommon.addIgnorePattern pat) + (IntSet.fold + (fun i s -> Util.StringSet.add (pathfunc !theState.(i).ri.path1) s) + !current Util.StringSet.empty); + ignoreAndRedisplay () + in grAdd grAction (ignoreMenu#add_item ~key:GdkKeysyms._i ~callback:(fun () -> getLock (fun () -> addRegExpByPath Uicommon.ignorePath)) - "Permanently ignore this path"); + "Permanently Ignore This _Path"); grAdd grAction (ignoreMenu#add_item ~key:GdkKeysyms._E ~callback:(fun () -> getLock (fun () -> addRegExpByPath Uicommon.ignoreExt)) - "Permanently ignore files with this extension"); + "Permanently Ignore Files with this _Extension"); grAdd grAction (ignoreMenu#add_item ~key:GdkKeysyms._N ~callback:(fun () -> getLock (fun () -> addRegExpByPath Uicommon.ignoreName)) - "Permanently ignore files with this name (in any dir)"); + "Permanently Ignore Files with this _Name (in any Dir)"); (* grAdd grRescan @@ -1929,30 +2044,30 @@ (********************************************************************* Sort menu *********************************************************************) - grAdd grAction + grAdd grRescan (sortMenu#add_item ~callback:(fun () -> getLock (fun () -> Sortri.sortByName(); sortAndRedisplay())) - "Sort entries by name"); - grAdd grAction + "Sort by _Name"); + grAdd grRescan (sortMenu#add_item ~callback:(fun () -> getLock (fun () -> Sortri.sortBySize(); sortAndRedisplay())) - "Sort entries by size"); - grAdd grAction + "Sort by _Size"); + grAdd grRescan (sortMenu#add_item ~callback:(fun () -> getLock (fun () -> Sortri.sortNewFirst(); sortAndRedisplay())) - "Sort new entries first"); - grAdd grAction + "Sort Ne_w Entries First"); + grAdd grRescan (sortMenu#add_item ~callback:(fun () -> getLock (fun () -> Sortri.restoreDefaultSettings(); sortAndRedisplay())) - "Go back to default ordering"); + "_Default Ordering"); (********************************************************************* Main function : synchronize @@ -1996,6 +2111,7 @@ textDetailed := (Some text); if Prefs.read Uicommon.confirmmerge then twoBoxAdvanced + ~parent:toplevelWindow ~title:title ~message:("Do you want to commit the changes to" ^ " the replicas ?") @@ -2053,53 +2169,144 @@ commitUpdates (); stopStats (); + let failureList = + Array.fold_right + (fun si l -> + match si.whatHappened with + Some (Util.Failed err, _) -> + (si, [err], "transport failure") :: l + | _ -> + l) + !theState [] + in + let failureCount = List.length failureList in let failures = - let count = - Array.fold_left - (fun l si -> - l + (match si.whatHappened with Some(Util.Failed(_), _) -> 1 | _ -> 0)) - 0 !theState in - if count = 0 then [] else - [Printf.sprintf "%d failure%s" count (if count=1 then "" else "s")] + if failureCount = 0 then [] else + [Printf.sprintf "%d failure%s" + failureCount (if failureCount = 1 then "" else "s")] in + let partialList = + Array.fold_right + (fun si l -> + match si.whatHappened with + Some (Util.Succeeded, _) + when partiallyProblematic si.ri && + not (problematic si.ri) -> + let errs = + match si.ri.replicas with + Different diff -> diff.errors1 @ diff.errors2 + | _ -> assert false + in + (si, errs, + "partial transfer (errors during update detection)") :: l + | _ -> + l) + !theState [] + in + let partialCount = List.length partialList in let partials = - let count = - Array.fold_left - (fun l si -> - l + match si.whatHappened with - Some(Util.Succeeded, _) - when partiallyProblematic si.ri && - not (problematic si.ri) -> - 1 - | _ -> - 0) - 0 !theState in - if count = 0 then [] else - [Printf.sprintf "%d partially transferred" count] in + if partialCount = 0 then [] else + [Printf.sprintf "%d partially transferred" partialCount] + in + let skippedList = + Array.fold_right + (fun si l -> + match si.ri.replicas with + Problem err -> + (si, [err], "error during update detection") :: l + | Different diff when diff.direction = Conflict -> + (si, [], + if diff.default_direction = Conflict then + "conflict" + else "skipped") :: l + | _ -> + l) + !theState [] + in + let skippedCount = List.length skippedList in let skipped = - let count = - Array.fold_left - (fun l si -> - l + (if problematic si.ri then 1 else 0)) - 0 !theState in - if count = 0 then [] else - [Printf.sprintf "%d skipped" count] in + if skippedCount = 0 then [] else + [Printf.sprintf "%d skipped" skippedCount] + in Trace.status (Printf.sprintf "Synchronization complete %s" (String.concat ", " (failures @ partials @ skipped))); displayGlobalProgress 0.; - grSet grRescan true + grSet grRescan true; + + if failureCount + partialCount + skippedCount > 0 then begin + let format n item sing plur = + match n with + 0 -> [] + | 1 -> [Format.sprintf "one %s%s" item sing] + | n -> [Format.sprintf "%d %s%s" n item plur] + in + let infos = + format failureCount "failure" "" "s" @ + format partialCount "partially transferred director" "y" "ies" @ + format skippedCount "skipped item" "" "s" + in + let message = + "The replicas are not fully synchronized.\nThere was" ^ + begin match infos with + [] -> assert false + | [x] -> " " ^ x + | l -> ":\n - " ^ String.concat ";\n - " l + end ^ + "." + in + summaryBox ~parent:toplevelWindow + ~title:"Synchronization summary" ~message ~f: + (fun t -> + let bullet = "\xe2\x80\xa2 " in + let layout = t#misc#pango_context#create_layout in + Pango.Layout.set_text layout bullet; + let (n, _) = Pango.Layout.get_pixel_size layout in + let path = + t#buffer#create_tag [`FONT_DESC (Lazy.force fontBold)] in + let description = + t#buffer#create_tag [`FONT_DESC (Lazy.force fontItalic)] in + let errorFirstLine = + t#buffer#create_tag [`LEFT_MARGIN (n); `INDENT (- n)] in + let errorNextLines = + t#buffer#create_tag [`LEFT_MARGIN (2 * n)] in + List.iter + (fun (si, errs, desc) -> + t#buffer#insert ~tags:[path] + (transcodeFilename (Path.toString si.ri.path1)); + t#buffer#insert ~tags:[description] + (" \xe2\x80\x94 " ^ desc ^ "\n"); + List.iter + (fun err -> + let errl = + Str.split (Str.regexp_string "\n") (transcode err) in + match errl with + [] -> + () + | f :: rem -> + t#buffer#insert ~tags:[errorFirstLine] + (bullet ^ f ^ "\n"); + List.iter + (fun n -> + t#buffer#insert ~tags:[errorNextLines] + (n ^ "\n")) + rem) + errs) + (failureList @ partialList @ skippedList)) + end + end in (********************************************************************* Quit button *********************************************************************) -(* actionBar#insert_space ();*) +(* actionBar#insert_space (); ignore (actionBar#insert_button ~text:"Quit" ~icon:((GMisc.image ~stock:`QUIT ())#coerce) ~tooltip:"Exit Unison" ~callback:safeExit ()); +*) (********************************************************************* go button @@ -2125,20 +2332,21 @@ (********************************************************************* Rescan button *********************************************************************) - let loadProfile p = + let updateFromProfile = ref (fun () -> ()) in + + let loadProfile p reload = debug (fun()-> Util.msg "Loading profile %s..." p); - Uicommon.initPrefs p displayWaitMessage getFirstRoot getSecondRoot - termInteract; - displayNewProfileLabel p; - setMainWindowColumnHeaders() + Uicommon.initPrefs p + (fun () -> if not reload then displayWaitMessage ()) + getFirstRoot getSecondRoot termInteract; + !updateFromProfile () in let reloadProfile () = match !Prefs.profileName with None -> () - | Some(n) -> grDisactivateAll (); loadProfile n in + | Some(n) -> clearMainWindow (); loadProfile n true in - let detectCmdName = "Rescan" in let detectCmd () = getLock detectUpdatesAndReconcile; updateDetails (); @@ -2148,7 +2356,7 @@ in (* actionBar#insert_space ();*) grAdd grRescan - (actionBar#insert_button ~text:detectCmdName + (actionBar#insert_button ~text:"Rescan" ~icon:((GMisc.image ~stock:`REFRESH ())#coerce) ~tooltip:"Check for updates" ~callback: (fun () -> reloadProfile(); detectCmd()) ()); @@ -2156,26 +2364,40 @@ (********************************************************************* Buttons for <--, M, -->, Skip *********************************************************************) + let doActionOnRow f i = + let theSI = !theState.(i) in + begin match theSI.whatHappened, theSI.ri.replicas with + None, Different diff -> + f theSI.ri diff; + redisplay i + | _ -> + () + end + in let doAction f = - match !current with + match currentRow () with Some i -> - let theSI = !theState.(i) in - begin match theSI.whatHappened, theSI.ri.replicas with - None, Different diff -> - f diff; - redisplay i; - nextInteresting () - | _ -> - () + doActionOnRow f i; + nextInteresting () + | None -> + (* FIX: this is quadratic when all items are selected. + We could trigger a redisplay instead, but it may be tricky + to preserve the set of selected rows, the focus row and the + scrollbar position. + The right fix is probably to move to a GTree.column_list. *) + let n = IntSet.cardinal !current in + if n > 0 then begin + if n > 20 then mainWindow#freeze (); + IntSet.iter (fun i -> doActionOnRow f i) !current; + if n > 20 then mainWindow#thaw () end - | None -> - () in + in let leftAction _ = - doAction (fun diff -> diff.direction <- Replica2ToReplica1) in + doAction (fun _ diff -> diff.direction <- Replica2ToReplica1) in let rightAction _ = - doAction (fun diff -> diff.direction <- Replica1ToReplica2) in - let questionAction _ = doAction (fun diff -> diff.direction <- Conflict) in - let mergeAction _ = doAction (fun diff -> diff.direction <- Merge) in + doAction (fun _ diff -> diff.direction <- Replica1ToReplica2) in + let questionAction _ = doAction (fun _ diff -> diff.direction <- Conflict) in + let mergeAction _ = doAction (fun _ diff -> diff.direction <- Merge) in actionBar#insert_space (); grAdd grAction @@ -2183,7 +2405,8 @@ (* ~icon:((GMisc.pixmap leftArrowBlack ())#coerce)*) ~icon:((GMisc.image ~stock:`GO_BACK ())#coerce) ~text:"Right to Left" - ~tooltip:"Propagate this item from the right replica to the left one" + ~tooltip:"Propagate selected items\n\ + from the right replica to the left one" ~callback:leftAction ()); (* actionBar#insert_space ();*) grAdd grAction @@ -2191,6 +2414,7 @@ (* ~icon:((GMisc.pixmap mergeLogoBlack())#coerce)*) ~icon:((GMisc.image ~stock:`ADD ())#coerce) ~text:"Merge" + ~tooltip:"Merge selected files" ~callback:mergeAction ()); (* actionBar#insert_space ();*) grAdd grAction @@ -2198,20 +2422,21 @@ (* ~icon:((GMisc.pixmap rightArrowBlack ())#coerce)*) ~icon:((GMisc.image ~stock:`GO_FORWARD ())#coerce) ~text:"Left to Right" - ~tooltip:"Propagate this item from the left replica to the right one" + ~tooltip:"Propagate selected items\n\ + from the left replica to the right one" ~callback:rightAction ()); (* actionBar#insert_space ();*) grAdd grAction (actionBar#insert_button ~text:"Skip" ~icon:((GMisc.image ~stock:`NO ())#coerce) - ~tooltip:"Skip this item" + ~tooltip:"Skip selected items" ~callback:questionAction ()); (********************************************************************* Diff / merge buttons *********************************************************************) let diffCmd () = - match !current with + match currentRow () with Some i -> getLock (fun () -> let item = !theState.(i) in @@ -2220,7 +2445,7 @@ Problem _ -> Uutil.Filesize.zero | Different diff -> - snd (if root1IsLocal then diff.rc2 else diff.rc1).size + snd (if !root1IsLocal then diff.rc2 else diff.rc1).size in item.bytesTransferred <- Uutil.Filesize.zero; item.bytesToTransfer <- len; @@ -2239,7 +2464,7 @@ actionBar#insert_space (); grAdd grDiff (actionBar#insert_button ~text:"Diff" ~icon:((GMisc.image ~stock:`DIALOG_INFO ())#coerce) - ~tooltip:"Compare the two items at each replica" + ~tooltip:"Compare the two files at each replica" ~callback:diffCmd ()); (* actionBar#insert_space ();*) @@ -2252,10 +2477,11 @@ (********************************************************************* Detail button *********************************************************************) - actionBar#insert_space (); +(* actionBar#insert_space ();*) grAdd grDetail (actionBar#insert_button ~text:"Details" ~icon:((GMisc.image ~stock:`INFO ())#coerce) - ~tooltip:"Show details" + ~tooltip:"Show detailed information about\n\ + an item, when available" ~callback:showDetCommand ()); (********************************************************************* @@ -2276,147 +2502,128 @@ (********************************************************************* Action menu *********************************************************************) - let (root1,root2) = Globals.roots () in - let loc1 = root2hostname root1 in - let loc2 = root2hostname root2 in - let descr = - if loc1 = loc2 then "left to right" else - Printf.sprintf "from %s to %s" loc1 loc2 in - let left = - actionsMenu#add_image_item ~key:GdkKeysyms._greater ~callback:rightAction - ~image:((GMisc.image ~stock:`GO_FORWARD ~icon_size:`MENU ())#coerce) - ~label:("Propagate this path " ^ descr) () in - grAdd grAction left; - left#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._greater; - left#add_accelerator ~group:accel_group GdkKeysyms._period; + let buildActionMenu init = + let actionMenu = replace_submenu "_Actions" actionItem in + grAdd grRescan + (actionMenu#add_image_item + ~callback:(fun _ -> mainWindow#select_all ()) + ~image:((GMisc.image ~stock:`SELECT_ALL ~icon_size:`MENU ())#coerce) + ~modi:[`CONTROL] ~key:GdkKeysyms._A + "Select _All"); + grAdd grRescan + (actionMenu#add_item + ~callback:(fun _ -> mainWindow#unselect_all ()) + ~modi:[`SHIFT; `CONTROL] ~key:GdkKeysyms._A + "_Deselect All"); - let merge = - actionsMenu#add_image_item ~key:GdkKeysyms._m ~callback:mergeAction - ~image:((GMisc.image ~stock:`ADD ~icon_size:`MENU ())#coerce) - ~label:"Merge the files" () in - grAdd grAction merge; -(* merge#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._m; *) + ignore (actionMenu#add_separator ()); - let descl = - if loc1 = loc2 then "right to left" else - Printf.sprintf "from %s to %s" - (Unicode.protect loc2) (Unicode.protect loc1) in - let right = - actionsMenu#add_image_item ~key:GdkKeysyms._less ~callback:leftAction - ~image:((GMisc.image ~stock:`GO_BACK ~icon_size:`MENU ())#coerce) - ~label:("Propagate this path " ^ descl) () in - grAdd grAction right; - right#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._less; - right#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._comma; + let (loc1, loc2) = + if init then ("", "") else + let (root1,root2) = Globals.roots () in + (root2hostname root1, root2hostname root2) + in + let def_descr = "Left to Right" in + let descr = + if init || loc1 = loc2 then def_descr else + Printf.sprintf "from %s to %s" loc1 loc2 in + let left = + actionMenu#add_image_item ~key:GdkKeysyms._greater ~callback:rightAction + ~image:((GMisc.image ~stock:`GO_FORWARD ~icon_size:`MENU ())#coerce) + ~name:("Propagate " ^ def_descr) ("Propagate " ^ descr) in + grAdd grAction left; + left#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._greater; + left#add_accelerator ~group:accel_group GdkKeysyms._period; - grAdd grAction - (actionsMenu#add_image_item ~key:GdkKeysyms._slash ~callback:questionAction - ~image:((GMisc.image ~stock:`NO ~icon_size:`MENU ())#coerce) - ~label:"Do not propagate changes to this path" ()); + let merge = + actionMenu#add_image_item ~key:GdkKeysyms._m ~callback:mergeAction + ~image:((GMisc.image ~stock:`ADD ~icon_size:`MENU ())#coerce) + "_Merge the Files" in + grAdd grAction merge; + (* merge#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._m; *) - (* Override actions *) - ignore (actionsMenu#add_separator ()); - grAdd grAction - (actionsMenu#add_item - ~callback:(fun () -> getLock (fun () -> - Array.iter - (fun si -> Recon.setDirection si.ri `Replica1ToReplica2 `Prefer) - !theState; - displayMain())) - "Resolve all conflicts in favor of first root"); - grAdd grAction - (actionsMenu#add_item - ~callback:(fun () -> getLock (fun () -> - Array.iter - (fun si -> Recon.setDirection si.ri `Replica2ToReplica1 `Prefer) - !theState; - displayMain())) - "Resolve all conflicts in favor of second root"); - grAdd grAction - (actionsMenu#add_item - ~callback:(fun () -> getLock (fun () -> - Array.iter - (fun si -> Recon.setDirection si.ri `Newer `Prefer) - !theState; - displayMain())) - "Resolve all conflicts in favor of most recently modified"); - grAdd grAction - (actionsMenu#add_item - ~callback:(fun () -> getLock (fun () -> - Array.iter - (fun si -> Recon.setDirection si.ri `Older `Prefer) - !theState; - displayMain())) - "Resolve all conflicts in favor of least recently modified"); - ignore (actionsMenu#add_separator ()); - grAdd grAction - (actionsMenu#add_item - ~callback:(fun () -> getLock (fun () -> - Array.iter - (fun si -> Recon.setDirection si.ri `Replica1ToReplica2 `Force) - !theState; - displayMain())) - "Force all changes from first root to second"); - grAdd grAction - (actionsMenu#add_item - ~callback:(fun () -> getLock (fun () -> - Array.iter - (fun si -> Recon.setDirection si.ri `Replica2ToReplica1 `Force) - !theState; - displayMain())) - "Force all changes from second root to first"); - grAdd grAction - (actionsMenu#add_item - ~callback:(fun () -> getLock (fun () -> - Array.iter - (fun si -> Recon.setDirection si.ri `Newer `Force) - !theState; - displayMain())) - "Force newer files to replace older ones"); - grAdd grAction - (actionsMenu#add_item - ~callback:(fun () -> getLock (fun () -> - Array.iter - (fun si -> Recon.setDirection si.ri `Merge `Force) - !theState; - displayMain())) - "Revert all paths to the merging default, if avaible"); - grAdd grAction - (actionsMenu#add_item - ~callback:(fun () -> getLock (fun () -> - Array.iter - (fun si -> Recon.setDirection si.ri `Older `Force) - !theState; - displayMain())) - "Force older files to replace newer ones"); - ignore (actionsMenu#add_separator ()); - grAdd grAction - (actionsMenu#add_item - ~callback:(fun () -> getLock (fun () -> - Array.iter - (fun si -> Recon.revertToDefaultDirection si.ri) - !theState; - displayMain())) - "Revert all paths to Unison's recommendations"); - grAdd grAction - (actionsMenu#add_item - ~callback:(fun () -> getLock (fun () -> - match !current with - Some i -> - let theSI = !theState.(i) in - Recon.revertToDefaultDirection theSI.ri; - redisplay i; - nextInteresting () - | None -> - ())) - "Revert selected path to Unison's recommendations"); + let def_descl = "Right to Left" in + let descl = + if init || loc1 = loc2 then def_descr else + Printf.sprintf "from %s to %s" + (Unicode.protect loc2) (Unicode.protect loc1) in + let right = + actionMenu#add_image_item ~key:GdkKeysyms._less ~callback:leftAction + ~image:((GMisc.image ~stock:`GO_BACK ~icon_size:`MENU ())#coerce) + ~name:("Propagate " ^ def_descl) ("Propagate " ^ descl) in + grAdd grAction right; + right#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._less; + right#add_accelerator ~group:accel_group ~modi:[`SHIFT] GdkKeysyms._comma; - (* Diff *) - ignore (actionsMenu#add_separator ()); - grAdd grDiff (actionsMenu#add_image_item ~key:GdkKeysyms._d ~callback:diffCmd - ~image:((GMisc.image ~stock:`DIALOG_INFO ~icon_size:`MENU ())#coerce) - ~label:"Show diffs for selected path" ()); + grAdd grAction + (actionMenu#add_image_item ~key:GdkKeysyms._slash ~callback:questionAction + ~image:((GMisc.image ~stock:`NO ~icon_size:`MENU ())#coerce) + "Do _Not Propagate Changes"); + (* Override actions *) + ignore (actionMenu#add_separator ()); + grAdd grAction + (actionMenu#add_item + ~callback:(fun () -> + doAction (fun ri _ -> + Recon.setDirection ri `Replica1ToReplica2 `Prefer)) + "Resolve Conflicts in Favor of First Root"); + grAdd grAction + (actionMenu#add_item + ~callback:(fun () -> + doAction (fun ri _ -> + Recon.setDirection ri `Replica2ToReplica1 `Prefer)) + "Resolve Conflicts in Favor of Second Root"); + grAdd grAction + (actionMenu#add_item + ~callback:(fun () -> + doAction (fun ri _ -> + Recon.setDirection ri `Newer `Prefer)) + "Resolve Conflicts in Favor of Most Recently Modified"); + grAdd grAction + (actionMenu#add_item + ~callback:(fun () -> + doAction (fun ri _ -> + Recon.setDirection ri `Older `Prefer)) + "Resolve conflicts in favor of least recently modified"); + ignore (actionMenu#add_separator ()); + grAdd grAction + (actionMenu#add_item + ~callback:(fun () -> + doAction (fun ri _ -> Recon.setDirection ri `Newer `Force)) + "Force Newer Files to Replace Older Ones"); + grAdd grAction + (actionMenu#add_item + ~callback:(fun () -> + doAction (fun ri _ -> Recon.setDirection ri `Older `Force)) + "Force Older Files to Replace Newer Ones"); + ignore (actionMenu#add_separator ()); + grAdd grAction + (actionMenu#add_item + ~callback:(fun () -> + doAction (fun ri _ -> Recon.revertToDefaultDirection ri)) + "_Revert to Unison's Recommendations"); + grAdd grAction + (actionMenu#add_item + ~callback:(fun () -> + doAction (fun ri _ -> Recon.setDirection ri `Merge `Force)) + "Revert to the Merging Default, if Available"); + + (* Diff *) + ignore (actionMenu#add_separator ()); + grAdd grDiff (actionMenu#add_image_item ~key:GdkKeysyms._d ~callback:diffCmd + ~image:((GMisc.image ~stock:`DIALOG_INFO ~icon_size:`MENU ())#coerce) + "Show _Diffs"); + + (* Details *) + grAdd grDetail + (actionMenu#add_image_item ~key:GdkKeysyms._i ~callback:showDetCommand + ~image:((GMisc.image ~stock:`INFO ~icon_size:`MENU ())#coerce) + "Detailed _Information") + + in + buildActionMenu true; + (********************************************************************* Synchronization menu *********************************************************************) @@ -2425,19 +2632,19 @@ (fileMenu#add_image_item ~key:GdkKeysyms._g ~image:(GMisc.image ~stock:`EXECUTE ~icon_size:`MENU () :> GObj.widget) ~callback:(fun () -> getLock synchronize) - ~label:"Go" ()); + "_Go"); grAdd grRescan (fileMenu#add_image_item ~key:GdkKeysyms._r ~image:(GMisc.image ~stock:`REFRESH ~icon_size:`MENU () :> GObj.widget) ~callback:(fun () -> reloadProfile(); detectCmd()) - ~label:detectCmdName ()); + "_Rescan"); grAdd grRescan (fileMenu#add_item ~key:GdkKeysyms._a ~callback:(fun () -> reloadProfile(); Prefs.set Globals.batch true; detectCmd()) - "Detect updates and proceed (without waiting)"); + "_Detect Updates and Proceed (Without Waiting)"); grAdd grRescan (fileMenu#add_item ~key:GdkKeysyms._f ~callback:( @@ -2461,22 +2668,25 @@ (String.concat ", " (Safelist.map (fun p -> "'"^(Path.toString p)^"'") failedpaths))); + let paths = Prefs.read Globals.paths in + let confirmBigDeletes = Prefs.read Globals.confirmBigDeletes in Prefs.set Globals.paths failedpaths; Prefs.set Globals.confirmBigDeletes false; detectCmd(); - reloadProfile()) - "Recheck unsynchronized items"); + Prefs.set Globals.paths paths; + Prefs.set Globals.confirmBigDeletes confirmBigDeletes) + "Re_check Unsynchronized Items"); ignore (fileMenu#add_separator ()); grAdd grRescan (fileMenu#add_image_item ~key:GdkKeysyms._p ~callback:(fun _ -> - match getProfile() with + match getProfile false with None -> () - | Some(p) -> loadProfile p; detectCmd ()) + | Some(p) -> clearMainWindow (); loadProfile p false; detectCmd ()) ~image:(GMisc.image ~stock:`OPEN ~icon_size:`MENU () :> GObj.widget) - ~label:"Select a new profile from the profile dialog..." ()); + "Change _Profile..."); let fastProf name key = grAdd grRescan @@ -2484,7 +2694,7 @@ ~callback:(fun _ -> if System.file_exists (Prefs.profilePathname name) then begin Trace.status ("Loading profile " ^ name); - loadProfile name; detectCmd () + loadProfile name false; detectCmd () end else Trace.status ("Profile " ^ name ^ " not found")) ("Select profile " ^ name)) in @@ -2503,19 +2713,19 @@ ignore (fileMenu#add_separator ()); ignore (fileMenu#add_item - ~callback:(fun _ -> statWin#show ()) "Statistics"); + ~callback:(fun _ -> statWin#show ()) "Show _Statistics"); ignore (fileMenu#add_separator ()); ignore (fileMenu#add_image_item ~key:GdkKeysyms._q ~callback:safeExit ~image:((GMisc.image ~stock:`QUIT ~icon_size:`MENU ())#coerce) - ~label:"Quit" ()); + "_Quit"); (********************************************************************* Expert menu *********************************************************************) if Prefs.read Uicommon.expert then begin - let expertMenu = add_submenu ~label:"Expert" () in + let (expertMenu, _) = add_submenu "Expert" in let addDebugToggle modname = let cm = @@ -2544,11 +2754,20 @@ *********************************************************************) grDisactivateAll (); + updateFromProfile := + (fun () -> + displayNewProfileLabel (); + setMainWindowColumnHeaders (Uicommon.roots2string ()); + buildActionMenu false); + + ignore (toplevelWindow#event#connect#delete ~callback: (fun _ -> safeExit (); true)); toplevelWindow#show (); - currentWindow := Some (toplevelWindow :> GWindow.window_skel); - detectCmd () + fun () -> + !updateFromProfile (); + mainWindow#misc#grab_focus (); + detectCmd () (********************************************************************* @@ -2576,17 +2795,18 @@ in ignore_result (tick ()); + let detectCmd = createToplevelWindow() in + Uicommon.uiInit fatalError tryAgainOrQuit displayWaitMessage - getProfile + (fun () -> getProfile true) getFirstRoot getSecondRoot termInteract; - scanProfiles(); - createToplevelWindow(); + detectCmd (); (* Display the ui *) (*JV: not useful, as Unison does not handle any signal From petersj at in.tum.de Tue Aug 4 07:54:15 2009 From: petersj at in.tum.de (Janosch Peters) Date: Tue, 4 Aug 2009 11:54:15 +0000 (UTC) Subject: [Unison-hackers] Undefined Symbols References: <20090731191254.GA11884@pps.jussieu.fr> Message-ID: On 07-31-2009, Jerome Vouillon wrote: > Hi, > On Fri, Jul 31, 2009 at 03:35:14PM +0000, Janosch Peters wrote: >> I get undefined symbols if I compile with UISTYLE=gtk2. I have gtk2 >> @2.16.3_0+no_x11+quartz installed. Is this supposed to work or do I >> need the x11 variant? The output I get is the following: > [...] >> Ld /Users/jp/Code/unison/trunk/src/uimacnew/build/Default/ >> Unison.app/Contents/MacOS/Unison normal i386 > I don't know whether the GTK UI works under Mac O X. But what you are > attempting to build here is the native UI. Are you really running > thefollowing command: > make UISTYLE=gtk2 I just tried again and I get a different error. So I guess I typed in sth different from UISTYLE=gtk2. I didnt realize that there is a native UI for OS X. I tried to build the native UI but then I get the same undefined symbols as mentioned in my first post. I have OS X 10.5.7, OCaml 3.10.2. and XCode 3.1.2. --Janosch From petersj at in.tum.de Tue Aug 4 08:06:12 2009 From: petersj at in.tum.de (Janosch Peters) Date: Tue, 4 Aug 2009 12:06:12 +0000 (UTC) Subject: [Unison-hackers] Undefined Symbols References: <20090731191254.GA11884@pps.jussieu.fr> Message-ID: On 08-04-2009, Janosch Peters wrote: > On 07-31-2009, Jerome Vouillon wrote: >> Hi, >> On Fri, Jul 31, 2009 at 03:35:14PM +0000, Janosch Peters wrote: >>> I get undefined symbols if I compile with UISTYLE=gtk2. I have >>> gtk2 @2.16.3_0+no_x11+quartz installed. Is this supposed to work or >>> do I need the x11 variant? The output I get is the following: >> [...] >>> Ld /Users/jp/Code/unison/trunk/src/uimacnew/build/Default/ >>> Unison.app/Contents/MacOS/Unison normal i386 >> I don't know whether the GTK UI works under Mac O X. But what you > are >> attempting to build here is the native UI. Are you really running >> thefollowing command: >> make UISTYLE=gtk2 > I just tried again and I get a different error. So I guess I typed in > sth different from UISTYLE=gtk2. I didnt realize that there is a > native UI for OS X. I tried to build the native UI but then I get the > same undefined symbols as mentioned in my first post. > I have OS X 10.5.7, OCaml 3.10.2. and XCode 3.1.2. I just recognized that this issue has allready been discussed on the list. Sorry for the noise. I built the UI with XCode and I compiles fine. Nevertheless, it would be great to make this work on the command line to. Is there a way to set the deployment target on the command line? From vouillon at seas.upenn.edu Fri Aug 7 07:39:21 2009 From: vouillon at seas.upenn.edu (vouillon@seas.upenn.edu) Date: Fri, 7 Aug 2009 07:39:21 -0400 Subject: [Unison-hackers] [unison-svn] r384 - trunk/src Message-ID: <200908071139.n77BdL0G027922@yaws.seas.upenn.edu> Author: vouillon Date: 2009-08-07 07:39:21 -0400 (Fri, 07 Aug 2009) New Revision: 384 Modified: trunk/src/RECENTNEWS trunk/src/mkProjectInfo.ml trunk/src/transfer.ml Log: * Transfer by rsync algorithm: fix the hashtable size limit to be below the maximum length of an array. Modified: trunk/src/RECENTNEWS =================================================================== --- trunk/src/RECENTNEWS 2009-08-03 17:09:46 UTC (rev 383) +++ trunk/src/RECENTNEWS 2009-08-07 11:39:21 UTC (rev 384) @@ -1,5 +1,11 @@ CHANGES FROM VERSION 2.37.5 +* Transfer by rsync algorithm: fix the hashtable size limit to be + below the maximum length of an array. + +------------------------------- +CHANGES FROM VERSION 2.37.5 + * GTK UI: - pop up a summary window when the replicas are not fully synchronized after transport Modified: trunk/src/mkProjectInfo.ml =================================================================== --- trunk/src/mkProjectInfo.ml 2009-08-03 17:09:46 UTC (rev 383) +++ trunk/src/mkProjectInfo.ml 2009-08-07 11:39:21 UTC (rev 384) @@ -100,3 +100,4 @@ + Modified: trunk/src/transfer.ml =================================================================== --- trunk/src/transfer.ml 2009-08-03 17:09:46 UTC (rev 383) +++ trunk/src/transfer.ml 2009-08-07 11:39:21 UTC (rev 384) @@ -468,10 +468,10 @@ (*** CUSTOM HASH TABLE ***) - (* Maximum number of entries in the hash table. + (* Half the maximum number of entries in the hash table. MUST be a power of 2 ! Typical values are around an average 2 * fileSize / blockSize. *) - let hashTableMaxLength = 2048 * 1024 + let hashTableMaxLength = 1024 * 1024 let rec upperPowerOfTwo n n2 = if (n2 >= n) || (n2 = hashTableMaxLength) then From mason.kramer at gmail.com Fri Aug 7 21:45:48 2009 From: mason.kramer at gmail.com (Mason Kramer) Date: Fri, 7 Aug 2009 21:45:48 -0400 Subject: [Unison-hackers] Unison 2.27 for Mac - Broken since 7/17 Message-ID: <3DCAA84F-4B6A-4ADC-A78E-0659A9C00F38@gmail.com> I'm not sure what changed on that fateful day three weeks ago, but that is the last time Unison reported a successful sync across ssh in my logs. I've been using the Mac Ports package, and I fear I may have upgraded ocaml to 3.11.1_0, which apparently broke Unison. But since then I have tried many ways to get Unison working, and nothing has worked. The stable and beta binaries available at http://alan.petitepomme.net/unison/index.html do not work for me, whether I use the GUI or text mode. When I use the Cocoa GUI, I get a Connecting... window indefinitely whenever I try to sync across ssh. Syncing local test folders works fine. Yes, I made sure to install the CLI on both computers for each version I tried. Network traffic analysis indicates than an ssh session to the target machine is being created when I try to connect. The correct binary is available at /usr/bin/local. This ought to be in the non-login shell's path, and it definitely was for a long time (since the program worked). I have also been unable to build Unison 2.27 from source. I built Ocaml 3.10, it built fine, but Unison wouldn't build from the command line or xcode project. In the xcode project, I get errors on Growl headers. From the command line, [09:40:32:/Volumes/MacHD (RAID1)/Media/Mason/Downloads/ unison-2.27.157]$ make ocamlc -o mkProjectInfo mkProjectInfo.ml ./mkProjectInfo > Makefile.ProjectInfo UISTYLE = macnew Building for Unix NATIVE = true THREADS = true STATIC = false OSTYPE = OSARCH = osx echo 'let myName = "'unison'";;' > ubase/projectInfo.ml echo 'let myVersion = "'2.27.157'";;' >> ubase/projectInfo.ml echo 'let myMajorVersion = "'2.27'";;' >> ubase/projectInfo.ml ocamlopt: ubase/projectInfo.ml ---> ubase/projectInfo.cmx ocamlopt -I lwt -I ubase -thread -c /Volumes/MacHD (RAID1)/Media/ Mason/Downloads/unison-2.27.157/ubase/projectInfo.ml /bin/sh: -c: line 0: syntax error near unexpected token `(' /bin/sh: -c: line 0: `ocamlopt -I lwt -I ubase -thread -c /Volumes/ MacHD (RAID1)/Media/Mason/Downloads/unison-2.27.157/ubase/ projectInfo.ml' make: *** [ubase/projectInfo.cmx] Error 2 ------ I really don't have a clue how where to go from here, but I am willing to try any tests you want to make of me and respond with the results if it helps you get this fixed. I am dying for Unison over here ;) From vouillon at seas.upenn.edu Mon Aug 10 08:57:43 2009 From: vouillon at seas.upenn.edu (vouillon@seas.upenn.edu) Date: Mon, 10 Aug 2009 08:57:43 -0400 Subject: [Unison-hackers] [unison-svn] r385 - trunk/src Message-ID: <200908101257.n7ACvhQW010684@yaws.seas.upenn.edu> Author: vouillon Date: 2009-08-10 08:57:43 -0400 (Mon, 10 Aug 2009) New Revision: 385 Modified: trunk/src/RECENTNEWS trunk/src/mkProjectInfo.ml trunk/src/transfer.ml Log: * Transfer by rsync: fixed string token length overflow due to recent changes in block size. Modified: trunk/src/RECENTNEWS =================================================================== --- trunk/src/RECENTNEWS 2009-08-07 11:39:21 UTC (rev 384) +++ trunk/src/RECENTNEWS 2009-08-10 12:57:43 UTC (rev 385) @@ -1,5 +1,11 @@ CHANGES FROM VERSION 2.37.5 +* Transfer by rsync: fixed string token length overflow due to recent + changes in block size. + +------------------------------- +CHANGES FROM VERSION 2.37.5 + * Transfer by rsync algorithm: fix the hashtable size limit to be below the maximum length of an array. Modified: trunk/src/mkProjectInfo.ml =================================================================== --- trunk/src/mkProjectInfo.ml 2009-08-07 11:39:21 UTC (rev 384) +++ trunk/src/mkProjectInfo.ml 2009-08-10 12:57:43 UTC (rev 385) @@ -101,3 +101,4 @@ + Modified: trunk/src/transfer.ml =================================================================== --- trunk/src/transfer.ml 2009-08-07 11:39:21 UTC (rev 384) +++ trunk/src/transfer.ml 2009-08-10 12:57:43 UTC (rev 385) @@ -96,8 +96,10 @@ (* Size of a block *) let minBlockSize = 700 -let maxQueueSize = 65500 -let maxQueueSizeFS = Uutil.Filesize.ofInt maxQueueSize +(* This should at most 65535+3 bytes, as we are using this size to + ensure that string token lengths will fit in 2 bytes. *) +let queueSize = 65500 +let queueSizeFS = Uutil.Filesize.ofInt queueSize type tokenQueue = { mutable data : Bytearray.t; (* the queued tokens *) mutable previous : [`Str of int | `Block of int | `None]; @@ -146,32 +148,28 @@ let pushEOF q showProgress transmit = flushQueue q showProgress transmit - (q.pos + 1 > Bytearray.length q.data) >>= (fun () -> + (q.pos + 1 > queueSize) >>= (fun () -> q.data.{q.pos} <- 'E'; q.pos <- q.pos + 1; q.previous <- `None; return ()) -let pushString q id transmit s pos len = - flushQueue q id transmit (q.pos + len + 3 > Bytearray.length q.data) - >>= (fun () -> - if q.pos + 3 + len > Bytearray.length q.data then begin - (* The file is longer than expected, so the string does not fit in - the buffer *) - assert (q.pos = 0); - q.data <- Bytearray.create maxQueueSize - end; +let rec pushString q id transmit s pos len = + flushQueue q id transmit (q.pos + len + 3 > queueSize) >>= fun () -> + let l = min len (queueSize - q.pos - 3) in q.data.{q.pos} <- 'S'; - encodeInt2 q.data (q.pos + 1) len; - assert (q.pos + 3 + len <= Bytearray.length q.data); - Bytearray.blit_from_string s pos q.data (q.pos + 3) len; - q.pos <- q.pos + len + 3; - q.prog <- q.prog + len; - q.previous <- `Str len; - return ()) + encodeInt2 q.data (q.pos + 1) l; + Bytearray.blit_from_string s pos q.data (q.pos + 3) l; + q.pos <- q.pos + l + 3; + q.prog <- q.prog + l; + q.previous <- `Str l; + if l < len then + pushString q id transmit s (pos + l) (len - l) + else + return () -let rec growString q id transmit len' s pos len = - let l = min (Bytearray.length q.data - q.pos) len in +let growString q id transmit len' s pos len = + let l = min (queueSize - q.pos) len in Bytearray.blit_from_string s pos q.data q.pos l; assert (q.data.{q.pos - len' - 3} = 'S'); assert (decodeInt2 q.data (q.pos - len' - 2) = len'); @@ -186,7 +184,7 @@ return () let pushBlock q id transmit pos = - flushQueue q id transmit (q.pos + 5 > Bytearray.length q.data) >>= (fun () -> + flushQueue q id transmit (q.pos + 5 > queueSize) >>= (fun () -> q.data.{q.pos} <- 'B'; encodeInt3 q.data (q.pos + 1) pos; encodeInt1 q.data (q.pos + 4) 1; @@ -221,14 +219,12 @@ | BLOCK pos, _ -> pushBlock q id transmit pos -let makeQueue length blockSize = +let makeQueue blockSize = { data = (* We need to make sure here that the size of the queue is not larger than 65538 (1 byte: header, 2 bytes: string size, 65535 bytes: string) *) - Bytearray.create - (if length > maxQueueSizeFS then maxQueueSize else - Uutil.Filesize.toInt length + 10); + Bytearray.create queueSize; pos = 0; previous = `None; prog = 0; bSize = blockSize } @@ -245,7 +241,7 @@ let bufSz = 8192 in let bufSzFS = Uutil.Filesize.ofInt 8192 in let buf = String.create bufSz in - let q = makeQueue length 0 in + let q = makeQueue 0 in let rec sendSlice length = let count = reallyRead infd buf 0 @@ -593,7 +589,7 @@ *) (* Enable token buffering *) - let tokenQueue = makeQueue srcLength blockSize in + let tokenQueue = makeQueue blockSize in let flushTokenQueue () = flushQueue tokenQueue showProgress transmit true in let transmit token = queueToken tokenQueue showProgress transmit token in From bcpierce at seas.upenn.edu Mon Aug 10 21:46:31 2009 From: bcpierce at seas.upenn.edu (bcpierce@seas.upenn.edu) Date: Mon, 10 Aug 2009 21:46:31 -0400 Subject: [Unison-hackers] [unison-svn] r386 - in trunk/src: . ubase uimacnew/uimacnew.xcodeproj Message-ID: <200908110146.n7B1kVBt023773@yaws.seas.upenn.edu> Author: bcpierce Date: 2009-08-10 21:46:31 -0400 (Mon, 10 Aug 2009) New Revision: 386 Modified: trunk/src/Makefile trunk/src/Makefile.OCaml trunk/src/RECENTNEWS trunk/src/mkProjectInfo.ml trunk/src/ubase/depend trunk/src/uimacnew/uimacnew.xcodeproj/project.pbxproj Log: * Makefile tweak: don't complain if etags is not found (I hope I got my bash syntax right...) Modified: trunk/src/Makefile =================================================================== --- trunk/src/Makefile 2009-08-10 12:57:43 UTC (rev 385) +++ trunk/src/Makefile 2009-08-11 01:46:31 UTC (rev 386) @@ -344,7 +344,9 @@ .PHONY: tags tags: - -$(ETAGS) *.mli */*.mli *.ml */*.ml */*.m *.c */*.c *.txt + -if [ -f `which $(ETAGS)` ]; then \ + $(ETAGS) *.mli */*.mli *.ml */*.ml */*.m *.c */*.c *.txt \ + ; fi all:: TAGS Modified: trunk/src/Makefile.OCaml =================================================================== --- trunk/src/Makefile.OCaml 2009-08-10 12:57:43 UTC (rev 385) +++ trunk/src/Makefile.OCaml 2009-08-11 01:46:31 UTC (rev 386) @@ -166,8 +166,8 @@ endif endif -MINOSXVERSION=10.4 -XCODEFLAGS=-sdk macosx$(MINOSXVERSION) +MINOSXVERSION=10.5 +# XCODEFLAGS=-sdk macosx$(MINOSXVERSION) ifeq ($(OSARCH),osx) CAMLFLAGS+=-ccopt -mmacosx-version-min=$(MINOSXVERSION) endif @@ -176,7 +176,7 @@ # The two cases for cltool are needed because Xcode 2.1+ # builds in build/Default/, and earlier versions use build/ .PHONY: macexecutable -macexecutable: $(NAME)-blob.o +macexecutable: # sed -e's/@@VERSION@@/$(VERSION)/' $(UIMACDIR)/Info.plist.template > $(UIMACDIR)/Info.plist (cd $(UIMACDIR); xcodebuild $(XCODEFLAGS) OCAMLLIBDIR="$(OCAMLLIBDIR)" SYMROOT=build) if [ -e $(UIMACDIR)/build/Default ]; then \ @@ -401,10 +401,18 @@ # files, so we have to use $(LD) to take care of COBJS. $(NAME)-blob.o: $(CAMLOBJS) $(COBJS) @echo Linking $@ - $(CAMLC) -output-obj -verbose $(CAMLFLAGS) -o u-b.o $(CFLAGS) $(CAMLLIBS) $(CLIBS) $(CAMLOBJS) - $(LD) -r -o $@ u-b.o $(COBJS) + $(CAMLC) -dstartup -output-obj -verbose -cclib -keep_private_externs $(CAMLFLAGS) -o u-b.o $(CFLAGS) $(CAMLLIBS) $(CLIBS) $(CAMLOBJS) + $(LD) -r -keep_private_externs -o $@ u-b.o $(COBJS) $(RM) u-b.o + +# Original: +# $(NAME)-blob.o: $(CAMLOBJS) $(COBJS) +# @echo Linking $@ +# $(CAMLC) -output-obj -verbose $(CAMLFLAGS) -o u-b.o $(CFLAGS) $(CAMLLIBS) $(CLIBS) $(CAMLOBJS) +# $(LD) -r -o $@ u-b.o $(COBJS) +# $(RM) u-b.o + %$(EXEC_EXT): %.ml $(OCAMLC) -verbose -o $@ $^ Modified: trunk/src/RECENTNEWS =================================================================== --- trunk/src/RECENTNEWS 2009-08-10 12:57:43 UTC (rev 385) +++ trunk/src/RECENTNEWS 2009-08-11 01:46:31 UTC (rev 386) @@ -1,5 +1,10 @@ CHANGES FROM VERSION 2.37.5 +* Makefile tweak: don't complain if etags is not found (I hope I got my bash syntax right...) + +------------------------------- +CHANGES FROM VERSION 2.37.5 + * Transfer by rsync: fixed string token length overflow due to recent changes in block size. Modified: trunk/src/mkProjectInfo.ml =================================================================== --- trunk/src/mkProjectInfo.ml 2009-08-10 12:57:43 UTC (rev 385) +++ trunk/src/mkProjectInfo.ml 2009-08-11 01:46:31 UTC (rev 386) @@ -102,3 +102,4 @@ + Modified: trunk/src/ubase/depend =================================================================== --- trunk/src/ubase/depend 2009-08-10 12:57:43 UTC (rev 385) +++ trunk/src/ubase/depend 2009-08-11 01:46:31 UTC (rev 386) @@ -2,6 +2,8 @@ myMap.cmx: myMap.cmi prefs.cmo: util.cmi uarg.cmi safelist.cmi prefs.cmi prefs.cmx: util.cmx uarg.cmx safelist.cmx prefs.cmi +proplist.cmo: util.cmi proplist.cmi +proplist.cmx: util.cmx proplist.cmi rx.cmo: rx.cmi rx.cmx: rx.cmi safelist.cmo: safelist.cmi @@ -14,5 +16,12 @@ uprintf.cmx: uprintf.cmi util.cmo: uprintf.cmi safelist.cmi util.cmi util.cmx: uprintf.cmx safelist.cmx util.cmi +myMap.cmi: prefs.cmi: util.cmi +proplist.cmi: +rx.cmi: +safelist.cmi: trace.cmi: prefs.cmi +uarg.cmi: +uprintf.cmi: +util.cmi: Modified: trunk/src/uimacnew/uimacnew.xcodeproj/project.pbxproj =================================================================== --- trunk/src/uimacnew/uimacnew.xcodeproj/project.pbxproj 2009-08-10 12:57:43 UTC (rev 385) +++ trunk/src/uimacnew/uimacnew.xcodeproj/project.pbxproj 2009-08-11 01:46:31 UTC (rev 386) @@ -664,6 +664,7 @@ "-Wno-unknown-pragmas", ); WRAPPER_EXTENSION = app; + ZERO_LINK = NO; }; name = Default; }; @@ -682,7 +683,7 @@ baseConfigurationReference = 2E282CCC0D9AE2E800439D01 /* ExternalSettings.xcconfig */; buildSettings = { LIBRARY_SEARCH_PATHS = ""; - SDKROOT = /Developer/SDKs/MacOSX10.4u.sdk; + SDKROOT = /Developer/SDKs/MacOSX10.5.sdk; USER_HEADER_SEARCH_PATHS = $OCAMLLIBDIR; }; name = Deployment; @@ -692,7 +693,7 @@ baseConfigurationReference = 2E282CCC0D9AE2E800439D01 /* ExternalSettings.xcconfig */; buildSettings = { LIBRARY_SEARCH_PATHS = ""; - SDKROOT = /Developer/SDKs/MacOSX10.4u.sdk; + SDKROOT = /Developer/SDKs/MacOSX10.5.sdk; USER_HEADER_SEARCH_PATHS = $OCAMLLIBDIR; }; name = Default; From vouillon at seas.upenn.edu Tue Aug 11 09:16:56 2009 From: vouillon at seas.upenn.edu (vouillon@seas.upenn.edu) Date: Tue, 11 Aug 2009 09:16:56 -0400 Subject: [Unison-hackers] [unison-svn] r387 - in trunk/src: . ubase Message-ID: <200908111316.n7BDGv8o002500@yaws.seas.upenn.edu> Author: vouillon Date: 2009-08-11 09:16:56 -0400 (Tue, 11 Aug 2009) New Revision: 387 Modified: trunk/src/RECENTNEWS trunk/src/case.ml trunk/src/copy.ml trunk/src/fileinfo.ml trunk/src/globals.ml trunk/src/mkProjectInfo.ml trunk/src/osx.ml trunk/src/path.ml trunk/src/pixmaps.ml trunk/src/props.ml trunk/src/stasher.ml trunk/src/ubase/prefs.ml trunk/src/ubase/prefs.mli trunk/src/uicommon.ml trunk/src/uigtk2.ml trunk/src/update.ml Log: * GTK UI: - assistant for creating profiles - profile editor Modified: trunk/src/RECENTNEWS =================================================================== --- trunk/src/RECENTNEWS 2009-08-11 01:46:31 UTC (rev 386) +++ trunk/src/RECENTNEWS 2009-08-11 13:16:56 UTC (rev 387) @@ -1,3 +1,10 @@ +CHANGES FROM VERSION 2.37.10 + +* GTK UI: + - assistant for creating profiles + - profile editor + +------------------------------- CHANGES FROM VERSION 2.37.5 * Makefile tweak: don't complain if etags is not found (I hope I got my bash syntax right...) Modified: trunk/src/case.ml =================================================================== --- trunk/src/case.ml 2009-08-11 01:46:31 UTC (rev 386) +++ trunk/src/case.ml 2009-08-11 13:16:56 UTC (rev 387) @@ -21,7 +21,7 @@ (* insensitive. This pref is set during the initial handshake if any one of *) (* the hosts is case insensitive. *) let caseInsensitiveMode = - Prefs.createString "ignorecase" "default" + Prefs.createBoolWithDefault "ignorecase" "!identify upper/lowercase filenames (true/false/default)" ("When set to {\\tt true}, this flag causes Unison to treat " ^ "filenames as case insensitive---i.e., files in the two " @@ -41,7 +41,7 @@ "*Pseudo-preference for internal use only" "" let unicode = - Prefs.createString "unicode" "default" + Prefs.createBoolWithDefault "unicode" "!assume Unicode encoding in case insensitive mode" "When set to {\\tt true}, this flag causes Unison to perform \ case insensitive file comparisons assuming Unicode encoding" @@ -55,8 +55,8 @@ let useUnicode b = let pref = Prefs.read unicode in - pref = "yes" || pref = "true" || - (defaultToUnicode && pref = "default" && b) + pref = `True || + (defaultToUnicode && pref = `Default && b) let useUnicodeAPI () = useUnicode true @@ -66,9 +66,8 @@ (* server with the rest of the prefs. *) let init b = Prefs.set someHostIsInsensitive - (Prefs.read caseInsensitiveMode = "yes" || - Prefs.read caseInsensitiveMode = "true" || - (Prefs.read caseInsensitiveMode = "default" && b)); + (Prefs.read caseInsensitiveMode = `True || + (Prefs.read caseInsensitiveMode = `Default && b)); Prefs.set unicodeEncoding (useUnicode b) (****) Modified: trunk/src/copy.ml =================================================================== --- trunk/src/copy.ml 2009-08-11 01:46:31 UTC (rev 386) +++ trunk/src/copy.ml 2009-08-11 13:16:56 UTC (rev 387) @@ -601,7 +601,7 @@ ^ "for more information.") let copyquoterem = - Prefs.createString "copyquoterem" "default" + Prefs.createBoolWithDefault "copyquoterem" "!add quotes to remote file name for copyprog (true/false/default)" ("When set to {\\tt true}, this flag causes Unison to add an extra layer " ^ "of quotes to the remote path passed to the external copy program. " @@ -690,8 +690,8 @@ else Prefs.read copyprog in - let extraquotes = Prefs.read copyquoterem = "true" - || ( Prefs.read copyquoterem = "default" + let extraquotes = Prefs.read copyquoterem = `True + || ( Prefs.read copyquoterem = `Default && Util.findsubstring "rsync" prog <> None) in let addquotes root s = match root with Modified: trunk/src/fileinfo.ml =================================================================== --- trunk/src/fileinfo.ml 2009-08-11 01:46:31 UTC (rev 386) +++ trunk/src/fileinfo.ml 2009-08-11 13:16:56 UTC (rev 387) @@ -19,8 +19,8 @@ let debugV = Util.debug "fileinfo+" let allowSymlinks = - Prefs.createString "links" "default" - "allow the synchronization of symbolic links (true/false/default)" + Prefs.createBoolWithDefault "links" + "!allow the synchronization of symbolic links (true/false/default)" ("When set to {\\tt true}, this flag causes Unison to synchronize \ symbolic links. When the flag is set to {\\tt false}, symbolic \ links will result in an error during update detection. \ @@ -36,9 +36,8 @@ let init b = Prefs.set symlinksAllowed - (Prefs.read allowSymlinks = "yes" || - Prefs.read allowSymlinks = "true" || - (Prefs.read allowSymlinks = "default" && not b)) + (Prefs.read allowSymlinks = `True || + (Prefs.read allowSymlinks = `Default && not b)) type typ = [ `ABSENT | `FILE | `DIRECTORY | `SYMLINK ] Modified: trunk/src/globals.ml =================================================================== --- trunk/src/globals.ml 2009-08-11 01:46:31 UTC (rev 386) +++ trunk/src/globals.ml 2009-08-11 13:16:56 UTC (rev 387) @@ -220,7 +220,7 @@ let confirmBigDeletes = Prefs.createBool "confirmbigdel" true "!ask about whole-replica (or path) deletes" - ("!When this is set to {\\tt true}, Unison will request an extra confirmation if it appears " + ("When this is set to {\\tt true}, Unison will request an extra confirmation if it appears " ^ "that the entire replica has been deleted, before propagating the change. If the {\\tt batch} " ^ "flag is also set, synchronization will be aborted. When the {\\tt path} preference is used, " ^ "the same confirmation will be requested for top-level paths. (At the moment, this flag only " @@ -254,7 +254,7 @@ if some parent of a given path matches an {\\tt ignore} pattern, then it will be skipped even if the path itself matches an {\\tt ignorenot} pattern. In particular, putting {\\tt ignore = Path *} in your profile - and then using {\tt ignorenot} to select particular paths to be + and then using {\\tt ignorenot} to select particular paths to be synchronized will not work. Instead, you should use the {\\tt path} preference to choose particular paths to synchronize.") Modified: trunk/src/mkProjectInfo.ml =================================================================== --- trunk/src/mkProjectInfo.ml 2009-08-11 01:46:31 UTC (rev 386) +++ trunk/src/mkProjectInfo.ml 2009-08-11 13:16:56 UTC (rev 387) @@ -65,7 +65,7 @@ Str.matched_group 1 str;; let extract_int re str = int_of_string (extract_str re str);; -let revisionString = "$Rev: 382$";; +let revisionString = "$Rev: 387$";; let pointVersion = if String.length revisionString > 5 then Scanf.sscanf revisionString "$Rev: %d " (fun x -> x) - pointVersionOrigin else (* Determining the pointVersionOrigin in bzr is kind of tricky: @@ -103,3 +103,4 @@ + Modified: trunk/src/osx.ml =================================================================== --- trunk/src/osx.ml 2009-08-11 01:46:31 UTC (rev 386) +++ trunk/src/osx.ml 2009-08-11 13:16:56 UTC (rev 387) @@ -26,7 +26,7 @@ (****) let rsrcSync = - Prefs.createString "rsrc" "default" + Prefs.createBoolWithDefault "rsrc" "!synchronize resource forks (true/false/default)" "When set to {\\tt true}, this flag causes Unison to synchronize \ resource forks and HFS meta-data. On filesystems that do not \ @@ -45,9 +45,8 @@ let init b = Prefs.set rsrc - (Prefs.read rsrcSync = "yes" || - Prefs.read rsrcSync = "true" || - (Prefs.read rsrcSync = "default" && b)) + (Prefs.read rsrcSync = `True || + (Prefs.read rsrcSync = `Default && b)) (****) Modified: trunk/src/path.ml =================================================================== --- trunk/src/path.ml 2009-08-11 01:46:31 UTC (rev 386) +++ trunk/src/path.ml 2009-08-11 13:16:56 UTC (rev 387) @@ -200,7 +200,7 @@ behave as if the object pointed to by the link had appeared literally \ at this position in the replica. See \ \\sectionref{symlinks}{Symbolic Links} for more details. \ - The syntax of \\ARG{pathspec>} is \ + The syntax of \\ARG{pathspec} is \ described in \\sectionref{pathspec}{Path Specification}.") let followLink path = Modified: trunk/src/pixmaps.ml =================================================================== --- trunk/src/pixmaps.ml 2009-08-11 01:46:31 UTC (rev 386) +++ trunk/src/pixmaps.ml 2009-08-11 13:16:56 UTC (rev 387) @@ -259,6 +259,24 @@ |] (***********************************************************************) +(* Busy-Interactive mous pointer *) +(***********************************************************************) + +let left_ptr_watch = "\ +\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\ +\x0c\x00\x00\x00\x1c\x00\x00\x00\x3c\x00\x00\x00\ +\x7c\x00\x00\x00\xfc\x00\x00\x00\xfc\x01\x00\x00\ +\xfc\x3b\x00\x00\x7c\x38\x00\x00\x6c\x54\x00\x00\ +\xc4\xdc\x00\x00\xc0\x44\x00\x00\x80\x39\x00\x00\ +\x80\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ +\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ +\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ +\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ +\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ +\x00\x00\x00\x00\x00\x00\x00\x00" + + +(***********************************************************************) (* Unison icon *) (***********************************************************************) Modified: trunk/src/props.ml =================================================================== --- trunk/src/props.ml 2009-08-11 01:46:31 UTC (rev 386) +++ trunk/src/props.ml 2009-08-11 13:16:56 UTC (rev 387) @@ -362,7 +362,7 @@ ("When this flag is set to \\verb|true|, the owner attributes " ^ "of the files are synchronized. " ^ "Whether the owner names or the owner identifiers are synchronized" - ^ "depends on the preference \texttt{numerids}.") + ^ "depends on the preference \\texttt{numerids}.") let kind = "user" @@ -382,7 +382,7 @@ false "synchronize group attributes" ("When this flag is set to \\verb|true|, the group attributes " ^ "of the files are synchronized. " - ^ "Whether the group names or the group identifiers are synchronized" + ^ "Whether the group names or the group identifiers are synchronized " ^ "depends on the preference \\texttt{numerids}.") let kind = "group" Modified: trunk/src/stasher.ml =================================================================== --- trunk/src/stasher.ml 2009-08-11 01:46:31 UTC (rev 386) +++ trunk/src/stasher.ml 2009-08-11 13:16:56 UTC (rev 387) @@ -56,7 +56,7 @@ ^ "be backed up, even if the {\\tt backup} preference selects " ^ "them---i.e., " ^ "it selectively overrides {\\tt backup}. The same caveats apply here " - ^ "as with {\\tt ignore} and {\tt ignorenot}.") + ^ "as with {\\tt ignore} and {\\tt ignorenot}.") let _ = Pred.alias backupnot "mirrornot" Modified: trunk/src/ubase/prefs.ml =================================================================== --- trunk/src/ubase/prefs.ml 2009-08-11 01:46:31 UTC (rev 386) +++ trunk/src/ubase/prefs.ml 2009-08-11 13:16:56 UTC (rev 387) @@ -103,26 +103,63 @@ (* generate an appropriate usage message. *) exception IllegalValue of string +(* aliasMap: prefName -> prefName *) +let aliasMap = ref (Util.StringMap.empty : string Util.StringMap.t) + +let canonicalName nm = + try Util.StringMap.find nm !aliasMap with Not_found -> nm + +type typ = + [`BOOL | `INT | `STRING | `STRING_LIST | `BOOLDEF | `CUSTOM | `UNKNOWN] + +(* prefType : prefName -> type *) +let prefType = ref (Util.StringMap.empty : typ Util.StringMap.t) + +let typ nm = try Util.StringMap.find nm !prefType with Not_found -> `UNKNOWN + (* prefs: prefName -> (doc, pspec, fulldoc) *) let prefs = ref (Util.StringMap.empty : (string * Uarg.spec * string) Util.StringMap.t) +let documentation nm = + try + let (doc, _, fulldoc) = Util.StringMap.find nm !prefs in + if doc <> "" && doc.[0] = '*' then raise Not_found; + let basic = doc = "" || doc.[0] <> '!' in + let doc = + if not basic then + String.sub doc 1 (String.length doc - 1) + else + doc + in + (doc, fulldoc, basic) + with Not_found -> + ("", "", false) + +let list () = + List.sort String.compare + (Util.StringMap.fold (fun nm _ l -> nm :: l) !prefType []) + (* aliased pref has *-prefixed doc and empty fulldoc *) let alias pref newname = (* pref must have been registered, so name pref is not empty, and will be *) (* found in the map, no need for catching exception *) let (_,pspec,_) = Util.StringMap.find (Safelist.hd (name pref)) !prefs in prefs := Util.StringMap.add newname ("*", pspec, "") !prefs; + aliasMap := Util.StringMap.add newname (Safelist.hd (name pref)) !aliasMap; pref := (fst !pref, newname::(snd !pref)) -let registerPref name pspec doc fulldoc = +let registerPref name typ pspec doc fulldoc = if Util.StringMap.mem name !prefs then raise (Util.Fatal ("Preference " ^ name ^ " registered twice")); - prefs := Util.StringMap.add name (doc, pspec, fulldoc) !prefs + prefs := Util.StringMap.add name (doc, pspec, fulldoc) !prefs; + (* Ignore internal preferences *) + if doc = "" || doc.[0] <> '*' then + prefType := Util.StringMap.add name typ !prefType -let createPrefInternal name local default doc fulldoc printer parsefn = +let createPrefInternal name typ local default doc fulldoc printer parsefn = let newCell = rawPref (default, [name]) in - registerPref name (parsefn newCell) doc fulldoc; + registerPref name typ (parsefn newCell) doc fulldoc; adddumper name local (fun () -> Marshal.to_string !newCell []); addprinter name (fun () -> printer (fst !newCell)); addresetter (fun () -> newCell := (default, [name])); @@ -130,35 +167,52 @@ newCell let create name ?(local=false) default doc fulldoc intern printer = - createPrefInternal name local default doc fulldoc printer + createPrefInternal name `CUSTOM local default doc fulldoc printer (fun cell -> Uarg.String (fun s -> set cell (intern (fst !cell) s))) let createBool name ?(local=false) default doc fulldoc = let doc = if default then doc ^ " (default true)" else doc in - createPrefInternal name local default doc fulldoc + createPrefInternal name `BOOL local default doc fulldoc (fun v -> [if v then "true" else "false"]) (fun cell -> Uarg.Bool (fun b -> set cell b)) let createInt name ?(local=false) default doc fulldoc = - createPrefInternal name local default doc fulldoc + createPrefInternal name `INT local default doc fulldoc (fun v -> [string_of_int v]) (fun cell -> Uarg.Int (fun i -> set cell i)) let createString name ?(local=false) default doc fulldoc = - createPrefInternal name local default doc fulldoc + createPrefInternal name `STRING local default doc fulldoc (fun v -> [v]) (fun cell -> Uarg.String (fun s -> set cell s)) let createFspath name ?(local=false) default doc fulldoc = - createPrefInternal name local default doc fulldoc + createPrefInternal name `STRING local default doc fulldoc (fun v -> [System.fspathToString v]) (fun cell -> Uarg.String (fun s -> set cell (System.fspathFromString s))) let createStringList name ?(local=false) doc fulldoc = - createPrefInternal name local [] doc fulldoc + createPrefInternal name `STRING_LIST local [] doc fulldoc (fun v -> v) (fun cell -> Uarg.String (fun s -> set cell (s::(fst !cell)))) +let createBoolWithDefault name ?(local=false) doc fulldoc = + createPrefInternal name `BOOLDEF local `Default doc fulldoc + (fun v -> [match v with + `True -> "true" + | `False -> "false" + | `Default -> "default"]) + (fun cell -> + Uarg.String + (fun s -> + let v = + match s with + "yes" | "true" -> `True + | "default" | "auto" -> `Default + | _ -> `False + in + set cell v)) + (*****************************************************************************) (* Command-line parsing *) (*****************************************************************************) Modified: trunk/src/ubase/prefs.mli =================================================================== --- trunk/src/ubase/prefs.mli 2009-08-11 01:46:31 UTC (rev 386) +++ trunk/src/ubase/prefs.mli 2009-08-11 13:16:56 UTC (rev 387) @@ -49,7 +49,15 @@ -> string (* documentation string *) -> string (* full (tex) documentation string *) -> string list t (* -> new preference value *) - + +val createBoolWithDefault : + string (* preference name *) + -> ?local:bool (* whether it is local to the client *) + -> string (* documentation string *) + -> string (* full (tex) documentation string *) + -> [`True|`False|`Default] t + (* -> new preference value *) + exception IllegalValue of string (* A more general creation function that allows arbitrary functions for *) (* interning and printing values. The interning function should raise *) @@ -128,6 +136,16 @@ (* ------------------------------------------------------------------------- *) +type typ = + [`BOOL | `INT | `STRING | `STRING_LIST | `BOOLDEF | `CUSTOM | `UNKNOWN] + +val canonicalName : string -> string +val typ : string -> typ +val documentation : string -> string * string * bool +val list : unit -> string list + +(* ------------------------------------------------------------------------- *) + val printFullDocs : unit -> unit val dumpPrefsToStderr : unit -> unit Modified: trunk/src/uicommon.ml =================================================================== --- trunk/src/uicommon.ml 2009-08-11 01:46:31 UTC (rev 386) +++ trunk/src/uicommon.ml 2009-08-11 13:16:56 UTC (rev 387) @@ -688,20 +688,17 @@ let profileName = begin match !clprofile with None -> - let dirString = Os.unisonDir in - let profiles_exist = (Files.ls dirString "*.prf")<>[] in let clroots_given = !rawRoots <> [] in let n = - if profiles_exist && not(clroots_given) then begin - (* Unison has been used before: at least one profile exists. - Ask the user to choose a profile or create a new one. *) + if not(clroots_given) then begin + (* Ask the user to choose a profile or create a new one. *) clprofile := getProfile(); match !clprofile with None -> exit 0 (* None means the user wants to quit *) | Some x -> x end else begin - (* First time use, OR roots given on command line. - In either case, the profile should be the default. *) + (* Roots given on command line. + The profile should be the default. *) clprofile := Some "default"; "default" end in Modified: trunk/src/uigtk2.ml =================================================================== --- trunk/src/uigtk2.ml 2009-08-11 01:46:31 UTC (rev 386) +++ trunk/src/uigtk2.ml 2009-08-11 13:16:56 UTC (rev 387) @@ -97,6 +97,22 @@ (Gpointer.region_of_string Pixmaps.icon_data) (GdkPixbuf.get_pixels p); p +let leftPtrWatch = + lazy + (let bitmap = + Gdk.Bitmap.create_from_data + ~width:32 ~height:32 Pixmaps.left_ptr_watch + in + let color = + Gdk.Color.alloc ~colormap:(Gdk.Color.get_system_colormap ()) `BLACK in + Gdk.Cursor.create_from_pixmap + (bitmap :> Gdk.pixmap) ~mask:bitmap ~fg:color ~bg:color ~x:2 ~y:2) + +let make_busy w = Gdk.Window.set_cursor w#misc#window (Lazy.force leftPtrWatch) +let make_interactive w = + (* HACK: setting the cursor to NULL restore the default cursor *) + Gdk.Window.set_cursor w#misc#window (Obj.magic Gpointer.boxed_null) + (********************************************************************* UI state variables *********************************************************************) @@ -289,13 +305,13 @@ (* twoBox: Display a message in a window and wait for the user to hit one of two buttons. Return true if the first button is chosen, false if the second button is chosen. *) -let twoBox ~parent ~title ~message ~astock ~bstock = +let twoBox ?(kind=`DIALOG_WARNING) ~parent ~title ~astock ~bstock message = let t = GWindow.dialog ~parent ~border_width:6 ~modal:true ~no_separator:true ~allow_grow:false () in t#vbox#set_spacing 12; let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in - ignore (GMisc.image ~stock:`DIALOG_WARNING ~icon_size:`DIALOG + ignore (GMisc.image ~stock:kind ~icon_size:`DIALOG ~yalign:0. ~packing:h1#pack ()); let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in ignore (GMisc.label @@ -322,8 +338,8 @@ inExit := true; if not !busy then exit 0 else if twoBox ~parent:(toplevelWindow ()) ~title:"Premature exit" - ~message:"Unison is working, exit anyway ?" ~astock:`YES ~bstock:`NO + "Unison is working, exit anyway ?" then exit 0; inExit := false end @@ -332,12 +348,12 @@ (* warnBox: Display a warning message in a window and wait (unless we're in batch mode) for the user to hit "OK" or "Exit". *) -let warnBox title message = +let warnBox ~parent title message = let message = transcode message in if Prefs.read Globals.batch then begin (* In batch mode, just pop up a window and go ahead *) let t = - GWindow.dialog ~parent:(toplevelWindow ()) + GWindow.dialog ~parent ~border_width:6 ~modal:true ~no_separator:true ~allow_grow:false () in t#vbox#set_spacing 12; let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in @@ -354,8 +370,8 @@ end else begin inExit := true; let ok = - twoBox ~parent:(toplevelWindow ()) ~title ~message - ~astock:`OK ~bstock:`QUIT in + twoBox ~parent:(toplevelWindow ()) ~title ~astock:`OK ~bstock:`QUIT + message in if not(ok) then doExit (); inExit := false end @@ -922,6 +938,1364 @@ (* ------ *) +module React = struct + type 'a t = { mutable state : 'a; mutable observers : ('a -> unit) list } + + let make v = + let res = { state = v; observers = [] } in + let update v = + if res.state <> v then begin + res.state <- v; List.iter (fun f -> f v) res.observers + end + in + (res, update) + + let const v = fst (make v) + + let add_observer x f = x.observers <- f :: x.observers + + let state x = x.state + + let lift f x = + let (res, update) = make (f (state x)) in + add_observer x (fun v -> update (f v)); + res + + let lift2 f x y = + let (res, update) = make (f (state x) (state y)) in + add_observer x (fun v -> update (f v (state y))); + add_observer y (fun v -> update (f (state x) v)); + res + + let lift3 f x y z = + let (res, update) = make (f (state x) (state y) (state z)) in + add_observer x (fun v -> update (f v (state y) (state z))); + add_observer y (fun v -> update (f (state x) v (state z))); + add_observer z (fun v -> update (f (state x) (state y) v)); + res + + let iter f x = f (state x); add_observer x f + + type 'a event = { mutable ev_observers : ('a -> unit) list } + + let make_event () = + let res = { ev_observers = [] } in + let trigger v = List.iter (fun f -> f v) res.ev_observers in + (res, trigger) + + let add_ev_observer x f = x.ev_observers <- f :: x.ev_observers + + let hold v e = + let (res, update) = make v in + add_ev_observer e update; + res + + let iter_ev f e = add_ev_observer e f + + let lift_ev f e = + let (res, trigger) = make_event () in + add_ev_observer e (fun x -> trigger (f x)); + res + + module Ops = struct + let (>>) x f = lift f x + let (>|) x f = iter f x + + let (>>>) x f = lift_ev f x + let (>>|) x f = iter_ev f x + end +end + +module GtkReact = struct + let entry (e : #GEdit.entry) = + let (res, update) = React.make e#text in + ignore (e#connect#changed ~callback:(fun () -> update (e#text))); + res + + let text_combo ((c, _) : _ GEdit.text_combo) = + let (res, update) = React.make c#active in + ignore (c#connect#changed ~callback:(fun () -> update (c#active))); + res + + let toggle_button (b : #GButton.toggle_button) = + let (res, update) = React.make b#active in + ignore (b#connect#toggled ~callback:(fun () -> update (b#active))); + res + + let file_chooser (c : #GFile.chooser) = + let (res, update) = React.make c#filename in + ignore (c#connect#selection_changed + ~callback:(fun () -> update (c#filename))); + res + + let current_tree_view_selection (t : #GTree.view) = + let m =t#model in + List.map (fun p -> m#get_row_reference p) t#selection#get_selected_rows + + let tree_view_selection_changed t = + let (res, trigger) = React.make_event () in + ignore (t#selection#connect#changed + ~callback:(fun () -> trigger (current_tree_view_selection t))); + res + + let tree_view_selection t = + React.hold (current_tree_view_selection t) (tree_view_selection_changed t) + + let label (l : #GMisc.label) x = React.iter (fun v -> l#set_text v) x + + let label_underlined (l : #GMisc.label) x = + React.iter (fun v -> l#set_text v; l#set_use_underline true) x + + let label_markup (l : #GMisc.label) x = + React.iter (fun v -> l#set_text v; l#set_use_markup true) x + + let show w x = + React.iter (fun b -> if b then w#misc#show () else w#misc#hide ()) x + let set_sensitive w x = React.iter (fun b -> w#misc#set_sensitive b) x +end + +open React.Ops + +(* ------ *) + +(* Resize an object (typically, a label with line wrapping) so that it + use all its available space *) +let adjustSize (w : #GObj.widget) = + let notYet = ref true in + ignore + (w#misc#connect#size_allocate ~callback:(fun r -> + if !notYet then begin + notYet := false; + (* JV: I have no idea where the 12 comes from. Without it, + a window resize may happen. *) + w#misc#set_size_request ~width:(max 10 (r.Gtk.width - 12)) () + end)) + +let createProfile parent = + let assistant = GAssistant.assistant ~modal:true () in + assistant#set_transient_for parent#as_window; + assistant#set_modal true; + assistant#set_title "Profile Creation"; + + let nonEmpty s = s <> "" in +(* + let integerRe = + Str.regexp "\\([+-]?[0-9]+\\|0o[0-7]+\\|0x[0-9a-zA-Z]+\\)" in +*) + let integerRe = Str.regexp "[0-9]+" in + let isInteger s = + Str.string_match integerRe s 0 && Str.matched_string s = s in + + (* Introduction *) + let intro = + GMisc.label + ~xpad:12 ~ypad:12 + ~text:"Welcome to the Unison Profile Creation Assistant.\n\n\ + Click \"Forward\" to begin." + () in + ignore + (assistant#append_page + ~title:"Profile Creation" + ~page_type:`INTRO + ~complete:true + intro#as_widget); + + (* Profile name and description *) + let description = GPack.vbox ~border_width:12 ~spacing:6 () in + adjustSize + (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT + ~text:"Please enter the name of the profile and \ + possibly a short description." + ~packing:(description#pack ~expand:false) ()); + let tbl = + let al = GBin.alignment ~packing:(description#pack ~expand:false) () in + al#set_left_padding 12; + GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6 + ~packing:(al#add) () in + let nameEntry = + GEdit.entry ~activates_default:true + ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) () in + let name = GtkReact.entry nameEntry in + ignore (GMisc.label ~text:"Profile _name:" ~xalign:0. + ~use_underline:true ~mnemonic_widget:nameEntry + ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()); + let labelEntry = + GEdit.entry ~activates_default:true + ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () in + let label = GtkReact.entry labelEntry in + ignore (GMisc.label ~text:"_Description:" ~xalign:0. + ~use_underline:true ~mnemonic_widget:labelEntry + ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()); + let existingProfileLabel = + GMisc.label ~xalign:1. ~packing:(description#pack ~expand:false) () + in + adjustSize existingProfileLabel; + GtkReact.label_markup existingProfileLabel + (name >> fun s -> Format.sprintf " Profile %s already exists." + (escapeMarkup s)); + let profileExists = + name >> fun s -> s <> "" && System.file_exists (Prefs.profilePathname s) + in + GtkReact.show existingProfileLabel profileExists; + + ignore + (assistant#append_page + ~title:"Profile Description" + ~page_type:`CONTENT + description#as_widget); + let setPageComplete page b = assistant#set_page_complete page#as_widget b in + React.lift2 (&&) (name >> nonEmpty) (profileExists >> not) + >| setPageComplete description; + + let connection = GPack.vbox ~border_width:12 ~spacing:18 () in + let al = GBin.alignment ~packing:(connection#pack ~expand:false) () in + al#set_left_padding 12; + let vb = + GPack.vbox ~spacing:6 ~packing:(al#add) () in + adjustSize + (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT + ~text:"You can use Unison to synchronize a local directory \ + with another local directory, or with a remote directory." + ~packing:(vb#pack ~expand:false) ()); + adjustSize + (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT + ~text:"Please select the kind of synchronization \ + you want to perform." + ~packing:(vb#pack ~expand:false) ()); + let tbl = + let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in + al#set_left_padding 12; + GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6 + ~packing:(al#add) () in + ignore (GMisc.label ~text:"Description:" ~xalign:0. ~yalign:0. + ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()); + let kindCombo = + let al = + GBin.alignment ~xscale:0. ~xalign:0. + ~packing:(tbl#attach ~left:1 ~top:0) () in + GEdit.combo_box_text + ~strings:["Local"; "Using SSH"; "Using RSH"; + "Through a plain TCP connection"] + ~active:0 ~packing:(al#add) () + in + ignore (GMisc.label ~text:"Synchronization _kind:" ~xalign:0. + ~use_underline:true ~mnemonic_widget:(fst kindCombo) + ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()); + let kind = + GtkReact.text_combo kindCombo + >> fun i -> List.nth [`Local; `SSH; `RSH; `SOCKET] i + in + let isLocal = kind >> fun k -> k = `Local in + let isSSH = kind >> fun k -> k = `SSH in + let isSocket = kind >> fun k -> k = `SOCKET in + let descrLabel = + GMisc.label ~xalign:0. ~line_wrap:true + ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () + in + adjustSize descrLabel; + GtkReact.label descrLabel + (kind >> fun k -> + match k with + `Local -> + "Local synchronization." + | `SSH -> + "This is the recommended way to synchronize \ + with a remote machine. A\xc2\xa0remote instance of Unison is \ + automatically started via SSH." + | `RSH -> + "Synchronization with a remote machine by starting \ + automatically a remote instance of Unison via RSH." + | `SOCKET -> + "Synchronization with a remote machine by connecting \ + to an instance of Unison already listening \ + on a specific TCP port."); + let vb = GPack.vbox ~spacing:6 ~packing:(connection#add) () in + GtkReact.show vb (isLocal >> not); + ignore (GMisc.label ~markup:"Configuration" ~xalign:0. + ~packing:(vb#pack ~expand:false) ()); + let al = GBin.alignment ~packing:(vb#add) () in + al#set_left_padding 12; + let vb = GPack.vbox ~spacing:6 ~packing:(al#add) () in + let requirementLabel = + GMisc.label ~xalign:0. ~line_wrap:true + ~packing:(vb#pack ~expand:false) () + in + adjustSize requirementLabel; + GtkReact.label requirementLabel + (kind >> fun k -> + match k with + `Local -> + "" + | `SSH -> + "There must be an SSH client installed on this machine, \ + and Unison and an SSH server installed on the remote machine." + | `RSH -> + "There must be an RSH client installed on this machine, \ + and Unison and an RSH server installed on the remote machine." + | `SOCKET -> + "There must be a Unison server running on the remote machine, \ + listening on the port that you specify here. \ + (Use \"Unison -socket xxx\" on the remote machine to start \ + the Unison server.)"); + let connDescLabel = + GMisc.label ~xalign:0. ~line_wrap:true + ~packing:(vb#pack ~expand:false) () + in + adjustSize connDescLabel; + GtkReact.label connDescLabel + (kind >> fun k -> + match k with + `Local -> "" + | `SSH -> "Please enter the host to connect to and a user name, \ + if different from your user name on this machine." + | `RSH -> "Please enter the host to connect to and a user name, \ + if different from your user name on this machine." + | `SOCKET -> "Please enter the host and port to connect to."); + let tbl = + let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in + al#set_left_padding 12; + GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6 + ~packing:(al#add) () in + let hostEntry = + GEdit.entry ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) () in + let host = GtkReact.entry hostEntry in + ignore (GMisc.label ~text:"_Host:" ~xalign:0. + ~use_underline:true ~mnemonic_widget:hostEntry + ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()); + let userEntry = + GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () + in + GtkReact.show userEntry (isSocket >> not); + let user = GtkReact.entry userEntry in + GtkReact.show + (GMisc.label ~text:"_User:" ~xalign:0. ~yalign:0. + ~use_underline:true ~mnemonic_widget:userEntry + ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()) + (isSocket >> not); + let portEntry = + GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () + in + GtkReact.show portEntry isSocket; + let port = GtkReact.entry portEntry in + GtkReact.show + (GMisc.label ~text:"_Port:" ~xalign:0. ~yalign:0. + ~use_underline:true ~mnemonic_widget:portEntry + ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()) + isSocket; + let compressLabel = + GMisc.label ~xalign:0. ~line_wrap:true + ~text:"Data compression can greatly improve performance \ + on slow connections. However, it may slow down \ + things on (fast) local networks." + ~packing:(vb#pack ~expand:false) () + in + adjustSize compressLabel; + GtkReact.show compressLabel isSSH; + let compressButton = + let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in + al#set_left_padding 12; + (GButton.check_button ~label:"Enable _compression" ~use_mnemonic:true + ~active:true ~packing:(al#add) ()) + in + GtkReact.show compressButton isSSH; + let compress = GtkReact.toggle_button compressButton in +(*XXX Disabled for now... *) +(* + adjustSize + (GMisc.label ~xalign:0. ~line_wrap:true + ~text:"If this is possible, it is recommended that Unison \ + attempts to connect immediately to the remote machine, \ + so that it can perform some auto-detections." + ~packing:(vb#pack ~expand:false) ()); + let connectImmediately = + let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in + al#set_left_padding 12; + GtkReact.toggle_button + (GButton.check_button ~label:"Connect _immediately" ~use_mnemonic:true + ~active:true ~packing:(al#add) ()) + in + let connectImmediately = + React.lift2 (&&) connectImmediately (isLocal >> not) in +*) + let pageComplete = + React.lift2 (||) isLocal + (React.lift2 (&&) (host >> nonEmpty) + (React.lift2 (||) (isSocket >> not) (port >> isInteger))) + in + ignore + (assistant#append_page + ~title:"Connection Setup" + ~page_type:`CONTENT + connection#as_widget); + pageComplete >| setPageComplete connection; + + (* Connection to server *) +(*XXX Disabled for now... Fill in this page + let connectionInProgress = GMisc.label ~text:"..." () in + let p = + assistant#append_page + ~title:"Connecting to Server..." + ~page_type:`PROGRESS + connectionInProgress#as_widget + in + ignore + (assistant#connect#prepare (fun () -> + if assistant#current_page = p then begin + if React.state connectImmediately then begin + (* XXXX start connection... *) + assistant#set_page_complete connectionInProgress#as_widget true + end else + assistant#set_current_page (p + 1) + end)); +*) + + (* Directory selection *) + let directorySelection = GPack.vbox ~border_width:12 ~spacing:6 () in + adjustSize + (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT + ~text:"Please select the two directories that you want to synchronize." + ~packing:(directorySelection#pack ~expand:false) ()); + let secondDirLabel1 = + GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT + ~text:"The second directory is relative to your home \ + directory on the remote machine." + ~packing:(directorySelection#pack ~expand:false) () + in + adjustSize secondDirLabel1; + GtkReact.show secondDirLabel1 ((React.lift2 (||) isLocal isSocket) >> not); + let secondDirLabel2 = + GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT + ~text:"The second directory is relative to \ + the working directory of the Unison server \ + running on the remote machine." + ~packing:(directorySelection#pack ~expand:false) () + in + adjustSize secondDirLabel2; + GtkReact.show secondDirLabel2 isSocket; + let tbl = + let al = + GBin.alignment ~packing:(directorySelection#pack ~expand:false) () in + al#set_left_padding 12; + GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6 + ~packing:(al#add) () in +(*XXX Should focus on this button when becomes visible... *) + let firstDirButton = + GFile.chooser_button ~action:`SELECT_FOLDER ~title:"First Directory" + ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) () + in + isLocal >| (fun b -> firstDirButton#set_title + (if b then "First Directory" else "Local Directory")); + GtkReact.label_underlined + (GMisc.label ~xalign:0. + ~mnemonic_widget:firstDirButton + ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()) + (isLocal >> fun b -> + if b then "_First directory:" else "_Local directory:"); + let noneToEmpty o = match o with None -> "" | Some s -> s in + let firstDir = GtkReact.file_chooser firstDirButton >> noneToEmpty in + let secondDirButton = + GFile.chooser_button ~action:`SELECT_FOLDER ~title:"Second Directory" + ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () in + let secondDirLabel = + GMisc.label ~xalign:0. + ~text:"Se_cond directory:" + ~use_underline:true ~mnemonic_widget:secondDirButton + ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) () in + GtkReact.show secondDirButton isLocal; + GtkReact.show secondDirLabel isLocal; + let remoteDirEdit = + GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () + in + let remoteDirLabel = + GMisc.label ~xalign:0. + ~text:"_Remote directory:" + ~use_underline:true ~mnemonic_widget:remoteDirEdit + ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) () + in + GtkReact.show remoteDirEdit (isLocal >> not); + GtkReact.show remoteDirLabel (isLocal >> not); + let secondDir = + React.lift3 (fun b l r -> if b then l else r) isLocal + (GtkReact.file_chooser secondDirButton >> noneToEmpty) + (GtkReact.entry remoteDirEdit) + in + ignore + (assistant#append_page + ~title:"Directory Selection" + ~page_type:`CONTENT + directorySelection#as_widget); + React.lift2 (||) (isLocal >> not) (React.lift2 (<>) firstDir secondDir) + >| setPageComplete directorySelection; + + (* Specific options *) + let options = GPack.vbox ~border_width:18 ~spacing:12 () in + (* Do we need to set specific options for FAT partitions? + If under Windows, then all the options are set properly, except for + ignoreinodenumbers in case one replica is on a FAT partition on a + remote non-Windows machine. As this is unlikely, we do not + handle this case. *) + let fat = + if Util.osType = `Win32 then + React.const false + else begin + let vb = + GPack.vbox ~spacing:6 ~packing:(options#pack ~expand:false) () in + let fatLabel = + GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT + ~text:"Select the following option if one of your \ + directory is on a FAT partition. This is typically \ + the case for a USB key." + ~packing:(vb#pack ~expand:false) () + in + adjustSize fatLabel; + let fatButton = + let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in + al#set_left_padding 12; + (GButton.check_button + ~label:"Synchronization involving a _FAT partition" + ~use_mnemonic:true ~active:false ~packing:(al#add) ()) + in + GtkReact.toggle_button fatButton + end + in + (* Fastcheck is safe except on FAT partitions and on Windows when + not in Unicode mode where there is a very slight chance of + missing an update when a file is moved onto another with the same + modification time. Nowadays, FAT is rarely used on working + partitions. In most cases, we should be in Unicode mode. + Thus, it seems sensible to always enable fastcheck. *) + let fastcheck = isLocal >> not >> (fun b -> b || Util.osType = `Win32) in + (* Unicode mode can be problematic when the source machine is under + Windows and the remote machine is not, as Unison may have already + been used using the legacy Latin 1 encoding. Cygwin (stable) + also does not handle Unicode at the moment. *) + let vb = GPack.vbox ~spacing:6 ~packing:(options#pack ~expand:false) () in + let askUnicode = + isLocal >> not >> fun b -> (b || Util.isCygwin) && Util.osType = `Win32 in + GtkReact.show vb askUnicode; + adjustSize + (GMisc.label ~xalign:0. ~line_wrap:true ~justify:`LEFT + ~text:"When synchronizing in case insensitive mode, \ + Unison has to make some assumptions regarding \ + filename encoding. If ensure, use Unicode." + ~packing:(vb#pack ~expand:false) ()); + let vb = + let al = GBin.alignment + ~xscale:0. ~xalign:0. ~packing:(vb#pack ~expand:false) () in + al#set_left_padding 12; + GPack.vbox ~spacing:0 ~packing:(al#add) () + in + ignore + (GMisc.label ~xalign:0. ~text:"Filename encoding:" + ~packing:(vb#pack ~expand:false) ()); + let hb = + let al = GBin.alignment + ~xscale:0. ~xalign:0. ~packing:(vb#pack ~expand:false) () in + al#set_left_padding 12; + GPack.button_box `VERTICAL ~layout:`START + ~spacing:0 ~packing:(al#add) () + in + let unicodeButton = + GButton.radio_button ~label:"_Unicode" ~use_mnemonic:true ~active:true + ~packing:(hb#add) () + in + ignore + (GButton.radio_button ~label:"_Latin 1" ~use_mnemonic:true + ~group:unicodeButton#group ~packing:(hb#add) ()); + let unicode = + React.lift2 (||) (askUnicode >> not) (GtkReact.toggle_button unicodeButton) + in + ignore + (assistant#append_page + ~title:"Specific Options" ~complete:true + ~page_type:`CONTENT + options#as_widget); + + let conclusion = + GMisc.label + ~xpad:12 ~ypad:12 + ~text:"You have now finished filling in the profile.\n\n\ + Click \"Apply\" to create it." + () in + ignore + (assistant#append_page + ~title:"Done" ~complete:true + ~page_type:`CONFIRM + conclusion#as_widget); + + let profileName = ref None in + let saveProfile () = + let filename = Prefs.profilePathname (React.state name) in + begin try + let ch = + System.open_out_gen [Open_wronly; Open_creat; Open_excl] 0o600 filename + in + Printf.fprintf ch "# Unison preferences\n"; + let label = React.state label in + if label <> "" then Printf.fprintf ch "label = %s\n" label; + Printf.fprintf ch "root = %s\n" (React.state firstDir); + let secondDir = React.state secondDir in + let host = React.state host in + let user = match React.state user with "" -> None | u -> Some u in + let secondRoot = + match React.state kind with + `Local -> Clroot.ConnectLocal (Some secondDir) + | `SSH -> Clroot.ConnectByShell + ("ssh", host, user, None, Some secondDir) + | `RSH -> Clroot.ConnectByShell + ("rsh", host, user, None, Some secondDir) + | `SOCKET -> Clroot.ConnectBySocket + (host, React.state port, Some secondDir) + in + Printf.fprintf ch "root = %s\n" (Clroot.clroot2string secondRoot); + if React.state compress && React.state kind = `SSH then + Printf.fprintf ch "sshargs = -C\n"; + if React.state fastcheck then + Printf.fprintf ch "fastcheck = true\n"; + if React.state unicode then + Printf.fprintf ch "unicode = true\n"; + if React.state fat then begin + Printf.fprintf ch "ignorecase = true\n"; + Printf.fprintf ch "ignoreinodenumbers = true\n"; + Printf.fprintf ch "links = false\n"; + Printf.fprintf ch "perms = 0o200\n" + end; + close_out ch; + profileName := Some (React.state name) + with Sys_error _ as e -> + okBox ~parent:assistant ~typ:`ERROR ~title:"Could not save profile" + ~message:(Uicommon.exn2string e) + end; + assistant#destroy (); + in + ignore (assistant#connect#close ~callback:saveProfile); + ignore (assistant#connect#destroy ~callback:GMain.Main.quit); + ignore (assistant#connect#cancel ~callback:assistant#destroy); + assistant#show (); + GMain.Main.main (); + !profileName + +(* ------ *) + +let nameOfType t = + match t with + `BOOL -> "boolean" + | `BOOLDEF -> "boolean" + | `INT -> "integer" + | `STRING -> "text" + | `STRING_LIST -> "text list" + | `CUSTOM -> "custom" + | `UNKNOWN -> "unknown" + +let defaultValue t = + match t with + `BOOL -> ["true"] + | `BOOLDEF -> ["true"] + | `INT -> ["0"] + | `STRING -> [""] + | `STRING_LIST -> [] + | `CUSTOM -> [] + | `UNKNOWN -> [] + +let editPreference parent nm ty vl = + let t = + GWindow.dialog ~parent ~border_width:12 + ~no_separator:true ~title:"Edit the Preference" + ~modal:true () in + let vb = t#vbox in + vb#set_spacing 6; + + let isList = + match ty with + `STRING_LIST | `CUSTOM | `UNKNOWN -> true + | _ -> false + in + let columns = if isList then 5 else 4 in + let rows = if isList then 3 else 2 in + let tbl = + GPack.table ~rows ~columns ~col_spacings:12 ~row_spacings:6 + ~packing:(vb#pack ~expand:false) () in + ignore (GMisc.label ~text:"Preference:" ~xalign:0. + ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()); + ignore (GMisc.label ~text:"Description:" ~xalign:0. + ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()); + ignore (GMisc.label ~text:"Type:" ~xalign:0. + ~packing:(tbl#attach ~left:0 ~top:2 ~expand:`NONE) ()); + ignore (GMisc.label ~text:(Unicode.protect nm) ~xalign:0. ~selectable:true () + ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X)); + let (doc, _, _) = Prefs.documentation nm in + ignore (GMisc.label ~text:doc ~xalign:0. ~selectable:true () + ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X)); + ignore (GMisc.label ~text:(nameOfType ty) ~xalign:0. ~selectable:true () + ~packing:(tbl#attach ~left:1 ~top:2 ~expand:`X)); + let newValue = + if isList then begin + let valueLabel = + GMisc.label ~text:"V_alue:" ~use_underline:true ~xalign:0. ~yalign:0. + ~packing:(tbl#attach ~left:0 ~top:3 ~expand:`NONE) () + in + let cols = new GTree.column_list in + let c_value = cols#add Gobject.Data.string in + let c_ml = cols#add Gobject.Data.caml in + let lst_store = GTree.list_store cols in + let lst = + let sw = + GBin.scrolled_window ~packing:(tbl#attach ~left:1 ~top:3 ~expand:`X) + ~shadow_type:`IN ~height:200 ~width:400 + ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in + GTree.view ~model:lst_store ~headers_visible:false + ~reorderable:true ~packing:sw#add () in + valueLabel#set_mnemonic_widget (Some (lst :> GObj.widget)); + let column = + GTree.view_column + ~renderer:(GTree.cell_renderer_text [], ["text", c_value]) () + in + ignore (lst#append_column column); + let vb = + GPack.button_box + `VERTICAL ~layout:`START ~spacing:6 + ~packing:(tbl#attach ~left:2 ~top:3 ~expand:`NONE) () + in + let selection = GtkReact.tree_view_selection lst in + let hasSel = selection >> fun l -> l <> [] in + let addB = + GButton.button ~stock:`ADD ~packing:(vb#pack ~expand:false) () in + let removeB = + GButton.button ~stock:`REMOVE ~packing:(vb#pack ~expand:false) () in + let editB = + GButton.button ~stock:`EDIT ~packing:(vb#pack ~expand:false) () in + let upB = + GButton.button ~stock:`GO_UP ~packing:(vb#pack ~expand:false) () in + let downB = + GButton.button ~stock:`GO_DOWN ~packing:(vb#pack ~expand:false) () in + List.iter (fun b -> b#set_xalign 0.) [addB; removeB; editB; upB; downB]; + GtkReact.set_sensitive removeB hasSel; + let editLabel = + GMisc.label ~text:"Edited _item:" + ~use_underline:true ~xalign:0. + ~packing:(tbl#attach ~left:0 ~top:4 ~expand:`NONE) () + in + let editEntry = + GEdit.entry ~packing:(tbl#attach ~left:1 ~top:4 ~expand:`X) () in + editLabel#set_mnemonic_widget (Some (editEntry :> GObj.widget)); + let edit = GtkReact.entry editEntry in + let edited = + React.lift2 + (fun l txt -> + match l with + [rf] -> lst_store#get ~row:rf#iter ~column:c_ml <> txt + | _ -> false) + selection edit + in + GtkReact.set_sensitive editB edited; + let selectionChange = GtkReact.tree_view_selection_changed lst in + selectionChange >>| (fun s -> + match s with + [rf] -> editEntry#set_text + (lst_store#get ~row:rf#iter ~column:c_value) + | _ -> ()); + let add () = + let txt = editEntry#text in + let row = lst_store#append () in + lst_store#set ~row ~column:c_value txt; + lst_store#set ~row ~column:c_ml txt; + lst#selection#select_iter row; + lst#scroll_to_cell (lst_store#get_path row) column + in + ignore (addB#connect#clicked ~callback:add); + ignore (editEntry#connect#activate ~callback:add); + let remove () = + match React.state selection with + [rf] -> let i = rf#iter in + if lst_store#iter_next i then + lst#selection#select_iter i + else begin + let p = rf#path in + if GTree.Path.prev p then + lst#selection#select_path p + end; + ignore (lst_store#remove rf#iter) + | _ -> () + in + ignore (removeB#connect#clicked ~callback:remove); + let edit () = + match React.state selection with + [rf] -> let row = rf#iter in + let txt = editEntry#text in + lst_store#set ~row ~column:c_value txt; + lst_store#set ~row ~column:c_ml txt + | _ -> () + in + ignore (editB#connect#clicked ~callback:edit); + let updateUpDown l = + let (upS, downS) = + match l with + [rf] -> (GTree.Path.prev rf#path, lst_store#iter_next rf#iter) + | _ -> (false, false) + in + upB#misc#set_sensitive upS; + downB#misc#set_sensitive downS + in + selectionChange >>| updateUpDown; + ignore (lst_store#connect#after#row_deleted + ~callback:(fun _ -> updateUpDown (React.state selection))); + let go_up () = + match React.state selection with + [rf] -> let p = rf#path in + if GTree.Path.prev p then begin + let i = rf#iter in + let i' = lst_store#get_iter p in + ignore (lst_store#swap i i'); + lst#scroll_to_cell (lst_store#get_path i) column + end; + updateUpDown (React.state selection) + | _ -> () + in + ignore (upB#connect#clicked ~callback:go_up); + let go_down () = + match React.state selection with + [rf] -> let i = rf#iter in + if lst_store#iter_next i then begin + let i' = rf#iter in + ignore (lst_store#swap i i'); + lst#scroll_to_cell (lst_store#get_path i') column + end; + updateUpDown (React.state selection) + | _ -> () + in + ignore (downB#connect#clicked ~callback:go_down); + List.iter + (fun v -> + let row = lst_store#append () in + lst_store#set ~row ~column:c_value (Unicode.protect v); + lst_store#set ~row ~column:c_ml v) + vl; + (fun () -> + let l = ref [] in + lst_store#foreach + (fun _ row -> l := lst_store#get ~row ~column:c_ml :: !l; false); + List.rev !l) + end else begin + let v = List.hd vl in + begin match ty with + `BOOL | `BOOLDEF -> + let hb = + GPack.button_box `HORIZONTAL ~layout:`START + ~packing:(tbl#attach ~left:1 ~top:3 ~expand:`X) () + in + let isTrue = v = "true" || v = "yes" in + let trueB = + GButton.radio_button ~label:"_True" ~use_mnemonic:true + ~active:isTrue ~packing:(hb#add) () + in + ignore + (GButton.radio_button ~label:"_False" ~use_mnemonic:true + ~group:trueB#group ~active:(not isTrue) ~packing:(hb#add) ()); + ignore + (GMisc.label ~text:"Value:" ~xalign:0. + ~packing:(tbl#attach ~left:0 ~top:3 ~expand:`NONE) ()); + (fun () -> [if trueB#active then "true" else "false"]) + | `INT | `STRING -> + let valueEntry = + GEdit.entry ~text:(List.hd vl) ~width_chars: 40 + ~activates_default:true + ~packing:(tbl#attach ~left:1 ~top:3 ~expand:`X) () + in + ignore + (GMisc.label ~text:"V_alue:" ~use_underline:true ~xalign:0. + ~mnemonic_widget:valueEntry + ~packing:(tbl#attach ~left:0 ~top:3 ~expand:`NONE) ()); + (fun () -> [valueEntry#text]) + | `STRING_LIST | `CUSTOM | `UNKNOWN -> + assert false + end + end + in + + let ok = ref false in + let cancelCommand () = t#destroy () in + let cancelButton = + GButton.button ~stock:`CANCEL ~packing:t#action_area#add () in + ignore (cancelButton#connect#clicked ~callback:cancelCommand); + let okCommand _ = ok := true; t#destroy () in + let okButton = + GButton.button ~stock:`OK ~packing:t#action_area#add () in + ignore (okButton#connect#clicked ~callback:okCommand); + okButton#grab_default (); + ignore (t#connect#destroy ~callback:GMain.Main.quit); + t#show (); + GMain.Main.main (); + if !ok then Some (newValue ()) else None + + +let markupRe = Str.regexp "<\\([a-z]+\\)>\\|\\|&\\([a-z]+\\);" +let entities = + [("amp", "&"); ("lt", "<"); ("gt", ">"); ("quot", "\""); ("apos", "'")] + +let rec insertMarkupRec tags (t : #GText.view) s i tl = + try + let j = Str.search_forward markupRe s i in + if j > i then + t#buffer#insert ~tags:(List.flatten tl) (String.sub s i (j - i)); + let tag = try Some (Str.matched_group 1 s) with Not_found -> None in + match tag with + Some tag -> + insertMarkupRec tags t s (Str.group_end 0) + ((try [List.assoc tag tags] with Not_found -> []) :: tl) + | None -> + let entity = try Some (Str.matched_group 3 s) with Not_found -> None in + match entity with + None -> + insertMarkupRec tags t s (Str.group_end 0) (List.tl tl) + | Some ent -> + begin try + t#buffer#insert ~tags:(List.flatten tl) (List.assoc ent entities) + with Not_found -> () end; + insertMarkupRec tags t s (Str.group_end 0) tl + with Not_found -> + let j = String.length s in + if j > i then + t#buffer#insert ~tags:(List.flatten tl) (String.sub s i (j - i)) + +let insertMarkup tags t s = + t#buffer#set_text ""; insertMarkupRec tags t s 0 [] + +let documentPreference ~compact ~packing = + let vb = GPack.vbox ~spacing:6 ~packing () in + ignore (GMisc.label ~markup:"Documentation" ~xalign:0. + ~packing:(vb#pack ~expand:false) ()); + let al = GBin.alignment ~packing:(vb#pack ~expand:true ~fill:true) () in + al#set_left_padding 12; + let columns = if compact then 3 else 2 in + let tbl = + GPack.table ~rows:2 ~columns ~col_spacings:12 ~row_spacings:6 + ~packing:(al#add) () in + tbl#misc#set_sensitive false; + ignore (GMisc.label ~text:"Short description:" ~xalign:0. + ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()); + ignore (GMisc.label ~text:"Long description:" ~xalign:0. ~yalign:0. + ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()); + let shortDescr = + GMisc.label ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) + ~xalign:0. ~selectable:true () in + let longDescr = + let sw = + if compact then + GBin.scrolled_window ~height:128 ~width:640 + ~packing:(tbl#attach ~left:0 ~top:2 ~right:2 ~expand:`BOTH) + ~shadow_type:`IN ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () + else + GBin.scrolled_window ~height:128 ~width:640 + ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`BOTH) + ~shadow_type:`IN ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () + in + GText.view ~editable:false ~packing:sw#add ~wrap_mode:`WORD () + in + let (>>>) x f = f x in + let newlineRe = Str.regexp "\n *" in + let styleRe = Str.regexp "{\\\\\\([a-z]+\\) \\([^{}]*\\)}" in + let verbRe = Str.regexp "\\\\verb|\\([^|]*\\)|" in + let argRe = Str.regexp "\\\\ARG{\\([^{}]*\\)}" in + let textttRe = Str.regexp "\\\\texttt{\\([^{}]*\\)}" in + let emphRe = Str.regexp "\\\\emph{\\([^{}]*\\)}" in + let sectionRe = Str.regexp "\\\\sectionref{\\([^{}]*\\)}{\\([^{}]*\\)}" in + let emdash = Str.regexp_string "---" in + let parRe = Str.regexp "\\\\par *" in + let underRe = Str.regexp "\\\\_ *" in + let dollarRe = Str.regexp "\\\\\\$ *" in + let formatDoc doc = + doc >>> + Str.global_replace newlineRe " " >>> + escapeMarkup >>> + Str.global_substitute styleRe + (fun s -> + try + let tag = + match Str.matched_group 1 s with + "em" -> "i" + | "tt" -> "tt" + | _ -> raise Exit + in + Format.sprintf "<%s>%s" tag (Str.matched_group 2 s) tag + with Exit -> + Str.matched_group 0 s) >>> + Str.global_replace verbRe "\\1" >>> + Str.global_replace argRe "\\1" >>> + Str.global_replace textttRe "\\1" >>> + Str.global_replace emphRe "\\1" >>> + Str.global_replace sectionRe "Section '\\2'" >>> + Str.global_replace emdash "\xe2\x80\x94" >>> + Str.global_replace parRe "\n" >>> + Str.global_replace underRe "_" >>> + Str.global_replace dollarRe "_" + in + let tags = + let create = longDescr#buffer#create_tag in + [("i", create [`FONT_DESC (Lazy.force fontItalic)]); + ("tt", create [`FONT_DESC (Lazy.force fontMonospace)])] + in + fun nm -> + let (short, long, _) = + match nm with + Some nm -> + tbl#misc#set_sensitive true; + Prefs.documentation nm + | _ -> + tbl#misc#set_sensitive false; + ("", "", false) + in + shortDescr#set_text (String.capitalize short); + insertMarkup tags longDescr (formatDoc long) +(* longDescr#buffer#set_text (formatDoc long)*) + +let addPreference parent = + let t = + GWindow.dialog ~parent ~border_width:12 + ~no_separator:true ~title:"Add a Preference" + ~modal:true () in + let vb = t#vbox in +(* vb#set_spacing 18;*) + let paned = GPack.paned `VERTICAL ~packing:vb#add () in + + let lvb = GPack.vbox ~spacing:6 ~packing:paned#pack1 () in + let preferenceLabel = + GMisc.label + ~text:"_Preferences:" ~use_underline:true + ~xalign:0. ~packing:(lvb#pack ~expand:false) () + in + let cols = new GTree.column_list in + let c_name = cols#add Gobject.Data.string in + let basic_store = GTree.list_store cols in + let full_store = GTree.list_store cols in + let lst = + let sw = + GBin.scrolled_window ~packing:(lvb#pack ~expand:true) + ~shadow_type:`IN ~height:200 ~width:400 + ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in + GTree.view ~headers_visible:false ~packing:sw#add () in + preferenceLabel#set_mnemonic_widget (Some (lst :> GObj.widget)); + ignore (lst#append_column + (GTree.view_column + ~renderer:(GTree.cell_renderer_text [], ["text", c_name]) ())); + let hiddenPrefs = + ["auto"; "doc"; "silent"; "terse"; "testserver"; "version"] in + let insert (store : #GTree.list_store) all = + List.iter + (fun nm -> + if + all || + (let (_, _, basic) = Prefs.documentation nm in basic && + not (List.mem nm hiddenPrefs)) + then begin + let row = store#append () in + store#set ~row ~column:c_name nm + end) + (Prefs.list ()) + in + insert basic_store false; + insert full_store true; + + let showAll = + GtkReact.toggle_button + (GButton.check_button ~label:"_Show all preferences" + ~use_mnemonic:true ~active:false ~packing:(lvb#pack ~expand:false) ()) + in + showAll >| + (fun b -> + lst#set_model + (Some (if b then full_store else basic_store :> GTree.model))); + + let selection = GtkReact.tree_view_selection lst in + let updateDoc = documentPreference ~compact:true ~packing:paned#pack2 in + selection >| + (fun l -> + let nm = + match l with + [rf] -> + let row = rf#iter in + let store = + if React.state showAll then full_store else basic_store in + Some (store#get ~row ~column:c_name) + | _ -> + None + in + updateDoc nm); + + let cancelCommand () = t#destroy () in + let cancelButton = + GButton.button ~stock:`CANCEL ~packing:t#action_area#add () in + ignore (cancelButton#connect#clicked ~callback:cancelCommand); + ignore (t#event#connect#delete ~callback:(fun _ -> cancelCommand (); true)); + let ok = ref false in + let addCommand _ = ok := true; t#destroy () in + let addButton = + GButton.button ~stock:`ADD ~packing:t#action_area#add () in + ignore (addButton#connect#clicked ~callback:addCommand); + GtkReact.set_sensitive addButton (selection >> fun l -> l <> []); + ignore (lst#connect#row_activated ~callback:(fun _ _ -> addCommand ())); + addButton#grab_default (); + + ignore (t#connect#destroy ~callback:GMain.Main.quit); + t#show (); + GMain.Main.main (); + if not !ok then None else + match React.state selection with + [rf] -> + let row = rf#iter in + let store = + if React.state showAll then full_store else basic_store in + Some (store#get ~row ~column:c_name) + | _ -> + None + +let editProfile parent name = + let t = + GWindow.dialog ~parent ~border_width:12 + ~no_separator:true ~title:(Format.sprintf "%s - Profile Editor" name) + ~modal:true () in + let vb = t#vbox in +(* t#vbox#set_spacing 18;*) + let paned = GPack.paned `VERTICAL ~packing:vb#add () in + + let lvb = GPack.vbox ~spacing:6 ~packing:paned#pack1 () in + let preferenceLabel = + GMisc.label + ~text:"_Preferences:" ~use_underline:true + ~xalign:0. ~packing:(lvb#pack ~expand:false) () + in + let hb = GPack.hbox ~spacing:12 ~packing:(lvb#add) () in + let cols = new GTree.column_list in + let c_name = cols#add Gobject.Data.string in + let c_type = cols#add Gobject.Data.string in + let c_value = cols#add Gobject.Data.string in + let c_ml = cols#add Gobject.Data.caml in + let lst_store = GTree.list_store cols in + let lst_sorted_store = GTree.model_sort lst_store in + lst_sorted_store#set_sort_column_id 0 `ASCENDING; + let lst = + let sw = + GBin.scrolled_window ~packing:(hb#pack ~expand:true) + ~shadow_type:`IN ~height:300 ~width:600 + ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in + GTree.view ~model:lst_sorted_store ~packing:sw#add + ~headers_clickable:true () in + preferenceLabel#set_mnemonic_widget (Some (lst :> GObj.widget)); + let vc_name = + GTree.view_column + ~title:"Name" + ~renderer:(GTree.cell_renderer_text [], ["text", c_name]) () in + vc_name#set_sort_column_id 0; + ignore (lst#append_column vc_name); + ignore (lst#append_column + (GTree.view_column + ~title:"Type" + ~renderer:(GTree.cell_renderer_text [], ["text", c_type]) ())); + ignore (lst#append_column + (GTree.view_column + ~title:"Value" + ~renderer:(GTree.cell_renderer_text [], ["text", c_value]) ())); + let vb = + GPack.button_box + `VERTICAL ~layout:`START ~spacing:6 ~packing:(hb#pack ~expand:false) () + in + let selection = GtkReact.tree_view_selection lst in + let hasSel = selection >> fun l -> l <> [] in + let addB = + GButton.button ~stock:`ADD ~packing:(vb#pack ~expand:false) () in + let editB = + GButton.button ~stock:`EDIT ~packing:(vb#pack ~expand:false) () in + let deleteB = + GButton.button ~stock:`DELETE ~packing:(vb#pack ~expand:false) () in + List.iter (fun b -> b#set_xalign 0.) [addB; editB; deleteB]; + GtkReact.set_sensitive editB hasSel; + GtkReact.set_sensitive deleteB hasSel; + + let (modified, setModified) = React.make false in + let formatValue vl = Unicode.protect (String.concat ", " vl) in + let deletePref () = + match React.state selection with + [rf] -> + let row = lst_sorted_store#convert_iter_to_child_iter rf#iter in + let (nm, ty, vl) = lst_store#get ~row ~column:c_ml in + if + twoBox ~kind:`DIALOG_QUESTION ~parent:t ~title:"Preference Deletion" + ~bstock:`CANCEL ~astock:`DELETE + (Format.sprintf "Do you really want to delete preference %s?" + (Unicode.protect nm)) + then begin + ignore (lst_store#remove row); + setModified true + end + | _ -> + () + in + let editPref path = + let row = + lst_sorted_store#convert_iter_to_child_iter + (lst_sorted_store#get_iter path) in + let (nm, ty, vl) = lst_store#get ~row ~column:c_ml in + match editPreference t nm ty vl with + Some [] -> + deletePref () + | Some vl' when vl <> vl' -> + lst_store#set ~row ~column:c_ml (nm, ty, vl'); + lst_store#set ~row ~column:c_value (formatValue vl'); + setModified true + | _ -> + () + in + let add () = + match addPreference t with + None -> + () + | Some nm -> + let existing = ref false in + lst_store#foreach + (fun path row -> + let (nm', _, _) = lst_store#get ~row ~column:c_ml in + if nm = nm' then begin + existing := true; editPref path; true + end else + false); + if not !existing then begin + let ty = Prefs.typ nm in + match editPreference parent nm ty (defaultValue ty) with + Some vl when vl <> [] -> + let row = lst_store#append () in + lst_store#set ~row ~column:c_name (Unicode.protect nm); + lst_store#set ~row ~column:c_type (nameOfType ty); + lst_store#set ~row ~column:c_ml (nm, ty, vl); + lst_store#set ~row ~column:c_value (formatValue vl); + setModified true + | _ -> + () + end + in + ignore (addB#connect#clicked ~callback:add); + ignore (editB#connect#clicked + ~callback:(fun () -> + match React.state selection with + [p] -> editPref p#path + | _ -> ())); + ignore (deleteB#connect#clicked ~callback:deletePref); + + let updateDoc = documentPreference ~compact:true ~packing:paned#pack2 in + selection >| + (fun l -> + let nm = + match l with + [rf] -> + let row = rf#iter in + Some (lst_sorted_store#get ~row ~column:c_name) + | _ -> + None + in + updateDoc nm); + ignore (lst#connect#row_activated ~callback:(fun path _ -> editPref path)); + + let group l = + let rec groupRec l k vl l' = + match l with + (k', v) :: r -> + if k = k' then + groupRec r k (v :: vl) l' + else + groupRec r k' [v] ((k, vl) :: l') + | [] -> + Safelist.fold_left + (fun acc (k, l) -> (k, List.rev l) :: acc) [] ((k, vl) :: l') + in + match l with + (k, v) :: r -> groupRec r k [v] [] + | [] -> [] + in + let lastOne l = [List.hd (Safelist.rev l)] in + let normalizeValue t vl = + match t with + `BOOL | `INT | `STRING -> lastOne vl + | `STRING_LIST | `CUSTOM | `UNKNOWN -> vl + | `BOOLDEF -> + let l = lastOne vl in + if l = ["default"] || l = ["auto"] then [] else l + in + let (>>>) x f = f x in + Prefs.readAFile name + >>> List.map (fun (_, _, nm, v) -> Prefs.canonicalName nm, v) + >>> List.stable_sort (fun (nm, _) (nm', _) -> compare nm nm') + >>> group + >>> List.iter + (fun (nm, vl) -> + let nm = Prefs.canonicalName nm in + let ty = Prefs.typ nm in + let vl = normalizeValue ty vl in + if vl <> [] then begin + let row = lst_store#append () in + lst_store#set ~row ~column:c_name (Unicode.protect nm); + lst_store#set ~row ~column:c_type (nameOfType ty); + lst_store#set ~row ~column:c_value (formatValue vl); + lst_store#set ~row ~column:c_ml (nm, ty, vl) + end); + + let applyCommand _ = + if React.state modified then begin + let filename = Prefs.profilePathname name in + try + let ch = + System.open_out_gen [Open_wronly; Open_creat; Open_trunc] 0o600 + filename + in + (*XXX Should trim whitespaces and check for '\n' at some point *) + Printf.fprintf ch "# Unison preferences\n"; + lst_store#foreach + (fun path row -> + let (nm, _, vl) = lst_store#get ~row ~column:c_ml in + List.iter (fun v -> Printf.fprintf ch "%s = %s\n" nm v) vl; + false); + close_out ch; + setModified false + with Sys_error _ as e -> + okBox ~parent:t ~typ:`ERROR ~title:"Could not save profile" + ~message:(Uicommon.exn2string e) + end + in + let applyButton = + GButton.button ~stock:`APPLY ~packing:t#action_area#add () in + ignore (applyButton#connect#clicked ~callback:applyCommand); + GtkReact.set_sensitive applyButton modified; + let cancelCommand () = t#destroy () in + let cancelButton = + GButton.button ~stock:`CANCEL ~packing:t#action_area#add () in + ignore (cancelButton#connect#clicked ~callback:cancelCommand); + ignore (t#event#connect#delete ~callback:(fun _ -> cancelCommand (); true)); + let okCommand _ = applyCommand (); t#destroy () in + let okButton = + GButton.button ~stock:`OK ~packing:t#action_area#add () in + ignore (okButton#connect#clicked ~callback:okCommand); + okButton#grab_default (); +(* +List.iter + (fun (nm, _, long) -> + try + let long = formatDoc long in + ignore (Str.search_forward (Str.regexp_string "\\") long 0); + Format.eprintf "%s %s at ." nm long + with Not_found -> ()) +(Prefs.listVisiblePrefs ()); +*) + +(* +TODO: + - Extra tabs for common preferences + (should keep track of any change, or blacklist some preferences) + - Add, modify, delete + - Keep track of whether there is any change (apply button) +*) + ignore (t#connect#destroy ~callback:GMain.Main.quit); + t#show (); + GMain.Main.main () + +(* ------ *) + let profilesAndRoots = ref [] let scanProfiles () = @@ -950,163 +2324,174 @@ (Files.ls Os.unisonDir "*.prf"))) let getProfile quit = - (* The selected profile *) - let result = ref None in + let ok = ref false in (* Build the dialog *) let t = - GWindow.dialog ~parent:(toplevelWindow ()) - ~title:"Profiles" ~modal:true ~width:400 () in + GWindow.dialog ~parent:(toplevelWindow ()) ~border_width:12 + ~no_separator:true ~title:"Profile Selection" + ~modal:true () in + t#set_default_width 550; - let cancelCommand _ = t#destroy (); result := None in - let cancelButton = GButton.button ~stock:(if quit then `QUIT else `CANCEL) + let cancelCommand _ = t#destroy () in + let cancelButton = + GButton.button ~stock:(if quit then `QUIT else `CANCEL) ~packing:t#action_area#add () in ignore (cancelButton#connect#clicked ~callback:cancelCommand); ignore (t#event#connect#delete ~callback:(fun _ -> cancelCommand (); true)); cancelButton#misc#set_can_default true; - let okCommand() = t#destroy () in + let okCommand() = ok := true; t#destroy () in let okButton = - GButton.button ~stock:`OK ~packing:t#action_area#add () in + GButton.button ~stock:`OPEN ~packing:t#action_area#add () in ignore (okButton#connect#clicked ~callback:okCommand); okButton#misc#set_sensitive false; okButton#grab_default (); let vb = t#vbox in + t#vbox#set_spacing 18; - ignore (GMisc.label - ~text:"Select an existing profile or create a new one" - ~xpad:2 ~ypad:5 ~packing:(vb#pack ~expand:false) ()); + let al = GBin.alignment ~packing:(vb#add) () in + al#set_left_padding 12; + let lvb = GPack.vbox ~spacing:6 ~packing:(al#add) () in + let selectLabel = + GMisc.label + ~text:"Select a _profile:" ~use_underline:true + ~xalign:0. ~packing:(lvb#pack ~expand:false) () + in + let hb = GPack.hbox ~spacing:12 ~packing:(lvb#add) () in let sw = - GBin.scrolled_window ~packing:(vb#pack ~expand:true) ~height:200 - ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in - let lst = GList.clist_poly ~selection_mode:`BROWSE ~packing:(sw#add) () in - let selRow = ref 0 in - let fillLst default = - scanProfiles(); - lst#freeze (); - lst#clear (); - let i = ref 0 in (* FIX: Work around a lablgtk bug *) - Safelist.iter - (fun (profile, info) -> - let labeltext = - match info.label with None -> "" | Some(l) -> " ("^l^")" in - let s = profile ^ labeltext in - ignore (lst#append [s]); - if profile = default then selRow := !i; - lst#set_row_data !i (profile, info); - incr i) - (Safelist.sort (fun (p, _) (p', _) -> compare p p') !profilesAndRoots); - let r = lst#rows in - let p = if r < 2 then 0. else float !selRow /. float (r - 1) in - lst#scroll_vertical `JUMP p; - lst#thaw () in + GBin.scrolled_window ~packing:(hb#pack ~expand:true) ~height:200 + ~shadow_type:`IN ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in + let cols = new GTree.column_list in + let c_name = cols#add Gobject.Data.string in + let c_label = cols#add Gobject.Data.string in + let c_ml = cols#add Gobject.Data.caml in + let lst_store = GTree.list_store cols in + let lst = GTree.view ~model:lst_store ~packing:sw#add () in + selectLabel#set_mnemonic_widget (Some (lst :> GObj.widget)); + let vc_name = + GTree.view_column + ~title:"Profile" + ~renderer:(GTree.cell_renderer_text [], ["text", c_name]) () + in + ignore (lst#append_column vc_name); + ignore (lst#append_column + (GTree.view_column + ~title:"Description" + ~renderer:(GTree.cell_renderer_text [], ["text", c_label]) ())); + + let vb = GPack.vbox ~spacing:6 ~packing:(vb#pack ~expand:false) () in + ignore (GMisc.label ~markup:"Summary" ~xalign:0. + ~packing:(vb#pack ~expand:false) ()); + let al = GBin.alignment ~packing:(vb#pack ~expand:false) () in + al#set_left_padding 12; let tbl = - GPack.table ~rows:2 ~columns:2 ~packing:(vb#pack ~expand:true) () in + GPack.table ~rows:2 ~columns:2 ~col_spacings:12 ~row_spacings:6 + ~packing:(al#add) () in tbl#misc#set_sensitive false; - ignore (GMisc.label ~text:"Root 1:" ~xpad:2 + ignore (GMisc.label ~text:"First root:" ~xalign:0. ~packing:(tbl#attach ~left:0 ~top:0 ~expand:`NONE) ()); - ignore (GMisc.label ~text:"Root 2:" ~xpad:2 + ignore (GMisc.label ~text:"Second root:" ~xalign:0. ~packing:(tbl#attach ~left:0 ~top:1 ~expand:`NONE) ()); let root1 = - GEdit.entry ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) - ~editable:false () in + GMisc.label ~packing:(tbl#attach ~left:1 ~top:0 ~expand:`X) + ~xalign:0. ~selectable:true () in let root2 = - GEdit.entry ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) - ~editable:false () in - root1#misc#set_can_focus false; - root2#misc#set_can_focus false; - let hb = - GPack.hbox ~border_width:2 ~spacing:2 ~packing:(vb#pack ~expand:false) () + GMisc.label ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) + ~xalign:0. ~selectable:true () in + + let fillLst default = + scanProfiles(); + lst_store#clear (); + Safelist.iter + (fun (profile, info) -> + let labeltext = + match info.label with None -> "" | Some l -> l in + let row = lst_store#append () in + lst_store#set ~row ~column:c_name (Unicode.protect profile); + lst_store#set ~row ~column:c_label (Unicode.protect labeltext); + lst_store#set ~row ~column:c_ml (profile, info); + if Some profile = default then begin + lst#selection#select_iter row; + lst#scroll_to_cell (lst_store#get_path row) vc_name + end) + (Safelist.sort (fun (p, _) (p', _) -> compare p p') !profilesAndRoots) in - let nw = - GButton.button ~label:"Create new profile" - ~packing:(hb#pack ~expand:false) () in - ignore (nw#connect#clicked ~callback:(fun () -> - let t = - GWindow.dialog ~title:"New profile" ~modal:true () - in - let vb = GPack.vbox ~border_width:4 ~packing:t#vbox#add () in - let f = GPack.vbox ~packing:(vb#pack ~expand:true ~padding:4) () in - let f0 = GPack.hbox ~spacing:4 ~packing:f#add () in - ignore (GMisc.label ~text:"Profile name:" - ~packing:(f0#pack ~expand:false) ()); - let prof = GEdit.entry ~packing:f0#add () in - prof#misc#grab_focus (); + let selection = GtkReact.tree_view_selection lst in + let hasSel = selection >> fun l -> l <> [] in + let selInfo = + selection >> fun l -> + match l with + [rf] -> Some (lst_store#get ~row:rf#iter ~column:c_ml, rf) + | _ -> None + in + selInfo >| + (fun info -> + match info with + Some ((profile, info), _) -> + begin match info.roots with + [r1; r2] -> root1#set_text (Unicode.protect r1); + root2#set_text (Unicode.protect r2); + tbl#misc#set_sensitive true + | _ -> root1#set_text ""; root2#set_text ""; + tbl#misc#set_sensitive false + end + | None -> + root1#set_text ""; root2#set_text ""; + tbl#misc#set_sensitive false); + GtkReact.set_sensitive okButton hasSel; - let exit () = t#destroy (); GMain.Main.quit () in - ignore (t#event#connect#delete ~callback:(fun _ -> exit (); true)); + let vb = + GPack.button_box + `VERTICAL ~layout:`START ~spacing:6 ~packing:(hb#pack ~expand:false) () + in + let addButton = + GButton.button ~stock:`ADD ~packing:(vb#pack ~expand:false) () in + ignore (addButton#connect#clicked + ~callback:(fun () -> + match createProfile t with + Some p -> fillLst (Some p) | None -> ())); + let editButton = + GButton.button ~stock:`EDIT ~packing:(vb#pack ~expand:false) () in + ignore (editButton#connect#clicked + ~callback:(fun () -> match React.state selInfo with + None -> () + | Some ((p, _), _) -> editProfile t p)); + GtkReact.set_sensitive editButton hasSel; + let deleteProfile () = + match React.state selInfo with + Some ((profile, _), rf) -> + if + twoBox ~kind:`DIALOG_QUESTION ~parent:t ~title:"Profile Deletion" + ~bstock:`CANCEL ~astock:`DELETE + (Format.sprintf "Do you really want to delete profile %s?" + (transcode profile)) + then begin + try + System.unlink (Prefs.profilePathname profile); + ignore (lst_store#remove rf#iter) + with Unix.Unix_error _ -> () + end + | None -> + () + in + let deleteButton = + GButton.button ~stock:`DELETE ~packing:(vb#pack ~expand:false) () in + ignore (deleteButton#connect#clicked ~callback:deleteProfile); + GtkReact.set_sensitive deleteButton hasSel; + List.iter (fun b -> b#set_xalign 0.) [addButton; editButton; deleteButton]; - let f3 = t#action_area in - let okCommand () = - let profile = prof#text in - if profile <> "" then - let filename = Prefs.profilePathname profile in - if System.file_exists filename then - okBox - ~parent:t - ~title:"Error" ~typ:`ERROR - ~message:("Profile \"" - ^ (transcodeFilename profile) - ^ "\" already exists!\nPlease select another name.") - else - (* Make an empty file *) - let ch = - System.open_out_gen - [Open_wronly; Open_creat; Open_excl] 0o600 filename in - close_out ch; - fillLst profile; - exit () in - let cancelButton = - GButton.button ~stock:`CANCEL ~packing:f3#add () in - ignore (cancelButton#connect#clicked ~callback:exit); - let okButton = GButton.button ~stock:`OK ~packing:f3#add () in - ignore (okButton#connect#clicked ~callback:okCommand); - okButton#grab_default (); - - t#show (); - GMain.Main.main ())); - - ignore (lst#connect#unselect_row ~callback:(fun ~row:_ ~column:_ ~event:_ -> - root1#set_text ""; root2#set_text ""; - result := None; - tbl#misc#set_sensitive false; - okButton#misc#set_sensitive false)); - - let select_row i = - (* Inserting the first row triggers the signal, even before the row - data is set. So, we need to catch the corresponding exception *) - (try - let (profile, info) = lst#get_row_data i in - result := Some profile; - begin match info.roots with - [r1; r2] -> root1#set_text (Unicode.protect r1); - root2#set_text (Unicode.protect r2); - tbl#misc#set_sensitive true - | _ -> root1#set_text ""; root2#set_text ""; - tbl#misc#set_sensitive false - end; - okButton#misc#set_sensitive true - with Gpointer.Null -> ()) in - - ignore (lst#connect#select_row - ~callback:(fun ~row:i ~column:_ ~event:_ -> select_row i)); - - ignore (lst#event#connect#button_press ~callback:(fun ev -> - match GdkEvent.get_type ev with - `TWO_BUTTON_PRESS -> - okCommand (); - true - | _ -> - false)); - fillLst "default"; - select_row !selRow; + ignore (lst#connect#row_activated ~callback:(fun _ _ -> okCommand ())); + fillLst None; lst#misc#grab_focus (); ignore (t#connect#destroy ~callback:GMain.Main.quit); t#show (); GMain.Main.main (); - !result + match React.state selInfo with + Some ((p, _), _) when !ok -> Some p + | _ -> None (* ------ *) @@ -1178,7 +2563,7 @@ ~allow_grow:false () in t#vbox#set_spacing 12; let h1 = GPack.hbox ~border_width:6 ~spacing:12 ~packing:t#vbox#pack () in - ignore (GMisc.image ~stock:`DIALOG_WARNING ~icon_size:`DIALOG + ignore (GMisc.image ~stock:`DIALOG_QUESTION ~icon_size:`DIALOG ~yalign:0. ~packing:h1#pack ()); let v1 = GPack.vbox ~spacing:12 ~packing:h1#pack () in ignore (GMisc.label @@ -1235,7 +2620,9 @@ TOP-LEVEL WINDOW **********************************************************************) -let displayWaitMessage () = Trace.status (Uicommon.contactingServerMsg ()) +let displayWaitMessage () = + make_busy (toplevelWindow ()); + Trace.status (Uicommon.contactingServerMsg ()) (* ------ *) @@ -1352,7 +2739,7 @@ ~height:(Prefs.read Uicommon.mainWindowHeight * 12) ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in GList.clist ~columns:5 ~titles_show:true - ~selection_mode:(*`BROWSE*)`MULTIPLE ~packing:sw#add () in + ~selection_mode:`MULTIPLE ~packing:sw#add () in (* let cols = new GTree.column_list in let c_replica1 = cols#add Gobject.Data.string in @@ -1413,16 +2800,16 @@ let showDetCommand () = let details = match currentRow () with - None -> + None -> None | Some row -> let path = Path.toString !theState.(row).ri.path1 in - match !theState.(row).whatHappened with - Some (Util.Failed _, Some det) -> + match !theState.(row).whatHappened with + Some (Util.Failed _, Some det) -> Some ("Merge execution details for file" ^ transcodeFilename path, det) - | _ -> + | _ -> match !theState.(row).ri.replicas with Problem err -> Some ("Errors for file " ^ transcodeFilename path, err) @@ -1541,7 +2928,7 @@ | Different _ -> (true, Uicommon.details2string !theState.(row).ri " ") in - let path = Path.toString !theState.(row).ri.path1 in + let path = Path.toString !theState.(row).ri.path1 in detailsWindow#buffer#set_text ""; detailsWindow#buffer#insert ~tags:[detailsWindowPath] (transcodeFilename path); @@ -1941,6 +3328,7 @@ let clearMainWindow () = grDisactivateAll (); + make_busy toplevelWindow; mainWindow#clear(); detailsWindow#buffer#set_text "" in @@ -1987,6 +3375,7 @@ stopStats (); grSet grGo (Array.length !theState > 0); grSet grRescan true; + make_interactive toplevelWindow; if Prefs.read Globals.confirmBigDeletes then begin if dangerousPaths <> [] then begin Prefs.set Globals.batch false; @@ -2077,6 +3466,7 @@ Trace.status "Nothing to synchronize" else begin grDisactivateAll (); + make_busy toplevelWindow; Trace.status "Propagating changes"; Transport.logStart (); @@ -2097,7 +3487,7 @@ let rec loop i actions pRiThisRound = if i < im then begin let theSI = !theState.(i) in - let textDetailed = ref None in + let textDetailed = ref None in let action = match theSI.whatHappened with None -> @@ -2108,19 +3498,19 @@ Transport.transportItem theSI.ri (Uutil.File.ofLine i) (fun title text -> - textDetailed := (Some text); + textDetailed := (Some text); if Prefs.read Uicommon.confirmmerge then - twoBoxAdvanced + twoBoxAdvanced ~parent:toplevelWindow - ~title:title - ~message:("Do you want to commit the changes to" - ^ " the replicas ?") - ~longtext:text - ~advLabel:"View details..." - ~astock:`YES - ~bstock:`NO + ~title:title + ~message:("Do you want to commit the changes to" + ^ " the replicas ?") + ~longtext:text + ~advLabel:"View details..." + ~astock:`YES + ~bstock:`NO else - true) + true) >>= (fun () -> return Util.Succeeded)) (fun e -> @@ -2234,6 +3624,7 @@ displayGlobalProgress 0.; grSet grRescan true; + make_interactive toplevelWindow; if failureCount + partialCount + skippedCount > 0 then begin let format n item sing plur = @@ -2779,7 +4170,8 @@ (* Initialize the GTK library *) ignore (GMain.Main.init ()); - Util.warnPrinter := Some (warnBox "Warning"); + Util.warnPrinter := + Some (fun msg -> warnBox ~parent:(toplevelWindow ()) "Warning" msg); GtkSignal.user_handler := (fun exn -> Modified: trunk/src/update.ml =================================================================== --- trunk/src/update.ml 2009-08-11 01:46:31 UTC (rev 386) +++ trunk/src/update.ml 2009-08-11 13:16:56 UTC (rev 387) @@ -978,7 +978,7 @@ timestamps have been changed without the files being actually updated. *) let fastcheck = - Prefs.createString "fastcheck" "default" + Prefs.createBoolWithDefault "fastcheck" "!do fast update detection (true/false/default)" ( "When this preference is set to \\verb|true|, \ Unison will use the modification time and length of a file as a @@ -1003,10 +1003,8 @@ \\sectionref{fastcheck}{Fast Checking} for more information.") let useFastChecking () = - (Prefs.read fastcheck = "yes") - || (Prefs.read fastcheck = "true") - || (Prefs.read fastcheck = "default" && Util.osType = `Unix) - || (Prefs.read fastcheck = "auto" && Util.osType = `Unix) + Prefs.read fastcheck = `True + || (Prefs.read fastcheck = `Default && Util.osType = `Unix) let immutable = Pred.create "immutable" ~advanced:true ("This preference specifies paths for directories whose \ From bcpierce at cis.upenn.edu Fri Aug 14 15:01:31 2009 From: bcpierce at cis.upenn.edu (Benjamin Pierce) Date: Fri, 14 Aug 2009 15:01:31 -0400 Subject: [Unison-hackers] Unison stable version, bugfix release (2.27.157) Message-ID: <9DA0CC76-CD17-4306-B969-77F974100EE5@cis.upenn.edu> A new stable version of Unison has been released, incorporating a number of miscellaneous bugfixes from Jerome Vouillon. The new version, 2.27.157, is compatible with the old stable version (2.27.57). Package maintainers are encouraged to switch to the new version. Best, Benjamin From vouillon at seas.upenn.edu Tue Aug 18 09:14:35 2009 From: vouillon at seas.upenn.edu (vouillon@seas.upenn.edu) Date: Tue, 18 Aug 2009 09:14:35 -0400 Subject: [Unison-hackers] [unison-svn] r388 - in trunk/src: . ubase Message-ID: <200908181314.n7IDEaQg019919@yaws.seas.upenn.edu> Author: vouillon Date: 2009-08-18 09:14:35 -0400 (Tue, 18 Aug 2009) New Revision: 388 Modified: trunk/src/RECENTNEWS trunk/src/case.ml trunk/src/copy.ml trunk/src/fileinfo.ml trunk/src/mkProjectInfo.ml trunk/src/osx.ml trunk/src/ubase/prefs.ml trunk/src/ubase/prefs.mli trunk/src/update.ml Log: * Fixed incompatible protocol change introduced in last commit (the type of some preferences was changed) Modified: trunk/src/RECENTNEWS =================================================================== --- trunk/src/RECENTNEWS 2009-08-11 13:16:56 UTC (rev 387) +++ trunk/src/RECENTNEWS 2009-08-18 13:14:35 UTC (rev 388) @@ -1,3 +1,9 @@ +CHANGES FROM VERSION 2.37.11 + +* Fixed incompatible protocol change introduced in last commit + (the type of some preferences was changed) + +------------------------------- CHANGES FROM VERSION 2.37.10 * GTK UI: Modified: trunk/src/case.ml =================================================================== --- trunk/src/case.ml 2009-08-11 13:16:56 UTC (rev 387) +++ trunk/src/case.ml 2009-08-18 13:14:35 UTC (rev 388) @@ -54,7 +54,7 @@ let defaultToUnicode = false let useUnicode b = - let pref = Prefs.read unicode in + let pref = Prefs.readBoolWithDefault unicode in pref = `True || (defaultToUnicode && pref = `Default && b) @@ -66,8 +66,8 @@ (* server with the rest of the prefs. *) let init b = Prefs.set someHostIsInsensitive - (Prefs.read caseInsensitiveMode = `True || - (Prefs.read caseInsensitiveMode = `Default && b)); + (Prefs.readBoolWithDefault caseInsensitiveMode = `True || + (Prefs.readBoolWithDefault caseInsensitiveMode = `Default && b)); Prefs.set unicodeEncoding (useUnicode b) (****) Modified: trunk/src/copy.ml =================================================================== --- trunk/src/copy.ml 2009-08-11 13:16:56 UTC (rev 387) +++ trunk/src/copy.ml 2009-08-18 13:14:35 UTC (rev 388) @@ -690,8 +690,8 @@ else Prefs.read copyprog in - let extraquotes = Prefs.read copyquoterem = `True - || ( Prefs.read copyquoterem = `Default + let extraquotes = Prefs.readBoolWithDefault copyquoterem = `True + || ( Prefs.readBoolWithDefault copyquoterem = `Default && Util.findsubstring "rsync" prog <> None) in let addquotes root s = match root with Modified: trunk/src/fileinfo.ml =================================================================== --- trunk/src/fileinfo.ml 2009-08-11 13:16:56 UTC (rev 387) +++ trunk/src/fileinfo.ml 2009-08-18 13:14:35 UTC (rev 388) @@ -36,8 +36,8 @@ let init b = Prefs.set symlinksAllowed - (Prefs.read allowSymlinks = `True || - (Prefs.read allowSymlinks = `Default && not b)) + (Prefs.readBoolWithDefault allowSymlinks = `True || + (Prefs.readBoolWithDefault allowSymlinks = `Default && not b)) type typ = [ `ABSENT | `FILE | `DIRECTORY | `SYMLINK ] Modified: trunk/src/mkProjectInfo.ml =================================================================== --- trunk/src/mkProjectInfo.ml 2009-08-11 13:16:56 UTC (rev 387) +++ trunk/src/mkProjectInfo.ml 2009-08-18 13:14:35 UTC (rev 388) @@ -65,7 +65,7 @@ Str.matched_group 1 str;; let extract_int re str = int_of_string (extract_str re str);; -let revisionString = "$Rev: 387$";; +let revisionString = "$Rev: 388$";; let pointVersion = if String.length revisionString > 5 then Scanf.sscanf revisionString "$Rev: %d " (fun x -> x) - pointVersionOrigin else (* Determining the pointVersionOrigin in bzr is kind of tricky: @@ -87,20 +87,3 @@ Printf.printf "VERSION=%d.%d.%d\n" majorVersion minorVersion pointVersion;; Printf.printf "NAME=%s\n" projectName;; - - - - - - - - - - - - - - - - - Modified: trunk/src/osx.ml =================================================================== --- trunk/src/osx.ml 2009-08-11 13:16:56 UTC (rev 387) +++ trunk/src/osx.ml 2009-08-18 13:14:35 UTC (rev 388) @@ -45,8 +45,8 @@ let init b = Prefs.set rsrc - (Prefs.read rsrcSync = `True || - (Prefs.read rsrcSync = `Default && b)) + (Prefs.readBoolWithDefault rsrcSync = `True || + (Prefs.readBoolWithDefault rsrcSync = `Default && b)) (****) Modified: trunk/src/ubase/prefs.ml =================================================================== --- trunk/src/ubase/prefs.ml 2009-08-11 13:16:56 UTC (rev 387) +++ trunk/src/ubase/prefs.ml 2009-08-18 13:14:35 UTC (rev 388) @@ -197,7 +197,8 @@ (fun cell -> Uarg.String (fun s -> set cell (s::(fst !cell)))) let createBoolWithDefault name ?(local=false) doc fulldoc = - createPrefInternal name `BOOLDEF local `Default doc fulldoc + createPrefInternal name `BOOLDEF local "default" doc fulldoc +(* (fun v -> [match v with `True -> "true" | `False -> "false" @@ -212,7 +213,15 @@ | _ -> `False in set cell v)) +*) + (fun v -> [v]) (fun cell -> Uarg.String (fun s -> set cell s)) +let readBoolWithDefault p = + match read p with + "yes" | "true" -> `True + | "default" | "auto" -> `Default + | _ -> `False + (*****************************************************************************) (* Command-line parsing *) (*****************************************************************************) Modified: trunk/src/ubase/prefs.mli =================================================================== --- trunk/src/ubase/prefs.mli 2009-08-11 13:16:56 UTC (rev 387) +++ trunk/src/ubase/prefs.mli 2009-08-18 13:14:35 UTC (rev 388) @@ -3,7 +3,9 @@ type 'a t -val read : 'a t -> 'a +val read : 'a t -> 'a +(*FIX: remove this function and change the type of the preferences instead*) +val readBoolWithDefault : string t -> [ `Default | `False | `True ] val set : 'a t -> 'a -> unit val name : 'a t -> string list @@ -55,7 +57,7 @@ -> ?local:bool (* whether it is local to the client *) -> string (* documentation string *) -> string (* full (tex) documentation string *) - -> [`True|`False|`Default] t + -> string t (* -> new preference value *) exception IllegalValue of string Modified: trunk/src/update.ml =================================================================== --- trunk/src/update.ml 2009-08-11 13:16:56 UTC (rev 387) +++ trunk/src/update.ml 2009-08-18 13:14:35 UTC (rev 388) @@ -1003,8 +1003,8 @@ \\sectionref{fastcheck}{Fast Checking} for more information.") let useFastChecking () = - Prefs.read fastcheck = `True - || (Prefs.read fastcheck = `Default && Util.osType = `Unix) + Prefs.readBoolWithDefault fastcheck = `True + || (Prefs.readBoolWithDefault fastcheck = `Default && Util.osType = `Unix) let immutable = Pred.create "immutable" ~advanced:true ("This preference specifies paths for directories whose \