This file is indexed.

/usr/lib/ocaml/lablgtk2/glade.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
(**************************************************************************)
(*                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 Gtk

(* GladeXML widget *)

type glade_xml = [`data|`glade_xml]

external init : unit -> unit = "ml_glade_init"
(* external gnome_init : unit -> unit = "ml_glade_gnome_init" *)
external create :
    ?file:string -> ?data:string ->
    ?root:string -> ?domain:string -> unit -> glade_xml obj
    = "ml_glade_xml_new"

external _signal_autoconnect :
    [> `glade_xml] obj ->
    (string * unit obj * string * unit obj option * bool -> unit) -> unit
    = "ml_glade_xml_signal_autoconnect_full"

let signal_autoconnect self ~f =
  _signal_autoconnect self
    (fun (handler, obj, signal, target, after) ->
      f ~handler ~signal ~after ?target obj)

external _signal_connect :
    [> `glade_xml] obj -> string ->
    (string * unit obj * string * unit obj option * bool -> unit) -> unit
    = "ml_glade_xml_signal_connect_full"

let signal_connect self ~handler ~f =
  _signal_connect self handler
    (fun (handler, obj, signal, target, after) ->
      f ~signal ~after ?target obj)

external get_widget : [> `glade_xml] obj -> name:string -> widget obj
    = "ml_glade_xml_get_widget"
external get_widget_name : [> `widget] obj -> string
    = "ml_glade_get_widget_name"
external get_widget_tree : [> `widget] obj -> glade_xml obj
    = "ml_glade_get_widget_tree"

let get_widget_msg ~name ?info xml =
  try get_widget ~name xml
  with Gpointer.Null ->
    let name = match info with None -> name | Some s -> s^":"^name in
    failwith ("Glade error: " ^ name ^ " is not accessible.")

(* Signal handlers *)
open Gobject

type handler =
  [ `Simple of (unit -> unit)
  | `Object of string * (unit obj -> unit)
  | `Custom of (Closure.argv -> data_get list -> unit) ]

let ($) f g x = g (f x)
let gtk_bool b argv _ = Closure.set_result argv (`BOOL b)
let known_handlers : (string, handler) Hashtbl.t = Hashtbl.create 11
let add_handler ~name handler =
  Hashtbl.add known_handlers name handler
open GtkBase
let _ = List.iter ~f:(fun (name,h) -> add_handler ~name h)
    [ "gtk_widget_destroy",`Object ("GtkObject", Object.cast $ Object.destroy);
      "gtk_main_quit", `Simple GtkMain.Main.quit;
      "gtk_widget_show", `Object ("GtkWidget", Widget.cast $ Widget.show);
      "gtk_widget_hide", `Object ("GtkWidget", Widget.cast $ Widget.hide);
      "gtk_widget_grab_focus",
      `Object ("GtkWidget",
               Widget.cast $ fun w -> set Widget.P.has_focus w true);
      "gtk_window_activate_default",
      `Object ("GtkWindow", fun w -> ignore (GtkWindow.Window.activate_default
                                               (GtkWindow.Window.cast w)));
      "gtk_true", `Custom (gtk_bool true);
      "gtk_false", `Custom (gtk_bool false);
    ]

open Printf

let check_handler ?target ?(name="<unknown>") handler =
  match handler with
    `Simple f ->
      fun _ -> f ()
  | `Object (cls, f) ->
      begin match target with
        None ->
          eprintf "Glade-warning: %s requires an object argument.\n" name;
          raise Not_found
      | Some obj ->
          if Gobject.is_a obj cls then
            fun _ -> f obj
          else begin
            eprintf "Glade-warning: %s expects a %s argument.\n" name cls;
            raise Not_found
          end
      end
  | `Custom f ->
      if target <> None then
        eprintf "Glade-warning: %s does not take an object argument.\n" name;
      fun argv -> f argv (Closure.get_args argv)

let bind_handlers ?(extra=[]) ?(warn=false) xml =
  signal_autoconnect xml ~f:
    begin fun ~handler:name ~signal ~after ?target obj ->
      try
        let handler =
          try List.assoc name extra
          with Not_found -> Hashtbl.find known_handlers name
        in
        let callback = check_handler ?target ~name handler in
        ignore (GtkSignal.connect_by_name obj ~name:signal ~after
		  ~callback:(Closure.create callback))
      with Not_found ->
        if warn then eprintf "Glade.bind_handlers: no handler for %s\n" name
    end;
  flush stderr

let bind_handler ~name ~handler ?(warn=true) xml =
  let warn = ref warn in
  signal_connect xml ~handler:name ~f:
    begin fun ~signal ~after ?target obj ->
      warn := false;
      let callback = check_handler ?target ~name handler in
      ignore (GtkSignal.connect_by_name obj ~name:signal ~after
		~callback:(Closure.create callback))
    end;
  if !warn then begin
    eprintf "Glade-warning: handler %s is not used\n" name;
    flush stderr
  end

(* To list bindings *)
let ($) f g x = g (f x)
let show_option sh = function None -> "None" | Some x -> "Some " ^ sh x
let print_binding oc ~handler ~signal ~after ?target obj =
  Printf.fprintf oc "object=%s, signal=%s, handler=%s, target=%s\n"
   (get_widget_name (GtkBase.Widget.cast obj)) signal handler
   (show_option (GtkBase.Widget.cast $ get_widget_name) target)
let print_bindings oc xml =
  signal_autoconnect xml ~f:(print_binding oc); flush oc

let trace_handlers oc xml =
  signal_autoconnect xml ~f:
    begin fun ~handler ~signal ~after ?target obj ->
      let callback _ =
        if signal = "" then
          Printf.fprintf oc "Glade-debug: handler %s called\n" handler
        else
          Printf.fprintf oc
            "Glade-debug: %s called by signal %s on widget %s\n"
            handler signal (get_widget_name (GtkBase.Widget.cast obj));
        flush oc
      in
      ignore (GtkSignal.connect_by_name obj ~name:signal ~after
		~callback:(Closure.create callback))
    end
      
(* class skeleton, for use in generated wrappers *)

let create ?file ?data ?root ?domain () =
  init (); create ?file ?data ?root ?domain ()

class xml ?trace ?(autoconnect = true) (xmldata : glade_xml Gtk.obj) =
  let () = match trace with Some oc -> trace_handlers oc xmldata | None -> () in
  let () = if autoconnect then bind_handlers xmldata in
  object (self)
    val xml = xmldata
    method xml = xmldata
    method bind ~name ~callback =
      bind_handler ~name ~handler:(`Simple callback) ~warn:true xmldata
  end