1{ $Id: carbonproc.pp 61638 2019-07-28 10:44:39Z martin $ 2 ---------------------------------------- 3 carbonproc.pp - Carbon interface procs 4 ---------------------------------------- 5 6 @created(Wed Aug 26st WET 2005) 7 @lastmod($Date: 2019-07-28 12:44:39 +0200 (So, 28 Jul 2019) $) 8 @author(Marc Weustink <marc@@lazarus.dommelstein.net>) 9 10 This unit contains procedures/functions needed for the Carbon <-> LCL interface 11 Common carbon untilities (usable by other projects) go to CarbonUtils 12 13 ***************************************************************************** 14 This file is part of the Lazarus Component Library (LCL) 15 16 See the file COPYING.modifiedLGPL.txt, included in this distribution, 17 for details about the license. 18 ***************************************************************************** 19} 20 21unit CarbonProc; 22 23{$mode objfpc}{$H+} 24 25interface 26 27// defines 28{$I carbondefines.inc} 29 30uses 31 MacOSAll, 32 Classes, SysUtils, DateUtils, Types, LCLType, LCLProc, 33 Controls, Forms, Graphics, Math, GraphType, StrUtils; 34 35const 36 CleanPMRect: PMRect = (top: 0; left: 0; bottom: 0; right: 0); 37 CleanPMOrientation: PMOrientation = 0; 38 39function OSError(AResult: OSStatus; const AMethodName, ACallName: String; 40 const AText: String = ''): Boolean; 41function OSError(AResult: OSStatus; const AObject: TObject; const AMethodName, ACallName: String; 42 const AText: String = ''): Boolean; 43function OSError(AResult: OSStatus; const AClass: TClass; const AMethodName, ACallName: String; 44 const AText: String = ''): Boolean; 45function OSError(AResult: OSStatus; const AObject: TObject; const AMethodName, ACallName: String; 46 const AText: String; AValidResult: OSStatus): Boolean; 47function OSError(AResult: OSStatus; const AMethodName, ACallName: String; 48 const AText: String; AValidResult: OSStatus): Boolean; 49 50var 51 DefaultTextStyle: ATSUStyle; // default Carbon text style 52 RGBColorSpace: CGColorSpaceRef; // global RGB color space 53 GrayColorSpace: CGColorSpaceRef; // global Gray color space 54 55 HIViewClassID: CFStringRef; // class CFString for HIView 56 CustomControlClassID: CFStringRef; // class CFString for custom control 57 58var 59 CarbonDefaultFont : AnsiString = ''; 60 CarbonDefaultMonoFont : AnsiString = 'Menlo Regular'; { Default introduced in Snow Leopard } 61 { TODO: Find from system } 62 CarbonDefaultFontSize : Integer = 0; 63 64{$I mackeycodes.inc} 65 66function VirtualKeyCodeToMac(AKey: Word): Word; 67function VirtualKeyCodeToCharCode(AKey: Word): Word; 68 69function GetBorderWindowAttrs(const ABorderStyle: TFormBorderStyle; 70 const ABorderIcons: TBorderIcons): WindowAttributes; 71 72function GetCarbonMouseClickCount(AEvent: EventRef): Integer; 73function GetCarbonMouseButton(AEvent: EventRef): Integer; 74function GetCarbonMsgKeyState: PtrInt; 75function GetCarbonShiftState: TShiftState; 76function ShiftStateToModifiers(const Shift: TShiftState): Byte; 77 78function FindCarbonFontID(const FontName: String): ATSUFontID; overload; 79function FindCarbonFontID(FontName: string; var Bold, Italic: Boolean; MonoSpace: Boolean): ATSUFontID; overload; 80function CarbonFontIDToFontName(ID: ATSUFontID): String; 81function FindQDFontFamilyID(const FontName: String; var Family: FontFamilyID): Boolean; 82 83function FontStyleToQDStyle(const AStyle: TFontStyles): MacOSAll.Style; 84function QDStyleToFontStyle(QDStyle: Integer): TFontStyles; 85 86procedure FillStandardDescription(out Desc: TRawImageDescription); 87 88function GetCarbonThemeMetric(Metric: ThemeMetric; DefaultValue: Integer = 0): Integer; 89 90function CreateCustomHIView(const ARect: HIRect; ControlStyle: TControlStyle = []): HIViewRef; 91 92procedure SetControlViewStyle(Control: ControlRef; TinySize, SmallSize, NormalSize: Integer; ControlHeight: Boolean = True); 93 94function CarbonHitTest(Control: ControlRef; const X,Y: integer; var part: ControlPartCode): Boolean; 95 96const 97 DEFAULT_CFSTRING_ENCODING = kCFStringEncodingUTF8; 98 99procedure CreateCFString(const S: String; out AString: CFStringRef); 100procedure CreateCFString(const Data: CFDataRef; Encoding: CFStringEncoding; out AString: CFStringRef); 101procedure FreeCFString(var AString: CFStringRef); 102function CFStringToStr(AString: CFStringRef; Encoding: CFStringEncoding = DEFAULT_CFSTRING_ENCODING): String; 103function CFStringToData(AString: CFStringRef; Encoding: CFStringEncoding = DEFAULT_CFSTRING_ENCODING): CFDataRef; 104 105function StringsToCFArray(S: TStrings): CFArrayRef; 106 107function RoundFixed(const F: Fixed): Integer; 108 109function GetCarbonRect(Left, Top, Width, Height: Integer): MacOSAll.Rect; 110function GetCarbonRect(const ARect: TRect): MacOSAll.Rect; 111function ParamsToCarbonRect(const AParams: TCreateParams): MacOSAll.Rect; 112function ParamsToRect(const AParams: TCreateParams): TRect; 113 114function CFDateRefToDateTime(dateRef: CFDateRef): TDateTime; 115 116type 117 CGRectArray = Array of CGRect; 118 119function ExcludeRect(const A, B: TRect): CGRectArray; 120 121function GetCGRect(X1, Y1, X2, Y2: Integer): CGRect; 122function GetCGRectSorted(X1, Y1, X2, Y2: Integer): CGRect; 123function RectToCGRect(const ARect: TRect): CGRect; 124function CGRectToRect(const ARect: CGRect): TRect; 125 126function ParamsToHIRect(const AParams: TCreateParams): HIRect; 127function CarbonRectToRect(const ARect: MacOSAll.Rect): TRect; 128function HIRectToCarbonRect(const ARect: HIRect): MacOSAll.Rect; 129function SortRect(const ARect: TRect): TRect; 130 131function PointToHIPoint(const APoint: TPoint): HIPoint; 132function PointToHISize(const APoint: TPoint): HISize; 133function HIPointToPoint(const APoint: HIPoint): TPoint; 134function GetHIPoint(X, Y: Single): HIPoint; 135function GetHISize(X, Y: Single): HISize; 136 137function ColorToRGBColor(const AColor: TColor): RGBColor; 138function RGBColorToColor(const AColor: RGBColor): TColor; 139function CreateCGColor(const AColor: TColor): CGColorRef; 140 141function DbgS(const ARect: MacOSAll.Rect): string; overload; 142function DbgS(const AColor: MacOSAll.RGBColor): string; overload; 143function DbgS(const APoint: HIPoint): string; overload; 144function DbgS(const ASize: HISize): string; overload; 145 146// Exception raising functions to centralize error strings 147procedure RaiseCreateWidgetError(AControl: TWinControl); 148procedure RaiseColorSpaceError; 149procedure RaiseMemoryAllocationError; 150procedure RaiseContextCreationError; 151 152implementation 153 154uses CarbonDbgConsts; 155 156{------------------------------------------------------------------------------ 157 Name: OSError 158 Params: AResult - Result of Carbon function call 159 AMethodName - Parent method name 160 ACallName - The Carbon function name 161 AText - Another text useful for debugging (param value, ...) 162 Returns: If an error was the result of calling the specified Carbon function 163 ------------------------------------------------------------------------------} 164function OSError(AResult: OSStatus; const AMethodName, ACallName: String; 165 const AText: String): Boolean; 166begin 167 if AResult = noErr then Result := False 168 else 169 begin 170 Result := True; 171 DebugLn(AMethodName + ' Error: ' + ACallName + ' ' + AText + 172 ' failed with result ' + DbgS(AResult)); 173 end; 174end; 175 176{------------------------------------------------------------------------------ 177 Name: OSError 178 Params: AResult - Result of Carbon function call 179 AObject - Method object 180 AMethodName - Parent method name 181 ACallName - The Carbon function name 182 AText - Another text useful for debugging (param value, ...) 183 Returns: If an error was the result of calling the specified Carbon function 184 ------------------------------------------------------------------------------} 185function OSError(AResult: OSStatus; const AObject: TObject; 186 const AMethodName, ACallName: String; 187 const AText: String = ''): Boolean; 188begin 189 if AResult = noErr then Result := False 190 else 191 begin 192 Result := True; 193 DebugLn(AObject.ClassName + '.' + AMethodName + ' Error: ' + ACallName + 194 ' ' + AText + ' failed with result ' + DbgS(AResult)); 195 end; 196end; 197 198{------------------------------------------------------------------------------ 199 Name: OSError 200 Params: AResult - Result of Carbon function call 201 AClass - Method object 202 AMethodName - Parent method name 203 ACallName - The Carbon function name 204 AText - Another text useful for debugging (param value, ...) 205 Returns: If an error was the result of calling the specified Carbon function 206 ------------------------------------------------------------------------------} 207function OSError(AResult: OSStatus; const AClass: TClass; 208 const AMethodName, ACallName: String; 209 const AText: String = ''): Boolean; 210begin 211 if AResult = noErr then Result := False 212 else 213 begin 214 Result := True; 215 DebugLn(AClass.ClassName + '.' + AMethodName + ' Error: ' + ACallName + 216 ' ' + AText + ' failed with result ' + DbgS(AResult)); 217 end; 218end; 219 220{------------------------------------------------------------------------------ 221 Name: OSError 222 Params: AResult - Result of Carbon function call 223 AObject - Method object 224 AMethodName - Parent method name 225 ACallName - The Carbon function name 226 AText - Another text useful for debugging (param value, ...) 227 AValidResult - Another result code that is valid like noErr 228 Returns: If an error was the result of calling the specified Carbon function 229 ------------------------------------------------------------------------------} 230function OSError(AResult: OSStatus; const AObject: TObject; 231 const AMethodName, ACallName: String; 232 const AText: String; AValidResult: OSStatus): Boolean; 233begin 234 if (AResult = noErr) or (AResult = AValidResult) then Result := False 235 else 236 begin 237 Result := True; 238 DebugLn(AObject.ClassName + '.' + AMethodName + ' Error: ' + ACallName + 239 ' ' + AText + ' failed with result ' + DbgS(AResult)); 240 end; 241end; 242 243{------------------------------------------------------------------------------ 244 Name: OSError 245 Params: AResult - Result of Carbon function call 246 AMethodName - Parent method name 247 ACallName - The Carbon function name 248 AText - Another text useful for debugging (param value, ...) 249 AValidResult - Another result code that is valid like noErr 250 Returns: If an error was the result of calling the specified Carbon function 251 ------------------------------------------------------------------------------} 252function OSError(AResult: OSStatus; const AMethodName, ACallName: String; 253 const AText: String; AValidResult: OSStatus): Boolean; 254begin 255 if (AResult = noErr) or (AResult = AValidResult) then Result := False 256 else 257 begin 258 Result := True; 259 DebugLn(AMethodName + ' Error: ' + ACallName + 260 ' ' + AText + ' failed with result ' + DbgS(AResult)); 261 end; 262end; 263 264{------------------------------------------------------------------------------ 265 Name: VirtualKeyCodeToMac 266 Returns: The Mac virtual key (MK_) code for the specified virtual 267 key code (VK_) or 0 268 ------------------------------------------------------------------------------} 269function VirtualKeyCodeToMac(AKey: Word): Word; 270begin 271 case AKey of 272 VK_BACK : Result := MK_BACKSPACE; 273 VK_TAB : Result := MK_TAB; 274 VK_RETURN : Result := MK_ENTER; 275 VK_PAUSE : Result := MK_PAUSE; 276 VK_CAPITAL : Result := MK_CAPSLOCK; 277 VK_ESCAPE : Result := MK_ESC; 278 VK_SPACE : Result := MK_SPACE; 279 VK_PRIOR : Result := MK_PAGUP; 280 VK_NEXT : Result := MK_PAGDN; 281 VK_END : Result := MK_END; 282 VK_HOME : Result := MK_HOME; 283 VK_LEFT : Result := MK_LEFT; 284 VK_UP : Result := MK_UP; 285 VK_RIGHT : Result := MK_RIGHT; 286 VK_DOWN : Result := MK_DOWN; 287 VK_SNAPSHOT : Result := MK_PRNSCR; 288 VK_INSERT : Result := MK_INS; 289 VK_DELETE : Result := MK_DEL; 290 VK_HELP : Result := MK_HELP; 291 VK_SLEEP : Result := MK_POWER; 292 VK_NUMPAD0 : Result := MK_NUMPAD0; 293 VK_NUMPAD1 : Result := MK_NUMPAD1; 294 VK_NUMPAD2 : Result := MK_NUMPAD2; 295 VK_NUMPAD3 : Result := MK_NUMPAD3; 296 VK_NUMPAD4 : Result := MK_NUMPAD4; 297 VK_NUMPAD5 : Result := MK_NUMPAD5; 298 VK_NUMPAD6 : Result := MK_NUMPAD6; 299 VK_NUMPAD7 : Result := MK_NUMPAD7; 300 VK_NUMPAD8 : Result := MK_NUMPAD8; 301 VK_NUMPAD9 : Result := MK_NUMPAD9; 302//VK_MULTIPLY : Result := MK_PADMULT; 303//VK_ADD : Result := MK_PADADD; 304 VK_SEPARATOR : Result := MK_PADDEC; 305 VK_SUBTRACT : Result := MK_PADSUB; 306 VK_DECIMAL : Result := MK_PADDEC; 307 VK_DIVIDE : Result := MK_PADDIV; 308 VK_F1 : Result := MK_F1; 309 VK_F2 : Result := MK_F2; 310 VK_F3 : Result := MK_F3; 311 VK_F4 : Result := MK_F4; 312 VK_F5 : Result := MK_F5; 313 VK_F6 : Result := MK_F6; 314 VK_F7 : Result := MK_F7; 315 VK_F8 : Result := MK_F8; 316 VK_F9 : Result := MK_F9; 317 VK_F10 : Result := MK_F10; 318 VK_F11 : Result := MK_F11; 319 VK_F12 : Result := MK_F12; 320 VK_F13 : Result := MK_F13; 321 VK_F14 : Result := MK_F14; 322 VK_F15 : Result := MK_F15; 323 VK_F16 : Result := MK_F16; 324 VK_F17 : Result := MK_F17; 325 VK_F18 : Result := MK_F18; 326 VK_F19 : Result := MK_F19; 327 VK_NUMLOCK : Result := MK_NUMLOCK; 328 VK_CLEAR : Result := MK_CLEAR; 329 VK_SCROLL : Result := MK_SCRLOCK; 330 VK_SHIFT : Result := MK_SHIFTKEY; 331 VK_CONTROL : Result := MK_COMMAND; 332 VK_MENU : Result := CarbonProc.MK_ALT; // see LCLType.MK_ALT 333 VK_OEM_3 : Result := MK_TILDE; 334//VK_OEM_MINUS : Result := MK_MINUS; 335 VK_OEM_PLUS : Result := MK_EQUAL; 336 VK_OEM_5 : Result := MK_BACKSLASH; 337 VK_OEM_4 : Result := MK_LEFTBRACKET; 338 VK_OEM_6 : Result := MK_RIGHTBRACKET; 339 VK_OEM_1 : Result := MK_SEMICOLON; 340 VK_OEM_7 : Result := MK_QUOTE; 341 VK_OEM_COMMA : Result := MK_COMMA; 342//VK_OEM_PERIOD: Result := MK_PERIOD; 343//VK_OEM_2 : Result := MK_SLASH; 344 else 345 Result := 0; 346 end; 347end; 348 349{------------------------------------------------------------------------------ 350 Name: VirtualKeyCodeToCharCode 351 Returns: The char code for the specified virtual key or the original 352 virtual key. Must be called after VirtualKeyCodeToMac since char codes 353 overlap VK_ codes. 354 ------------------------------------------------------------------------------} 355function VirtualKeyCodeToCharCode(AKey: Word): Word; 356begin 357 case AKey of 358 VK_MULTIPLY : Result := Ord('*'); 359 VK_ADD : Result := Ord('+'); 360 VK_OEM_MINUS : Result := Ord('-'); 361 VK_OEM_PERIOD: Result := Ord('.'); 362 VK_OEM_2 : Result := Ord('/'); 363 else 364 Result := AKey; 365 end; 366end; 367 368{------------------------------------------------------------------------------ 369 Name: GetBorderWindowAttrs 370 Returns: Converts the form border style and icons to Carbon window attributes 371 ------------------------------------------------------------------------------} 372function GetBorderWindowAttrs(const ABorderStyle: TFormBorderStyle; 373 const ABorderIcons: TBorderIcons): WindowAttributes; 374begin 375 case ABorderStyle of 376 bsNone: 377 Result := kWindowNoTitleBarAttribute; 378 bsToolWindow, bsSingle: 379 Result := kWindowCloseBoxAttribute or 380 kWindowCollapseBoxAttribute; 381 bsSizeable: 382 Result := kWindowCloseBoxAttribute or kWindowCollapseBoxAttribute 383 or kWindowFullZoomAttribute or kWindowResizableAttribute; 384 bsDialog: 385 Result := kWindowCloseBoxAttribute; 386 bsSizeToolWin: 387 Result := kWindowCloseBoxAttribute or kWindowResizableAttribute; 388 else 389 Result := kWindowNoAttributes; 390 end; 391 392 if biSystemMenu in ABorderIcons then 393 begin 394 Result := Result or kWindowCloseBoxAttribute; 395 if biMinimize in ABorderIcons then 396 Result := Result or kWindowCollapseBoxAttribute 397 else 398 Result := Result and not kWindowCollapseBoxAttribute; 399 if biMaximize in ABorderIcons then 400 Result := Result or kWindowFullZoomAttribute 401 else 402 Result := Result and not kWindowFullZoomAttribute; 403 end 404 else 405 Result := Result and not (kWindowCloseBoxAttribute or 406 kWindowCollapseBoxAttribute or kWindowFullZoomAttribute); 407end; 408 409{------------------------------------------------------------------------------ 410 Name: GetCarbonMouseClickCount 411 Returns: The click count of mouse 412 ------------------------------------------------------------------------------} 413function GetCarbonMouseClickCount(AEvent: EventRef): Integer; 414var 415 ClickCount: UInt32; 416const 417 SName = 'CarbonWindow_MouseProc'; 418begin 419 Result := 1; 420 421 if OSError( 422 GetEventParameter(AEvent, kEventParamClickCount, typeUInt32, nil, 423 SizeOf(ClickCount), nil, @ClickCount), 424 SName, SGetEvent, 'kEventParamClickCount') then Exit; 425 426 Result := Integer(ClickCount); 427 {debugln('GetClickCount ClickCount=',dbgs(ClickCount));} 428end; 429 430{------------------------------------------------------------------------------ 431 Name: GetCarbonMouseButton 432 Returns: The event state of mouse 433 ------------------------------------------------------------------------------} 434function GetCarbonMouseButton(AEvent: EventRef): Integer; 435 // 1 = left, 2 = right, 3 = middle 436var 437 MouseButton: EventMouseButton; 438 Modifiers: UInt32; 439const 440 SName = 'GetCarbonMouseButton'; 441begin 442 Result := 0; 443 Modifiers := 0; 444 445 if OSError( 446 GetEventParameter(AEvent, kEventParamMouseButton, typeMouseButton, nil, 447 SizeOf(MouseButton), nil, @MouseButton), 448 SName, SGetEvent, 'kEventParamMouseButton', eventParameterNotFoundErr) then Exit; 449 Result := MouseButton; 450 451 if OSError( 452 GetEventParameter(AEvent, kEventParamKeyModifiers, typeUInt32, nil, 453 SizeOf(Modifiers), nil, @Modifiers), 454 SName, SGetEvent, 'kEventParamKeyModifiers', eventParameterNotFoundErr) then Exit; 455 456 if Result = 1 then 457 begin 458 if (Modifiers and optionKey) > 0 then 459 Result := 3 460 else 461 if (Modifiers and controlKey) > 0 then 462 Result := 2; 463 end; 464end; 465 466{------------------------------------------------------------------------------ 467 Name: GetCarbonMsgKeyState 468 Returns: The current state of mouse and function keys 469 ------------------------------------------------------------------------------} 470function GetCarbonMsgKeyState: PtrInt; 471var 472 Modifiers, ButtonState: UInt32; 473begin 474 Result := 0; 475 476 Modifiers := GetCurrentEventKeyModifiers; // shift, control, option, command 477 ButtonState := GetCurrentEventButtonState; // Bit 0 first button (left), 478 // bit 1 second (right), bit2 third (middle) ... 479 480 if (ButtonState and 1) > 0 then Inc(Result, MK_LButton); 481 if (ButtonState and 2) > 0 then Inc(Result, MK_RButton); 482 if (ButtonState and 4) > 0 then Inc(Result, MK_MButton); 483 if (shiftKey and Modifiers) > 0 then Inc(Result, MK_Shift); 484 if (controlKey and Modifiers) > 0 then Inc(Result, MK_Control); 485 if (optionKey and Modifiers) > 0 then Inc(Result, LCLType.MK_ALT); // see CarbonProc.MK_ALT 486 487 //DebugLn('GetCarbonMsgKeyState Result=',dbgs(KeysToShiftState(Result)),' Modifiers=',hexstr(Modifiers,8),' ButtonState=',hexstr(ButtonState,8)); 488end; 489 490{------------------------------------------------------------------------------ 491 Name: GetCarbonShiftState 492 Returns: The current shift state of mouse and function keys 493 ------------------------------------------------------------------------------} 494function GetCarbonShiftState: TShiftState; 495var 496 Modifiers, ButtonState: UInt32; 497begin 498 Result := []; 499 500 Modifiers := GetCurrentEventKeyModifiers; // shift, control, option, command 501 ButtonState := GetCurrentEventButtonState; // Bit 0 first button (left), 502 // bit 1 second (right), bit2 third (middle) ... 503 504 if (ButtonState and 1) > 0 then Include(Result, ssLeft); 505 if (ButtonState and 2) > 0 then Include(Result, ssRight); 506 if (ButtonState and 4) > 0 then Include(Result, ssMiddle); 507 if (shiftKey and Modifiers) > 0 then Include(Result, ssShift); 508 if (cmdKey and Modifiers) > 0 then Include(Result, ssMeta); 509 if (controlKey and Modifiers) > 0 then Include(Result, ssCtrl); 510 if (optionKey and Modifiers) > 0 then Include(Result, ssAlt); 511 if (alphaLock and Modifiers) > 0 then Include(Result, ssCaps); 512 513 //DebugLn('GetCarbonShiftState Result=',dbgs(Result),' Modifiers=',hexstr(Modifiers,8),' ButtonState=',hexstr(ButtonState,8)); 514end; 515 516{------------------------------------------------------------------------------ 517 Name: ShiftStateToModifiers 518 Params: Shift - Shift state to convert 519 Returns: The Carbon key modifiers converted from the passed shift state 520 ------------------------------------------------------------------------------} 521function ShiftStateToModifiers(const Shift: TShiftState): Byte; 522begin 523 //if Shift = [ssAlt] then 524 // Result := kMenuNoModifiers 525 //else 526 //begin 527 if ssMeta in Shift then 528 Result := kMenuNoModifiers 529 else 530 Result := kMenuNoCommandModifier; 531 532 if ssShift in Shift then Inc(Result, kMenuShiftModifier); 533 if ssCtrl in Shift then Inc(Result, kMenuControlModifier); 534 if ssAlt in Shift then Inc(Result, kMenuOptionModifier); 535 //end; 536end; 537 538const 539 lclFontName = kFontFullName; 540 lclFontPlatform = kFontMacintoshPlatform; 541 lclFontScript = kFontNoScriptCode; 542 lclFontLanguage = kFontNoLanguageCode; 543 544 545{------------------------------------------------------------------------------ 546 Name: FindCarbonFontID 547 Params: FontName - The font name, UTF-8 encoded 548 Returns: Carbon font ID of font with the specified name 549 ------------------------------------------------------------------------------} 550function FindCarbonFontID(const FontName: String): ATSUFontID; 551var 552 fn : String; 553begin 554 Result := 0; 555 556 //DebugLn('FindCarbonFontID ' + FontName); 557 558 if IsFontNameDefault(FontName) 559 then fn:=CarbonDefaultFont 560 else fn:=FontName; 561 if (fn <> '') then 562 begin 563 OSError(ATSUFindFontFromName(@fn[1], Length(fn), 564 lclFontName, lclFontPlatform, lclFontScript, 565 lclFontLanguage, Result), 566 'FindCarbonFontID', 'ATSUFindFontFromName'); 567 end; 568end; 569 570{------------------------------------------------------------------------------ 571 Name: FindCarbonFontID 572 Params: FontName - The font name, UTF-8 encoded 573 Bold, Italic - Font style, cleared if the style was found 574 MonoSpace: Indication that Fixed Pitch font is wanted. 575 Currently only implemented for font name 'default' 576 Returns: Carbon font ID of font with the specified name 577 578 Finds the font ID for the given font name. The ATSU bold/italic styles 579 are manufactured, so if possible this will match the full font name including 580 styles. If a match is found it will clear Bold/Italic. 581 ------------------------------------------------------------------------------} 582function FindCarbonFontID(FontName: string; var Bold, Italic: Boolean; MonoSpace: Boolean): ATSUFontID; 583 584 function FindFont(const fn: string; code: FontNameCode; out ID: ATSUFontID): Boolean; 585 begin 586 Result := ATSUFindFontFromName(PChar(fn), Length(fn), code, 587 lclFontPlatform, lclFontScript, lclFontLanguage, ID) = noErr; 588 if not Result then 589 ID := 0; 590 end; 591 592const 593 SRegular = ' Regular'; 594 SBold = ' Bold'; 595 SItalic = ' Italic'; 596 SOblique = ' Oblique'; 597var 598 FamilyName: string; 599begin 600 if IsFontNameDefault(FontName) then 601 if MonoSpace then 602 FontName := CarbonDefaultMonoFont 603 else 604 FontName := CarbonDefaultFont; 605 FamilyName := FontName; 606 if AnsiEndsStr(SRegular, FamilyName) then 607 SetLength(FamilyName, Length(FamilyName) - Length(SRegular)); 608 if (Bold and Italic) and 609 (FindFont(FamilyName + SBold + SItalic, kFontFullName, Result) or 610 FindFont(FamilyName + SBold + SOblique, kFontFullName, Result)) then begin 611 Bold := False; 612 Italic := False; 613 end 614 else if Bold and FindFont(FamilyName + SBold, kFontFullName, Result) then 615 Bold := False 616 else if Italic and 617 (FindFont(FamilyName + SItalic, kFontFullName, Result) or 618 FindFont(FamilyName + SOblique, kFontFullName, Result)) then 619 Italic := False 620 else if not FindFont(FontName, kFontFullName, Result) then 621 FindFont(FontName, kFontFamilyName, Result) 622end; 623 624{------------------------------------------------------------------------------ 625 Name: CarbonFontIDToFontName 626 Params: IS - Carbon font ID 627 Returns: The font name, UTF-8 encoded 628 ------------------------------------------------------------------------------} 629function CarbonFontIDToFontName(ID: ATSUFontID): String; 630var 631 NameLength: LongWord; 632 FontName: UTF8String; 633const 634 SName = 'CarbonFontIDToFontName'; 635begin 636 Result := ''; 637 NameLength:=1024; 638 639 // retrieve font name length 640 if OSError(ATSUFindFontName(ID, lclFontName, lclFontPlatform, 641 lclFontScript, lclFontLanguage, NameLength, nil, 642 @NameLength, nil), SName, 'ATSUFindFontName', 'Length') then Exit; 643 644 SetLength(FontName, NameLength); 645 646 // retrieve font name 647 if OSError(ATSUFindFontName(ID, lclFontName, lclFontPlatform, 648 lclFontScript, lclFontLanguage, NameLength, 649 @FontName[1], @NameLength, nil), SName, 'ATSUFindFontName', 'Name') then Exit; 650 651 Result := FontName; 652end; 653 654{------------------------------------------------------------------------------ 655 Name: CarbonFontIDToFontName 656 Params: FontName - The font name, UTF-8 encoded 657 Returns: Returns QuickDraw font family ID 658 The function returns true, if the font family has be found, false 659 otherwise. 660 Note: FMGetFontFamilyFromName is deprecated in OSX 10.4. 661 There's no replacment for the function, in future OSX versions. 662 ------------------------------------------------------------------------------} 663function FindQDFontFamilyID(const FontName: String; var Family: FontFamilyID): Boolean; 664var 665 name : Str255; 666begin 667 name:=FontName; 668 Family:=FMGetFontFamilyFromName(name); 669 Result:=true; 670end; 671 672{------------------------------------------------------------------------------ 673 Name: FontStyleToQDStyle 674 Params: AStyle - Font style 675 Returns: QuickDraw Style 676 ------------------------------------------------------------------------------} 677function FontStyleToQDStyle(const AStyle: TFontStyles): MacOSAll.Style; 678begin 679 Result := MacOSAll.normal; 680 681 if fsBold in AStyle then Result := Result or MacOSAll.bold; 682 if fsItalic in AStyle then Result := Result or MacOSAll.italic; 683 if fsUnderline in AStyle then Result := Result or MacOSAll.underline; 684 // fsStrikeOut has no counterpart? 685end; 686 687{------------------------------------------------------------------------------ 688 Name: QDStyleToFontStyle 689 Params: QDStyle - Quick Draw font style 690 Returns: LCL Font Style 691 ------------------------------------------------------------------------------} 692function QDStyleToFontStyle(QDStyle: Integer): TFontStyles; 693begin 694 Result := []; 695 if QDStyle and MacOSAll.bold > 0 then Include(Result, fsBold); 696 if QDStyle and MacOSAll.italic > 0 then Include(Result, fsItalic); 697 if QDStyle and MacOSAll.underline > 0 then Include(Result, fsUnderline); 698end; 699 700{------------------------------------------------------------------------------ 701 Name: FillStandardDescription 702 Params: Desc - Raw image description 703 704 Fills the raw image description with standard Carbon internal image storing 705 description 706 ------------------------------------------------------------------------------} 707procedure FillStandardDescription(out Desc: TRawImageDescription); 708begin 709 Desc.Init; 710 711 Desc.Format := ricfRGBA; 712// Width and Height skipped 713 Desc.PaletteColorCount := 0; 714 715 Desc.BitOrder := riboReversedBits; 716 Desc.ByteOrder := riboMSBFirst; 717 Desc.LineEnd := rileDQWordBoundary; // 128bit aligned 718 719 Desc.LineOrder := riloTopToBottom; 720 Desc.BitsPerPixel := 32; 721 Desc.Depth := 32; 722 723 // 8-8-8-8 mode, $AARRGGBB 724 Desc.RedPrec := 8; 725 Desc.GreenPrec := 8; 726 Desc.BluePrec := 8; 727 Desc.AlphaPrec := 8; 728 729 Desc.AlphaShift := 24; 730 Desc.RedShift := 16; 731 Desc.GreenShift := 08; 732 Desc.BlueShift := 00; 733 734 Desc.MaskBitOrder := riboReversedBits; 735 Desc.MaskBitsPerPixel := 1; 736 Desc.MaskLineEnd := rileByteBoundary; 737 Desc.MaskShift := 0; 738end; 739 740{------------------------------------------------------------------------------ 741 Name: GetCarbonThemeMetric 742 Params: Metric - Theme metric 743 DefaultValue 744 Returns: Theme metric value or default value if fails 745 ------------------------------------------------------------------------------} 746function GetCarbonThemeMetric(Metric: ThemeMetric; DefaultValue: Integer): Integer; 747begin 748 if OSError(GetThemeMetric(Metric, Result{%H-}), 749 'GetCarbonThemeMetric', 'GetThemeMetric') then Result := DefaultValue; 750end; 751 752{------------------------------------------------------------------------------ 753 Name: CreateCustomHIView 754 Params: ARect - Bounds rect 755 ControlStyle 756 Returns: New custom HIView 757 ------------------------------------------------------------------------------} 758function CreateCustomHIView(const ARect: HIRect; ControlStyle: TControlStyle): HIViewRef; 759var 760 Features: HIViewFeatures; 761const 762 SName = 'CreateCustomHIView'; 763begin 764 Result := nil; 765 766 if OSError( 767 HIObjectCreate(CustomControlClassID, nil, HIObjectRef(Result)), 768 SName, 'HIObjectCreate') then Exit; 769 770 Features := kHIViewFeatureAllowsSubviews; 771 if not (csNoFocus in ControlStyle) then 772 Features := Features or kHIViewFeatureGetsFocusOnClick; 773 774 OSError( 775 HIViewChangeFeatures(Result, Features, 0), 776 SName, 'HIViewChangeFeatures'); 777 778 OSError(HIViewSetVisible(Result, True), SName, SViewVisible); 779 OSError(HIViewSetFrame(Result, ARect), SName, SViewFrame); 780end; 781 782{------------------------------------------------------------------------------ 783 Name: SetControlViewSize 784 Params: Control - Mac OS Carbon control handle 785 TinySize - if control size, is less or equal to TinySize then 786 tine size view style is set. The same goes with Small an 787 NormalSize. If control size is larger than control size, 788 then view style is set to Auto. 789 SmallSize 790 NormalSize 791 ControlHeight - if Height (default) instead of Width of the control 792 should be measured 793 ------------------------------------------------------------------------------} 794procedure SetControlViewStyle(Control: ControlRef; TinySize, SmallSize, 795 NormalSize: Integer; ControlHeight: Boolean); 796var 797 R: MacOSAlL.Rect; 798 Data: Word; 799 ControlSize: Integer; 800begin 801 FillChar(R{%H-}, SizeOf(R), 0); 802 GetControlBounds(Control, R); 803 if ControlHeight then ControlSize := R.Bottom - R.Top 804 else ControlSize := R.Right - R.Left; 805 806 if ControlSize > NormalSize then Data := kControlSizeAuto 807 else if ControlSize = NormalSize then Data := kControlSizeNormal 808 else if ControlSize >= SmallSize then Data := kControlSizeSmall 809 else if ControlSize >= TinySize then Data := kControlSizeMini 810 else Data := kControlSizeAuto; 811 812 SetControlData(Control, kControlEntireControl, kControlSizeTag, SizeOf(Data), @Data); 813end; 814 815 816{------------------------------------------------------------------------------ 817 Name: CarbonHitTest 818 Params: Control - control to test 819 x,y - mouse coordinates in control's local coordinates 820 part - hit test result 821 Returns: True - if hittest is succsefull, False - overwise 822 823 Performs hit-test on a carbon control (hiview) 824 ------------------------------------------------------------------------------} 825function CarbonHitTest(Control: ControlRef; const X,Y: integer; var part: ControlPartCode): Boolean; 826var 827 event : EventRef; 828 mp : MacOSAll.point; 829begin 830 Result := false; 831 if CreateEvent(kCFAllocatorDefault, kEventClassControl, kEventControlHitTest, 0, 0, event{%H-}) <> noErr then 832 Exit; 833 mp.h := X; 834 mp.v := Y; 835 SetEventParameter(event, kEventParamDirectObject, typeControlRef, sizeof(Control), @Control); 836 SetEventParameter(event, kEventParamMouseLocation, typeQDPoint, sizeof(mp), @mp); 837 if SendEventToEventTarget(event, GetControlEventTarget(Control))= noErr then 838 Result:=GetEventParameter(event, kEventParamControlPart, typeControlPartCode, nil, sizeof(part), nil, @part)=noErr; 839 ReleaseEvent(event); 840end; 841 842{------------------------------------------------------------------------------ 843 Name: CreateCFString 844 Params: S - UTF-8 string 845 AString - Core Foundation string ref 846 847 Creates new Core Foundation string from the specified string 848 ------------------------------------------------------------------------------} 849procedure CreateCFString(const S: String; out AString: CFStringRef); 850begin 851 AString := CFStringCreateWithCString(nil, Pointer(PChar(S)), DEFAULT_CFSTRING_ENCODING); 852end; 853 854{------------------------------------------------------------------------------ 855 Name: CreateCFString 856 Params: Data - CFDataRef 857 Encoding - Data encoding format 858 AString - Core Foundation string ref 859 860 Creates new Core Foundation string from the specified data and format 861 ------------------------------------------------------------------------------} 862procedure CreateCFString(const Data: CFDataRef; Encoding: CFStringEncoding; out 863 AString: CFStringRef); 864begin 865 AString := nil; 866 if Data = nil then Exit; 867 AString := CFStringCreateWithBytes(nil, CFDataGetBytePtr(Data), 868 CFDataGetLength(Data), Encoding, False); 869end; 870 871{------------------------------------------------------------------------------ 872 Name: FreeCFString 873 Params: AString - Core Foundation string ref to free 874 875 Frees specified Core Foundation string 876 ------------------------------------------------------------------------------} 877procedure FreeCFString(var AString: CFStringRef); 878begin 879 if AString <> nil then 880 CFRelease(Pointer(AString)); 881end; 882 883{------------------------------------------------------------------------------ 884 Name: CFStringToStr 885 Params: AString - Core Foundation string ref 886 Encoding - Result data encoding format 887 Returns: UTF-8 string 888 889 Converts Core Foundation string to string 890 ------------------------------------------------------------------------------} 891function CFStringToStr(AString: CFStringRef; Encoding: CFStringEncoding): String; 892var 893 Str: Pointer; 894 StrSize: CFIndex; 895 StrRange: CFRange; 896begin 897 if AString = nil then 898 begin 899 Result := ''; 900 Exit; 901 end; 902 903 // Try the quick way first 904 Str := CFStringGetCStringPtr(AString, Encoding); 905 if Str <> nil then 906 Result := PChar(Str) 907 else 908 begin 909 // if that doesn't work this will 910 StrRange.location := 0; 911 StrRange.length := CFStringGetLength(AString); 912 913 CFStringGetBytes(AString, StrRange, Encoding, 914 Ord('?'), False, nil, 0, StrSize{%H-}); 915 SetLength(Result, StrSize); 916 917 if StrSize > 0 then 918 CFStringGetBytes(AString, StrRange, Encoding, 919 Ord('?'), False, @Result[1], StrSize, StrSize); 920 end; 921end; 922 923{------------------------------------------------------------------------------ 924 Name: CFStringToData 925 Params: AString - Core Foundation string ref 926 Encoding - Result data encoding format 927 Returns: CFDataRef 928 929 Converts Core Foundation string to data 930 ------------------------------------------------------------------------------} 931function CFStringToData(AString: CFStringRef; Encoding: CFStringEncoding): CFDataRef; 932var 933 S: String; 934begin 935 Result := nil; 936 if AString = nil then Exit; 937 S := CFStringToStr(AString, Encoding); 938 939 if Length(S) > 0 then 940 Result := CFDataCreate(nil, @S[1], Length(S)) 941 else 942 Result := CFDataCreate(nil, nil, 0); 943end; 944 945{------------------------------------------------------------------------------ 946 Name: StringsToCFArray 947 Params: S - Strings 948 Returns: Creates CFArray from strings 949 ------------------------------------------------------------------------------} 950function StringsToCFArray(S: TStrings): CFArrayRef; 951var 952 StrArray: Array of CFStringRef; 953 I: Integer; 954begin 955 SetLength(StrArray, S.Count); 956 957 for I := 0 to S.Count - 1 do CreateCFString(S[I], StrArray[I]); 958 959 if S.Count > 0 then 960 Result := CFArrayCreate(nil, @StrArray[0], Length(StrArray), nil) 961 else 962 Result := CFArrayCreate(nil, nil, 0, nil); 963end; 964 965{------------------------------------------------------------------------------ 966 Name: RoundFixed 967 Params: F - Fixed value 968 Returns: Rounded passed fixed value 969 ------------------------------------------------------------------------------} 970function RoundFixed(const F: Fixed): Integer; 971begin 972 Result := Round(Fix2X(F)); 973end; 974 975{------------------------------------------------------------------------------ 976 Name: GetCarbonRect 977 Params: Left, Top, Width, Height - Coordinates 978 Returns: Carbon Rect 979 ------------------------------------------------------------------------------} 980function GetCarbonRect(Left, Top, Width, Height: Integer): MacOSAll.Rect; 981begin 982 Result.Left := Left; 983 Result.Top := Top; 984 Result.Right := Left + Width; 985 Result.Bottom := Top + Height; 986end; 987 988{------------------------------------------------------------------------------ 989 Name: GetCarbonRect 990 Params: ARect - Rectangle 991 Returns: Carbon Rect 992 ------------------------------------------------------------------------------} 993function GetCarbonRect(const ARect: TRect): MacOSAll.Rect; 994begin 995 Result.Left := ARect.Left; 996 Result.Top := ARect.Top; 997 Result.Right := ARect.Right; 998 Result.Bottom := ARect.Bottom; 999end; 1000 1001{------------------------------------------------------------------------------ 1002 Name: ParamsToCarbonRect 1003 Params: AParams - Creation parameters 1004 Returns: Carbon Rect from creation parameters 1005 ------------------------------------------------------------------------------} 1006function ParamsToCarbonRect(const AParams: TCreateParams): MacOSAll.Rect; 1007begin 1008 Result.Left := AParams.X; 1009 Result.Top := AParams.Y; 1010 Result.Right := AParams.X + AParams.Width; 1011 Result.Bottom := AParams.Y + AParams.Height; 1012end; 1013 1014{------------------------------------------------------------------------------ 1015 Name: ParamsToRect 1016 Params: AParams - Creation parameters 1017 Returns: TRect from creation parameters 1018 ------------------------------------------------------------------------------} 1019function ParamsToRect(const AParams: TCreateParams): TRect; 1020begin 1021 Result.Left := AParams.X; 1022 Result.Top := AParams.Y; 1023 Result.Right := AParams.X + AParams.Width; 1024 Result.Bottom := AParams.Y + AParams.Height; 1025end; 1026 1027function CFDateRefToDateTime(dateRef: CFDateRef): TDateTime; 1028var 1029 absTime: CFAbsoluteTime; 1030 gDate: CFGregorianDate; 1031 tz: CFTimeZoneRef; 1032begin 1033 absTime := CFDateGetAbsoluteTime(dateRef); 1034 tz := CFTimeZoneCopySystem; 1035 gDate := CFAbsoluteTimeGetGregorianDate(absTime, tz); 1036 CFRelease(tz); 1037 1038 with gDate do 1039 if not TryEncodeDateTime( 1040 trunc(year), trunc(month), trunc(day), 1041 trunc(hour), trunc(minute), trunc(second), 0, result) 1042 then 1043 result := 0; 1044 1045end; 1046 1047{------------------------------------------------------------------------------ 1048 Name: ExcludeRect 1049 Params: A - Source rectangle 1050 B - Rectangle to be excluded 1051 Returns: Array of CGRect, which are product of exclusion rectangle B from 1052 rectangle A. 1053 Note: The returned rectangles may overlap. 1054 ------------------------------------------------------------------------------} 1055function ExcludeRect(const A, B: TRect): CGRectArray; 1056begin 1057 SetLength(Result, 0); 1058 if (A.Left >= A.Right) or (A.Top >= A.Bottom) then Exit; 1059 1060 SetLength(Result, 1); 1061 Result[0] := RectToCGRect(A); 1062 1063 if (B.Left >= B.Right) or (B.Top >= B.Bottom) then Exit; 1064 1065 if (B.Left < A.Right) and (B.Right > A.Left) 1066 and (B.Top < A.Bottom) and (B.Bottom > A.Top) then 1067 begin // rectangles have intersection 1068 SetLength(Result, 0); 1069 1070 if B.Top > A.Top then 1071 begin 1072 SetLength(Result, Succ(Length(Result))); 1073 Result[High(Result)] := GetCGRect(A.Left, A.Top, A.Right, B.Top); 1074 end; 1075 1076 if B.Bottom < A.Bottom then 1077 begin 1078 SetLength(Result, Succ(Length(Result))); 1079 Result[High(Result)] := GetCGRect(A.Left, B.Bottom, A.Right, A.Bottom); 1080 end; 1081 1082 if B.Left > A.Left then 1083 begin 1084 SetLength(Result, Succ(Length(Result))); 1085 Result[High(Result)] := GetCGRect(A.Left, A.Top, B.Left, A.Bottom); 1086 end; 1087 1088 if B.Right < A.Right then 1089 begin 1090 SetLength(Result, Succ(Length(Result))); 1091 Result[High(Result)] := GetCGRect(B.Right, A.Top, A.Right, A.Bottom); 1092 end; 1093 end; 1094end; 1095 1096{------------------------------------------------------------------------------ 1097 Name: GetCGRect 1098 Params: X1, Y1, X2, Y2 - Rectangle coordinates 1099 Returns: CGRect 1100 ------------------------------------------------------------------------------} 1101function GetCGRect(X1, Y1, X2, Y2: Integer): CGRect; 1102begin 1103 Result.origin.x := X1; 1104 Result.size.width := X2 - X1; 1105 Result.origin.y := Y1; 1106 Result.size.height := Y2 - Y1; 1107end; 1108 1109{------------------------------------------------------------------------------ 1110 Name: GetCGRectSorted 1111 Params: X1, Y1, X2, Y2 - Rectangle coordinates 1112 Returns: CGRect, coordinates are sorted 1113 ------------------------------------------------------------------------------} 1114function GetCGRectSorted(X1, Y1, X2, Y2: Integer): CGRect; 1115begin 1116 if X1 <= X2 then 1117 begin 1118 Result.origin.x := X1; 1119 Result.size.width := X2 - X1; 1120 end 1121 else 1122 begin 1123 Result.origin.x := X2; 1124 Result.size.width := X1 - X2; 1125 end; 1126 1127 if Y1 <= Y2 then 1128 begin 1129 Result.origin.y := Y1; 1130 Result.size.height := Y2 - Y1; 1131 end 1132 else 1133 begin 1134 Result.origin.y := Y2; 1135 Result.size.height := Y1 - Y2; 1136 end; 1137end; 1138 1139{------------------------------------------------------------------------------ 1140 Name: RectToCGRect 1141 Params: ARect - Rectangle 1142 Returns: CGRect 1143 ------------------------------------------------------------------------------} 1144function RectToCGRect(const ARect: TRect): CGRect; 1145begin 1146 Result.origin.x := ARect.Left; 1147 Result.origin.y := ARect.Top; 1148 Result.size.width := ARect.Right - ARect.Left; 1149 Result.size.height := ARect.Bottom - ARect.Top; 1150end; 1151 1152{------------------------------------------------------------------------------ 1153 Name: CGRectToRect 1154 Params: ARect - CGRect 1155 Returns: TRect 1156 ------------------------------------------------------------------------------} 1157function CGRectToRect(const ARect: CGRect): TRect; 1158begin 1159 if CGRectIsNull(ARect) <> 0 then 1160 begin // CGRect passed is invalid! 1161 Result.Left := 0; 1162 Result.Top := 0; 1163 Result.Right := 0; 1164 Result.Bottom := 0; 1165 end 1166 else 1167 begin 1168 Result.Left := Floor(ARect.origin.x); 1169 Result.Top := Floor(ARect.origin.y); 1170 Result.Right := Ceil(ARect.origin.x + ARect.size.width); 1171 Result.Bottom := Ceil(ARect.origin.y + ARect.size.height); 1172 end; 1173end; 1174 1175{------------------------------------------------------------------------------ 1176 Name: ParamsToHIRect 1177 Params: AParams - Creation parameters 1178 Returns: HIView Rect from creation parameters 1179 ------------------------------------------------------------------------------} 1180function ParamsToHIRect(const AParams: TCreateParams): HIRect; 1181begin 1182 Result.origin.x := AParams.X; 1183 Result.origin.y := AParams.Y; 1184 Result.size.width := AParams.Width; 1185 Result.size.height := AParams.Height; 1186end; 1187 1188{------------------------------------------------------------------------------ 1189 Name: CarbonRectToRect 1190 Params: ARect - Carbon Rect 1191 Returns: Rectangle 1192 ------------------------------------------------------------------------------} 1193function CarbonRectToRect(const ARect: MacOSAll.Rect): TRect; 1194begin 1195 Result.Left := ARect.Left; 1196 Result.Top := ARect.Top; 1197 Result.Right := ARect.Right; 1198 Result.Bottom := ARect.Bottom; 1199end; 1200 1201{------------------------------------------------------------------------------ 1202 Name: HIRectToCarbonRect 1203 Params: ARect - HIRect 1204 Returns: Carbon Rect 1205 ------------------------------------------------------------------------------} 1206function HIRectToCarbonRect(const ARect: HIRect): MacOSAll.Rect; 1207begin 1208 if CGRectIsNull(ARect) <> 0 then 1209 begin // CGRect passed is invalid! 1210 Result.Left := 0; 1211 Result.Top := 0; 1212 Result.Right := 0; 1213 Result.Bottom := 0; 1214 end 1215 else 1216 begin 1217 Result.Left := Floor(ARect.origin.x); 1218 Result.Top := Floor(ARect.origin.y); 1219 Result.Right := Ceil(ARect.origin.x + ARect.size.width); 1220 Result.Bottom := Ceil(ARect.origin.y + ARect.size.height); 1221 end; 1222end; 1223 1224function SortRect(const ARect: TRect): TRect; 1225begin 1226 if ARect.Left <= ARect.Right then 1227 begin 1228 Result.Left := ARect.Left; 1229 Result.Right := ARect.Right; 1230 end 1231 else 1232 begin 1233 Result.Left := ARect.Right; 1234 Result.Right := ARect.Left; 1235 end; 1236 1237 if ARect.Top <= ARect.Bottom then 1238 begin 1239 Result.Top := ARect.Top; 1240 Result.Bottom := ARect.Bottom; 1241 end 1242 else 1243 begin 1244 Result.Top := ARect.Bottom; 1245 Result.Bottom := ARect.Top; 1246 end; 1247end; 1248 1249{------------------------------------------------------------------------------ 1250 Name: PointToHIPoint 1251 Params: APoint - Point 1252 Returns: HIPoint 1253 ------------------------------------------------------------------------------} 1254function PointToHIPoint(const APoint: TPoint): HIPoint; 1255begin 1256 Result.X := APoint.X; 1257 Result.Y := APoint.Y; 1258end; 1259 1260{------------------------------------------------------------------------------ 1261 Name: PointToHISize 1262 Params: APoint - Point 1263 Returns: HISize 1264 ------------------------------------------------------------------------------} 1265function PointToHISize(const APoint: TPoint): HISize; 1266begin 1267 Result.Width := APoint.X; 1268 Result.Height := APoint.Y; 1269end; 1270 1271{------------------------------------------------------------------------------ 1272 Name: HIPointToPoint 1273 Params: APoint - HIPoint 1274 Returns: Point 1275 ------------------------------------------------------------------------------} 1276function HIPointToPoint(const APoint: HIPoint): TPoint; 1277begin 1278 Result.X := Trunc(APoint.X); 1279 Result.Y := Trunc(APoint.Y); 1280end; 1281 1282{------------------------------------------------------------------------------ 1283 Name: GetHIPoint 1284 Params: X, Y 1285 Returns: HIPoint 1286 ------------------------------------------------------------------------------} 1287function GetHIPoint(X, Y: Single): HIPoint; 1288begin 1289 Result.X := X; 1290 Result.Y := Y; 1291end; 1292 1293{------------------------------------------------------------------------------ 1294 Name: GetHISize 1295 Params: X, Y 1296 Returns: HISize 1297 ------------------------------------------------------------------------------} 1298function GetHISize(X, Y: Single): HISize; 1299begin 1300 Result.width := X; 1301 Result.height := Y; 1302end; 1303 1304{------------------------------------------------------------------------------ 1305 Name: ColorToRGBColor 1306 Params: AColor - Color 1307 Returns: Carbon RGBColor 1308 ------------------------------------------------------------------------------} 1309function ColorToRGBColor(const AColor: TColor): RGBColor; 1310var 1311 V: TColorRef; 1312begin 1313 V := ColorToRGB(AColor); 1314 1315 Result.Red := Red(V); 1316 Result.Red := (Result.Red shl 8) or Result.Red; 1317 Result.Green := Green(V); 1318 Result.Green := (Result.Green shl 8) or Result.Green; 1319 Result.Blue := Blue(V); 1320 Result.Blue := (Result.Blue shl 8) or Result.Blue; 1321end; 1322 1323{------------------------------------------------------------------------------ 1324 Name: RGBColorToColor 1325 Params: AColor - Carbon RGBColor 1326 Returns: Color 1327 ------------------------------------------------------------------------------} 1328function RGBColorToColor(const AColor: RGBColor): TColor; 1329begin 1330 Result := RGBToColor((AColor.Red shr 8) and $FF, (AColor.Green shr 8) and $FF, (AColor.Blue shr 8) and $FF); 1331end; 1332 1333{------------------------------------------------------------------------------ 1334 Name: CreateCGColor 1335 Params: AColor - Color 1336 Returns: CGColorRef 1337 1338 Creates CGColorRef from the specified color. You are responsible for 1339 releasing it by CGColorRelease. 1340 ------------------------------------------------------------------------------} 1341function CreateCGColor(const AColor: TColor): CGColorRef; 1342var 1343 V: TColorRef; 1344 F: Array [0..3] of Single; 1345begin 1346 V := ColorToRGB(AColor); 1347 1348 F[0] := Red(V) / 255; 1349 F[1] := Green(V) / 255; 1350 F[2] := Blue(V) / 255; 1351 F[3] := 1; // Alpha 1352 Result := CGColorCreate(RGBColorSpace, @F[0]); 1353end; 1354 1355function DbgS(const ARect: MacOSAll.Rect): String; 1356begin 1357 Result := DbgS(ARect.left) + ', ' + DbgS(ARect.top) 1358 + ', ' + DbgS(ARect.right) + ', ' + DbgS(ARect.bottom); 1359end; 1360 1361function DbgS(const AColor: MacOSAll.RGBColor): String; 1362begin 1363 Result := 1364 'R: ' + IntToHex(AColor.Red, 4) + 1365 ' G: ' + IntToHex(AColor.Green, 4) + 1366 ' B: ' + IntToHex(AColor.Blue, 4); 1367end; 1368 1369function DbgS(const APoint: HIPoint): string; 1370begin 1371 Result := 'X: ' + DbgS(APoint.X) + ' Y: ' + DbgS(APoint.Y); 1372end; 1373 1374function DbgS(const ASize: HISize): string; 1375begin 1376 Result := 'W: ' + DbgS(ASize.width) + ' H: ' + DbgS(ASize.height); 1377end; 1378 1379{------------------------------------------------------------------------------ 1380 Name: RaiseCreateWidgetError 1381 Params: AControl - Which control was being created 1382 1383 Raises exception for widget creation error 1384 1385 Used on CarbonPrivate 1386 ------------------------------------------------------------------------------} 1387procedure RaiseCreateWidgetError(AControl: TWinControl); 1388begin 1389 raise Exception.CreateFmt('Unable to create Carbon widget for %s: %s!', 1390 [AControl.Name, AControl.ClassName]); 1391end; 1392 1393procedure RaiseColorSpaceError; 1394begin 1395 raise Exception.Create('Unable to create CGColorSpaceRef'); 1396end; 1397 1398procedure RaiseMemoryAllocationError; 1399begin 1400 raise Exception.Create('Unable to allocate memory'); 1401end; 1402 1403procedure RaiseContextCreationError; 1404begin 1405 raise Exception.Create('Unable to create CGContextRef'); 1406end; 1407 1408{------------------------------------------------------------------------------ 1409 Name: CustomControlHandler 1410 Handles custom control class methods 1411 ------------------------------------------------------------------------------} 1412function CustomControlHandler(ANextHandler: EventHandlerCallRef; 1413 AEvent: EventRef; 1414 {%H-}AData: Pointer): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} 1415var 1416 EventClass, EventKind: LongWord; 1417 Part: ControlPartCode; 1418const 1419 SName = 'CustomControlHandler'; 1420begin 1421 EventClass := GetEventClass(AEvent); 1422 EventKind := GetEventKind(AEvent); 1423 1424 case EventClass of 1425 kEventClassHIObject: 1426 case EventKind of 1427 kEventHIObjectConstruct, 1428 kEventHIObjectDestruct: Result := noErr; 1429 kEventHIObjectInitialize: Result := CallNextEventHandler(ANextHandler, AEvent); 1430 end; 1431 kEventClassControl: 1432 case EventKind of 1433 kEventControlGetFocusPart, 1434 kEventControlSetFocusPart: Result := CallNextEventHandler(ANextHandler, AEvent); 1435 kEventControlHitTest: 1436 begin 1437 //Result := CallNextEventHandler(ANextHandler, AEvent); 1438 // I was not able to find what for is this workaround (r11394) 1439 // returning kControlEditTextPart for any customcontrol looks strange 1440 // It seems to interfer with what widget really hit the mouse click. 1441 // 1442 // But it breaks grid's mouse selecting when clicking (near) at 1443 // the borders of cells on an always show editor grid. 1444 // 1445 // Found, without it double click doesn't occur in custom controls 1446 // temporarily restored old behaviour affects issue 22542 1447 // kControlEditTextPart is an arbitrary number 1448 {$IFDEF VerboseMouse} 1449 DebugLn('CustomControlHandler HitTest'); 1450 {$ENDIF} 1451 1452 Part := kControlEditTextPart; // workaround 1453 1454 Result := SetEventParameter(AEvent, kEventParamControlPart, 1455 typeControlPartCode, SizeOf(Part), @Part); 1456 OSError(Result, SName, SSetEvent); 1457 end; 1458 end; 1459 kEventClassTextInput: Result := noErr; 1460 kEventClassScrollable: Result := noErr; 1461 end; 1462end; 1463 1464procedure InitDefaultFont; 1465var 1466 s : Str255; 1467 st : MacOSAll.Style; 1468 sz : SInt16; 1469begin 1470 //Note: the GetThemeFont is deprecated in 10.5. CoreText functions should be used! 1471 MacOSAll.GetThemeFont(kThemeSystemFont, GetApplicationScript, @s, sz{%H-}, st{%H-}); 1472 CarbonDefaultFont := s; 1473 CarbonDefaultFontSize := sz; 1474end; 1475 1476var 1477 EventSpec: Array [0..8] of EventTypeSpec; 1478 CustomControlHandlerUPP: EventHandlerUPP; 1479 1480initialization 1481 1482 OSError( 1483 ATSUCreateStyle(DefaultTextStyle), 'CarbonProc.initialization', SCreateStyle); 1484 RGBColorSpace := CGColorSpaceCreateDeviceRGB; 1485 GrayColorSpace := CGColorSpaceCreateDeviceGray; 1486 1487 EventSpec[0].eventClass := kEventClassHIObject; 1488 EventSpec[0].eventKind := kEventHIObjectConstruct; 1489 EventSpec[1].eventClass := kEventClassHIObject; 1490 EventSpec[1].eventKind := kEventHIObjectInitialize; 1491 EventSpec[2].eventClass := kEventClassHIObject; 1492 EventSpec[2].eventKind := kEventHIObjectDestruct; 1493 EventSpec[3].eventClass := kEventClassControl; 1494 EventSpec[3].eventKind := kEventControlHitTest; 1495 EventSpec[4].eventClass := kEventClassTextInput; 1496 EventSpec[4].eventKind := kEventTextInputUnicodeForKeyEvent; 1497 EventSpec[5].eventClass := kEventClassControl; 1498 EventSpec[5].eventKind := kEventControlGetFocusPart; 1499 EventSpec[6].eventClass := kEventClassControl; 1500 EventSpec[6].eventKind := kEventControlSetFocusPart; 1501 EventSpec[7].eventClass := kEventClassScrollable; 1502 EventSpec[7].eventKind := kEventScrollableGetInfo; 1503 EventSpec[8].eventClass := kEventClassScrollable; 1504 EventSpec[8].eventKind := kEventScrollableScrollTo; 1505 1506 CustomControlHandlerUPP := NewEventHandlerUPP(EventHandlerProcPtr(@CustomControlHandler)); 1507 1508 CreateCFString('com.lazarus.customcontrol', CustomControlClassID); 1509 CreateCFString('com.apple.hiview', HIViewClassID); 1510 1511 OSError( 1512 HIObjectRegisterSubclass(CustomControlClassID, HIViewClassID, 0, 1513 CustomControlHandlerUPP, Length(EventSpec), @EventSpec[0], nil, nil), 1514 'CarbonProc.initialization', 'HIObjectRegisterSubclass'); 1515 1516 InitDefaultFont; 1517 1518finalization 1519 1520 FreeCFString(CustomControlClassID); 1521 FreeCFString(HIViewClassID); 1522 DisposeEventHandlerUPP(CustomControlHandlerUPP); 1523 1524 1525 OSError( 1526 ATSUDisposeStyle(DefaultTextStyle), 'CarbonProc.finalization', SDisposeStyle); 1527 CGColorSpaceRelease(RGBColorSpace); 1528 CGColorSpaceRelease(GrayColorSpace); 1529 1530end. 1531 1532 1533