Initial revision

[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-0.1.0 / applications / radtest / tiWindow.ml

diff --git a/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/radtest/tiWindow.ml b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/radtest/tiWindow.ml
new file mode 100644 (file)
index 0000000..b44b4d4
--- /dev/null
+++ b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/radtest/tiWindow.ml
@@ -0,0 +1,117 @@
+
+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
+
+
+