← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/libgtkada2/intrepid

« back to all changes in this revision

Viewing changes to src/glib-object.adb

  • Committer: Bazaar Package Importer
  • Author(s): Luca Falavigna
  • Date: 2008-08-11 09:46:51 UTC
  • mfrom: (6.1.1 squeeze)
  • Revision ID: james.westby@ubuntu.com-20080811094651-9mjd6acwa98ffw5c
Tags: 2.12.0-2ubuntu1
Add lpia to supported architectures.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/glib-object.adb
1
1
-----------------------------------------------------------------------
2
2
--               GtkAda - Ada95 binding for Gtk+/Gnome               --
3
3
--                                                                   --
 
4
--                Copyright (C) 2001-2008, AdaCore                   --
4
5
--                                                                   --
5
6
-- This library is free software; you can redistribute it and/or     --
6
7
-- modify it under the terms of the GNU General Public               --
25
25
with Unchecked_Deallocation;
26
26
 
27
27
with Glib.Type_Conversion_Hooks;
28
 
with Gtkada.Types; use Gtkada.Types;
 
28
with Gtkada.Bindings;  use Gtkada.Bindings;
 
29
with Gtkada.C;         use Gtkada.C;
 
30
with Gtkada.Types;     use Gtkada.Types;
29
31
 
30
32
package body Glib.Object is
 
33
   package Signal_Id_Arrays is new Gtkada.C.Unbounded_Arrays
 
34
     (Glib.Signal_Id, Glib.Null_Signal_Id, Glib.Guint,
 
35
      Glib.Object.Signal_Id_Array);
31
36
 
32
37
   procedure Free_User_Data (Data : System.Address);
33
38
   --  Free the user data Data. This function should not be called directly
39
44
      Destroy : System.Address);
40
45
   pragma Import (C, Set_User_Data, "g_object_set_qdata_full");
41
46
 
 
47
   function To_Object is new Ada.Unchecked_Conversion
 
48
     (System.Address, GObject);
 
49
 
42
50
   ----------------
43
51
   -- Deallocate --
44
52
   ----------------
53
61
      Free (Obj);
54
62
   end Deallocate;
55
63
 
56
 
   -------------------------
57
 
   -- Conversion_Function --
58
 
   -------------------------
59
 
 
60
 
   function Conversion_Function
61
 
     (Obj : System.Address; Stub : GObject_Record'Class) return GObject
62
 
   is
63
 
      function Get_Type (Obj : System.Address) return GType;
64
 
      pragma Import (C, Get_Type, "ada_gobject_get_type");
65
 
 
66
 
      Name  : constant String := Type_Name (Get_Type (Obj));
67
 
      Hooks : Glib.Type_Conversion_Hooks.Hook_List_Access;
68
 
 
69
 
      use type Glib.Type_Conversion_Hooks.Hook_List_Access;
70
 
 
71
 
   begin
72
 
      Hooks := Glib.Type_Conversion_Hooks.Conversion_Hooks;
73
 
 
74
 
      while Hooks /= null loop
75
 
         declare
76
 
            R : constant GObject := Hooks.Func (Name);
77
 
         begin
78
 
            if R /= null then
79
 
               return R;
80
 
            end if;
81
 
         end;
82
 
 
83
 
         Hooks := Hooks.Next;
84
 
      end loop;
85
 
 
86
 
      return new GObject_Record'Class'(Stub);
87
 
   end Conversion_Function;
88
 
 
89
64
   --------------------
90
65
   -- Free_User_Data --
91
66
   --------------------
152
127
      Stub : GObject_Record'Class) return GObject
153
128
   is
154
129
      function Internal
155
 
        (Object : in System.Address;
156
 
         Quark  : in Glib.GQuark) return GObject;
 
130
        (Object : System.Address;
 
131
         Quark  : Glib.GQuark) return System.Address;
157
132
      pragma Import (C, Internal, "g_object_get_qdata");
158
133
 
159
134
      use type System.Address;
169
144
         GtkAda_String_Quark := Glib.Quark_From_String (GtkAda_String);
170
145
      end if;
171
146
 
172
 
      R := Internal (Obj, GtkAda_String_Quark);
 
147
      R := To_Object (Internal (Obj, GtkAda_String_Quark));
173
148
 
174
149
      if R = null then
175
 
         R := Conversion_Function (Obj, Stub);
 
150
         R := Glib.Type_Conversion_Hooks.Conversion_Function (Obj, Stub);
176
151
 
177
152
         --  This function will either simply return what we expect (Stub), or
178
153
         --  try to create the exact Ada type corresponding to the C type.
188
163
   ------------------------
189
164
 
190
165
   function Get_User_Data_Fast
191
 
     (Obj  : in System.Address;
192
 
      Stub : in GObject_Record'Class) return GObject
 
166
     (Obj  : System.Address;
 
167
      Stub : GObject_Record'Class) return GObject
193
168
   is
194
169
      pragma Suppress (All_Checks);
195
170
 
196
171
      function Internal
197
 
        (Object : in System.Address;
198
 
         Quark  : in Glib.GQuark) return GObject;
 
172
        (Object : System.Address;
 
173
         Quark  : Glib.GQuark) return System.Address;
199
174
      pragma Import (C, Internal, "g_object_get_qdata");
200
175
 
201
176
      use type System.Address;
211
186
         GtkAda_String_Quark := Glib.Quark_From_String (GtkAda_String);
212
187
      end if;
213
188
 
214
 
      R := Internal (Obj, GtkAda_String_Quark);
 
189
      R := To_Object (Internal (Obj, GtkAda_String_Quark));
215
190
 
216
191
      if R = null then
217
192
         R := new GObject_Record'Class'(Stub);
225
200
   -- Is_Created --
226
201
   ----------------
227
202
 
228
 
   function Is_Created (Object : in GObject_Record'Class) return Boolean is
 
203
   function Is_Created (Object : GObject_Record'Class) return Boolean is
229
204
      use type System.Address;
230
205
   begin
231
206
      return Object.Ptr /= System.Null_Address;
278
253
      procedure Set_User_Data
279
254
        (Obj     : System.Address;
280
255
         Quark   : Glib.GQuark;
281
 
         Data    : GObject;
 
256
         Data    : System.Address;
282
257
         Destroy : System.Address);
283
258
      pragma Import (C, Set_User_Data, "g_object_set_qdata_full");
284
259
 
285
260
   begin
286
261
      Result.Ptr := Obj.Ptr;
287
262
      Set_User_Data
288
 
        (Obj.Ptr, GtkAda_String_Quark, Result, Free_User_Data'Address);
 
263
        (Obj.Ptr, GtkAda_String_Quark, Result'Address, Free_User_Data'Address);
289
264
      Deallocate (Obj);
290
265
      return Result;
291
266
   end Unchecked_Cast;
341
316
   --------------
342
317
 
343
318
   function List_Ids (Typ : Glib.GType) return Signal_Id_Array is
344
 
      type Flat_Id_Array is array (Guint) of Signal_Id;
345
 
      pragma Convention (C, Flat_Id_Array);
346
 
      type Flat_Id_Array_Access is access all Flat_Id_Array;
347
 
 
 
319
      use Signal_Id_Arrays;
348
320
      function Internal
349
 
        (Typ : GType; N_Ids : access Guint) return Flat_Id_Array_Access;
 
321
        (Typ : GType; N_Ids : access Guint) return Unbounded_Array_Access;
350
322
      pragma Import (C, Internal, "g_signal_list_ids");
351
323
 
352
 
      N_Ids  : aliased Guint;
353
 
      Result : constant Flat_Id_Array_Access := Internal (Typ, N_Ids'Access);
 
324
      N      : aliased Guint;
 
325
      Output : constant Unbounded_Array_Access := Internal (Typ, N'Access);
 
326
      Result : constant Signal_Id_Array := To_Array (Output, N);
354
327
 
355
328
   begin
356
 
      if N_Ids = 0 then
357
 
         return (1 .. 0 => 0);
358
 
      else
359
 
         return Signal_Id_Array (Result (0 .. N_Ids - 1));
360
 
      end if;
 
329
      G_Free (Output);
 
330
      return Result;
361
331
   end List_Ids;
362
332
 
363
333
   -----------------
364
334
   -- Signal_Name --
365
335
   -----------------
366
336
 
367
 
   function Signal_Name (Q : Signal_Query) return String is
 
337
   function Signal_Name (Q : Signal_Query) return Glib.Signal_Name is
368
338
      function Internal
369
339
        (Q : Signal_Query) return Interfaces.C.Strings.chars_ptr;
370
340
      pragma Import (C, Internal, "ada_gsignal_query_signal_name");
371
341
 
372
342
   begin
373
 
      return Interfaces.C.Strings.Value (Internal (Q));
 
343
      return Glib.Signal_Name
 
344
        (String'(Interfaces.C.Strings.Value (Internal (Q))));
374
345
   end Signal_Name;
375
346
 
376
347
   ------------
378
349
   ------------
379
350
 
380
351
   function Params (Q : Signal_Query) return GType_Array is
381
 
      type Flat_GType_Array is array (Guint) of GType;
382
 
      pragma Convention (C, Flat_GType_Array);
383
 
      type Flat_GType_Array_Access is access all Flat_GType_Array;
384
 
 
 
352
      use GType_Arrays;
385
353
      function Internal
386
354
        (Q     : Signal_Query;
387
 
         N_Ids : access Guint) return Flat_GType_Array_Access;
 
355
         N_Ids : access Guint) return Unbounded_Array_Access;
388
356
      pragma Import (C, Internal, "ada_gsignal_query_params");
389
357
 
390
 
      N_Ids  : aliased Guint;
391
 
      Result : constant Flat_GType_Array_Access := Internal (Q, N_Ids'Access);
 
358
      N      : aliased Guint;
 
359
      Output : constant Unbounded_Array_Access := Internal (Q, N'Access);
 
360
      Result : constant GType_Array := To_Array (Output, N);
392
361
 
393
362
   begin
394
 
      if N_Ids = 0 then
395
 
         return (1 .. 0 => GType_Invalid);
396
 
      else
397
 
         return GType_Array (Result (0 .. N_Ids - 1));
398
 
      end if;
 
363
      --  Do not free Output, it belongs to gtk+
 
364
      --  G_Free (Output);
 
365
      return Result;
399
366
   end Params;
400
367
 
401
368
   ------------
477
444
         Destroy : System.Address);
478
445
      pragma Import (C, Set_Data_Internal_Id, "g_object_set_qdata_full");
479
446
 
 
447
      function Get_Data_Internal
 
448
        (Object : System.Address;
 
449
         Key    : String) return System.Address;
 
450
      pragma Import (C, Get_Data_Internal, "g_object_get_data");
 
451
 
 
452
      function Get_Data_Internal_Id
 
453
        (Object : System.Address;
 
454
         Key    : Glib.GQuark) return System.Address;
 
455
      pragma Import (C, Get_Data_Internal_Id, "g_object_get_qdata");
 
456
 
480
457
      ----------
481
458
      -- Free --
482
459
      ----------
506
483
        (Object : access GObject_Record'Class;
507
484
         Id     : String := "user_data") return Data_Type
508
485
      is
509
 
         function Internal
510
 
           (Object : System.Address;
511
 
            Key    : String) return System.Address;
512
 
         pragma Import (C, Internal, "g_object_get_data");
513
 
 
514
486
         D : constant Cb_Record_Access :=
515
 
           Convert (Internal (Get_Object (Object), Id & ASCII.NUL));
516
 
 
 
487
           Convert (Get_Data_Internal (Get_Object (Object), Id & ASCII.NUL));
517
488
      begin
518
489
         if D = null or else D.Ptr = null then
519
490
            raise Gtkada.Types.Data_Error;
527
498
      ---------
528
499
 
529
500
      function Get
 
501
        (Object  : access GObject_Record'Class;
 
502
         Id      : String := "user_data";
 
503
         Default : Data_Type) return Data_Type
 
504
      is
 
505
         D : constant Cb_Record_Access :=
 
506
           Convert (Get_Data_Internal (Get_Object (Object), Id & ASCII.NUL));
 
507
      begin
 
508
         if D = null or else D.Ptr = null then
 
509
            return Default;
 
510
         else
 
511
            return D.Ptr.all;
 
512
         end if;
 
513
      end Get;
 
514
 
 
515
      ---------
 
516
      -- Get --
 
517
      ---------
 
518
 
 
519
      function Get
530
520
        (Object : access GObject_Record'Class;
531
521
         Id     : Glib.GQuark) return Data_Type
532
522
      is
533
 
         function Internal
534
 
           (Object : System.Address;
535
 
            Key    : Glib.GQuark) return System.Address;
536
 
         pragma Import (C, Internal, "g_object_get_qdata");
537
 
 
538
523
         D : constant Cb_Record_Access :=
539
 
           Convert (Internal (Get_Object (Object), Id));
540
 
 
 
524
           Convert (Get_Data_Internal_Id (Get_Object (Object), Id));
541
525
      begin
542
526
         if D = null or else D.Ptr = null then
543
527
            raise Gtkada.Types.Data_Error;
547
531
      end Get;
548
532
 
549
533
      ---------
 
534
      -- Get --
 
535
      ---------
 
536
 
 
537
      function Get
 
538
        (Object  : access GObject_Record'Class;
 
539
         Id      : Glib.GQuark;
 
540
         Default : Data_Type) return Data_Type
 
541
      is
 
542
         D : constant Cb_Record_Access :=
 
543
           Convert (Get_Data_Internal_Id (Get_Object (Object), Id));
 
544
      begin
 
545
         if D = null or else D.Ptr = null then
 
546
            return Default;
 
547
         else
 
548
            return D.Ptr.all;
 
549
         end if;
 
550
      end Get;
 
551
 
 
552
      ---------
550
553
      -- Set --
551
554
      ---------
552
555
 
692
695
      Internal (Get_Object (Object), Notify, Data);
693
696
   end Weak_Unref;
694
697
 
 
698
   -------------------------------
 
699
   -- Interface_List_Properties --
 
700
   -------------------------------
 
701
 
 
702
   function Interface_List_Properties
 
703
     (Vtable : Interface_Vtable) return Glib.Param_Spec_Array
 
704
   is
 
705
      use Pspec_Arrays;
 
706
      function Internal
 
707
        (Vtable  : Interface_Vtable;
 
708
         N_Props : access Guint) return Unbounded_Array_Access;
 
709
      pragma Import (C, Internal, "g_object_interface_list_properties");
 
710
 
 
711
      N       : aliased Guint;
 
712
      Output  : constant Unbounded_Array_Access := Internal (Vtable, N'Access);
 
713
      Result  : constant Param_Spec_Array := To_Array (Output, Integer (N));
 
714
 
 
715
   begin
 
716
      --  Doc says we should free, but that results in double-deallocation...
 
717
--     G_Free (Output);
 
718
      return Result;
 
719
   end Interface_List_Properties;
 
720
 
 
721
   ---------------------------
 
722
   -- Class_List_Properties --
 
723
   ---------------------------
 
724
 
 
725
   function Class_List_Properties
 
726
     (Class : GObject_Class) return Glib.Param_Spec_Array
 
727
   is
 
728
      use Pspec_Arrays;
 
729
      function Internal
 
730
        (Class   : GObject_Class;
 
731
         N_Props : access Guint) return Unbounded_Array_Access;
 
732
      pragma Import (C, Internal, "g_object_class_list_properties");
 
733
 
 
734
      N      : aliased Guint;
 
735
      Output : constant Unbounded_Array_Access := Internal (Class, N'Access);
 
736
      Result : constant Param_Spec_Array := To_Array (Output, Integer (N));
 
737
   begin
 
738
      --  Doc says we should free, but that results in double-deallocation...
 
739
--      G_Free (Output);
 
740
      return Result;
 
741
   end Class_List_Properties;
 
742
 
695
743
end Glib.Object;