paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-13 17:59:32 +02:00
Code Issues Packages Projects Releases Wiki Activity

Carbon intf.:

Browse Source 
- more Carbon call checks
- improved Menus: checks, radio items
- finished TStatusBar
- removed "&" from win control captions
- resolved TForm maximize <-> restored and client x bounds bug

git-svn-id: trunk@10930 -
This commit is contained in:
tombo 2007-04-10 13:29:48 +00:00
parent e57532df45
commit d769236c82
18 changed files with 1395 additions and 575 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -2398,6 +2398,7 @@ lcl/interfacebase.pp svneol=native#text/pascal
lcl/interfaces/LAYOUT.txt svneol=native#text/plain
lcl/interfaces/carbon/README.txt svneol=native#text/plain
lcl/interfaces/carbon/carboncanvas.pp svneol=native#text/pascal
lcl/interfaces/carbon/carbonconsts.pp svneol=native#text/pascal
lcl/interfaces/carbon/carbondebug.inc svneol=native#text/plain
lcl/interfaces/carbon/carbondef.pp svneol=native#text/pascal
lcl/interfaces/carbon/carbonedits.pp svneol=native#text/pascal

68
lcl/interfaces/carbon/carbonconsts.pp Normal file
View File

@ -0,0 +1,68 @@
{
/***************************************************************************
carbonconsts.pp - Carbon string constants
***************************************************************************/
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.modifiedLGPL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
}
unit CarbonConsts;
{$mode objfpc}{$H+}
interface
const
SCreateWidget = 'CreateWidget';
SDestroyWidget = 'DestroyWidget';
SInvalidate = 'Invalidate';
SEnable = 'Enable';
SSetColor = 'SetColor';
SSetText = 'SetText';
SSetControlProp = 'SetControlProperty';
SSetFontStyle = 'SetControlFontStyle';
SCreateBevelButton = 'SCreateBevelButtonControl';
SGetWindowBounds = 'GetWindowBounds';
SViewForMouse = 'HIViewGetViewForMouseEvent';
SViewVisible = 'HIViewSetVisible';
SViewConvert = 'HIViewConvertPoint';
SViewRender = 'HIViewRenderle';
SViewNeedsDisplay = 'HiViewSetNeedsDisplay';
SViewNeedsDisplayRect = 'HiViewSetNeedsDisplayInRect';
SViewAddView = 'HIViewAddSubview';
SEnableControl = 'EnableControl';
SDisableControl = 'DisableControl';
SChangeWindowAttrs = 'ChangeWindowAttributes';
SGetData = 'GetControlData';
SSetData = 'GetControlData';
SGetEvent = 'GetEventParameter';
SSetEvent = 'SetEventParameter';
SInstallEvent = 'InstallEventHandler';
SControlPart = 'kEventParamControlPart';
SKeyModifiers = 'kEventParamKeyModifiers';
SControlFont = 'kControlFontStyleTag';
implementation
end.

5
lcl/interfaces/carbon/carbonedits.pp
View File

@ -306,6 +306,7 @@ begin
finally
FreeCFString(CFString);
end;
FItemIndex := -1;
FMaxLength := 0;
end;
@ -504,9 +505,9 @@ end;
procedure TCarbonMemo.DestroyWidget;
begin
DisposeControl(FScrollView);
inherited DestroyWidget;
DisposeControl(FScrollView);
end;
procedure TCarbonMemo.TextDidChange;

2
lcl/interfaces/carbon/carbonint.pas
View File

@ -39,7 +39,7 @@ uses
// rtl+ftl
Types, Classes, SysUtils, Math, FPCAdds,
// carbon bindings
FPCMacOSAll, CarbonUtils,
FPCMacOSAll, CarbonUtils, CarbonConsts,
// interfacebase
InterfaceBase,
// LCL

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

@ -188,7 +188,7 @@ var
AlertBtnIdx : DialogItemIndex;
I: Integer;
const AName = 'PromptUser';
const SName = 'PromptUser';
begin
{$IFDEF VerboseLCLIntf}
DebugLn('TCarbonWidgetSet.PromptUser DialogCaption: ' + DialogCaption +
@ -292,9 +292,9 @@ begin
try
if OSError(CreateStandardAlert(AlertCode, CaptionStr, MessageStr, @ParamRec, AlertRef),
Self, AName, 'CreateStandardAlert') then Exit;
Self, SName, 'CreateStandardAlert') then Exit;
if OSError(RunStandardAlert(AlertRef, nil, AlertBtnIdx), Self, AName,
if OSError(RunStandardAlert(AlertRef, nil, AlertBtnIdx), Self, SName,
'RunStandardAlert') then Exit;
{Convert Carbon result to LCL "id" dialog result}

76
lcl/interfaces/carbon/carbonmenus.pp
View File

@ -52,6 +52,7 @@ type
protected
procedure RegisterEvents; virtual;
procedure UnregisterEvents; virtual;
procedure Update;
public
LCLMenuItem: TMenuItem; // LCL menu item which created this widget
Menu: MenuRef; // Reference to the Carbon menu
@ -88,11 +89,9 @@ begin
begin
if FParentMenu <> nil then
begin
SetMenuItemHierarchicalMenu(FParentMenu.Menu, GetIndex + 1, Menu);
SetCaption(LCLMenuItem.Caption);
SetBitmap(LCLMenuItem.Bitmap);
SetStyle;
Update;
end;
if FItems = nil then FItems := TObjectList.Create(False);
@ -124,6 +123,22 @@ begin
//
end;
procedure TCarbonMenu.Update;
begin
if FParentMenu = nil then Exit;
// add sub menu if exists
if Menu <> nil then
SetMenuItemHierarchicalMenu(FParentMenu.Menu, GetIndex + 1, Menu);
SetCheck(LCLMenuItem.Checked);
SetBitmap(LCLMenuItem.Bitmap);
SetStyle;
SetVisible(LCLMenuItem.Visible);
SetEnable(LCLMenuItem.Enabled);
end;
constructor TCarbonMenu.Create(const AMenuItem: TMenuItem; WithMenu: Boolean);
begin
inherited Create;
@ -190,12 +205,13 @@ var
CFString: CFStringRef;
Index: Integer;
begin
FParentMenu := AParentMenu;
{$IFDEF VerboseMenu}
DebugLn('TCarbonMenu.Attach ' + LCLMenuItem.Name + ' Index: ' + DbgS(GetIndex) +
' Menu: ' + DbgS(Menu));
{$ENDIF}
FParentMenu := AParentMenu;
Index := GetIndex;
if FParentMenu.FRoot then MenuNeeded; // menu tiem is in toplevel of root menu
@ -223,15 +239,7 @@ begin
SetMenuItemProperty(FParentMenu.Menu, Index + 1,
LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(TCarbonMenu), @Self);
// add sub menu if exists
if Menu <> nil then
SetMenuItemHierarchicalMenu(FParentMenu.Menu, Index + 1, Menu);
SetBitmap(LCLMenuItem.Bitmap);
SetStyle;
SetVisible(LCLMenuItem.Visible);
SetEnable(LCLMenuItem.Enabled);
Update;
end;
procedure TCarbonMenu.AttachToMenuBar;
@ -250,6 +258,7 @@ procedure TCarbonMenu.SetCaption(const ACaption: String);
var
CFString: CFStringRef;
Index: Integer;
S: String;
begin
if FParentMenu = nil then Exit;
@ -261,7 +270,10 @@ begin
Index := GetIndex;
ChangeMenuItemAttributes(FParentMenu.Menu, Index + 1, 0, kMenuItemAttrSeparator);
CreateCFString(LCLMenuItem.Caption, CFString);
S := LCLMenuItem.Caption;
DeleteAmpersands(S);
CreateCFString(S, CFString);
try
SetMenuItemTextWithCFString(FParentMenu.Menu, Index + 1, CFString);
@ -315,7 +327,7 @@ var
IconType: Byte;
AIcon: CGImageRef;
AHandle: FPCMacOSAll.Handle;
const AName = 'TCarbonMenu.SetBitmap';
const SName = 'TCarbonMenu.SetBitmap';
begin
{$IFDEF VerboseMenu}
DebugLn('TCarbonMenu.SetBitmap ' + LCLMenuItem.Name + ' ABitmap: ' + DbgS(ABitmap)
@ -327,7 +339,7 @@ begin
if ABitmap <> nil then
begin
if not CheckBitmap(ABitmap.Handle, AName) then Exit;
if not CheckBitmap(ABitmap.Handle, SName) then Exit;
IconType := kMenuCGImageRefType;
AIcon := TCarbonBitmap(ABitmap.Handle).CGImage;
end;
@ -346,20 +358,37 @@ begin
if OSError(
SetMenuItemIconHandle(FParentMenu.Menu, GetIndex + 1, IconType, AHandle),
AName, 'SetMenuItemIconHandle') then Exit;
SName, 'SetMenuItemIconHandle') then Exit;
if Menu <> nil then
OSError(SetMenuTitleIcon(Menu, IconType, AIcon), AName, 'SetMenuTitleIcon');
OSError(SetMenuTitleIcon(Menu, IconType, AIcon), SName, 'SetMenuTitleIcon');
end;
procedure TCarbonMenu.SetCheck(AChecked: Boolean);
var
I: Integer;
Item: TCarbonMenu;
begin
DebugLn('TCarbonMenu.SetShortCut ' + LCLMenuItem.Caption + ' ' + DbgS(AChecked));
if FParentMenu = nil then Exit;
if AChecked then
begin
if LCLMenuItem.RadioItem then
SetItemMark(FParentMenu.Menu, GetIndex + 1, Char(kDiamondCharCode)) // or kBulletCharCode
begin
SetItemMark(FParentMenu.Menu, GetIndex + 1, Char(kBulletCharCode)); // or kDiamondCharCode
// uncheck siblings
for I := 0 to FParentMenu.FItems.Count - 1 do
begin
Item := TCarbonMenu(FParentMenu.FItems[I]);
if Item = Self then Continue;
if Item.LCLMenuItem.RadioItem and Item.LCLMenuItem.AutoCheck and
(Item.LCLMenuItem.GroupIndex = LCLMenuItem.GroupIndex) then
Item.SetCheck(False);
end;
end
else
SetItemMark(FParentMenu.Menu, GetIndex + 1, Char(kCheckCharCode));
end
@ -373,8 +402,9 @@ var
Shift: TShiftState;
Key: Word;
Index: Integer;
const AName = 'SetShortCut';
const SName = 'SetShortCut';
begin
DebugLn('TCarbonMenu.SetShortCut ' + ShortCutToText(AShortCut));
if FParentMenu = nil then Exit;
ShortCutToKey(AShortCut, Key, Shift);
@ -382,10 +412,10 @@ begin
Index := GetIndex;
if OSError(SetMenuItemModifiers(FParentMenu.Menu, Index + 1,
ShiftStateToModifiers(Shift)),
Self, AName, 'SetMenuItemModifiers') then Exit;
Self, SName, 'SetMenuItemModifiers') then Exit;
OSError(SetMenuItemCommandKey(FParentMenu.Menu, Index + 1, False, Key),
Self, AName, 'SetMenuItemCommandKey');
Self, SName, 'SetMenuItemCommandKey');
end;
procedure TCarbonMenu.SetStyle;

27
lcl/interfaces/carbon/carbonobject.inc
View File

@ -121,8 +121,7 @@ begin
try
TmpSpec := MakeEventSpec(kEventClassApplication, kEventAppQuit);
Result := InstallApplicationEventHandler(QuitUPP, 1, @TmpSpec, nil, @QuitHandler);
if Result <> noErr then Exit;
if not InstallApplicationEventHandler(QuitUPP, 1, @TmpSpec, nil, @QuitHandler) then Exit;
try
// Run our event loop until quitNow is set.
@ -161,7 +160,7 @@ var
CarbonMenu: TCarbonMenu;
Msg: TLMessage;
S: LongWord;
const AName = 'CarbonApp_CommandProcess';
const SName = 'CarbonApp_CommandProcess';
begin
{$IFDEF VerboseAppEvent}
DebugLn('CarbonApp_CommandProcess');
@ -171,7 +170,7 @@ begin
if not OSError(
GetEventParameter(AEvent, kEventParamDirectObject,
typeHICommand, nil, SizeOf(HICommand), nil, @Command),
AName, 'GetEventParameter') then
SName, 'GetEventParameter') then
begin
{$IFDEF VerboseMenu}
DebugLn('CarbonApp_CommandProcess MenuRef: ' + DbgS(Command.menuRef) +
@ -185,7 +184,7 @@ begin
begin
if not OSError(GetMenuItemProperty(Command.menuRef, Command.menuItemIndex,
LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(TCarbonMenu), S, @CarbonMenu),
AName, 'GetMenuItemProperty') then
SName, 'GetMenuItemProperty') then
begin
{$IFDEF VerboseMenu}
DebugLn('CarbonApp_CommandProcess CarbonMenu: ' + DbgS(CarbonMenu));
@ -280,10 +279,8 @@ begin
// standard event handlers are installed while our event loop runs.
EventSpec := MakeEventSpec(LCLCarbonEventClass,LCLCarbonEventKindMain);
if InstallApplicationEventHandler(EventLoopUPP, 1, @EventSpec, nil,
@EventLoopHandler) <> noErr
then
RaiseGDBException('TCarbonWidgetSet.AppRun install eventhandler failed');
if not InstallApplicationEventHandler(EventLoopUPP, 1, @EventSpec, nil,
@EventLoopHandler) then Exit;
try
if CreateEvent(nil, EventSpec.eventClass, EventSpec.eventKind,
@ -561,7 +558,7 @@ end;
procedure TCarbonWidgetSet.AppBringToFront;
var
Proc: ProcessSerialNumber;
const AName = 'AppBringToFront';
const SName = 'AppBringToFront';
begin
{$IFDEF VerboseObject}
DebugLn('TCarbonWidgetSet.AppBringToFront');
@ -572,8 +569,8 @@ begin
34. How do I bring all my windows to the front?
*)
if OSError(GetCurrentProcess(Proc), Self, AName, 'GetCurrentProcess') then Exit;
OSError(SetFrontProcess(Proc), Self, AName, 'SetFrontProcess');
if OSError(GetCurrentProcess(Proc), Self, SName, 'GetCurrentProcess') then Exit;
OSError(SetFrontProcess(Proc), Self, SName, 'SetFrontProcess');
end;
{------------------------------------------------------------------------------
@ -592,7 +589,7 @@ end;
Attaches the menu of window to menu bar
------------------------------------------------------------------------------}
procedure TCarbonWidgetSet.AttachMenuToWindow(AMenuObject: TComponent);
const AName = 'TCarbonWidgetSet.AttachMenuToWindow';
const SName = 'TCarbonWidgetSet.AttachMenuToWindow';
begin
{$IFDEF VerboseObject}
DebugLn('TCarbonWidgetSet.AttachMenuToWindow ' + AMenuObject.Name);
@ -600,11 +597,11 @@ begin
if (AMenuObject is TMainMenu) and (TMainMenu(AMenuObject).Handle <> 0) then
begin
if not CheckMenu(TMainMenu(AMenuObject).Handle, AName) then Exit;
if not CheckMenu(TMainMenu(AMenuObject).Handle, SName) then Exit;
if FMainMenu <> nil then
begin
DebugLn(AName + ' Unable to change main menu - menu bar is set yet!');
DebugLn(SName + ' Unable to change main menu - menu bar is set yet!');
Exit;
end;

569
lcl/interfaces/carbon/carbonprivate.pp
View File

@ -36,7 +36,7 @@ uses
// widgetset
WSControls, WSLCLClasses, WSProc,
// LCL Carbon
CarbonUtils, CarbonDef,
CarbonUtils, CarbonDef, CarbonConsts,
// LCL
LMessages, LCLMessageGlue, LCLProc, LCLType, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, ExtCtrls, Menus;
@ -296,6 +296,12 @@ implementation
uses InterfaceBase, CarbonProc, CarbonWSStdCtrls, CarbonStrings,
CarbonGDIObjects;
{------------------------------------------------------------------------------
Name: RaiseCreateWidgetError
Params: AControl - Which control was being created
Raises exception for widget creation error
------------------------------------------------------------------------------}
procedure RaiseCreateWidgetError(AControl: TWinControl);
begin
raise Exception.CreateFmt('Unable to create Carbon widget for %s: %s!',
@ -317,27 +323,44 @@ var SavedMouseUpMsg: TLMMouse;
{ TCarbonHintWindow }
{------------------------------------------------------------------------------
Method: TCarbonHintWindow.CreateWidget
Params: AParams - Creation parameters
Creates Carbon hint window
------------------------------------------------------------------------------}
procedure TCarbonHintWindow.CreateWidget(const AParams: TCreateParams);
var
Window: WindowRef;
begin
if CreateNewWindow(kHelpWindowClass,
kWindowCompositingAttribute or
kWindowHideOnSuspendAttribute or kWindowStandardHandlerAttribute,
ParamsToCarbonRect(AParams), Window) = noErr then
begin
Widget := Window;
if OSError(
CreateNewWindow(kHelpWindowClass,
kWindowCompositingAttribute or
kWindowHideOnSuspendAttribute or kWindowStandardHandlerAttribute,
ParamsToCarbonRect(AParams), Window),
Self, SCreateWidget, 'CreateNewWindow') then RaiseCreateWidgetError(LCLObject);
SetWindowProperty(Widget, LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(Self), @Self);
SetControlProperty(Content, LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(Self), @Self);
end
else RaiseCreateWidgetError(LCLObject);
Widget := Window;
OSError(
SetWindowProperty(Widget, LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(Self), @Self),
Self, SCreateWidget, 'SetWindowProperty');
OSError(
SetControlProperty(Content, LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(Self), @Self),
Self, SCreateWidget, SSetControlProp);
SetColor(LCLObject.Color);
end;
{ TCarbonCustomControl }
{------------------------------------------------------------------------------
Method: TCarbonCustomControl.CreateWidget
Params: AParams - Creation parameters
Creates Carbon custom control
------------------------------------------------------------------------------}
procedure TCarbonCustomControl.CreateWidget(const AParams: TCreateParams);
var
Control: ControlRef;
@ -349,58 +372,59 @@ begin
kControlSupportsSetCursor or kControlSupportsContextualMenus or
kControlSupportsClickActivation;
if CreateUserPaneControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
Attrs, Control) = noErr then
begin
Widget := Control;
if OSError(
CreateUserPaneControl(GetTopParentWindow, ParamsToCarbonRect(AParams), Attrs, Control),
Self, SCreateWidget, 'CreateUserPaneControl') then RaiseCreateWidgetError(LCLObject);
Widget := Control;
inherited;
end
else RaiseCreateWidgetError(LCLObject);
inherited;
end;
{ TCarbonGroupBox }
{------------------------------------------------------------------------------
Method: TCarbonGroupBox.CreateWidget
Params: AParams - Creation parameters
Creates Carbon custom group box
------------------------------------------------------------------------------}
procedure TCarbonGroupBox.CreateWidget(const AParams: TCreateParams);
var
Control: ControlRef;
CFString: CFStringRef;
R: TRect;
begin
CreateCFString(AParams.Caption, CFString);
try
if CreateGroupBoxControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
CFString, not (LCLObject.Parent is TCustomGroupBox), Control) = noErr then
begin
Widget := Control;
if not GetClientRect(R) then
begin
DebugLn('TCarbonGroupBox.CreateWidget Error - no content region!');
Exit;
end;
if CreateUserPaneControl(GetTopParentWindow, GetCarbonRect(R),
kControlSupportsEmbedding or kControlHandlesTracking, FUserPane) <> noErr then
begin
DebugLn('TCarbonGroupBox.CreateWidget Error - unable to create content control!');
Exit;
end;
if HIViewAddSubview(Control, FUserPane) <> noErr then
begin
DebugLn('TCarbonGroupBox.CreateWidget Error - unable to embed conent control!');
Exit;
end;
inherited;
end
else RaiseCreateWidgetError(LCLObject);
finally
FreeCFString(CFString);
if OSError(
CreateGroupBoxControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
nil, not (LCLObject.Parent is TCustomGroupBox), Control),
Self, SCreateWidget, 'CreateGroupBoxControl') then RaiseCreateWidgetError(LCLObject);
Widget := Control;
if not GetClientRect(R) then
begin
DebugLn('TCarbonGroupBox.CreateWidget Error - no content region!');
Exit;
end;
if OSError(
CreateUserPaneControl(GetTopParentWindow, GetCarbonRect(R),
kControlSupportsEmbedding or kControlHandlesTracking, FUserPane),
Self, SCreateWidget, 'CreateUserPaneControl') then Exit;
if OSError(HIViewAddSubview(Control, FUserPane), Self, SCreateWidget,
SViewAddView) then Exit;
inherited;
SetText(AParams.Caption);
end;
{------------------------------------------------------------------------------
Method: TCarbonGroupBox.DestroyWidget
Clean-up
------------------------------------------------------------------------------}
procedure TCarbonGroupBox.DestroyWidget;
begin
DisposeControl(FUserPane);
@ -408,6 +432,10 @@ begin
inherited DestroyWidget;
end;
{------------------------------------------------------------------------------
Method: TCarbonGroupBox.GetContent
Returns: Content area control
------------------------------------------------------------------------------}
function TCarbonGroupBox.GetContent: ControlRef;
begin
Result := FUserPane;
@ -415,23 +443,33 @@ end;
{ TCarbonStatusBar }
{------------------------------------------------------------------------------
Method: TCarbonStatusBar.CreateWidget
Params: AParams - Creation parameters
Creates Carbon status bar
------------------------------------------------------------------------------}
procedure TCarbonStatusBar.CreateWidget(const AParams: TCreateParams);
var
Control: ControlRef;
begin
if not OSError(CreatePlacardControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
Control),
Self, 'CreateWidget', 'CreatePlacardControl') then
begin
Widget := Control;
if OSError(
CreatePlacardControl(GetTopParentWindow, ParamsToCarbonRect(AParams), Control),
Self, SCreateWidget, 'CreatePlacardControl') then RaiseCreateWidgetError(LCLObject);
inherited;
end
else RaiseCreateWidgetError(LCLObject);
Widget := Control;
inherited;
FPanels := TObjectList.Create(True);
UpdatePanel; // add panels
end;
{------------------------------------------------------------------------------
Method: TCarbonStatusBar.DestroyWidget
Clean-up
------------------------------------------------------------------------------}
procedure TCarbonStatusBar.DestroyWidget;
begin
FPanels.Free;
@ -439,11 +477,22 @@ begin
inherited DestroyWidget;
end;
{------------------------------------------------------------------------------
Method: TCarbonStatusBar.GetValidEvents
Returns: Set of events with installed handlers
Returns the set of events with installed handlers
------------------------------------------------------------------------------}
class function TCarbonStatusBar.GetValidEvents: TCarbonControlEvents;
begin
Result := [cceDraw];
end;
{------------------------------------------------------------------------------
Method: TCarbonStatusBar.Draw
Draw event handler
------------------------------------------------------------------------------}
procedure TCarbonStatusBar.Draw;
var
StatusBar: TStatusBar;
@ -455,11 +504,15 @@ begin
begin
GetClientRect(R);
WidgetSet.DrawText(HDC(Context), PChar(StatusBar.SimpleText),
Length(StatusBar.SimpleText), R, 0);
WidgetSet.ExtTextOut(HDC(Context), R.Top, R.Left, 0, nil, PChar(StatusBar.SimpleText),
Length(StatusBar.SimpleText), nil);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonStatusBar.GetPreferredSize
Returns: The preffered size of status bar for autosizing or (0, 0)
------------------------------------------------------------------------------}
function TCarbonStatusBar.GetPreferredSize: TPoint;
begin
Result := inherited GetPreferredSize;
@ -467,10 +520,14 @@ begin
// stretch status bar to whole window width
if LCLObject.Parent <> nil then
Result.X := LCLObject.Parent.ClientWidth;
Result.Y := 20;
end;
{------------------------------------------------------------------------------
Method: TCarbonStatusBar.UpdatePanel
Params: AIndex - Index of panel to update or -1 to update all
Updates properties of the specified panel(s) of status bar
------------------------------------------------------------------------------}
procedure TCarbonStatusBar.UpdatePanel(AIndex: Integer);
var
StatusBar: TStatusBar;
@ -483,8 +540,6 @@ begin
begin
// hide panels
for I := 0 to FPanels.Count - 1 do (FPanels[I] as TPanel).Hide;
Invalidate; // update text
end
else
begin
@ -526,10 +581,18 @@ begin
for I := FPanels.Count - 1 downto StatusBar.Panels.Count do
FPanels.Delete(I);
end;
Invalidate;
end;
{ TCarbonListBox }
{------------------------------------------------------------------------------
Method: TCarbonListBox.CreateWidget
Params: AParams - Creation parameters
Creates Carbon list box
------------------------------------------------------------------------------}
procedure TCarbonListBox.CreateWidget(const AParams: TCreateParams);
begin
// TODO
@ -540,17 +603,31 @@ begin
FItemIndex := -1;
end;
{------------------------------------------------------------------------------
Method: TCarbonListBox.GetItemsCount
Returns: The count of items in list box
------------------------------------------------------------------------------}
function TCarbonListBox.GetItemsCount: Integer;
begin
Result := 0;
// TODO
end;
{------------------------------------------------------------------------------
Method: TCarbonListBox.GetItemIndex
Returns: The index of selected item in list box
------------------------------------------------------------------------------}
function TCarbonListBox.GetItemIndex: Integer;
begin
Result := FItemIndex;
end;
{------------------------------------------------------------------------------
Method: TCarbonListBox.SetItemIndex
Params: AIndex - Index of item to select
Sets the index of item to select
------------------------------------------------------------------------------}
procedure TCarbonListBox.SetItemIndex(AIndex: Integer);
begin
// TODO
@ -558,16 +635,33 @@ end;
{ TCarbonCustomCheckBox }
{------------------------------------------------------------------------------
Method: TCarbonCustomCheckBox.GetValidEvents
Returns: Set of events with installed handlers
Returns the set of events with installed handlers
------------------------------------------------------------------------------}
class function TCarbonCustomCheckBox.GetValidEvents: TCarbonControlEvents;
begin
Result := [cceValueChanged, cceHit];
end;
{------------------------------------------------------------------------------
Method: TCarbonCustomCheckBox.Hit
Params: AControlPart - Hitted control part
Hit event handler
------------------------------------------------------------------------------}
procedure TCarbonCustomCheckBox.Hit(AControlPart: ControlPartCode);
begin
// do nothing, because value changed will be fired immediately
end;
{------------------------------------------------------------------------------
Method: TCarbonCustomCheckBox.ValueChanged
Value changed event handler
------------------------------------------------------------------------------}
procedure TCarbonCustomCheckBox.ValueChanged;
begin
LCLSendChangedMsg(LCLObject);
@ -575,10 +669,15 @@ end;
{ TCarbonCheckBox }
{------------------------------------------------------------------------------
Method: TCarbonCheckBox.CreateWidget
Params: AParams - Creation parameters
Creates Carbon check box
------------------------------------------------------------------------------}
procedure TCarbonCheckBox.CreateWidget(const AParams: TCreateParams);
var
Control: ControlRef;
CFString: CFStringRef;
Value: UInt32;
begin
case (LCLObject as TCustomCheckBox).State of
@ -587,27 +686,29 @@ begin
cbGrayed : Value := kControlCheckBoxMixedValue;
end;
CreateCFString(AParams.Caption, CFString);
try
if CreateCheckBoxControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
CFString, Value, True, Control) = noErr then
begin
Widget := Control;
if OSError(
CreateCheckBoxControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
nil, Value, True, Control),
Self, SCreateWidget, 'CreateCheckBoxControl') then RaiseCreateWidgetError(LCLObject);
Widget := Control;
inherited;
end
else RaisecreateWidgetError(LCLObject);
finally
FreeCFString(CFString);
end;
inherited;
SetText(AParams.Caption);
end;
{ TCarbonToggleBox }
{------------------------------------------------------------------------------
Method: TCarbonToggleBox.CreateWidget
Params: AParams - Creation parameters
Creates Carbon toggle box
------------------------------------------------------------------------------}
procedure TCarbonToggleBox.CreateWidget(const AParams: TCreateParams);
var
Control: ControlRef;
CFString: CFStringRef;
Value: UInt32;
begin
case (LCLObject as TToggleBox).State of
@ -616,29 +717,31 @@ begin
cbGrayed : Value := kControlCheckBoxMixedValue;
end;
CreateCFString(AParams.Caption, CFString);
try
if CreateBevelButtonControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
CFString, kControlBevelButtonNormalBevel,
kControlBehaviorToggles, nil, 0, 0, 0, Control) = noErr then
begin
Widget := Control;
inherited;
end
else RaisecreateWidgetError(LCLObject);
finally
FreeCFString(CFString);
end;
if OSError(
CreateBevelButtonControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
nil, kControlBevelButtonNormalBevel,
kControlBehaviorToggles, nil, 0, 0, 0, Control),
Self, SCreateWidget, SCreateBevelButton) then RaiseCreateWidgetError(LCLObject);
Widget := Control;
inherited;
SetText(AParams.Caption);
SetControl32BitValue(Control, Value);
end;
{ TCarbonRadioButton }
{------------------------------------------------------------------------------
Method: TCarbonRadioButton.CreateWidget
Params: AParams - Creation parameters
Creates Carbon radio button
------------------------------------------------------------------------------}
procedure TCarbonRadioButton.CreateWidget(const AParams: TCreateParams);
var
Control: ControlRef;
CFString: CFStringRef;
Value: UInt32;
begin
case (LCLObject as TRadioButton).State of
@ -647,21 +750,23 @@ begin
cbGrayed : Value := kControlCheckBoxMixedValue;
end;
CreateCFString(AParams.Caption, CFString);
try
if CreateRadioButtonControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
CFString, Value, True, Control) = noErr then
begin
Widget := Control;
inherited;
end
else RaisecreateWidgetError(LCLObject);
finally
FreeCFString(CFString);
end;
if OSError(
CreateRadioButtonControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
nil, Value, True, Control),
Self, SCreateWidget, 'CreateRadioButtonControl') then RaiseCreateWidgetError(LCLObject);
Widget := Control;
inherited;
SetText(AParams.Caption);
end;
{------------------------------------------------------------------------------
Method: TCarbonRadioButton.ValueChanged
Value changed event handler
------------------------------------------------------------------------------}
procedure TCarbonRadioButton.ValueChanged;
var
RadioButton: TRadioButton;
@ -670,7 +775,7 @@ var
begin
if GetControl32BitValue(ControlRef(Widget)) = kControlCheckBoxCheckedValue then
begin
DebugLn('TCarbonRadioButton.ValueChanged Uncheck Sibling');
//DebugLn('TCarbonRadioButton.ValueChanged Uncheck Sibling');
// uncheck sibling radio buttons
RadioButton := (LCLObject as TRadioButton);
@ -688,13 +793,25 @@ begin
inherited;
end;
{ TCarbonButton }
{ TCarbonCustomButton }
{------------------------------------------------------------------------------
Method: TCarbonCustomButton.GetValidEvents
Returns: Set of events with installed handlers
Returns the set of events with installed handlers
------------------------------------------------------------------------------}
class function TCarbonCustomButton.GetValidEvents: TCarbonControlEvents;
begin
Result := [cceHit];
end;
{------------------------------------------------------------------------------
Method: TCarbonCustomButton.Hit
Params: AControlPart - Hitted control part
Hit event handler
------------------------------------------------------------------------------}
procedure TCarbonCustomButton.Hit(AControlPart: ControlPartCode);
begin
LCLSendClickedMsg(LCLObject);
@ -702,57 +819,73 @@ end;
{ TCarbonButton }
{------------------------------------------------------------------------------
Method: TCarbonButton.CreateWidget
Params: AParams - Creation parameters
Creates Carbon button
------------------------------------------------------------------------------}
procedure TCarbonButton.CreateWidget(const AParams: TCreateParams);
var
Control: ControlRef;
CFString: CFStringRef;
begin
// create the button at bounds with title
CreateCFString(AParams.Caption, CFString);
try
if CreatePushButtonControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
CFString, Control) = noErr then
begin
Widget := Control;
// create the button at bounds
if OSError(
CreatePushButtonControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
nil, Control),
Self, SCreateWidget, 'CreatePushButtonControl') then RaiseCreateWidgetError(LCLObject);
inherited;
end
else RaisecreateWidgetError(LCLObject);
finally
FreeCFString(CFString);
end;
Widget := Control;
inherited;
SetText(AParams.Caption);
end;
{ TCarbonBitBtn }
{------------------------------------------------------------------------------
Method: TCarbonBitBtn.CreateWidget
Params: AParams - Creation parameters
Creates Carbon bitmap button
------------------------------------------------------------------------------}
procedure TCarbonBitBtn.CreateWidget(const AParams: TCreateParams);
var
Control: ControlRef;
CFString: CFStringRef;
ButtonKind: ThemeButtonKind;
begin
CreateCFString(AParams.Caption, CFString);
try
if CreateBevelButtonControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
CFString, kControlBevelButtonNormalBevel, kControlBehaviorPushbutton,
nil, 0, 0, 0, Control) = noErr then
begin
Widget := Control;
inherited;
end
else RaisecreateWidgetError(LCLObject);
finally
FreeCFString(CFString);
end;
if OSError(
CreateBevelButtonControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
nil, kControlBevelButtonLargeBevel, kControlBehaviorPushbutton,
nil, 0, 0, 0, Control),
Self, SCreateWidget, SCreateBevelButton) then RaiseCreateWidgetError(LCLObject);
Widget := Control;
inherited;
SetText(AParams.Caption);
// set round border
ButtonKind := kThemeRoundedBevelButton;
OSError(SetControlData(ControlRef(Widget), kControlEntireControl,
kControlBevelButtonKindTag, SizeOf(ThemeButtonKind), @ButtonKind),
Self, SCreateWidget, SSetData, 'kControlBevelButtonKindTag');
end;
{ TCarbonStaticText }
{------------------------------------------------------------------------------
Method: TCarbonStaticText.CreateWidget
Params: AParams - Creation parameters
Creates Carbon static text
------------------------------------------------------------------------------}
procedure TCarbonStaticText.CreateWidget(const AParams: TCreateParams);
var
Control: ControlRef;
CFString: CFStringRef;
MultiLine: Boolean = True;
FontStyle: ControlFontStyleRec;
begin
@ -763,32 +896,45 @@ begin
taCenter: FontStyle.just := teCenter;
end;
CreateCFString(AParams.Caption, CFString);
try
if CreateStaticTextControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
CFString, @FontStyle, Control) = noErr then
begin
Widget := Control;
inherited;
end
else RaisecreateWidgetError(LCLObject);
finally
FreeCFString(CFString);
end;
if OSError(
CreateStaticTextControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
nil, @FontStyle, Control),
Self, SCreateWidget, 'CreateStaticTextControl') then RaiseCreateWidgetError(LCLObject);
Widget := Control;
inherited;
SetText(AParams.Caption);
// switch on multi-line attribute
SetControlData(Control, kControlEntireControl,
kControlStaticTextIsMultilineTag, SizeOf(Boolean), @MultiLine);
OSError(
SetControlData(Control, kControlEntireControl,
kControlStaticTextIsMultilineTag, SizeOf(Boolean), @MultiLine),
Self, SCreateWidget, SSetData, 'kControlStaticTextIsMultilineTag');
end;
{ TCarbonCustomBar }
{------------------------------------------------------------------------------
Method: TCarbonCustomBar.SetData
Params: APos - New position
Sets the position of custom bar
------------------------------------------------------------------------------}
procedure TCarbonCustomBar.SetData(APos: Integer);
begin
SetControl32BitValue(ControlRef(Widget), APos);
end;
{------------------------------------------------------------------------------
Method: TCarbonCustomBar.SetData
Params: APos - New position
AMin - New minimum
AMax - New maximum
Sets the position, minimum and maximum of custom bar
------------------------------------------------------------------------------}
procedure TCarbonCustomBar.SetData(APos, AMin, AMax: Integer);
begin
SetControl32BitMinimum(ControlRef(Widget), AMin);
@ -796,6 +942,15 @@ begin
SetControl32BitValue(ControlRef(Widget), APos);
end;
{------------------------------------------------------------------------------
Method: TCarbonCustomBar.SetData
Params: APos - New position
AMin - New minimum
AMax - New maximum
APage - New page size
Sets the position, minimum, maximum and page size of custom bar
------------------------------------------------------------------------------}
procedure TCarbonCustomBar.SetData(APos, AMin, AMax, APage: Integer);
begin
SetControl32BitMinimum(ControlRef(Widget), AMin);
@ -804,6 +959,10 @@ begin
SetControlViewSize(ControlRef(Widget), APage);
end;
{------------------------------------------------------------------------------
Method: TCarbonCustomBar.GetPos
Returns: The position of custom bar
------------------------------------------------------------------------------}
function TCarbonCustomBar.GetPos: Integer;
begin
Result := GetControl32BitValue(ControlRef(Widget));
@ -811,6 +970,12 @@ end;
{ TCarbonProgressBar }
{------------------------------------------------------------------------------
Method: TCarbonProgressBar.CreateWidget
Params: AParams - Creation parameters
Creates Carbon progress bar
------------------------------------------------------------------------------}
procedure TCarbonProgressBar.CreateWidget(const AParams: TCreateParams);
var
ProgressBar: TCustomProgressBar;
@ -819,15 +984,14 @@ begin
ProgressBar := LCLObject as TCustomProgressBar;
// create determinate progress bar
if CreateProgressBarControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
ProgressBar.Position, ProgressBar.Min, ProgressBar.Max, False,
Control) = noErr then
begin
Widget := Control;
if OSError(
CreateProgressBarControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
ProgressBar.Position, ProgressBar.Min, ProgressBar.Max, False, Control),
Self, SCreateWidget, 'CreateProgressBarControl') then RaiseCreateWidgetError(LCLObject);
Widget := Control;
inherited;
end
else RaiseCreateWidgetError(LCLObject);
inherited;
end;
{ TCarbonTrackBar }
@ -853,21 +1017,43 @@ begin
Result := 2;
end;
{------------------------------------------------------------------------------
Method: TCarbonTrackBar.GetValidEvents
Returns: Set of events with installed handlers
Returns the set of events with installed handlers
------------------------------------------------------------------------------}
class function TCarbonTrackBar.GetValidEvents: TCarbonControlEvents;
begin
Result := [cceValueChanged, cceIndicatorMoved];
end;
{------------------------------------------------------------------------------
Method: TCarbonTrackBar.ValueChanged
Value changed event handler
------------------------------------------------------------------------------}
procedure TCarbonTrackBar.ValueChanged;
begin
LCLSendChangedMsg(LCLObject);
end;
{------------------------------------------------------------------------------
Method: TCarbonTrackBar.IndicatorMoved
Indicator moved event handler
------------------------------------------------------------------------------}
procedure TCarbonTrackBar.IndicatorMoved;
begin
ValueChanged;
end;
{------------------------------------------------------------------------------
Method: TCarbonTrackBar.CreateWidget
Params: AParams - Creation parameters
Creates Carbon track bar
------------------------------------------------------------------------------}
procedure TCarbonTrackBar.CreateWidget(const AParams: TCreateParams);
var
TrackBar: TCustomTrackBar;
@ -877,19 +1063,25 @@ begin
FTicks := GetTicks;
if CreateSliderControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
TrackBar.Position, TrackBar.Min, TrackBar.Max,
kControlSliderPointsDownOrRight, FTicks, True, nil, Control) = noErr then
begin
Widget := Control;
if OSError(
CreateSliderControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
TrackBar.Position, TrackBar.Min, TrackBar.Max,
kControlSliderPointsDownOrRight, FTicks, True, nil, Control),
Self, SCreateWidget, 'CreateSliderControl') then RaiseCreateWidgetError(LCLObject);
Widget := Control;
inherited;
end
else RaiseCreateWidgetError(LCLObject);
inherited;
end;
{ TCarbonScrollBar }
{------------------------------------------------------------------------------
Method: TCarbonScrollBar.CreateWidget
Params: AParams - Creation parameters
Creates Carbon scroll bar
------------------------------------------------------------------------------}
procedure TCarbonScrollBar.CreateWidget(const AParams: TCreateParams);
var
ScrollBar: TCustomScrollBar;
@ -897,22 +1089,33 @@ var
begin
ScrollBar := LCLObject as TCustomScrollBar;
if CreateScrollBarControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
ScrollBar.Position, ScrollBar.Min, ScrollBar.Max, ScrollBar.PageSize, True,
nil, Control) = noErr then
begin
Widget := Control;
if OSError(
CreateScrollBarControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
ScrollBar.Position, ScrollBar.Min, ScrollBar.Max, ScrollBar.PageSize, True,
nil, Control),
Self, SCreateWidget, 'CreateScrollBarControl') then RaiseCreateWidgetError(LCLObject);
Widget := Control;
inherited;
end
else RaiseCreateWidgetError(LCLObject);
inherited;
end;
{------------------------------------------------------------------------------
Method: TCarbonScrollBar.GetValidEvents
Returns: Set of events with installed handlers
Returns the set of events with installed handlers
------------------------------------------------------------------------------}
class function TCarbonScrollBar.GetValidEvents: TCarbonControlEvents;
begin
Result := [cceValueChanged, cceIndicatorMoved, cceDoAction];
end;
{------------------------------------------------------------------------------
Method: TCarbonScrollBar.ValueChanged
Value changed event handler
------------------------------------------------------------------------------}
procedure TCarbonScrollBar.ValueChanged;
var
ScrollMsg: TLMScroll;
@ -927,17 +1130,29 @@ begin
DeliverMessage(LCLObject, ScrollMsg);
end;
{------------------------------------------------------------------------------
Method: TCarbonScrollBar.IndicatorMoved
Indicator moved event handler
------------------------------------------------------------------------------}
procedure TCarbonScrollBar.IndicatorMoved;
begin
ValueChanged;
end;
{------------------------------------------------------------------------------
Method: TCarbonScrollBar.DoAction
Params: AControlPart - Control part to perform the action
Action event handler
------------------------------------------------------------------------------}
procedure TCarbonScrollBar.DoAction(AControlPart: ControlPartCode);
var
ScrollMsg: TLMScroll;
ScrollCode: SmallInt;
begin
ScrollCode := -1; // valid scrollcode is >= 0
case AControlPart of
kControlUpButtonPart : ScrollCode := SB_LINEUP;
kControlDownButtonPart: ScrollCode := SB_LINEDOWN;

234
lcl/interfaces/carbon/carbonprivatecommon.inc
View File

@ -19,6 +19,9 @@
// H A N D L E R S
// ==================================================================
{------------------------------------------------------------------------------
Name: CarbonCommon_Dispose
------------------------------------------------------------------------------}
function CarbonCommon_Dispose(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
@ -28,6 +31,10 @@ begin
LCLSendDestroyMsg(AWidget.LCLObject); // widget is disposed in DestroyHandle
end;
{------------------------------------------------------------------------------
Name: CarbonCommon_Draw
Handles draw event
------------------------------------------------------------------------------}
function CarbonCommon_Draw(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
@ -41,8 +48,10 @@ begin
// first let carbon draw/update
Result := CallNextEventHandler(ANextHandler, AEvent);
GetEventParameter(AEvent, kEventParamCGContextRef, typeCGContextRef, nil,
SizeOf(CGContextRef), nil, @(AWidget.Context.CGContext));
if OSError(
GetEventParameter(AEvent, kEventParamCGContextRef, typeCGContextRef, nil,
SizeOf(CGContextRef), nil, @(AWidget.Context.CGContext)),
'CarbonCommon_Draw', SGetEvent, 'kEventParamCGContextRef') then Exit;
AWidget.Context.Reset;
@ -64,12 +73,16 @@ begin
end;
end;
{------------------------------------------------------------------------------
Name: CarbonCommon_BoundsChanged
Handles bounds changing
------------------------------------------------------------------------------}
function CarbonCommon_BoundsChanged(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
var
AWinControl: TWinControl;
WidgetBounds, OldBounds, ResizedBounds: TRect;
WidgetBounds, OldBounds: TRect;
Resized: Boolean;
begin
{$IFDEF VerboseCommonEvent}
@ -78,47 +91,37 @@ begin
// first let carbon draw/update
Result := CallNextEventHandler(ANextHandler, AEvent);
if AWidget.LCLObject is TWinControl then
AWinControl := TWinControl(AWidget.LCLObject);
AWidget.GetBounds(WidgetBounds);
OldBounds := AWinControl.BoundsRect;
// then send a LM_SIZE message
if (OldBounds.Right - OldBounds.Left <> WidgetBounds.Right - WidgetBounds.Left) or
(OldBounds.Bottom - OldBounds.Top <> WidgetBounds.Bottom - WidgetBounds.Top) then
begin
AWinControl := TWinControl(AWidget.LCLObject);
AWidget.GetBounds(WidgetBounds);
OldBounds := AWinControl.BoundsRect;
// form expects client size
if AWidget is TCarbonWindow then
begin
AWidget.GetClientRect(ResizedBounds);
OffsetRect(ResizedBounds, WidgetBounds.Left, WidgetBounds.Top);
end
else ResizedBounds := WidgetBounds;
LCLSendSizeMsg(AWinControl, WidgetBounds.Right - WidgetBounds.Left,
WidgetBounds.Bottom - WidgetBounds.Top, Size_SourceIsInterface);
Resized := True;
end
else Resized := False;
// then send a LM_SIZE message
if (OldBounds.Right - OldBounds.Left <> WidgetBounds.Right - WidgetBounds.Left) or
(OldBounds.Bottom - OldBounds.Top <> WidgetBounds.Bottom - WidgetBounds.Top) then
begin
LCLSendSizeMsg(AWinControl, ResizedBounds.Right - ResizedBounds.Left,
ResizedBounds.Bottom - ResizedBounds.Top, Size_SourceIsInterface);
Resized := True;
end
else Resized := False;
// then send a LM_MOVE message
if (OldBounds.Left <> WidgetBounds.Left) or
(OldBounds.Top <> WidgetBounds.Top) then
begin
LCLSendMoveMsg(AWinControl, ResizedBounds.Left,
ResizedBounds.Top, Move_SourceIsInterface);
end;
// invalidate control canvas
if Resized then AWidget.Invalidate;
// invalidate parent client area, previously covered by control
if (AWinControl.Parent <> nil) and AWinControl.Parent.HandleAllocated then
begin
TCarbonWidget(AWinControl.Parent.Handle).Invalidate(@OldBounds);
end;
// then send a LM_MOVE message
if (OldBounds.Left <> WidgetBounds.Left) or
(OldBounds.Top <> WidgetBounds.Top) then
begin
LCLSendMoveMsg(AWinControl, WidgetBounds.Left,
WidgetBounds.Top, Move_SourceIsInterface);
end;
// invalidate control canvas
if Resized then AWidget.Invalidate;
// invalidate parent client area, previously covered by control
if (AWinControl.Parent <> nil) and AWinControl.Parent.HandleAllocated then
begin
TCarbonWidget(AWinControl.Parent.Handle).Invalidate(@OldBounds);
end;
end;
@ -171,24 +174,39 @@ var
Msg: TLMMouse;
MouseButton: EventMouseButton;
ControlPart: ControlPartCode;
const
SName = 'CarbonCommon_Track';
SControlAction = 'kEventParamControlAction';
begin
{$IFDEF VerboseMouse}
DebugLn('CarbonCommon_Track ', DbgSName(AWidget.LCLObject));
{$ENDIF}
GetEventParameter(AEvent, kEventParamControlAction, typeControlActionUPP, nil, SizeOf(ActionUPP), nil, @OldActionUPP);
GetEventParameter(AEvent, kEventParamMouseButton, typeMouseButton, nil, SizeOf(EventMouseButton), nil, @MouseButton);
if OSError(
GetEventParameter(AEvent, kEventParamControlAction, typeControlActionUPP,
nil, SizeOf(ActionUPP), nil, @OldActionUPP), SName, SGetEvent,
SControlAction) then Exit;
if OSError(
GetEventParameter(AEvent, kEventParamMouseButton, typeMouseButton, nil,
SizeOf(EventMouseButton), nil, @MouseButton), SName, SGetEvent,
'kEventParamMouseButton') then Exit;
ActionUPP := NewControlActionUPP(@CarbonCommon_TrackProgress);
SetEventParameter(AEvent, kEventParamControlAction, typeControlActionUPP,
SizeOf(ActionUPP), @ActionUPP);
try
if OSError(
SetEventParameter(AEvent, kEventParamControlAction, typeControlActionUPP,
SizeOf(ActionUPP), @ActionUPP), SName, SSetEvent, SControlAction) then Exit;
// this does not return until the mouse is released
Result := CallNextEventHandler(ANextHandler, AEvent);
SetEventParameter(AEvent, kEventParamControlAction, typeControlActionUPP,
SizeOf(OldActionUPP), @OldActionUPP);
DisposeControlActionUPP(ActionUPP);
// this does not return until the mouse is released
Result := CallNextEventHandler(ANextHandler, AEvent);
if OSError(
SetEventParameter(AEvent, kEventParamControlAction, typeControlActionUPP,
SizeOf(OldActionUPP), @OldActionUPP), SName, SSetEvent, SControlAction) then Exit;
finally
DisposeControlActionUPP(ActionUPP);
end;
FillChar(Msg, SizeOf(Msg), 0);
if (MouseButton >= Low(MSGKIND)) and (MouseButton <= High(MSGKIND)) then
@ -202,8 +220,9 @@ begin
if (AWidget is TCarbonControl) and
(cceHit in (AWidget as TCarbonControl).GetValidEvents) then
begin
GetEventParameter(AEvent, kEventParamControlPart, typeControlPartCode, nil,
SizeOf(ControlPartCode), nil, @ControlPart);
if OSError(
GetEventParameter(AEvent, kEventParamControlPart, typeControlPartCode, nil,
SizeOf(ControlPartCode), nil, @ControlPart), SName, SGetEvent, SControlPart) then Exit;
{$IFDEF VerboseMouse}
DebugLn('CarbonCommon_Track Control Part ' + DbgS(ControlPart) +
@ -220,57 +239,65 @@ begin
DeliverMessage(AWidget.LCLObject, Msg);
end;
{------------------------------------------------------------------------------
Name: CarbonCommon_CursorChange
Cursor changing
------------------------------------------------------------------------------}
function CarbonCommon_CursorChange(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
var
AStatus: OSSTATUS;
ALocation: FPCMacOSAll.Point;
AModifiers: UInt32;
ACursorWasSet: Boolean;
ACursor: TCursor;
ACursorWasSet: Boolean;
Widget: TCarbonWidget; //
Control: ControlRef; // the control we are dealing with
// or the rootcontrol if none found
const
SName = 'CarbonCommon_CursorChange';
begin
Result := CallNextEventHandler(ANextHandler, AEvent);
AStatus := GetEventParameter(AEvent, kEventParamMouseLocation, typeQDPoint, nil,
SizeOf(ALocation), nil, @ALocation);
if AStatus = noErr then
if OSError(GetEventParameter(AEvent, kEventParamMouseLocation, typeQDPoint, nil,
SizeOf(ALocation), nil, @ALocation), SName, SGetEvent,
'kEventParamMouseLocation') then Exit;
if OSError(GetEventParameter(AEvent, kEventParamKeyModifiers, typeUInt32, nil,
SizeOf(AModifiers), nil, @AModifiers), SName, SGetEvent, SKeyModifiers) then Exit;
//Find out which control the mouse event should occur for
Control := nil;
if OSError(HIViewGetViewForMouseEvent(AWidget.Content, AEvent, Control),
SName, SViewForMouse) then Exit;
if Control = nil then Exit;
Widget := GetCarbonWidget(Control);
if Widget = nil then Exit;
GlobalToLocal(ALocation);
if OSError(HandleControlSetCursor(Control, ALocation, AModifiers, ACursorWasSet),
SName, 'HandleControlSetCursor') then
ACursorWasSet := False;
if not ACursorWasSet then
begin
AStatus := GetEventParameter(AEvent, kEventParamKeyModifiers, typeUInt32, nil,
SizeOf(AModifiers), nil, @AModifiers);
if AStatus = noErr then
begin
//Find out which control the mouse event should occur for
Control := nil;
if HIViewGetViewForMouseEvent(AWidget.Content, AEvent, Control) <> noErr then Exit;
if Control = nil then Exit;
ACursor := Screen.Cursor;
if ACursor = crDefault then
ACursor := Widget.LCLObject.Cursor;
Widget := GetCarbonWidget(Control);
if Widget = nil then Exit;
GlobalToLocal(ALocation);
AStatus := HandleControlSetCursor(Control, ALocation,
AModifiers, ACursorWasSet);
if AStatus <> noErr then
ACursorWasSet := False;
if not ACursorWasSet then
begin
ACursor := Screen.Cursor;
if ACursor = crDefault then
ACursor := Widget.LCLObject.Cursor;
WidgetSet.SetCursor(Screen.Cursors[ACursor]);
end;
Result := noErr;
end;
WidgetSet.SetCursor(Screen.Cursors[ACursor]);
end;
Result := noErr;
end;
{------------------------------------------------------------------------------
Name: CarbonCommon_ContextualMenuClick
PopupMenu auto popup support
------------------------------------------------------------------------------}
function CarbonCommon_ContextualMenuClick(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
@ -294,6 +321,10 @@ begin
Result := noErr; // do not propagate
end;
{------------------------------------------------------------------------------
Name: CarbonCommon_SetFocusPart
Handles set or kill focus
------------------------------------------------------------------------------}
function CarbonCommon_SetFocusPart(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
@ -302,8 +333,10 @@ var
begin
Result := CallNextEventHandler(ANextHandler, AEvent);
if GetEventParameter(AEvent, kEventParamControlPart, typeControlPartCode, nil,
SizeOf(ControlPartCode), nil, @FocusPart) <> noErr then Exit;
if OSError(
GetEventParameter(AEvent, kEventParamControlPart, typeControlPartCode, nil,
SizeOf(ControlPartCode), nil, @FocusPart), 'CarbonCommon_SetFocusPart',
SGetEvent, SControlPart) then Exit;
{$IFDEF VerboseCommonEvent}
DebugLn('CarbonCommon_SetFocusPart: ', DbgSName(AWidget.LCLObject), ' ' +
@ -316,6 +349,10 @@ begin
LCLSendKillFocusMsg(AWidget.LCLObject);
end;
{------------------------------------------------------------------------------
Name: CarbonCommon_GetNextFocusCandidate
TabOrder and TabStop support
------------------------------------------------------------------------------}
function CarbonCommon_GetNextFocusCandidate(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
@ -325,16 +362,21 @@ var
TabIndex: Integer;
TabList: TFPList;
AControl: TCarbonWidget;
const
SName = 'CarbonCommon_GetNextFocusCandidate';
begin
{$IFDEF VerboseCommonEvent}
DebugLn('CarbonCommon_GetNextFocusCandidate: ', DbgSName(AWidget.LCLObject));
{$ENDIF}
//Result := CallNextEventHandler(ANextHandler, AEvent);
if GetEventParameter(AEvent, kEventParamStartControl, typeControlRef, nil,
SizeOf(ControlRef), nil, @StartControl) <> noErr then Exit;
if GetEventParameter(AEvent, kEventParamControlPart, typeControlPartCode, nil,
SizeOf(ControlPartCode), nil, @FocusPart) <> noErr then Exit;
if OSError(GetEventParameter(AEvent, kEventParamStartControl, typeControlRef,
nil, SizeOf(ControlRef), nil, @StartControl), SName, SGetEvent,
'kEventParamStartControl') then Exit;
if OSError(
GetEventParameter(AEvent, kEventParamControlPart, typeControlPartCode, nil,
SizeOf(ControlPartCode), nil, @FocusPart), SName, SGetEvent, SControlPart) then Exit;
TabIndex := 0;
TabList := TFPList.Create;
@ -367,8 +409,7 @@ begin
NextControl := nil;
OSError(SetEventParameter(AEvent, kEventParamNextControl, typeControlRef,
SizeOf(ControlRef), @NextControl), 'CarbonCommon_GetNextFocusCandidate',
'SetEventParameter');
SizeOf(ControlRef), @NextControl), SName, SSetEvent, 'kEventParamNextControl');
finally
TabList.Free;
end;
@ -376,6 +417,10 @@ begin
Result := noErr;
end;
{------------------------------------------------------------------------------
Name: CarbonCommon_SetCursor
Sets cursor
------------------------------------------------------------------------------}
function CarbonCommon_SetCursor(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
@ -403,5 +448,6 @@ begin
ACursor := AWidget.LCLObject.Cursor;
end;
WidgetSet.SetCursor(Screen.Cursors[ACursor]);
Result := noErr; // cursor was setted
end;

300
lcl/interfaces/carbon/carbonprivatecontrol.inc
View File

@ -35,15 +35,21 @@ begin
Result := CallNextEventHandler(ANextHandler, AEvent);
if GetEventParameter(AEvent, kEventParamControlPart, typeControlPartCode, nil,
SizeOf(ControlPartCode), nil, @ControlPart) = noErr then
begin
(AWidget as TCarbonControl).Hit(ControlPart);
end;
if OSError(
GetEventParameter(AEvent, kEventParamControlPart, typeControlPartCode, nil,
SizeOf(ControlPartCode), nil, @ControlPart), 'CarbonControl_Hit', SGetEvent,
SControlPart) then Exit;
(AWidget as TCarbonControl).Hit(ControlPart);
// send postponed mouse up event
DeliverMessage(AWidget.LCLObject, SavedMouseUpMsg);
end;
{------------------------------------------------------------------------------
Name: CarbonControl_ValueChanged
Handles value change
------------------------------------------------------------------------------}
function CarbonControl_ValueChanged(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
@ -57,6 +63,10 @@ begin
(AWidget as TCarbonControl).ValueChanged;
end;
{------------------------------------------------------------------------------
Name: CarbonControl_IndicatorMoved
Handles indicator move
------------------------------------------------------------------------------}
function CarbonControl_IndicatorMoved(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
@ -70,6 +80,10 @@ begin
(AWidget as TCarbonControl).IndicatorMoved;
end;
{------------------------------------------------------------------------------
Name: CarbonControl_TextDidChange
Handles text change
------------------------------------------------------------------------------}
function CarbonControl_TextDidChange(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
@ -83,6 +97,10 @@ begin
(AWidget as TCarbonControl).TextDidChange;
end;
{------------------------------------------------------------------------------
Name: CarbonControl_ListItemSelected
Handles list item change
------------------------------------------------------------------------------}
function CarbonControl_ListItemSelected(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
@ -96,8 +114,11 @@ begin
Result := CallNextEventHandler(ANextHandler, AEvent);
// get selected item index
if GetEventParameter(AEvent, kEventParamComboBoxListSelectedItemIndex,
typeCFIndex, nil, SizeOf(CFIndex), nil, @Index) <> noErr then Index := -1;
if OSError(
GetEventParameter(AEvent, kEventParamComboBoxListSelectedItemIndex,
typeCFIndex, nil, SizeOf(CFIndex), nil, @Index),
'CarbonControl_ListItemSelected', SGetEvent,
'kEventParamComboBoxListSelectedItemIndex') then Index := -1;
(AWidget as TCarbonControl).ListItemSelected(Index);
end;
@ -117,6 +138,7 @@ end;
{------------------------------------------------------------------------------
Method: TCarbonControl.Hit
Params: AControlPart - Hitted control part
Hit event handler
------------------------------------------------------------------------------}
@ -126,42 +148,79 @@ begin
LCLObject.Name, ': ', LCLObject.ClassName);
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.Draw
Draw event handler
------------------------------------------------------------------------------}
procedure TCarbonControl.Draw;
begin
DebugLn('TCarbonControl.Draw is invalid ', ClassName, ' ',
LCLObject.Name, ': ', LCLObject.ClassName);
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.ValueChanged
Value changed event handler
------------------------------------------------------------------------------}
procedure TCarbonControl.ValueChanged;
begin
DebugLn('TCarbonControl.ValueChanged is invalid ', ClassName, ' ',
LCLObject.Name, ': ', LCLObject.ClassName);
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.IndicatorMoved
Indicator moved event handler
------------------------------------------------------------------------------}
procedure TCarbonControl.IndicatorMoved;
begin
DebugLn('TCarbonControl.IndicatorMoved is invalid ', ClassName, ' ',
LCLObject.Name, ': ', LCLObject.ClassName);
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.TextDidChange
Text changed event handler
------------------------------------------------------------------------------}
procedure TCarbonControl.TextDidChange;
begin
DebugLn('TCarbonControl.TextDidChange is invalid! ', ClassName, ' ',
LCLObject.Name, ': ', LCLObject.ClassName);
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.DoAction
Params: AControlPart - Control part to perform the action
Action event handler
------------------------------------------------------------------------------}
procedure TCarbonControl.DoAction(AControlPart: ControlPartCode);
begin
DebugLn('TCarbonControl.DoAction is invalid ', ClassName, ' ',
LCLObject.Name, ': ', LCLObject.ClassName);
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.ListItemSelected
Params: AIndex - Selected item index
List item selected event handler
------------------------------------------------------------------------------}
procedure TCarbonControl.ListItemSelected(AIndex: Integer);
begin
DebugLn('TCarbonControl.ListItemSelected is invalid ', ClassName, ' ',
LCLObject.Name, ': ', LCLObject.ClassName);
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.RegisterEvents
Registers event handlers for control
------------------------------------------------------------------------------}
procedure TCarbonControl.RegisterEvents;
var
TmpSpec: EventTypeSpec;
@ -264,6 +323,11 @@ begin
{$ENDIF}
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.UnregisterEvents
Unregisters event handlers
------------------------------------------------------------------------------}
procedure TCarbonControl.UnregisterEvents;
var
Events: TCarbonControlEvents;
@ -294,19 +358,31 @@ begin
UnregisterEventHandler(@CarbonControl_ListItemSelected);
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.CreateWidget
Params: AParams - Creation parameters
Override to provide Carbon control creation
------------------------------------------------------------------------------}
procedure TCarbonControl.CreateWidget(const AParams: TCreateParams);
begin
SetControlProperty(Widget, LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(Self), @Self);
OSError(
SetControlProperty(Widget, LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(Self), @Self),
Self, SCreateWidget, SSetControlProp, 'Widget');
if Content <> ControlRef(Widget) then
SetControlProperty(Content, LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(Self), @Self);
OSError(
SetControlProperty(Content, LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(Self), @Self),
SCreateWidget, SSetControlProp, 'Content');
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.DestroyWidget
Override to do some clean-up
------------------------------------------------------------------------------}
procedure TCarbonControl.DestroyWidget;
begin
RemoveControlProperty(Widget, LAZARUS_FOURCC, WIDGETINFO_FOURCC);
if Content <> ControlRef(Widget) then
RemoveControlProperty(Content, LAZARUS_FOURCC, WIDGETINFO_FOURCC);
DisposeControl(ControlRef(Widget));
Widget := nil;
end;
@ -337,34 +413,53 @@ end;
------------------------------------------------------------------------------}
procedure TCarbonControl.Invalidate(Rect: PRect);
begin
if Rect = nil then HiViewSetNeedsDisplay(Frame, True)
if Rect = nil then
OSError(
HiViewSetNeedsDisplay(Frame, True), Self, SInvalidate, SViewNeedsDisplay)
else
HiViewSetNeedsDisplayInRect(Content, RectToCGRect(Rect^), True);
OSError(
HiViewSetNeedsDisplayInRect(Content, RectToCGRect(Rect^), True), Self,
SInvalidate, SViewNeedsDisplayRect);
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.IsEnabled
Returns: If control is enabled
------------------------------------------------------------------------------}
function TCarbonControl.IsEnabled: Boolean;
begin
Result := IsControlEnabled(Frame);
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.IsVisible
Returns: If control is visible
------------------------------------------------------------------------------}
function TCarbonControl.IsVisible: Boolean;
begin
Result := FPCMacOSAll.IsControlVisible(Frame);
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.Enable
Params: AEnable - if enable
Returns: If control is enabled
Changes control enabled
------------------------------------------------------------------------------}
function TCarbonControl.Enable(AEnable: Boolean): Boolean;
begin
Result := not FPCMacOSAll.IsControlEnabled(Frame);
if AEnable then
FPCMacOSAll.EnableControl(Frame)
OSError(FPCMacOSAll.EnableControl(Frame), Self, SEnable, SEnableControl)
else
FPCMacOSAll.DisableControl(Frame);
OSError(FPCMacOSAll.DisableControl(Frame), Self, SEnable, SDisableControl);
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.GetBounds
Params: ARect - Record for window coordinates
Params: ARect - Record for control coordinates
Returns: If function succeeds
Returns the control bounding rectangle relative to the client origin of its
@ -375,21 +470,34 @@ var
AWndRect: FPCMacOSAll.Rect;
begin
Result := FPCMacOSAll.GetControlBounds(Frame, AWndRect) <> nil;
if Result then ARect := CarbonRectToRect(AWndRect);
if Result then
ARect := CarbonRectToRect(AWndRect)
else
DebugLn('TCarbonControl.GetBounds failed for ' + DbgSName(LCLObject));
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.GetScreenBounds
Params: ARect - Record for control coordinates
Returns: If function succeeds
Returns the control bounding rectangle relative to the screen
------------------------------------------------------------------------------}
function TCarbonControl.GetScreenBounds(var ARect: TRect): Boolean;
var
BoundsRect: HIRect;
WindowRect: FPCMacOSAll.Rect;
const
SName = 'GetScreenBounds';
begin
Result := False;
if HIViewGetBounds(Frame, BoundsRect) <> noErr then Exit;
if HIViewConvertRect(BoundsRect, Frame, nil) <> noErr then Exit;
if OSError(HIViewGetBounds(Frame, BoundsRect), Self, SName, 'HIViewGetBounds') then Exit;
if OSError(HIViewConvertRect(BoundsRect, Frame, nil), Self, SName,
'HIViewConvertRect') then Exit;
if GetWindowBounds(GetTopParentWindow, kWindowStructureRgn,
WindowRect) <> noErr then Exit;
if OSError(GetWindowBounds(GetTopParentWindow, kWindowStructureRgn,
WindowRect), Self, SName, SGetWindowBounds) then Exit;
ARect := CGRectToRect(BoundsRect);
OffsetRect(ARect, WindowRect.left, WindowRect.top);
@ -397,6 +505,15 @@ begin
Result := True;
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.SetBounds
Params: ARect - Record for control coordinates
Returns: If function succeeds
Sets the control bounding rectangle relative to the client origin of its
parent
------------------------------------------------------------------------------}
function TCarbonControl.SetBounds(const ARect: TRect): Boolean;
var
R: TRect;
@ -417,29 +534,47 @@ begin
Result := True;
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.SetColor
Params: AColor - New color
Sets the color of control (for edit like controls)
------------------------------------------------------------------------------}
procedure TCarbonControl.SetColor(const AColor: TColor);
var
FontStyle: ControlFontStyleRec;
begin
// get current font style preserve other font settings
GetControlData(ControlRef(Widget), kControlEntireControl,
kControlFontStyleTag, SizeOf(FontStyle), @FontStyle, nil);
OSError(GetControlData(ControlRef(Widget), kControlEntireControl,
kControlFontStyleTag, SizeOf(FontStyle), @FontStyle, nil), Self, SSetColor,
SGetData, SControlFont);
FontStyle.flags := FontStyle.flags or kControlUseBackColorMask;
FontStyle.backColor := ColorToRGBColor(AColor);
SetControlFontStyle(ControlRef(Widget), FontStyle);
OSError(SetControlFontStyle(ControlRef(Widget), FontStyle), Self, SSetColor,
SSetFontStyle);
// invalidate control
Invalidate;
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.SetFont
Params: AFont - New font
Sets the font of control
------------------------------------------------------------------------------}
procedure TCarbonControl.SetFont(const AFont: TFont);
var
FontStyle: ControlFontStyleRec;
const
SName = 'SetFont';
begin
// get current font style to preserve other font settings
GetControlData(ControlRef(Widget), kControlEntireControl,
kControlFontStyleTag, SizeOf(FontStyle), @FontStyle, nil);
OSError(GetControlData(ControlRef(Widget), kControlEntireControl,
kControlFontStyleTag, SizeOf(FontStyle), @FontStyle, nil), Self, SName,
SGetData, SControlFont);
FontStyle.flags := FontStyle.flags or kControlUseFontMask or kControlUseSizeMask or
kControlUseFaceMask or kControlUseForeColorMask;
@ -449,56 +584,80 @@ begin
FontStyle.style := FontStyleToQDStyle(AFont.Style);
FontStyle.foreColor := ColorToRGBColor(AFont.Color);
SetControlFontStyle(ControlRef(Widget), FontStyle);
OSError(SetControlFontStyle(ControlRef(Widget), FontStyle), Self, SName,
SSetFontStyle);
// invalidate control
Invalidate;
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.ShowHide
Params: AVisible - if show
Shows or hides control
------------------------------------------------------------------------------}
procedure TCarbonControl.ShowHide(AVisible: Boolean);
begin
HIViewSetVisible(Frame, AVisible);
OSError(HIViewSetVisible(Frame, AVisible), Self, 'ShowHide', SViewVisible);
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.GetText
Params: S - Text
Returns: If the function succeeds
Gets the text or caption of control
------------------------------------------------------------------------------}
function TCarbonControl.GetText(var S: String): Boolean;
begin
Result := False; // control caption is static, edit controls override this
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.SetText
Params: S - New text
Returns: If the function succeeds
Sets the text or caption of control
------------------------------------------------------------------------------}
function TCarbonControl.SetText(const S: String): Boolean;
var
CFString: CFStringRef;
T: String;
begin
Result := False;
CFString := HIViewCopyText(HIViewRef(Widget));
if CFString = nil then Exit;
T := S;
DeleteAmpersands(T);
CreateCFString(T, CFString);
try
S := CFStringToStr(CFString);
if OSError(HIViewSetText(HIViewRef(Widget), CFString), Self, SSetText,
'HIViewSetText') then Exit;
Result := True;
finally
FreeCFString(CFString);
end;
end;
function TCarbonControl.SetText(const S: String): Boolean;
var
CFString: CFStringRef;
begin
Result := False;
CreateCFString(S, CFString);
try
Result := HIViewSetText(HIViewRef(Widget), CFString) = noErr;
finally
FreeCFString(CFString);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.Update
Returns: If the function succeeds
Updates control
------------------------------------------------------------------------------}
function TCarbonControl.Update: Boolean;
begin
Result := HIViewRender(HIViewRef(Widget)) = noErr;
Result := False;
if OSError(HIViewRender(HIViewRef(Widget)), Self, 'Update', 'HIViewRender') then Exit;
Result := True;
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.GetTopParentWindow
Returns: Window reference
Retrieves the parent window reference of the Carbon control
Returns: Retrieves the parent window reference of the Carbon control
------------------------------------------------------------------------------}
function TCarbonControl.GetTopParentWindow: WindowRef;
var
@ -533,14 +692,17 @@ var
P: FPCMacOSAll.Point;
MousePoint: HIPoint;
R: FPCMacOSAll.Rect;
const
SName = 'GetMousePos';
begin
GetGlobalMouse(P);
GetWindowBounds(GetTopParentWindow, kWindowStructureRgn, R);
OSError(GetWindowBounds(GetTopParentWindow, kWindowStructureRgn, R),
Self, SName, SGetWindowBounds);
MousePoint.X := P.h - R.left;
MousePoint.Y := P.v - R.top;
HIViewConvertPoint(MousePoint, nil, Content);
OSError(HIViewConvertPoint(MousePoint, nil, Content), Self, SName, SViewConvert);
Result.X := Trunc(MousePoint.X);
Result.Y := Trunc(MousePoint.Y);
end;
@ -550,19 +712,20 @@ end;
Params: ARect - Record for client area coordinates
Returns: If the function succeeds
Returns the control client rectangle relative to the parent client area origin
Returns the control client rectangle relative to the control origin
------------------------------------------------------------------------------}
function TCarbonControl.GetClientRect(var ARect: TRect): Boolean;
var
AClientRect: FPCMacOSAll.Rect;
ClientRegion: FPCMacOSAll.RgnHandle;
R: OSStatus;
begin
Result := False;
ClientRegion := FPCMacOSAll.NewRgn();
try
case GetControlRegion(ControlRef(Widget), kControlContentMetaPart,
ClientRegion) of
R := GetControlRegion(ControlRef(Widget), kControlContentMetaPart, ClientRegion);
case R of
errInvalidPartCode:
begin
// controls without content area have clientrect = boundsrect
@ -579,27 +742,32 @@ begin
if Result then ARect := CarbonRectToRect(AClientRect);
//DebugLn('TCarbonControl.GetClientRect ' + LCLObject.Name + ' ' + DbgS(Result));
end;
else
OSError(R, Self, 'GetClientRect', 'GetControlRegion');
end;
finally
FPCMacOSAll.DisposeRgn(ClientRegion);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonControl.GetPreferredSize
Returns: The preffered size of control for autosizing or (0, 0)
------------------------------------------------------------------------------}
function TCarbonControl.GetPreferredSize: TPoint;
var
R: FPCMacOSAll.Rect;
S: SmallInt;
begin
Result.X := 0;
Result.Y := 0;
R := GetCarbonRect(0, 0, 0, 0);
if GetBestControlRect(ControlRef(Widget), R, S) = noErr then
begin
Result.X := R.right - R.left;
Result.Y := R.bottom - R.top;
end
else
begin
Result.X := 0;
Result.Y := 0;
end;
if OSError(GetBestControlRect(ControlRef(Widget), R, S), Self,
'GetPreferredSize', 'GetBestControlRect') then Exit;
Result.X := R.right - R.left;
Result.Y := R.bottom - R.top;
end;

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

@ -19,6 +19,9 @@
// H A N D L E R S
// ==================================================================
{------------------------------------------------------------------------------
Name: CarbonWindow_Close
------------------------------------------------------------------------------}
function CarbonWindow_Close(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
@ -59,6 +62,9 @@ var
// or the rootcontrol if none found
Widget: TCarbonWidget; // the widget specific to the mouse event
// or the window's widgetinfo if none found
const
SName = 'CarbonWindow_MouseProc';
AGetEvent = 'GetEventParameter';
//
// helper functions used commonly
@ -67,8 +73,13 @@ var
var
ClickCount: UInt32;
begin
GetEventParameter(AEvent, kEventParamClickCount, typeUInt32, nil,
SizeOf(ClickCount), nil, @ClickCount);
Result := 1;
if OSError(
GetEventParameter(AEvent, kEventParamClickCount, typeUInt32, nil,
SizeOf(ClickCount), nil, @ClickCount),
SName, AGetEvent, 'kEventParamClickCount') then Exit;
Result := ClickCount;
//debugln('GetClickCount ClickCount=',dbgs(ClickCount));
end;
@ -78,8 +89,13 @@ var
var
MouseButton: EventMouseButton;
begin
GetEventParameter(AEvent, kEventParamMouseButton, typeMouseButton, nil,
SizeOf(MouseButton), nil, @MouseButton);
Result := 1;
if OSError(
GetEventParameter(AEvent, kEventParamMouseButton, typeMouseButton, nil,
SizeOf(MouseButton), nil, @MouseButton),
SName, AGetEvent, 'kEventParamMouseButton') then Exit;
Result := MouseButton;
end;
@ -87,8 +103,10 @@ var
var
MousePoint: HIPoint;
begin
GetEventParameter(AEvent, kEventParamWindowMouseLocation, typeHIPoint, nil,
SizeOf(MousePoint), nil, @MousePoint);
if OSError(
GetEventParameter(AEvent, kEventParamWindowMouseLocation, typeHIPoint, nil,
SizeOf(MousePoint), nil, @MousePoint),
SName, AGetEvent, 'kEventParamWindowMouseLocation') then Exit;
HIViewConvertPoint(MousePoint, nil, Control);
Result.X := Trunc(MousePoint.X);
@ -99,8 +117,13 @@ var
var
WheelDelta: SInt32;
begin
GetEventParameter(AEvent, kEventParamMouseWheelDelta, typeSInt32, nil,
SizeOf(WheelDelta), nil, @WheelDelta);
Result := 0;
if OSError(
GetEventParameter(AEvent, kEventParamMouseWheelDelta, typeSInt32, nil,
SizeOf(WheelDelta), nil, @WheelDelta),
SName, AGetEvent, 'kEventParamMouseWheelDelta') then Exit;
Result := WheelDelta;
{$IFDEF VerboseMouse}
DebugLn('GetMouseWheelDelta WheelDelta=', DbgS(WheelDelta), ' ', HexStr(WheelDelta, 8));
@ -126,7 +149,7 @@ var
Msg: ^TLMMouse;
begin
{$IFDEF VerboseMouse}
DebugLN('HandleMouseDownEvent');
DebugLn('HandleMouseDownEvent');
{$ENDIF}
Msg := @AMsg;
@ -178,7 +201,7 @@ var
MSg: ^TLMMouseMove;
begin
{$IFDEF VerboseMouse}
DebugLN('HandleMouseMovedEvent');
DebugLn('HandleMouseMovedEvent');
{$ENDIF}
Msg := @AMsg;
@ -193,7 +216,7 @@ var
procedure HandleMouseDraggedEvent(var AMsg);
begin
{$IFDEF VerboseMouse}
DebugLN('-- mouse dragged --');
DebugLn('-- mouse dragged --');
{$ENDIF}
// TODO
end;
@ -204,7 +227,7 @@ var
MSg: ^TLMMouseEvent;
begin
{$IFDEF VerboseMouse}
DebugLN('HandleMouseWheelEvent');
DebugLn('HandleMouseWheelEvent');
{$ENDIF}
Msg := @AMsg;
@ -230,7 +253,8 @@ begin
//Find out which control the mouse event should occur for
Control := nil;
if HIViewGetViewForMouseEvent(AWidget.Content, AEvent, Control) <> noErr then Exit;
if OSError(HIViewGetViewForMouseEvent(AWidget.Content, AEvent, Control),
SName, 'HIViewGetViewForMouseEvent') then Exit;
if Control = nil then Exit;
Widget := GetCarbonWidget(Control);
@ -266,6 +290,10 @@ begin
NotifyApplicationUserInput(Msg.Message.Msg);
end;
{------------------------------------------------------------------------------
Name: CarbonWindow_KeyboardProc
Handles key events
------------------------------------------------------------------------------}
function CarbonWindow_KeyboardProc(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
@ -281,6 +309,9 @@ var
IsSysKey: Boolean; //Is alt (option) key down?
KeyData : PtrInt; //Modifiers (ctrl, alt, mouse buttons...)
EventKind: UInt32; //The kind of this event
const
SName = 'CarbonWindow_KeyboardProc';
AGetEvent = 'GetEventParameter';
//See what changed in the modifiers flag so that we can emulate a keyup/keydown
//note: this function assumes that only a bit of the flag can be modified at
@ -290,8 +321,10 @@ var
begin
Result:=false;
SendChar:=false;
if GetEventParameter(AEvent, kEventParamKeyModifiers, typeUInt32, nil,
sizeof(CurMod), nil, @CurMod)<>noErr then exit;
if OSError(
GetEventParameter(AEvent, kEventParamKeyModifiers, typeUInt32, nil,
SizeOf(CurMod), nil, @CurMod), SName, AGetEvent,
'kEventParamKeyModifiers') then Exit;
//see what changed. we only care of bits 8 through 12
diff:=(PrevKeyModifiers xor CurMod) and $1F00;
@ -314,6 +347,7 @@ var
else exit; //Error! More that one bit changed in the modifiers?
end;
Result:=true;
{$IFDEF VerboseKeyboard}
DebugLn('[EmulateModifiersDownUp] VK =', DbgsVKCode(VKKeyCode));
{$ENDIF}
@ -350,8 +384,9 @@ var
KeyData:=GetCarbonMsgKeyState;
IsSysKey:=(GetCurrentEventKeyModifiers and optionKey)>0;
if GetEventParameter(AEvent, kEventParamKeyCode, typeUInt32, nil,
sizeof(KeyCode), nil, @KeyCode)<>noErr then exit;
if OSError(GetEventParameter(AEvent, kEventParamKeyCode, typeUInt32, nil,
Sizeof(KeyCode), nil, @KeyCode), SName, AGetEvent,
'kEventParamKeyCode') then Exit;
//non-printable keys (see mackeycodes.inc)
//for these keys, only send keydown/keyup (not char or UTF8KeyPress)
@ -398,39 +433,47 @@ var
//printable keys
//for these keys, send char or UTF8KeyPress
if GetEventParameter(AEvent, kEventParamKeyUnicodes, typeUnicodeText, nil,
6, @TextLen, @Buf[1])<>noErr then exit;
if OSError(
GetEventParameter(AEvent, kEventParamKeyUnicodes, typeUnicodeText, nil,
6, @TextLen, @Buf[1]), SName, AGetEvent, 'kEventParamKeyUnicodes') then Exit;
if TextLen>0 then
begin
SendChar:=true;
u:=UTF16CharacterToUnicode(PWideChar(@Buf[1]),CharLen);
if CharLen=0 then exit;
UTF8Character:=UnicodeToUTF8(u);
if ord(Utf8Character[1])<=127 then //It's (true) ascii.
KeyChar:=Utf8Character[1]
else //not ascii, get the Mac character.
if GetEventParameter(AEvent, kEventParamKeyMacCharCodes, typeChar, nil,
sizeof(KeyChar), nil, @KeyChar)<>noErr then exit;
if OSError(
GetEventParameter(AEvent, kEventParamKeyMacCharCodes, typeChar, nil,
Sizeof(KeyChar), nil, @KeyChar), SName, AGetEvent,
'kEventParamKeyMacCharCodes') then Exit;
case KeyChar of
'a'..'z' : VKKeyCode:=VK_A+ord(KeyChar)-ord('a');
'A'..'Z' : VKKeyCode:=ord(KeyChar);
#27 : VKKeyCode:=VK_ESCAPE;
#8 : VKKeyCode:=VK_BACK;
' ' : VKKeyCode:=VK_SPACE;
#13 : VKKeyCode:=VK_RETURN;
'0'..'9' : case KeyCode of
MK_NUMPAD0 : VKKeyCode:=VK_NUMPAD0;
MK_NUMPAD1 : VKKeyCode:=VK_NUMPAD1;
MK_NUMPAD2 : VKKeyCode:=VK_NUMPAD2;
MK_NUMPAD3 : VKKeyCode:=VK_NUMPAD3;
MK_NUMPAD4 : VKKeyCode:=VK_NUMPAD4;
MK_NUMPAD5 : VKKeyCode:=VK_NUMPAD5;
MK_NUMPAD6 : VKKeyCode:=VK_NUMPAD6;
MK_NUMPAD7 : VKKeyCode:=VK_NUMPAD7;
MK_NUMPAD8 : VKKeyCode:=VK_NUMPAD8;
MK_NUMPAD9 : VKKeyCode:=VK_NUMPAD9
else VKKeyCode:=ord(KeyChar);
end
'a'..'z': VKKeyCode:=VK_A+ord(KeyChar)-ord('a');
'A'..'Z': VKKeyCode:=ord(KeyChar);
#27 : VKKeyCode:=VK_ESCAPE;
#8 : VKKeyCode:=VK_BACK;
' ' : VKKeyCode:=VK_SPACE;
#13 : VKKeyCode:=VK_RETURN;
'0'..'9':
case KeyCode of
MK_NUMPAD0: VKKeyCode:=VK_NUMPAD0;
MK_NUMPAD1: VKKeyCode:=VK_NUMPAD1;
MK_NUMPAD2: VKKeyCode:=VK_NUMPAD2;
MK_NUMPAD3: VKKeyCode:=VK_NUMPAD3;
MK_NUMPAD4: VKKeyCode:=VK_NUMPAD4;
MK_NUMPAD5: VKKeyCode:=VK_NUMPAD5;
MK_NUMPAD6: VKKeyCode:=VK_NUMPAD6;
MK_NUMPAD7: VKKeyCode:=VK_NUMPAD7;
MK_NUMPAD8: VKKeyCode:=VK_NUMPAD8;
MK_NUMPAD9: VKKeyCode:=VK_NUMPAD9
else VKKeyCode:=ord(KeyChar);
end;
else
case KeyCode of
MK_PADDIV : VKKeyCode:=VK_DIVIDE;
@ -438,7 +481,12 @@ var
MK_PADSUB : VKKeyCode:=VK_SUBTRACT;
MK_PADADD : VKKeyCode:=VK_ADD;
MK_PADDEC : VKKeyCode:=VK_DECIMAL;
MK_PADENTER: begin VKKeyCode:=VK_RETURN; KeyChar:=#13; UTF8Character:=KeyChar; end;
MK_PADENTER:
begin
VKKeyCode:=VK_RETURN;
KeyChar:=#13;
UTF8Character:=KeyChar;
end;
end;
end;
@ -459,7 +507,7 @@ var
else Debugln('[TranslateMacKeyCode] ***WARNING: Can''t get unicode character!***');
end;
function HandleRawKeyDownEvent : OSStatus;
function HandleRawKeyDownEvent: OSStatus;
var
KeyMsg: TLMKeyDown;
CharMsg: TLMChar;
@ -485,8 +533,10 @@ var
{$IFDEF VerboseKeyboard}
DebugLn('[HandleRawKeyDownEvent] LCL handled CN_KEYDOWN, exiting');
{$ENDIF}
NotifyApplicationUserInput(KeyMsg.Msg);
Result := noErr;
exit;
Exit;
end;
//Here is where we (interface) can do something with the key
@ -503,7 +553,9 @@ var
DebugLn('[HandleRawKeyDownEvent] LCL handled LM_KEYDOWN, exiting');
{$ENDIF}
//Result already set by CallNextEventHandler
exit;
NotifyApplicationUserInput(KeyMsg.Msg);
Exit;
end;
end;
@ -519,7 +571,7 @@ var
{$ENDIF}
if Result=EventNotHandledErr then
Result := noErr;
exit;
Exit;
end;
// create the CN_CHAR / CN_SYSCHAR message
@ -538,7 +590,9 @@ var
{$ENDIF}
if Result=EventNotHandledErr then
Result := noErr;
exit;
NotifyApplicationUserInput(CharMsg.Msg);
Exit;
end;
//Here is where we (interface) can do something with the key
@ -557,9 +611,10 @@ var
{$ENDIF}
if Result=EventNotHandledErr then
Result := noErr;
exit;
NotifyApplicationUserInput(CharMsg.Msg);
Exit;
end;
end;
end;
@ -589,7 +644,9 @@ var
Debugln('[HandleRawKeyUpEvent] LCL handled CN_KEYUP, exiting');
{$ENDIF}
Result := noErr;
exit;
NotifyApplicationUserInput(KeyMsg.Msg);
Exit;
end;
//Here is where we (interface) can do something with the key
@ -607,7 +664,9 @@ var
{$ENDIF}
if Result=EventNotHandledErr then
Result := noErr;
exit;
NotifyApplicationUserInput(KeyMsg.Msg);
Exit;
end;
end;
@ -615,9 +674,10 @@ var
begin
Result := EventNotHandledErr;
//In compositing mode, this is the content view
Control := nil;
GetKeyboardFocus(AWidget.Widget, Control);
if OSError(GetKeyboardFocus(AWidget.Widget, Control), SName,
'GetKeyboardFocus') then Exit;
if Control = nil then Control := AWidget.Content;
// if a control other than root is found, send the message
@ -630,19 +690,18 @@ begin
if Widget <> nil then Break;
Control := HIViewGetSuperview(Control);
end;
if (Widget = nil) or (Control = AWidget.Content)
then Widget := AWidget;
if (Widget = nil) or (Control = AWidget.Content) then Widget := AWidget;
EventKind := GetEventKind(AEvent);
if EventKind = kEventRawKeyModifiersChanged then
begin
if not EmulateModifiersDownUp then exit;
if not EmulateModifiersDownUp then Exit;
end
else
if not TranslateMacKeyCode then
begin
Debugln('[CarbonWindow_KeyboardProc] ***WARNING: TranslateMacKeyCode failed***');
exit;
Exit;
end;
case EventKind of
@ -652,6 +711,10 @@ begin
end;
end;
{------------------------------------------------------------------------------
Name: CarbonWindow_ActivateProc
Handles window activating/deactivating
------------------------------------------------------------------------------}
function CarbonWindow_ActivateProc(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
@ -670,17 +733,25 @@ begin
case EventKind of
kEventWindowActivated: Msg.msg := LM_ACTIVATE;
kEventWindowDeactivated: Msg.msg := LM_DEACTIVATE;
else Exit;
else
DebugLn('CarbonWindow_ActivateProc invalid event kind: ' + DbgS(EventKind));
Exit;
end;
DeliverMessage(AWidget.LCLObject, Msg);
end;
{------------------------------------------------------------------------------
Name: CarbonWindow_ShowWindow
Handles window minimizing/maximizing/restoring
------------------------------------------------------------------------------}
function CarbonWindow_ShowWindow(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
var
Msg: TLMShowWindow;
EventKind: UInt32;
WidgetBounds: TRect;
Kind: Integer;
begin
{$IFDEF VerboseWindowEvent}
DebugLn('CarbonWindow_ShowWindow ', DbgSName(AWidget.LCLObject));
@ -688,32 +759,45 @@ begin
Result := CallNextEventHandler(ANextHandler, AEvent);
FillChar(Msg, SizeOf(Msg), 0);
Msg.msg := LM_SHOWWINDOW;
EventKind := GetEventKind(AEvent);
Kind := -1;
case EventKind of
kEventWindowCollapsed:
begin
Msg.Show := False;
Msg.Status := SW_MINIMIZE;
end;
kEventWindowCollapsed: Kind := SIZEICONIC;
kEventWindowExpanded, kEventWindowZoomed:
begin
Msg.Show := True;
if IsWindowInStandardState(WindowRef(AWidget.Widget), nil, nil) then
Msg.Status := SW_SHOWNORMAL
Kind := SIZEFULLSCREEN
else
Msg.Status := SW_SHOWMAXIMIZED;
Kind := SIZENORMAL;
end;
else Exit;
else
DebugLn('CarbonWindow_ShowWindow invalid event kind: ' + DbgS(EventKind));
Exit;
end;
DeliverMessage(AWidget.LCLObject, Msg);
{$IFDEF VerboseWindowEvent}
DebugLn('CarbonWindow_ShowWindow Event: ', DbgS(EventKind) + ' Kind: ' +
DbgS(Kind) + ' Showing: ' + DbgS(AWidget.LCLObject.Showing));
{$ENDIF}
if Kind >= 0 then
begin
AWidget.GetBounds(WidgetBounds);
LCLSendSizeMsg(AWidget.LCLObject, WidgetBounds.Right - WidgetBounds.Left,
WidgetBounds.Bottom - WidgetBounds.Top, Size_SourceIsInterface or Kind);
end;
end;
{ TCarbonWindow }
{------------------------------------------------------------------------------
Method: TCarbonWindow.RegisterEvents
Registers event handlers for window and its content area
------------------------------------------------------------------------------}
procedure TCarbonWindow.RegisterEvents;
var
MouseSpec: array [0..6] of EventTypeSpec;
@ -832,6 +916,11 @@ begin
{$ENDIF}
end;
{------------------------------------------------------------------------------
Method: TCarbonWindow.UnregisterEvents
Unregisters event handlers
------------------------------------------------------------------------------}
procedure TCarbonWindow.UnregisterEvents;
begin
UnregisterEventHandler(@CarbonWindow_Close);
@ -852,6 +941,12 @@ begin
UnregisterEventHandler(@CarbonCommon_CursorChange);
end;
{------------------------------------------------------------------------------
Method: TCarbonWindow.CreateWidget
Params: AParams - Creation parameters
Creates Carbon window
------------------------------------------------------------------------------}
procedure TCarbonWindow.CreateWidget(const AParams: TCreateParams);
var
Window: WindowRef;
@ -880,20 +975,26 @@ begin
Attributes := kWindowCloseBoxAttribute or kWindowResizableAttribute;
end;
if CreateNewWindow(NewWindowClass,
Attributes or kWindowCompositingAttribute or
kWindowStandardHandlerAttribute or kWindowLiveResizeAttribute or
kWindowInWindowMenuAttribute, ParamsToCarbonRect(AParams),
Window) = noErr then
begin
Widget := Window;
SetWindowProperty(Widget, LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(Self), @Self);
SetControlProperty(Content, LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(Self), @Self);
end
else RaiseCreateWidgetError(LCLObject);
//DebugLn('TCarbonWindow.CreateWidget ' + DbgS(ParamsToCarbonRect(AParams)));
if OSError(
CreateNewWindow(NewWindowClass,
Attributes or kWindowCompositingAttribute or
kWindowStandardHandlerAttribute or kWindowLiveResizeAttribute or
kWindowInWindowMenuAttribute, ParamsToCarbonRect(AParams), Window),
Self, SCreateWidget, 'CreateNewWindow') then RaiseCreateWidgetError(LCLObject);
Widget := Window;
OSError(
SetWindowProperty(Window, LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(Self), @Self),
Self, SCreateWidget, 'SetWindowProperty');
OSError(
SetControlProperty(Content, LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(Self), @Self),
Self, SCreateWidget, SSetControlProp);
SetText(AParams.Caption);
DebugLn('TCarbonWindow.CreateWidget succeeds');
SetColor(LCLObject.Color);
MinSize.width := LCLObject.Constraints.EffectiveMinWidth;
@ -903,14 +1004,17 @@ begin
if MaxSize.width <= 0 then MaxSize.width := 10000;
if MaxSize.height <= 0 then MaxSize.height := 10000;
SetWindowResizeLimits(Window, @MinSize, @MaxSize);
OSError(SetWindowResizeLimits(Window, @MinSize, @MaxSize), Self, SCreateWidget,
'SetWindowResizeLimits');
end;
{------------------------------------------------------------------------------
Method: TCarbonWindow.DestroyWidget
Override to do some clean-up
------------------------------------------------------------------------------}
procedure TCarbonWindow.DestroyWidget;
begin
RemoveWindowProperty(Widget, LAZARUS_FOURCC, WIDGETINFO_FOURCC);
RemoveControlProperty(Content, LAZARUS_FOURCC, WIDGETINFO_FOURCC);
DisposeWindow(WindowRef(Widget));
Widget := nil;
end;
@ -921,8 +1025,9 @@ end;
------------------------------------------------------------------------------}
function TCarbonWindow.GetContent: ControlRef;
begin
if HIViewFindByID(HIViewGetRoot(WindowRef(Widget)), kHIViewWindowContentID,
Result) <> noErr then Result := nil;
if OSError(
HIViewFindByID(HIViewGetRoot(WindowRef(Widget)), kHIViewWindowContentID,
Result), Self, 'GetContent', 'HIViewGetRoot') then Result := nil;
end;
{------------------------------------------------------------------------------
@ -936,11 +1041,16 @@ var
begin
GetGlobalMouse(P);
GetWindowBounds(WindowRef(Widget), kWindowContentRgn, R);
OSError(GetWindowBounds(WindowRef(Widget), kWindowContentRgn, R),
Self, 'GetMousePos', SGetWindowBounds);
Result.X := P.h - R.left;
Result.Y := P.v - R.Top;
end;
{------------------------------------------------------------------------------
Method: TCarbonWindow.GetTopParentWindow
Returns: Retrieves the window reference
------------------------------------------------------------------------------}
function TCarbonWindow.GetTopParentWindow: WindowRef;
begin
Result := WindowRef(Widget);
@ -956,13 +1066,17 @@ end;
function TCarbonWindow.GetClientRect(var ARect: TRect): Boolean;
var
AWndRect, AClientRect: FPCMacOSAll.Rect;
const
SName = 'GetClientRect';
begin
Result := False;
if FPCMacOSAll.GetWindowBounds(WindowRef(Widget), kWindowStructureRgn,
AWndRect) <> noErr then Exit;
if FPCMacOSAll.GetWindowBounds(WindowRef(Widget), kWindowContentRgn,
AClientRect) <> noErr then Exit;
if OSError(
GetWindowBounds(WindowRef(Widget), kWindowStructureRgn, AWndRect), Self,
SName, SGetWindowBounds, 'kWindowStructureRgn') then Exit;
if OSError(
GetWindowBounds(WindowRef(Widget), kWindowContentRgn, AClientRect), Self,
SName, SGetWindowBounds, 'kWindowContentRgn') then Exit;
ARect.Left := AClientRect.Left - AWndRect.Left;
ARect.Top := AClientRect.Top - AWndRect.Top;
@ -980,21 +1094,40 @@ end;
------------------------------------------------------------------------------}
procedure TCarbonWindow.Invalidate(Rect: PRect);
begin
if Rect = nil then HiViewSetNeedsDisplay(HIViewRef(Content), True)
if Rect = nil then
OSError(HiViewSetNeedsDisplay(HIViewRef(Content), True), Self, SInvalidate,
SViewNeedsDisplay)
else
HiViewSetNeedsDisplayInRect(HIViewRef(Content), RectToCGRect(Rect^), True);
OSError(
HiViewSetNeedsDisplayInRect(HIViewRef(Content), RectToCGRect(Rect^), True),
Self, SInvalidate, SViewNeedsDisplayRect);
end;
{------------------------------------------------------------------------------
Method: TCarbonWindow.IsEnabled
Returns: If window is enabled
------------------------------------------------------------------------------}
function TCarbonWindow.IsEnabled: Boolean;
begin
Result := IsControlEnabled(Content);
end;
{------------------------------------------------------------------------------
Method: TCarbonWindow.IsVisible
Returns: If window is visible
------------------------------------------------------------------------------}
function TCarbonWindow.IsVisible: Boolean;
begin
Result := FPCMacOSAll.IsWindowVisible(WindowRef(Widget));
end;
{------------------------------------------------------------------------------
Method: TCarbonWindow.Enable
Params: AEnable - if enable
Returns: If window is enabled
Changes window enabled
------------------------------------------------------------------------------}
function TCarbonWindow.Enable(AEnable: Boolean): boolean;
begin
Result := not FPCMacOSAll.IsControlEnabled(Content);
@ -1003,56 +1136,109 @@ begin
// add/remove standard handler
if AEnable then
begin
FPCMacOSAll.EnableControl(Content);
ChangeWindowAttributes(WindowRef(Widget), kWindowStandardHandlerAttribute,
kWindowNoAttributes);
OSError(FPCMacOSAll.EnableControl(Content), Self, SEnable, SEnableControl);
OSError(
ChangeWindowAttributes(WindowRef(Widget), kWindowStandardHandlerAttribute,
kWindowNoAttributes), Self, SEnable, SChangeWindowAttrs);
end
else
begin
FPCMacOSAll.DisableControl(Content);
ChangeWindowAttributes(WindowRef(Widget), kWindowNoAttributes,
kWindowStandardHandlerAttribute);
OSError(FPCMacOSAll.DisableControl(Content), Self, SEnable, SDisableControl);
OSError(
ChangeWindowAttributes(WindowRef(Widget), kWindowNoAttributes,
kWindowStandardHandlerAttribute), Self, SEnable, SChangeWindowAttrs);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonWindow.GetBounds
Params: ARect - Record for window coordinates
Params: ARect - Record for window coordinates
Returns: If function succeeds
Returns the window bounding rectangle relative to the client origin of its
parent
Note: only the pos of rectangle is exact, its size is size of client area
------------------------------------------------------------------------------}
function TCarbonWindow.GetBounds(var ARect: TRect): Boolean;
var
AWndRect: FPCMacOSAll.Rect;
AWndRect, AClientRect: FPCMacOSAll.Rect;
const
SName = 'GetBounds';
begin
Result := FPCMacOSAll.GetWindowBounds(WindowRef(Widget), kWindowStructureRgn,
AWndRect) = noErr;
if Result then ARect := CarbonRectToRect(AWndRect);
Result := False;
if OSError(
FPCMacOSAll.GetWindowBounds(WindowRef(Widget), kWindowStructureRgn, AWndRect),
Self, SName, SGetWindowBounds, 'kWindowStructureRgn') then Exit;
if OSError(
FPCMacOSAll.GetWindowBounds(WindowRef(Widget), kWindowContentRgn, AClientRect),
Self, SName, SGetWindowBounds, 'kWindowContentRgn') then Exit;
ARect.Left := AWndRect.Left;
ARect.Top := AWndRect.Top;
ARect.Right := ARect.Left + (AClientRect.Right - AClientRect.Left);
ARect.Bottom := ARect.Top + (AClientRect.Bottom - AClientRect.Top);
Result := True;
end;
{------------------------------------------------------------------------------
Method: TCarbonWindow.GetScreenBounds
Params: ARect - Record for window coordinates
Returns: If function succeeds
Returns the window bounding rectangle relative to the screen
Note: only the pos of rectangle is exact, its size is size of client area
------------------------------------------------------------------------------}
function TCarbonWindow.GetScreenBounds(var ARect: TRect): Boolean;
begin
Result := GetBounds(ARect);
end;
{------------------------------------------------------------------------------
Method: TCarbonWindow.SetBounds
Params: ARect - Record for window coordinates
Returns: If function succeeds
Sets the window content bounding rectangle relative to the window frame origin
------------------------------------------------------------------------------}
function TCarbonWindow.SetBounds(const ARect: TRect): Boolean;
begin
Result := FPCMacOSAll.SetWindowBounds(WindowRef(Widget), kWindowContentRgn,
GetCarbonRect(ARect)) = noErr;
Result := False;
if OSError(FPCMacOSAll.SetWindowBounds(WindowRef(Widget), kWindowContentRgn,
GetCarbonRect(ARect)), Self, 'SetBounds', 'SetWindowBounds') then Exit;
Result := True;
end;
{------------------------------------------------------------------------------
Method: TCarbonWindow.SetColor
Params: AColor - New color
Sets the color of window content
------------------------------------------------------------------------------}
procedure TCarbonWindow.SetColor(const AColor: TColor);
begin
SetWindowContentColor(WindowRef(Widget), ColorToRGBColor(AColor));
OSError(SetWindowContentColor(WindowRef(Widget), ColorToRGBColor(AColor)),
Self, SSetColor, 'SetWindowContentColor');
end;
{------------------------------------------------------------------------------
Method: TCarbonWindow.SetFont
Params: AFont - New font
Sets the font of window
------------------------------------------------------------------------------}
procedure TCarbonWindow.SetFont(const AFont: TFont);
begin
//
end;
{------------------------------------------------------------------------------
Method: TCarbonWindow.ShowHide
Params: AVisible - if show
Shows or hides window
------------------------------------------------------------------------------}
procedure TCarbonWindow.ShowHide(AVisible: Boolean);
begin
if AVisible then
@ -1061,21 +1247,25 @@ begin
FPCMacOSAll.HideWindow(WindowRef(Widget));
end;
{------------------------------------------------------------------------------
Method: TCarbonWindow.GetText
Params: S - Text
Returns: If the function succeeds
Gets the title of window
------------------------------------------------------------------------------}
function TCarbonWindow.GetText(var S: String): Boolean;
var
CFString: CFStringRef;
begin
Result := False;
if CopyWindowTitleAsCFString(WindowRef(Widget), CFString) = NoErr then
try
S := CFStringToStr(CFString);
Result := True;
finally
FreeCFString(CFString);
end;
Result := False; // window title is static
end;
{------------------------------------------------------------------------------
Method: TCarbonWindow.SetText
Params: S - New text
Returns: If the function succeeds
Sets the title of window
------------------------------------------------------------------------------}
function TCarbonWindow.SetText(const S: String): Boolean;
var
CFString: CFStringRef;
@ -1083,13 +1273,23 @@ begin
Result := False;
CreateCFString(S, CFString);
try
Result := SetWindowTitleWithCFString(WindowRef(Widget), CFString) = noErr;
if OSError(SetWindowTitleWithCFString(WindowRef(Widget), CFString), Self,
SSetText, 'SetWindowTitleWithCFString') then Exit;
Result := True;
finally
FreeCFString(CFString);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonWindow.Update
Returns: If the function succeeds
Updates window content
------------------------------------------------------------------------------}
function TCarbonWindow.Update: Boolean;
begin
Result := HIViewRender(Content) = noErr;
Result := False;
if OSError(HIViewRender(Content), Self, 'Update', SViewRender) then Exit;
Result := True;
end;

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

@ -542,9 +542,10 @@ begin
if (FontName <> '') and not SameText(FontName, 'default') then
begin
ATSUFindFontFromName(@FontName[1], Length(FontName),
kFontFamilyName, kFontMacintoshPlatform, kFontRomanScript,
kFontEnglishLanguage, Result);
OSError(ATSUFindFontFromName(@FontName[1], Length(FontName),
kFontFamilyName, kFontMacintoshPlatform, kFontRomanScript,
kFontEnglishLanguage, Result),
'FindCarbonFontID', 'ATSUFindFontFromName');
end;
end;

82
lcl/interfaces/carbon/carbontabs.pp
View File

@ -71,8 +71,10 @@ type
procedure ValueChanged; override;
procedure Hit(AControlPart: ControlPartCode); override;
public
function GetClientRect(var ARect: TRect): Boolean; override;
procedure Add(ATab: TCarbonTab; AIndex: Integer);
procedure Remove(AIndex: Integer);
procedure SetTabIndex(AIndex: Integer);
public
property TabPosition: TTabPosition read FTabPositon;
end;
@ -161,27 +163,37 @@ end;
procedure TCarbonTabsControl.UpdateTabs(AIndex: Integer; TilEnd: Boolean);
begin
// update tabs count
SetControl32BitMaximum(ControlRef(Widget), FTabs.Count);
// TODO imageindex
while AIndex < FTabs.Count do
begin
DebugLn('TCarbonTabsControl.UpdateTabs ' + DbgS(AIndex) + ' Caption: ' +
TCarbonTab(FTabs[AIndex]).LCLObject.Caption);
SetTabCaption(AIndex, TCarbonTab(FTabs[AIndex]).LCLObject.Caption);
if not TilEnd then Exit;
Inc(AIndex);
end;
Invalidate;
end;
procedure TCarbonTabsControl.SetTabCaption(AIndex: Integer; const S: String);
var
Info: ControlTabInfoRecV1;
T: String;
begin
Info.version := kControlTabInfoVersionOne;
Info.iconSuiteID := 0;
CreateCFString(S, Info.name);
T := S;
DeleteAmpersands(T);
CreateCFString(T, Info.name);
try
if OSError(SetControlData(ControlRef(Widget), AIndex + 1, kControlTabInfoTag,
SizeOf(ControlTabInfoRecV1), @Info),
@ -200,16 +212,41 @@ procedure TCarbonTabsControl.ValueChanged;
var
Msg: TLMNotify;
NMHdr: TNMHDR;
VIndex, PIndex: Integer;
begin
// TODO changing
VIndex := GetControl32BitValue(ControlRef(Widget)) - 1;
if (VIndex >= 0) and (VIndex < FTabs.Count) then
PIndex := (TCarbonTab(FTabs[VIndex]).LCLObject as TCustomPage).PageIndex
else
PIndex := -1;
// send changing
FillChar(Msg, SizeOf(TLMNotify), 0);
Msg.Msg := LM_NOTIFY;
FillChar(NMHdr, SizeOf(TNMHdr), 0);
NMHdr.code := TCN_SELCHANGING;
NMHdr.hwndFrom := LCLObject.Handle;
NMHdr.idFrom := PIndex;
Msg.NMHdr := @NMHdr;
if DeliverMessage(LCLObject, Msg) <> 0 then
begin // tab change cancelled
SetTabIndex((LCLObject as TCustomNoteBook).PageIndex);
Exit;
end;
SetTabIndex(PIndex);
// send change
FillChar(Msg, SizeOf(TLMNotify), 0);
Msg.Msg := LM_NOTIFY;
FillChar(NMHdr, SizeOf(TNMHdr), 0);
NMHdr.code := TCN_SELCHANGE;
NMHdr.hwndFrom := LCLObject.Handle;
NMHdr.idFrom := GetControl32BitValue(ControlRef(Widget)) - 1;
NMHdr.idFrom := PIndex;
Msg.NMHdr := @NMHdr;
@ -221,6 +258,31 @@ begin
ValueChanged;
end;
{------------------------------------------------------------------------------
Method: TCarbonTabsControl.GetClientRect
Params: ARect - Record for client area coordinates
Returns: If the function succeeds
Returns the tabs control client rectangle relative to control origin
------------------------------------------------------------------------------}
function TCarbonTabsControl.GetClientRect(var ARect: TRect): Boolean;
var
AClientRect: FPCMacOSAll.Rect;
begin
Result := False;
DebugLn('TCarbonTabsControl.GetClientRect');
if OSError(GetControlData(ControlRef(Widget), kControlEntireControl,
kControlTabContentRectTag, SizeOf(FPCMacOSAll.Rect), @AClientRect, nil),
Self, 'GetClientRect', 'GetControlData') then Exit;
ARect := CarbonRectToRect(AClientRect);
DebugLn('TCarbonTabsControl.GetClientRect ' + DbgS(ARect));
Result := True;
end;
procedure TCarbonTabsControl.Add(ATab: TCarbonTab; AIndex: Integer);
begin
FTabs.Insert(AIndex, ATab);
@ -236,5 +298,19 @@ begin
UpdateTabs(AIndex, True);
end;
procedure TCarbonTabsControl.SetTabIndex(AIndex: Integer);
var
I, VIndex: Integer;
begin
VIndex := (LCLObject as TCustomNotebook).Page[AIndex].VisibleIndex;
// show tab with VIndex, hide the others
for I := 0 to FTabs.Count - 1 do
TCarbonTab(FTabs[I]).ShowHide(I = VIndex);
if GetControl32BitValue(ControlRef(Widget)) <> VIndex + 1 then
SetControl32BitValue(ControlRef(Widget), VIndex + 1);
end;
end.

45
lcl/interfaces/carbon/carbonutils.pas
View File

@ -31,8 +31,11 @@ unit CarbonUtils;
interface
// debugging defines
{$I carbondebug.inc}
uses
FPCMacOSAll;
FPCMacOSAll, CarbonConsts;
type
TFourCC = packed array[0..3] of Char;
@ -47,20 +50,23 @@ function MakeFourCC(AFourCC: TFourCC): FourCharCode; inline;
// Some missing macros (params differ)
function InstallMenuEventHandler(inMenu: MenuRef;
inHandler: EventHandlerUPP; inNumTypes: UInt32; inList: EventTypeSpecPtr;
inUserData: Pointer; outRef: EventHandlerRefPtr): OSStatus; inline;
inUserData: Pointer; outRef: EventHandlerRefPtr): Boolean;
function InstallControlEventHandler(inControl: ControlRef;
inHandler: EventHandlerUPP; inNumTypes: UInt32; inList: EventTypeSpecPtr;
inUserData: Pointer; outRef: EventHandlerRefPtr): OSStatus; inline;
inUserData: Pointer; outRef: EventHandlerRefPtr): Boolean;
function InstallWindowEventHandler(inWindow: WindowRef;
inHandler: EventHandlerUPP; inNumTypes: UInt32; inList: EventTypeSpecPtr;
inUserData: Pointer; outRef: EventHandlerRefPtr): OSStatus; inline;
inUserData: Pointer; outRef: EventHandlerRefPtr): Boolean;
function InstallApplicationEventHandler(inHandler: EventHandlerUPP;
inNumTypes: UInt32; inList: EventTypeSpecPtr; inUserData: Pointer;
outRef: EventHandlerRefPtr): OSStatus; inline;
outRef: EventHandlerRefPtr): Boolean;
implementation
uses
CarbonProc;
function MakeEventSpec(AClass, AKind: TFourCC): EventTypeSpec; inline;
begin
Result.eventClass := FourCharCode(AClass);
@ -86,34 +92,39 @@ end;
function InstallMenuEventHandler(inMenu: MenuRef; inHandler: EventHandlerUPP;
inNumTypes: UInt32; inList: EventTypeSpecPtr; inUserData: Pointer;
outRef: EventHandlerRefPtr): OSStatus; inline;
outRef: EventHandlerRefPtr): Boolean; inline;
begin
Result := InstallEventHandler(GetMenuEventTarget(inMenu), inHandler,
inNumTypes, inList, inUserData, outRef);
Result := not OSError(
InstallEventHandler(GetMenuEventTarget(inMenu), inHandler, inNumTypes,
inList, inUserData, outRef), 'InstallMenuEventHandler', SInstallEvent);
end;
function InstallControlEventHandler(inControl: ControlRef;
inHandler: EventHandlerUPP; inNumTypes: UInt32; inList: EventTypeSpecPtr;
inUserData: Pointer; outRef: EventHandlerRefPtr): OSStatus; inline;
inUserData: Pointer; outRef: EventHandlerRefPtr): Boolean; inline;
begin
Result := InstallEventHandler(GetControlEventTarget(inControl), inHandler,
inNumTypes, inList, inUserData, outRef);
Result := not OSError(
InstallEventHandler(GetControlEventTarget(inControl), inHandler, inNumTypes,
inList, inUserData, outRef), 'InstallControlEventHandler', SInstallEvent);
end;
function InstallWindowEventHandler(inWindow: WindowRef;
inHandler: EventHandlerUPP; inNumTypes: UInt32; inList: EventTypeSpecPtr;
inUserData: Pointer; outRef: EventHandlerRefPtr): OSStatus; inline;
inUserData: Pointer; outRef: EventHandlerRefPtr): Boolean; inline;
begin
Result := InstallEventHandler(GetWindowEventTarget(inWindow), inHandler,
inNumTypes, inList, inUserData, outRef);
Result := not OSError(
InstallEventHandler(GetWindowEventTarget(inWindow), inHandler, inNumTypes,
inList, inUserData, outRef), 'InstallWindowEventHandler', SInstallEvent);
end;
function InstallApplicationEventHandler(inHandler: EventHandlerUPP;
inNumTypes: UInt32; inList: EventTypeSpecPtr; inUserData: Pointer;
outRef: EventHandlerRefPtr): OSStatus; inline;
outRef: EventHandlerRefPtr): Boolean; inline;
begin
Result := InstallEventHandler(GetApplicationEventTarget, inHandler,
inNumTypes, inList, inUserData, outRef);
Result := not OSError(
InstallEventHandler(GetApplicationEventTarget, inHandler, inNumTypes,
inList, inUserData, outRef), 'InstallApplicationEventHandler',
SInstallEvent);
end;

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

@ -576,7 +576,7 @@ var
EnumLogFont: TEnumLogFontEx;
Metric: TNewTextMetricEx;
FontType, I: Integer;
const AName = 'TCarbonWidgetSet.EnumFontFamiliesEx';
const SName = 'TCarbonWidgetSet.EnumFontFamiliesEx';
begin
{$IFDEF VerboseWinAPI}
DebugLn('TCarbonWidgetSet.EnumFontFamiliesEx');
@ -590,14 +590,14 @@ begin
if (lpLogFont^.lfCharSet = DEFAULT_CHARSET) and (lpLogFont^.lfFaceName = '') then
begin
// all system fonts
if OSError(ATSUFontCount(FamilyCount), AName, 'ATSUFontCount') then Exit;
if OSError(ATSUFontCount(FamilyCount), SName, 'ATSUFontCount') then Exit;
GetMem(FamilyListPtr, SizeOf(ATSUFontID) * FamilyCount);
try
if OSError(ATSUGetFontIDs(FamilyListPtr, FamilyCount, nil), AName, 'ATSUGetFontIDs') then Exit;
if OSError(ATSUGetFontIDs(FamilyListPtr, FamilyCount, nil), SName, 'ATSUGetFontIDs') then Exit;
{$IFDEF VerboseWinAPI}
DebugLn(AName + ' Found: ' + DbgS(FamilyCount));
DebugLn(SName + ' Found: ' + DbgS(FamilyCount));
{$ENDIF}
PFamily := FamilyListPtr;
@ -606,14 +606,14 @@ begin
// retrieve font name length
if OSError(ATSUFindFontName(PFamily^, kFontFamilyName, kFontMacintoshPlatform,
kFontRomanScript, kFontEnglishLanguage, NameLength, nil,
@NameLength, nil), AName, 'ATSUFindFontName', 'Length') then Continue;
@NameLength, nil), SName, 'ATSUFindFontName', 'Length') then Continue;
SetLength(FontName, NameLength);
// retrieve font name, UTF-16 encoded
if OSError(ATSUFindFontName(PFamily^, kFontFamilyName, kFontMacintoshPlatform,
kFontRomanScript, kFontEnglishLanguage, NameLength,
@FontName[1], @NameLength, nil), AName, 'ATSUFindFontName', 'Name') then Continue;
@FontName[1], @NameLength, nil), SName, 'ATSUFindFontName', 'Name') then Continue;
if FontName <> '' then // execute callback
begin
@ -633,7 +633,7 @@ begin
end
else
begin
DebugLn(AName + ' with specific face or specific char set is not implemented!');
DebugLn(SName + ' with specific face or specific char set is not implemented!');
end;
end;
@ -1573,7 +1573,8 @@ begin
COLOR_3DLIGHT:
R := GetThemeBrushAsColor(kThemeBrushButtonActiveLightShadow, Depth, True, C);
//COLOR_HOTLIGHT:
COLOR_INFOBK, COLOR_WINDOW, COLOR_FORM:
COLOR_INFOBK,
COLOR_WINDOW, COLOR_FORM:
R := GetThemeBrushAsColor(kThemeBrushDocumentWindowBackground, Depth, True, C);
else
DebugLn('TCarbonWidgetSet.GetSysColor TODO ', DbgS(NIndex));
@ -1645,14 +1646,14 @@ var
TextLayout: ATSUTextLayout;
ADC: TCarbonDeviceContext;
TextBefore, TextAfter, Ascent, Descent: ATSUTextMeasurement;
const AName = 'GetTextExtentPoint';
const SName = 'GetTextExtentPoint';
begin
{$IFDEF VerboseWinAPI}
DebugLn('TCarbonWidgetSet.GetTextExtentPoint DC: ' + DbgS(DC) + ' Str: ' + Str);
{$ENDIF}
Result := False;
if not CheckDC(DC, AName) then
if not CheckDC(DC, SName) then
// workaround for calculating metrics of invisible controls
ADC := DefaultContext
else
@ -1663,7 +1664,7 @@ begin
// finally compute the text dimensions
if OSError(ATSUGetUnjustifiedBounds(TextLayout, kATSUFromTextBeginning,
kATSUToTextEnd, TextBefore, TextAfter, Ascent, Descent),
Self, AName, 'ATSUGetUnjustifiedBounds') then Exit;
Self, SName, 'ATSUGetUnjustifiedBounds') then Exit;
Size.cx := (TextAfter - TextBefore) shr 16;
Size.cy := (Descent + Ascent) shr 16;
@ -1695,7 +1696,7 @@ var
B: Boolean;
TextLayout: ATSUTextLayout;
TextBefore, TextAfter, Ascent, Descent: ATSUTextMeasurement;
const AName = 'GetTextMetrics';
const SName = 'GetTextMetrics';
AGetAttrName = 'ATSUGetAttribute';
begin
{$IFDEF VerboseWinAPI}
@ -1703,7 +1704,7 @@ begin
{$ENDIF}
Result := False;
if not CheckDC(DC, AName) then
if not CheckDC(DC, SName) then
// workaround for calculating metrics of invisible controls
ADC := DefaultContext
else
@ -1721,7 +1722,7 @@ begin
if not ADC.BeginTextRender('x', 1, TextLayout) then Exit;
try
if OSError(ATSUGetUnjustifiedBounds(TextLayout, kATSUFromTextBeginning,
kATSUToTextEnd, TextBefore, TextAfter, Ascent, Descent), AName,
kATSUToTextEnd, TextBefore, TextAfter, Ascent, Descent), SName,
'ATSUGetUnjustifiedBounds') then Exit
finally
ADC.EndTextRender(TextLayout);
@ -1732,7 +1733,7 @@ begin
TM.tmHeight := (Ascent + Descent) shr 16;
if OSError(ATSUGetAttribute(TextStyle, kATSULeadingTag, SizeOf(M), @M, nil),
Self, AName, AGetAttrName, 'kATSULeadingTag', kATSUNotSetErr) then Exit;
Self, SName, AGetAttrName, 'kATSULeadingTag', kATSUNotSetErr) then Exit;
TM.tmInternalLeading := M shr 16;
TM.tmExternalLeading := 0;
@ -1748,20 +1749,20 @@ begin
TM.tmBreakChar := '?';
if OSError(ATSUGetAttribute(TextStyle, kATSUQDBoldfaceTag, SizeOf(B), @B, nil),
Self, AName, AGetAttrName, 'kATSUQDBoldfaceTag', kATSUNotSetErr) then Exit;
Self, SName, AGetAttrName, 'kATSUQDBoldfaceTag', kATSUNotSetErr) then Exit;
if B then TM.tmWeight := FW_NORMAL
else TM.tmWeight := FW_BOLD;
if OSError(ATSUGetAttribute(TextStyle, kATSUQDItalicTag, SizeOf(B), @B, nil),
Self, AName, AGetAttrName, 'kATSUQDItalicTag', kATSUNotSetErr) then Exit;
Self, SName, AGetAttrName, 'kATSUQDItalicTag', kATSUNotSetErr) then Exit;
TM.tmItalic := Byte(B);
if OSError(ATSUGetAttribute(TextStyle, kATSUQDUnderlineTag, SizeOf(B), @B, nil),
Self, AName, AGetAttrName, 'kATSUQDUnderlineTag', kATSUNotSetErr) then Exit;
Self, SName, AGetAttrName, 'kATSUQDUnderlineTag', kATSUNotSetErr) then Exit;
TM.tmUnderlined := Byte(B);
if OSError(ATSUGetAttribute(TextStyle, kATSUStyleStrikeThroughTag, SizeOf(B), @B, nil),
Self, AName, AGetAttrName, 'kATSUStyleStrikeThroughTag', kATSUNotSetErr) then Exit;
Self, SName, AGetAttrName, 'kATSUStyleStrikeThroughTag', kATSUNotSetErr) then Exit;
TM.tmStruckOut := Byte(B);
// TODO: get these from font
@ -2520,7 +2521,7 @@ function TCarbonWidgetSet.SelectObject(DC: HDC; GDIObj: HGDIOBJ): HGDIOBJ;
var
AObject: TObject;
ADC: TCarbonDeviceContext;
const AName = 'TCarbonWidgetSet.SelectObject';
const SName = 'TCarbonWidgetSet.SelectObject';
begin
{$IFDEF VerboseWinAPI}
DebugLn('TCarbonWidgetSet.SelectObject DC: ' + DbgS(DC) + ' GDIObj: ' +
@ -2528,8 +2529,8 @@ begin
{$ENDIF}
Result := 0;
if not CheckDC(DC, AName) then Exit;
if not CheckGDIObject(GDIObj, AName) then Exit;
if not CheckDC(DC, SName) then Exit;
if not CheckGDIObject(GDIObj, SName) then Exit;
ADC := TCarbonDeviceContext(DC);
AObject := TObject(GDIObj);
@ -2556,7 +2557,7 @@ begin
begin
if not (ADC is TCarbonBitmapContext) then
begin
DebugLn(AName + ' Error - The specified device context is not bitmap context!');
DebugLn(SName + ' Error - The specified device context is not bitmap context!');
Exit;
end;
@ -2923,11 +2924,11 @@ end;
Returns: If the function succeeds
Shows the window normal, minimized or maximized
TODO: solve maximized <-> normal bug
------------------------------------------------------------------------------}
function TCarbonWidgetSet.ShowWindow(hWnd: HWND; nCmdShow: Integer): Boolean;
var
P: FPCMacOSAll.Point;
Maximized: Boolean;
begin
{$IFDEF VerboseWinAPI}
DebugLn('TCarbonWidgetSet.ShowWindow hWnd: ' + DbgS(hWnd) + ' nCmdShow: ' +
@ -2941,19 +2942,25 @@ begin
SW_SHOWNORMAL, SW_SHOWMAXIMIZED:
begin
if IsWindowCollapsed(AsWindowRef(HWnd)) then
Result := CollapseWindow(AsWindowRef(HWnd), False) = noErr;
if CollapseWindow(AsWindowRef(HWnd), False) <> noErr then Exit;
if Result then
// for checking if any change is necessary
Maximized := IsWindowInStandardState(AsWindowRef(HWnd), nil, nil);
if nCmdShow = SW_SHOWNORMAL then
begin
if nCmdShow = SW_SHOWNORMAL then
Result := ZoomWindowIdeal(AsWindowRef(HWnd), inZoomIn, P) = noErr
if not Maximized then Result := True
else
Result := ZoomWindowIdeal(AsWindowRef(HWnd), inZoomIn, P) = noErr;
end
else
if Maximized then Result := True
else
begin
P.v := $3FFF;
P.h := $3FFF;
Result := ZoomWindowIdeal(AsWindowRef(HWnd), inZoomOut, P) = noErr;
end;
end;
end;
SW_MINIMIZE: Result := CollapseWindow(AsWindowRef(HWnd), True) = noErr;
end;
@ -2993,7 +3000,7 @@ function TCarbonWidgetSet.StretchMaskBlt(DestDC: HDC; X, Y, Width,
Height: Integer; SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer;
Mask: HBITMAP; XMask, YMask: Integer; Rop: DWORD): Boolean;
const
AName = 'TCarbonWidgetSet.StretchMaskBlt';
SName = 'TCarbonWidgetSet.StretchMaskBlt';
begin
{$IFDEF VerboseWinAPI}
DebugLn('TCarbonWidgetSet.StretchMaskBlt DestDC: ' + DbgS(DestDC) + ' SrcDC: ',
@ -3004,11 +3011,11 @@ begin
{$ENDIF}
Result := False;
if not CheckDC(DestDC, AName, 'Dest') then Exit;
if not CheckDC(SrcDC, AName, 'Src') then Exit;
if not CheckDC(DestDC, SName, 'Dest') then Exit;
if not CheckDC(SrcDC, SName, 'Src') then Exit;
if not (TCarbonDeviceContext(SrcDC) is TCarbonBitmapContext) then
begin
DebugLn(AName + ' Error - invalid source device context!');
DebugLn(SName + ' Error - invalid source device context!');
Exit;
end;
@ -3094,7 +3101,7 @@ begin
if WindowPart <> inContent then Exit;
if OSError(GetWindowBounds(Window, kWindowContentRgn, R), Self,
'WindowFromPoint', 'GetWindowBounds') then Exit;
'WindowFromPoint', SGetWindowBounds) then Exit;
Dec(P.h, R.left);
Dec(P.v, R.top);

24
lcl/interfaces/carbon/carbonwsdialogs.pp
View File

@ -142,7 +142,7 @@ var
FileRef: FSRef;
FileURL: CFURLRef;
FileCFStr: CFStringRef;
const AName = 'TCarbonWSFileDialog.ShowModal';
const SName = 'TCarbonWSFileDialog.ShowModal';
begin
{$IFDEF VerboseWSClass}
DebugLn('TCarbonWSFileDialog.ShowModal for ' + ACommonDialog.Name);
@ -152,7 +152,7 @@ begin
// Initialize record to default values
if OSError(NavGetDefaultDialogCreationOptions(CreationOptions),
AName, 'NavGetDefaultDialogCreationOptions') then Exit;
SName, 'NavGetDefaultDialogCreationOptions') then Exit;
if FileDialog.Title <> '' then // Override dialog's default title?
CreateCFString(FileDialog.Title, CreationOptions.windowTitle);
@ -174,13 +174,13 @@ begin
// Create Save dialog
if OSError(NavCreatePutFileDialog(@CreationOptions, 0, 0, nil, nil,
DialogRef), AName, 'NavCreatePutFileDialog') then Exit;
DialogRef), SName, 'NavCreatePutFileDialog') then Exit;
end
else
if FileDialog is TSelectDirectoryDialog then // Create Choose folder dialog
begin
if OSError(NavCreateChooseFolderDialog(@CreationOptions, nil, nil, nil,
DialogRef), AName, 'NavCreateChooseFolderDialog') then Exit;
DialogRef), SName, 'NavCreateChooseFolderDialog') then Exit;
end
else
if FileDialog is TOpenDialog then
@ -194,29 +194,29 @@ begin
// Create Open dialog
if OSError(NavCreateGetFileDialog(@CreationOptions, nil, nil, nil, nil,
nil, DialogRef), AName, 'NavCreateGetFileDialog') then Exit;
nil, DialogRef), SName, 'NavCreateGetFileDialog') then Exit;
end;
try
// Display dialog
if OSError(NavDialogRun(DialogRef), AName, 'NavDialogRun') then Exit;
if OSError(NavDialogRun(DialogRef), SName, 'NavDialogRun') then Exit;
if NavDialogGetUserAction(DialogRef) <> kNavUserActionCancel then // User OK?
begin
if OSError(NavDialogGetReply(DialogRef, DialogReply), AName,
if OSError(NavDialogGetReply(DialogRef, DialogReply), SName,
'NavDialogGetReply') then Exit; // Get user's selection
if OSError(AECountItems(DialogReply.Selection, FileCount), AName,
if OSError(AECountItems(DialogReply.Selection, FileCount), SName,
'AECountItems') then Exit;
for FileIdx := 1 to FileCount do
begin
if OSError(AEGetNthDesc(DialogReply.Selection, FileIdx, typeFSRef,
@Keyword, FileDesc), AName, 'AEGetNthDesc') then Exit;
@Keyword, FileDesc), SName, 'AEGetNthDesc') then Exit;
// Get file reference
if OSError(AEGetDescData(FileDesc, @FileRef, SizeOf(FSRef)), AName,
if OSError(AEGetDescData(FileDesc, @FileRef, SizeOf(FSRef)), SName,
'AEGetDescData') then Exit;
if OSError(AEDisposeDesc(FileDesc), AName, 'AEDisposeDesc') then Exit;
if OSError(AEDisposeDesc(FileDesc), SName, 'AEDisposeDesc') then Exit;
FileURL := CFURLCreateFromFSRef(kCFAllocatorDefault, FileRef); // Get URL
FileCFStr := CFURLCopyFileSystemPath(FileURL, kCFURLPOSIXPathStyle); // Get path
@ -243,7 +243,7 @@ begin
must mean extension and not path to file's folder.}
// Dispose of data that record points to (?)
if OSError(NavDisposeReply(DialogReply), AName, 'NavDisposeReply') then
if OSError(NavDisposeReply(DialogReply), SName, 'NavDisposeReply') then
Exit;
FileDialog.UserChoice := mrOK;

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

@ -319,7 +319,7 @@ class procedure TCarbonWSCustomNotebook.SetPageIndex(const ANotebook: TCustomNot
begin
if not CheckHandle(ANotebook, Self, 'SetPageIndex') then Exit;
SetControl32BitValue(AsControlRef(ANotebook.Handle), AIndex + 1);
TCarbonTabsControl(ANotebook.Handle).SetTabIndex(AIndex);
end;
{------------------------------------------------------------------------------

3
lcl/interfaces/carbon/carbonwsmenus.pp
View File

@ -211,8 +211,7 @@ begin
if not CheckMenuItem(AMenuItem, 'SetShortCut') then Exit;
if not CheckMenuItem(AMenuItem.Parent, 'SetShortCut', 'Parent') then Exit;
if OldShortCut <> NewShortCut then
TCarbonMenu(AMenuItem.Handle).SetShortCut(NewShortCut);
TCarbonMenu(AMenuItem.Handle).SetShortCut(NewShortCut);
end;
{------------------------------------------------------------------------------