--- /dev/null
+
+open Utils
+open Property
+
+open TiBase
+open TiContainer
+
+
+class tiwindow ~widget ~name ~parent_tree ~pos ?(insert_evbox=true)
+ parent_window =
+object(self)
+ val window = widget
+ inherit ticontainer ~name ~widget
+ ~insert_evbox:false ~parent_tree ~pos parent_window as container
+
+ method connect_event = window#event#connect
+
+ method private class_name = "GWindow.window"
+
+ method private get_mandatory_props = [ "title" ]
+
+(* method private save_clean_proplist =
+ List.remove_assoc "title" container#save_clean_proplist
+
+ method private emit_clean_proplist plist =
+ List.remove_assoc "title" (container#emit_clean_proplist plist)
+*)
+ method remove_me () =
+ let sref = ref "" in
+ self#save_to_string sref;
+ let lexbuf = Lexing.from_string !sref in
+ let node = Load_parser.window Load_lexer.token lexbuf in
+ add_undo (Add_window node);
+ self#remove_me_without_undo ()
+
+ method copy () = self#copy_to_sel window_selection
+
+ method remove_me_without_undo () =
+ self#forall ~callback:(fun tiw -> tiw#remove_me_without_undo ());
+ parent_window#remove_sel (self : #tiwidget0 :> tiwidget0);
+ name_list := list_remove !name_list ~f:(fun n -> n=name);
+ Hashtbl.remove widget_map name;
+ Propwin.remove name;
+ widget#destroy ()
+
+ method private get_packing packing = ""
+
+ method emit_code f param_list =
+ let param_string =
+ match param_list with
+ | [] -> ""
+ | _ -> "['" ^
+ (String.concat ~sep:", '"
+ (List.map ~f:(fun c -> (String.make 1 c)) param_list)) ^
+ "] " in
+ Format.fprintf f "(* Code for %s *)@\n@\n@[<hv 2>class %s%s () ="
+ name param_string name;
+ self#emit_init_code f ~packing:"";
+ Format.fprintf f "@]@\n@[<hv 2>object (self)";
+ self#emit_method_code f;
+ Format.fprintf f "@ method show () = %s#show ()" name;
+ Format.fprintf f "@ @[<v 2>initializer";
+ self#emit_initializer_code f;
+ Format.fprintf f "@ ()@]@]@ end@\n@\n"
+
+(* method private save_start formatter =
+ Format.fprintf formatter "@[<0>@\n@[<2><window name=%s>" name;
+ Format.fprintf formatter "@\ntitle=\"%s\""
+ (List.assoc "title" proplist)#get
+*)
+ method private save_end formatter =
+ Format.fprintf formatter "@]@\n</window>@\n@]"
+
+ method private menu ~time =
+ let menu = GMenu.menu () and menu_add = GMenu.menu () in
+ List.iter
+ ~f:(fun n ->
+ let mi = GMenu.menu_item ~packing:menu_add#append ~label:n ()
+ in mi#connect#activate
+ ~callback:(fun () -> self#add_child n (); ()); ())
+ widget_add_list;
+ let mi_add = GMenu.menu_item ~packing:menu#append ~label:("add to "^ name) ()
+ and mi_paste = GMenu.menu_item ~packing:menu#append ~label:"Paste" ()
+ in
+ mi_add#set_submenu menu_add;
+ if !selection <> ""
+ then begin mi_paste#connect#activate ~callback:self#paste; () end
+ else mi_paste#misc#set_sensitive false;
+ menu#popup ~button:3 ~time
+
+
+ initializer
+ classe <- "window";
+ window#set_title name;
+ proplist <- proplist @
+ [ "title",
+ new prop_string ~name:"title" ~init:name ~set:(ftrue window#set_title);
+ "allow_shrink", new prop_bool ~name:"allow_shrink" ~init:"false"
+ ~set:(ftrue window#set_allow_shrink);
+ "allow_grow", new prop_bool ~name:"allow_grow" ~init:"true"
+ ~set:(ftrue window#set_allow_grow);
+ "auto_shrink", new prop_bool ~name:"auto_shrink" ~init:"false"
+ ~set:(ftrue window#set_auto_shrink);
+ "x position", new prop_int ~name:"x" ~init:"-2"
+ ~set:(fun x -> window#misc#set_geometry ~x (); true);
+ "y position", new prop_int ~name:"y" ~init:"-2"
+ ~set:(fun y -> window#misc#set_geometry ~y (); true) ]
+end
+
+let new_tiwindow ~name ?(listprop = []) =
+ let w = GWindow.window ~show:true () in
+ w#misc#set_can_focus false;
+ w#misc#set_can_default false;
+ new tiwindow ~widget:w ~name
+
+
+