1 ------------------------------------------------------------------------------
3 -- GNAT ncurses Binding --
5 -- Terminal_Interface.Curses.Mouse --
9 ------------------------------------------------------------------------------
10 -- Copyright (c) 1998 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
37 -- Contact: http://www.familiepfeifer.de/Contact.aspx?Lang=en
40 -- Binding Version 01.00
41 ------------------------------------------------------------------------------
44 with Terminal_Interface
.Curses
.Aux
; use Terminal_Interface
.Curses
.Aux
;
45 with Interfaces
.C
; use Interfaces
.C
;
48 package body Terminal_Interface
.Curses
.Mouse
is
50 use type System
.Bit_Order
;
51 use type Interfaces
.C
.int
;
53 function Has_Mouse
return Boolean
55 function Mouse_Avail
return C_Int
;
56 pragma Import
(C
, Mouse_Avail
, "_nc_has_mouse");
58 if Has_Key
(Key_Mouse
) or else Mouse_Avail
/= 0 then
65 function Get_Mouse
return Mouse_Event
67 type Event_Access
is access all Mouse_Event
;
69 function Getmouse
(Ev
: Event_Access
) return C_Int
;
70 pragma Import
(C
, Getmouse
, "getmouse");
72 Event
: aliased Mouse_Event
;
74 if Getmouse
(Event
'Access) = Curses_Err
then
75 raise Curses_Exception
;
80 procedure Register_Reportable_Event
(Button
: in Mouse_Button
;
81 State
: in Button_State
;
82 Mask
: in out Event_Mask
)
84 Button_Nr
: constant Natural := Mouse_Button
'Pos (Button
);
85 State_Nr
: constant Natural := Button_State
'Pos (State
);
87 if Button
in Modifier_Keys
and then State
/= Pressed
then
88 raise Curses_Exception
;
90 if Button
in Real_Buttons
then
91 Mask
:= Mask
or ((2 ** (6 * Button_Nr
)) ** State_Nr
);
93 Mask
:= Mask
or (BUTTON_CTRL
** (Button_Nr
- 4));
96 end Register_Reportable_Event
;
98 procedure Register_Reportable_Events
(Button
: in Mouse_Button
;
99 State
: in Button_States
;
100 Mask
: in out Event_Mask
)
103 for S
in Button_States
'Range loop
105 Register_Reportable_Event
(Button
, S
, Mask
);
108 end Register_Reportable_Events
;
110 function Start_Mouse
(Mask
: Event_Mask
:= All_Events
)
113 function MMask
(M
: Event_Mask
;
114 O
: access Event_Mask
) return Event_Mask
;
115 pragma Import
(C
, MMask
, "mousemask");
117 Old
: aliased Event_Mask
;
119 R
:= MMask
(Mask
, Old
'Access);
123 procedure End_Mouse
(Mask
: in Event_Mask
:= No_Events
)
129 procedure Dispatch_Event
(Mask
: in Event_Mask
;
130 Button
: out Mouse_Button
;
131 State
: out Button_State
);
133 procedure Dispatch_Event
(Mask
: in Event_Mask
;
134 Button
: out Mouse_Button
;
135 State
: out Button_State
) is
138 Button
:= Alt
; -- preset to non real button;
139 if (Mask
and BUTTON1_EVENTS
) /= 0 then
141 elsif (Mask
and BUTTON2_EVENTS
) /= 0 then
143 elsif (Mask
and BUTTON3_EVENTS
) /= 0 then
145 elsif (Mask
and BUTTON4_EVENTS
) /= 0 then
148 if Button
in Real_Buttons
then
149 L
:= 2 ** (6 * Mouse_Button
'Pos (Button
));
150 for I
in Button_State
'Range loop
151 if (Mask
and L
) /= 0 then
159 if (Mask
and BUTTON_CTRL
) /= 0 then
161 elsif (Mask
and BUTTON_SHIFT
) /= 0 then
163 elsif (Mask
and BUTTON_ALT
) /= 0 then
169 procedure Get_Event
(Event
: in Mouse_Event
;
170 Y
: out Line_Position
;
171 X
: out Column_Position
;
172 Button
: out Mouse_Button
;
173 State
: out Button_State
)
175 Mask
: constant Event_Mask
:= Event
.Bstate
;
177 X
:= Column_Position
(Event
.X
);
178 Y
:= Line_Position
(Event
.Y
);
179 Dispatch_Event
(Mask
, Button
, State
);
182 procedure Unget_Mouse
(Event
: in Mouse_Event
)
184 function Ungetmouse
(Ev
: Mouse_Event
) return C_Int
;
185 pragma Import
(C
, Ungetmouse
, "ungetmouse");
187 if Ungetmouse
(Event
) = Curses_Err
then
188 raise Curses_Exception
;
192 function Enclosed_In_Window
(Win
: Window
:= Standard_Window
;
193 Event
: Mouse_Event
) return Boolean
195 function Wenclose
(Win
: Window
; Y
: C_Int
; X
: C_Int
)
197 pragma Import
(C
, Wenclose
, "wenclose");
199 if Wenclose
(Win
, C_Int
(Event
.Y
), C_Int
(Event
.X
))
200 = Curses_Bool_False
then
205 end Enclosed_In_Window
;
207 function Mouse_Interval
(Msec
: Natural := 200) return Natural
209 function Mouseinterval
(Msec
: C_Int
) return C_Int
;
210 pragma Import
(C
, Mouseinterval
, "mouseinterval");
212 return Natural (Mouseinterval
(C_Int
(Msec
)));
215 end Terminal_Interface
.Curses
.Mouse
;