Testgtk source code
This code is part of testgtk, a demo application packaged with GtkAda. Testgtk demonstrates the various widgets of GtkAda
-----------------------------------------------------------------------
-- GtkAda - Ada95 binding for the Gimp Toolkit --
-- --
-- Copyright (C) 2000 --
-- Emmanuel Briot, Joel Brobecker and Arnaud Charlet --
-- --
-- This library is free software; you can redistribute it and/or --
-- modify it under the terms of the GNU General Public --
-- License as published by the Free Software Foundation; either --
-- version 2 of the License, or (at your option) any later version. --
-- --
-- This library 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 --
-- General Public License for more details. --
-- --
-- You should have received a copy of the GNU General Public --
-- License along with this library; if not, write to the --
-- Free Software Foundation, Inc., 59 Temple Place - Suite 330, --
-- Boston, MA 02111-1307, USA. --
-- --
--
--
--
--
--
--
--
-----------------------------------------------------------------------
with Glib;
use Glib;
with Gdk.Font;
use Gdk.Font;
with Gtk.Box;
use Gtk.Box;
with Gtk.Dnd;
use Gtk.Dnd;
with Gtk.Selection;
use Gtk.Selection;
with Gdk.Types;
use Gdk.Types;
with Gtk.Enums;
use Gtk.Enums;
with Gtk.Button;
use Gtk.Button;
with Gtk.Table;
use Gtk.Table;
with Gtk.Label;
use Gtk.Label;
with Gtk.Handlers;
use Gtk.Handlers;
with Gtk.Image;
use Gtk.Image;
with Gtkada.Types;
use Gtkada.Types;
with Gtk.Widget;
use Gtk.Widget;
with Gtk.Arguments;
use Gtk.Arguments;
with Interfaces.C.Strings;
with Gdk.Pixmap;
use Gdk.Pixmap;
with Gdk.Bitmap;
use Gdk.Bitmap;
with Gdk.Color;
use Gdk.Color;
with Gdk.Window;
use Gdk.Window;
with Gtk.Frame;
use Gtk.Frame;
pragma Warnings (Off); -- Gtk.Text
is obsolescent
with Gtk.Text;
use Gtk.Text;
pragma Warnings (On);
with Gdk.Dnd;
use Gdk.Dnd;
package body Create_Dnd
is
function "+" (S : String)
return Interfaces.C.Strings.chars_ptr
renames Interfaces.C.Strings.New_String;
Drag_Icon_Xpm :
constant Gtkada.Types.Chars_Ptr_Array
:= "36 48 9 1"
+ " c None"
+ ". c #020204"
+ "+ c #8F8F90"
+ "@ c #D3D3D2"
+ "# c #AEAEAC"
+ "$ c #ECECEC"
+ "% c #A2A2A4"
+ "& c #FEFEFC"
+ "* c #BEBEBC"
+ " ....................."
+ " ..&&&&&&&&&&&&&&&&&&&."
+ " ...&&&&&&&&&&&&&&&&&&&."
+ " ..&.&&&&&&&&&&&&&&&&&&&."
+ " ..&&.&&&&&&&&&&&&&&&&&&&."
+ " ..&&&.&&&&&&&&&&&&&&&&&&&."
+ " ..&&&&.&&&&&&&&&&&&&&&&&&&."
+ " ..&&&&&.&&&@&&&&&&&&&&&&&&&."
+ " ..&&&&&&.*$%$+$&&&&&&&&&&&&&."
+ " ..&&&&&&&.%$%$+&&&&&&&&&&&&&&."
+ " ..&&&&&&&&.#@$&&&&&&&&&&&&&&."
+ " ..&&&&&&&&&.#$**#$&&&&&&&&&&&&&."
+ " ..&&&&&&&&&&.&@%&%$&&&&&&&&&&&&&."
+ " ..&&&&&&&&&&&.&&&&&&&&&&&&&&&&&&&."
+ " ..&&&&&&&&&&&&.&&&&&&&&&&&&&&&&&&&."
+ "................&$@&&&@&&&&&&&&&&&&."
+ ".&&&&&&&+&@%#+@#@*$%$+$&&&&&&&&&&."
+ ".&&&&&&&+&@#@&&@*%$%$+&&&&&&&&&&&."
+ ".&&&&&&&+&$%@@@#@$&&&&&&&&&&&."
+ ".&&&&&&@#@@$&*@&@#@#$**#$&&&&&&&&&&."
+ ".&&&&&&&&&&&&&&&&&&&@%&%$&&&&&&&&&&."
+ ".&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&."
+ ".&&&&&&&&$#@@$&&&&&&&&&&&&&&&&&&&&&."
+ ".&&&&&&&&&+&$+&$&@&$@&&$@&&&&&&&&&&."
+ ".&&&&&&&&&+&@%#+@#@*$%&+$&&&&&&&&."
+ ".&&&&&&&&&+&@#@&&@*%$%$+&&&&&&&&&."
+ ".&&&&&&&&&+&$%@@@#@$&&&&&&&&&."
+ ".&&&&&&&&@#@@$&*@&@#@#$#*#$&&&&&&&&."
+ ".&&&&&&&&&&&&&&&&&&&&&$%&%$&&&&&&&&."
+ ".&&&&&&&&&&$#@@$&&&&&&&&&&&&&&&&&&&."
+ ".&&&&&&&&&&&+&$%&$$@&$@&&$@&&&&&&&&."
+ ".&&&&&&&&&&&+&@%#+@#@*$%$+$&&&&&&."
+ ".&&&&&&&&&&&+&@#@&&@*#$%$+&&&&&&&."
+ ".&&&&&&&&&&&+&$+&*@@@#@$&&&&&&&."
+ ".&&&&&&&&&&$%@@&&*@&@#@#$#*#&&&&&&&."
+ ".&&&&&&&&&&&&&&&&&&&&&&&$%&%$&&&&&&."
+ ".&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&."
+ ".&&&&&&&&&&&&&&$#@@$&&&&&&&&&&&&&&&."
+ ".&&&&&&&&&&&&&&&+&$%&$$@&$@&&$@&&&&."
+ ".&&&&&&&&&&&&&&&+&@%#+@#@*$%$+$&&."
+ ".&&&&&&&&&&&&&&&+&@#@&&@*#$%$+&&&."
+ ".&&&&&&&&&&&&&&&+&$+&*@@@#@$&&&."
+ ".&&&&&&&&&&&&&&$%@@&&*@&@#@#$#*#&&&."
+ ".&&&&&&&&&&&&&&&&&&&&&&&&&&&$%&%$&&."
+ ".&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&."
+ ".&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&."
+ ".&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&."
+ "....................................";
Trashcan_Closed_Xpm :
constant Gtkada.Types.Chars_Ptr_Array
:= "64 80 17 1"
+ " c None"
+ ". c #030304"
+ "+ c #5A5A5C"
+ "@ c #323231"
+ "# c #888888"
+ "$ c #1E1E1F"
+ "% c #767677"
+ "& c #494949"
+ "* c #9E9E9C"
+ "= c #111111"
+ "- c #3C3C3D"
+ "; c #6B6B6B"
+ "> c #949494"
+ ", c #282828"
+ "' c #808080"
+ ") c #545454"
+ "! c #AEAEAC"
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " ==......=$$...=== "
+ " ..$------)+++++++++++++@$$... "
+ " ..=@@-------&+++++++++++++++++++-.... "
+ " =.$$@@@-&&)++++)-,$$$$=@@&+++++++++++++,..$ "
+ " .$$$$@@&+++++++&$$$@@@@-&,$,-++++++++++;;;&.. "
+ " $$$$,@--&++++++&$$)++++++++-,$&++++++;%%'%%;;$@ "
+ " .-@@-@-&++++++++-@++++++++++++,-++++++;''%;;;%*-$ "
+ " +------++++++++++++++++++++++++++++++;;%%%;;##*!. "
+ " =+----+++++++++++++++++++++++;;;;;;;;;;;;%'>>). "
+ " .=)&+++++++++++++++++;;;;;;;;;;;;;;%''>>#>#@. "
+ " =..=&++++++++++++;;;;;;;;;;;;;%###>>###+%== "
+ " .&....=-+++++%;;####''''''''''##'%%%)..#. "
+ " .+-++@....=,+%#####'%%%%%%%%%;@$-@-@*++!. "
+ " .+-++-+++-&-@$$=$=......$,,,@;&)+!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " =+-++-+++-+++++++++!++++!++++!+++!++!+++= "
+ " $.++-+++-+++++++++!++++!++++!+++!++!+.$ "
+ " =.++++++++++++++!++++!++++!+++!++.= "
+ " $..+++++++++++++++!++++++...$ "
+ " $$=.............=$$ "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " ";
Trashcan_Open_Xpm :
constant Gtkada.Types.Chars_Ptr_Array :=
"64 80 17 1"
+ " c None"
+ ". c #030304"
+ "+ c #5A5A5C"
+ "@ c #323231"
+ "# c #888888"
+ "$ c #1E1E1F"
+ "% c #767677"
+ "& c #494949"
+ "* c #9E9E9C"
+ "= c #111111"
+ "- c #3C3C3D"
+ "; c #6B6B6B"
+ "> c #949494"
+ ", c #282828"
+ "' c #808080"
+ ") c #545454"
+ "! c #AEAEAC"
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " .=.==.,@ "
+ " ==.,@-&&&)-= "
+ " .$@,&++;;;%>*- "
+ " $,-+)+++%%;;'#+. "
+ " =---+++++;%%%;%##@. "
+ " @)++++++++;%%%%'#%$ "
+ " $&++++++++++;%%;%##@= "
+ " ,-++++)+++++++;;;'#%) "
+ " @+++&&--&)++++;;%'#'-. "
+ " ,&++-@@,,,,-)++;;;'>'+, "
+ " =-++&@$@&&&&-&+;;;%##%+@ "
+ " =,)+)-,@@&+++++;;;;%##%&@ "
+ " @--&&,,@&)++++++;;;;'#)@ "
+ " ---&)-,@)+++++++;;;%''+, "
+ " $--&)+&$-+++++++;;;%%'';- "
+ " .,-&+++-$&++++++;;;%''%&= "
+ " $,-&)++)-@++++++;;%''%), "
+ " =,@&)++++&&+++++;%'''+$@&++++++ "
+ " .$@-++++++++++++;'#';,........=$@&++++ "
+ " =$@@&)+++++++++++'##-.................=&++ "
+ " .$$@-&)+++++++++;%#+$.....................=)+ "
+ " $$,@-)+++++++++;%;@=........................,+ "
+ " .$$@@-++++++++)-)@=............................ "
+ " $,@---)++++&)@===............................,. "
+ " $-@---&)))-$$=..............................=)!. "
+ " --&-&&,,$=,==...........................=&+++!. "
+ " =,=$..=$+)+++++&@$=.............=$@&+++++!++!. "
+ " .)-++-+++++++++++++++++++++++++++!++!++!. "
+ " .+-++-+++++++++++++++++++++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!+++!!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "
+ " =+-++-+++-+++++++++!++++!++++!+++!++!+++= "
+ " $.++-+++-+++++++++!++++!++++!+++!++!+.$ "
+ " =.++++++++++++++!++++!++++!+++!++.= "
+ " $..+++++++++++++++!++++++...$ "
+ " $$==...........==$$ "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " "
+ " ";
Have_Drag : Boolean := False;
Log : Gtk_Text;
Drag_Icon : Gdk_Pixmap;
Drag_Mask : Gdk_Bitmap;
Trashcan_Open : Gdk_Pixmap;
Trashcan_Closed : Gdk_Pixmap;
Trashcan_Open_Mask : Gdk_Bitmap;
Trashcan_Closed_Mask : Gdk_Bitmap;
My_Target_String1 :
constant Guint := 0;
My_Target_String2 :
constant Guint := 1;
My_Target_Url :
constant Guint := 2;
My_Target_Rootwin :
constant Guint := 3;
package Widget_Callback
is new
Gtk.Handlers.Callback (Gtk.Widget.Gtk_Widget_Record);
package Return_Callback
is new
Gtk.Handlers.Return_Callback (Gtk.Widget.Gtk_Widget_Record, Boolean);
Target_Table :
constant Target_Entry_Array
:= ((+"STRING", Target_No_Constraint, My_Target_String1),
(+"text/plain", Target_No_Constraint, My_Target_String2),
(+"text/uri-list", Target_No_Constraint, My_Target_Url),
(+"application/x-rootwin-drop", Target_No_Constraint,
My_Target_Rootwin));
-- all the known data types in this application. Any MIME type can be used,
-- as well a strings defined in the motif protocol, like "STRING".
Target_Table_String :
constant Target_Entry_Array
:= ((+"STRING", Target_No_Constraint, My_Target_String1),
(+"text/plain", Target_No_Constraint, My_Target_String2));
-- For a drop site that only accepts Data of type STRING or text/plain
Target_Table_Url :
constant Target_Entry_Array
:= (1 => (+"text/uri-list", Target_No_Constraint, My_Target_Url));
-- For a drop site that only accepts Data of type url.
----------
-- Help --
----------
function Help
return String
is
begin
return "This demo demonstrates the drag-
and-drop features
of GtkAda."
& " Several @bdrag-
and-drop@B (dnd) protocols are supported, so that"
& " your application can easily communicate
with other external codes,"
& " but this
is mostly transparent
for you."
& ASCII.LF
& "Although providing dnd capabilities
in your application
is not"
& " difficult, it requires you to take care
of several things, which"
& " might be a little bit tricky the first time. You should look
at"
& " this demo
while reading its source code, extensively documented"
& "
in testgtk/create_dnd.adb
in the GtkAda distribution."
& ASCII.LF
& "Several things worth noting
in this demo:"
& ASCII.LF
& ASCII.LF
& " - Several @bdrag sources@B are available. The first only knows"
& " how to transmitted plain text data. The second one only knows"
& " about URLs, whereas the third one can provide any
of the above."
& ASCII.LF
& ASCII.LF
& " - Several @bdrop sites@B are also provided. Like the drag sources,"
& " they
all have special attributes
and accept only special types"
& "
of data. Thus, some dnd operations will simply be rejected
if"
& " there
is no common
type between the drag source
and the drop site."
& ASCII.LF
& ASCII.LF
& " - In addition,
all of the above have special types
of @bactions@B"
& " that they can handle. These are either @bAction_Copy@B,"
& " @bAction_Move@B,
or a combination
of the two. These actions"
& " control the default behavior
of the drag
and drop operation. The"
& " action selected will be the first one common to both the drag"
& " source
and the drop site, unless you press @bshift@B
at the same"
& " time to force a move. Notice than
when Action_Move
is selected,"
& " GtkAda asks the drag source to delete the data, thus the Delete"
& " message that you see on the output."
& ASCII.LF
& ASCII.LF
& " - The @btrashcan@B has a special behavior, since no default"
& " behavior
is associated to it,
and everything
is managed directly"
& " by the demo, by connecting to the appropriate signals. We also"
& " chose to change its visual aspect
when the mouse
is over the"
& " widget
and a drag-
and-drop operation
is taking place."
& ASCII.LF
& ASCII.LF
& " - The @bicons@B can be freely modified. Note that the pixmap used"
& "
when dragging from the first button
is different than the one used"
& "
for the other buttons. This can provide some interesting visual"
& " clues
for the user.";
end Help;
-------------
-- Put_Log --
-------------
procedure Put_Log (Str : String)
is
begin
Insert (Log,
Gdk.Font.Null_Font,
Fore => Gdk.Color.Null_Color,
Back => Gdk.Color.Null_Color,
Chars => Str & ASCII.LF);
end Put_Log;
----------------------
-- Target_Drag_Drop --
----------------------
-- A handler called for the signal "drag_drop", ie every time the user
-- drops something on Widget.
-- You need to provide such a handler when you do not provide any
-- default behavior in Dest_Set, as is the case for the pixmap in Run.
--
-- Note that even if there is no common target between the drag source
-- and the drop site, this handler is called anyway. However, since
-- Get_Targets will return a Null_List, nothing will be printed.
--
-- This is the general form for handlers of "drag_drop".
function Target_Drag_Drop
(Widget :
access Gtk_Widget_Record'Class;
Args : Gtk_Args)
return Boolean
is
Context : Drag_Context := Drag_Context (To_C_Proxy (Args, 1));
X : Gint := To_Gint (Args, 2);
Y : Gint := To_Gint (Args, 3);
Time : Guint := To_Guint (Args, 4);
pragma Warnings (Off, Context);
pragma Warnings (Off, X);
pragma Warnings (Off, Y);
pragma Warnings (Off, Time);
use type Guint_List.Glist;
begin
Have_Drag := False;
Put_Log ("Drop");
Set (Gtk_Image (Widget), Trashcan_Closed, Trashcan_Closed_Mask);
return False;
end Target_Drag_Drop;
-------------------------------
-- Target_Drag_Data_Received --
-------------------------------
-- This function is called automatically every time some new data
-- has been received on the trash can.
--
-- This is the general form of handlers for "drag_data_received".
procedure Target_Drag_Data_Received
(Widget :
access Gtk.Widget.Gtk_Widget_Record'Class;
Args :
in Gtk_Args)
is
Context :
constant Drag_Context := Drag_Context (To_C_Proxy (Args, 1));
X : Gint := To_Gint (Args, 2);
Y : Gint := To_Gint (Args, 3);
Data :
constant Selection_Data := Selection_Data (To_C_Proxy (Args, 4));
Info : Guint := To_Guint (Args, 5); -- third item
of the Target_Entry
Time :
constant Guint := To_Guint (Args, 6);
pragma Warnings (Off, Widget);
pragma Warnings (Off, X);
pragma Warnings (Off, Y);
pragma Warnings (Off, Info);
begin
if Get_Length (Data) >= 0
and then Get_Format (Data) = 8
then
Put_Log ("Received " & Get_Data_As_String (Data) & "
in trashcan");
Finish
(Context, Success => True, Del => False, Time => Guint32 (Time));
else
Finish
(Context, Success => False, Del => False, Time => Guint32 (Time));
end if;
end Target_Drag_Data_Received;
------------------------
-- Target_Drag_Motion --
------------------------
-- This is the handler for the signal "drag_motion".
-- It is called every time the user is doing a drag-and-drop operation, and
-- the mouse is currently over Widget (but not released yet).
-- This is used to change the visual aspect of Widget to provide visual
-- clues to the user.
-- This is the general form for handlers of "drag_motion".
function Target_Drag_Motion (Widget :
access Gtk_Widget_Record'Class;
Args : Gtk_Args)
return Boolean
is
Context :
constant Drag_Context := Drag_Context (To_C_Proxy (Args, 1));
X : Gint := To_Gint (Args, 2);
Y : Gint := To_Gint (Args, 3);
Time :
constant Guint := To_Guint (Args, 4);
pragma Warnings (Off, X);
pragma Warnings (Off, Y);
Toto : Gtk_Image;
begin
if not Have_Drag
then
Have_Drag := True;
Toto := Gtk_Image (Widget);
Set (Toto, Trashcan_Open, Trashcan_Open_Mask);
end if;
Drag_Status (Context, Get_Suggested_Action (Context), Guint32 (Time));
return True;
end Target_Drag_Motion;
-----------------------
-- Target_Drag_Leave --
-----------------------
-- A handler called whenever a drag-and-drop operation is being performed,
-- and the mouse has just left the area covered by Widget on the screen.
-- This is used to restore the default visual aspect of Widget.
--
-- Leave is also called when the drop is done on Widget.
--
-- This is the general form of handlers for "drag_leave".
procedure Target_Drag_Leave (Widget :
access Gtk_Widget_Record'Class;
Args : Gtk_Args)
is
Context : Drag_Context := Drag_Context (To_C_Proxy (Args, 1));
Time : Guint := To_Guint (Args, 2);
pragma Warnings (Off, Context);
pragma Warnings (Off, Time);
begin
Put_Log ("Leave");
Have_Drag := False;
Set (Gtk_Image (Widget), Trashcan_Closed, Trashcan_Closed_Mask);
end Target_Drag_Leave;
------------------------------
-- Label_Drag_Data_Received --
------------------------------
-- This function is called automatically every time some new data
-- has been received on the label "Drop Here".
--
-- This is the general form of handlers for "drag_data_received".
procedure Label_Drag_Data_Received
(Widget :
access Gtk.Widget.Gtk_Widget_Record'Class;
Args :
in Gtk_Args)
is
Context :
constant Drag_Context := Drag_Context (To_C_Proxy (Args, 1));
X : Gint := To_Gint (Args, 2);
Y : Gint := To_Gint (Args, 3);
Data :
constant Selection_Data := Selection_Data (To_C_Proxy (Args, 4));
Info : Guint := To_Guint (Args, 5); -- third item
of the Target_Entry
Time :
constant Guint := To_Guint (Args, 6);
pragma Warnings (Off, Widget);
pragma Warnings (Off, X);
pragma Warnings (Off, Y);
pragma Warnings (Off, Info);
begin
-- Put_Log ("Selection=" & Atom_Name (Get_Selection (Data)));
-- Put_Log ("Target=" & Atom_Name (Get_Target (Data)));
-- Put_Log ("Type=" & Atom_Name (Get_Type (Data)));
-- Put_Log ("Source Actions="
-- & Drag_Action'Image (Get_Actions (Context)));
-- Put_Log ("Suggested Action="
-- & Drag_Action'Image (Get_Suggested_Action (Context)));
-- Put_Log ("Action=" & Drag_Action'Image (Get_Action (Context)));
if Get_Length (Data) >= 0
and then Get_Format (Data) = 8
then
Put_Log ("Received "
& Get_Data_As_String (Data)
& "
in label");
Gtk.Dnd.Finish
(Context, Success => True, Del => False, Time => Guint32 (Time));
else
Gtk.Dnd.Finish
(Context, Success => False, Del => False, Time => Guint32 (Time));
end if;
end Label_Drag_Data_Received;
--------------------------
-- Source_Drag_Data_Get --
--------------------------
-- This is called when the user has dropped the item, and GtkAda needs
-- to know what was actually dragged. The source widget should thus give
-- some data, that will be transmitted to the drop widget through the
-- signal "drag_data_received".
--
-- This is the general form of handlers for "drag_data_get".
procedure Source_Drag_Data_Get
(Widget :
access Gtk.Widget.Gtk_Widget_Record'Class;
Args :
in Gtk_Args)
is
Context : Drag_Context := Drag_Context (To_C_Proxy (Args, 1));
Data :
constant Selection_Data := Selection_Data (To_C_Proxy (Args, 2));
Info :
constant Guint := To_Guint (Args, 3);
-- third item of the Target_Entry
Time : Guint := To_Guint (Args, 4);
pragma Warnings (Off, Widget);
pragma Warnings (Off, Context);
pragma Warnings (Off, Time);
begin
if Info = My_Target_Rootwin
then
Put_Log ("I was dropped on the root window");
elsif Info = My_Target_Url
then
Selection_Data_Set (Data, Get_Target (Data), 8,
"file://www.act-europe.fr");
else
Selection_Data_Set (Data, Get_Target (Data), 8,
"I'm Data!, Info was " & Guint'Image (Info));
end if;
end Source_Drag_Data_Get;
-----------------------------
-- Source_Drag_Data_Delete --
-----------------------------
-- This handler is called whenever the drop site of a drag-and-drop
-- operation has decided that the data should be deleted, or if the
-- selected action was Action_Move.
--
-- This is the general handler type for "drag_data_delete".
procedure Source_Drag_Data_Delete
(Widget :
access Gtk.Widget.Gtk_Widget_Record'Class;
Args : Gtk_Args)
is
Context : Drag_Context := Drag_Context (To_C_Proxy (Args, 1));
pragma Warnings (Off, Context);
pragma Warnings (Off, Widget);
begin
Put_Log ("Delete the data!");
end Source_Drag_Data_Delete;
---------
-- Run --
---------
procedure Run (Frame :
access Gtk.Frame.Gtk_Frame_Record'Class)
is
Table : Gtk_Table;
Label : Gtk_Label;
Button : Gtk_Button;
Pixmap : Gtk_Image;
Box : Gtk_Box;
begin
Set_Label (Frame, "Drag-
and-Drop");
Gtk_New_Vbox (Box, Homogeneous => False);
Add (Frame, Box);
Gtk_New (Table, 3, 3, False);
Pack_Start (Box, Table);
Create_From_Xpm_D (Drag_Icon,
Null_Window,
Get_Colormap (Frame),
Drag_Mask,
Null_Color,
Drag_Icon_Xpm);
Create_From_Xpm_D (Trashcan_Open,
Null_Window,
Get_Colormap (Frame),
Trashcan_Open_Mask,
Null_Color,
Trashcan_Open_Xpm);
Create_From_Xpm_D (Trashcan_Closed,
Null_Window,
Get_Colormap (Frame),
Trashcan_Closed_Mask,
Null_Color,
Trashcan_Closed_Xpm);
-----------------
-- Drop sites --
-----------------
-- First drop site: a simple label
Gtk_New (Label, "Drop plain text here." & ASCII.LF
& "Action_Move only" & ASCII.LF);
Gtk.Dnd.Dest_Set (Label,
Dest_Default_All,
Target_Table_String, -- only STRING
or text/plain
Action_Move);
Attach (Table, Label, 0, 1, 0, 1);
Widget_Callback.Connect (Label, "drag_data_received",
Label_Drag_Data_Received'Access);
-- Second drop site: a simple label
Gtk_New (Label, "Drop Url here." & ASCII.LF
& "Action_Copy
or Action_Move" & ASCII.LF);
Gtk.Dnd.Dest_Set (Label,
Dest_Default_All,
Target_Table_Url, -- only urls
Action_Copy + Action_Move);
Attach (Table, Label, 1, 2, 0, 1);
Widget_Callback.Connect (Label, "drag_data_received",
Label_Drag_Data_Received'Access);
-- Third drop site: a simple label
Gtk_New (Label, "Drop Anything" & ASCII.LF
& "only Here" & ASCII.LF);
Gtk.Dnd.Dest_Set (Label,
Dest_Default_All,
Target_Table, -- only urls
Action_Copy + Action_Move);
Attach (Table, Label, 2, 3, 0, 1);
Widget_Callback.Connect (Label, "drag_data_received",
Label_Drag_Data_Received'Access);
-----------------
-- Drag sites --
-----------------
-- First Drag site
Gtk_New (Button, "Drag String from Here" & ASCII.LF);
Gtk.Dnd.Source_Set (Button,
Button1_Mask
or Button3_Mask,
Target_Table_String,
Action_Copy + Action_Move);
Attach (Table, Button, 0, 1, 1, 2);
Widget_Callback.Connect (Button, "drag_data_get",
Source_Drag_Data_Get'Access);
Widget_Callback.Connect (Button, "drag_data_delete",
Source_Drag_Data_Delete'Access);
Gtk.Dnd.Source_Set_Icon (Button,
Get_Colormap (Frame),
Drag_Icon, Drag_Mask);
-- Second Drag site
Gtk_New (Button, "Drag Url from Here" & ASCII.LF);
Gtk.Dnd.Source_Set (Button,
Button1_Mask
or Button3_Mask,
Target_Table_Url,
Action_Copy + Action_Move);
Attach (Table, Button, 1, 2, 1, 2);
Widget_Callback.Connect (Button, "drag_data_get",
Source_Drag_Data_Get'Access);
Widget_Callback.Connect (Button, "drag_data_delete",
Source_Drag_Data_Delete'Access);
-- Third Drag site
Gtk_New (Button, "Drag String
or" & ASCII.LF
& "Url from Here" & ASCII.LF);
Gtk.Dnd.Source_Set (Button,
Button1_Mask
or Button3_Mask,
Target_Table,
Action_Copy + Action_Move + Action_Ask);
Attach (Table, Button, 2, 3, 1, 2);
Widget_Callback.Connect (Button, "drag_data_get",
Source_Drag_Data_Get'Access);
Widget_Callback.Connect (Button, "drag_data_delete",
Source_Drag_Data_Delete'Access);
-- Special drop site
Gtk_New (Pixmap, Trashcan_Closed, Trashcan_Closed_Mask);
Gtk.Dnd.Dest_Set (Pixmap);
Attach (Table, Pixmap, 0, 1, 2, 3);
Return_Callback.Connect (Pixmap, "drag_drop",
Target_Drag_Drop'Access);
Widget_Callback.Connect (Pixmap, "drag_data_received",
Target_Drag_Data_Received'Access);
Return_Callback.Connect (Pixmap, "drag_motion",
Target_Drag_Motion'Access);
Widget_Callback.Connect (Pixmap, "drag_leave",
Target_Drag_Leave'Access);
-- The log window
Gtk_New (Log);
Pack_Start (Box, Log);
Show_All (Frame);
end Run;
end Create_Dnd;