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

   1 (* $Id$ *)
   2
   3 open Gaux
   4 open Gtk
   5 open GObj
   6 open GContainer
   7
   8 open Utils
   9 open Common
  10 open Property
  11
  12 (* possible children; used to make the menus *)
  13 let widget_add_list =
  14   [ "vbox"; "hbox"; "vbutton_box"; "hbutton_box"; "fixed";
  15     "frame"; "aspect_frame"; "handle_box"; "event_box";
  16     "hseparator"; "vseparator"; "statusbar"; "label"; "notebook";
  17     "color_selection";
  18     "button";
  19     "toggle_button"; "check_button"; "radio_button"; "scrolled_window";
  20
  21     "entry"; "spin_button"; "combo"; "clist"; "toolbar"]
  22
  23
  24 (*********** selection ***********)
  25
  26 let selection = ref ""
  27 let window_selection = ref ""
  28
  29
  30 (**************** signals class ***************)
  31
  32 class tiwidget_signals ~signals =
  33   let name_changed : string signal = signals in
  34   object
  35     val after = false
  36     method after = {< after = true >}
  37     method name_changed = name_changed#connect ~after
  38   end
  39
  40
  41 (************* class type ***************)
  42 (* the ti<gtkwidget> classes encapsulate the corresponding gtk
  43    widget which will be in the gtk-window and a tree item
  44    labelled with the name of the widget which will be in the
  45    tree-window.
  46    all these classes have the same following interface *)
  47
  48 class virtual tiwidget0 = object
  49   method virtual widget : GObj.widget
  50   method virtual connect_event : GObj.event_signals
  51   method virtual parent : tiwidget0 option
  52   method virtual set_parent : tiwidget0 -> unit
  53   method virtual base : GObj.widget
  54   method virtual tree_item : GTree2.tree_item
  55   method virtual tree : GTree2.tree
  56   method virtual children : (tiwidget0 * Gtk.Tags.pack_type) list
  57   method virtual name : string
  58   method virtual proplist : (string * prop) list
  59   method virtual add_to_proplist : (string * prop) list -> unit
  60   method virtual change_name_in_proplist : string -> string -> unit
  61   method virtual set_property : string -> string -> unit
  62   method virtual forall :  callback:(tiwidget0 -> unit) -> unit
  63   method virtual remove : tiwidget0 -> unit
  64 (*  method virtual add_child_with_name : string -> string -> pos:int -> tiwidget0 *)
  65   method virtual add_children : ?pos:int -> yywidget_tree -> unit
  66   method virtual add_children_wo_undo : ?pos:int -> yywidget_tree -> string
  67   method virtual remove_me  : unit -> unit
  68   method virtual remove_me_without_undo  : unit -> unit
  69   method virtual emit_code : Format.formatter -> char list -> unit
  70   method virtual emit_init_code : Format.formatter -> packing:string -> unit
  71   method virtual emit_method_code : Format.formatter -> unit
  72   method virtual emit_initializer_code : Format.formatter -> unit
  73   method virtual save : Format.formatter -> unit
  74   method virtual copy : unit -> unit
  75   method virtual connect : tiwidget_signals
  76   method virtual disconnect : GtkSignal.id -> bool
  77   method virtual child_up : tiwidget0 -> unit
  78   method virtual up : unit -> unit
  79   method virtual child_down : tiwidget0 -> unit
  80   method virtual down : unit -> unit
  81   method virtual next : tiwidget0
  82   method virtual next_child : tiwidget0 -> tiwidget0
  83   method virtual last : tiwidget0
  84   method virtual prev : tiwidget0
  85   method virtual set_full_menu : bool -> unit
  86 end
  87
  88 class virtual window_and_tree0 = object
  89   method virtual tiwin : tiwidget0
  90 (*  method virtual tree_window : window *)
  91   method virtual change_selected : tiwidget0 -> unit
  92   method virtual remove_sel : tiwidget0 -> unit
  93   method virtual add_param : char
  94   method virtual remove_param : char -> unit
  95 (*  method virtual emit : unit -> unit *)
  96 end
  97
  98 (* forward declaration of function new_widget *)
  99 let new_tiwidget :
 100     (classe:string -> ?pos:int -> name:string ->parent_tree:GTree2.tree ->
 101       ?insert_evbox:bool -> ?listprop:(string * string) list -> window_and_tree0 -> tiwidget0) ref =
 102   ref (fun ~classe ?pos ~name ~parent_tree ?insert_evbox ?listprop w -> failwith "new_tiwidget")
 103
 104
 105 let widget_map = Hashtbl.create 17
 106
 107 (* list of names of radio_buttons (for groups) *)
 108 let radio_button_pool = ref []
 109
 110
 111 (************* window creation class *************)
 112 (* an instance of this class is created for each window opened
 113    in radtest. It contains the tree window and the gtk window (tiwin) *)
 114
 115 class window_and_tree ~name =
 116   let tree_window = GWindow.window ~show:true ~title:(name ^ "-Tree") () in
 117   let vbox = GPack.vbox ~spacing:2 ~packing:tree_window#add () in
 118   let root_tree = GTree2.tree ~packing:vbox#pack ~selection_mode:`EXTENDED () in
 119   let project_tree_item = GTree2.tree_item () in
 120   let label = GMisc.label ~text:name ~xalign:0. ~yalign:0.5
 121       ~packing:project_tree_item#add () in
 122
 123   object(self)
 124
 125     inherit window_and_tree0
 126
 127 (* the params of the window class; because the class clist needs a param
 128    I suppose there will be no more than 26 clists in a single window    *)
 129     val param_list = Array.create 26 false
 130
 131     method add_param =
 132       let i = ref 0 in
 133       while param_list.(!i) do incr i done;
 134       param_list.(!i) <- true;
 135       char_of_int (97 + !i)
 136
 137     method remove_param c =
 138       param_list.(int_of_char c - 97) <- false
 139
 140     method private param_list =
 141       let r = ref [] in
 142       for i = 25 downto 0 do
 143         if Array.unsafe_get param_list i then r := (char_of_int (i+97)) :: !r
 144       done;
 145       !r
 146
 147 (* I use magic here because the real initialization is done
 148    below in the initializer part. It can't be done here because
 149    of the call to self *)
 150     val mutable tiwin = (Obj.magic 0 : tiwidget0)
 151
 152     method tiwin = tiwin
 153     method tree_window = tree_window
 154
 155     method project_tree_item = project_tree_item
 156
 157 (* the selected item in this window *)
 158     val mutable selected = (None : tiwidget0 option)
 159
 160 (* what to do when a new item is selected.
 161    this method is passed to all the tiwidgets (by the select_fun
 162    parameter) and they will call it when they are clicked on;
 163    she is also called when changing the selection the arrow keys
 164    (see in the initializer part) *)
 165     method change_selected sel =
 166       match selected with
 167       | None ->
 168           selected <- Some sel;
 169           sel#tree_item#misc#set_state `SELECTED;
 170           sel#base#misc#set_state `SELECTED;
 171           Propwin.show sel
 172       | Some old_sel ->
 173           if sel = old_sel then begin
 174             selected <- None;
 175             sel#base#misc#set_state `NORMAL;
 176             sel#tree_item#misc#set_state `NORMAL
 177           end else begin
 178             old_sel#tree_item#misc#set_state `NORMAL;
 179             old_sel#base#misc#set_state `NORMAL;
 180             selected <- Some sel;
 181             sel#tree_item#misc#set_state `SELECTED;
 182             sel#base#misc#set_state `SELECTED;
 183             Propwin.show sel
 184           end
 185
 186 (* the tiwidget tiw is being removed; if it was selected,
 187    put the selection to None *)
 188     method remove_sel tiw =
 189       match selected with
 190       | Some sel when sel = tiw -> selected <- None
 191       | _ -> ()
 192
 193 (* emits the code corresponding to this window *)
 194     method emit c = tiwin#emit_code c self#param_list;
 195
 196     method delete () =
 197       tiwin#remove_me_without_undo ();
 198       tree_window#destroy ();
 199
 200     initializer
 201       tiwin <- !new_tiwidget ~classe:"window" ~name ~parent_tree:root_tree
 202           (self : #window_and_tree0 :> window_and_tree0);
 203
 204       tiwin#connect#name_changed ~callback:
 205           (fun n -> label#set_text n; tree_window#set_title (n ^ "-Tree"));
 206
 207       Propwin.show tiwin;
 208
 209       tree_window#event#connect#key_press ~callback:
 210         begin fun ev ->
 211           let state = GdkEvent.Key.state ev in
 212           let keyval = GdkEvent.Key.keyval ev in
 213           if keyval = GdkKeysyms._Up then begin
 214             match selected with
 215             | None -> ()
 216             | Some t ->
 217                 if List.mem `CONTROL state then t#up ()
 218                 else try
 219                   self#change_selected t#prev
 220                 with Not_found -> ()
 221           end
 222           else if keyval = GdkKeysyms._Down then begin
 223             match selected with
 224             | None -> ()
 225             | Some t ->
 226                 if List.mem `CONTROL state then t#down ()
 227                 else try
 228                   self#change_selected t#next
 229                 with Not_found -> ()
 230           end;
 231           GtkSignal.stop_emit ();
 232           true
 233         end;
 234       ()
 235   end
 236
 237
 238
 239 (***************** class implementation *****************)
 240 (* this is the base class of the ti<gtkwidget> hierarchy.
 241    all these classes will inherit from tiwidget, but without
 242    adding new methods. In this way all the classes have the
 243    same interface and we can use them in lists, pass them to
 244    functions without caring on the type.
 245    All methods needed by any of the classes are defined in
 246    tiwidget but if a method is not pertinent in tiwidget
 247    it has for implementation:
 248       failwith "<name of the method>"
 249    the real implementation of the method is done in the
 250    class (or classes) in which it is needed (or sometimes
 251    in tiwidget anyway).
 252    Additionally, to workaround some problem with recursive types
 253    the type of the (public) methods of tiwidget is defined in
 254    tiwidget0 of which tiwidget inherits.
 255    The parent_tree parameter is the tree in which the
 256    tiwidget#tree_item will be inserted at position :pos.
 257 *)
 258
 259 class virtual tiwidget ~name ~parent_tree:(parent_tree : GTree2.tree) ~pos
 260     ~widget ?(insert_evbox=true) (parent_window : window_and_tree0) =
 261 object(self)
 262
 263   inherit tiwidget0
 264   inherit has_ml_signals
 265
 266   val evbox =
 267     if insert_evbox then
 268       let ev = GBin.event_box () in ev#add widget#coerce; Some ev
 269     else None
 270
 271 (* used only for windows delete_event *)
 272   method connect_event = failwith "tiwidget::connect_event"
 273
 274   val widget = widget#coerce
 275   method widget = widget
 276
 277   val mutable parent = None
 278   method set_parent p = parent <- Some p
 279   method parent =  parent
 280   method private sure_parent =
 281     match parent with
 282     | None -> failwith "sure_parent"
 283     | Some p -> p
 284
 285   method base =
 286     match evbox with
 287     | None -> widget#coerce
 288     | Some ev -> ev#coerce
 289
 290 (* this is the name used in new_tiwidget for the creation
 291    of an object of this class *)
 292   val mutable classe = ""
 293
 294   val tree_item = GTree2.tree_item ()
 295   method tree_item = tree_item
 296
 297   val mutable stree = GTree2.tree ()
 298   method tree = stree
 299
 300   val label = GMisc.label ~text:name ~xalign:0. ~yalign:0.5 ()
 301
 302   val mutable name : string = name
 303   method name = name
 304
 305 (* this is the complete name for the creation of the widget
 306    in lablgtk e.g. GPack.vbox; used in emit_init_code *)
 307   method private class_name = ""
 308
 309   val mutable proplist : (string * prop) list = []
 310   method proplist = proplist
 311   method private get_mandatory_props = []
 312
 313   method add_to_proplist plist = proplist <- proplist @ plist
 314
 315 (* for children of a box *)
 316   method change_name_in_proplist : string -> string -> unit =
 317     fun _ _ -> ()
 318   method set_property name value_string = try
 319     (List.assoc name proplist)#set value_string
 320   with Not_found -> Printf.printf "Property not_found %s, %s\n" name value_string;
 321     flush stdout
 322
 323   method private get_property name =
 324     (List.assoc name proplist)#get
 325
 326
 327 (* the proplist with some items removed e.g. the expand... in a box
 328    used for saving and emitting code *)
 329   method private emit_clean_proplist =
 330     List.fold_left ~f:(fun l p -> List.remove_assoc p l)
 331       ~init:proplist
 332       ([ "name"; "expand"; "fill"; "padding" ] @ self#get_mandatory_props)
 333 (*  method private emit_clean_proplist plist =
 334     List.fold_left ~init:plist ~f:
 335       (fun pl propname -> List.remove_assoc propname pl)
 336         [ "name"; "expand"; "fill"; "padding" ]
 337 *)
 338
 339   method private save_clean_proplist =
 340     List.fold_left ~f:(fun l p -> List.remove_assoc p l)
 341       ~init:proplist ("name" :: self#get_mandatory_props)
 342 (*  method private save_clean_proplist =
 343     List.remove_assoc "name" proplist *)
 344
 345   val mutable children : (tiwidget0 * Gtk.Tags.pack_type) list = []
 346   method children = children
 347   method forall =
 348     fun ~callback -> List.iter (List.map children ~f:fst) ~f:callback
 349
 350 (* encapsulate container#add and container#remove
 351    they are here because they depend on the type of the widget:
 352    e.g.: gtkbin->add scrolled_window->add_with_viewport box->pack *)
 353   method private add = failwith (name ^ "::add")
 354   method remove = failwith (name ^ "::remove")
 355
 356
 357 (* removes self from his parent;
 358    will be different for a window *)
 359   method remove_me () =
 360     let sref = ref "" in
 361     self#save_to_string sref;
 362     let pos = list_pos ~item:(self : #tiwidget0 :> tiwidget0)
 363         (List.map self#sure_parent#children ~f:fst) in
 364     let lexbuf = Lexing.from_string !sref in
 365     let node = Load_parser.widget Load_lexer.token lexbuf in
 366     add_undo (Add (self#sure_parent#name, node, pos));
 367     self#remove_me_without_undo ()
 368
 369   method remove_me_without_undo () =
 370 (* it should be enough to only recursively remove the children from the
 371    name_list and do the tip#remove and tip#tree#remove
 372    only for self *)
 373     self#forall ~callback:(fun tiw -> tiw#remove_me_without_undo ());
 374     parent_window#remove_sel (self : #tiwidget0 :> tiwidget0);
 375     match parent with
 376     | None -> failwith "remove without parent"
 377     | Some (tip : #tiwidget0) ->
 378         tip#tree#remove tree_item;
 379         tip#remove (self : #tiwidget0 :> tiwidget0);
 380         name_list := list_remove !name_list ~f:(fun n -> n=name);
 381         Hashtbl.remove widget_map name;
 382         Propwin.remove name
 383
 384 (* used for undo *)
 385   method private remove_child_by_name name () =
 386     let child = fst (List.find children
 387         ~f:(fun (ch, _) -> ch#name = name)) in
 388     child#remove_me ()
 389
 390 (* for most widgets we make a child with new_tiwidget and then add it
 391    to self; for toolbars we use toolbar#insert_button...     *)
 392       method private make_child = !new_tiwidget
 393
 394 (* adds a child and shows his properties;
 395    used when adding a child by the menu or DnD *)
 396   method private add_child classe ?name ?(undo = true) ?(affich = true) ?(pos = -1) ?(listprop = []) () =
 397     let name = match name with
 398     | None -> make_new_name classe
 399     | Some n -> n in
 400     let child = self#make_child ~classe ~name ~parent_tree:stree parent_window ~pos ~listprop in
 401     child#set_parent (self : #tiwidget0 :> tiwidget0);
 402     self#add child ~pos;
 403     if affich then Propwin.show child;
 404     if undo then add_undo (Remove name);
 405     child
 406
 407
 408 (* adds the subtree saved in the Node *)
 409   method add_children ?(pos = -1) node =
 410     let child_name = self#add_children_wo_undo node ~pos in
 411     add_undo (Remove child_name)
 412
 413   method add_children_wo_undo ?(pos = -1) (Node (child, children)) =
 414     let classe, name, property_list = child in
 415     let rname = change_name name in
 416     let tc = self#add_child classe ~name:rname ~undo:false ~affich:false ~pos ~listprop:property_list () in
 417     List.iter (List.rev children)
 418       ~f:(fun c -> tc#add_children_wo_undo c; ());
 419     List.iter property_list ~f:(fun (n,v) -> tc#set_property n v);
 420     rname
 421
 422 (* only a tiwindow can emit code *)
 423   method emit_code = failwith "emit_code"
 424
 425 (* some methods for emitting code *)
 426 (* this one calculates the expand, fill and padding parameters
 427    of a box child *)
 428   method private get_packing packing =
 429     let aux name =
 430       let prop  = List.assoc name proplist in
 431       if prop#modified then " ~" ^ name ^ ":" ^ prop#code else ""
 432     in
 433     let efp = try
 434       (aux "expand") ^ (aux "fill") ^ (aux "padding")
 435     with Not_found -> "" in
 436     if efp = "" then ("~packing:" ^ packing)
 437     else ("~packing:(" ^ packing ^ efp ^ ")")
 438
 439 (* this one emits the declaration code of the widget *)
 440   method emit_init_code formatter ~packing =
 441     Format.fprintf formatter "@ @[<hv 2>let %s =@ @[<hov 2>%s"
 442       name self#class_name;
 443     List.iter self#get_mandatory_props
 444       ~f:begin fun name ->
 445         Format.fprintf formatter "@ ~%s:%s" name
 446           (List.assoc name proplist)#code
 447       end;
 448     let packing = self#get_packing packing in
 449     if packing <> "" then Format.fprintf formatter "@ %s" packing;
 450     self#emit_prop_code formatter;
 451     Format.fprintf formatter "@ ()@ in@]@]"
 452
 453 (* this one emits the properties which do not have their
 454    default value; used by emit_init_code *)
 455   method private emit_prop_code formatter =
 456     let mandatory = self#get_mandatory_props in
 457     List.iter self#emit_clean_proplist ~f:
 458       begin  fun (name, prop) ->
 459         if List.mem name mandatory then () else
 460         if prop#modified then
 461           Format.fprintf formatter "@ ~%s:%s" prop#name prop#code
 462       end
 463
 464 (* this one emits the method returning this widget *)
 465   method emit_method_code formatter =
 466     Format.fprintf formatter "@ method %s = %s" name name;
 467
 468 (* emits the code in the initializer part for this widget *)
 469   method emit_initializer_code _ = ()
 470
 471 (* for saving the project to a file. Used also by copy and cut *)
 472   method private save_start formatter =
 473     Format.fprintf formatter "@\n@[<2><%s name=%s>" classe name;
 474     List.iter
 475       ~f:(fun p -> Format.fprintf formatter
 476           "@\n%s=\"%s\"" p (List.assoc p proplist)#get)
 477       self#get_mandatory_props
 478
 479
 480   method private save_end formatter =
 481     Format.fprintf formatter "@]@\n</%s>" classe
 482
 483   method save formatter =
 484     self#save_start formatter;
 485     List.iter self#save_clean_proplist ~f:
 486       (fun (name, prop) ->
 487         if prop#modified then
 488           Format.fprintf formatter "@\n%s=%s" name prop#save_code);
 489     self#forall ~callback:(fun w -> w#save formatter);
 490     self#save_end formatter
 491
 492
 493   method private save_to_string string_ref =
 494     let b = Buffer.create 80 in
 495     let f = Format.formatter_of_buffer b in
 496     self#save f;
 497     Format.pp_print_flush f ();
 498     string_ref := Buffer.contents b
 499
 500   method private copy_to_sel selection = self#save_to_string selection
 501
 502   method copy () = self#copy_to_sel selection
 503
 504   method private cut () =
 505     self#copy ();
 506     self#remove_me ()
 507
 508   method private paste () =
 509     let lexbuf = Lexing.from_string !selection in
 510     let node = Load_parser.widget Load_lexer.token lexbuf in
 511     self#add_children node
 512
 513
 514 (* ML signal used when the name of the widget is changed *)
 515   val name_changed : string signal = new signal
 516   method connect = new tiwidget_signals ~signals:name_changed
 517   method private call_name_changed = name_changed#call
 518
 519
 520 (* this is necessary because gtk_tree#remove deletes the tree
 521    when removing the last item  *)
 522 (* suppressed this in gtktree2
 523   method new_tree () =
 524     stree <- GTree2.tree;
 525     tree_item#set_subtree stree;
 526     tree_item#expand ()
 527 *)
 528
 529 (* when full_menu is true we use the menu else the restricted menu *)
 530   val mutable full_menu  = true
 531   method set_full_menu b = full_menu <- b
 532
 533 (* the menu for this widget
 534    This menu is recalculated when one clicks on the 3rd button.
 535    There is nothing to do e.g. when the name of the widget changes,
 536    it will change in the menu the next time. *)
 537   method private menu ~time = self#restricted_menu ~time
 538
 539 (* the restricted menu for this widget
 540    used for containers when they are full *)
 541   method private restricted_menu ~time =
 542     let menu = GMenu.menu () in
 543     let mi_remove = GMenu.menu_item ~packing:menu#append        ~label:"remove" ()
 544     and mi_cut  = GMenu.menu_item ~packing:menu#append ~label:"Cut" ()
 545     and mi_copy = GMenu.menu_item ~packing:menu#append ~label:"Copy" () in
 546     mi_remove#connect#activate ~callback:self#remove_me;
 547     mi_copy#connect#activate ~callback:self#copy;
 548     mi_cut#connect#activate ~callback:self#cut;
 549     menu#popup ~button:3 ~time
 550
 551 (* changes all that depends on the name *)
 552   method private set_new_name new_name =
 553     if test_unique new_name then begin
 554       Hashtbl.remove widget_map name;
 555       Hashtbl.add widget_map ~key:new_name
 556         ~data:(self : #tiwidget0 :> tiwidget0);
 557       if (classe = "radio_button") then begin
 558         radio_button_pool := new_name ::
 559           (list_remove !radio_button_pool ~f:(fun x -> x = name));
 560         List.iter
 561           ~f:(fun x -> Propwin.update (Hashtbl.find widget_map x) false)
 562           !radio_button_pool
 563       end;
 564       label#set_text new_name;
 565       let old_name = name in
 566       name <- new_name;
 567 (*      Propwin.change_name old_name new_name; *)
 568       name_list :=
 569         new_name :: (list_remove !name_list ~f:(fun n -> n=old_name));
 570       begin match self#parent with
 571       | None -> ()
 572       | Some p -> p#change_name_in_proplist old_name new_name
 573       end;
 574       self#call_name_changed new_name;
 575       true
 576     end
 577     else begin
 578       message_name ();
 579       Propwin.update self true;
 580       false
 581     end
 582
 583
 584 (* moves the present tiw up in his parents' children list *)
 585 (* does something only when the parent is a box *)
 586   method child_up = fun _ -> ()
 587
 588   method up () = match parent with
 589   | None -> ()
 590   | Some t -> t#child_up (self : #tiwidget0 :> tiwidget0)
 591
 592   method child_down = fun _ -> ()
 593
 594   method down () = match parent with
 595   | None -> ()
 596   | Some t -> t#child_down (self : #tiwidget0 :> tiwidget0)
 597
 598
 599 (* get the next tiwidget in the tree (used with Down arrow) *)
 600   method next =
 601     if children <> [] then fst (List.hd children)
 602     else begin
 603       match parent with
 604       | None -> raise Not_found
 605       | Some p -> p#next_child (self : #tiwidget0 :> tiwidget0)
 606     end
 607
 608   method next_child child =
 609     let _, tl = cut_list ~item:child (List.map ~f:fst children) in
 610     match tl with
 611     | ch :: next :: _ -> next
 612     | ch :: [] -> begin
 613         match parent with
 614         | None -> raise Not_found
 615         | Some p -> p#next_child (self : #tiwidget0 :> tiwidget0)
 616     end
 617     | _ -> failwith "next_child"
 618
 619 (* get the last child of the last child ... of our last child.
 620    Used by prev. *)
 621   method last =
 622     if children = [] then (self : #tiwidget0 :> tiwidget0)
 623     else (fst (List.hd (List.rev children)))#last
 624
 625 (* get the previous tiwidget in the tree (used with Up arrow) *)
 626   method prev =
 627     match parent with
 628     | None -> raise Not_found
 629     | Some p ->
 630         let hd, _ = cut_list ~item:(self : #tiwidget0 :> tiwidget0)
 631             (List.map ~f:fst p#children) in
 632         match hd with
 633         | [] -> p
 634         | h :: _ -> h#last
 635
 636   initializer
 637     Hashtbl.add widget_map ~key:name ~data:(self : #tiwidget0 :> tiwidget0);
 638     name_list := name :: !name_list;
 639     parent_tree#insert tree_item ~pos;
 640     tree_item#set_subtree stree;
 641     tree_item#add label#coerce;
 642     tree_item#expand ();
 643
 644     proplist <-  proplist @
 645       [ "name",
 646         new prop_string ~name:"name" ~init:name ~set:self#set_new_name;
 647         "width", new prop_int ~name:"width" ~init:"-2"
 648           ~set:(fun v -> widget#misc#set_geometry ~width:v (); true);
 649         "height", new prop_int ~name:"height" ~init:"-2"
 650           ~set:(fun v -> widget#misc#set_geometry ~height:v (); true) ];
 651
 652     self#add_signal name_changed;
 653
 654     tree_item#event#connect#button_press ~callback:
 655       (fun ev -> match GdkEvent.get_type ev with
 656       | `BUTTON_PRESS ->
 657           if GdkEvent.Button.button ev = 1 then begin
 658             parent_window#change_selected
 659               (self : #tiwidget0 :> tiwidget0);
 660           end
 661           else if GdkEvent.Button.button ev = 3 then begin
 662             if full_menu
 663             then self#menu ~time:(GdkEvent.Button.time ev)
 664             else self#restricted_menu ~time:(GdkEvent.Button.time ev);
 665           end;
 666           GtkSignal.stop_emit ();
 667           true
 668       | _ -> false);
 669     ()
 670 end
 671