1----------------------------------------------------------------------- 2-- GtkAda - Ada95 binding for Gtk+/Gnome -- 3-- -- 4-- Copyright (C) 2000-2013, AdaCore -- 5-- -- 6-- This library is free software; you can redistribute it and/or -- 7-- modify it under the terms of the GNU General Public -- 8-- License as published by the Free Software Foundation; either -- 9-- version 2 of the License, or (at your option) any later version. -- 10-- -- 11-- This library is distributed in the hope that it will be useful, -- 12-- but WITHOUT ANY WARRANTY; without even the implied warranty of -- 13-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- 14-- General Public License for more details. -- 15-- -- 16-- You should have received a copy of the GNU General Public -- 17-- License along with this library; if not, write to the -- 18-- Free Software Foundation, Inc., 59 Temple Place - Suite 330, -- 19-- Boston, MA 02111-1307, USA. -- 20-- -- 21-- As a special exception, if other files instantiate generics from -- 22-- this unit, or you link this unit with other files to produce an -- 23-- executable, this unit does not by itself cause the resulting -- 24-- executable to be covered by the GNU General Public License. This -- 25-- exception does not however invalidate any other reasons why the -- 26-- executable file might be covered by the GNU Public License. -- 27----------------------------------------------------------------------- 28 29with System; 30with Interfaces.C.Strings; 31 32with Glib.Type_Conversion_Hooks; 33 34package body Gtk.Tooltips is 35 36 package Type_Conversion is new Glib.Type_Conversion_Hooks.Hook_Registrator 37 (Get_Type'Access, Gtk_Tooltips_Record); 38 pragma Warnings (Off, Type_Conversion); 39 40 ------------ 41 -- Enable -- 42 ------------ 43 44 procedure Enable (Tooltips : access Gtk_Tooltips_Record) is 45 procedure Internal (Tooltips : System.Address); 46 pragma Import (C, Internal, "gtk_tooltips_enable"); 47 48 begin 49 Internal (Get_Object (Tooltips)); 50 end Enable; 51 52 ------------- 53 -- Disable -- 54 ------------- 55 56 procedure Disable (Tooltips : access Gtk_Tooltips_Record) is 57 procedure Internal (Tooltips : System.Address); 58 pragma Import (C, Internal, "gtk_tooltips_disable"); 59 60 begin 61 Internal (Get_Object (Tooltips)); 62 end Disable; 63 64 ------------- 65 -- Gtk_New -- 66 ------------- 67 68 procedure Gtk_New (Widget : out Gtk_Tooltips) is 69 begin 70 Widget := new Gtk_Tooltips_Record; 71 Gtk.Tooltips.Initialize (Widget); 72 end Gtk_New; 73 74 ---------------- 75 -- Initialize -- 76 ---------------- 77 78 procedure Initialize (Widget : access Gtk_Tooltips_Record'Class) is 79 function Internal return System.Address; 80 pragma Import (C, Internal, "gtk_tooltips_new"); 81 82 begin 83 Set_Object (Widget, Internal); 84 end Initialize; 85 86 ------------------ 87 -- Force_Window -- 88 ------------------ 89 90 procedure Force_Window (Widget : access Gtk_Tooltips_Record) is 91 procedure Internal (Widget : System.Address); 92 pragma Import (C, Internal, "gtk_tooltips_force_window"); 93 94 begin 95 Internal (Get_Object (Widget)); 96 end Force_Window; 97 98 --------------- 99 -- Set_Delay -- 100 --------------- 101 102 procedure Set_Delay 103 (Tooltips : access Gtk_Tooltips_Record; 104 Duration : Guint := 500) 105 is 106 procedure Internal (Tooltips : System.Address; Duration : Guint); 107 pragma Import (C, Internal, "gtk_tooltips_set_delay"); 108 109 begin 110 Internal (Get_Object (Tooltips), Duration); 111 end Set_Delay; 112 113 ------------- 114 -- Set_Tip -- 115 ------------- 116 117 procedure Set_Tip 118 (Tooltips : access Gtk_Tooltips_Record; 119 Widget : access Gtk.Widget.Gtk_Widget_Record'Class; 120 Tip_Text : UTF8_String; 121 Tip_Private : UTF8_String := "") 122 is 123 procedure Internal 124 (Tooltips : System.Address; 125 Widget : System.Address; 126 Tip_Text : UTF8_String; 127 Tip_Private : UTF8_String); 128 pragma Import (C, Internal, "gtk_tooltips_set_tip"); 129 130 begin 131 Internal (Get_Object (Tooltips), Get_Object (Widget), 132 Tip_Text & ASCII.NUL, 133 Tip_Private & ASCII.NUL); 134 end Set_Tip; 135 136 -------------- 137 -- Get_Data -- 138 -------------- 139 140 function Get_Data 141 (Widget : access Gtk.Widget.Gtk_Widget_Record'Class) return Tooltips_Data 142 is 143 type C_Data is record 144 Tooltips : System.Address; 145 Widget : System.Address; 146 Text : Interfaces.C.Strings.chars_ptr; 147 Privat : Interfaces.C.Strings.chars_ptr; 148 end record; 149 pragma Convention (C, C_Data); 150 -- keep in sync with the C structure. 151 152 type C_Data_Access is access C_Data; 153 pragma Convention (C, C_Data_Access); 154 155 function Internal (Widget : System.Address) return C_Data_Access; 156 pragma Import (C, Internal, "gtk_tooltips_data_get"); 157 158 Ptr : constant C_Data_Access := Internal (Get_Object (Widget)); 159 T : constant String := Interfaces.C.Strings.Value (Ptr.Text); 160 P : constant String := Interfaces.C.Strings.Value (Ptr.Privat); 161 Data : Tooltips_Data (Text_Length => T'Length, 162 Private_Length => P'Length); 163 Stub : Gtk_Tooltips_Record; 164 165 begin 166 Data.Tooltips := Gtk_Tooltips (Get_User_Data (Ptr.Tooltips, Stub)); 167 Data.Widget := Gtk.Widget.Gtk_Widget (Widget); 168 Data.Text := T; 169 Data.Text_Private := P; 170 return Data; 171 end Get_Data; 172 173 ---------------- 174 -- Set_Markup -- 175 ---------------- 176 177 procedure Set_Markup 178 (Tooltips : access Gtk_Tooltips_Record; 179 Text : UTF8_String) 180 is 181 procedure Internal 182 (Tooltips : System.Address; 183 Text : UTF8_String); 184 procedure Internal 185 (Tooltips : System.Address; 186 Text : System.Address); 187 pragma Import (C, Internal, "gtk_tooltip_set_markup"); 188 189 begin 190 if Text /= "" then 191 Internal (Get_Object (Tooltips), Text & ASCII.NUL); 192 193 else 194 Internal (Get_Object (Tooltips), System.Null_Address); 195 end if; 196 end Set_Markup; 197 198 ------------------------- 199 -- Set_Icon_From_Stock -- 200 ------------------------- 201 202 procedure Set_Icon_From_Stock 203 (Tooltips : access Gtk_Tooltips_Record; 204 Stock_Id : String; 205 Size : Gtk.Enums.Gtk_Icon_Size) 206 is 207 procedure Internal 208 (Tooltips : System.Address; 209 Stock_Id : UTF8_String; 210 Size : Gtk.Enums.Gtk_Icon_Size); 211 procedure Internal 212 (Tooltips : System.Address; 213 Stock_Id : System.Address; 214 Size : Gtk.Enums.Gtk_Icon_Size); 215 pragma Import (C, Internal, "gtk_tooltip_set_icon_from_stock"); 216 217 begin 218 if Stock_Id /= "" then 219 Internal (Get_Object (Tooltips), Stock_Id & ASCII.NUL, Size); 220 221 else 222 Internal (Get_Object (Tooltips), System.Null_Address, Size); 223 end if; 224 end Set_Icon_From_Stock; 225 226end Gtk.Tooltips; 227