helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/radtest/tiContainer.ml

   1
   2 open Gtk
   3 open GObj
   4 open GContainer
   5
   6 open Utils
   7 open Property
   8
   9 open TiBase
  10
  11 (* for containers being able to have at least one child;
  12    not for buttons (can't have children) *)
  13
  14 class virtual ticontainer ~widget ~name
  15     ?(insert_evbox=true) ~parent_tree ~pos parent_window =
  16 object(self)
  17
  18   val container = (widget : #container :> container)
  19
  20   inherit tiwidget ~name ~widget ~insert_evbox
  21       ~parent_tree ~pos parent_window as widget
  22
  23 (* name of the add method: add for most bin widgets,
  24    pack for boxes, add_with_viewport for scrolled windows... *)
  25   method private name_of_add_method = "#add"
  26
  27   method private add child ~pos =
  28     container#add child#base;
  29     children <- [child, `START];
  30     self#set_full_menu false;
  31     tree_item#drag#dest_unset ()
  32
  33   method remove child =
  34     container#remove child#base;
  35     children <- [];
  36     self#set_full_menu true;
  37     tree_item#drag#dest_set ~actions:[`COPY]
  38       [ { target = "STRING"; flags = []; info = 0} ]
  39
  40   method private menu ~time =
  41     let menu = GMenu.menu () and menu_add = GMenu.menu () in
  42     List.iter
  43       ~f:(fun n ->
  44         let mi = GMenu.menu_item ~packing:menu_add#append ~label:n ()
  45         in mi#connect#activate
  46           ~callback:(fun () -> self#add_child n ();()); ())
  47       widget_add_list;
  48     let mi_add = GMenu.menu_item ~packing:menu#append
  49         ~label:("add to " ^ name) ()
  50     and mi_remove = GMenu.menu_item ~packing:menu#append
  51         ~label:("remove " ^ name) ()
  52     and mi_cut  = GMenu.menu_item ~packing:menu#append ~label:"Cut" ()
  53     and mi_copy = GMenu.menu_item ~packing:menu#append ~label:"Copy" ()
  54     and mi_paste = GMenu.menu_item ~packing:menu#append ~label:"Paste" () in
  55     mi_remove#connect#activate ~callback:self#remove_me;
  56     mi_add#set_submenu menu_add;
  57     mi_copy#connect#activate ~callback:self#copy;
  58     mi_cut#connect#activate ~callback:self#cut;
  59     if !selection <> ""
  60     then begin mi_paste#connect#activate ~callback:self#paste; () end
  61     else mi_paste#misc#set_sensitive false;
  62     menu#popup ~button:3 ~time
  63
  64   method emit_init_code c ~packing =
  65     widget#emit_init_code c ~packing;
  66     self#forall ~callback:(fun child -> child#emit_init_code c
  67         ~packing:(name ^ self#name_of_add_method))
  68
  69   method emit_method_code c =
  70     widget#emit_method_code c;
  71     self#forall ~callback:(fun child -> child#emit_method_code c)
  72
  73   method emit_initializer_code c =
  74     widget#emit_initializer_code c;
  75     self#forall ~callback:(fun child -> child#emit_initializer_code c)
  76
  77
  78   initializer
  79     proplist <-  proplist @
  80       [ "border_width", new prop_int ~name:"border_width" ~init:"0"
  81                           ~set:(ftrue container#set_border_width) ];
  82
  83     tree_item#drag#dest_set ~actions:[`COPY]
  84       [ { target = "STRING"; flags = []; info = 0} ];
  85     tree_item#drag#connect#data_received ~callback:
  86       begin fun (context : drag_context) ~x ~y
  87           (data : selection_data) ~info ~time ->
  88             self#add_child data#data ();
  89             context#finish ~success:true ~del:false ~time
  90       end;()
  91 end
  92