1------------------------------------------------------------------------------ 2-- -- 3-- GNAT ncurses Binding -- 4-- -- 5-- Terminal_Interface.Curses.Mouse -- 6-- -- 7-- B O D Y -- 8-- -- 9------------------------------------------------------------------------------ 10-- Copyright 2018,2020 Thomas E. Dickey -- 11-- Copyright 1999-2009,2014 Free Software Foundation, Inc. -- 12-- -- 13-- Permission is hereby granted, free of charge, to any person obtaining a -- 14-- copy of this software and associated documentation files (the -- 15-- "Software"), to deal in the Software without restriction, including -- 16-- without limitation the rights to use, copy, modify, merge, publish, -- 17-- distribute, distribute with modifications, sublicense, and/or sell -- 18-- copies of the Software, and to permit persons to whom the Software is -- 19-- furnished to do so, subject to the following conditions: -- 20-- -- 21-- The above copyright notice and this permission notice shall be included -- 22-- in all copies or substantial portions of the Software. -- 23-- -- 24-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS -- 25-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- 26-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -- 27-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, -- 28-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -- 29-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR -- 30-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. -- 31-- -- 32-- Except as contained in this notice, the name(s) of the above copyright -- 33-- holders shall not be used in advertising or otherwise to promote the -- 34-- sale, use or other dealings in this Software without prior written -- 35-- authorization. -- 36------------------------------------------------------------------------------ 37-- Author: Juergen Pfeifer, 1996 38-- Version Control: 39-- $Revision: 1.28 $ 40-- $Date: 2020/06/27 18:50:44 $ 41-- Binding Version 01.00 42------------------------------------------------------------------------------ 43with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux; 44with Interfaces.C; use Interfaces.C; 45use Interfaces; 46 47package body Terminal_Interface.Curses.Mouse is 48 49 function Has_Mouse return Boolean 50 is 51 function Mouse_Avail return C_Int; 52 pragma Import (C, Mouse_Avail, "has_mouse"); 53 begin 54 if Has_Key (Key_Mouse) or else Mouse_Avail /= 0 then 55 return True; 56 else 57 return False; 58 end if; 59 end Has_Mouse; 60 61 function Get_Mouse return Mouse_Event 62 is 63 type Event_Access is access all Mouse_Event; 64 65 function Getmouse (Ev : Event_Access) return C_Int; 66 pragma Import (C, Getmouse, "getmouse"); 67 68 Event : aliased Mouse_Event; 69 begin 70 if Getmouse (Event'Access) = Curses_Err then 71 raise Curses_Exception; 72 end if; 73 return Event; 74 end Get_Mouse; 75 76 procedure Register_Reportable_Event (Button : Mouse_Button; 77 State : Button_State; 78 Mask : in out Event_Mask) 79 is 80 Button_Nr : constant Natural := Mouse_Button'Pos (Button); 81 State_Nr : constant Natural := Button_State'Pos (State); 82 begin 83 if Button in Modifier_Keys and then State /= Pressed then 84 raise Curses_Exception; 85 else 86 if Button in Real_Buttons then 87 Mask := Mask or ((2 ** (6 * Button_Nr)) ** State_Nr); 88 else 89 Mask := Mask or (BUTTON_CTRL ** (Button_Nr - 4)); 90 end if; 91 end if; 92 end Register_Reportable_Event; 93 94 procedure Register_Reportable_Events (Button : Mouse_Button; 95 State : Button_States; 96 Mask : in out Event_Mask) 97 is 98 begin 99 for S in Button_States'Range loop 100 if State (S) then 101 Register_Reportable_Event (Button, S, Mask); 102 end if; 103 end loop; 104 end Register_Reportable_Events; 105 106 function Start_Mouse (Mask : Event_Mask := All_Events) 107 return Event_Mask 108 is 109 function MMask (M : Event_Mask; 110 O : access Event_Mask) return Event_Mask; 111 pragma Import (C, MMask, "mousemask"); 112 R : Event_Mask; 113 Old : aliased Event_Mask; 114 begin 115 R := MMask (Mask, Old'Access); 116 if R = No_Events then 117 Beep; 118 end if; 119 return Old; 120 end Start_Mouse; 121 122 procedure End_Mouse (Mask : Event_Mask := No_Events) 123 is 124 begin 125 if Mask /= No_Events then 126 Beep; 127 end if; 128 end End_Mouse; 129 130 procedure Dispatch_Event (Mask : Event_Mask; 131 Button : out Mouse_Button; 132 State : out Button_State); 133 134 procedure Dispatch_Event (Mask : Event_Mask; 135 Button : out Mouse_Button; 136 State : out Button_State) is 137 L : Event_Mask; 138 begin 139 Button := Alt; -- preset to non real button; 140 if (Mask and BUTTON1_EVENTS) /= 0 then 141 Button := Left; 142 elsif (Mask and BUTTON2_EVENTS) /= 0 then 143 Button := Middle; 144 elsif (Mask and BUTTON3_EVENTS) /= 0 then 145 Button := Right; 146 elsif (Mask and BUTTON4_EVENTS) /= 0 then 147 Button := Button4; 148 end if; 149 if Button in Real_Buttons then 150 State := Released; -- preset to non real button; 151 L := 2 ** (6 * Mouse_Button'Pos (Button)); 152 for I in Button_State'Range loop 153 if (Mask and L) /= 0 then 154 State := I; 155 exit; 156 end if; 157 L := 2 * L; 158 end loop; 159 else 160 State := Pressed; 161 if (Mask and BUTTON_CTRL) /= 0 then 162 Button := Control; 163 elsif (Mask and BUTTON_SHIFT) /= 0 then 164 Button := Shift; 165 elsif (Mask and BUTTON_ALT) /= 0 then 166 Button := Alt; 167 end if; 168 end if; 169 end Dispatch_Event; 170 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) 176 is 177 Mask : constant Event_Mask := Event.Bstate; 178 begin 179 X := Column_Position (Event.X); 180 Y := Line_Position (Event.Y); 181 Dispatch_Event (Mask, Button, State); 182 end Get_Event; 183 184 procedure Unget_Mouse (Event : Mouse_Event) 185 is 186 function Ungetmouse (Ev : Mouse_Event) return C_Int; 187 pragma Import (C, Ungetmouse, "ungetmouse"); 188 begin 189 if Ungetmouse (Event) = Curses_Err then 190 raise Curses_Exception; 191 end if; 192 end Unget_Mouse; 193 194 function Enclosed_In_Window (Win : Window := Standard_Window; 195 Event : Mouse_Event) return Boolean 196 is 197 function Wenclose (Win : Window; Y : C_Int; X : C_Int) 198 return Curses_Bool; 199 pragma Import (C, Wenclose, "wenclose"); 200 begin 201 if Wenclose (Win, C_Int (Event.Y), C_Int (Event.X)) 202 = Curses_Bool_False 203 then 204 return False; 205 else 206 return True; 207 end if; 208 end Enclosed_In_Window; 209 210 function Mouse_Interval (Msec : Natural := 200) return Natural 211 is 212 function Mouseinterval (Msec : C_Int) return C_Int; 213 pragma Import (C, Mouseinterval, "mouseinterval"); 214 begin 215 return Natural (Mouseinterval (C_Int (Msec))); 216 end Mouse_Interval; 217 218end Terminal_Interface.Curses.Mouse; 219