Subject: glade virtual handlers again From: Gabriel de Perthuis To: lablgtk at math.nagoya-u.ac.jp Content-Type: multipart/mixed; boundary="=-nXSeD9hSlnPcYJ+XeN7S" Date: Fri, 08 Apr 2005 15:57:54 +0200 Message-Id: <1112968675.29608.22.camel at localhost.localdomain> Mime-Version: 1.0 --=-nXSeD9hSlnPcYJ+XeN7S Content-Type: text/plain Content-Transfer-Encoding: 7bit (Same message with a more recent patch and an example of generated code) I have improved the glade virtual handlers generation idea a bit. It now works with all events, the handler type is now a labelled type instead of unit -> unit. To handle a drag_drop signal named my_drag_drop in the glade XML, you just implement a method with that name and the right signature: method drag_drop context ~x ~y ~time = foo and use lablgladecc with the -virtual option. The generated code for connecting the signal uses GtkSignal.connect with the appropriate constructor: GtkSignal.connect ~sgn:GtkBase.Widget.S.drag_leave ~callback:self#drag_leave _glade_main_vbox I think it is a useful improvement. I have tested it a bit so that it works with the various options to lablgladecc, like -hide-default and -debug. Please give it a try. --=-nXSeD9hSlnPcYJ+XeN7S Content-Disposition: attachment; filename=lablglade-virtual-patch-4 Content-Type: text/plain; name=lablglade-virtual-patch-4; charset=UTF-8 Content-Transfer-Encoding: 7bit --- lablgtk2-2.4.0+2004.11.19/src/Makefile 2004-11-17 11:24:57.000000000 +0100 +++ lablgtk2-2.4.0+2004.11.19.perso/src/Makefile 2005-04-07 22:08:00.000000000 +0200 @@ -207,7 +207,7 @@ lablgtkopt:: $(THOBJS:.cmo=.cmx) endif lablgladecc$(XE): xml_lexer.cmo lablgladecc.cmo - $(LINKER) -o $@ xml_lexer.cmo lablgladecc.cmo + $(LINKER) -o $@ str.cma xml_lexer.cmo lablgladecc.cmo testcc$(XE): lablgladecc$(XE) lablgtktop ./lablgladecc -test > testcc.ml --- lablgtk2-2.4.0+2004.11.19/src/lablgladecc.ml 2004-07-09 15:52:21.000000000 +0200 +++ lablgtk2-2.4.0+2004.11.19.perso/src/lablgladecc.ml 2005-04-08 02:18:50.000000000 +0200 @@ -12,6 +12,7 @@ let warning s = prerr_string "Warning: " (* grep Object.try_cast *.ml | sed 's/gtk\([^.]*\)[^"]*"Gtk\([^"]*\)".*/ "Gtk\2", ("Gtk\1.\2", "G\1.\2");/' *) (* But you also need to do some post-editing. Do not forget H and V classes *) +(*Glade widget name, module containing magic cast, constructor using cast value*) let classes = ref [ "GtkWidget", ("GtkBase.Widget", "GObj.widget_full"); "GtkContainer", ("GtkBase.Container", "GContainer.container"); @@ -27,7 +28,7 @@ let classes = ref [ "GtkSocket", ("GtkWindow.Socket", "GWindow.socket"); "GtkInvisible", ("GtkBase.Container", "GContainer.container"); "GtkButton", ("GtkButton.Button", "GButton.button"); - "button", ("GtkButton.Button", "GButton.button"); +(* "button", ("GtkButton.Button", "GButton.button"); *) "GtkToggleButton", ("GtkButton.ToggleButton", "GButton.toggle_button"); "GtkCheckButton", ("GtkButton.ToggleButton", "GButton.toggle_button"); "GtkRadioButton", ("GtkButton.RadioButton", "GButton.radio_button"); @@ -106,6 +107,355 @@ let classes = ref [ "GtkPlug", ("GtkWindow.Plug", "GWindow.plug"); ] +(* grep 'class ' *.props|sed 's/.*class *\([^ ]\+\) *.* *: *\([^ ]\+\) *{.*/\("Gtk\1", "Gtk\2"\);/'|grep -v \{|sort|uniq *) +(* Still some edits - watch out for GtkGtk, GtkGObject as well as GtkV and GtkH variants *) +(* test for loops and bogus root elements: + +let next = List.map ~f:(fun (a, b) -> (a, try List.assoc b parents with _ -> failwith b));; +let iter () = + if List.filter (fun (a, b) -> a = b) !r <> [] then failwith "Loop!"; + r := next (List.filter (fun (a, b) -> b <> "GtkObject" && b <> "GObject") !r);; +r := parents;; +while !r <> [] do iter () done;; +*) +(* Not sure for GtkAction, never seen it in glade *) + +let parents = [ +("GtkAction", "GObject"); +("GtkAdjustment", "GtkObject"); +("GtkAlignment", "GtkBin"); +("GtkArrow", "GtkMisc"); +("GtkAspectFrame", "GtkFrame"); +("GtkBin", "GtkContainer"); +("GtkBox", "GtkContainer"); +("GtkHBox", "GtkContainer"); +("GtkVBox", "GtkContainer"); +("GtkBpath", "GtkShape"); +("GtkButtonBox", "GtkBox"); +("GtkHButtonBox", "GtkBox"); +("GtkVButtonBox", "GtkBox"); +("GtkButton", "GtkBin"); +("GtkCalendar", "GtkWidget"); +("GtkCanvas", "GtkLayout"); +("GtkCellLayout", "GtkObject"); +("GtkCellRenderer", "GtkObject"); +("GtkCellRendererPixbuf", "GtkCellRenderer"); +("GtkCellRendererText", "GtkCellRenderer"); +("GtkCellRendererToggle", "GtkCellRenderer"); +("GtkCheckButton", "GtkToggleButton"); +("GtkCheckMenuItem", "GtkMenuItem"); +("GtkClipgroup", "GtkGroup"); +("GtkClist", "GtkContainer"); +("GtkColorButton", "GtkButton"); +("GtkColorSelectionDialog", "GtkDialog"); +("GtkColorSelection", "GtkBox"); +("GtkComboBoxEntry", "GtkComboBox"); +("GtkComboBox", "GtkBin"); +("GtkCombo", "GtkBox"); +("GtkContainer", "GtkWidget"); +("GtkDialog", "GtkWindow"); +("GtkDrawingArea", "GtkWidget"); +("GtkEditable", "GtkWidget"); +("GtkEllipse", "GtkRE"); +("GtkEntry", "GtkEditable"); +("GtkEventBox", "GtkBin"); +("GtkExpander", "GtkBin"); +("GtkFileSelection", "GtkDialog"); +("GtkFixed", "GtkContainer"); +("GtkFontButton", "GtkButton"); +("GtkFontSelectionDialog", "GtkDialog"); +("GtkFontSelection", "GtkBox"); +("GtkFrame", "GtkBin"); +("GtkGammaCurve", "GtkBox"); +("GtkGroup", "GtkItem"); +("GtkHandleBox", "GtkBin"); +("GtkIconFactory", "GObject"); +("GtkImage", "GtkMisc"); +("GtkImageMenuItem", "GtkMenuItem"); +("GtkInputDialog", "GtkDialog"); +("GtkInvisible", "GtkWidget"); +("GtkItem", "GtkBin"); +("GtkLabel", "GtkMisc"); +("GtkLayout", "GtkContainer"); +("GtkLine", "GtkItem"); +("GtkList", "GtkContainer"); +("GtkListItem", "GtkItem"); +("GtkListStore", "GtkTreeModel"); +("GtkMenuBar", "GtkMenuShell"); +("GtkMenu", "GtkMenuShell"); +("GtkMenuItem", "GtkItem"); +("GtkMenuShell", "GtkContainer"); +("GtkMessageDialog", "GtkDialog"); +("GtkMisc", "GtkWidget"); +("GtkNotebook", "GtkContainer"); +("GtkOldEditable", "GtkEditable"); +("GtkOptionMenu", "GtkButton"); +("GtkPaned", "GtkContainer"); +("GtkHPaned", "GtkContainer"); +("GtkVPaned", "GtkContainer"); +("GtkPixbuf", "GtkItem"); +("GtkPlug", "GtkBin"); +("GtkPolygon", "GtkShape"); +("GtkPreview", "GtkWidget"); +("GtkProgressBar", "GtkWidget"); +("GtkProgress", "GtkWidget"); +("GtkRadioAction", "GtkToggleAction"); +("GtkRadioButton", "GtkToggleButton"); +("GtkRadioMenuItem", "GtkCheckMenuItem"); +("GtkRadioToolButton", "GtkToggleToolButton"); +("GtkRange", "GtkWidget"); +("GtkRect", "GtkRE"); +("GtkRE", "GtkShape"); +("GtkRichText", "GtkItem"); +("GtkRuler", "GtkWidget"); +("GtkHRuler", "GtkWidget"); +("GtkVRuler", "GtkWidget"); +("GtkScale", "GtkRange"); +("GtkHScale", "GtkRange"); +("GtkVScale", "GtkRange"); +("GtkScrollbar", "GtkRange"); +("GtkHScrollbar", "GtkRange"); +("GtkVScrollbar", "GtkRange"); +("GtkScrolledWindow", "GtkBin"); +("GtkSeparator", "GtkWidget"); +("GtkSeparatorToolItem", "GtkToolItem"); +("GtkShape", "GtkItem"); +("GtkSizeGroup", "GObject"); +("GtkSocket", "GtkContainer"); +("GtkSpinButton", "GtkEntry"); +("GtkStatusbar", "GtkBox"); +("GtkStyle", "GObject"); +("GtkTable", "GtkContainer"); +("GtkTextBuffer", "GObject"); +("GtkTextChildAnchor", "GObject"); +("GtkText", "GtkItem"); +("GtkText", "GtkOldEditable"); +("GtkTextMark", "GObject"); +("GtkTextTag", "GObject"); +("GtkTextTagTable", "GObject"); +("GtkTextView", "GtkContainer"); +("GtkTipsQuery", "GtkLabel"); +("GtkToggleAction", "GtkAction"); +("GtkToggleButton", "GtkButton"); +("GtkToggleToolButton", "GtkToolButton"); +("GtkToolbar", "GtkContainer"); +("GtkToolButton", "GtkToolItem"); +("GtkToolItem", "GtkBin"); +("GtkTooltips", "GtkObject"); +("GtkTree", "GtkContainer"); +("GtkTreeItem", "GtkItem"); +("GtkTreeModelFilter", "GObject"); +("GtkTreeModel", "GObject"); +("GtkTreeModelSort", "GObject"); +("GtkTreeSelection", "GObject"); +("GtkTreeSortable", "GObject"); +("GtkTreeViewColumn", "GObject"); +("GtkTreeView", "GtkContainer"); +("GtkViewport", "GtkBin"); +("GtkWidget", "GtkObject"); +("GtkWindow", "GtkBin"); +] + +(* a mli parser was used for this - overkill, grepping should give most of it *) +let signals = +[("action_activated", "GtkEdit.EntryCompletion.S.action_activated"); +("activate", "GtkBin.Expander.S.activate"); +("activate", "GtkBroken.OldEditable.S.activate"); +("activate", "GtkButton.Button.S.activate"); +("activate", "GtkEdit.Entry.S.activate"); +("activate", "GtkMenu.MenuItem.S.activate"); +("activate_current", "GtkMenu.MenuShell.S.activate_current"); +("activate_default", "GtkWindow.Window.S.activate_default"); +("activate_focus", "GtkWindow.Window.S.activate_focus"); +("activate_item", "GtkMenu.MenuItem.S.activate_item"); +("add", "GtkBase.Container.S.add"); +("adjust_bounds", "GtkRange.Range.S.adjust_bounds"); +("apply_tag", "GtkText.Buffer.S.apply_tag"); +("begin_user_action", "GtkText.Buffer.S.begin_user_action"); +("cancel", "GtkMenu.MenuShell.S.cancel"); +("change_value", "GtkEdit.SpinButton.S.change_value"); +("changed", "GtkData.Adjustment.S.changed"); +("changed", "GtkEdit.ComboBox.S.changed"); +("changed", "GtkEdit.Editable.S.changed"); +("changed", "GtkMenu.OptionMenu.S.changed"); +("changed", "GtkText.Buffer.S.changed"); +("changed", "GtkTree.TreeSelection.S.changed"); +("check_resize", "GtkBase.Container.S.check_resize"); +("child_attached", "GtkBin.HandleBox.S.child_attached"); +("child_detached", "GtkBin.HandleBox.S.child_detached"); +("click_column", "GtkList.CList.S.click_column"); +("clicked", "GtkButton.Button.S.clicked"); +("clicked", "GtkButton.ToolButton.S.clicked"); +("clicked", "GtkTree.TreeViewColumn.S.clicked"); +("close", "GtkWindow.Dialog.S.close"); +("collapse", "GtkBroken.TreeItem.S.collapse"); +("color_changed", "GtkMisc.ColorSelection.S.color_changed"); +("color_set", "GtkButton.ColorButton.S.color_set"); +("columns_changed", "GtkTree.TreeView.S.columns_changed"); +("copy_clipboard", "GtkBroken.OldEditable.S.copy_clipboard"); +("copy_clipboard", "GtkEdit.Entry.S.copy_clipboard"); +("copy_clipboard", "GtkMisc.Label.S.copy_clipboard"); +("copy_clipboard", "GtkText.View.S.copy_clipboard"); +("current_folder_changed", "GtkFile.FileChooser.S.current_folder_changed"); +("cursor_changed", "GtkTree.TreeView.S.cursor_changed"); +("cut_clipboard", "GtkBroken.OldEditable.S.cut_clipboard"); +("cut_clipboard", "GtkEdit.Entry.S.cut_clipboard"); +("cut_clipboard", "GtkText.View.S.cut_clipboard"); +("cycle_focus", "GtkMenu.MenuShell.S.cycle_focus"); +("day_selected", "GtkMisc.Calendar.S.day_selected"); +("day_selected_double_click", "GtkMisc.Calendar.S.day_selected_double_click"); +("deactivate", "GtkMenu.MenuShell.S.deactivate"); +("delete_from_cursor", "GtkEdit.Entry.S.delete_from_cursor"); +("delete_from_cursor", "GtkText.View.S.delete_from_cursor"); +("delete_range", "GtkText.Buffer.S.delete_range"); +("delete_text", "GtkEdit.Editable.S.delete_text"); +("deselect", "GtkBase.Item.S.deselect"); +("destroy", "GtkBase.Object.S.destroy"); +("drag_begin", "GtkBase.Widget.S.drag_begin"); +("drag_data_delete", "GtkBase.Widget.S.drag_data_delete"); +("drag_data_get", "GtkBase.Widget.S.drag_data_get"); +("drag_data_received", "GtkBase.Widget.S.drag_data_received"); +("drag_drop", "GtkBase.Widget.S.drag_drop"); +("drag_end", "GtkBase.Widget.S.drag_end"); +("drag_leave", "GtkBase.Widget.S.drag_leave"); +("drag_motion", "GtkBase.Widget.S.drag_motion"); +("edited", "GtkTree.CellRendererText.S.edited"); +("embedded", "GtkWindow.Plug.S.embedded"); +("end_user_action", "GtkText.Buffer.S.end_user_action"); +("enter", "GtkButton.Button.S.enter"); +("event", "GtkBase.Widget.S.event"); +("event", "GtkText.Tag.S.event"); +("event_after", "GtkBase.Widget.S.event_after"); +("expand", "GtkBroken.TreeItem.S.expand"); +("expand_collapse_cursor_row", "GtkTree.TreeView.S.expand_collapse_cursor_row"); +("file_activated", "GtkFile.FileChooser.S.file_activated"); +("focus_home_or_end", "GtkButton.Toolbar.S.focus_home_or_end"); +("font_set", "GtkButton.FontButton.S.font_set"); +("format_value", "GtkRange.Scale.S.format_value"); +("frame_event", "GtkWindow.Window.S.frame_event"); +("hide", "GtkBase.Widget.S.hide"); +("input", "GtkEdit.SpinButton.S.input"); +("insert_at_cursor", "GtkEdit.Entry.S.insert_at_cursor"); +("insert_at_cursor", "GtkText.View.S.insert_at_cursor"); +("insert_child_anchor", "GtkText.Buffer.S.insert_child_anchor"); +("insert_pixbuf", "GtkText.Buffer.S.insert_pixbuf"); +("insert_text", "GtkEdit.Editable.S.insert_text"); +("insert_text", "GtkText.Buffer.S.insert_text"); +("keys_changed", "GtkWindow.Window.S.keys_changed"); +("leave", "GtkButton.Button.S.leave"); +("map", "GtkBase.Widget.S.map"); +("mark_deleted", "GtkText.Buffer.S.mark_deleted"); +("mark_set", "GtkText.Buffer.S.mark_set"); +("match_selected", "GtkEdit.EntryCompletion.S.match_selected"); +("modified_changed", "GtkText.Buffer.S.modified_changed"); +("month_changed", "GtkMisc.Calendar.S.month_changed"); +("move_current", "GtkMenu.MenuShell.S.move_current"); +("move_cursor", "GtkBroken.OldEditable.S.move_cursor"); +("move_cursor", "GtkEdit.Entry.S.move_cursor"); +("move_cursor", "GtkMisc.Label.S.move_cursor"); +("move_cursor", "GtkText.View.S.move_cursor"); +("move_cursor", "GtkTree.TreeView.S.move_cursor"); +("move_focus", "GtkButton.Toolbar.S.move_focus"); +("move_focus", "GtkText.View.S.move_focus"); +("move_focus", "GtkWindow.Window.S.move_focus"); +("move_focus_out", "GtkBin.ScrolledWindow.S.move_focus_out"); +("move_page", "GtkBroken.OldEditable.S.move_page"); +("move_scroll", "GtkMenu.Menu.S.move_scroll"); +("move_slider", "GtkRange.Range.S.move_slider"); +("move_to_column", "GtkBroken.OldEditable.S.move_to_column"); +("move_to_row", "GtkBroken.OldEditable.S.move_to_row"); +("move_word", "GtkBroken.OldEditable.S.move_word"); +("next_month", "GtkMisc.Calendar.S.next_month"); +("next_year", "GtkMisc.Calendar.S.next_year"); +("orientation_changed", "GtkButton.Toolbar.S.orientation_changed"); +("output", "GtkEdit.SpinButton.S.output"); +("page_horizontally", "GtkText.View.S.page_horizontally"); +("parent_set", "GtkBase.Widget.S.parent_set"); +("paste_clipboard", "GtkBroken.OldEditable.S.paste_clipboard"); +("paste_clipboard", "GtkEdit.Entry.S.paste_clipboard"); +("paste_clipboard", "GtkText.View.S.paste_clipboard"); +("plug_added", "GtkWindow.Socket.S.plug_added"); +("plug_removed", "GtkWindow.Socket.S.plug_removed"); +("populate_popup", "GtkEdit.Entry.S.populate_popup"); +("populate_popup", "GtkMisc.Label.S.populate_popup"); +("populate_popup", "GtkText.View.S.populate_popup"); +("popup_context_menu", "GtkButton.Toolbar.S.popup_context_menu"); +("pressed", "GtkButton.Button.S.pressed"); +("prev_month", "GtkMisc.Calendar.S.prev_month"); +("prev_year", "GtkMisc.Calendar.S.prev_year"); +("realize", "GtkBase.Widget.S.realize"); +("released", "GtkButton.Button.S.released"); +("remove", "GtkBase.Container.S.remove"); +("remove_tag", "GtkText.Buffer.S.remove_tag"); +("resize_column", "GtkList.CList.S.resize_column"); +("response", "GtkWindow.Dialog.S.response"); +("row_activated", "GtkTree.TreeView.S.row_activated"); +("row_collapsed", "GtkTree.TreeView.S.row_collapsed"); +("row_expanded", "GtkTree.TreeView.S.row_expanded"); +("scroll_child", "GtkBin.ScrolledWindow.S.scroll_child"); +("scroll_horizontal", "GtkList.CList.S.scroll_horizontal"); +("scroll_vertical", "GtkList.CList.S.scroll_vertical"); +("select", "GtkBase.Item.S.select"); +("select_all", "GtkList.CList.S.select_all"); +("select_all", "GtkTree.TreeView.S.select_all"); +("select_child", "GtkBroken.Tree.S.select_child"); +("select_child", "GtkList.Liste.S.select_child"); +("select_cursor_parent", "GtkTree.TreeView.S.select_cursor_parent"); +("select_cursor_row", "GtkTree.TreeView.S.select_cursor_row"); +("select_row", "GtkList.CList.S.select_row"); +("selection_changed", "GtkBroken.Tree.S.selection_changed"); +("selection_changed", "GtkFile.FileChooser.S.selection_changed"); +("selection_changed", "GtkList.Liste.S.selection_changed"); +("selection_done", "GtkMenu.MenuShell.S.selection_done"); +("selection_get", "GtkBase.Widget.S.selection_get"); +("selection_received", "GtkBase.Widget.S.selection_received"); +("set_anchor", "GtkText.View.S.set_anchor"); +("set_focus", "GtkBase.Container.S.set_focus"); +("set_focus", "GtkWindow.Window.S.set_focus"); +("set_scroll_adjustments", "GtkBin.Viewport.S.set_scroll_adjustments"); +("set_scroll_adjustments", "GtkText.View.S.set_scroll_adjustments"); +("set_scroll_adjustments", "GtkTree.TreeView.S.set_scroll_adjustments"); +("show", "GtkBase.Widget.S.show"); +("size_allocate", "GtkBase.Widget.S.size_allocate"); +("sort_column_changed", "GtkTree.TreeSortable.S.sort_column_changed"); +("start_interactive_search", "GtkTree.TreeView.S.start_interactive_search"); +("start_query", "GtkMisc.TipsQuery.S.start_query"); +("state_changed", "GtkBase.Widget.S.state_changed"); +("stop_query", "GtkMisc.TipsQuery.S.stop_query"); +("style_changed", "GtkButton.Toolbar.S.style_changed"); +("style_set", "GtkBase.Widget.S.style_set"); +("switch_page", "GtkPack.Notebook.S.switch_page"); +("tag_added", "GtkText.TagTable.S.tag_added"); +("tag_changed", "GtkText.TagTable.S.tag_changed"); +("tag_removed", "GtkText.TagTable.S.tag_removed"); +("test_collapse_row", "GtkTree.TreeView.S.test_collapse_row"); +("test_expand_row", "GtkTree.TreeView.S.test_expand_row"); +("text_popped", "GtkMisc.Statusbar.S.text_popped"); +("text_pushed", "GtkMisc.Statusbar.S.text_pushed"); +("toggle", "GtkBase.Item.S.toggle"); +("toggle_cursor_row", "GtkTree.TreeView.S.toggle_cursor_row"); +("toggle_overwrite", "GtkEdit.Entry.S.toggle_overwrite"); +("toggle_overwrite", "GtkText.View.S.toggle_overwrite"); +("toggled", "GtkButton.ToggleButton.S.toggled"); +("toggled", "GtkButton.ToggleToolButton.S.toggled"); +("toggled", "GtkMenu.CheckMenuItem.S.toggled"); +("toggled", "GtkTree.CellRendererToggle.S.toggled"); +("unmap", "GtkBase.Widget.S.unmap"); +("unrealize", "GtkBase.Widget.S.unrealize"); +("unselect_all", "GtkList.CList.S.unselect_all"); +("unselect_all", "GtkTree.TreeView.S.unselect_all"); +("unselect_child", "GtkBroken.Tree.S.unselect_child"); +("unselect_child", "GtkList.Liste.S.unselect_child"); +("unselect_row", "GtkList.CList.S.unselect_row"); +("update_preview", "GtkFile.FileChooser.S.update_preview"); +("value_changed", "GtkData.Adjustment.S.value_changed"); +("value_changed", "GtkEdit.SpinButton.S.value_changed"); +("value_changed", "GtkRange.Range.S.value_changed"); +("widget_entered", "GtkMisc.TipsQuery.S.widget_entered"); +("widget_selected", "GtkMisc.TipsQuery.S.widget_selected"); +] + + open Xml_lexer let parse_header lexbuf = @@ -127,11 +477,22 @@ let parse_field lexbuf ~tag = do () done; Buffer.contents b +type signal = { + shandler: string; + scamlhandler: string; + sname: string; + swcamlname: string; + swclass: string; + safter: bool; + (*slookup: string option;*) + } + type wtree = { wclass: string; wname: string; wcamlname : string; wchildren: wtree list; + wsignals: signal list; mutable wrapped: bool; } @@ -165,20 +526,49 @@ let is_default_name s = with | _ -> false -let is_top_widget wtree w = - match wtree.wchildren with - | [w'] -> w.wcamlname = w'.wcamlname - | _ -> false +let caml_signal_name n = + Str.global_replace (Str.regexp "-") "_" (String.uncapitalize n) + +let constructor_of_signal ~wclass ~sname = + let s = caml_signal_name sname in + let l = List.filter (fun (a, _) -> a = s) signals in + let l = List.map snd l in + let rec f wc = + let qs = (fst (List.assoc wc !classes))^".S."^s in +(* eprintf "%s\n" qs;*) + if List.filter ((=) qs) l <> [] then + qs + else + f (List.assoc wc parents) + in + f wclass let rec parse_widget ~wclass ~wname lexbuf = - let widgets = ref [] in - while match token lexbuf with + let widgets = ref [] and signals = ref [] in + while match token lexbuf with | Tag ("widget", attrs, closed) -> widgets := parse_widget ~wclass:(List.assoc "class" attrs) ~wname:(List.assoc "id" attrs) lexbuf :: !widgets; true | Tag ("child",_,_) | Endtag "child" -> true + | Tag ("signal", attrs, closed) -> ( + let h = List.assoc "handler" attrs in + signals := { + shandler = h; + scamlhandler = camlize h; + sname = List.assoc "name" attrs; + swcamlname = camlize wname; + swclass = wclass; + safter = ( + try match List.assoc "after" attrs with + |"yes" -> true + |"no" -> false + |_-> warning "after tag has unexpected value\n"; false + with Not_found -> false) + } :: !signals; + if not closed then while token lexbuf <> Endtag "signal" do () done; true + ) | Tag (tag,_,closed) -> if not closed then while token lexbuf <> Endtag tag do () done; true | Endtag "widget" -> @@ -189,41 +579,67 @@ let rec parse_widget ~wclass ~wname lexb failwith "bad XML syntax" do () done; { wclass = wclass; wname = wname; wcamlname = camlize wname; - wchildren = List.rev !widgets; wrapped = false } + wchildren = List.rev !widgets; wsignals = List.rev !signals; + wrapped = false; } let rec flatten_tree w = let children = List.map ~f:flatten_tree w.wchildren in w :: List.flatten children -let output_widget w = - try - let (modul, clas) = List.assoc w.wclass !classes in - w.wrapped <- true; - - begin match clas with - | "GList.clist" -> - printf " val %s : int %s =\n" w.wcamlname clas - | _ -> - printf " val %s =\n" w.wcamlname - end; - - if !debug then - printf " prerr_endline \"creating %s:%s\";\n" w.wclass w.wcamlname; - printf " new %s (%s.cast\n" clas modul; - printf " (%s ~name:\"%s\" ~info:\"%s\" xmldata))\n" - "Glade.get_widget_msg" w.wname w.wclass; - printf " method %s = %s\n" w.wcamlname w.wcamlname - with Not_found -> - warning (sprintf "Widget %s::%s is not supported" w.wname w.wclass) -;; let roots = ref [] let embed = ref false let trace = ref false +let virtual_ = ref false let output_classes = ref [] +let mangle s = + "_glade_"^s + +let output_widget_prelude w = + try + let (modul, clas) = List.assoc w.wclass !classes in + w.wrapped <- true; + let wn = mangle w.wcamlname in + begin match clas with + | "GList.clist" -> + printf " let %s : int %s = " wn clas + | _ -> + printf " let %s = " wn + end; + if !debug then + printf "\n prerr_endline \"creating %s:%s\";\n " + w.wclass w.wcamlname; + printf "%s.cast\n" modul; + printf " (Glade.get_widget_msg ~name:\"%s\" ~info:\"%s\" xmldata) in\n" + w.wname w.wclass + with Not_found -> + warning (sprintf "Widget %s::%s is not supported" w.wname w.wclass) + +let output_signal s = + try + printf " ignore (GtkSignal.connect ~sgn:%s\n" + (constructor_of_signal ~wclass:s.swclass ~sname:s.sname); + printf " ~callback:self#%s %s%s);\n" + s.scamlhandler (if s.safter then "~after:true " else "") (mangle s.swcamlname) + with + Not_found -> + warning (sprintf "Signal %s is not supported in widget %s\n" s.sname s.swclass); + printf "()\n" + +let output_widget w = + let (modul, clas) = List.assoc w.wclass !classes in + printf " val %s = new %s %s\n" w.wcamlname clas (mangle w.wcamlname); + printf " method %s = %s\n" w.wcamlname w.wcamlname + +let output_toplevel w = + let (modul, clas) = List.assoc w.wclass !classes in + printf " val %s = new %s %s\n" "toplevel" clas (mangle w.wcamlname); + printf " method %s = %s\n" "toplevel" "toplevel" + let output_wrapper ~file wtree = - printf "class %s %s?domain ?autoconnect(*=true*) () =\n" + printf "class"; if !virtual_ then printf " virtual"; + printf " %s %s?domain ?autoconnect(*=true*) () =\n" wtree.wcamlname (if !embed then "" else if file = "" then "~file " else "?(file=\"" ^ file ^ "\") "); @@ -231,20 +647,40 @@ let output_wrapper ~file wtree = printf " let xmldata = Glade.create %s ~root:\"%s\" ?domain () in\n" (if !embed then "~data " else "~file ") wtree.wname; + let widgets = flatten_tree wtree in + + let top_child = + match wtree.wchildren with + | [w] -> w + | _ -> + warning "Glade error - toplevel doesn't have exactly one child\n"; + wtree in + let appears_in_method w = + not (!hide_default_names && w <> wtree && w <> top_child && + is_default_name w.wname) in + let appears_in_signal w = + w.wsignals <> [] in + let appears_in_prelude w = + appears_in_signal w || appears_in_method w in + (* the camlname <> "_" criterium should be handled for the signal case*) + List.iter (List.filter appears_in_prelude widgets) + ~f:output_widget_prelude; + print_string " object (self)\n"; printf " inherit Glade.xml %s?autoconnect xmldata\n" (if !trace then "~trace:stderr " else ""); - let widgets = {wtree with wcamlname= "toplevel"} :: flatten_tree wtree in - - let is_hidden w = - w.wcamlname = "_" || - (!hide_default_names && not (is_top_widget wtree w) && - is_default_name w.wname) - in - - List.iter (List.filter (fun w -> not (is_hidden w)) widgets) + + List.iter (List.filter appears_in_method widgets) ~f:output_widget; + output_toplevel wtree; + + if !virtual_ then ( + Printf.printf " initializer (\n"; + List.iter (List.filter appears_in_signal widgets) + ~f:(fun w -> List.iter output_signal w.wsignals); + Printf.printf " )\n"; + ); (* reparent method *) begin match wtree.wchildren with @@ -320,7 +756,7 @@ let process ?(file="") chan = file; if !embed then printf "let data = \"%s\"\n\n" (String.escaped data); parse_body ~file lexbuf; - output_check_all () + if not !virtual_ then output_check_all () with Failure s -> eprintf "lablgladecc: in %s, before char %d, %s\n" file (Lexing.lexeme_start lexbuf) s @@ -332,7 +768,7 @@ let output_test () = begin fun (clas, _) -> output_widget {wname = "a"^clas; wcamlname = camlize ("a"^clas); - wclass = clas; wchildren = []; wrapped = true} + wclass = clas; wchildren = []; wsignals = []; wrapped = true} end; print_string " end\n\n"; print_string "let _ = print_endline \"lablgladecc test finished\"\n" @@ -344,6 +780,7 @@ let main () = "-embed", Arg.Set embed, " embed input file into generated program"; "-trace", Arg.Set trace, " trace calls to handlers"; "-debug", Arg.Set debug, " add debug code"; + "-virtual", Arg.Set virtual_, " use virtual methods for event handlers"; "-root", Arg.String (fun s -> roots := s :: !roots), " generate only a wrapper for and its children"; "-hide-default", Arg.Set hide_default_names, --=-nXSeD9hSlnPcYJ+XeN7S Content-Disposition: attachment; filename=ui.ml Content-Type: text/plain; name=ui.ml; charset=UTF-8 Content-Transfer-Encoding: 7bit (* Automatically generated from ui.glade by lablgladecc *) class virtual main_window ?(file="ui.glade") ?domain ?autoconnect(*=true*) () = let xmldata = Glade.create ~file ~root:"main_window" ?domain () in let _glade_main_window = GtkWindow.Window.cast (Glade.get_widget_msg ~name:"main_window" ~info:"GtkWindow" xmldata) in let _glade_vbox1 = GtkPack.Box.cast (Glade.get_widget_msg ~name:"vbox1" ~info:"GtkVBox" xmldata) in let _glade_main_vbox = GtkPack.Box.cast (Glade.get_widget_msg ~name:"main_vbox" ~info:"GtkVBox" xmldata) in let _glade_togglebutton1 = GtkButton.ToggleButton.cast (Glade.get_widget_msg ~name:"togglebutton1" ~info:"GtkToggleButton" xmldata) in object (self) inherit Glade.xml ?autoconnect xmldata val main_window = new GWindow.window _glade_main_window method main_window = main_window val vbox1 = new GPack.box _glade_vbox1 method vbox1 = vbox1 val main_vbox = new GPack.box _glade_main_vbox method main_vbox = main_vbox val toplevel = new GWindow.window _glade_main_window method toplevel = toplevel initializer ( ignore (GtkSignal.connect ~sgn:GtkBase.Widget.S.drag_leave ~callback:self#drag_leave _glade_main_vbox); ignore (GtkSignal.connect ~sgn:GtkBase.Widget.S.drag_motion ~callback:self#drag_motion _glade_main_vbox); ignore (GtkSignal.connect ~sgn:GtkBase.Widget.S.realize ~callback:self#main_vbox_realize _glade_main_vbox); ignore (GtkSignal.connect ~sgn:GtkBase.Widget.S.drag_drop ~callback:self#drag_drop _glade_main_vbox); ignore (GtkSignal.connect ~sgn:GtkBase.Widget.S.drag_data_received ~callback:self#drag_data_received _glade_main_vbox); ignore (GtkSignal.connect ~sgn:GtkButton.ToggleButton.S.toggled ~callback:self#clickety _glade_togglebutton1); ) method reparent parent = vbox1#misc#reparent parent; toplevel#destroy () method check_widgets () = () end --=-nXSeD9hSlnPcYJ+XeN7S--