src/gtk2/gui/configWindow.ml

   1 (* Copyright 2004 b8_bavard, INRIA *)
   2 (*
   3     This file is part of mldonkey.
   4
   5     mldonkey is free software; you can redistribute it and/or modify
   6     it under the terms of the GNU General Public License as published by
   7     the Free Software Foundation; either version 2 of the License, or
   8     (at your option) any later version.
   9
  10     mldonkey is distributed in the hope that it will be useful,
  11     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13     GNU General Public License for more details.
  14
  15     You should have received a copy of the GNU General Public License
  16     along with mldonkey; if not, write to the Free Software
  17     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18 *)
  19
  20 (* preference settings of MLDonkey. *)
  21
  22 open GuiTypes2
  23
  24 module M = GuiMessages
  25 module O = GuiOptions
  26 module A = GuiArt
  27 module U = GuiUtf8
  28
  29 let (!!) = Options.(!!)
  30 let (<:>) = GuiTools.(<:>)
  31
  32 let verbose = O.gtk_verbose_configwin
  33
  34 let lprintf' fmt =
  35   Printf2.lprintf ("GuiConfigWindow: " ^^ fmt)
  36
  37 type pref_box =
  38   BFilename
  39 | BPath
  40 | BPassword
  41 | BString
  42 | BCombo
  43 | BTime
  44 | BColor
  45 | BFont
  46 | BScale
  47 | BFloat
  48 | BInt
  49 | BInt32
  50 | BInt64
  51 | BAdvanced
  52 | BBool
  53
  54 type ('a, 'b, 'c) preference =
  55   {
  56     pref_section : 'a option;
  57     opt_section : string;
  58     pref_subsection : 'b option;
  59     mutable pref_help : string;
  60     pref_advanced : bool;
  61     pref_default : string;
  62
  63     mutable pref_name : string;
  64     mutable pref_label : string;
  65     mutable pref_group : 'c option;
  66     mutable pref_option_list : string list;    (* Used for combo_box *)
  67     mutable pref_value : string;
  68     mutable pref_new_value : string;           (* Internally used by ConfigWindow *)
  69     mutable pref_type : pref_box;
  70     mutable pref_apply : unit -> unit;         (* Becarefull overwritten by ConfigWindow *)
  71     mutable pref_apply_default : unit -> unit; (* Becarefull overwritten by ConfigWindow *)
  72   }
  73
  74 (*************************************************************************)
  75 (*                                                                       *)
  76 (*                         Global functions                              *)
  77 (*                                                                       *)
  78 (*************************************************************************)
  79
  80 let safe_int s = float_of_int (Options.value_to_int (Options.StringValue s))
  81
  82 let safe_int32 s =
  83   try
  84     Int32.to_float (Int32.of_string s)
  85   with _ -> failwith "Options: not an int32 option"
  86
  87 let safe_int64 s = Int64.to_float (Options.value_to_int64 (Options.StringValue s))
  88
  89 let safe_float s = Options.value_to_float (Options.StringValue s)
  90
  91 let safe_bool s = Options.value_to_bool (Options.StringValue s)
  92
  93 let remove_ s =
  94   String2.replace s '_' ""
  95
  96 (*************************************************************************)
  97 (*                                                                       *)
  98 (*                         message_to_stem                               *)
  99 (*                                                                       *)
 100 (*************************************************************************)
 101
 102 let message_to_stem m context pixels =
 103   let pango_layout = Pango.Layout.create context in
 104   let m = String2.replace m '\n' " " in
 105   let sl = String2.split_simplify m ' ' in
 106   let m =
 107     let s = ref "" in
 108     List.iter (fun t ->
 109       let str = match !s with "" -> t | _ -> !s ^ " " ^ t in
 110       Pango.Layout.set_text pango_layout str;
 111       if fst (Pango.Layout.get_pixel_size pango_layout) <= pixels
 112         then s := str
 113         else s := !s ^ "\n" ^ t
 114     ) sl;
 115     !s
 116   in
 117   (U.simple_utf8_of (Printf.sprintf "%s" m))
 118
 119 (*************************************************************************)
 120 (*                                                                       *)
 121 (*                         event_wrap_widget                             *)
 122 (*                                                                       *)
 123 (*************************************************************************)
 124
 125 let event_wrap_widget ~w ~p ?h_label () =
 126   match h_label with
 127       None -> w#coerce
 128     | Some label ->
 129         begin
 130           let evbox = GBin.event_box () in
 131           ignore (evbox#event#add [`ENTER_NOTIFY;`LEAVE_NOTIFY]);
 132           ignore (evbox#event#connect#enter_notify
 133             ~callback:
 134               (fun ev ->
 135                  if GdkEvent.get_type ev = `ENTER_NOTIFY
 136                    then begin
 137                      let context = label#misc#pango_context#as_context in
 138                      let dw = new GDraw.drawable label#misc#window in
 139                      let width = (fst dw#size) * 7 / 10 in (* looks to be the good ratio with several themes. to see ... *)
 140                      (if !!verbose then lprintf' "Help box width %d\n" width);
 141                      label#set_label (message_to_stem p.pref_help context width);
 142                      true
 143                    end else false
 144           ));
 145           ignore (evbox#event#connect#leave_notify
 146             ~callback:
 147               (fun ev ->
 148                  if GdkEvent.get_type ev = `LEAVE_NOTIFY
 149                    then (label#set_label ""; true)
 150                    else false
 151           ));
 152           evbox#add w#coerce;
 153           evbox#coerce
 154         end
 155
 156 (*************************************************************************)
 157 (*                                                                       *)
 158 (*                         add_string_param                              *)
 159 (*                                                                       *)
 160 (*************************************************************************)
 161
 162 let add_string_param ~p ~top ~(table : GPack.table) ?(h_label : GMisc.label option) () =
 163   let label =
 164     GMisc.label ~xalign:0.
 165       ~markup:(U.simple_utf8_of p.pref_label) ()
 166   in
 167   let edit =
 168      GEdit.entry ~text:(U.simple_utf8_of p.pref_new_value)
 169        ~editable:true ~visibility:true ()
 170   in
 171 (*
 172   ignore (table#misc#connect#size_allocate
 173       ~callback: (fun r ->
 174         lprintf' "Table width %d\n" r.Gtk.width;
 175   ));
 176 *)
 177   table#attach ~left:0 ~top
 178     ~xpadding:18 ~ypadding:0
 179     ~expand:`X ~fill:`X
 180     (event_wrap_widget ~w:label ~p ?h_label ());
 181   table#attach ~left:1 ~top
 182     ~xpadding:0 ~ypadding:0
 183     ~expand:`X ~fill:`X
 184     (event_wrap_widget ~w:edit ~p ?h_label ());
 185   p.pref_apply <- (fun _ -> p.pref_new_value <- edit#text);
 186   p.pref_apply_default <- (fun _ -> edit#set_text (U.simple_utf8_of p.pref_default))
 187
 188 (*************************************************************************)
 189 (*                                                                       *)
 190 (*                         add_password_param                            *)
 191 (*                                                                       *)
 192 (*************************************************************************)
 193
 194 let add_password_param ~p ~top ~(table : GPack.table) ?(h_label : GMisc.label option) () =
 195   let label = GMisc.label ~xalign:0. ~markup:(U.simple_utf8_of p.pref_label) () in
 196   let hbox = GPack.hbox ~homogeneous:false ~spacing:6 () in
 197   let pixbuf = A.get_icon ~icon:M.icon_stock_password ~size:A.SMALL () in
 198   let _image = GMisc.image ~pixbuf ~packing:(hbox#pack ~expand:false ~fill:true) () in
 199   let edit =
 200     GEdit.entry ~text:(U.simple_utf8_of p.pref_new_value) ~editable:true ~visibility:false
 201       ~packing:(hbox#pack ~expand:true ~fill:true) ()
 202   in
 203   table#attach ~left:0 ~top
 204     ~xpadding:18 ~ypadding:0
 205     ~expand:`X ~fill:`X
 206     (event_wrap_widget ~w:label ~p ?h_label ());
 207   table#attach ~left:1 ~top
 208     ~xpadding:0 ~ypadding:0
 209     ~expand:`X ~fill:`X
 210     (event_wrap_widget ~w:hbox ~p ?h_label ());
 211   p.pref_apply <- (fun _ -> p.pref_new_value <- edit#text);
 212   p.pref_apply_default <- (fun _ -> edit#set_text (U.simple_utf8_of p.pref_default))
 213
 214 (*************************************************************************)
 215 (*                                                                       *)
 216 (*                         add_scale_param                               *)
 217 (*                                                                       *)
 218 (*************************************************************************)
 219
 220 let add_scale_param ~p ~top ~(table : GPack.table) ?(h_label : GMisc.label option) () =
 221   let label = GMisc.label ~xalign:0. ~markup:(U.simple_utf8_of p.pref_label) () in
 222   let value = (safe_float p.pref_new_value) *. 100. in
 223   let range =
 224     GData.adjustment ~lower:0. ~upper:110.
 225       ~value ~step_incr:1. ()
 226   in
 227   let scale =
 228     GRange.scale `HORIZONTAL ~adjustment:range ~digits:0
 229       ~draw_value:true ~value_pos:`RIGHT ~update_policy:`CONTINUOUS ()
 230   in
 231   table#attach ~left:0 ~top
 232     ~xpadding:18 ~ypadding:0
 233     ~expand:`X ~fill:`X
 234     (event_wrap_widget ~w:label ~p ?h_label ());
 235   table#attach ~left:1 ~top
 236     ~xpadding:0 ~ypadding:0
 237     ~expand:`X ~fill:`X
 238     (event_wrap_widget ~w:scale ~p ?h_label ());
 239   p.pref_apply <- (fun _ -> p.pref_new_value <- string_of_float (range#value /. 100.));
 240   p.pref_apply_default <- (fun _ -> range#set_value ((safe_float p.pref_default) *. 100.))
 241
 242 (*************************************************************************)
 243 (*                                                                       *)
 244 (*                         add_int_param                                 *)
 245 (*                                                                       *)
 246 (*************************************************************************)
 247
 248 let add_int_param ~p ~f ~top ~(table : GPack.table) ?(h_label : GMisc.label option) () =
 249   let value = f p.pref_new_value in
 250   let label = GMisc.label ~xalign:0. ~markup:(U.simple_utf8_of p.pref_label) () in
 251   let hbox = GPack.hbox ~homogeneous:false ~spacing:3 () in
 252   let range = GData.adjustment ~lower:0. ~upper:(float_of_int max_int) ~step_incr:1. () in
 253   let spin =
 254     GEdit.spin_button ~adjustment:range ~rate:1. ~digits:0 ~numeric:true
 255       ~snap_to_ticks:true ~update_policy:`IF_VALID ~value ~wrap:true
 256       ~packing:(hbox#pack ~expand:false ~fill:true) ()
 257   in
 258   let _a_box =
 259     GPack.hbox ~homogeneous:false
 260       ~packing:(hbox#pack ~expand:true ~fill:true) ()
 261   in
 262   table#attach ~left:0 ~top
 263     ~xpadding:18 ~ypadding:0
 264     ~expand:`X ~fill:`X
 265     (event_wrap_widget ~w:label ~p ?h_label ());
 266   table#attach ~left:1 ~top
 267     ~xpadding:0 ~ypadding:0
 268     ~expand:`X ~fill:`X
 269     (event_wrap_widget ~w:hbox ~p ?h_label ());
 270   p.pref_apply <- (fun _ -> p.pref_new_value <- string_of_int spin#value_as_int);
 271   p.pref_apply_default <- (fun _ -> spin#set_value (f p.pref_default))
 272
 273 (*************************************************************************)
 274 (*                                                                       *)
 275 (*                         add_float_param                               *)
 276 (*                                                                       *)
 277 (*************************************************************************)
 278
 279 let add_float_param ~p ~top ~(table : GPack.table) ?(h_label : GMisc.label option) () =
 280   let value = safe_float p.pref_new_value in
 281   let label = GMisc.label ~xalign:0. ~markup:(U.simple_utf8_of p.pref_label) () in
 282   let hbox = GPack.hbox ~homogeneous:false ~spacing:3 () in
 283   let range = GData.adjustment ~lower:0. ~upper:((float_of_int max_int) *. 1000.) ~step_incr:0.1 () in
 284   let spin =
 285     GEdit.spin_button ~adjustment:range ~rate:1. ~digits:1 ~numeric:true
 286       ~snap_to_ticks:true ~update_policy:`IF_VALID ~value ~wrap:true
 287       ~packing:(hbox#pack ~expand:false ~fill:true) ()
 288   in
 289   let _a_box =
 290     GPack.hbox ~homogeneous:false
 291       ~packing:(hbox#pack ~expand:true ~fill:true) ()
 292   in
 293   table#attach ~left:0 ~top
 294     ~xpadding:18 ~ypadding:0
 295     ~expand:`X ~fill:`X
 296     (event_wrap_widget ~w:label ~p ?h_label ());
 297   table#attach ~left:1 ~top
 298     ~xpadding:0 ~ypadding:0
 299     ~expand:`X ~fill:`X
 300     (event_wrap_widget ~w:hbox ~p ?h_label ());
 301   p.pref_apply <- (fun _ -> p.pref_new_value <- string_of_float spin#value);
 302   p.pref_apply_default <- (fun _ -> spin#set_value (float_of_string p.pref_default))
 303
 304 (*************************************************************************)
 305 (*                                                                       *)
 306 (*                         add_filename_param                            *)
 307 (*                                                                       *)
 308 (*************************************************************************)
 309
 310 let last_dir = ref ""
 311
 312 let add_filename_param ~p ~top ~(table : GPack.table) ~path ?(h_label : GMisc.label option) () =
 313   let label = GMisc.label ~xalign:0. ~markup:(U.simple_utf8_of p.pref_label) () in
 314   let hbox = GPack.hbox ~homogeneous:false ~spacing:6 () in
 315   let edit =
 316     GEdit.entry ~text:(U.simple_utf8_of p.pref_new_value) ~editable:true ~visibility:true
 317       ~packing:(hbox#pack ~expand:true ~fill:true) ()
 318   in
 319   let button = GButton.button ~packing:(hbox#pack ~expand:false ~fill:true) () in
 320   GuiTools.add_complex_box
 321     ~cont:((<:>) button)
 322     ~style:`BOTH_HORIZ
 323     ~markup:!M.cW_lb_browse
 324     ~icon:(A.get_icon ~icon:M.icon_stock_directory ~size:A.SMALL ()) ();
 325   table#attach ~left:0 ~top
 326     ~xpadding:18 ~ypadding:0
 327     ~expand:`X ~fill:`X
 328     (event_wrap_widget ~w:label ~p ?h_label ());
 329   table#attach ~left:1 ~top
 330     ~xpadding:0 ~ypadding:0
 331     ~expand:`X ~fill:`X
 332     (event_wrap_widget ~w:hbox ~p ?h_label ());
 333   let files = ref ([] : string list) in
 334   let f_sel () =
 335     let dialog = GWindow.file_selection
 336       ~title:(U.simple_utf8_of p.pref_label)
 337       ~modal:false
 338       ~show:true ()
 339     in
 340     let wb_ok = dialog#ok_button in
 341     let wb_cancel = dialog#cancel_button in
 342     let _ =
 343       match p.pref_new_value with
 344           "" ->
 345             if !last_dir <> ""
 346               then dialog#set_filename !last_dir
 347         | dir -> dialog#set_filename dir
 348     in
 349     ignore (wb_ok#connect#clicked ~callback:
 350       (fun () ->
 351          files := [dialog#filename];
 352          let _ =
 353            match !files with
 354                []
 355              | [""] -> ()
 356              | l ->
 357                  last_dir := Filename.dirname (List.hd l);
 358                  if not path
 359                    then edit#set_text (U.simple_utf8_of (List.hd l))
 360                    else edit#set_text (U.simple_utf8_of !last_dir)
 361          in
 362          dialog#destroy ()
 363     ));
 364     ignore (wb_cancel#connect#clicked dialog#destroy)
 365   in
 366   ignore (button#connect#clicked f_sel);
 367   p.pref_apply <- (fun _ -> p.pref_new_value <- edit#text);
 368   p.pref_apply_default <- (fun _ -> edit#set_text (U.simple_utf8_of p.pref_default))
 369
 370 (*************************************************************************)
 371 (*                                                                       *)
 372 (*                         add_color_param                               *)
 373 (*                                                                       *)
 374 (*************************************************************************)
 375
 376 let add_color_param ~p ~top ~(table : GPack.table) ?(h_label : GMisc.label option) () =
 377   let label = GMisc.label ~xalign:0. ~markup:(U.simple_utf8_of p.pref_label) () in
 378   let hbox = GPack.hbox ~homogeneous:false () in
 379   let button = GButton.button ~packing:(hbox#pack ~expand:false ~fill:true) () in
 380   let box = GPack.hbox ~homogeneous:false ~spacing:6 ~packing:button#add () in
 381   GuiTools.add_complex_box
 382     ~cont:((<:>) box)
 383     ~style:`ICONS
 384     ~icon:(A.get_icon ~icon:M.icon_stock_color ~size:A.SMALL ()) ();
 385   let _separator =
 386     GMisc.separator `VERTICAL
 387     ~packing:(box#pack ~expand:false ~fill:true) ()
 388   in
 389   let pixbuf = GdkPixbuf.create ~width:100 ~height:!!O.gtk_look_lists_icon_size () in
 390   let colv = ref "" in
 391   let set_color col =
 392     try
 393       GdkPixbuf.fill pixbuf (Int32.of_string col)
 394     with _ -> ()
 395   in
 396   let string_of_int_of_col color =
 397     let r = (Gdk.Color.red color) / 256 in
 398     let g = (Gdk.Color.green color) / 256 in
 399     let b = (Gdk.Color.blue color) / 256 in
 400     let s = Printf.sprintf "%02X%02X%02X" r g b in
 401     let _ =
 402       for i = 1 to (String.length s) - 1 do
 403         if s.[i] = ' ' then s.[i] <- '0'
 404       done
 405     in
 406     colv := "#" ^ s;
 407     ("0x" ^ s ^ "FF")
 408   in
 409   let col = GDraw.color (`NAME p.pref_new_value) in
 410   set_color (string_of_int_of_col col);
 411   let _sample = GuiTools.add_pixbuf ~cont:((<:>) box) ~pixbuf in
 412   let _separator =
 413     GMisc.separator `VERTICAL
 414     ~packing:(box#pack ~expand:false ~fill:true) ()
 415   in
 416   let _a_box =
 417     GPack.hbox ~homogeneous:false
 418       ~packing:(hbox#pack ~expand:true ~fill:true) ()
 419   in
 420   table#attach ~left:0 ~top
 421     ~xpadding:18 ~ypadding:0
 422     ~expand:`X ~fill:`X
 423     (event_wrap_widget ~w:label ~p ?h_label ());
 424   table#attach ~left:1 ~top
 425     ~xpadding:0 ~ypadding:0
 426     ~expand:`X ~fill:`X
 427     (event_wrap_widget ~w:hbox ~p ?h_label ());
 428   let f_sel () =
 429     let dialog = GWindow.color_selection_dialog
 430         ~title:(U.simple_utf8_of p.pref_label)
 431         ~modal:false
 432         ~show:true ()
 433     in
 434     let color = GDraw.color (`NAME !colv) in
 435     dialog#colorsel#set_color color;
 436     let wb_ok = dialog#ok_button in
 437     let wb_cancel = dialog#cancel_button in
 438     let _ = wb_ok#connect#clicked
 439       (fun () ->
 440          let color = dialog#colorsel#color in
 441          set_color (string_of_int_of_col color);
 442          dialog#destroy ()
 443       )
 444     in
 445     ignore (wb_cancel#connect#clicked dialog#destroy)
 446   in
 447   ignore (button#connect#clicked f_sel);
 448   p.pref_apply <- (fun _ -> p.pref_new_value <- !colv);
 449   p.pref_apply_default <-
 450     (fun _ ->
 451        let color = GDraw.color (`NAME p.pref_default) in
 452        set_color (string_of_int_of_col color))
 453
 454 (*************************************************************************)
 455 (*                                                                       *)
 456 (*                         add_font_param                                *)
 457 (*                                                                       *)
 458 (*************************************************************************)
 459
 460 let add_font_param ~p ~top ~(table : GPack.table) ?(h_label : GMisc.label option) () =
 461   let label = GMisc.label ~xalign:0. ~markup:(U.simple_utf8_of p.pref_label) () in
 462   let hbox = GPack.hbox ~homogeneous:false () in
 463   let button = GButton.button ~packing:(hbox#pack ~expand:false ~fill:true) () in
 464   let box = GPack.hbox ~homogeneous:false ~spacing:6 ~packing:button#add () in
 465   GuiTools.add_complex_box
 466     ~cont:((<:>) box)
 467     ~style:`ICONS
 468     ~icon:(A.get_icon ~icon:M.icon_stock_font ~size:A.SMALL ()) ();
 469   let _separator =
 470     GMisc.separator `VERTICAL
 471     ~packing:(box#pack ~expand:false ~fill:true) ()
 472   in
 473   let sample =
 474     GMisc.label ~width:100 ~xalign:0.
 475       ~markup:!M.cW_lb_font_sample
 476       ~packing:(box#pack ~expand:false ~fill:true) ()
 477   in
 478   let fontv = ref "" in
 479   let set_font font =
 480     sample#misc#modify_font_by_name font;
 481     fontv := font
 482   in
 483   set_font p.pref_new_value;
 484   let _separator =
 485     GMisc.separator `VERTICAL
 486     ~packing:(box#pack ~expand:false ~fill:true) ()
 487   in
 488   let _a_box =
 489     GPack.hbox ~homogeneous:false
 490       ~packing:(hbox#pack ~expand:true ~fill:true) ()
 491   in
 492   table#attach ~left:0 ~top
 493     ~xpadding:18 ~ypadding:0
 494     ~expand:`X ~fill:`X
 495     (event_wrap_widget ~w:label ~p ?h_label ());
 496   table#attach ~left:1 ~top
 497     ~xpadding:0 ~ypadding:0
 498     ~expand:`X ~fill:`X
 499     (event_wrap_widget ~w:hbox ~p ?h_label ());
 500   let f_sel () =
 501     let dialog = GWindow.font_selection_dialog
 502         ~title:(U.simple_utf8_of p.pref_label)
 503         ~modal:false
 504         ~show:true ()
 505     in
 506     dialog#selection#set_font_name !fontv;
 507     let wb_ok = dialog#ok_button in
 508     let wb_cancel = dialog#cancel_button in
 509     let _ = wb_ok#connect#clicked
 510         (fun () ->
 511           let font = dialog#selection#font_name in
 512           set_font font;
 513           dialog#destroy ()
 514         )
 515     in
 516     ignore (wb_cancel#connect#clicked dialog#destroy)
 517   in
 518   ignore (button#connect#clicked f_sel);
 519   p.pref_apply <- (fun _ -> p.pref_new_value <- !fontv);
 520   p.pref_apply_default <- (fun _ -> set_font p.pref_default)
 521
 522 (*************************************************************************)
 523 (*                                                                       *)
 524 (*                         add_bool                                      *)
 525 (*                                                                       *)
 526 (*************************************************************************)
 527
 528 let add_bool ~p ~top ~(table : GPack.table) ?(h_label : GMisc.label option) () =
 529   let active = safe_bool p.pref_new_value in
 530   let check = GButton.check_button ~active ~label:(U.simple_utf8_of p.pref_label) () in
 531   table#attach ~left:0 ~top
 532     ~xpadding:18 ~ypadding:0
 533     ~right:2 ~bottom:(top + 1)
 534     ~expand:`X ~fill:`X
 535     (event_wrap_widget ~w:check ~p ?h_label ());
 536   check
 537
 538 (*************************************************************************)
 539 (*                                                                       *)
 540 (*                         add_bool_param                                *)
 541 (*                                                                       *)
 542 (*************************************************************************)
 543
 544 let add_bool_param ~p ~top ~(table : GPack.table) ?(h_label : GMisc.label option) () =
 545   let check = add_bool ~p ~top ~table ?h_label () in
 546   p.pref_apply <- (fun _ -> p.pref_new_value <- string_of_bool check#active);
 547   p.pref_apply_default <- (fun _ -> check#set_active (bool_of_string p.pref_default))
 548
 549 (*************************************************************************)
 550 (*                                                                       *)
 551 (*                         add_advanced_param                            *)
 552 (*                                                                       *)
 553 (*************************************************************************)
 554
 555 let add_advanced_param ~p ~top ~(table : GPack.table) ?(h_label : GMisc.label option) ~advanced_mode () =
 556   let check = add_bool ~p ~top ~table ?h_label () in
 557   p.pref_apply <-
 558         (fun _ ->
 559            begin
 560              advanced_mode := check#active;
 561              p.pref_new_value <- string_of_bool check#active
 562           end
 563         );
 564   p.pref_apply_default <-
 565         (fun _ ->
 566            begin
 567              advanced_mode := check#active;
 568              check#set_active (bool_of_string p.pref_default)
 569            end
 570         )
 571
 572 (*************************************************************************)
 573 (*                                                                       *)
 574 (*                         add_combo_param                               *)
 575 (*                                                                       *)
 576 (*************************************************************************)
 577
 578 let set_combobox_value (combobox : GEdit.combo_box) (column : string GTree.column) v =
 579   combobox#model#foreach
 580     (fun _ row ->
 581       let s = combobox#model#get ~row ~column in
 582       if s = v
 583         then begin
 584           combobox#set_active_iter (Some row);
 585           true
 586         end else false)
 587
 588 let get_combobox_value (combobox : GEdit.combo_box) (column : string GTree.column) default =
 589   match combobox#active_iter with
 590       None -> default
 591     | Some row -> combobox#model#get ~row ~column
 592
 593 let add_combo_param ~p ~top ~(table : GPack.table) ?(h_label : GMisc.label option) () =
 594   let label = GMisc.label ~xalign:0. ~markup:(U.simple_utf8_of p.pref_label) () in
 595   let (combobox, (_, column)) =
 596     GEdit.combo_box_text ~strings:(List.map U.simple_utf8_of p.pref_option_list) ()
 597   in
 598   set_combobox_value combobox column (U.simple_utf8_of p.pref_new_value);
 599   table#attach ~left:0 ~top
 600     ~xpadding:18 ~ypadding:0
 601      ~expand:`X ~fill:`X
 602     (event_wrap_widget ~w:label ~p ?h_label ());
 603   table#attach ~left:1 ~top
 604     ~xpadding:0 ~ypadding:0
 605     ~expand:`X ~fill:`X
 606     (event_wrap_widget ~w:combobox ~p ?h_label ());
 607   p.pref_apply <- (fun _ -> p.pref_new_value <- get_combobox_value combobox column p.pref_default);
 608   p.pref_apply_default <- (fun _ -> set_combobox_value combobox column (U.simple_utf8_of p.pref_default))
 609
 610 (*************************************************************************)
 611 (*                                                                       *)
 612 (*                         add_time_param                                *)
 613 (*                                                                       *)
 614 (*************************************************************************)
 615
 616 let add_time_param ~p ~top ~(table : GPack.table) ?(h_label : GMisc.label option) () =
 617   let label = GMisc.label ~xalign:0. ~markup:(U.simple_utf8_of p.pref_label) () in
 618   let hbox = GPack.hbox ~homogeneous:false ~spacing:3 () in
 619   let range_day = GData.adjustment ~lower:0. ~upper:365. ~step_incr:1. () in
 620   let spin_day =
 621     GEdit.spin_button ~adjustment:range_day ~rate:1. ~digits:0 ~numeric:true
 622       ~snap_to_ticks:true ~update_policy:`IF_VALID ~wrap:true
 623       ~packing:(hbox#pack ~expand:false ~fill:true) ()
 624   in
 625   let _label_day =
 626     GMisc.label ~xalign:0. ~markup:!M.cW_lb_day
 627       ~packing:(hbox#pack ~expand:false ~fill:true) ()
 628   in
 629   let range_hour = GData.adjustment ~lower:0. ~upper:23. ~step_incr:1. () in
 630   let spin_hour =
 631     GEdit.spin_button ~adjustment:range_hour ~rate:1. ~digits:0 ~numeric:true
 632       ~snap_to_ticks:true ~update_policy:`IF_VALID ~wrap:true
 633       ~packing:(hbox#pack ~expand:false ~fill:true) ()
 634   in
 635   let _label_hour =
 636     GMisc.label ~xalign:0. ~markup:!M.cW_lb_hour
 637       ~packing:(hbox#pack ~expand:false ~fill:true) ()
 638   in
 639   let range_minute = GData.adjustment ~lower:0. ~upper:59. ~step_incr:1. () in
 640   let spin_minute =
 641     GEdit.spin_button ~adjustment:range_minute ~rate:1. ~digits:0 ~numeric:true
 642       ~snap_to_ticks:true ~update_policy:`IF_VALID ~wrap:true
 643       ~packing:(hbox#pack ~expand:false ~fill:true) ()
 644   in
 645   let _label_minute =
 646     GMisc.label ~xalign:0. ~markup:!M.cW_lb_minute
 647       ~packing:(hbox#pack ~expand:false ~fill:true) ()
 648   in
 649   let range_second = GData.adjustment ~lower:0. ~upper:59. ~step_incr:1. () in
 650   let spin_second =
 651     GEdit.spin_button ~adjustment:range_second ~rate:1. ~digits:0 ~numeric:true
 652       ~snap_to_ticks:true ~update_policy:`IF_VALID ~wrap:true
 653       ~packing:(hbox#pack ~expand:false ~fill:true) ()
 654   in
 655   let _label_second =
 656     GMisc.label ~xalign:0. ~markup:!M.cW_lb_second
 657       ~packing:(hbox#pack ~expand:false ~fill:true) ()
 658   in
 659   let _a_box =
 660     GPack.hbox ~homogeneous:false
 661       ~packing:(hbox#pack ~expand:true ~fill:true) ()
 662   in
 663   let set_time v =
 664     let time = int_of_float (safe_int v)  in
 665     let days = time / 60 / 60 / 24 in
 666     let rest = time - days * 60 * 60 * 24 in
 667     let hours = rest / 60 / 60 in
 668     let rest = rest - hours * 60 * 60 in
 669     let minutes = rest / 60 in
 670     let seconds = rest - minutes * 60 in
 671     spin_day#set_value (float_of_int days);
 672     spin_hour#set_value (float_of_int hours);
 673     spin_minute#set_value (float_of_int minutes);
 674     spin_second#set_value (float_of_int seconds)
 675   in
 676   let get_time _ =
 677     let days = spin_day#value_as_int * 60 * 60 * 24 in
 678     let hours = spin_hour#value_as_int * 60 * 60 in
 679     let minutes = spin_minute#value_as_int * 60 in
 680     let seconds = spin_second#value_as_int in
 681     let time = seconds + minutes + hours + days in
 682     string_of_int time
 683   in
 684   set_time p.pref_new_value;
 685   table#attach ~left:0 ~top
 686     ~xpadding:18 ~ypadding:0
 687     ~expand:`X ~fill:`X
 688     (event_wrap_widget ~w:label ~p ?h_label ());
 689   table#attach ~left:1 ~top
 690     ~xpadding:0 ~ypadding:0
 691     ~expand:`X ~fill:`X
 692     (event_wrap_widget ~w:hbox ~p ?h_label ());
 693   p.pref_apply <- (fun _ -> p.pref_new_value <- get_time () );
 694   p.pref_apply_default <- (fun _ -> set_time p.pref_default)
 695
 696 (*************************************************************************)
 697 (*                                                                       *)
 698 (*                         add_pref                                      *)
 699 (*                                                                       *)
 700 (*************************************************************************)
 701
 702 let add_pref ?h_label ~table ~p ~top ~advanced_mode () =
 703     match p.pref_type with
 704         BBool -> add_bool_param ~p ~top ~table ?h_label ()
 705       | BAdvanced -> add_advanced_param ~p ~top ~table ?h_label ~advanced_mode ()
 706       | BFilename -> add_filename_param ~p ~top ~table ~path:false ?h_label ()
 707       | BPath -> add_filename_param ~p ~top ~table ~path:true ?h_label ()
 708       | BPassword -> add_password_param ~p ~top ~table ?h_label ()
 709       | BCombo -> add_combo_param ~p ~top ~table ?h_label ()
 710       | BTime -> add_time_param ~p ~top ~table ?h_label ()
 711       | BColor -> add_color_param ~p ~top ~table ?h_label ()
 712       | BFont -> add_font_param ~p ~top ~table ?h_label ()
 713       | BInt -> add_int_param ~p ~f:safe_int ~top ~table ?h_label ()
 714       | BInt32 -> add_int_param ~p ~f:safe_int32 ~top ~table ?h_label ()
 715       | BInt64 -> add_int_param ~p ~f:safe_int64 ~top ~table ?h_label ()
 716       | BFloat -> add_float_param ~p ~top ~table ?h_label ()
 717       | BScale -> add_scale_param ~p ~top ~table ?h_label ()
 718       | _ -> add_string_param ~p ~top ~table ?h_label ()
 719
 720
 721 (*************************************************************************)
 722 (*************************************************************************)
 723 (*************************************************************************)
 724 (*                                                                       *)
 725 (*                         CONFIGPANEL                                   *)
 726 (*                                                                       *)
 727 (*************************************************************************)
 728 (*************************************************************************)
 729 (*************************************************************************)
 730
 731 module ConfigPanel (CW:
 732
 733 (*************************************************************************)
 734 (*************************************************************************)
 735 (*************************************************************************)
 736 (*                                                                       *)
 737 (*                         FUNCTOR Argument                              *)
 738 (*                                                                       *)
 739 (*************************************************************************)
 740 (*************************************************************************)
 741 (*************************************************************************)
 742
 743     sig
 744
 745       type section
 746       and  subsection
 747       and  group
 748
 749       val section_to_label    : section option -> string
 750       val subsection_to_label : subsection option -> string
 751       val group_to_label      : group option -> string
 752       val icon_from_section   : section option -> GdkPixbuf.pixbuf
 753       val advanced_mode       : bool ref
 754       val save_options        : (string * string) list ->        (* (pref_name, pref_new_value) *)
 755                                   (string, (section, subsection, group) preference) Hashtbl.t ->
 756                                      unit
 757
 758     end) =
 759   (struct
 760
 761     open CW
 762
 763 (*************************************************************************)
 764 (*************************************************************************)
 765 (*************************************************************************)
 766 (*                                                                       *)
 767 (*                         FUNCTOR Body                                  *)
 768 (*                                                                       *)
 769 (*************************************************************************)
 770 (*************************************************************************)
 771 (*************************************************************************)
 772
 773 (*************************************************************************)
 774 (*                                                                       *)
 775 (*                         Global tables                                 *)
 776 (*                                                                       *)
 777 (*************************************************************************)
 778
 779     let (preferences_values : (string, (section, subsection, group) preference) Hashtbl.t) =
 780       Hashtbl.create 103
 781
 782     let (sections : (section option * (subsection option *
 783                         (group option * (pref_box *
 784                             string list ref) list ref) list ref)
 785                                 list ref) list ref ) = ref []
 786
 787 (*************************************************************************)
 788 (*                                                                       *)
 789 (*                         Global variables                              *)
 790 (*                                                                       *)
 791 (*************************************************************************)
 792
 793     let (win : GWindow.window option ref) = ref None
 794
 795     let wwidth = ref ((Gdk.Screen.width ()) * 2 / 3)
 796     let wheight = ref ((Gdk.Screen.height ()) * 3 / 4)
 797
 798     let (current_section : section option ref) = ref None
 799
 800 (*************************************************************************)
 801 (*                                                                       *)
 802 (*                         build_sections                                *)
 803 (*                                                                       *)
 804 (*************************************************************************)
 805
 806 let build_sections _ =
 807   Hashtbl.iter (fun name p ->
 808     let t = (p.pref_section, ref [p.pref_subsection, ref [p.pref_group, ref [p.pref_type, ref [p.pref_name]]]]) in
 809     let list = sections in
 810     if not (List.mem_assoc (fst t) !list)
 811       then begin
 812         list := List.sort (fun t1 t2 -> compare t1 t2) (t::!list)
 813       end else begin
 814         let list = List.assoc (fst t) !list in
 815         let t = List.hd !(snd t) in
 816         if not (List.mem_assoc (fst t) !list)
 817           then begin
 818             list := List.sort (fun t1 t2 -> compare t1 t2) (t::!list)
 819           end else begin
 820             let list = List.assoc (fst t) !list in
 821             let t = List.hd !(snd t) in
 822             if not (List.mem_assoc (fst t) !list)
 823               then begin
 824                 list := List.sort (fun t1 t2 -> compare t1 t2) (t::!list)
 825               end else begin
 826                 let list = List.assoc (fst t) !list in
 827                 let t = List.hd !(snd t) in
 828                 if not (List.mem_assoc (fst t) !list)
 829                   then begin
 830                     list := List.sort (fun t1 t2 -> compare t1 t2) (t::!list)
 831                   end else begin
 832                     let list = List.assoc (fst t) !list in
 833                     let t = List.hd !(snd t) in
 834                     if not (List.mem t !list)
 835                       then begin
 836                         list := List.sort (fun t1 t2 -> compare t1 t2) (t::!list)
 837                       end
 838                   end
 839               end
 840           end
 841       end
 842   ) preferences_values
 843
 844 (*************************************************************************)
 845 (*                                                                       *)
 846 (*                         add_group_name                                *)
 847 (*                                                                       *)
 848 (*************************************************************************)
 849
 850 let add_group_name ~grp ~(table : GPack.table) ~top =
 851   if grp <> None
 852     then begin
 853       let s = group_to_label grp in
 854       let hbox = GPack.hbox ~homogeneous:false ~border_width:6 () in
 855       let markup =
 856         Printf.sprintf "<span foreground=\"%s\" weight=\"bold\">%s</span>"
 857           !!O.gtk_color_default s
 858       in
 859       let _label =
 860         GMisc.label ~xalign:0. ~markup
 861           ~packing:(hbox#pack ~expand:false ~fill:true) ()
 862       in
 863       table#attach ~left:0 ~top
 864         ~right:2 ~bottom:(top + 1)
 865         ~expand:`X ~fill:`X
 866         hbox#coerce
 867     end
 868
 869 (*************************************************************************)
 870 (*                                                                       *)
 871 (*                         add_groups                                    *)
 872 (*                                                                       *)
 873 (*************************************************************************)
 874
 875 let add_groups h_label groups =
 876   let scroll_table_box =
 877     GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC
 878       ~placement:`TOP_LEFT ()
 879   in
 880   let table =
 881     GPack.table ~columns:2 ~homogeneous:false
 882        ~row_spacings:6 ~col_spacings:6 ~border_width:6
 883        ~packing:scroll_table_box#add_with_viewport ()
 884   in
 885   let index = ref 0 in
 886   List.iter (fun (grp, prefs) ->
 887      let list = ref [] in
 888      List.iter (fun (box, names) ->
 889        List.iter (fun name ->
 890          let p = Hashtbl.find preferences_values name in
 891          if (not p.pref_advanced) || !advanced_mode
 892            then list := p :: !list
 893        ) !names
 894      ) !prefs;
 895      list := List.rev !list;
 896      if !list <> []
 897        then begin
 898          add_group_name ~grp ~table ~top:!index;
 899          incr (index)
 900        end;
 901      List.iter (fun p ->
 902        add_pref ~h_label ~table ~p ~top:!index ~advanced_mode ();
 903        incr (index)
 904      ) !list
 905   ) !groups;
 906   scroll_table_box#coerce
 907
 908 (*************************************************************************)
 909 (*                                                                       *)
 910 (*                         add_subsections                               *)
 911 (*                                                                       *)
 912 (*************************************************************************)
 913
 914 let rec iter (notebook : GPack.notebook) h_label subsections =
 915   match subsections with
 916       [] -> ()
 917     | (sub, groups) :: tail ->
 918         begin
 919           let w = add_groups h_label groups in
 920           let markup = subsection_to_label sub in
 921           ignore (notebook#append_page
 922             ~tab_label:((GMisc.label ~use_underline:true ~markup ())#coerce)
 923             w);
 924           iter notebook h_label tail
 925         end
 926
 927 let add_subsections (box : GPack.box) h_label subsections =
 928   match !subsections with
 929       [] -> ()
 930     | [None, groups] ->
 931         begin
 932           let w = add_groups h_label groups in
 933           box#pack ~expand:true ~fill:true w
 934         end
 935     | _ ->
 936         begin
 937           let notebook = GPack.notebook ~homogeneous_tabs:true ~scrollable:true
 938                  ~packing:(box#pack ~expand:true ~fill:true) ()
 939           in
 940           iter notebook h_label !subsections
 941         end
 942
 943 (*************************************************************************)
 944 (*                                                                       *)
 945 (*                         add_subsection                                *)
 946 (*                                                                       *)
 947 (*************************************************************************)
 948
 949 let add_section menu box pref_label h_label section subsections =
 950   let item = GList.list_item () in
 951   let label = section_to_label section in
 952   let markup =
 953     Printf.sprintf "<span foreground=\"%s\" weight=\"bold\">%s</span>"
 954       !!O.gtk_color_default label
 955   in
 956   GuiTools.add_complex_box
 957     ~cont:((<:>) item)
 958     ~markup
 959     ~style:`BOTH
 960     ~icon:(icon_from_section section) ();
 961   menu#append item;
 962   item#set_border_width 6;
 963   ignore (item#connect#select ~callback:
 964     (fun _ ->
 965       pref_label#set_label (remove_ markup);
 966       let list =
 967         try
 968           List.assoc !current_section !sections
 969         with Not_found -> ref []
 970       in
 971       List.iter (fun (sub, groups) ->
 972         List.iter (fun (grp, prefs) ->
 973           List.iter (fun (box, names) ->
 974             List.iter (fun name ->
 975               try
 976                 let p = Hashtbl.find preferences_values name in
 977                 p.pref_apply ()
 978               with Not_found -> ()
 979             ) !names
 980           ) !prefs
 981         ) !groups
 982       ) !list;
 983       List.iter (fun w -> w#destroy ()) box#children;
 984       current_section := None;
 985       add_subsections box h_label subsections;
 986       current_section := section
 987   ))
 988
 989 (*************************************************************************)
 990 (*                                                                       *)
 991 (*                         insert_options                                *)
 992 (*                                                                       *)
 993 (*************************************************************************)
 994
 995 let h_pb = A.get_icon ~icon:M.icon_menu_help ~size:A.LARGE ()
 996
 997
 998 let insert_options (menu : GList.liste) (opt_box : GPack.box) =
 999   let pref_evbox =
1000     GBin.event_box ~packing:(opt_box#pack ~expand:false ~fill:true) ()
1001   in
1002   pref_evbox#misc#modify_bg [(`NORMAL, (`NAME "#AFAFF4"))];
1003   let pref_label =
1004     GMisc.label ~xalign:0. ~yalign:0.
1005       ~xpad:3 ~ypad:3 ~packing:pref_evbox#add ()
1006   in
1007   pref_label#set_use_markup true;
1008   let box_table =
1009     GPack.vbox ~homogeneous:false
1010       ~packing:(opt_box#pack ~expand:true ~fill:true) ()
1011   in
1012   let frame =
1013     GBin.frame ~height:(!wheight / 7)
1014       ~packing:(opt_box#pack ~expand:false ~fill:true) ()
1015   in
1016   let h_hbox =
1017     GPack.hbox ~homogeneous:false ~spacing:6
1018       ~border_width:3 ~packing:frame#add ()
1019   in
1020   let _icon_h =
1021     GMisc.image ~pixbuf:h_pb
1022       ~packing:(h_hbox#pack ~expand:false ~fill:true) ()
1023   in
1024   let  h_vbox =
1025     GPack.hbox ~homogeneous:false ~border_width:3
1026        ~packing:(h_hbox#pack ~expand:true ~fill:true) ()
1027   in
1028   let h_label =
1029     GMisc.label ~xalign:0. ~yalign:0.
1030       ~packing:(h_vbox#pack ~expand:true ~fill:true) ()
1031   in
1032   List.iter (fun (sec,subs) ->
1033     add_section menu box_table pref_label h_label sec subs
1034   ) !sections;
1035   menu#select_item ~pos:0
1036
1037 (*************************************************************************)
1038 (*                                                                       *)
1039 (*                         save_all_prefs                                *)
1040 (*                                                                       *)
1041 (*************************************************************************)
1042
1043 let save_all_prefs _ =
1044   let list = ref [] in
1045   Hashtbl.iter (fun name p ->
1046     (if p.pref_section = !current_section
1047       then p.pref_apply ());
1048     if p.pref_value <> p.pref_new_value
1049       then begin
1050           list := (p.pref_name, p.pref_new_value) :: !list;
1051           p.pref_new_value <- p.pref_value
1052       end
1053
1054   ) preferences_values;
1055   save_options !list preferences_values
1056
1057 (*************************************************************************)
1058 (*                                                                       *)
1059 (*                         save_section_prefs                            *)
1060 (*                                                                       *)
1061 (*************************************************************************)
1062
1063 let save_section_prefs _ =
1064   let list = ref [] in
1065   Hashtbl.iter (fun name p ->
1066     if p.pref_section = !current_section
1067       then begin
1068         p.pref_apply ();
1069         if p.pref_value <> p.pref_new_value
1070           then begin
1071             list := (p.pref_name, p.pref_new_value) :: !list;
1072             p.pref_new_value <- p.pref_value
1073             end
1074       end
1075   ) preferences_values;
1076   save_options !list preferences_values
1077
1078 (*************************************************************************)
1079 (*                                                                       *)
1080 (*                         clear                                         *)
1081 (*                                                                       *)
1082 (*************************************************************************)
1083
1084 let clear () =
1085   sections := [];
1086   Hashtbl.clear preferences_values
1087
1088 (*************************************************************************)
1089 (*                                                                       *)
1090 (*                         CONFIG WINDOW                                 *)
1091 (*                                                                       *)
1092 (*************************************************************************)
1093
1094
1095 let create_config_window on_ok =
1096   let window =
1097     GWindow.window ~width:!wwidth ~height:!wheight
1098       ~title:(remove_ !M.mW_lb_settings)
1099       ~icon:(A.get_icon ~icon:M.icon_menu_settings ~size:A.SMALL ())
1100       ~position:`CENTER_ALWAYS
1101       ~kind:`TOPLEVEL
1102       ~resizable:true ~modal:false ()
1103   in
1104   window#set_skip_taskbar_hint false;
1105   window#set_skip_pager_hint false;
1106   ignore (window#connect#destroy ~callback:
1107     (fun _ ->
1108        win := None;
1109        current_section := None
1110   ));
1111   let vbox =
1112     GPack.vbox ~homogeneous:false
1113       ~packing:window#add ()
1114   in
1115   let hbox =
1116     GPack.hbox ~homogeneous:false ~border_width:6
1117       ~packing:(vbox#pack ~expand:true ~fill:true) ()
1118   in
1119   let vbox_menu =
1120     GPack.vbox ~homogeneous:false ~border_width:6
1121       ~packing:(hbox#pack ~expand:false ~fill:true) ()
1122   in
1123   let vbox_opt =
1124     GPack.vbox ~homogeneous:false ~border_width:6 ~spacing:6
1125       ~packing:(hbox#pack ~expand:true ~fill:true) ()
1126   in
1127   let scroll_menu_box =
1128     GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`ALWAYS
1129       ~placement:`TOP_LEFT
1130       ~packing:(vbox_menu#pack ~expand:true ~fill:true) ()
1131   in
1132   let menu_list =
1133     GList.liste ~selection_mode:`SINGLE
1134       ~packing:scroll_menu_box#add_with_viewport ()
1135   in
1136   let _separator =
1137     GMisc.separator `HORIZONTAL
1138     ~packing:(vbox#pack ~expand:false ~fill:true) ()
1139   in
1140   let hbox_button =
1141     GPack.hbox ~homogeneous:false ~border_width:6
1142       ~packing:(vbox#pack ~expand:false ~fill:true) ()
1143   in
1144   let bbox =
1145     GuiTools.tool_bar `HORIZONTAL ~border_width:6 ~spacing:6
1146       ~layout:`END ~packing:hbox_button#add ()
1147   in
1148   ignore (bbox#add_button
1149     ~markup:!M.pW_lb_cancel
1150     ~style:`BOTH_HORIZ
1151     ~icon:(A.get_icon ~icon:M.icon_stock_close ~size:A.SMALL ())
1152     ~f:(window#destroy) ()
1153   );
1154   let f () =
1155     Hashtbl.iter (fun name p ->
1156       if p.pref_section = !current_section
1157         then p.pref_apply_default ()
1158     ) preferences_values
1159   in
1160   ignore (bbox#add_button
1161     ~markup:!M.pW_lb_default
1162     ~style:`TEXT
1163     ~f ()
1164   );
1165   let f () =
1166     save_section_prefs ()
1167   in
1168   ignore (bbox#add_button
1169     ~markup:!M.pW_lb_apply
1170     ~style:`TEXT
1171     ~f ()
1172   );
1173   let f () =
1174     save_all_prefs ();
1175     on_ok ();
1176     window#destroy ()
1177   in
1178   ignore (bbox#add_button
1179     ~markup:!M.pW_lb_ok
1180     ~style:`BOTH_HORIZ
1181     ~icon:(A.get_icon ~icon:M.icon_stock_ok ~size:A.SMALL ())
1182     ~f ()
1183   );
1184   insert_options menu_list vbox_opt;
1185   win := Some window;
1186   window#show ()
1187
1188
1189
1190
1191 let config_window ?(on_ok = fun () -> ()) () =
1192   match !win with
1193       Some w ->
1194         w#present ()
1195     | None ->
1196        begin
1197          let _ =
1198             match !sections with
1199                 [] -> build_sections ()
1200               | _ -> ()
1201           in
1202           create_config_window on_ok
1203         end
1204
1205   end)
1206
1207 (*************************************************************************)
1208 (*************************************************************************)
1209 (*************************************************************************)
1210 (*                                                                       *)
1211 (*                         PANEL                                         *)
1212 (*                                                                       *)
1213 (*************************************************************************)
1214 (*************************************************************************)
1215 (*************************************************************************)
1216
1217 let panel ~(structure: (string * ('a, 'b, 'c) preference list) list)
1218   ?(title=(remove_ !M.mW_lb_settings))
1219   ?(icon=(A.get_icon ~icon:M.icon_menu_settings ~size:A.SMALL ()))
1220   ?(advanced_mode=ref false)
1221   ?(on_ok = fun () -> ()) () =
1222   let window =
1223     GWindow.window
1224       ~title
1225       ~icon
1226       ~position:`CENTER_ALWAYS
1227       ~kind:`TOPLEVEL
1228       ~resizable:true ~modal:false ()
1229   in
1230   window#set_skip_taskbar_hint false;
1231   window#set_skip_pager_hint false;
1232   let vbox =
1233     GPack.vbox ~homogeneous:false
1234       ~packing:window#add ()
1235   in
1236   let notebook =
1237     GPack.notebook ~homogeneous_tabs:true ~scrollable:true
1238       ~packing:(vbox#pack ~expand:true ~fill:true) ()
1239   in
1240   let _separator =
1241     GMisc.separator `HORIZONTAL
1242     ~packing:(vbox#pack ~expand:false ~fill:true) ()
1243   in
1244   let hbox_button =
1245     GPack.hbox ~homogeneous:false ~border_width:6
1246       ~packing:(vbox#pack ~expand:false ~fill:true) ()
1247   in
1248   let bbox =
1249     GuiTools.tool_bar `HORIZONTAL ~border_width:6 ~spacing:6
1250       ~layout:`END ~packing:hbox_button#add ()
1251   in
1252   ignore (bbox#add_button
1253     ~markup:!M.pW_lb_cancel
1254     ~style:`BOTH_HORIZ
1255     ~icon:(A.get_icon ~icon:M.icon_stock_close ~size:A.SMALL ())
1256     ~f:(window#destroy) ()
1257   );
1258   let f () =
1259     List.iter (fun (_, prefs) ->
1260       List.iter (fun p ->
1261         p.pref_apply_default ()
1262       ) prefs;
1263     ) structure
1264   in
1265   ignore (bbox#add_button
1266     ~markup:!M.pW_lb_default
1267     ~style:`TEXT
1268     ~f ()
1269   );
1270   let f () =
1271     List.iter (fun (_, prefs) ->
1272       List.iter (fun p ->
1273         p.pref_apply ();
1274       ) prefs;
1275     ) structure;
1276     on_ok ();
1277     window#destroy ()
1278   in
1279   ignore (bbox#add_button
1280     ~markup:!M.pW_lb_ok
1281     ~style:`BOTH_HORIZ
1282     ~icon:(A.get_icon ~icon:M.icon_stock_ok ~size:A.SMALL ())
1283     ~f ()
1284   );
1285   List.iter (fun (s, prefs) ->
1286     let top = ref 0 in
1287     let markup = GuiTools.create_markup s in
1288     let scrolled_box =
1289       GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`ALWAYS
1290         ~placement:`TOP_LEFT ()
1291     in
1292     let table =
1293       GPack.table ~columns:2 ~homogeneous:false
1294          ~row_spacings:6 ~col_spacings:6 ~border_width:6
1295          ~packing:scrolled_box#add_with_viewport ()
1296     in
1297     ignore (notebook#append_page
1298       ~tab_label:((GMisc.label ~use_underline:true ~markup ())#coerce)
1299       scrolled_box#coerce);
1300     List.iter (fun p->
1301       add_pref ~table ~p ~top:!top ~advanced_mode ();
1302       incr top
1303     ) prefs;
1304   ) structure;
1305   window#show ()
1306
1307 (*************************************************************************)
1308 (*************************************************************************)
1309 (*************************************************************************)
1310 (*                                                                       *)
1311 (*                         SIMPLE_PANEL                                  *)
1312 (*                                                                       *)
1313 (*************************************************************************)
1314 (*************************************************************************)
1315 (*************************************************************************)
1316
1317 let simple_panel ~(prefs: (('a, 'b, 'c) preference) list)
1318   ?(title=(remove_ !M.mW_lb_settings))
1319   ?(icon=(A.get_icon ~icon:M.icon_menu_settings ~size:A.SMALL ()))
1320   ?(advanced_mode=ref false)
1321   ?(on_ok = fun () -> ()) () =
1322   let window =
1323     GWindow.window
1324       ~title
1325       ~icon
1326       ~position:`CENTER_ALWAYS
1327       ~kind:`TOPLEVEL
1328       ~resizable:true ~modal:false ()
1329   in
1330   window#set_skip_taskbar_hint false;
1331   window#set_skip_pager_hint false;
1332   let vbox =
1333     GPack.vbox ~homogeneous:false
1334       ~packing:window#add ()
1335   in
1336   let table =
1337     GPack.table ~columns:2 ~homogeneous:false
1338        ~row_spacings:6 ~col_spacings:6 ~border_width:6
1339        ~packing:vbox#add ()
1340   in
1341   let _separator =
1342     GMisc.separator `HORIZONTAL
1343     ~packing:(vbox#pack ~expand:false ~fill:true) ()
1344   in
1345   let hbox_button =
1346     GPack.hbox ~homogeneous:false ~border_width:6
1347       ~packing:(vbox#pack ~expand:false ~fill:true) ()
1348   in
1349   let bbox =
1350     GuiTools.tool_bar `HORIZONTAL ~border_width:6 ~spacing:6
1351       ~layout:`END ~packing:hbox_button#add ()
1352   in
1353   ignore (bbox#add_button
1354     ~markup:!M.pW_lb_cancel
1355     ~style:`BOTH_HORIZ
1356     ~icon:(A.get_icon ~icon:M.icon_stock_close ~size:A.SMALL ())
1357     ~f:(window#destroy) ()
1358   );
1359   let f () =
1360     List.iter (fun p ->
1361       p.pref_apply_default ()
1362     ) prefs
1363   in
1364   ignore (bbox#add_button
1365     ~markup:!M.pW_lb_default
1366     ~style:`TEXT
1367     ~f ()
1368   );
1369   let f () =
1370     List.iter (fun p ->
1371       p.pref_apply ();
1372     ) prefs;
1373     on_ok ();
1374     window#destroy ()
1375   in
1376   ignore (bbox#add_button
1377     ~markup:!M.pW_lb_ok
1378     ~style:`BOTH_HORIZ
1379     ~icon:(A.get_icon ~icon:M.icon_stock_ok ~size:A.SMALL ())
1380     ~f ()
1381   );
1382   let top = ref 0 in
1383   List.iter (fun p ->
1384     add_pref ~table ~p ~top:!top ~advanced_mode ();
1385     incr top
1386   ) prefs;
1387   window#show ()
1388
1389 (*************************************************************************)
1390 (*************************************************************************)
1391 (*************************************************************************)
1392 (*                                                                       *)
1393 (*                         INPUT_WINDOW                                  *)
1394 (*                                                                       *)
1395 (*************************************************************************)
1396 (*************************************************************************)
1397 (*************************************************************************)
1398
1399 let input_window ~(pref: ('a, 'b, 'c) preference)
1400   ?(title=(remove_ !M.mW_lb_settings))
1401   ?(icon=(A.get_icon ~icon:M.icon_menu_settings ~size:A.SMALL ()))
1402   ?(advanced_mode=ref false)
1403   ?(on_ok = fun () -> ()) () =
1404   let window =
1405     GWindow.window
1406       ~title
1407       ~icon
1408       ~position:`CENTER_ALWAYS
1409       ~kind:`TOPLEVEL
1410       ~resizable:true ~modal:false ()
1411   in
1412   window#set_skip_taskbar_hint false;
1413   window#set_skip_pager_hint false;
1414   let vbox =
1415     GPack.vbox ~homogeneous:false
1416       ~packing:window#add ()
1417   in
1418   let table =
1419     GPack.table ~columns:2 ~homogeneous:false
1420        ~row_spacings:6 ~col_spacings:6 ~border_width:6
1421        ~packing:vbox#add ()
1422   in
1423   let _separator =
1424     GMisc.separator `HORIZONTAL
1425     ~packing:(vbox#pack ~expand:false ~fill:true) ()
1426   in
1427   let hbox_button =
1428     GPack.hbox ~homogeneous:false ~border_width:6
1429       ~packing:(vbox#pack ~expand:false ~fill:true) ()
1430   in
1431   let bbox =
1432     GuiTools.tool_bar `HORIZONTAL ~border_width:6 ~spacing:6
1433       ~layout:`END ~packing:hbox_button#add ()
1434   in
1435   ignore (bbox#add_button
1436     ~markup:!M.pW_lb_cancel
1437     ~style:`BOTH_HORIZ
1438     ~icon:(A.get_icon ~icon:M.icon_stock_close ~size:A.SMALL ())
1439     ~f:(window#destroy) ()
1440   );
1441   ignore (bbox#add_button
1442     ~markup:!M.pW_lb_default
1443     ~style:`TEXT
1444     ~f:(pref.pref_apply_default) ()
1445   );
1446   let f () =
1447     pref.pref_apply ();
1448     on_ok ();
1449     window#destroy ()
1450   in
1451   ignore (bbox#add_button
1452     ~markup:!M.pW_lb_ok
1453     ~style:`BOTH_HORIZ
1454     ~icon:(A.get_icon ~icon:M.icon_stock_ok ~size:A.SMALL ())
1455     ~f ()
1456   );
1457   add_pref ~table ~p:pref ~top:0 ~advanced_mode ();
1458   window#show ()