paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-06 00:28:05 +02:00
Code Issues Packages Projects Releases Wiki Activity

No mouse up events for mouse wheel.

Browse Source
This commit is contained in:
Margers 2025-02-17 09:36:11 +00:00 committed by Michael Van Canneyt
parent 0ce9845809
commit 89af29c27f
3 changed files with 15 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
packages/rtl-console/src/inc/mouse.inc
View File

@ -130,8 +130,9 @@ begin
begin begin
if (LastMouseEvent.Buttons=0) then if (LastMouseEvent.Buttons=0) then
MouseEvent.Action:=MouseActionDown MouseEvent.Action:=MouseActionDown
else else { MouseButton4 or MouseButton5 has no Up event, weed them out }
MouseEvent.Action:=MouseActionUp; if ((LastMouseEvent.Buttons and (MouseButton4 or MouseButton5)) = 0) then
MouseEvent.Action:=MouseActionUp;
end; end;
LastMouseEvent:=MouseEvent; LastMouseEvent:=MouseEvent;
end; end;

16
packages/rtl-console/src/unix/keyboard.pp
View File

@ -503,11 +503,12 @@ const
Action : 0; Action : 0;
); );
procedure GenFakeReleaseEvent(MouseEvent : TMouseEvent); procedure GenFakeReleaseEvent(var MouseEvent : TMouseEvent);
begin begin
MouseEvent.action := MouseActionUp; MouseEvent.action := MouseActionUp;
MouseEvent.buttons := 0; MouseEvent.buttons := 0;
PutMouseEvent(MouseEvent); { fake event is to decive LastMouseEvent
PutMouseEvent(MouseEvent); do not make real event }
end; end;
procedure GenMouseEvent; procedure GenMouseEvent;
@ -650,10 +651,13 @@ const
end; end;
*) *)
PutMouseEvent(MouseEvent); PutMouseEvent(MouseEvent);
if (MouseEvent.buttons and (8+16)) <> 0 then // 'M' escape sequence cannot map button 4&5 release, so fake one. if (MouseEvent.buttons and (MouseButton4 or MouseButton5)) <> 0 then
GenFakeReleaseEvent(MouseEvent); GenFakeReleaseEvent(MouseEvent);
if NeedMouseRelease then if NeedMouseRelease then
begin
GenFakeReleaseEvent(MouseEvent); GenFakeReleaseEvent(MouseEvent);
PutMouseEvent(MouseEvent); {rxvt bug, need real event here as workaround }
end;
{$ifdef DebugMouse} {$ifdef DebugMouse}
if MouseEvent.Action=MouseActionDown then if MouseEvent.Action=MouseActionDown then
Write(system.stderr,'Button down : ') Write(system.stderr,'Button down : ')
@ -776,11 +780,11 @@ const
end; end;
end; end;
PutMouseEvent(MouseEvent); PutMouseEvent(MouseEvent);
if (ButtonMask and (8+16)) <> 0 then // 'M' escape sequence cannot map button 4&5 release, so fake one. if (ButtonMask and (MouseButton4 or MouseButton5)) <> 0 then
begin begin
MouseEvent.Action:=MouseActionUp; MouseEvent.Action:=MouseActionUp; {to trick LastMouseEvent pretend that we have MouseActionUp event }
MouseEvent.Buttons:=LastMouseEvent.Buttons and not ButtonMask; MouseEvent.Buttons:=LastMouseEvent.Buttons and not ButtonMask;
PutMouseEvent(MouseEvent); {PutMouseEvent(MouseEvent); do not put actual event }
end; end;
LastMouseEvent:=MouseEvent; LastMouseEvent:=MouseEvent;
end; end;

2
packages/rtl-console/src/win/mouse.pp
View File

@ -104,6 +104,7 @@ procedure MouseEventHandler(var ir:INPUT_RECORD);
e.buttons := e.buttons and not (MouseButton4 or MouseButton5); e.buttons := e.buttons and not (MouseButton4 or MouseButton5);
e.Action := MouseActionUp; e.Action := MouseActionUp;
LastHandlermouseEvent:=e; LastHandlermouseEvent:=e;
{ do not put actual event (fake it just for LastHandlermouseEvent)
while PendingMouseEvents>=MouseEventBufSize do while PendingMouseEvents>=MouseEventBufSize do
begin begin
LeaveCriticalSection(ChangeMouseEvents); LeaveCriticalSection(ChangeMouseEvents);
@ -111,6 +112,7 @@ procedure MouseEventHandler(var ir:INPUT_RECORD);
EnterCriticalSection(ChangeMouseEvents); EnterCriticalSection(ChangeMouseEvents);
end; end;
PutMouseEvent(e); PutMouseEvent(e);
}
end; end;
end; end;
// this should be done in PutMouseEvent, now it is PM // this should be done in PutMouseEvent, now it is PM