helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/applications/radtest/tiWindow.ml

   1
   2 open Utils
   3 open Property
   4
   5 open TiBase
   6 open TiContainer
   7
   8
   9 class tiwindow ~widget ~name ~parent_tree ~pos ?(insert_evbox=true)
  10     parent_window =
  11 object(self)
  12   val window = widget
  13   inherit ticontainer ~name ~widget
  14       ~insert_evbox:false ~parent_tree ~pos parent_window as container
  15
  16   method connect_event = window#event#connect
  17
  18   method private class_name = "GWindow.window"
  19
  20   method private get_mandatory_props = [ "title" ]
  21
  22 (*  method private save_clean_proplist =
  23     List.remove_assoc "title" container#save_clean_proplist
  24
  25   method private emit_clean_proplist plist =
  26     List.remove_assoc "title" (container#emit_clean_proplist plist)
  27 *)
  28   method remove_me () =
  29     let sref = ref "" in
  30     self#save_to_string sref;
  31     let lexbuf = Lexing.from_string !sref in
  32     let node = Load_parser.window Load_lexer.token lexbuf in
  33     add_undo (Add_window node);
  34     self#remove_me_without_undo ()
  35
  36   method copy () = self#copy_to_sel window_selection
  37
  38   method remove_me_without_undo () =
  39     self#forall ~callback:(fun tiw -> tiw#remove_me_without_undo ());
  40     parent_window#remove_sel (self : #tiwidget0 :> tiwidget0);
  41     name_list := list_remove !name_list ~f:(fun n -> n=name);
  42     Hashtbl.remove widget_map name;
  43     Propwin.remove name;
  44     widget#destroy ()
  45
  46   method private get_packing packing = ""
  47
  48   method emit_code f param_list =
  49     let param_string =
  50       match param_list with
  51       |  [] -> ""
  52       | _ -> "['" ^
  53           (String.concat ~sep:", '"
  54              (List.map ~f:(fun c -> (String.make 1 c)) param_list)) ^
  55           "] " in
  56     Format.fprintf f "(* Code for %s *)@\n@\n@[<hv 2>class %s%s () ="
  57       name param_string name;
  58     self#emit_init_code f ~packing:"";
  59     Format.fprintf f "@]@\n@[<hv 2>object (self)";
  60     self#emit_method_code f;
  61     Format.fprintf f "@ method show () = %s#show ()" name;
  62     Format.fprintf f "@ @[<v 2>initializer";
  63     self#emit_initializer_code f;
  64     Format.fprintf f "@ ()@]@]@ end@\n@\n"
  65
  66 (*  method private save_start formatter =
  67     Format.fprintf formatter "@[<0>@\n@[<2><window name=%s>" name;
  68     Format.fprintf formatter "@\ntitle=\"%s\""
  69       (List.assoc "title" proplist)#get
  70 *)
  71   method private save_end formatter =
  72     Format.fprintf formatter "@]@\n</window>@\n@]"
  73
  74   method private menu ~time =
  75     let menu = GMenu.menu () and menu_add = GMenu.menu () in
  76     List.iter
  77       ~f:(fun n ->
  78         let mi = GMenu.menu_item ~packing:menu_add#append ~label:n ()
  79         in mi#connect#activate
  80           ~callback:(fun () -> self#add_child n (); ()); ())
  81       widget_add_list;
  82     let mi_add = GMenu.menu_item ~packing:menu#append ~label:("add to "^ name) ()
  83     and mi_paste = GMenu.menu_item ~packing:menu#append ~label:"Paste" ()
  84     in
  85     mi_add#set_submenu menu_add;
  86     if !selection <> ""
  87     then begin mi_paste#connect#activate ~callback:self#paste; () end
  88     else mi_paste#misc#set_sensitive false;
  89     menu#popup ~button:3 ~time
  90
  91
  92   initializer
  93     classe <- "window";
  94     window#set_title name;
  95     proplist <- proplist @
  96       [ "title",
  97         new prop_string ~name:"title" ~init:name ~set:(ftrue window#set_title);
  98         "allow_shrink", new prop_bool ~name:"allow_shrink" ~init:"false"
  99                           ~set:(ftrue window#set_allow_shrink);
 100         "allow_grow", new prop_bool ~name:"allow_grow" ~init:"true"
 101                         ~set:(ftrue window#set_allow_grow);
 102         "auto_shrink", new prop_bool ~name:"auto_shrink" ~init:"false"
 103                          ~set:(ftrue window#set_auto_shrink);
 104         "x position", new prop_int ~name:"x" ~init:"-2"
 105           ~set:(fun x -> window#misc#set_geometry ~x (); true);
 106         "y position", new prop_int ~name:"y" ~init:"-2"
 107           ~set:(fun y -> window#misc#set_geometry ~y (); true) ]
 108 end
 109
 110 let new_tiwindow ~name ?(listprop = []) =
 111   let w = GWindow.window ~show:true () in
 112   w#misc#set_can_focus false;
 113   w#misc#set_can_default false;
 114   new tiwindow ~widget:w ~name
 115
 116
 117