paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-25 14:19:12 +02:00
Code Issues Packages Projects Releases Wiki Activity
HiDPIImageList
lazarus/lcl/interfaces/carbon/carbonproc.pp

1533 lines
53 KiB
ObjectPascal
Raw Permalink Blame History

{ $Id$
----------------------------------------
carbonproc.pp - Carbon interface procs
----------------------------------------
@created(Wed Aug 26st WET 2005)
@lastmod($Date$)
@author(Marc Weustink <marc@@lazarus.dommelstein.net>)
This unit contains procedures/functions needed for the Carbon <-> LCL interface
Common carbon untilities (usable by other projects) go to CarbonUtils
*****************************************************************************
This file is part of the Lazarus Component Library (LCL)
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
}
unit CarbonProc;
{$mode objfpc}{$H+}
interface
// defines
{$I carbondefines.inc}
uses
MacOSAll,
Classes, SysUtils, DateUtils, Types, LCLType, LCLProc,
Controls, Forms, Graphics, Math, GraphType, StrUtils;
const
CleanPMRect: PMRect = (top: 0; left: 0; bottom: 0; right: 0);
CleanPMOrientation: PMOrientation = 0;
function OSError(AResult: OSStatus; const AMethodName, ACallName: String;
const AText: String = ''): Boolean;
function OSError(AResult: OSStatus; const AObject: TObject; const AMethodName, ACallName: String;
const AText: String = ''): Boolean;
function OSError(AResult: OSStatus; const AClass: TClass; const AMethodName, ACallName: String;
const AText: String = ''): Boolean;
function OSError(AResult: OSStatus; const AObject: TObject; const AMethodName, ACallName: String;
const AText: String; AValidResult: OSStatus): Boolean;
function OSError(AResult: OSStatus; const AMethodName, ACallName: String;
const AText: String; AValidResult: OSStatus): Boolean;
var
DefaultTextStyle: ATSUStyle; // default Carbon text style
RGBColorSpace: CGColorSpaceRef; // global RGB color space
GrayColorSpace: CGColorSpaceRef; // global Gray color space
HIViewClassID: CFStringRef; // class CFString for HIView
CustomControlClassID: CFStringRef; // class CFString for custom control
var
CarbonDefaultFont : AnsiString = '';
CarbonDefaultMonoFont : AnsiString = 'Menlo Regular'; { Default introduced in Snow Leopard }
{ TODO: Find from system }
CarbonDefaultFontSize : Integer = 0;
{$I mackeycodes.inc}
function VirtualKeyCodeToMac(AKey: Word): Word;
function VirtualKeyCodeToCharCode(AKey: Word): Word;
function GetBorderWindowAttrs(const ABorderStyle: TFormBorderStyle;
const ABorderIcons: TBorderIcons): WindowAttributes;
function GetCarbonMouseClickCount(AEvent: EventRef): Integer;
function GetCarbonMouseButton(AEvent: EventRef): Integer;
function GetCarbonMsgKeyState: PtrInt;
function GetCarbonShiftState: TShiftState;
function ShiftStateToModifiers(const Shift: TShiftState): Byte;
function FindCarbonFontID(const FontName: String): ATSUFontID; overload;
function FindCarbonFontID(FontName: string; var Bold, Italic: Boolean; MonoSpace: Boolean): ATSUFontID; overload;
function CarbonFontIDToFontName(ID: ATSUFontID): String;
function FindQDFontFamilyID(const FontName: String; var Family: FontFamilyID): Boolean;
function FontStyleToQDStyle(const AStyle: TFontStyles): MacOSAll.Style;
function QDStyleToFontStyle(QDStyle: Integer): TFontStyles;
procedure FillStandardDescription(out Desc: TRawImageDescription);
function GetCarbonThemeMetric(Metric: ThemeMetric; DefaultValue: Integer = 0): Integer;
function CreateCustomHIView(const ARect: HIRect; ControlStyle: TControlStyle = []): HIViewRef;
procedure SetControlViewStyle(Control: ControlRef; TinySize, SmallSize, NormalSize: Integer; ControlHeight: Boolean = True);
function CarbonHitTest(Control: ControlRef; const X,Y: integer; var part: ControlPartCode): Boolean;
const
DEFAULT_CFSTRING_ENCODING = kCFStringEncodingUTF8;
procedure CreateCFString(const S: String; out AString: CFStringRef);
procedure CreateCFString(const Data: CFDataRef; Encoding: CFStringEncoding; out AString: CFStringRef);
procedure FreeCFString(var AString: CFStringRef);
function CFStringToStr(AString: CFStringRef; Encoding: CFStringEncoding = DEFAULT_CFSTRING_ENCODING): String;
function CFStringToData(AString: CFStringRef; Encoding: CFStringEncoding = DEFAULT_CFSTRING_ENCODING): CFDataRef;
function StringsToCFArray(S: TStrings): CFArrayRef;
function RoundFixed(const F: Fixed): Integer;
function GetCarbonRect(Left, Top, Width, Height: Integer): MacOSAll.Rect;
function GetCarbonRect(const ARect: TRect): MacOSAll.Rect;
function ParamsToCarbonRect(const AParams: TCreateParams): MacOSAll.Rect;
function ParamsToRect(const AParams: TCreateParams): TRect;
function CFDateRefToDateTime(dateRef: CFDateRef): TDateTime;
type
CGRectArray = Array of CGRect;
function ExcludeRect(const A, B: TRect): CGRectArray;
function GetCGRect(X1, Y1, X2, Y2: Integer): CGRect;
function GetCGRectSorted(X1, Y1, X2, Y2: Integer): CGRect;
function RectToCGRect(const ARect: TRect): CGRect;
function CGRectToRect(const ARect: CGRect): TRect;
function ParamsToHIRect(const AParams: TCreateParams): HIRect;
function CarbonRectToRect(const ARect: MacOSAll.Rect): TRect;
function HIRectToCarbonRect(const ARect: HIRect): MacOSAll.Rect;
function SortRect(const ARect: TRect): TRect;
function PointToHIPoint(const APoint: TPoint): HIPoint;
function PointToHISize(const APoint: TPoint): HISize;
function HIPointToPoint(const APoint: HIPoint): TPoint;
function GetHIPoint(X, Y: Single): HIPoint;
function GetHISize(X, Y: Single): HISize;
function ColorToRGBColor(const AColor: TColor): RGBColor;
function RGBColorToColor(const AColor: RGBColor): TColor;
function CreateCGColor(const AColor: TColor): CGColorRef;
function DbgS(const ARect: MacOSAll.Rect): string; overload;
function DbgS(const AColor: MacOSAll.RGBColor): string; overload;
function DbgS(const APoint: HIPoint): string; overload;
function DbgS(const ASize: HISize): string; overload;
// Exception raising functions to centralize error strings
procedure RaiseCreateWidgetError(AControl: TWinControl);
procedure RaiseColorSpaceError;
procedure RaiseMemoryAllocationError;
procedure RaiseContextCreationError;
implementation
uses CarbonDbgConsts;
{------------------------------------------------------------------------------
Name: OSError
Params: AResult - Result of Carbon function call
AMethodName - Parent method name
ACallName - The Carbon function name
AText - Another text useful for debugging (param value, ...)
Returns: If an error was the result of calling the specified Carbon function
------------------------------------------------------------------------------}
function OSError(AResult: OSStatus; const AMethodName, ACallName: String;
const AText: String): Boolean;
begin
if AResult = noErr then Result := False
else
begin
Result := True;
DebugLn(AMethodName + ' Error: ' + ACallName + ' ' + AText +
' failed with result ' + DbgS(AResult));
end;
end;
{------------------------------------------------------------------------------
Name: OSError
Params: AResult - Result of Carbon function call
AObject - Method object
AMethodName - Parent method name
ACallName - The Carbon function name
AText - Another text useful for debugging (param value, ...)
Returns: If an error was the result of calling the specified Carbon function
------------------------------------------------------------------------------}
function OSError(AResult: OSStatus; const AObject: TObject;
const AMethodName, ACallName: String;
const AText: String = ''): Boolean;
begin
if AResult = noErr then Result := False
else
begin
Result := True;
DebugLn(AObject.ClassName + '.' + AMethodName + ' Error: ' + ACallName +
' ' + AText + ' failed with result ' + DbgS(AResult));
end;
end;
{------------------------------------------------------------------------------
Name: OSError
Params: AResult - Result of Carbon function call
AClass - Method object
AMethodName - Parent method name
ACallName - The Carbon function name
AText - Another text useful for debugging (param value, ...)
Returns: If an error was the result of calling the specified Carbon function
------------------------------------------------------------------------------}
function OSError(AResult: OSStatus; const AClass: TClass;
const AMethodName, ACallName: String;
const AText: String = ''): Boolean;
begin
if AResult = noErr then Result := False
else
begin
Result := True;
DebugLn(AClass.ClassName + '.' + AMethodName + ' Error: ' + ACallName +
' ' + AText + ' failed with result ' + DbgS(AResult));
end;
end;
{------------------------------------------------------------------------------
Name: OSError
Params: AResult - Result of Carbon function call
AObject - Method object
AMethodName - Parent method name
ACallName - The Carbon function name
AText - Another text useful for debugging (param value, ...)
AValidResult - Another result code that is valid like noErr
Returns: If an error was the result of calling the specified Carbon function
------------------------------------------------------------------------------}
function OSError(AResult: OSStatus; const AObject: TObject;
const AMethodName, ACallName: String;
const AText: String; AValidResult: OSStatus): Boolean;
begin
if (AResult = noErr) or (AResult = AValidResult) then Result := False
else
begin
Result := True;
DebugLn(AObject.ClassName + '.' + AMethodName + ' Error: ' + ACallName +
' ' + AText + ' failed with result ' + DbgS(AResult));
end;
end;
{------------------------------------------------------------------------------
Name: OSError
Params: AResult - Result of Carbon function call
AMethodName - Parent method name
ACallName - The Carbon function name
AText - Another text useful for debugging (param value, ...)
AValidResult - Another result code that is valid like noErr
Returns: If an error was the result of calling the specified Carbon function
------------------------------------------------------------------------------}
function OSError(AResult: OSStatus; const AMethodName, ACallName: String;
const AText: String; AValidResult: OSStatus): Boolean;
begin
if (AResult = noErr) or (AResult = AValidResult) then Result := False
else
begin
Result := True;
DebugLn(AMethodName + ' Error: ' + ACallName +
' ' + AText + ' failed with result ' + DbgS(AResult));
end;
end;
{------------------------------------------------------------------------------
Name: VirtualKeyCodeToMac
Returns: The Mac virtual key (MK_) code for the specified virtual
key code (VK_) or 0
------------------------------------------------------------------------------}
function VirtualKeyCodeToMac(AKey: Word): Word;
begin
case AKey of
VK_BACK : Result := MK_BACKSPACE;
VK_TAB : Result := MK_TAB;
VK_RETURN : Result := MK_ENTER;
VK_PAUSE : Result := MK_PAUSE;
VK_CAPITAL : Result := MK_CAPSLOCK;
VK_ESCAPE : Result := MK_ESC;
VK_SPACE : Result := MK_SPACE;
VK_PRIOR : Result := MK_PAGUP;
VK_NEXT : Result := MK_PAGDN;
VK_END : Result := MK_END;
VK_HOME : Result := MK_HOME;
VK_LEFT : Result := MK_LEFT;
VK_UP : Result := MK_UP;
VK_RIGHT : Result := MK_RIGHT;
VK_DOWN : Result := MK_DOWN;
VK_SNAPSHOT : Result := MK_PRNSCR;
VK_INSERT : Result := MK_INS;
VK_DELETE : Result := MK_DEL;
VK_HELP : Result := MK_HELP;
VK_SLEEP : Result := MK_POWER;
VK_NUMPAD0 : Result := MK_NUMPAD0;
VK_NUMPAD1 : Result := MK_NUMPAD1;
VK_NUMPAD2 : Result := MK_NUMPAD2;
VK_NUMPAD3 : Result := MK_NUMPAD3;
VK_NUMPAD4 : Result := MK_NUMPAD4;
VK_NUMPAD5 : Result := MK_NUMPAD5;
VK_NUMPAD6 : Result := MK_NUMPAD6;
VK_NUMPAD7 : Result := MK_NUMPAD7;
VK_NUMPAD8 : Result := MK_NUMPAD8;
VK_NUMPAD9 : Result := MK_NUMPAD9;
//VK_MULTIPLY : Result := MK_PADMULT;
//VK_ADD : Result := MK_PADADD;
VK_SEPARATOR : Result := MK_PADDEC;
VK_SUBTRACT : Result := MK_PADSUB;
VK_DECIMAL : Result := MK_PADDEC;
VK_DIVIDE : Result := MK_PADDIV;
VK_F1 : Result := MK_F1;
VK_F2 : Result := MK_F2;
VK_F3 : Result := MK_F3;
VK_F4 : Result := MK_F4;
VK_F5 : Result := MK_F5;
VK_F6 : Result := MK_F6;
VK_F7 : Result := MK_F7;
VK_F8 : Result := MK_F8;
VK_F9 : Result := MK_F9;
VK_F10 : Result := MK_F10;
VK_F11 : Result := MK_F11;
VK_F12 : Result := MK_F12;
VK_F13 : Result := MK_F13;
VK_F14 : Result := MK_F14;
VK_F15 : Result := MK_F15;
VK_F16 : Result := MK_F16;
VK_F17 : Result := MK_F17;
VK_F18 : Result := MK_F18;
VK_F19 : Result := MK_F19;
VK_NUMLOCK : Result := MK_NUMLOCK;
VK_CLEAR : Result := MK_CLEAR;
VK_SCROLL : Result := MK_SCRLOCK;
VK_SHIFT : Result := MK_SHIFTKEY;
VK_CONTROL : Result := MK_COMMAND;
VK_MENU : Result := MK_ALT;
VK_OEM_3 : Result := MK_TILDE;
//VK_OEM_MINUS : Result := MK_MINUS;
VK_OEM_PLUS : Result := MK_EQUAL;
VK_OEM_5 : Result := MK_BACKSLASH;
VK_OEM_4 : Result := MK_LEFTBRACKET;
VK_OEM_6 : Result := MK_RIGHTBRACKET;
VK_OEM_1 : Result := MK_SEMICOLON;
VK_OEM_7 : Result := MK_QUOTE;
VK_OEM_COMMA : Result := MK_COMMA;
//VK_OEM_PERIOD: Result := MK_PERIOD;
//VK_OEM_2 : Result := MK_SLASH;
else
Result := 0;
end;
end;
{------------------------------------------------------------------------------
Name: VirtualKeyCodeToCharCode
Returns: The char code for the specified virtual key or the original
virtual key. Must be called after VirtualKeyCodeToMac since char codes
overlap VK_ codes.
------------------------------------------------------------------------------}
function VirtualKeyCodeToCharCode(AKey: Word): Word;
begin
case AKey of
VK_MULTIPLY : Result := Ord('*');
VK_ADD : Result := Ord('+');
VK_OEM_MINUS : Result := Ord('-');
VK_OEM_PERIOD: Result := Ord('.');
VK_OEM_2 : Result := Ord('/');
else
Result := AKey;
end;
end;
{------------------------------------------------------------------------------
Name: GetBorderWindowAttrs
Returns: Converts the form border style and icons to Carbon window attributes
------------------------------------------------------------------------------}
function GetBorderWindowAttrs(const ABorderStyle: TFormBorderStyle;
const ABorderIcons: TBorderIcons): WindowAttributes;
begin
case ABorderStyle of
bsNone:
Result := kWindowNoTitleBarAttribute;
bsToolWindow, bsSingle:
Result := kWindowCloseBoxAttribute or
kWindowCollapseBoxAttribute;
bsSizeable:
Result := kWindowCloseBoxAttribute or kWindowCollapseBoxAttribute
or kWindowFullZoomAttribute or kWindowResizableAttribute;
bsDialog:
Result := kWindowCloseBoxAttribute;
bsSizeToolWin:
Result := kWindowCloseBoxAttribute or kWindowResizableAttribute;
else
Result := kWindowNoAttributes;
end;
if biSystemMenu in ABorderIcons then
begin
Result := Result or kWindowCloseBoxAttribute;
if biMinimize in ABorderIcons then
Result := Result or kWindowCollapseBoxAttribute
else
Result := Result and not kWindowCollapseBoxAttribute;
if biMaximize in ABorderIcons then
Result := Result or kWindowFullZoomAttribute
else
Result := Result and not kWindowFullZoomAttribute;
end
else
Result := Result and not (kWindowCloseBoxAttribute or
kWindowCollapseBoxAttribute or kWindowFullZoomAttribute);
end;
{------------------------------------------------------------------------------
Name: GetCarbonMouseClickCount
Returns: The click count of mouse
------------------------------------------------------------------------------}
function GetCarbonMouseClickCount(AEvent: EventRef): Integer;
var
ClickCount: UInt32;
const
SName = 'CarbonWindow_MouseProc';
begin
Result := 1;
if OSError(
GetEventParameter(AEvent, kEventParamClickCount, typeUInt32, nil,
SizeOf(ClickCount), nil, @ClickCount),
SName, SGetEvent, 'kEventParamClickCount') then Exit;
Result := Integer(ClickCount);
{debugln('GetClickCount ClickCount=',dbgs(ClickCount));}
end;
{------------------------------------------------------------------------------
Name: GetCarbonMouseButton
Returns: The event state of mouse
------------------------------------------------------------------------------}
function GetCarbonMouseButton(AEvent: EventRef): Integer;
// 1 = left, 2 = right, 3 = middle
var
MouseButton: EventMouseButton;
Modifiers: UInt32;
const
SName = 'GetCarbonMouseButton';
begin
Result := 0;
Modifiers := 0;
if OSError(
GetEventParameter(AEvent, kEventParamMouseButton, typeMouseButton, nil,
SizeOf(MouseButton), nil, @MouseButton),
SName, SGetEvent, 'kEventParamMouseButton', eventParameterNotFoundErr) then Exit;
Result := MouseButton;
if OSError(
GetEventParameter(AEvent, kEventParamKeyModifiers, typeUInt32, nil,
SizeOf(Modifiers), nil, @Modifiers),
SName, SGetEvent, 'kEventParamKeyModifiers', eventParameterNotFoundErr) then Exit;
if Result = 1 then
begin
if (Modifiers and optionKey) > 0 then
Result := 3
else
if (Modifiers and controlKey) > 0 then
Result := 2;
end;
end;
{------------------------------------------------------------------------------
Name: GetCarbonMsgKeyState
Returns: The current state of mouse and function keys
------------------------------------------------------------------------------}
function GetCarbonMsgKeyState: PtrInt;
var
Modifiers, ButtonState: UInt32;
begin
Result := 0;
Modifiers := GetCurrentEventKeyModifiers; // shift, control, option, command
ButtonState := GetCurrentEventButtonState; // Bit 0 first button (left),
// bit 1 second (right), bit2 third (middle) ...
if (ButtonState and 1) > 0 then Inc(Result, MK_LButton);
if (ButtonState and 2) > 0 then Inc(Result, MK_RButton);
if (ButtonState and 4) > 0 then Inc(Result, MK_MButton);
if (shiftKey and Modifiers) > 0 then Inc(Result, MK_Shift);
if (controlKey and Modifiers) > 0 then Inc(Result, MK_Control);
if (optionKey and Modifiers) > 0 then Inc(Result, $20000000);
//DebugLn('GetCarbonMsgKeyState Result=',dbgs(KeysToShiftState(Result)),' Modifiers=',hexstr(Modifiers,8),' ButtonState=',hexstr(ButtonState,8));
end;
{------------------------------------------------------------------------------
Name: GetCarbonShiftState
Returns: The current shift state of mouse and function keys
------------------------------------------------------------------------------}
function GetCarbonShiftState: TShiftState;
var
Modifiers, ButtonState: UInt32;
begin
Result := [];
Modifiers := GetCurrentEventKeyModifiers; // shift, control, option, command
ButtonState := GetCurrentEventButtonState; // Bit 0 first button (left),
// bit 1 second (right), bit2 third (middle) ...
if (ButtonState and 1) > 0 then Include(Result, ssLeft);
if (ButtonState and 2) > 0 then Include(Result, ssRight);
if (ButtonState and 4) > 0 then Include(Result, ssMiddle);
if (shiftKey and Modifiers) > 0 then Include(Result, ssShift);
if (cmdKey and Modifiers) > 0 then Include(Result, ssMeta);
if (controlKey and Modifiers) > 0 then Include(Result, ssCtrl);
if (optionKey and Modifiers) > 0 then Include(Result, ssAlt);
if (alphaLock and Modifiers) > 0 then Include(Result, ssCaps);
//DebugLn('GetCarbonShiftState Result=',dbgs(Result),' Modifiers=',hexstr(Modifiers,8),' ButtonState=',hexstr(ButtonState,8));
end;
{------------------------------------------------------------------------------
Name: ShiftStateToModifiers
Params: Shift - Shift state to convert
Returns: The Carbon key modifiers converted from the passed shift state
------------------------------------------------------------------------------}
function ShiftStateToModifiers(const Shift: TShiftState): Byte;
begin
//if Shift = [ssAlt] then
// Result := kMenuNoModifiers
//else
//begin
if ssMeta in Shift then
Result := kMenuNoModifiers
else
Result := kMenuNoCommandModifier;
if ssShift in Shift then Inc(Result, kMenuShiftModifier);
if ssCtrl in Shift then Inc(Result, kMenuControlModifier);
if ssAlt in Shift then Inc(Result, kMenuOptionModifier);
//end;
end;
const
lclFontName = kFontFullName;
lclFontPlatform = kFontMacintoshPlatform;
lclFontScript = kFontNoScriptCode;
lclFontLanguage = kFontNoLanguageCode;
{------------------------------------------------------------------------------
Name: FindCarbonFontID
Params: FontName - The font name, UTF-8 encoded
Returns: Carbon font ID of font with the specified name
------------------------------------------------------------------------------}
function FindCarbonFontID(const FontName: String): ATSUFontID;
var
fn : String;
begin
Result := 0;
//DebugLn('FindCarbonFontID ' + FontName);
if SameText(FontName, 'default')
then fn:=CarbonDefaultFont
else fn:=FontName;
if (fn <> '') then
begin
OSError(ATSUFindFontFromName(@fn[1], Length(fn),
lclFontName, lclFontPlatform, lclFontScript,
lclFontLanguage, Result),
'FindCarbonFontID', 'ATSUFindFontFromName');
end;
end;
{------------------------------------------------------------------------------
Name: FindCarbonFontID
Params: FontName - The font name, UTF-8 encoded
Bold, Italic - Font style, cleared if the style was found
MonoSpace: Indication that Fixed Pitch font is wanted.
Currently only implemented for font name 'default'
Returns: Carbon font ID of font with the specified name
Finds the font ID for the given font name. The ATSU bold/italic styles
are manufactured, so if possible this will match the full font name including
styles. If a match is found it will clear Bold/Italic.
------------------------------------------------------------------------------}
function FindCarbonFontID(FontName: string; var Bold, Italic: Boolean; MonoSpace: Boolean): ATSUFontID;
function FindFont(const fn: string; code: FontNameCode; out ID: ATSUFontID): Boolean;
begin
Result := ATSUFindFontFromName(PChar(fn), Length(fn), code,
lclFontPlatform, lclFontScript, lclFontLanguage, ID) = noErr;
if not Result then
ID := 0;
end;
const
SRegular = ' Regular';
SBold = ' Bold';
SItalic = ' Italic';
SOblique = ' Oblique';
var
FamilyName: string;
begin
if SameText(FontName, 'default') then
if MonoSpace then
FontName := CarbonDefaultMonoFont
else
FontName := CarbonDefaultFont;
FamilyName := FontName;
if AnsiEndsStr(SRegular, FamilyName) then
SetLength(FamilyName, Length(FamilyName) - Length(SRegular));
if (Bold and Italic) and
(FindFont(FamilyName + SBold + SItalic, kFontFullName, Result) or
FindFont(FamilyName + SBold + SOblique, kFontFullName, Result)) then begin
Bold := False;
Italic := False;
end
else if Bold and FindFont(FamilyName + SBold, kFontFullName, Result) then
Bold := False
else if Italic and
(FindFont(FamilyName + SItalic, kFontFullName, Result) or
FindFont(FamilyName + SOblique, kFontFullName, Result)) then
Italic := False
else if not FindFont(FontName, kFontFullName, Result) then
FindFont(FontName, kFontFamilyName, Result)
end;
{------------------------------------------------------------------------------
Name: CarbonFontIDToFontName
Params: IS - Carbon font ID
Returns: The font name, UTF-8 encoded
------------------------------------------------------------------------------}
function CarbonFontIDToFontName(ID: ATSUFontID): String;
var
NameLength: LongWord;
FontName: UTF8String;
const
SName = 'CarbonFontIDToFontName';
begin
Result := '';
NameLength:=1024;
// retrieve font name length
if OSError(ATSUFindFontName(ID, lclFontName, lclFontPlatform,
lclFontScript, lclFontLanguage, NameLength, nil,
@NameLength, nil), SName, 'ATSUFindFontName', 'Length') then Exit;
SetLength(FontName, NameLength);
// retrieve font name
if OSError(ATSUFindFontName(ID, lclFontName, lclFontPlatform,
lclFontScript, lclFontLanguage, NameLength,
@FontName[1], @NameLength, nil), SName, 'ATSUFindFontName', 'Name') then Exit;
Result := FontName;
end;
{------------------------------------------------------------------------------
Name: CarbonFontIDToFontName
Params: FontName - The font name, UTF-8 encoded
Returns: Returns QuickDraw font family ID
The function returns true, if the font family has be found, false
otherwise.
Note: FMGetFontFamilyFromName is deprecated in OSX 10.4.
There's no replacment for the function, in future OSX versions.
------------------------------------------------------------------------------}
function FindQDFontFamilyID(const FontName: String; var Family: FontFamilyID): Boolean;
var
name : Str255;
begin
name:=FontName;
Family:=FMGetFontFamilyFromName(name);
Result:=true;
end;
{------------------------------------------------------------------------------
Name: FontStyleToQDStyle
Params: AStyle - Font style
Returns: QuickDraw Style
------------------------------------------------------------------------------}
function FontStyleToQDStyle(const AStyle: TFontStyles): MacOSAll.Style;
begin
Result := MacOSAll.normal;
if fsBold in AStyle then Result := Result or MacOSAll.bold;
if fsItalic in AStyle then Result := Result or MacOSAll.italic;
if fsUnderline in AStyle then Result := Result or MacOSAll.underline;
// fsStrikeOut has no counterpart?
end;
{------------------------------------------------------------------------------
Name: QDStyleToFontStyle
Params: QDStyle - Quick Draw font style
Returns: LCL Font Style
------------------------------------------------------------------------------}
function QDStyleToFontStyle(QDStyle: Integer): TFontStyles;
begin
Result := [];
if QDStyle and MacOSAll.bold > 0 then Include(Result, fsBold);
if QDStyle and MacOSAll.italic > 0 then Include(Result, fsItalic);
if QDStyle and MacOSAll.underline > 0 then Include(Result, fsUnderline);
end;
{------------------------------------------------------------------------------
Name: FillStandardDescription
Params: Desc - Raw image description
Fills the raw image description with standard Carbon internal image storing
description
------------------------------------------------------------------------------}
procedure FillStandardDescription(out Desc: TRawImageDescription);
begin
Desc.Init;
Desc.Format := ricfRGBA;
// Width and Height skipped
Desc.PaletteColorCount := 0;
Desc.BitOrder := riboReversedBits;
Desc.ByteOrder := riboMSBFirst;
Desc.LineEnd := rileDQWordBoundary; // 128bit aligned
Desc.LineOrder := riloTopToBottom;
Desc.BitsPerPixel := 32;
Desc.Depth := 32;
// 8-8-8-8 mode, $AARRGGBB
Desc.RedPrec := 8;
Desc.GreenPrec := 8;
Desc.BluePrec := 8;
Desc.AlphaPrec := 8;
Desc.AlphaShift := 24;
Desc.RedShift := 16;
Desc.GreenShift := 08;
Desc.BlueShift := 00;
Desc.MaskBitOrder := riboReversedBits;
Desc.MaskBitsPerPixel := 1;
Desc.MaskLineEnd := rileByteBoundary;
Desc.MaskShift := 0;
end;
{------------------------------------------------------------------------------
Name: GetCarbonThemeMetric
Params: Metric - Theme metric
DefaultValue
Returns: Theme metric value or default value if fails
------------------------------------------------------------------------------}
function GetCarbonThemeMetric(Metric: ThemeMetric; DefaultValue: Integer): Integer;
begin
if OSError(GetThemeMetric(Metric, Result{%H-}),
'GetCarbonThemeMetric', 'GetThemeMetric') then Result := DefaultValue;
end;
{------------------------------------------------------------------------------
Name: CreateCustomHIView
Params: ARect - Bounds rect
ControlStyle
Returns: New custom HIView
------------------------------------------------------------------------------}
function CreateCustomHIView(const ARect: HIRect; ControlStyle: TControlStyle): HIViewRef;
var
Features: HIViewFeatures;
const
SName = 'CreateCustomHIView';
begin
Result := nil;
if OSError(
HIObjectCreate(CustomControlClassID, nil, HIObjectRef(Result)),
SName, 'HIObjectCreate') then Exit;
Features := kHIViewFeatureAllowsSubviews;
if not (csNoFocus in ControlStyle) then
Features := Features or kHIViewFeatureGetsFocusOnClick;
OSError(
HIViewChangeFeatures(Result, Features, 0),
SName, 'HIViewChangeFeatures');
OSError(HIViewSetVisible(Result, True), SName, SViewVisible);
OSError(HIViewSetFrame(Result, ARect), SName, SViewFrame);
end;
{------------------------------------------------------------------------------
Name: SetControlViewSize
Params: Control - Mac OS Carbon control handle
TinySize - if control size, is less or equal to TinySize then
tine size view style is set. The same goes with Small an
NormalSize. If control size is larger than control size,
then view style is set to Auto.
SmallSize
NormalSize
ControlHeight - if Height (default) instead of Width of the control
should be measured
------------------------------------------------------------------------------}
procedure SetControlViewStyle(Control: ControlRef; TinySize, SmallSize,
NormalSize: Integer; ControlHeight: Boolean);
var
R: MacOSAlL.Rect;
Data: Word;
ControlSize: Integer;
begin
FillChar(R{%H-}, SizeOf(R), 0);
GetControlBounds(Control, R);
if ControlHeight then ControlSize := R.Bottom - R.Top
else ControlSize := R.Right - R.Left;
if ControlSize > NormalSize then Data := kControlSizeAuto
else if ControlSize = NormalSize then Data := kControlSizeNormal
else if ControlSize >= SmallSize then Data := kControlSizeSmall
else if ControlSize >= TinySize then Data := kControlSizeMini
else Data := kControlSizeAuto;
SetControlData(Control, kControlEntireControl, kControlSizeTag, SizeOf(Data), @Data);
end;
{------------------------------------------------------------------------------
Name: CarbonHitTest
Params: Control - control to test
x,y - mouse coordinates in control's local coordinates
part - hit test result
Returns: True - if hittest is succsefull, False - overwise
Performs hit-test on a carbon control (hiview)
------------------------------------------------------------------------------}
function CarbonHitTest(Control: ControlRef; const X,Y: integer; var part: ControlPartCode): Boolean;
var
event : EventRef;
mp : MacOSAll.point;
begin
Result := false;
if CreateEvent(kCFAllocatorDefault, kEventClassControl, kEventControlHitTest, 0, 0, event{%H-}) <> noErr then
Exit;
mp.h := X;
mp.v := Y;
SetEventParameter(event, kEventParamDirectObject, typeControlRef, sizeof(Control), @Control);
SetEventParameter(event, kEventParamMouseLocation, typeQDPoint, sizeof(mp), @mp);
if SendEventToEventTarget(event, GetControlEventTarget(Control))= noErr then
Result:=GetEventParameter(event, kEventParamControlPart, typeControlPartCode, nil, sizeof(part), nil, @part)=noErr;
ReleaseEvent(event);
end;
{------------------------------------------------------------------------------
Name: CreateCFString
Params: S - UTF-8 string
AString - Core Foundation string ref
Creates new Core Foundation string from the specified string
------------------------------------------------------------------------------}
procedure CreateCFString(const S: String; out AString: CFStringRef);
begin
AString := CFStringCreateWithCString(nil, Pointer(PChar(S)), DEFAULT_CFSTRING_ENCODING);
end;
{------------------------------------------------------------------------------
Name: CreateCFString
Params: Data - CFDataRef
Encoding - Data encoding format
AString - Core Foundation string ref
Creates new Core Foundation string from the specified data and format
------------------------------------------------------------------------------}
procedure CreateCFString(const Data: CFDataRef; Encoding: CFStringEncoding; out
AString: CFStringRef);
begin
AString := nil;
if Data = nil then Exit;
AString := CFStringCreateWithBytes(nil, CFDataGetBytePtr(Data),
CFDataGetLength(Data), Encoding, False);
end;
{------------------------------------------------------------------------------
Name: FreeCFString
Params: AString - Core Foundation string ref to free
Frees specified Core Foundation string
------------------------------------------------------------------------------}
procedure FreeCFString(var AString: CFStringRef);
begin
if AString <> nil then
CFRelease(Pointer(AString));
end;
{------------------------------------------------------------------------------
Name: CFStringToStr
Params: AString - Core Foundation string ref
Encoding - Result data encoding format
Returns: UTF-8 string
Converts Core Foundation string to string
------------------------------------------------------------------------------}
function CFStringToStr(AString: CFStringRef; Encoding: CFStringEncoding): String;
var
Str: Pointer;
StrSize: CFIndex;
StrRange: CFRange;
begin
if AString = nil then
begin
Result := '';
Exit;
end;
// Try the quick way first
Str := CFStringGetCStringPtr(AString, Encoding);
if Str <> nil then
Result := PChar(Str)
else
begin
// if that doesn't work this will
StrRange.location := 0;
StrRange.length := CFStringGetLength(AString);
CFStringGetBytes(AString, StrRange, Encoding,
Ord('?'), False, nil, 0, StrSize{%H-});
SetLength(Result, StrSize);
if StrSize > 0 then
CFStringGetBytes(AString, StrRange, Encoding,
Ord('?'), False, @Result[1], StrSize, StrSize);
end;
end;
{------------------------------------------------------------------------------
Name: CFStringToData
Params: AString - Core Foundation string ref
Encoding - Result data encoding format
Returns: CFDataRef
Converts Core Foundation string to data
------------------------------------------------------------------------------}
function CFStringToData(AString: CFStringRef; Encoding: CFStringEncoding): CFDataRef;
var
S: String;
begin
Result := nil;
if AString = nil then Exit;
S := CFStringToStr(AString, Encoding);
if Length(S) > 0 then
Result := CFDataCreate(nil, @S[1], Length(S))
else
Result := CFDataCreate(nil, nil, 0);
end;
{------------------------------------------------------------------------------
Name: StringsToCFArray
Params: S - Strings
Returns: Creates CFArray from strings
------------------------------------------------------------------------------}
function StringsToCFArray(S: TStrings): CFArrayRef;
var
StrArray: Array of CFStringRef;
I: Integer;
begin
SetLength(StrArray, S.Count);
for I := 0 to S.Count - 1 do CreateCFString(S[I], StrArray[I]);
if S.Count > 0 then
Result := CFArrayCreate(nil, @StrArray[0], Length(StrArray), nil)
else
Result := CFArrayCreate(nil, nil, 0, nil);
end;
{------------------------------------------------------------------------------
Name: RoundFixed
Params: F - Fixed value
Returns: Rounded passed fixed value
------------------------------------------------------------------------------}
function RoundFixed(const F: Fixed): Integer;
begin
Result := Round(Fix2X(F));
end;
{------------------------------------------------------------------------------
Name: GetCarbonRect
Params: Left, Top, Width, Height - Coordinates
Returns: Carbon Rect
------------------------------------------------------------------------------}
function GetCarbonRect(Left, Top, Width, Height: Integer): MacOSAll.Rect;
begin
Result.Left := Left;
Result.Top := Top;
Result.Right := Left + Width;
Result.Bottom := Top + Height;
end;
{------------------------------------------------------------------------------
Name: GetCarbonRect
Params: ARect - Rectangle
Returns: Carbon Rect
------------------------------------------------------------------------------}
function GetCarbonRect(const ARect: TRect): MacOSAll.Rect;
begin
Result.Left := ARect.Left;
Result.Top := ARect.Top;
Result.Right := ARect.Right;
Result.Bottom := ARect.Bottom;
end;
{------------------------------------------------------------------------------
Name: ParamsToCarbonRect
Params: AParams - Creation parameters
Returns: Carbon Rect from creation parameters
------------------------------------------------------------------------------}
function ParamsToCarbonRect(const AParams: TCreateParams): MacOSAll.Rect;
begin
Result.Left := AParams.X;
Result.Top := AParams.Y;
Result.Right := AParams.X + AParams.Width;
Result.Bottom := AParams.Y + AParams.Height;
end;
{------------------------------------------------------------------------------
Name: ParamsToRect
Params: AParams - Creation parameters
Returns: TRect from creation parameters
------------------------------------------------------------------------------}
function ParamsToRect(const AParams: TCreateParams): TRect;
begin
Result.Left := AParams.X;
Result.Top := AParams.Y;
Result.Right := AParams.X + AParams.Width;
Result.Bottom := AParams.Y + AParams.Height;
end;
function CFDateRefToDateTime(dateRef: CFDateRef): TDateTime;
var
absTime: CFAbsoluteTime;
gDate: CFGregorianDate;
tz: CFTimeZoneRef;
begin
absTime := CFDateGetAbsoluteTime(dateRef);
tz := CFTimeZoneCopySystem;
gDate := CFAbsoluteTimeGetGregorianDate(absTime, tz);
CFRelease(tz);
with gDate do
if not TryEncodeDateTime(
trunc(year), trunc(month), trunc(day),
trunc(hour), trunc(minute), trunc(second), 0, result)
then
result := 0;
end;
{------------------------------------------------------------------------------
Name: ExcludeRect
Params: A - Source rectangle
B - Rectangle to be excluded
Returns: Array of CGRect, which are product of exclusion rectangle B from
rectangle A.
Note: The returned rectangles may overlap.
------------------------------------------------------------------------------}
function ExcludeRect(const A, B: TRect): CGRectArray;
begin
SetLength(Result, 0);
if (A.Left >= A.Right) or (A.Top >= A.Bottom) then Exit;
SetLength(Result, 1);
Result[0] := RectToCGRect(A);
if (B.Left >= B.Right) or (B.Top >= B.Bottom) then Exit;
if (B.Left < A.Right) and (B.Right > A.Left)
and (B.Top < A.Bottom) and (B.Bottom > A.Top) then
begin // rectangles have intersection
SetLength(Result, 0);
if B.Top > A.Top then
begin
SetLength(Result, Succ(Length(Result)));
Result[High(Result)] := GetCGRect(A.Left, A.Top, A.Right, B.Top);
end;
if B.Bottom < A.Bottom then
begin
SetLength(Result, Succ(Length(Result)));
Result[High(Result)] := GetCGRect(A.Left, B.Bottom, A.Right, A.Bottom);
end;
if B.Left > A.Left then
begin
SetLength(Result, Succ(Length(Result)));
Result[High(Result)] := GetCGRect(A.Left, A.Top, B.Left, A.Bottom);
end;
if B.Right < A.Right then
begin
SetLength(Result, Succ(Length(Result)));
Result[High(Result)] := GetCGRect(B.Right, A.Top, A.Right, A.Bottom);
end;
end;
end;
{------------------------------------------------------------------------------
Name: GetCGRect
Params: X1, Y1, X2, Y2 - Rectangle coordinates
Returns: CGRect
------------------------------------------------------------------------------}
function GetCGRect(X1, Y1, X2, Y2: Integer): CGRect;
begin
Result.origin.x := X1;
Result.size.width := X2 - X1;
Result.origin.y := Y1;
Result.size.height := Y2 - Y1;
end;
{------------------------------------------------------------------------------
Name: GetCGRectSorted
Params: X1, Y1, X2, Y2 - Rectangle coordinates
Returns: CGRect, coordinates are sorted
------------------------------------------------------------------------------}
function GetCGRectSorted(X1, Y1, X2, Y2: Integer): CGRect;
begin
if X1 <= X2 then
begin
Result.origin.x := X1;
Result.size.width := X2 - X1;
end
else
begin
Result.origin.x := X2;
Result.size.width := X1 - X2;
end;
if Y1 <= Y2 then
begin
Result.origin.y := Y1;
Result.size.height := Y2 - Y1;
end
else
begin
Result.origin.y := Y2;
Result.size.height := Y1 - Y2;
end;
end;
{------------------------------------------------------------------------------
Name: RectToCGRect
Params: ARect - Rectangle
Returns: CGRect
------------------------------------------------------------------------------}
function RectToCGRect(const ARect: TRect): CGRect;
begin
Result.origin.x := ARect.Left;
Result.origin.y := ARect.Top;
Result.size.width := ARect.Right - ARect.Left;
Result.size.height := ARect.Bottom - ARect.Top;
end;
{------------------------------------------------------------------------------
Name: CGRectToRect
Params: ARect - CGRect
Returns: TRect
------------------------------------------------------------------------------}
function CGRectToRect(const ARect: CGRect): TRect;
begin
if CGRectIsNull(ARect) <> 0 then
begin // CGRect passed is invalid!
Result.Left := 0;
Result.Top := 0;
Result.Right := 0;
Result.Bottom := 0;
end
else
begin
Result.Left := Floor(ARect.origin.x);
Result.Top := Floor(ARect.origin.y);
Result.Right := Ceil(ARect.origin.x + ARect.size.width);
Result.Bottom := Ceil(ARect.origin.y + ARect.size.height);
end;
end;
{------------------------------------------------------------------------------
Name: ParamsToHIRect
Params: AParams - Creation parameters
Returns: HIView Rect from creation parameters
------------------------------------------------------------------------------}
function ParamsToHIRect(const AParams: TCreateParams): HIRect;
begin
Result.origin.x := AParams.X;
Result.origin.y := AParams.Y;
Result.size.width := AParams.Width;
Result.size.height := AParams.Height;
end;
{------------------------------------------------------------------------------
Name: CarbonRectToRect
Params: ARect - Carbon Rect
Returns: Rectangle
------------------------------------------------------------------------------}
function CarbonRectToRect(const ARect: MacOSAll.Rect): TRect;
begin
Result.Left := ARect.Left;
Result.Top := ARect.Top;
Result.Right := ARect.Right;
Result.Bottom := ARect.Bottom;
end;
{------------------------------------------------------------------------------
Name: HIRectToCarbonRect
Params: ARect - HIRect
Returns: Carbon Rect
------------------------------------------------------------------------------}
function HIRectToCarbonRect(const ARect: HIRect): MacOSAll.Rect;
begin
if CGRectIsNull(ARect) <> 0 then
begin // CGRect passed is invalid!
Result.Left := 0;
Result.Top := 0;
Result.Right := 0;
Result.Bottom := 0;
end
else
begin
Result.Left := Floor(ARect.origin.x);
Result.Top := Floor(ARect.origin.y);
Result.Right := Ceil(ARect.origin.x + ARect.size.width);
Result.Bottom := Ceil(ARect.origin.y + ARect.size.height);
end;
end;
function SortRect(const ARect: TRect): TRect;
begin
if ARect.Left <= ARect.Right then
begin
Result.Left := ARect.Left;
Result.Right := ARect.Right;
end
else
begin
Result.Left := ARect.Right;
Result.Right := ARect.Left;
end;
if ARect.Top <= ARect.Bottom then
begin
Result.Top := ARect.Top;
Result.Bottom := ARect.Bottom;
end
else
begin
Result.Top := ARect.Bottom;
Result.Bottom := ARect.Top;
end;
end;
{------------------------------------------------------------------------------
Name: PointToHIPoint
Params: APoint - Point
Returns: HIPoint
------------------------------------------------------------------------------}
function PointToHIPoint(const APoint: TPoint): HIPoint;
begin
Result.X := APoint.X;
Result.Y := APoint.Y;
end;
{------------------------------------------------------------------------------
Name: PointToHISize
Params: APoint - Point
Returns: HISize
------------------------------------------------------------------------------}
function PointToHISize(const APoint: TPoint): HISize;
begin
Result.Width := APoint.X;
Result.Height := APoint.Y;
end;
{------------------------------------------------------------------------------
Name: HIPointToPoint
Params: APoint - HIPoint
Returns: Point
------------------------------------------------------------------------------}
function HIPointToPoint(const APoint: HIPoint): TPoint;
begin
Result.X := Trunc(APoint.X);
Result.Y := Trunc(APoint.Y);
end;
{------------------------------------------------------------------------------
Name: GetHIPoint
Params: X, Y
Returns: HIPoint
------------------------------------------------------------------------------}
function GetHIPoint(X, Y: Single): HIPoint;
begin
Result.X := X;
Result.Y := Y;
end;
{------------------------------------------------------------------------------
Name: GetHISize
Params: X, Y
Returns: HISize
------------------------------------------------------------------------------}
function GetHISize(X, Y: Single): HISize;
begin
Result.width := X;
Result.height := Y;
end;
{------------------------------------------------------------------------------
Name: ColorToRGBColor
Params: AColor - Color
Returns: Carbon RGBColor
------------------------------------------------------------------------------}
function ColorToRGBColor(const AColor: TColor): RGBColor;
var
V: TColorRef;
begin
V := ColorToRGB(AColor);
Result.Red := Red(V);
Result.Red := (Result.Red shl 8) or Result.Red;
Result.Green := Green(V);
Result.Green := (Result.Green shl 8) or Result.Green;
Result.Blue := Blue(V);
Result.Blue := (Result.Blue shl 8) or Result.Blue;
end;
{------------------------------------------------------------------------------
Name: RGBColorToColor
Params: AColor - Carbon RGBColor
Returns: Color
------------------------------------------------------------------------------}
function RGBColorToColor(const AColor: RGBColor): TColor;
begin
Result := RGBToColor((AColor.Red shr 8) and $FF, (AColor.Green shr 8) and $FF, (AColor.Blue shr 8) and $FF);
end;
{------------------------------------------------------------------------------
Name: CreateCGColor
Params: AColor - Color
Returns: CGColorRef
Creates CGColorRef from the specified color. You are responsible for
releasing it by CGColorRelease.
------------------------------------------------------------------------------}
function CreateCGColor(const AColor: TColor): CGColorRef;
var
V: TColorRef;
F: Array [0..3] of Single;
begin
V := ColorToRGB(AColor);
F[0] := Red(V) / 255;
F[1] := Green(V) / 255;
F[2] := Blue(V) / 255;
F[3] := 1; // Alpha
Result := CGColorCreate(RGBColorSpace, @F[0]);
end;
function DbgS(const ARect: MacOSAll.Rect): String;
begin
Result := DbgS(ARect.left) + ', ' + DbgS(ARect.top)
+ ', ' + DbgS(ARect.right) + ', ' + DbgS(ARect.bottom);
end;
function DbgS(const AColor: MacOSAll.RGBColor): String;
begin
Result :=
'R: ' + IntToHex(AColor.Red, 4) +
' G: ' + IntToHex(AColor.Green, 4) +
' B: ' + IntToHex(AColor.Blue, 4);
end;
function DbgS(const APoint: HIPoint): string;
begin
Result := 'X: ' + DbgS(APoint.X) + ' Y: ' + DbgS(APoint.Y);
end;
function DbgS(const ASize: HISize): string;
begin
Result := 'W: ' + DbgS(ASize.width) + ' H: ' + DbgS(ASize.height);
end;
{------------------------------------------------------------------------------
Name: RaiseCreateWidgetError
Params: AControl - Which control was being created
Raises exception for widget creation error
Used on CarbonPrivate
------------------------------------------------------------------------------}
procedure RaiseCreateWidgetError(AControl: TWinControl);
begin
raise Exception.CreateFmt('Unable to create Carbon widget for %s: %s!',
[AControl.Name, AControl.ClassName]);
end;
procedure RaiseColorSpaceError;
begin
raise Exception.Create('Unable to create CGColorSpaceRef');
end;
procedure RaiseMemoryAllocationError;
begin
raise Exception.Create('Unable to allocate memory');
end;
procedure RaiseContextCreationError;
begin
raise Exception.Create('Unable to create CGContextRef');
end;
{------------------------------------------------------------------------------
Name: CustomControlHandler
Handles custom control class methods
------------------------------------------------------------------------------}
function CustomControlHandler(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
{%H-}AData: Pointer): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
var
EventClass, EventKind: LongWord;
Part: ControlPartCode;
const
SName = 'CustomControlHandler';
begin
EventClass := GetEventClass(AEvent);
EventKind := GetEventKind(AEvent);
case EventClass of
kEventClassHIObject:
case EventKind of
kEventHIObjectConstruct,
kEventHIObjectDestruct: Result := noErr;
kEventHIObjectInitialize: Result := CallNextEventHandler(ANextHandler, AEvent);
end;
kEventClassControl:
case EventKind of
kEventControlGetFocusPart,
kEventControlSetFocusPart: Result := CallNextEventHandler(ANextHandler, AEvent);
kEventControlHitTest:
begin
//Result := CallNextEventHandler(ANextHandler, AEvent);
// I was not able to find what for is this workaround (r11394)
// returning kControlEditTextPart for any customcontrol looks strange
// It seems to interfer with what widget really hit the mouse click.
//
// But it breaks grid's mouse selecting when clicking (near) at
// the borders of cells on an always show editor grid.
//
// Found, without it double click doesn't occur in custom controls
// temporarily restored old behaviour affects issue 22542
// kControlEditTextPart is an arbitrary number
{$IFDEF VerboseMouse}
DebugLn('CustomControlHandler HitTest');
{$ENDIF}
Part := kControlEditTextPart; // workaround
Result := SetEventParameter(AEvent, kEventParamControlPart,
typeControlPartCode, SizeOf(Part), @Part);
OSError(Result, SName, SSetEvent);
end;
end;
kEventClassTextInput: Result := noErr;
kEventClassScrollable: Result := noErr;
end;
end;
procedure InitDefaultFont;
var
s : Str255;
st : MacOSAll.Style;
sz : SInt16;
begin
//Note: the GetThemeFont is deprecated in 10.5. CoreText functions should be used!
MacOSAll.GetThemeFont(kThemeSystemFont, GetApplicationScript, @s, sz{%H-}, st{%H-});
CarbonDefaultFont := s;
CarbonDefaultFontSize := sz;
end;
var
EventSpec: Array [0..8] of EventTypeSpec;
CustomControlHandlerUPP: EventHandlerUPP;
initialization
OSError(
ATSUCreateStyle(DefaultTextStyle), 'CarbonProc.initialization', SCreateStyle);
RGBColorSpace := CGColorSpaceCreateDeviceRGB;
GrayColorSpace := CGColorSpaceCreateDeviceGray;
EventSpec[0].eventClass := kEventClassHIObject;
EventSpec[0].eventKind := kEventHIObjectConstruct;
EventSpec[1].eventClass := kEventClassHIObject;
EventSpec[1].eventKind := kEventHIObjectInitialize;
EventSpec[2].eventClass := kEventClassHIObject;
EventSpec[2].eventKind := kEventHIObjectDestruct;
EventSpec[3].eventClass := kEventClassControl;
EventSpec[3].eventKind := kEventControlHitTest;
EventSpec[4].eventClass := kEventClassTextInput;
EventSpec[4].eventKind := kEventTextInputUnicodeForKeyEvent;
EventSpec[5].eventClass := kEventClassControl;
EventSpec[5].eventKind := kEventControlGetFocusPart;
EventSpec[6].eventClass := kEventClassControl;
EventSpec[6].eventKind := kEventControlSetFocusPart;
EventSpec[7].eventClass := kEventClassScrollable;
EventSpec[7].eventKind := kEventScrollableGetInfo;
EventSpec[8].eventClass := kEventClassScrollable;
EventSpec[8].eventKind := kEventScrollableScrollTo;
CustomControlHandlerUPP := NewEventHandlerUPP(EventHandlerProcPtr(@CustomControlHandler));
CreateCFString('com.lazarus.customcontrol', CustomControlClassID);
CreateCFString('com.apple.hiview', HIViewClassID);
OSError(
HIObjectRegisterSubclass(CustomControlClassID, HIViewClassID, 0,
CustomControlHandlerUPP, Length(EventSpec), @EventSpec[0], nil, nil),
'CarbonProc.initialization', 'HIObjectRegisterSubclass');
InitDefaultFont;
finalization
FreeCFString(CustomControlClassID);
FreeCFString(HIViewClassID);
DisposeEventHandlerUPP(CustomControlHandlerUPP);
OSError(
ATSUDisposeStyle(DefaultTextStyle), 'CarbonProc.finalization', SDisposeStyle);
CGColorSpaceRelease(RGBColorSpace);
CGColorSpaceRelease(GrayColorSpace);
end.
Reference in New Issue View Git Blame Copy Permalink