/usr/lib/ocaml/lablgtk2/gObj.ml is in liblablgtk2-ocaml-dev 2.16.0+dfsg-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 | (**************************************************************************)
(* Lablgtk *)
(* *)
(* This program is free software; you can redistribute it *)
(* and/or modify it under the terms of the GNU Library General *)
(* Public License as published by the Free Software Foundation *)
(* version 2, with the exception described in file COPYING which *)
(* comes with the library. *)
(* *)
(* This program is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
(* GNU Library General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Library General *)
(* Public License along with this program; if not, write to the *)
(* Free Software Foundation, Inc., 59 Temple Place, Suite 330, *)
(* Boston, MA 02111-1307 USA *)
(* *)
(* *)
(**************************************************************************)
(* $Id$ *)
open StdLabels
open Gaux
open Gobject
open Gtk
open GtkData
open GtkBase
(* GObject *)
class ['a] gobject_signals obj = object
val obj : 'a obj = obj
val after = false
method after = {< after = true >}
method private connect : 'b. ('a,'b) GtkSignal.t -> callback:'b -> _ =
fun sgn ~callback -> GtkSignal.connect obj ~sgn ~after ~callback
method private notify : 'b. ('a, 'b) property -> callback:('b -> unit) -> _ =
fun prop ~callback -> GtkSignal.connect_property obj ~prop ~callback
end
class gobject_ops obj = object
val obj = obj
method get_oid = get_oid obj
method get_type = Type.name (get_type obj)
method disconnect = GtkSignal.disconnect obj
method handler_block = GtkSignal.handler_block obj
method handler_unblock = GtkSignal.handler_unblock obj
method set_property : 'a. string -> 'a data_set -> unit =
Property.set_dyn obj
method get_property = Property.get_dyn obj
method freeze_notify () = Property.freeze_notify obj
method thaw_notify () = Property.thaw_notify obj
end
(* GtkObject *)
class type ['a] objvar = object
val obj : 'a obj
end
class gtkobj obj = object
val obj = obj
method destroy () = Object.destroy obj
method get_oid = get_oid obj
end
class gtkobj_signals_impl obj = object (self)
inherit ['a] gobject_signals obj
method destroy = self#connect Object.S.destroy
end
class type gtkobj_signals =
object ('a)
method after : 'a
method destroy : callback:(unit -> unit) -> GtkSignal.id
end
(* Widget *)
module Widget = GtkBase.Widget
module Event = Widget.Signals.Event
module Signals = Widget.S
module P = Widget.P
class event_signals obj = object (self)
inherit ['a] gobject_signals (obj :> Gtk.widget obj)
method any = self#connect Event.any
method after_any = self#connect Signals.event_after
method button_press = self#connect Event.button_press
method button_release = self#connect Event.button_release
method client = self#connect Event.client
method configure = self#connect Event.configure
method delete = self#connect Event.delete
method destroy = self#connect Event.destroy
method enter_notify = self#connect Event.enter_notify
method expose = self#connect Event.expose
method focus_in = self#connect Event.focus_in
method focus_out = self#connect Event.focus_out
method key_press = self#connect Event.key_press
method key_release = self#connect Event.key_release
method leave_notify = self#connect Event.leave_notify
method map = self#connect Event.map
method motion_notify = self#connect Event.motion_notify
method property_notify = self#connect Event.property_notify
method proximity_in = self#connect Event.proximity_in
method proximity_out = self#connect Event.proximity_out
method scroll = self#connect Event.scroll
method selection_clear = self#connect Event.selection_clear
method selection_notify = self#connect Event.selection_notify
method selection_request = self#connect Event.selection_request
method unmap = self#connect Event.unmap
method visibility_notify = self#connect Event.visibility_notify
method window_state = self#connect Event.window_state
end
class event_ops obj = object
val obj = (obj :> Gtk.widget obj)
method add = Widget.add_events obj
method connect = new event_signals obj
method send : Gdk.Tags.event_type Gdk.event -> bool = Widget.event obj
method set_extensions = set Widget.P.extension_events obj
end
let iter_setcol set style =
List.iter ~f:(fun (state, color) -> set style state (GDraw.color color))
class style st = object
val style = st
method as_style = style
method copy = {< style = Style.copy style >}
method colormap = Style.get_colormap style
method font = Style.get_font style
method bg = Style.get_bg style
method set_bg = iter_setcol Style.set_bg style
method fg = Style.get_fg style
method set_fg = iter_setcol Style.set_fg style
method light = Style.get_light style
method set_light = iter_setcol Style.set_light style
method dark = Style.get_dark style
method set_dark = iter_setcol Style.set_dark style
method mid = Style.get_mid style
method set_mid = iter_setcol Style.set_mid style
method base = Style.get_base style
method set_base = iter_setcol Style.set_base style
method text = Style.get_text style
method set_text = iter_setcol Style.set_text style
method set_font = Style.set_font style
end
class selection_input (sel : Gtk.selection_data) = object
val sel = sel
method selection = Selection.selection sel
method target = Gdk.Atom.name (Selection.target sel)
end
class selection_data sel = object
inherit selection_input sel
method typ = Gdk.Atom.name (Selection.seltype sel)
method data = Selection.get_data sel
method format = Selection.format sel
end
class selection_context sel = object
inherit selection_input sel
method return ?typ ?(format=8) data =
let typ =
match typ with Some t -> Gdk.Atom.intern t | _ -> Selection.target sel in
Selection.set sel ~typ ~format ~data:(Some data)
end
class drag_signals obj = object (self)
inherit ['a] gobject_signals obj
method private connect_drag : 'b. ('a, Gdk.drag_context -> 'b) GtkSignal.t ->
callback:(drag_context -> 'b) -> _ =
fun sgn ~callback ->
self#connect sgn (fun context -> callback (new drag_context context))
method beginning = self#connect_drag Signals.drag_begin
method ending = self#connect_drag Signals.drag_end
method data_delete = self#connect_drag Signals.drag_data_delete
method leave = self#connect_drag Signals.drag_leave
method motion = self#connect_drag Signals.drag_motion
method drop = self#connect_drag Signals.drag_drop
method data_get ~callback =
self#connect Signals.drag_data_get ~callback:
begin fun context seldata ~info ~time ->
callback (new drag_context context) (new selection_context seldata)
~info ~time
end
method data_received ~callback =
self#connect Signals.drag_data_received
~callback:(fun context ~x ~y data -> callback (new drag_context context)
~x ~y (new selection_data data))
end
and drag_ops obj = object
val obj = obj
method connect = new drag_signals obj
method dest_set ?(flags=[`ALL]) ?(actions=[]) targets =
DnD.dest_set obj ~flags ~actions ~targets:(Array.of_list targets)
method dest_unset () = DnD.dest_unset obj
method get_data ~target ?(time=Int32.zero) (context : drag_context) =
DnD.get_data obj context#context ~target:(Gdk.Atom.intern target) ~time
method highlight () = DnD.highlight obj
method unhighlight () = DnD.unhighlight obj
method source_set ?modi:m ?(actions=[]) targets =
DnD.source_set obj ?modi:m ~actions ~targets:(Array.of_list targets)
method source_set_icon ?(colormap = Gdk.Color.get_system_colormap ())
(pix : GDraw.pixmap) =
DnD.source_set_icon obj ~colormap pix#pixmap ?mask:pix#mask
method source_unset () = DnD.source_unset obj
end
and drag_context context = object
inherit GDraw.drag_context context
method context = context
method finish = DnD.finish context
method source_widget =
new widget (unsafe_cast (DnD.get_source_widget context))
method set_icon_widget (w : widget) =
DnD.set_icon_widget context (w#as_widget)
method set_icon_pixmap ?(colormap = Gdk.Color.get_system_colormap ())
(pix : GDraw.pixmap) =
DnD.set_icon_pixmap context ~colormap pix#pixmap ?mask:pix#mask
end
and misc_signals obj = object (self)
inherit gtkobj_signals_impl obj
method show = self#connect Signals.show
method hide = self#connect Signals.hide
method map = self#connect Signals.map
method unmap = self#connect Signals.unmap
method query_tooltip = self#connect Signals.query_tooltip
method realize = self#connect Signals.realize
method unrealize = self#connect Signals.unrealize
method state_changed = self#connect Signals.state_changed
method size_allocate = self#connect Signals.size_allocate
method parent_set ~callback =
self#connect Signals.parent_set ~callback:
begin function
None -> callback None
| Some w -> callback (Some (new widget (unsafe_cast w)))
end
method style_set ~callback =
self#connect Signals.style_set ~callback:
(fun opt -> callback (may opt ~f:(new style)))
method selection_get ~callback =
self#connect Signals.selection_get ~callback:
begin fun seldata ~info ~time ->
callback (new selection_context seldata) ~info ~time
end
method selection_received ~callback =
self#connect Signals.selection_received
~callback:(fun data -> callback (new selection_data data))
end
and misc_ops obj = object (self)
inherit gobject_ops obj
method get_flag = Object.get_flag obj
method connect = new misc_signals obj
method show () = Widget.show obj
method unparent () = Widget.unparent obj
method show_all () = Widget.show_all obj
method hide () = Widget.hide obj
method hide_all () = Widget.hide_all obj
method map () = Widget.map obj
method unmap () = Widget.unmap obj
method realize () = Widget.realize obj
method unrealize () = Widget.unrealize obj
method draw = Widget.draw obj
method activate () = Widget.activate obj
method reparent (w : widget) = Widget.reparent obj w#as_widget
(* method popup = popup obj *)
method intersect = Widget.intersect obj
method grab_focus () = set P.has_focus obj true
method grab_default () = set P.has_default obj true
method is_ancestor (w : widget) = Widget.is_ancestor obj w#as_widget
method add_accelerator ~sgn:sg ~group ?modi ?flags key =
Widget.add_accelerator obj ~sgn:sg group ~key ?modi ?flags
method remove_accelerator ~group ?modi key =
Widget.remove_accelerator obj group ~key ?modi
(* method lock_accelerators () = lock_accelerators obj *)
method set_name = set P.name obj
method set_state = Widget.set_state obj
method set_sensitive = set P.sensitive obj
method set_can_default = set P.can_default obj
method set_can_focus = set P.can_focus obj
method set_app_paintable = set P.app_paintable obj
method set_double_buffered = Widget.set_double_buffered obj
method set_size_request =
Widget.size_params [] ~cont:(fun p () -> set_params obj p)
method set_size_chars ?desc ?lang ?width ?height () =
let metrics =
(self#pango_context : GPango.context)#get_metrics ?desc ?lang () in
let width = may_map width ~f:
(fun w -> w * GPango.to_pixels metrics#approx_digit_width)
and height = may_map height ~f:
(fun h -> h * GPango.to_pixels (metrics#ascent+metrics#descent)) in
self#set_size_request ?width ?height ()
method set_style (style : style) = set P.style obj style#as_style
method modify_fg = iter_setcol Widget.modify_fg obj
method modify_bg = iter_setcol Widget.modify_bg obj
method modify_text = iter_setcol Widget.modify_text obj
method modify_base = iter_setcol Widget.modify_base obj
method modify_font = Widget.modify_font obj
method modify_font_by_name s =
Widget.modify_font obj (Pango.Font.from_string s)
method create_pango_context =
new GPango.context_rw (Widget.create_pango_context obj)
(* get functions *)
method name = get P.name obj
method toplevel =
try new widget (unsafe_cast (Widget.get_toplevel obj))
with Gpointer.Null -> failwith "GObj.misc_ops#toplevel"
method window = Widget.window obj
method colormap = Widget.get_colormap obj
method visual = Widget.get_visual obj
method visual_depth = Gdk.Visual.depth (Widget.get_visual obj)
method pointer = Widget.get_pointer obj
method style = new style (get P.style obj)
method visible = self#get_flag `VISIBLE
method parent =
may_map (fun w -> new widget (unsafe_cast w)) (get P.parent obj)
method allocation = Widget.allocation obj
method pango_context = new GPango.context (Widget.get_pango_context obj)
(* icon *)
method render_icon ?detail ~size id =
Widget.render_icon obj (GtkStock.convert_id id) size detail
(* selection *)
method convert_selection ~target ?(time=Int32.zero) sel =
Selection.convert obj ~sel ~target:(Gdk.Atom.intern target) ~time
method grab_selection ?(time=Int32.zero) sel =
Selection.owner_set obj ~sel ~time
method add_selection_target ~target ?(info=0) sel =
Selection.add_target obj ~sel ~target:(Gdk.Atom.intern target) ~info
method clear_selection_targets sel = Selection.clear_targets obj ~sel
(* tooltip *)
method has_tooltip = get P.has_tooltip obj
method tooltip_markup = get P.tooltip_markup obj
method tooltip_text = get P.tooltip_text obj
method set_has_tooltip = set P.has_tooltip obj
method set_tooltip_markup = set P.tooltip_markup obj
method set_tooltip_text = set P.tooltip_text obj
end
and widget obj = object (self)
inherit gtkobj obj
method as_widget = (obj :> Gtk.widget obj)
method misc = new misc_ops (obj :> Gtk.widget obj)
method drag = new drag_ops (unsafe_cast obj : Gtk.widget obj)
method coerce = (self :> widget)
end
(* just to check that GDraw.misc_ops is compatible with misc_ops *)
let _ = fun (x : #GDraw.misc_ops) -> (x : misc_ops)
class widget_signals_impl (obj : [>Gtk.widget] obj) = gtkobj_signals_impl obj
class type widget_signals = gtkobj_signals
class ['a] widget_impl (obj : 'a obj) = widget obj
class widget_full obj = object
inherit widget obj
method connect = new widget_signals_impl obj
end
let as_widget (w : widget) = w#as_widget
let wrap_widget w = new widget (unsafe_cast w)
let unwrap_widget w = unsafe_cast w#as_widget
let conv_widget_option =
{ kind = `OBJECT;
proj = (function `OBJECT c -> may_map ~f:wrap_widget c
| _ -> failwith "GObj.get_object");
inj = (fun c -> `OBJECT (may_map ~f:unwrap_widget c)) }
let conv_widget =
{ kind = `OBJECT;
proj = (function `OBJECT (Some c) -> wrap_widget c
| `OBJECT None -> raise Gpointer.Null
| _ -> failwith "GObj.get_object");
inj = (fun c -> `OBJECT (Some (unwrap_widget c))) }
let pack_return self ~packing ~show =
may packing ~f:(fun f -> (f (self :> widget) : unit));
if show <> Some false then self#misc#show ();
self
|