1 ------------------------------------------------------------------------------
3 -- GNAT ncurses Binding --
5 -- Terminal_Interface.Curses.Mouse --
9 ------------------------------------------------------------------------------
10 -- Copyright (c) 1998-2009,2014 Free Software Foundation, Inc. --
12 -- Permission is hereby granted, free of charge, to any person obtaining a --
13 -- copy of this software and associated documentation files (the --
14 -- "Software"), to deal in the Software without restriction, including --
15 -- without limitation the rights to use, copy, modify, merge, publish, --
16 -- distribute, distribute with modifications, sublicense, and/or sell --
17 -- copies of the Software, and to permit persons to whom the Software is --
18 -- furnished to do so, subject to the following conditions: --
20 -- The above copyright notice and this permission notice shall be included --
21 -- in all copies or substantial portions of the Software. --
23 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS --
24 -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF --
25 -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. --
26 -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, --
27 -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR --
28 -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR --
29 -- THE USE OR OTHER DEALINGS IN THE SOFTWARE. --
31 -- Except as contained in this notice, the name(s) of the above copyright --
32 -- holders shall not be used in advertising or otherwise to promote the --
33 -- sale, use or other dealings in this Software without prior written --
35 ------------------------------------------------------------------------------
36 -- Author: Juergen Pfeifer, 1996
39 -- $Date: 2014/09/13 19:10:18 $
40 -- Binding Version 01.00
41 ------------------------------------------------------------------------------
42 with Terminal_Interface
.Curses
.Aux
; use Terminal_Interface
.Curses
.Aux
;
43 with Interfaces
.C
; use Interfaces
.C
;
46 package body Terminal_Interface
.Curses
.Mouse
is
48 use type System
.Bit_Order
;
50 function Has_Mouse
return Boolean
52 function Mouse_Avail
return C_Int
;
53 pragma Import
(C
, Mouse_Avail
, "has_mouse");
55 if Has_Key
(Key_Mouse
) or else Mouse_Avail
/= 0 then
62 function Get_Mouse
return Mouse_Event
64 type Event_Access
is access all Mouse_Event
;
66 function Getmouse
(Ev
: Event_Access
) return C_Int
;
67 pragma Import
(C
, Getmouse
, "getmouse");
69 Event
: aliased Mouse_Event
;
71 if Getmouse
(Event
'Access) = Curses_Err
then
72 raise Curses_Exception
;
77 procedure Register_Reportable_Event
(Button
: Mouse_Button
;
79 Mask
: in out Event_Mask
)
81 Button_Nr
: constant Natural := Mouse_Button
'Pos (Button
);
82 State_Nr
: constant Natural := Button_State
'Pos (State
);
84 if Button
in Modifier_Keys
and then State
/= Pressed
then
85 raise Curses_Exception
;
87 if Button
in Real_Buttons
then
88 Mask
:= Mask
or ((2 ** (6 * Button_Nr
)) ** State_Nr
);
90 Mask
:= Mask
or (BUTTON_CTRL
** (Button_Nr
- 4));
93 end Register_Reportable_Event
;
95 procedure Register_Reportable_Events
(Button
: Mouse_Button
;
96 State
: Button_States
;
97 Mask
: in out Event_Mask
)
100 for S
in Button_States
'Range loop
102 Register_Reportable_Event
(Button
, S
, Mask
);
105 end Register_Reportable_Events
;
107 function Start_Mouse
(Mask
: Event_Mask
:= All_Events
)
110 function MMask
(M
: Event_Mask
;
111 O
: access Event_Mask
) return Event_Mask
;
112 pragma Import
(C
, MMask
, "mousemask");
114 Old
: aliased Event_Mask
;
116 R
:= MMask
(Mask
, Old
'Access);
117 if R
= No_Events
then
123 procedure End_Mouse
(Mask
: Event_Mask
:= No_Events
)
126 if Mask
/= No_Events
then
131 procedure Dispatch_Event
(Mask
: Event_Mask
;
132 Button
: out Mouse_Button
;
133 State
: out Button_State
);
135 procedure Dispatch_Event
(Mask
: Event_Mask
;
136 Button
: out Mouse_Button
;
137 State
: out Button_State
) is
140 Button
:= Alt
; -- preset to non real button;
141 if (Mask
and BUTTON1_EVENTS
) /= 0 then
143 elsif (Mask
and BUTTON2_EVENTS
) /= 0 then
145 elsif (Mask
and BUTTON3_EVENTS
) /= 0 then
147 elsif (Mask
and BUTTON4_EVENTS
) /= 0 then
150 if Button
in Real_Buttons
then
151 L
:= 2 ** (6 * Mouse_Button
'Pos (Button
));
152 for I
in Button_State
'Range loop
153 if (Mask
and L
) /= 0 then
161 if (Mask
and BUTTON_CTRL
) /= 0 then
163 elsif (Mask
and BUTTON_SHIFT
) /= 0 then
165 elsif (Mask
and BUTTON_ALT
) /= 0 then
171 procedure Get_Event
(Event
: Mouse_Event
;
172 Y
: out Line_Position
;
173 X
: out Column_Position
;
174 Button
: out Mouse_Button
;
175 State
: out Button_State
)
177 Mask
: constant Event_Mask
:= Event
.Bstate
;
179 X
:= Column_Position
(Event
.X
);
180 Y
:= Line_Position
(Event
.Y
);
181 Dispatch_Event
(Mask
, Button
, State
);
184 procedure Unget_Mouse
(Event
: Mouse_Event
)
186 function Ungetmouse
(Ev
: Mouse_Event
) return C_Int
;
187 pragma Import
(C
, Ungetmouse
, "ungetmouse");
189 if Ungetmouse
(Event
) = Curses_Err
then
190 raise Curses_Exception
;
194 function Enclosed_In_Window
(Win
: Window
:= Standard_Window
;
195 Event
: Mouse_Event
) return Boolean
197 function Wenclose
(Win
: Window
; Y
: C_Int
; X
: C_Int
)
199 pragma Import
(C
, Wenclose
, "wenclose");
201 if Wenclose
(Win
, C_Int
(Event
.Y
), C_Int
(Event
.X
))
208 end Enclosed_In_Window
;
210 function Mouse_Interval
(Msec
: Natural := 200) return Natural
212 function Mouseinterval
(Msec
: C_Int
) return C_Int
;
213 pragma Import
(C
, Mouseinterval
, "mouseinterval");
215 return Natural (Mouseinterval
(C_Int
(Msec
)));
218 end Terminal_Interface
.Curses
.Mouse
;