This file is indexed.

/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