paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-18 16:09:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

build lazarus now always use -w to get entering/leaving marks, improved carbon intf mouse events

Browse Source 
git-svn-id: trunk@8514 -
This commit is contained in:
mattias 2006-01-13 18:43:42 +00:00
parent 9018eba6c8
commit 6e8ee76fb2
10 changed files with 372 additions and 88 deletions

12
Makefile
View File

@ -354,6 +354,9 @@ endif
ifeq ($(FULL_TARGET),powerpc64-linux)
override TARGET_UNITS+=runtimetypeinfocontrols.pas
endif
ifeq ($(FULL_TARGET),powerpc64-linux)
override TARGET_UNITS+=runtimetypeinfocontrols.pas
endif
ifeq ($(FULL_TARGET),i386-linux)
override TARGET_PROGRAMS+=lazarus startlazarus
endif
@ -471,6 +474,9 @@ endif
ifeq ($(FULL_TARGET),powerpc64-linux)
override CLEAN_FILES+=$(wildcard $(COMPILER_UNITTARGETDIR)/*$(OEXT)) $(wildcard $(COMPILER_UNITTARGETDIR)/*$(PPUEXT)) $(wildcard $(COMPILER_UNITTARGETDIR)/*$(RSTEXT)) $(wildcard *$(OEXT)) $(wildcard *$(PPUEXT)) $(wildcard *$(RSTEXT))
endif
ifeq ($(FULL_TARGET),powerpc64-linux)
override CLEAN_FILES+=$(wildcard $(COMPILER_UNITTARGETDIR)/*$(OEXT)) $(wildcard $(COMPILER_UNITTARGETDIR)/*$(PPUEXT)) $(wildcard $(COMPILER_UNITTARGETDIR)/*$(RSTEXT)) $(wildcard *$(OEXT)) $(wildcard *$(PPUEXT)) $(wildcard *$(RSTEXT))
endif
ifeq ($(FULL_TARGET),i386-linux)
override TARGET_EXAMPLEDIRS+=examples
endif
@ -588,6 +594,9 @@ endif
ifeq ($(FULL_TARGET),powerpc64-linux)
override COMPILER_OPTIONS+=-gl
endif
ifeq ($(FULL_TARGET),powerpc64-linux)
override COMPILER_OPTIONS+=-gl
endif
ifeq ($(FULL_TARGET),i386-linux)
override CLEAN_FILES+=$(wildcard *$(OEXT)) $(wildcard *$(PPUEXT)) $(wildcard *$(RSTEXT))
endif
@ -3380,6 +3389,9 @@ endif
ifeq ($(FULL_TARGET),powerpc64-linux)
override COMPILER_UNITDIR+=../../packager/units/$(CPU_TARGET)-$(OS_TARGET)/ ../../packager/units/$(CPU_TARGET)-$(OS_TARGET)/ ./
endif
ifeq ($(FULL_TARGET),powerpc64-linux)
override COMPILER_UNITDIR+=../../ideintf/units/$(CPU_TARGET)-$(OS_TARGET)/ ../../lcl/units/$(CPU_TARGET)-$(OS_TARGET)/ ../../lcl/units/$(CPU_TARGET)-$(OS_TARGET)/$(LCL_PLATFORM)/ ../../packager/units/$(CPU_TARGET)-$(OS_TARGET)/ .
endif
ifeq ($(FULL_TARGET),i386-linux)
TARGET_EXAMPLEDIRS_EXAMPLES=1
endif

2
ide/buildlazdialog.pas
View File

@ -362,6 +362,8 @@ begin
if Result<>mrOk then exit;
if ExtraOptions<>'' then
Tool.EnvironmentOverrides.Values['OPT'] := ExtraOptions;
// add -w option to print leaving/entering messages
Tool.CmdLineParams:=Tool.CmdLineParams+' -w';
// append target OS
if Options.TargetOS<>'' then
Tool.CmdLineParams:=Tool.CmdLineParams+' OS_TARGET='+Options.TargetOS;

87
ide/outputfilter.pas
View File

@ -1023,50 +1023,55 @@ begin
Result:=false;
MakeBeginPattern:= 'make' + GetDefaultExecutableExt + '[';
i:=length(MakeBeginPattern);
if copy(s,1,i)<>MakeBeginPattern then exit;
Result:=true;
CurrentMessageParts.Values['Stage']:='make';
if copy(s,1,i)=MakeBeginPattern then begin
Result:=true;
CurrentMessageParts.Values['Stage']:='make';
inc(i);
if (i>length(s)) or (not (s[i] in ['0'..'9'])) then exit;
while (i<=length(s)) and (s[i] in ['0'..'9']) do inc(i);
if (i>length(s)) or (s[i]<>']') then exit;
// check for enter directory
if copy(s,i,length(EnterDirPattern))=EnterDirPattern then
begin
inc(i,length(EnterDirPattern));
if (fCurrentDirectory<>'') then begin
if (fMakeDirHistory=nil) then fMakeDirHistory:=TStringList.Create;
fMakeDirHistory.Add(fCurrentDirectory);
end;
InternalSetCurrentDirectory(copy(s,i,length(s)-i));
exit;
end;
// check for leaving directory
if copy(s,i,length(LeavingDirPattern))=LeavingDirPattern then
begin
if (fMakeDirHistory<>nil) and (fMakeDirHistory.Count>0) then begin
InternalSetCurrentDirectory(fMakeDirHistory[fMakeDirHistory.Count-1]);
fMakeDirHistory.Delete(fMakeDirHistory.Count-1);
inc(i);
if (i>length(s)) or (not (s[i] in ['0'..'9'])) then exit;
while (i<=length(s)) and (s[i] in ['0'..'9']) do inc(i);
if (i>length(s)) or (s[i]<>']') then exit;
// check for enter directory
if copy(s,i,length(EnterDirPattern))=EnterDirPattern then
begin
inc(i,length(EnterDirPattern));
if (fCurrentDirectory<>'') then begin
if (fMakeDirHistory=nil) then fMakeDirHistory:=TStringList.Create;
fMakeDirHistory.Add(fCurrentDirectory);
end;
InternalSetCurrentDirectory(copy(s,i,length(s)-i));
exit;
end else begin
// leaving what directory???
InternalSetCurrentDirectory('');
end;
end;
// check for make message
if copy(s,i,length(MakeMsgPattern))=MakeMsgPattern then
begin
BracketEnd:=i+length(MakeMsgPattern);
while (BracketEnd<=length(s)) and (s[BracketEnd]<>']') do inc(BracketEnd);
MsgStartPos:=BracketEnd+1;
while (MsgStartPos<=length(s)) and (s[MsgStartPos]=' ') do inc(MsgStartPos);
MakeMsg:=copy(s,MsgStartPos,length(s)-MsgStartPos+1);
DoAddFilteredLine(s);
if AnsiCompareText(copy(MakeMsg,1,5),'Error')=0 then
if (ofoExceptionOnError in Options) then
raise EOutputFilterError.Create(s);
exit;
// check for leaving directory
if copy(s,i,length(LeavingDirPattern))=LeavingDirPattern then
begin
if (fMakeDirHistory<>nil) and (fMakeDirHistory.Count>0) then begin
InternalSetCurrentDirectory(fMakeDirHistory[fMakeDirHistory.Count-1]);
fMakeDirHistory.Delete(fMakeDirHistory.Count-1);
exit;
end else begin
// leaving which directory???
InternalSetCurrentDirectory('');
end;
end;
// check for make message
if copy(s,i,length(MakeMsgPattern))=MakeMsgPattern then
begin
BracketEnd:=i+length(MakeMsgPattern);
while (BracketEnd<=length(s)) and (s[BracketEnd]<>']') do inc(BracketEnd);
MsgStartPos:=BracketEnd+1;
while (MsgStartPos<=length(s)) and (s[MsgStartPos]=' ') do inc(MsgStartPos);
MakeMsg:=copy(s,MsgStartPos,length(s)-MsgStartPos+1);
DoAddFilteredLine(s);
if AnsiCompareText(copy(MakeMsg,1,5),'Error')=0 then
if (ofoExceptionOnError in Options) then
raise EOutputFilterError.Create(s);
exit;
end;
end
else begin
// TODO: under MacOS X and probably BSD too the make does not write
// entering and leaving directory
end;
end;

2
lcl/forms.pp
View File

@ -1339,7 +1339,7 @@ begin
if Keys and MK_LButton <> 0 then Include(Result,ssLeft);
if Keys and MK_RButton <> 0 then Include(Result,ssRight);
if Keys and MK_MButton <> 0 then Include(Result,ssMiddle);
if GetKeyState(VK_MENU) < 0 then Include(Result, ssAlt);
if GetKeyState(VK_MENU) < 0 then Include(Result,ssAlt);
end;
function KeyDataToShiftState(KeyData: Longint): TShiftState;

6
lcl/interfaces/carbon/carbonprivatehiview.inc
View File

@ -23,6 +23,10 @@
// MCarbonWSWinControl_Hit_UPP: EventHandlerUPP = nil;
{ CarbonPrivateHIView_Dispose
Is called when the control is freed by carbon.
Frees the widgetinfo.
}
function CarbonPrivateHIView_Dispose(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AInfo: PWidgetInfo): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
@ -57,7 +61,7 @@ function CarbonPrivateHIView_MouseMove(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AInfo: PWidgetInfo): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
begin
WriteLN('MouseMove');
DebugLn('CarbonPrivateHIView_MouseMove');
Result := CallNextEventHandler(ANextHandler, AEvent);
end;

321
lcl/interfaces/carbon/carbonprivatewindow.inc
View File

@ -19,6 +19,61 @@
// H A N D L E R S
// ==================================================================
function GetCarbonMsgKeyState: PtrInt;
var
Modifiers, ButtonState: UInt32;
begin
Result:=0;
Modifiers := GetCurrentKeyModifiers; // shift, cpntrol, option, command
ButtonState := GetCurrentEventButtonState; // Bit 0 first button (left),
// bit 1 second (right), bit2 third (middle) ...
if (ButtonState and 1)>0 then
inc(Result,MK_LButton);
if (ButtonState and 2)>0 then
inc(Result,MK_RButton);
if (ButtonState and 4)>0 then
inc(Result,MK_MButton);
if (shiftKey and Modifiers)>0 then
inc(Result,MK_Shift);
if (cmdKey and Modifiers)>0 then
inc(Result,MK_Control);
debugln('GetCarbonMsgKeyState Result=',dbgs(KeysToShiftState(Result)),' Modifiers=',hexstr(Modifiers,8),' ButtonState=',hexstr(ButtonState,8));
end;
function GetCarbonShiftState: TShiftState;
var
Modifiers, ButtonState: UInt32;
begin
Result:=[];
Modifiers := GetCurrentKeyModifiers; // shift, cpntrol, option, command
ButtonState := GetCurrentEventButtonState; // Bit 0 first button (left),
// bit 1 second (right), bit2 third (middle) ...
if (ButtonState and 1)>0 then
Include(Result,ssLeft);
if (ButtonState and 2)>0 then
Include(Result,ssRight);
if (ButtonState and 4)>0 then
Include(Result,ssMiddle);
if (shiftKey and Modifiers)>0 then
Include(Result,ssShift);
if (cmdKey and Modifiers)>0 then
Include(Result,ssCtrl);
if (controlKey and Modifiers)>0 then
Include(Result,ssMeta);
if (optionKey and Modifiers)>0 then
Include(Result,ssAlt);
if (alphaLock and Modifiers)>0 then
Include(Result,ssCaps);
debugln('GetCarbonShiftState Result=',dbgs(Result),' Modifiers=',hexstr(Modifiers,8),' ButtonState=',hexstr(ButtonState,8));
end;
function CarbonPrivateWindow_Close(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AInfo: PWidgetInfo): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
@ -58,33 +113,33 @@ begin
FreeWidgetInfo(AInfo);
end;
//Generic function that handles all types of mouse events
{ TrackProgress:
Generic function that handles all mouse dragging events }
procedure TrackProgress(AControl: ControlRef; APartCode: ControlPartCode); {$IFDEF darwin}mwpascal;{$ENDIF}
var
Modifiers, ButtonState: UInt32;
MousePoint: HIPoint;
pt: FPCMacOSAll.Point;
AbsMousePos: FPCMacOSAll.Point;
Window: WindowRef;
R: FPCMacOSAll.Rect;
Msg: TLMMouseMove;
Info:PWidgetInfo;
begin
debugln('TrackProgress');
GetGlobalMouse(Pt);
GetGlobalMouse(AbsMousePos);
Window := HIViewGetWindow(AControl);
GetWindowBounds(Window, kWindowStructureRgn, R);
MousePoint.X := pt.h - R.left;
MousePoint.Y := pt.v - R.Top;
MousePoint.X := AbsMousePos.h - R.Left;
MousePoint.Y := AbsMousePos.v - R.Top;
HIViewConvertPoint(MousePoint, nil, AControl);
Modifiers := GetCurrentKeyModifiers;
ButtonState := GetCurrentButtonState;
FillChar(Msg.Msg,SizeOf(Msg),0);
Msg.Msg := LM_MOUSEMOVE;
Msg.XPos := Trunc(MousePoint.X);
Msg.YPos := Trunc(MousePoint.Y);
Msg.Keys := GetCarbonMsgKeyState;
Info := GetWidgetInfo(AControl);
if Info = nil then begin
//AControl should be fine but if it isn't, default to the window
@ -93,10 +148,12 @@ begin
if Info <> nil
then DeliverMessage(Info^.LCLObject, Msg);
DebugLn('-- track, x:%d, y:%d, m:0x%x, b:0x%x', [Round(MousePoint.X), Round(MousePoint.Y), Modifiers, ButtonState]);
end;
{ CarbonPrivateWindow_ControlTrack
Handles/Creates LM_MOUSEMOVE events while dragging.
For mouse move events while not dragging see below
CarbonPrivateWindow_MouseProc }
function CarbonPrivateWindow_ControlTrack(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AInfo: PWidgetInfo): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
@ -104,8 +161,7 @@ const
MSGKIND: array[1..3] of Integer = (LM_LBUTTONUP, LM_RBUTTONUP, LM_MBUTTONUP);
var
Control: ControlRef;
Modifiers, ButtonState: UInt32;
MousePoint: HIPoint;//QDPoint;
MousePoint: HIPoint;//QDPoint;
ActionUPP, OldActionUPP: ControlActionUPP;
pt: FPCMacOSAll.Point;
MouseButton: EventMouseButton;
@ -113,12 +169,10 @@ var
R: FPCMacOSAll.Rect;
Msg: TLMMouseMove;
begin
DebugLn('-- Control track A');
GetEventParameter(AEvent, kEventParamKeyModifiers, typeUInt32, nil, SizeOf(Modifiers), nil, @Modifiers);
DebugLn('CarbonPrivateWindow_ControlTrack');
GetEventParameter(AEvent, kEventParamWindowMouseLocation, typeHIPoint, nil, SizeOf(MousePoint), nil, @MousePoint);
GetEventParameter(AEvent, kEventParamControlAction, typeControlActionUPP, nil, sizeof(ActionUPP), nil, @OldActionUPP);
GetEventParameter(AEvent, kEventParamMouseButton, typeMouseButton, nil, SizeOf(MouseButton), nil, @MouseButton);
ButtonState := GetCurrentEventButtonState;
ActionUPP := NewControlActionUPP(@TrackProgress);
SetEventParameter(AEvent, kEventParamControlAction, typeControlActionUPP, sizeof(ActionUPP), @ActionUPP);
@ -139,19 +193,16 @@ begin
HIViewConvertPoint(MousePoint, nil, Control);
Modifiers := GetCurrentKeyModifiers;
ButtonState := GetCurrentButtonState;
FillChar(Msg,SizeOf(Msg),0);
if (MouseButton >= Low(MSGKIND))
and (MouseButton <= High(MSGKIND))
then Msg.Msg := MSGKIND[MouseButton];
Msg.XPos := Trunc(MousePoint.X);
Msg.YPos := Trunc(MousePoint.Y);
Msg.Keys := GetCarbonMsgKeyState;
DeliverMessage(AInfo^.LCLObject, Msg);
DebugLn('-- Control track B, x:%d, y:%d, m:0x%x, b:0x%x', [Round(MousePoint.X), Round(MousePoint.Y), Modifiers, ButtonState]);
end;
function CarbonPrivateWindow_MouseProc(ANextHandler: EventHandlerCallRef;
@ -170,15 +221,21 @@ var
var
ClickCount: UInt32;
begin
GetEventParameter(AEvent, kEventParamClickCount, typeUInt32, nil, SizeOf(ClickCount), nil, @ClickCount);
GetEventParameter(AEvent, kEventParamClickCount, typeUInt32, nil,
SizeOf(ClickCount), nil, @ClickCount);
Result := ClickCount;
//debugln('GetClickCount ClickCount=',dbgs(ClickCount));
end;
function GetMouseButton:Integer;
// 1 = left
// 2 = right
// 3 = middle
var
MouseButton: EventMouseButton;
begin
GetEventParameter(AEvent, kEventParamMouseButton, typeMouseButton, nil, SizeOf(MouseButton), nil, @MouseButton);
GetEventParameter(AEvent, kEventParamMouseButton, typeMouseButton, nil,
SizeOf(MouseButton), nil, @MouseButton);
Result := MouseButton;
end;
@ -186,17 +243,30 @@ var
var
MousePoint: HIPoint;//QDPoint;
begin
GetEventParameter(AEvent, kEventParamWindowMouseLocation, typeHIPoint, nil, SizeOf(MousePoint), nil, @MousePoint);
GetEventParameter(AEvent, kEventParamWindowMouseLocation, typeHIPoint, nil,
SizeOf(MousePoint), nil, @MousePoint);
HIViewConvertPoint(MousePoint, nil, Control);
Result.X := Round(MousePoint.X);
Result.Y := Round(MousePoint.Y);
// WriteLn('Mouse to Widget Coords: X=',Result.X,' Y=',Result.Y);
end;
function GetMouseWheelDelta: Integer;
var
WheelDelta: SInt32;
begin
GetEventParameter(AEvent, kEventParamMouseWheelDelta, typeSInt32, nil,
SizeOf(WheelDelta), nil, @WheelDelta);
Result := WheelDelta;
debugln('GetMouseWheelDelta WheelDelta=',dbgs(WheelDelta),' ',hexstr(WheelDelta,8));
end;
//
// handler functions
//
procedure HandleMouseDownEvent(var AMsg);
const
// array of clickcount x buttontype
MSGKIND: array[1..4, 1..3] of Integer = (
(LM_LBUTTONDOWN, LM_RBUTTONDOWN, LM_MBUTTONDOWN),
(LM_LBUTTONDBLCLK, LM_RBUTTONDBLCLK, LM_MBUTTONDBLCLK),
@ -218,23 +288,22 @@ var
MousePoint := GetMousePoint;
if (ClickCount < Low(MSGKIND))
or (ClickCount > Low(MSGKIND))
or (ClickCount > High(MSGKIND))
then ClickCount := 1;
if (MouseButton >= Low(MSGKIND))
and (MouseButton <= High(MSGKIND))
then Msg^.Msg := MSGKIND[ClickCount, MouseButton];
if (MouseButton < Low(MSGKIND[1]))
or (MouseButton > High(MSGKIND[1])) then
exit;
Msg^.Msg := MSGKIND[ClickCount, MouseButton];
//debugln('HandleMouseDownEvent CliCount=',dbgs(ClickCount),' MouseButton=',dbgs(MouseButton),' Msg^.Msg=',dbgs(Msg^.Msg));
Msg^.XPos := MousePoint.X;
Msg^.YPos := MousePoint.Y;
Msg^.Keys := GetCarbonMsgKeyState;
//LMMouse.Keys;
{$Warning CarbonPrivateWindow_MouseProc LMMouse.Keys TODO}
Spec := MakeEventSpec(kEventClassControl, kEventControlTrack);
InstallControlEventHandler(Control, RegisterEventHandler(@CarbonPrivateWindow_ControlTrack),
1, @Spec, Info, nil);
end;
procedure HandleMouseUpEvent(var AMsg);
@ -259,8 +328,7 @@ var
Msg^.XPos := MousePoint.X;
Msg^.YPos := MousePoint.Y;
//LMMouse.Keys;
Msg^.Keys := GetCarbonMsgKeyState;
end;
procedure HandleMouseMovedEvent(var AMsg);
@ -268,7 +336,7 @@ var
MousePoint: TPoint;
MSg: ^TLMMouseMove;
begin
DebugLN('-- mouse move --');
DebugLN('HandleMouseMovedEvent');
Msg := @AMsg;
MousePoint := GetMousePoint;
@ -276,6 +344,7 @@ var
Msg^.Msg := LM_MOUSEMOVE;
Msg^.XPos := MousePoint.X;
Msg^.YPos := MousePoint.Y;
Msg^.Keys := GetCarbonMsgKeyState;
end;
procedure HandleMouseDraggedEvent(var AMsg);
@ -285,9 +354,21 @@ var
end;
procedure HandleMouseWheelEvent(var AMsg);
var
MousePoint: TPoint;
MSg: ^TLMMouseEvent;
begin
DebugLN('-- mouse wheel --');
//TODO should be simple
DebugLN('HandleMouseWheelEvent');
Msg := @AMsg;
MousePoint := GetMousePoint;
Msg^.Msg := LM_MOUSEWHEEL;
Msg^.Button := GetMouseButton;
Msg^.X := MousePoint.X;
Msg^.Y := MousePoint.Y;
Msg^.State := GetCarbonShiftState;
Msg^.WheelDelta := GetMouseWheelDelta;
end;
var
@ -310,7 +391,7 @@ begin
// if a control other than root is found, send the message
// to the control instead of the window
// if a lower control without widgetInfo is found, use its parent
// Note: HIViewGetViewForMouseEvent returns the root if noting found
// Note: HIViewGetViewForMouseEvent returns the root if nothing found
Info := nil;
while Control <> Root do
begin
@ -330,12 +411,13 @@ begin
//For the enter and exit events tracking must be enabled
//tracking is enabled by defining a rect that you want to track
// SEE FPCMacOSAll line 134390
// TODO: Tracking
kEventMouseEntered : Msg.Message.Msg := CM_MOUSEENTER;
kEventMouseExited : Msg.Message.Msg := CM_MOUSELEAVE;
kEventMouseWheelMoved : HandleMouseWheelEvent(Msg);
else
exit(EventNotHandledErr);
end;
// Msg is set in the Appropriate HandleMousexxx procedure
@ -348,6 +430,160 @@ begin
end;
end;
function CarbonPrivateWindow_KeyboardProc(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWIndowInfo: PWidgetInfo): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
var
Control: ControlRef; // the control we are dealing with
// or the rootcontrol if none found
Info: PWidgetInfo; // the info specific to the mouse event
// or the window's widgetinfo if none found
function GetVKKeyCode: word;
var
KeyCode: UInt32;
KeyChar: char;
Buf: array[1..6] of byte;
TextLen: UInt32;
begin
KeyChar:=#0;
KeyCode:=0;
FillChar(Buf,SizeOf(Buf),0);
GetEventParameter(AEvent, kEventParamKeyCode, typeUInt32, nil,
SizeOf(KeyCode), nil, @KeyCode);
GetEventParameter(AEvent, kEventParamKeyMacCharCodes, typeChar, nil,
SizeOf(KeyChar), nil, @KeyChar);
Result:=0;
case KeyCode of
0:
case KeyChar of
'a'..'z': Result:=VK_A+ord(KeyChar)-ord('a');
'A'..'Z': Result:=VK_A+ord(KeyChar)-ord('A');
'+': Result:=VK_ADD;
end;
end;
GetEventParameter(AEvent, kEventParamKeyMacCharCodes, typeChar, nil,
SizeOf(KeyChar), nil, @KeyChar);
GetEventParameter(AEvent, kEventParamKeyUnicodes, typeUnicodeText, nil,
6, @TextLen, @Buf[1]);
debugln('GetVKKeyCode Result=',dbgs(Result),' KeyCode='+dbgs(KeyCode),' KeyChar='+DbgStr(KeyChar),' TextLen='+dbgs(TextLen),
' '+dbgs(Buf[1])+','+dbgs(Buf[2])+','+dbgs(Buf[3])+','+dbgs(Buf[4])+','+dbgs(Buf[5])+','+dbgs(Buf[6]));
end;
function GetCharacterCode: word;
var
KeyChar: char;
Buf: array[1..6] of byte;
TextLen: UInt32;
begin
KeyChar:=#0;
FillChar(Buf,SizeOf(Buf),0);
GetEventParameter(AEvent, kEventParamKeyMacCharCodes, typeChar, nil,
SizeOf(KeyChar), nil, @KeyChar);
GetEventParameter(AEvent, kEventParamKeyUnicodes, typeUnicodeText, nil,
6, @TextLen, @Buf[1]);
Result:=ord(KeyChar);
debugln('GetCharacterCode Result=',dbgs(Result),' KeyChar='+DbgStr(KeyChar),
' '+dbgs(Buf[1])+','+dbgs(Buf[2])+','+dbgs(Buf[3])+','+dbgs(Buf[4])+','+dbgs(Buf[5])+','+dbgs(Buf[6]));
end;
procedure HandleRawKeyDownEvent;
var
KeyMsg: TLMKeyDown;
CharMsg: TLMChar;
begin
DebugLN('HandleRawKeyDownEvent Info^.LCLObject=',DbgSName(Info^.LCLObject));
// create the LM_KEYDOWN message
FillChar(KeyMsg, SizeOf(KeyMsg), 0);
KeyMsg.Msg := LM_KEYDOWN;
KeyMsg.KeyData := GetCarbonMsgKeyState;
KeyMsg.CharCode := GetVKKeyCode;
// Msg is set in the Appropriate HandleKeyxxx procedure
if DeliverMessage(Info^.LCLObject, KeyMsg) = 0 then begin
Result := EventNotHandledErr;
if KeyMsg.CharCode=0 then
exit;
end
else begin
// the LCL does not want the event propagated
Result := noErr;
exit;
end;
// create the LM_CHAR / LM_SYSCHAR message
FillChar(CharMsg, SizeOf(CharMsg), 0);
if (GetCurrentKeyModifiers and optionKey)>0 then
CharMsg.Msg := LM_SYSCHAR
else
CharMsg.Msg := LM_CHAR;
CharMsg.KeyData := GetCarbonMsgKeyState;
CharMsg.CharCode := GetCharacterCode;
// Msg is set in the Appropriate HandleKeyxxx procedure
if DeliverMessage(Info^.LCLObject, CharMsg) = 0 then begin
Result := EventNotHandledErr;
end
else begin
// the LCL does not want the event propagated
Result := noErr;
end;
end;
var
Msg: record
Message: TLMessage;
Extra: array[0..20] of Byte; // some messages are a bit larger, make some room
end;
EventKind: UInt32;
Root: ControlRef;
begin
FillChar(Msg, SizeOf(Msg), 0);
GetRootControl(AWindowInfo^.Widget, Root);
Control := nil;
//HIViewGetViewForMouseEvent(Root, AEvent, Control);
if Control = nil
then Control := Root;
// if a control other than root is found, send the message
// to the control instead of the window
// if a lower control without widgetInfo is found, use its parent
Info := nil;
while Control <> Root do
begin
Info := GetWidgetInfo(Pointer(Control));
if Info <> nil then Break;
Control := HIViewGetSuperview(Control);
end;
if (Info = nil) or (Control = Root)
then Info := AWindowInfo;
EventKind := GetEventKind(AEvent);
case EventKind of
kEventRawKeyDown: HandleRawKeyDownEvent;
else
exit(EventNotHandledErr);
end;
if Msg.Message.Msg=0 then
exit(EventNotHandledErr);
// Msg is set in the Appropriate HandleKeyxxx procedure
if DeliverMessage(Info^.LCLObject, Msg) = 0 then begin
Result := EventNotHandledErr; //CallNextEventHandler(ANextHandler, AEvent);
end
else begin
// the LCL does not want the event propagated
Result := noErr;
end;
end;
// ==================================================================
// C L A S S
// ==================================================================
@ -358,6 +594,7 @@ procedure TCarbonPrivateWindow.RegisterEvents(AInfo: PWidgetInfo);
var
MouseSpec: array [0..6] of EventTypeSpec;
TmpSpec: EventTypeSpec;
KeySpecs: array[0..2] of EventTypeSpec;
begin
TmpSpec := MakeEventSpec(kEventClassWindow, kEventWindowClose);
InstallWindowEventHandler(AInfo^.Widget,
@ -387,7 +624,13 @@ begin
InstallWindowEventHandler(AInfo^.Widget,
RegisterEventHandler(@CarbonPrivateWindow_MouseProc),
7, @MouseSpec[0], Pointer(AInfo), nil);
KeySpecs[0].eventClass := kEventClassKeyboard;
KeySpecs[0].eventKind := kEventRawKeyDown;
InstallWindowEventHandler(AInfo^.Widget,
RegisterEventHandler(@CarbonPrivateWindow_KeyboardProc),
1, @KeySpecs[0], Pointer(AInfo), nil);
end;
procedure TCarbonPrivateWindow.UnregisterEvents;

2
lcl/interfaces/carbon/carbonproc.pp
View File

@ -46,6 +46,8 @@ procedure UnRegisterEventHandler(AHandler: TCarbonWSEventHandlerProc);
function GetCarbonRect(Left, Top, Width, Height: Integer): FPCMacOSAll.Rect;
function GetCarbonRect(const ARect: TRect): FPCMacOSAll.Rect;
function Dbgs(const ARect: FPCMacOSAll.Rect): string; overload;
implementation

18
lcl/interfaces/carbon/carbonwinapi.inc
View File

@ -457,7 +457,23 @@ end;
function TCarbonWidgetSet.GetKeyState(nVirtKey: Integer): Smallint;
begin
Result:=inherited GetKeyState(nVirtKey);
Result:=0;
case nVirtKey of
VK_MENU:
if (GetCurrentKeyModifiers and optionKey)>0 then
// the ssAlt/VK_MENU is mapped to optionKey under MacOS
Result:=-1;
VK_SHIFT:
if (GetCurrentKeyModifiers and shiftKey)>0 then
Result:=-1;
VK_CONTROL:
if (GetCurrentKeyModifiers and cmdKey)>0 then
// the ssCtrl/VK_CONTROL is mapped to optionKey under MacOS
Result:=-1;
else
debugln('TCarbonWidgetSet.GetKeyState TODO ',dbgs(nVirtkey));
end;
end;
function TCarbonWidgetSet.GetObject(GDIObj: HGDIOBJ; BufSize: Integer;

4
lcl/lmessages.pp
View File

@ -397,7 +397,7 @@ type
TLMKey = record
Msg: Cardinal;
CharCode: Word;
CharCode: Word; // VK_XXX constants as TLMKeyDown/Up, ascii if TLMChar
Unused: Word;
{$ifdef cpu64}
Unused2 : Longint;
@ -583,7 +583,7 @@ type
PLMMouseEvent = ^TLMMouseEvent;
TLMMouseEvent = record
Msg : Cardinal;
Button : LongInt;
Button : LongInt; // as TMouseButton, 1=left, 2=right, 3=middle
WheelDelta : Longint; { -1 for up, 1 for down }
State : TShiftState;
X : Integer;

6
lcl/lresources.pp
View File

@ -3057,13 +3057,13 @@ var
{$endif}
begin
{$IFDEF FPC_BIG_ENDIAN}
if SizeOf(e)=10 then begin
{$IFDEF FPC_HAS_TYPE_EXTENDED}
ReverseBytes(@e,10);
Write(e,10);
end else begin
{$ELSE}
ConvertEndianBigDoubleToLRSExtended(@e,@LRSExtended);
Write(LRSExtended,10);
end;
{$ENDIF}
{$ENDIF}
Write(e,10);
end;