src/gtk2/gui/guiServers.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 (* The servers window of MLgui *)
  21
  22 open GuiTypes2
  23 open GuiTypes
  24 open CommonTypes
  25
  26 open GuiTools
  27 open GuiGlobal
  28 open GuiColumns
  29 open Md4
  30 open GuiProto
  31
  32 module M = GuiMessages
  33 module Mi = GuiMisc
  34 module O = GuiOptions
  35 module G = GuiGlobal
  36 module A = GuiArt
  37 module U = GuiUtf8
  38
  39 let (!!) = Options.(!!)
  40 let (=:=) = Options.(=:=)
  41 let (<:>) = GuiTools.(<:>)
  42
  43 let verbose = O.gtk_verbose_servers
  44
  45 let lprintf' fmt =
  46   Printf2.lprintf ("GuiServers: " ^^ fmt)
  47
  48 (*************************************************************************)
  49 (*                                                                       *)
  50 (*                         Global variables                              *)
  51 (*                                                                       *)
  52 (*************************************************************************)
  53
  54 let current_net = ref 0
  55
  56 let (user_label : GMisc.label option ref) = ref None
  57 let (server_label : GMisc.label option ref) = ref None
  58
  59 let net_cols = new GTree.column_list
  60 let net_num = net_cols#add Gobject.Data.int
  61 let net_text = net_cols#add Gobject.Data.string
  62 let net_icon = net_cols#add Gobject.Data.gobject_option
  63 let net_store = GTree.list_store net_cols
  64 let net_model = GTree.model_sort net_store
  65
  66 let _ =
  67   net_model#set_default_sort_func
  68     (fun model iter_a iter_b ->
  69        let a = model#get ~row:iter_a ~column:net_text in
  70        let b = model#get ~row:iter_b ~column:net_text in
  71        compare a b
  72   )
  73
  74 let (view_context : GPango.context option ref) = ref None
  75
  76 (*************************************************************************)
  77 (*                                                                       *)
  78 (*                         server_num                                    *)
  79 (*                                                                       *)
  80 (*************************************************************************)
  81
  82 let server_num key =
  83   try int_of_string key with _ -> raise Not_found
  84
  85 (*************************************************************************)
  86 (*                                                                       *)
  87 (*                         server_of_key                                 *)
  88 (*                                                                       *)
  89 (*************************************************************************)
  90
  91 let server_of_key key =
  92   try
  93     let num = server_num key in
  94     Hashtbl.find G.servers num
  95   with _ -> raise Not_found
  96
  97 (*************************************************************************)
  98 (*                                                                       *)
  99 (*                         keys_to_servers                               *)
 100 (*                                                                       *)
 101 (*************************************************************************)
 102
 103 let keys_to_servers keys =
 104   let l = ref [] in
 105   List.iter (fun k ->
 106     try
 107       let s = server_of_key k in
 108       l := s :: !l
 109     with _ -> ()) keys;
 110   !l
 111
 112 (*************************************************************************)
 113 (*                                                                       *)
 114 (*                         server_key                                    *)
 115 (*                                                                       *)
 116 (*************************************************************************)
 117
 118 let server_key server_num =
 119   Printf.sprintf "%d" server_num
 120
 121 (*************************************************************************)
 122 (*                                                                       *)
 123 (*                         Templates                                     *)
 124 (*                                                                       *)
 125 (*************************************************************************)
 126
 127 module ServerUsers = GuiUsers.UserList (struct
 128
 129   let columns = O.servers_users_columns
 130   let view_context = view_context
 131   let module_name = "ServerUsers"
 132
 133 end)
 134
 135
 136 let userstore = new ServerUsers.g_user ()
 137
 138 module Servers = GuiTemplates.Gview(struct
 139
 140   module Column = GuiColumns.Server
 141
 142   type item = server_info
 143
 144   let columns = O.servers_columns
 145   let get_key = (fun s -> server_key s.server_num)
 146   let module_name = "Servers"
 147
 148 end)
 149
 150 class g_server () =
 151 (* first we create a GTree.column_list *)
 152   let server_cols         = new GTree.column_list in
 153 (*
 154  * we fill the newly created GTree.column_list to
 155  * define the interface between the GTree.model and
 156  * the  GTree.view.
 157  *)
 158   let server_network_str  = server_cols#add Gobject.Data.string in
 159   let server_name         = server_cols#add Gobject.Data.string in
 160   let server_ip_port      = server_cols#add Gobject.Data.string in
 161   let server_state_str    = server_cols#add Gobject.Data.string in
 162   let server_nusers       = server_cols#add Gobject.Data.int64 in
 163   let server_nfiles       = server_cols#add Gobject.Data.int64 in
 164   let server_desc         = server_cols#add Gobject.Data.string in
 165   let server_tags_str     = server_cols#add Gobject.Data.string in
 166   let server_score        = server_cols#add Gobject.Data.int in
 167   let server_network_pixb = server_cols#add Gobject.Data.gobject_option in
 168   let server_state_pixb   = server_cols#add Gobject.Data.gobject_option in
 169   let server_preferred    = server_cols#add Gobject.Data.boolean in
 170   object (self)
 171 (* from this point you cannot change server_cols ! *)
 172   inherit Servers.g_list server_cols
 173
 174 (*
 175  * to create an instance from the virtual class g_list of GuiTemplates
 176  * we have to define its virtual methods.
 177  *)
 178
 179 (*************************************************************************)
 180 (*                                                                       *)
 181 (*                         from_item                                     *)
 182 (*                                                                       *)
 183 (*************************************************************************)
 184
 185   method from_item (row : Gtk.tree_iter) (s : server_info) =
 186     store#set ~row ~column:server_nusers        s.server_nusers;
 187     store#set ~row ~column:server_nfiles        s.server_nfiles;
 188     store#set ~row ~column:server_score         s.server_score;
 189     store#set ~row ~column:server_network_str  (Mi.network_name s.server_network);
 190     store#set ~row ~column:server_name         (U.utf8_of s.server_name);
 191     store#set ~row ~column:server_ip_port      (Mi.address_to_string s.server_addr s.server_port);
 192     store#set ~row ~column:server_state_str    (Mi.string_of_state s.server_state 0);
 193     store#set ~row ~column:server_tags_str     (Mi.tags_to_string s.server_tags);
 194     store#set ~row ~column:server_desc         (U.utf8_of s.server_description);
 195     store#set ~row ~column:server_network_pixb (Mi.network_pixb s.server_network ~size:A.SMALL ());
 196     store#set ~row ~column:server_state_pixb   (Mi.server_state_of_server s.server_network s.server_state ~size:A.SMALL);
 197     store#set ~row ~column:server_preferred     s.server_preferred
 198
 199 (*************************************************************************)
 200 (*                                                                       *)
 201 (*                         from_new_item                                 *)
 202 (*                                                                       *)
 203 (*************************************************************************)
 204
 205   method from_new_item (row : Gtk.tree_iter) (s : server_info) (s_new : server_info) =
 206     if s.server_name <> s_new.server_name
 207       then begin
 208         store#set ~row ~column:server_name (U.utf8_of s_new.server_name);
 209       end;
 210     if s.server_state <> s_new.server_state
 211       then begin
 212         store#set ~row ~column:server_state_str (Mi.string_of_state s_new.server_state 0);
 213         store#set ~row ~column:server_state_pixb (Mi.server_state_of_server s_new.server_network s_new.server_state ~size:A.SMALL)
 214       end;
 215     if (s.server_addr, s.server_port) <> (s_new.server_addr, s_new.server_port)
 216       then begin
 217         store#set ~row ~column:server_ip_port (Mi.address_to_string s_new.server_addr s_new.server_port);
 218       end;
 219     if s.server_nusers <> s_new.server_nusers
 220       then begin
 221         store#set ~row ~column:server_nusers s_new.server_nusers;
 222       end;
 223     if s.server_nfiles <> s_new.server_nfiles
 224       then begin
 225         store#set ~row ~column:server_nfiles s_new.server_nfiles;
 226       end;
 227     if s.server_tags <> s_new.server_tags
 228       then begin
 229         store#set ~row ~column:server_tags_str (Mi.tags_to_string s_new.server_tags);
 230       end;
 231     if s.server_description <> s_new.server_description
 232       then begin
 233         store#set ~row ~column:server_desc (U.utf8_of s_new.server_description)
 234       end;
 235     if s.server_score <> s_new.server_score
 236       then begin
 237         store#set ~row ~column:server_score s_new.server_score
 238       end;
 239     if s.server_preferred <> s_new.server_preferred
 240       then begin
 241         store#set ~row ~column:server_preferred s_new.server_preferred
 242       end
 243
 244 (*************************************************************************)
 245 (*                                                                       *)
 246 (*                         content                                       *)
 247 (*                                                                       *)
 248 (*************************************************************************)
 249
 250   method content col c =
 251     let autosize = match col#sizing with `AUTOSIZE -> true | _ -> false in
 252     match c with
 253       Col_server_name ->
 254          begin
 255            if !!O.gtk_look_use_icons
 256              then begin
 257                let renderer = GTree.cell_renderer_pixbuf [`XALIGN 0.;`XPAD 4] in
 258                col#pack ~expand:false renderer;
 259                col#add_attribute renderer "pixbuf" server_state_pixb
 260              end;
 261            let renderer = GTree.cell_renderer_text [`XALIGN 0.] in
 262            col#pack ~expand:false renderer;
 263            if autosize
 264              then col#add_attribute renderer "text" server_name
 265              else col#set_cell_data_func renderer
 266                (fun model row ->
 267                   match !view_context with
 268                     Some context when col#width > 0 ->
 269                       begin
 270                         let width =
 271                           if !!O.gtk_look_use_icons
 272                             then (col#width - 4 - !!O.gtk_look_lists_icon_size) - 4 * !G.char_width
 273                             else col#width - 4 * !G.char_width
 274                         in
 275                         let name = model#get ~row ~column:server_name in
 276                         let s = GuiTools.fit_string_to_pixels name ~context ~pixels:width in
 277                         renderer#set_properties [ `TEXT s ; `EDITABLE true ];
 278                         ignore (renderer#connect#edited ~callback:
 279                           (fun path name ->
 280                              try
 281                                let iter = self#get_iter path in
 282                                let k = self#find_model_key iter in
 283                                let s = server_of_key k in
 284                                GuiCom.send (ServerRename (server_num k, name));
 285                                let row = self#convert_iter_to_child_iter iter in
 286                                store#set ~row ~column:server_name s.server_name
 287                              with _ -> ()
 288                         ));
 289                       end
 290                   | _ -> renderer#set_properties [ `TEXT "" ]
 291              )
 292          end
 293
 294     | Col_server_address ->
 295          begin
 296            let renderer = GTree.cell_renderer_text [`XALIGN 0.] in
 297            col#pack renderer;
 298            col#add_attribute renderer "text" server_ip_port
 299          end
 300
 301     | Col_server_state ->
 302          begin
 303            let renderer = GTree.cell_renderer_text [`XALIGN 0.] in
 304            col#pack renderer;
 305            col#add_attribute renderer "text" server_state_str
 306          end
 307
 308     | Col_server_users ->
 309          begin
 310            let renderer = GTree.cell_renderer_text [`XALIGN 1.] in
 311            col#pack renderer;
 312            col#add_attribute renderer "text" server_nusers
 313          end
 314
 315     | Col_server_files ->
 316          begin
 317            let renderer = GTree.cell_renderer_text [`XALIGN 1.] in
 318            col#pack renderer;
 319            col#add_attribute renderer "text" server_nfiles
 320          end
 321
 322     | Col_server_desc ->
 323          begin
 324            let renderer = GTree.cell_renderer_text [`XALIGN 0.] in
 325            col#pack renderer;
 326            col#add_attribute renderer "text" server_desc
 327          end
 328
 329     | Col_server_tags ->
 330          begin
 331            let renderer = GTree.cell_renderer_text [`XALIGN 0.] in
 332            col#pack renderer;
 333            col#add_attribute renderer "text" server_tags_str
 334          end
 335
 336     | Col_server_network ->
 337          begin
 338            if !!O.gtk_look_use_icons
 339              then begin
 340                let renderer = GTree.cell_renderer_pixbuf [`XALIGN 0.] in
 341                col#pack renderer;
 342                col#add_attribute renderer "pixbuf" server_network_pixb
 343              end else begin
 344                let renderer = GTree.cell_renderer_text [`XALIGN 0.] in
 345                col#pack renderer;
 346                col#add_attribute renderer "text" server_network_str
 347              end
 348          end
 349
 350     | Col_server_preferred ->
 351          begin
 352            let renderer = GTree.cell_renderer_toggle [`XALIGN 0.5] in
 353            col#pack renderer;
 354            col#add_attribute renderer "active" server_preferred;
 355            ignore (renderer#connect#toggled ~callback:
 356              (fun path ->
 357                 try
 358                   let iter = self#get_iter path in
 359                   let k = self#find_model_key iter in
 360                   let s = server_of_key k in
 361                   GuiCom.send (ServerSetPreferred (server_num k, not s.server_preferred));
 362                   let row = self#convert_iter_to_child_iter iter in
 363                   store#set ~row ~column:server_preferred s.server_preferred
 364                 with _ -> ()
 365            ));
 366          end
 367
 368 (*************************************************************************)
 369 (*                                                                       *)
 370 (*                         sort_items                                    *)
 371 (*                                                                       *)
 372 (*************************************************************************)
 373
 374   method sort_items c k1 k2 =
 375     try
 376       let s1 = server_of_key k1 in
 377       let s2 = server_of_key k2 in
 378       match c with
 379         Col_server_address ->
 380           begin
 381             let i = compare s1.server_addr s2.server_addr in
 382             if i = 0
 383               then compare s1.server_port s2.server_port
 384               else i
 385           end
 386
 387       | Col_server_state -> compare (Mi.string_of_state s1.server_state 0)
 388                                     (Mi.string_of_state s2.server_state 0)
 389       | Col_server_users -> compare s1.server_nusers s2.server_nusers
 390       | Col_server_files -> compare s1.server_nfiles s2.server_nfiles
 391       | Col_server_desc -> compare (String.lowercase s1.server_description)
 392                                    (String.lowercase s2.server_description)
 393       | Col_server_network -> compare s1.server_network s2.server_network
 394       | Col_server_name -> compare (String.lowercase s1.server_name)
 395                                    (String.lowercase s2.server_name)
 396       | Col_server_tags -> compare s1.server_tags s2.server_tags
 397       | Col_server_preferred -> compare s1.server_preferred s2.server_preferred
 398   with _ -> 0
 399
 400 (*************************************************************************)
 401 (*                                                                       *)
 402 (*                         force_update_icons                            *)
 403 (*                                                                       *)
 404 (*************************************************************************)
 405
 406     method force_update_icons () =
 407       let f k row =
 408         let s = server_of_key k in
 409         store#set ~row ~column:server_network_pixb (Mi.network_pixb s.server_network ~size:A.SMALL ());
 410         store#set ~row ~column:server_state_pixb   (Mi.server_state_of_server s.server_network s.server_state ~size:A.SMALL)
 411       in
 412       List.iter (fun k ->
 413         try
 414           let row = self#find_row k in
 415           Gaux.may ~f:(f k ) row
 416         with _ -> ()
 417       ) (self#all_items ())
 418
 419   end
 420
 421 let serverstore = new g_server ()
 422
 423 (*************************************************************************)
 424 (*                                                                       *)
 425 (*                         update_servers_label                          *)
 426 (*                                                                       *)
 427 (*************************************************************************)
 428
 429 let update_servers_labels () =
 430   let _ =
 431     match !server_label with
 432         Some label ->
 433           begin
 434             let markup =
 435               create_default_bold_markup
 436                (Printf.sprintf "%s (%d)" !M.sT_lb_servers !G.nservers)
 437             in
 438             label#set_label markup
 439           end
 440       | _ -> ()
 441   in
 442   GuiStatusBar.update_servers ()
 443
 444 (*************************************************************************)
 445 (*                                                                       *)
 446 (*                         update_users_label                            *)
 447 (*                                                                       *)
 448 (*************************************************************************)
 449
 450 let update_users_label () =
 451   match !user_label with
 452       Some label ->
 453         begin
 454           let markup =
 455             create_default_bold_markup
 456              (Printf.sprintf "%s (%d)" !M.sT_lb_users userstore#nitems)
 457           in
 458           label#set_label markup
 459         end
 460     | _ -> ()
 461
 462 (*************************************************************************)
 463 (*                                                                       *)
 464 (*                         message to the core                           *)
 465 (*                                                                       *)
 466 (*************************************************************************)
 467
 468 let remove sel () =
 469   let l = keys_to_servers sel in
 470   List.iter (fun s ->
 471     GuiCom.send (RemoveServer_query s.server_num)
 472   ) l
 473
 474 let connect_to sel () =
 475   let l = keys_to_servers sel in
 476   List.iter (fun s ->
 477     GuiCom.send (ConnectServer s.server_num)
 478   ) l
 479
 480 let disconnect sel () =
 481   let l = keys_to_servers sel in
 482   List.iter (fun s ->
 483     GuiCom.send (DisconnectServer s.server_num)
 484   ) l
 485
 486 let view_users sel () =
 487   let l = keys_to_servers sel in
 488   List.iter (fun s ->
 489     GuiCom.send (ViewUsers s.server_num)
 490   ) l
 491
 492 let add_new_server entry_addr entry_port () =
 493   try
 494     let addr = entry_addr#text in
 495     let port = entry_port#value_as_int in
 496     let ip = Ip.of_string addr in
 497     GuiCom.send (AddServer_query (!current_net, ip, port))
 498   with _ -> ()
 499
 500 let connect_more_servers () =
 501   GuiCom.send ConnectMore_query
 502
 503 let remove_old_servers () =
 504   GuiCom.send CleanOldServers
 505
 506 let clear_users sel () =
 507   let l = keys_to_servers sel in
 508   List.iter (fun s ->
 509     match s.server_users with
 510         None -> ()
 511       | Some l ->
 512           begin
 513             List.iter (fun user_num ->
 514               Hashtbl.remove G.users user_num
 515             ) l;
 516             s.server_users <- None
 517           end
 518   ) l;
 519   userstore#clear (); (* if we call clear_users there is a good chance that some users are currently displaied *)
 520   update_users_label ()
 521
 522 let get_user_info user_num =
 523   GuiCom.send (GetUser_info user_num)
 524
 525 let server_set_preferred sel b () =
 526   let l = keys_to_servers sel in
 527   List.iter (fun s ->
 528     GuiCom.send (ServerSetPreferred (s.server_num, b))
 529   ) l
 530
 531 let server_rename s name () =
 532   GuiCom.send (ServerRename (s.server_num, name))
 533
 534 (*************************************************************************)
 535 (*                                                                       *)
 536 (*                         server_menu                                   *)
 537 (*                                                                       *)
 538 (*************************************************************************)
 539
 540 let server_menu sel =
 541   let l =
 542     match sel with
 543         [] -> []
 544       | _ ->
 545             [
 546              `I ((!M.sT_me_connect), connect_to sel) ;
 547              `I ((!M.sT_me_disconnect), disconnect sel) ;
 548              `I ((!M.sT_me_view_users), view_users sel) ;
 549              `I ((!M.sT_me_remove), remove sel) ;
 550              `I ((!M.sT_me_clear_users), clear_users sel);
 551              `S
 552             ]
 553   in
 554   l @
 555             [
 556              `I ((!M.sT_me_connect_more_servers), connect_more_servers) ;
 557              `I ((!M.sT_me_remove_old_servers), remove_old_servers)
 558             ]
 559
 560 (*************************************************************************)
 561 (*                                                                       *)
 562 (*                         on_select_server                              *)
 563 (*                                                                       *)
 564 (*************************************************************************)
 565
 566 let on_select_server sel =
 567   userstore#clear ();
 568   update_users_label ();
 569   match sel with
 570       [] -> ()
 571     | k :: tail ->
 572         begin
 573           try
 574             let s = server_of_key k in
 575             match s.server_users with
 576                 None -> (if !!verbose then lprintf' "No user for server %s\n" s.server_name)
 577               | Some l ->
 578                   begin
 579                     List.iter (fun user_num ->
 580                       try
 581                         (if !!verbose then lprintf' "Add user %d to list of server %s\n" user_num s.server_name);
 582                         let u = Hashtbl.find G.users user_num in
 583                         userstore#add_item u ~f:update_users_label ()
 584                       with _ -> get_user_info user_num
 585                     ) l
 586                   end
 587           with _ -> ()
 588         end
 589
 590 (*************************************************************************)
 591 (*                                                                       *)
 592 (*                         filter_server                                 *)
 593 (*                                                                       *)
 594 (*************************************************************************)
 595
 596 let filter_disconnected_servers = ref false
 597
 598 let filter_server k =
 599   try
 600     let s = server_of_key k in
 601     not ((!filter_disconnected_servers &&
 602            (match s.server_state with
 603                 NotConnected _
 604               | NewHost -> true | _ -> false)) ||
 605          List.memq s.server_network !G.networks_filtered)
 606   with _ -> true
 607
 608 (*************************************************************************)
 609 (*                                                                       *)
 610 (*                         Templates initialization                      *)
 611 (*                                                                       *)
 612 (*************************************************************************)
 613
 614 let _ =
 615   serverstore#set_filter filter_server
 616
 617 (*************************************************************************)
 618 (*                                                                       *)
 619 (*                         clear                                         *)
 620 (*                                                                       *)
 621 (*************************************************************************)
 622
 623 let clear () =
 624   serverstore#clear ();
 625   userstore#clear ();
 626   net_store#clear ();
 627   current_net := 0;
 628   update_servers_labels ();
 629   update_users_label ()
 630
 631 (*************************************************************************)
 632 (*                                                                       *)
 633 (*                         message from the core                         *)
 634 (*                                                                       *)
 635 (*************************************************************************)
 636
 637 let hashtbl_server_update s s_new =
 638   s.server_addr <- s_new.server_addr;
 639   s.server_port <- s_new.server_port;
 640   s.server_realport <- s_new.server_realport;
 641   s.server_score <- s_new.server_score;
 642   s.server_tags <- s_new.server_tags;
 643   s.server_nusers <- s_new.server_nusers;
 644   s.server_nfiles <- s_new.server_nfiles;
 645   s.server_state <- s_new.server_state;
 646   s.server_name <- s_new.server_name;
 647   s.server_description <- s_new.server_description;
 648   s.server_users <- s_new.server_users;
 649   s.server_banner <- s_new.server_banner;
 650   s.server_preferred <- s_new.server_preferred
 651
 652 let remove_server server_num =
 653   try
 654     let s = Hashtbl.find G.servers server_num in
 655     let _ =
 656       match s.server_users with
 657           None -> ()
 658         | Some l ->
 659             List.iter (fun user_num ->
 660               Hashtbl.remove G.users user_num
 661             ) l
 662     in
 663     Hashtbl.remove G.servers server_num;
 664     serverstore#remove_item (server_key server_num);
 665     decr G.nservers;
 666     update_servers_labels ()
 667   with _ -> ()
 668
 669 let update_server serv =
 670   try
 671     let s = Hashtbl.find G.servers serv.server_num in
 672     let row = serverstore#find_row (server_key serv.server_num) in
 673     let s_new = {serv with server_users = s.server_users} in
 674     let _ =
 675       match Mi.is_connected s_new.server_state, Mi.is_connected s.server_state with
 676           true, false -> incr G.nconnected_servers
 677         | false, true -> decr G.nconnected_servers
 678         | _ -> ()
 679     in
 680     Gaux.may ~f:(fun r -> serverstore#update_item r s s_new) row;
 681     hashtbl_server_update s s_new;
 682     update_servers_labels ()
 683   with Not_found ->
 684     begin
 685       serverstore#add_item serv ~f:update_servers_labels ();
 686       if Mi.is_connected serv.server_state
 687         then begin
 688           incr G.nconnected_servers
 689         end;
 690       incr G.nservers;
 691       Hashtbl.add G.servers serv.server_num serv
 692     end
 693
 694
 695 let server_info s =
 696   match s.server_state with
 697       RemovedHost ->
 698         remove_server s.server_num
 699     | _  ->
 700         update_server s
 701
 702 let h_server_update_state server_num state =
 703   try
 704     let s = Hashtbl.find G.servers server_num in
 705     let row = serverstore#find_row (server_key server_num) in
 706     if state = RemovedHost
 707       then remove_server server_num
 708       else begin
 709         let s_new = {s with server_state = state} in
 710         let _ =
 711           match Mi.is_connected s_new.server_state, Mi.is_connected s.server_state with
 712               true, false -> incr G.nconnected_servers
 713             | false, true -> decr G.nconnected_servers
 714             | _ -> ()
 715         in
 716         Gaux.may ~f:(fun r -> serverstore#update_item r s s_new) row;
 717         s.server_state <- s_new.server_state
 718       end
 719
 720   with Not_found -> GuiCom.send (GetServer_info server_num)
 721
 722 let h_server_busy server_num nusers nfiles =
 723   try
 724     let s = Hashtbl.find G.servers server_num in
 725     let row = serverstore#find_row (server_key server_num) in
 726     let s_new = {s with server_nusers = nusers;
 727                         server_nfiles = nfiles}
 728     in
 729     Gaux.may ~f:(fun r -> serverstore#update_item r s s_new) row;
 730     s.server_nusers <- s_new.server_nusers;
 731     s.server_nfiles <- s_new.server_nfiles
 732   with Not_found -> GuiCom.send (GetServer_info server_num)
 733
 734 let h_server_update_users server_num user =
 735   try
 736     let s = Hashtbl.find G.servers server_num in
 737     let _row = serverstore#find_row (server_key server_num) in
 738     match s.server_users with
 739         None ->
 740           begin
 741             s.server_users <- Some [user]
 742           end
 743       | Some list ->
 744           if not (List.mem user list)
 745             then begin
 746               s.server_users <- Some (user :: list)
 747             end
 748
 749   with Not_found ->
 750     if server_num <> 0
 751       then begin
 752         Hashtbl.remove G.users user;       (* Anyway remove the user. Will be sent back by the core *)
 753         GuiCom.send (GetServer_info server_num);
 754         GuiCom.send (GetServer_users server_num)
 755       end
 756
 757 let clean_servers_table servers =
 758   let l = serverstore#all_items () in
 759   (if !!verbose then lprintf' "Cleaning servers\n   servers table : %d\n   new servers   : %d\n"
 760      (List.length l) (List.length servers));
 761   List.iter (fun k ->                                              (* the core sends more servers than what the GUI displays.
 762                                                                     * better to do it this way.
 763                                                                     *)
 764     try
 765       let s = server_of_key k in
 766       if not (List.mem s.server_num servers)
 767         then remove_server s.server_num
 768     with _ -> ()
 769   ) l;
 770   if !!verbose
 771     then begin
 772       let l = serverstore#all_items () in
 773       lprintf' "   ----------------------------\n   servers table : %d\n" (List.length l)
 774     end
 775
 776 (*************************************************************************)
 777 (*                                                                       *)
 778 (*                         message from GuiNetwoks                       *)
 779 (*                                                                       *)
 780 (*************************************************************************)
 781
 782 let clean_servers net_num net_enabled =
 783   if not net_enabled
 784     then begin
 785       let l = serverstore#all_items () in
 786       List.iter (fun k ->
 787         try
 788           let s = server_of_key k in
 789           if s.server_network = net_num
 790             then remove_server s.server_num
 791         with _ -> ()
 792       ) l
 793     end
 794
 795 let reset_servers_filter () =
 796   serverstore#refresh_filter ()
 797
 798 (*************************************************************************)
 799 (*                                                                       *)
 800 (*                         on_net_select                                 *)
 801 (*                                                                       *)
 802 (*************************************************************************)
 803
 804 let on_net_select net_num =
 805   current_net := net_num
 806
 807 (*************************************************************************)
 808 (*                                                                       *)
 809 (*                         renderer_pack_combobox                        *)
 810 (*                                                                       *)
 811 (*************************************************************************)
 812
 813 let renderer_pack_combobox (combobox : GEdit.combo_box)
 814      ((col_pixb : GdkPixbuf.pixbuf option GTree.column),
 815       (col_text : string GTree.column),
 816       (col_num  : int GTree.column)) (f : int -> unit) =
 817   if !!O.gtk_look_use_icons
 818     then begin
 819       let pixb_renderer = GTree.cell_renderer_pixbuf [] in
 820       combobox#pack pixb_renderer ;
 821       combobox#add_attribute pixb_renderer "pixbuf" col_pixb
 822     end;
 823   let str_renderer = GTree.cell_renderer_text [ `XPAD 6 ] in
 824   combobox#pack str_renderer;
 825   combobox#add_attribute str_renderer "text" col_text;
 826   ignore (combobox#connect#changed ~callback:
 827     (fun _ ->
 828       match combobox#active_iter with
 829           Some row ->
 830             begin
 831               let num = combobox#model#get ~row ~column:col_num in
 832               f num
 833             end
 834         | _ -> ()
 835   ))
 836
 837 (*************************************************************************)
 838 (*                                                                       *)
 839 (*                         build_net_menu                                *)
 840 (*                                                                       *)
 841 (*************************************************************************)
 842
 843 let build_net_menu () =
 844   Hashtbl.iter (fun num net ->
 845     if net.net_enabled && (Mi.net_has_server net)
 846       then begin
 847         let row = net_store#append () in
 848         net_store#set ~row ~column:net_num net.net_num;
 849         net_store#set ~row ~column:net_text (U.simple_utf8_of net.net_name);
 850         net_store#set ~row ~column:net_icon (Mi.network_pixb net.net_num ~size:A.SMALL ())
 851       end
 852   ) G.networks
 853
 854 (*************************************************************************)
 855 (*                                                                       *)
 856 (*                         servers window                                *)
 857 (*                                                                       *)
 858 (*************************************************************************)
 859
 860 open GMain
 861
 862 let add_server_box (table : GPack.table) =
 863   let hbox_add_s =
 864     GPack.hbox ~homogeneous:false
 865       ~spacing:6 ~border_width:6 ()
 866   in
 867   let pixbuf = A.get_icon ~icon:M.icon_stock_add_server ~size:A.SMALL () in
 868   let _img =
 869     GMisc.image ~pixbuf ~xalign:0.
 870       ~packing:(hbox_add_s#pack ~expand:false ~fill:true) ()
 871   in
 872   let markup = create_bold_markup !M.sT_lb_add_server in
 873   let _label =
 874     GMisc.label ~markup ~xalign:0.
 875       ~packing:(hbox_add_s#pack ~expand:false ~fill:true) ()
 876   in
 877   let markup = create_markup !M.sT_lb_server_ip in
 878   let label_ip_addr = GMisc.label ~markup ~xalign:0. () in
 879   let markup = create_markup !M.sT_lb_server_port in
 880   let label_port = GMisc.label ~markup ~xalign:0. () in
 881   let net_combo = GEdit.combo_box ~model:net_model () in
 882   let entry_ip_addr = GEdit.entry ~width:100 () in
 883   let range = GData.adjustment ~lower:1. ~upper:65535. ~step_incr:1. () in
 884   let entry_port =
 885     GEdit.spin_button ~adjustment:range ~rate:1. ~digits:0
 886       ~numeric:true ~snap_to_ticks:true ~update_policy:`IF_VALID
 887       ~width:60 ~wrap:true ()
 888   in
 889   let wtool = tool_bar `HORIZONTAL ~layout:`END () in
 890   let markup = create_markup !M.sT_lb_server_add in
 891   let bAdd_server = wtool#add_button
 892       ~style:`TEXT
 893       ~markup
 894       ~f:(add_new_server entry_ip_addr entry_port) ()
 895   in
 896   bAdd_server#misc#set_sensitive false;
 897   ignore (entry_ip_addr#connect#changed ~callback:
 898     (fun _ ->
 899        try
 900          let b = (Ip.valid (Ip.of_string entry_ip_addr#text)) in
 901          bAdd_server#misc#set_sensitive b
 902        with _ -> bAdd_server#misc#set_sensitive false
 903   ));
 904   let top = ref 0 in
 905   List.iter (fun data ->
 906     List.iter (fun (w, (left, right, xpadding)) ->
 907       table#attach ~left ~top:!top
 908         ~right ~bottom:(!top + 1)
 909         ~xpadding ~ypadding:0
 910         ~shrink:`X ~fill:`X
 911         w
 912     ) data;
 913     incr top
 914   ) [
 915      [(hbox_add_s#coerce,    (0, 2, 0 ))];
 916      [(net_combo#coerce,     (0, 2, 18))];
 917      [(label_ip_addr#coerce, (0, 1, 18)); (label_port#coerce, (1, 2, 0))];
 918      [(entry_ip_addr#coerce, (0, 1, 18)); (entry_port#coerce, (1, 2, 0))];
 919      [(wtool#coerce,         (0, 2, 0 ))];
 920     ];
 921
 922   renderer_pack_combobox net_combo (net_icon, net_text, net_num) on_net_select;
 923   net_combo#set_active 0
 924
 925
 926 let servers_box gui =
 927   let vpaned_servers =
 928     GPack.paned `VERTICAL ~border_width:6 ()
 929   in
 930   build_net_menu ();
 931   ignore (vpaned_servers#connect#destroy ~callback:
 932     (fun _ ->
 933       view_context := None;
 934       userstore#clear ();
 935       net_store#clear ();
 936       current_net := 0;
 937       user_label := None;
 938       server_label := None;
 939   ));
 940   let vbox_servers =
 941     GPack.vbox ~homogeneous:false
 942       ~packing:vpaned_servers#add1 ()
 943   in
 944   let hbox =
 945     GPack.hbox ~homogeneous:false ~spacing:6
 946       ~packing:vpaned_servers#add2 ()
 947   in
 948   let vbox_users =
 949     GPack.vbox ~homogeneous:false
 950       ~packing:(hbox#pack ~expand:true ~fill:true) ()
 951   in
 952
 953   let servers_evbox =
 954     GBin.event_box ~packing:(vbox_servers#pack ~expand:false ~fill:true) ()
 955   in
 956   servers_evbox#misc#modify_bg [(`NORMAL, (`NAME "#AFAFF4"))];
 957   let servers_label =
 958     GMisc.label ~xalign:0. ~yalign:0.
 959       ~xpad:3 ~ypad:3 ~packing:servers_evbox#add ()
 960   in
 961   let users_evbox =
 962     GBin.event_box ~packing:(vbox_users#pack ~expand:false ~fill:true) ()
 963   in
 964   users_evbox#misc#modify_bg [(`NORMAL, (`NAME "#AFAFF4"))];
 965   let users_label =
 966     GMisc.label ~xalign:0. ~yalign:0.
 967       ~xpad:3 ~ypad:3 ~packing:users_evbox#add ()
 968   in
 969
 970   let serverview =
 971     Servers.treeview ~mode:`MULTIPLE
 972       ~packing:(vbox_servers#pack ~expand:true ~fill:true) ()
 973   in
 974   view_context := Some serverview#view#misc#pango_context;
 975   serverview#set_model serverstore#gmodel;
 976   serverview#set_menu server_menu;
 977   serverview#set_on_select on_select_server;
 978   let userview =
 979     ServerUsers.treeview ~mode:`MULTIPLE
 980       ~packing:(vbox_users#pack ~expand:true ~fill:true) ()
 981   in
 982   userview#set_model userstore#gmodel;
 983   userview#set_menu GuiUsers.user_menu;
 984
 985   let vbox_cmd =
 986     GPack.vbox ~homogeneous:false ~spacing:12
 987       ~packing:(hbox#pack ~expand:false ~fill:true) ()
 988   in
 989   let hbox_tb =
 990     GPack.hbox ~homogeneous:false ~spacing:6 ~border_width:6
 991       ~packing:(vbox_cmd#pack ~expand:false ~fill:true) ()
 992   in
 993   let t_button =
 994     GButton.toggle_button
 995       ~packing:(hbox_tb#pack ~expand:false ~fill:false) ()
 996   in
 997   t_button#set_active (not !filter_disconnected_servers);
 998   let box =
 999     GPack.hbox ~homogeneous:false ~spacing:6
1000       ~packing:t_button#add ()
1001   in
1002   let pixbuf =
1003     A.get_icon ~size:A.MEDIUM
1004       ~icon:(M.icon_stock_all_servers) ()
1005   in
1006   let _img =
1007     GMisc.image ~pixbuf ~xalign:0.
1008       ~packing:(box#pack ~expand:false ~fill:true) ()
1009   in
1010   let markup = create_markup !M.sT_lb_display_all_servers in
1011   let _label =
1012     GMisc.label ~markup ~xalign:0. ~use_underline:true
1013       ~mnemonic_widget:t_button#coerce
1014       ~packing:(box#pack ~expand:false ~fill:true) ()
1015   in
1016   let frame =
1017     GBin.frame ~border_width:6 ~shadow_type:`ETCHED_IN
1018     ~packing:(vbox_cmd#pack ~expand:false ~fill:true) ()
1019   in
1020   let table_server =
1021     GPack.table ~columns:2 ~homogeneous:false
1022        ~row_spacings:6 ~col_spacings:2
1023        ~border_width:6 ~packing:frame#add ()
1024   in
1025   add_server_box table_server;
1026
1027   ignore (t_button#connect#toggled ~callback:
1028     (fun _ ->
1029        filter_disconnected_servers := not t_button#active;
1030        serverstore#refresh_filter ()
1031   ));
1032
1033   GuiTools.set_vpaned vpaned_servers O.servers_vpane_up;
1034   GuiTools.get_vpaned vpaned_servers O.servers_vpane_up;
1035
1036   servers_label#set_use_markup true;
1037   users_label#set_use_markup true;
1038   server_label := Some servers_label;
1039   user_label := Some users_label;
1040   update_servers_labels ();
1041   update_users_label ();
1042
1043   vpaned_servers#coerce