1{%MainUnit carbonint.pas} 2 3{****************************************************************************** 4 All utility method implementations of the TCarbonWidgetSet class are here. 5 6 7 ****************************************************************************** 8 Implementation 9 ****************************************************************************** 10 11 ***************************************************************************** 12 This file is part of the Lazarus Component Library (LCL) 13 14 See the file COPYING.modifiedLGPL.txt, included in this distribution, 15 for details about the license. 16 ***************************************************************************** 17} 18 19{ TCarbonWidgetSet } 20 21{ 22 This event handler will fix the focus indication in AXApplication for 23 standard controls where it gets it wrong. Necessary to support accessibility 24 for TMemo / TEdit for example 25} 26function AppAccessibilityEventHandler(inHandlerCallRef: EventHandlerCallRef; 27 inEvent: EventRef; 28 {%H-}inUserData: Pointer): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} 29var 30 lAXRole, lInputStr: CFStringRef; 31 lInputAXObject: AXUIElementRef; 32 EventKind: UInt32; 33 lInputPasStr: string; 34 lElement, lElement2: AXUIElementRef; 35 lAXArray: CFMutableArrayRef; 36begin 37 Result := CallNextEventHandler(inHandlerCallRef, inEvent); 38 39 GetEventParameter(inEvent, kEventParamAccessibleObject, 40 typeCFTypeRef, nil, SizeOf(AXUIElementRef), nil, @lInputAXObject); 41 42 EventKind := GetEventKind(inEvent); 43 case EventKind of 44 kEventAccessibleGetNamedAttribute: 45 begin 46 GetEventParameter(inEvent, kEventParamAccessibleAttributeName, 47 typeCFStringRef, nil, SizeOf(CFStringRef), nil, @lInputStr); 48 49 lInputPasStr := CFStringToStr(lInputStr); 50 51 if lInputPasStr = 'AXFocusedUIElement' then 52 begin 53 // First interfere only if the element returned is in our black list 54 // for example: memo border 55 GetEventParameter(inEvent, kEventParamAccessibleAttributeValue, 56 typeCFTypeRef, nil, SizeOf(AXUIElementRef), nil, @lElement); 57 58 AXUIElementCopyAttributeValue(lElement, CFSTR('AXRoleDescription'), lAXRole{%H-}); 59 lInputPasStr := CFStringToStr(lAXRole); 60 if lInputPasStr = 'memoborder' then 61 begin 62 AXUIElementCopyAttributeValue(lElement, CFSTR('AXChildren'), lAXArray{%H-}); 63 lElement2 := CFArrayGetValueAtIndex(lAXArray, 0); 64 SetEventParameter(inEvent, kEventParamAccessibleAttributeValue, typeCFTypeRef, 65 SizeOf(AXUIElementRef), @lElement2); 66 67 Result := noErr; 68 Exit; 69 end; 70 end; 71 end; // kEventAccessibleGetNamedAttribute 72 end; // case EventKind of 73end; 74 75{ 76The only drawback to making your own event loop dispatching calls in the main 77application thread is that you won't get the standard application event handler 78installed. Specifically, the RunApplicationEventLoop function installs handlers 79to do the following: 80* Allow clicks in the menu bar to begin menu tracking 81* Dispatch Apple events by calling AEProcessAppleEvent 82* Respond to quit Apple events by quitting RunApplicationEventLoop. 83 84One way to work around this limitation is by creating a dummy custom event 85handler. When you are ready to process events, create the dummy event yourself, 86post it to the queue and then call RunApplicationEventLoop (to install the 87standard application event handler). The dummy event handler can then process 88the events manually. For an example of using this method, see Technical 89Q&A 1061 in Developer Documentation Technical Q&As. 90 91} 92 93// From: Technical Q&A 1061 in Developer Documentation Technical Q&As 94// MWE: modified to fit the LCL, but the basic idea comes from Q&A 1061 95 96function QuitEventHandler(inHandlerCallRef: EventHandlerCallRef; 97 inEvent: EventRef; 98 {%H-}inUserData: Pointer): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} 99 // This event handler is used to override the kEventClassApplication 100 // kEventAppQuit event while inside our event loop (EventLoopEventHandler). 101 // It simply calls through to the next handler and, if that handler returns 102 // noErr (indicating that the application is doing to quit), it sets 103 // a Boolean to tell our event loop to quit as well. 104 // MWE: in our case, terminates the app also 105begin 106 Result := CallNextEventHandler(inHandlerCallRef, inEvent); 107 if Result <> noErr then Exit; 108 109 if (Widgetset <> nil) and TCarbonWidgetSet(Widgetset).FTerminating then Exit; 110 111 TCarbonWidgetSet(Widgetset).FTerminating := True; 112 113 if Application = nil then Exit; 114 Application.Terminate; 115end; 116 117 118function EventLoopEventHandler({%H-}inHandlerCallRef: EventHandlerCallRef; 119 {%H-}inEvent: EventRef; 120 inUserData: Pointer): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} 121 // This code contains the standard Carbon event dispatch loop, 122 // as per "Inside Macintosh: Handling Carbon Events", Listing 3-10, 123 // except: 124 // 125 // o this loop supports yielding to cooperative threads based on the 126 // application maintaining the gNumberOfRunningThreads global 127 // variable, and 128 // 129 // o it also works around a problem with the Inside Macintosh code 130 // which unexpectedly quits when run on traditional Mac OS 9. 131 // 132 // See RunApplicationEventLoopWithCooperativeThreadSupport for 133 // an explanation of why this is inside a Carbon event handler. 134 // 135 // The code in Inside Mac has a problem in that it quits the 136 // event loop when ReceiveNextEvent returns an error. This is 137 // wrong because ReceiveNextEvent can return eventLoopQuitErr 138 // when you call WakeUpProcess on traditional Mac OS. So, rather 139 // than relying on an error from ReceiveNextEvent, this routine tracks 140 // whether the application is really quitting by installing a 141 // customer handler for the kEventClassApplication/kEventAppQuit 142 // Carbon event. All the custom handler does is call through 143 // to the previous handler and, if it returns noErr (which indicates 144 // the application is quitting, it sets quitNow so that our event 145 // loop quits. 146 // 147 // Note that this approach continues to support QuitApplicationEventLoop, 148 // which is a simple wrapper that just posts a kEventClassApplication/ 149 // kEventAppQuit event to the event loop. 150 151var 152 QuitUPP: EventHandlerUPP; 153 QuitHandler: EventHandlerRef; 154 TmpSpec: EventTypeSpec; 155 Loop: TApplicationMainLoop = nil; 156begin 157 // Get our TApplicationMainLoop 158 Result := noErr; 159 if (not Assigned(inUserData)) or TCarbonWidgetSet(inUserData).FUserTerm then Exit; 160 Loop := TCarbonWidgetSet(inUserData).FAppLoop; 161 if not Assigned(Loop) then Exit; 162 163 // Install our override on the kEventClassApplication, kEventAppQuit event. 164 QuitUPP := NewEventHandlerUPP(EventHandlerProcPtr(Pointer(@QuitEventHandler))); 165 //todo: raise exception ?? 166 if QuitUPP = nil then Exit; 167 168 try 169 TmpSpec := MakeEventSpec(kEventClassApplication, kEventAppQuit); 170 if not InstallApplicationEventHandler(QuitUPP, 1, @TmpSpec, nil, @QuitHandler) then Exit; 171 try 172 // Run our event loop until quitNow is set. 173 Loop; 174 finally 175 MacOSAll.RemoveEventHandler(QuitHandler); 176 end; 177 finally 178 DisposeEventHandlerUPP(QuitUPP); 179 end; 180 181(* 182 theTarget := GetEventDispatcherTarget; 183 repeat 184 if MNumberOfRunningThreads = 0 185 then timeToWaitForEvent := kEventDurationForever 186 else timeToWaitForEvent := kEventDurationNoWait; 187 188 Result := ReceiveNextEvent(0, nil, timeToWaitForEvent, true, theEvent); 189 if Result = noErr 190 then begin 191 SendEventToEventTarget(theEvent, theTarget); 192 ReleaseEvent(theEvent); 193 end; 194 if MNumberOfRunningThreads > 0 195 then YieldToAnyThread; 196 until quitNow; 197*) 198end; 199 200{------------------------------------------------------------------------------ 201 Name: CarbonApp_CommandProcess 202 Handles main menu and context menus commands 203 ------------------------------------------------------------------------------} 204function CarbonApp_CommandProcess(ANextHandler: EventHandlerCallRef; 205 AEvent: EventRef; 206 {%H-}AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} 207var 208 Command: HICommandExtended; 209 CarbonMenu: TCarbonMenu; 210 Msg: TLMessage; 211 S: LongWord; 212 AllowMenu: Boolean; 213 Focused: HWND; 214 HotChar: Char; 215const SName = 'CarbonApp_CommandProcess'; 216begin 217 {$IFDEF VerboseAppEvent} 218 DebugLn('CarbonApp_CommandProcess'); 219 {$ENDIF} 220 221 if not OSError( 222 GetEventParameter(AEvent, kEventParamDirectObject, 223 typeHICommand, nil, SizeOf(HICommand), nil, @Command), 224 SName, 'GetEventParameter') then 225 begin 226 {$IFDEF VerboseMenu} 227 DebugLn('CarbonApp_CommandProcess MenuRef: ' + DbgS(Command.menuRef) + 228 ' Item: ' + DbgS(Command.menuItemIndex) + ' CommandID: ' + DbgS(Command.commandID) + 229 ' Attrs: ' + DbgS(Command.attributes)); 230 {$ENDIF} 231 232 // check command and send "click" message to menu item 233 if (Command.commandID = MENU_FOURCC) and 234 (Command.attributes and kHICommandFromMenu > 0) and 235 (Command.menuRef <> nil) then 236 begin 237 if not OSError(GetMenuItemProperty(Command.menuRef, Command.menuItemIndex, 238 LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(TCarbonMenu), S{%H-}, @CarbonMenu), 239 SName, 'GetMenuItemProperty') then 240 begin 241 {$IFDEF VerboseMenu} 242 DebugLn('CarbonApp_CommandProcess CarbonMenu: ' + DbgS(CarbonMenu)); 243 {$ENDIF} 244 if CarbonMenu <> nil then 245 begin 246 Hotchar:=CarbonMenu.GetShortCutKey; 247 { CommandProcess is fired before a keyboard event } 248 { we must check if the control has default system handlers on the hot-key used } 249 { if so, CommandProcess is not processed, and the key values event are sent } 250 { to the control by the system. } 251 { } 252 { Another possible solution of the problem, is to Post another custom event } 253 { to the loop, and report LCL about Menu pressed after the event arrives, } 254 { though it might seem, like interface is lagging } 255 if (CarbonMenu.Parent.Dismissed<>kHIMenuDismissedBySelection) and (HotChar<>#0) then 256 begin 257 AllowMenu := True; 258 Focused:=GetFocus; 259 if (Focused<>0) and (TObject(Focused) is TCarbonControl) then 260 begin 261 TCarbonControl(Focused).AllowMenuProcess(HotChar, GetCarbonShiftState, AllowMenu); 262 if not AllowMenu then 263 begin 264 Result:=eventNotHandledErr; 265 CarbonMenu.Parent.Dismissed:=0; 266 Exit; 267 end; 268 end; 269 end; 270 271 if CarbonMenu.Parent.Dismissed=kHIMenuDismissedBySelection then begin 272 FillChar(Msg{%H-}, SizeOf(Msg), 0); 273 Msg.msg := LM_ACTIVATE; 274 DeliverMessage(CarbonMenu.LCLMenuItem, Msg); 275 if assigned(CarbonMenu.Parent) then // if parent not closed 276 CarbonMenu.Parent.Dismissed:=0; 277 Result := noErr; 278 Exit; 279 end else 280 Result:=CallNextEventHandler(ANextHandler, AEvent); 281 282 end; 283 end; 284 end; 285 end; 286 287 Result := CallNextEventHandler(ANextHandler, AEvent); 288end; 289 290{------------------------------------------------------------------------------ 291 Name: CarbonApp_Shown 292 Handles application show 293 ------------------------------------------------------------------------------} 294function CarbonApp_Shown(ANextHandler: EventHandlerCallRef; 295 AEvent: EventRef; 296 {%H-}AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} 297begin 298 {$IFDEF VerboseAppEvent} 299 DebugLn('CarbonApp_Shown'); 300 {$ENDIF} 301 302 Result := CallNextEventHandler(ANextHandler, AEvent); 303 304 Application.IntfAppRestore; 305end; 306 307{------------------------------------------------------------------------------ 308 Name: CarbonApp_Hidden 309 Handles application hide 310 ------------------------------------------------------------------------------} 311function CarbonApp_Hidden(ANextHandler: EventHandlerCallRef; 312 AEvent: EventRef; 313 {%H-}AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} 314begin 315 {$IFDEF VerboseAppEvent} 316 DebugLn('CarbonApp_Hidden'); 317 {$ENDIF} 318 319 Result := CallNextEventHandler(ANextHandler, AEvent); 320 321 Application.IntfAppMinimize; 322end; 323 324{------------------------------------------------------------------------------ 325 Name: CarbonApp_Deactivated 326 Handles application deactivation 327 ------------------------------------------------------------------------------} 328function CarbonApp_Deactivated(ANextHandler: EventHandlerCallRef; 329 AEvent: EventRef; 330 {%H-}AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} 331begin 332 {$IFDEF VerboseAppEvent} 333 DebugLn('CarbonApp_Deactivate'); 334 {$ENDIF} 335 336 Result := CallNextEventHandler(ANextHandler, AEvent); 337 338 Application.IntfAppDeactivate; 339end; 340 341{------------------------------------------------------------------------------ 342 Name: CarbonApp_Activated 343 Handles application activation 344 ------------------------------------------------------------------------------} 345function CarbonApp_Activated(ANextHandler: EventHandlerCallRef; 346 AEvent: EventRef; 347 {%H-}AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} 348begin 349 {$IFDEF VerboseAppEvent} 350 DebugLn('CarbonApp_Activate'); 351 {$ENDIF} 352 353 Result := CallNextEventHandler(ANextHandler, AEvent); 354 355 Application.IntfAppActivate; 356end; 357 358{------------------------------------------------------------------------------ 359 Name: CarbonApp_Activated 360 Handles application activation 361 ------------------------------------------------------------------------------} 362function CarbonApp_LazWake(ANextHandler: EventHandlerCallRef; 363 AEvent: EventRef; 364 {%H-}AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} 365begin 366 {$IFDEF VerboseAppEvent} 367 DebugLn('CarbonApp_LazWake'); 368 {$ENDIF} 369 370 Result := CallNextEventHandler(ANextHandler, AEvent); 371 372 if IsMultiThread then 373 begin 374 // a thread is waiting -> synchronize 375 CheckSynchronize; 376 end; 377end; 378 379 380{------------------------------------------------------------------------------ 381 Name: CarbonApp_Open 382 Handles application open 383 ------------------------------------------------------------------------------} 384function CarbonApp_Open(var AEvent: AppleEvent; var {%H-}Reply: AppleEvent; 385 {%H-}Data: SInt32): OSErr; {$IFDEF darwin}mwpascal;{$ENDIF} 386var 387 DocList: AEDescList; 388 FileCount: Integer; 389 FileIdx: Integer; 390 Keyword: AEKeyword; 391 FileDesc: AEDesc; 392 FileRef: FSRef; 393 FileURL: CFURLRef; 394 FileCFStr: CFStringRef; 395 Files: Array of String; 396const 397 SName = 'OpenDocEventHandler'; 398begin 399 {$IFDEF VerboseAppEvent} 400 DebugLn('CarbonApp_Open'); 401 {$ENDIF} 402 403 if OSError(AEGetParamDesc(AEvent, keyDirectObject, typeAEList, DocList{%H-}), 404 SName, 'AEGetParamDesc') then Exit; 405 406 try 407 if OSError(AECountItems(DocList, FileCount{%H-}), SName, 'AECountItems') then Exit; 408 409 410 SetLength(Files, 0); 411 412 for FileIdx := 1 to FileCount do 413 begin 414 if OSError(AEGetNthDesc(DocList, FileIdx, typeFSRef, @Keyword, FileDesc{%H-}), 415 SName, 'AEGetNthDesc') then Continue; 416 417 if OSError(AEGetDescData(FileDesc, @FileRef, SizeOf(FSRef)), 418 SName, 'AEGetDescData') then Continue; 419 420 if OSError(AEDisposeDesc(FileDesc), 421 SName, 'AEDisposeDesc') then Continue; 422 423 FileURL := CFURLCreateFromFSRef(kCFAllocatorDefault, FileRef); 424 FileCFStr := CFURLCopyFileSystemPath(FileURL, kCFURLPOSIXPathStyle); 425 try 426 SetLength(Files, Length(Files) + 1); 427 Files[High(Files)] := CFStringToStr(FileCFStr); 428 finally 429 FreeCFString(FileURL); 430 FreeCFString(FileCFStr); 431 end; 432 end; 433 434 if Length(Files) > 0 then 435 begin 436 if Application <> nil then 437 begin 438 if Application.MainForm <> nil then 439 Application.MainForm.IntfDropFiles(Files); 440 441 Application.IntfDropFiles(Files); 442 end; 443 end; 444 finally 445 AEDisposeDesc(DocList); 446 end; 447 448 Result := noErr; 449end; 450 451{------------------------------------------------------------------------------ 452 Name: CarbonApp_DragReceive 453 Handles dropping files on application 454 ------------------------------------------------------------------------------} 455function CarbonApp_DragReceive(theWindow: WindowRef; handlerRefCon: UnivPtr; theDrag: DragRef): OSErr; {$IFDEF darwin}mwpascal;{$ENDIF} 456var 457 theItemRef: DragItemRef; 458 theFlavorData: HFSFlavor; 459 theDataSize: Size; 460 theFilename: pchar; 461 theFileRef: FSRef; 462 numItems: UInt16; 463 Files: array of string; 464 itemNum: UInt16; 465begin 466 SetLength(Files, 0); 467 468 numItems := 0; 469 470 if CountDragItems(theDrag, numItems) <> noErr then exit; 471 472 if numItems > 0 then 473 for itemNum := 1 to numItems do 474 begin 475 if GetDragItemReferenceNumber(theDrag, itemNum, theItemRef) <> noErr then continue; 476 theDataSize := sizeof(theFlavorData); 477 if GetFlavorData(theDrag, theItemRef, kDragFlavorTypeHFS, @theFlavorData, theDataSize, 0) <> noErr then continue; 478 479 FSpMakeFSRef(theFlavorData.fileSpec, theFileRef); 480 481 theFilename := stralloc(1024); //PATH_MAX = 1024 482 483 FSRefMakePath(theFileRef, theFilename, StrBufSize(theFilename)); 484 485 try 486 SetLength(Files, Length(Files) + 1); 487 Files[High(Files)] := theFilename; 488 finally 489 StrDispose(theFilename); 490 end; 491 end; 492 493 if Length(Files) > 0 then 494 begin 495 if Application <> nil then 496 begin 497 if Application.MainForm <> nil then 498 Application.MainForm.IntfDropFiles(Files); 499 500 Application.IntfDropFiles(Files); 501 end; 502 end; 503 504 Result := noErr; 505end; 506 507{------------------------------------------------------------------------------ 508 Name: CarbonApp_Quit 509 Handles application quit 510 ------------------------------------------------------------------------------} 511function CarbonApp_Quit(var {%H-}AEvent: AppleEvent; var {%H-}Reply: AppleEvent; 512 {%H-}Data: SInt32): OSErr; {$IFDEF darwin}mwpascal;{$ENDIF} 513begin 514 {$IFDEF VerboseAppEvent} 515 DebugLn('CarbonApp_Quit'); 516 {$ENDIF} 517 518 if (Application <> nil) and (Application.MainForm <> nil) then 519 begin 520 Application.MainForm.Close; 521 end; 522 523 Result := noErr; 524end; 525 526{------------------------------------------------------------------------------ 527 Method: TCarbonWidgetSet.AppInit 528 Params: ScreenInfo 529 530 Initialize Carbon Widget Set 531 ------------------------------------------------------------------------------} 532procedure TCarbonWidgetSet.AppInit(var ScreenInfo: TScreenInfo); 533var 534 ScreenDC: HDC; 535begin 536 {$IFDEF VerboseObject} 537 DebugLn('TCarbonWidgetSet.AppInit'); 538 {$ENDIF} 539 540 WakeMainThread := @OnWakeMainThread; 541 542 // fill the screen info 543 ScreenDC := GetDC(0); 544 try 545 ScreenInfo.PixelsPerInchX := 96; //GetDeviceCaps(ScreenDC, LOGPIXELSX); 546 ScreenInfo.PixelsPerInchY := 96; //GetDeviceCaps(ScreenDC, LOGPIXELSY); 547 ScreenInfo.ColorDepth := GetDeviceCaps(ScreenDC, BITSPIXEL); 548 finally 549 ReleaseDC(0, ScreenDC); 550 end; 551 552 fMainEventQueue:=GetMainEventQueue; 553 554 555end; 556 557{------------------------------------------------------------------------------ 558 Method: TCarbonWidgetSet.AppRun 559 Params: ALoop 560 ------------------------------------------------------------------------------} 561procedure TCarbonWidgetSet.AppRun(const ALoop: TApplicationMainLoop); 562 // A reimplementation of RunApplicationEventLoop that supports 563 // yielding time to cooperative threads. It relies on the 564 // rest of your application to maintain a global variable, 565 // gNumberOfRunningThreads, that reflects the number of threads 566 // that are ready to run. 567var 568 DummyEvent: EventRef; 569 EventSpec: EventTypeSpec; 570 EventLoopUPP, AccessibilityUPP: EventHandlerUPP; 571 EventLoopHandler, AccessibilityHandle: EventHandlerRef; 572begin 573 {$IFDEF VerboseObject} 574 DebugLn('TCarbonWidgetSet.AppRun'); 575 {$ENDIF} 576 FAppLoop:=ALoop; 577 DummyEvent := nil; 578 579 // Accessibility for AXApplication 580 AccessibilityUPP := NewEventHandlerUPP(EventHandlerProcPtr(Pointer(@AppAccessibilityEventHandler))); 581 EventSpec := MakeEventSpec(kEventClassAccessibility, kEventAccessibleGetNamedAttribute); 582 InstallApplicationEventHandler(AccessibilityUPP, 1, @EventSpec, Self, @AccessibilityHandle); 583 584 // Create a UPP for EventLoopEventHandler and QuitEventHandler 585 586 EventLoopUPP := NewEventHandlerUPP(EventHandlerProcPtr( 587 Pointer(@EventLoopEventHandler))); 588 if EventLoopUPP = nil then 589 RaiseGDBException('TCarbonWidgetSet.InitMainLoop no eventhandler'); 590 591 // Install EventLoopEventHandler, create a dummy event and post it, 592 // and then call RunApplicationEventLoop. The rationale for this 593 // is as follows: We want to unravel RunApplicationEventLoop so 594 // that we can can yield to cooperative threads. In fact, the 595 // core code for RunApplicationEventLoop is pretty easy (you 596 // can see it above in EventLoopEventHandler). However, if you 597 // just execute this code you miss out on all the standard event 598 // handlers. These are relatively easy to reproduce (handling 599 // the quit event and so on), but doing so is a pain because 600 // a) it requires a bunch boilerplate code, and b) if Apple 601 // extends the list of standard event handlers, your application 602 // wouldn't benefit. So, we execute our event loop from within 603 // a Carbon event handler that we cause to be executed by 604 // explicitly posting an event to our event loop. Thus, the 605 // standard event handlers are installed while our event loop runs. 606 607 EventSpec := MakeEventSpec(LCLCarbonEventClass, LCLCarbonEventKindMain); 608 if not InstallApplicationEventHandler(EventLoopUPP, 1, @EventSpec, Self, 609 @EventLoopHandler) then Exit; 610 try 611 if CreateEvent(nil, EventSpec.eventClass, EventSpec.eventKind, 0, 612 kEventAttributeNone, DummyEvent) <> noErr 613 then 614 RaiseGDBException('TCarbonWidgetSet.InitMainLoop create first dummy event failed'); 615 616 try 617 {if SetEventParameter(DummyEvent, MakeFourCC('Loop'), 618 MakeFourCC('TAML'), SizeOf(ALoop), 619 @ALoop) <> noErr 620 then 621 RaiseGDBException('TCarbonWidgetSet.InitMainLoop setparam to first event failed');} 622 623 //DebuglnThrea dLog('TCarbonWidgetSet.AppRun '+dbgs(GetMainEventQueue)); 624 if PostEventToQueue(FMainEventQueue, DummyEvent, 625 kEventPriorityHigh) <> noErr 626 then 627 RaiseGDBException('TCarbonWidgetSet.AppRun post dummy event failed'); 628 finally 629 ReleaseEvent(DummyEvent); 630 end; 631 632 SignalFirstAppEvent; 633 if not FUserTerm then 634 begin 635 RunApplicationEventLoop; 636 end; 637 FAppStdEvents:=True; 638 639 finally 640 MacOSAll.RemoveEventHandler(EventLoopHandler); 641 DisposeEventHandlerUPP(EventLoopUPP); 642 end; 643 644 {$IFDEF VerboseObject} 645 DebugLn('TCarbonWidgetSet.AppRun END'); 646 {$ENDIF} 647end; 648 649{------------------------------------------------------------------------------ 650 Method: TCarbonWidgetSet.AppProcessMessages 651 652 Handle all pending messages 653 ------------------------------------------------------------------------------} 654procedure TCarbonWidgetSet.AppProcessMessages; 655var 656 Target: EventTargetRef; 657 Event: EventRef; 658 CurEventClass: TEventInt; 659 CurEventKind: TEventInt; 660begin 661 {$IFDEF VerboseObject} 662 DebugLn('TCarbonWidgetSet.AppProcessMessages'); 663 {$ENDIF} 664 665 if not FAppStdEvents then InstallStandardEventHandler(GetApplicationEventTarget); 666 667 Target := GetEventDispatcherTarget; 668 CurEventClass.Chars[4] := #0; 669 CurEventKind.Chars[4] := #0; 670 repeat 671 FreePendingWidgets; 672 if ReceiveNextEvent(0, nil, kEventDurationNoWait, True, 673 Event{%H-}) <> noErr then Break; 674 675 CurEventClass.Int := GetEventClass(Event); 676 CurEventKind.Int := GetEventKind(Event); 677 678 {$IFDEF DebugEventLoop} 679 DebugLn('EventClass: "',CurEventClass.Chars,'" EventKind: ',IntToStr(CurEventKind.Int)); 680 {$ENDIF} 681 682 if CurEventClass.Chars = LCLCarbonEventClass then 683 begin 684 // internal carbon intf message 685 {$IFDEF DebugEventLoop} 686 DebugLn('EventKind: ',CurEventKind.Chars); 687 {$ENDIF} 688 if (CurEventKind.Chars = LCLCarbonEventKindUser) then 689 begin 690 end; 691 end; 692 693 SendEventToEventTarget(Event, Target); 694 ReleaseEvent(Event); 695 696 if Clipboard <> nil then 697 if Clipboard.OwnerShips > 0 then Clipboard.CheckOwnerShip; 698 699 until Application.Terminated; 700 701 {$IFDEF VerboseObject} 702 DebugLn('TCarbonWidgetSet.AppProcessMessages END'); 703 {$ENDIF} 704end; 705 706{------------------------------------------------------------------------------ 707 Method: TCarbonWidgetSet.AppWaitMessage 708 709 Passes execution control to Carbon 710 ------------------------------------------------------------------------------} 711procedure TCarbonWidgetSet.AppWaitMessage; 712var 713 Event: EventRef; 714begin 715 {$IFDEF VerboseObject} 716 DebugLn('TCarbonWidgetSet.AppWaitMessage'); 717 {$ENDIF} 718 719 // Simply wait forever for the next event. 720 // Don't pull it, so we can handle it later. 721 OSError(ReceiveNextEvent(0, nil, kEventDurationForever, False, Event{%H-}), 722 Self, 'AppWaitMessage', 'ReceiveNextEvent'); 723end; 724 725{------------------------------------------------------------------------------ 726 Method: TCarbonWidgetSet.Create 727 728 Constructor for the class 729 ------------------------------------------------------------------------------} 730constructor TCarbonWidgetSet.Create; 731begin 732 CarbonWidgetSet := Self; 733 inherited Create; 734 FTerminating := False; 735 fMenuEnabled := True; 736 737 FTimerMap := TMap.Create(its4, SizeOf(TWSTimerProc)); 738 FCurrentCursor := 0; 739 FMainMenu := 0; 740 FCaptureWidget := 0; 741 742 RegisterEvents; 743 744 { if using Cocoa, we need an autorelease pool 745 and we also need to initialize NSApplication } 746 {$ifdef CarbonUseCocoa} 747 pool := NSAutoreleasePool.Create; 748 749 NSApplicationLoad(); 750 {$endif} 751end; 752 753{------------------------------------------------------------------------------ 754 Method: TCarbonWidgetSet.Destroy 755 756 Destructor for the class 757 ------------------------------------------------------------------------------} 758destructor TCarbonWidgetSet.Destroy; 759begin 760 CaretWidgetSetReleased; 761 762 FreeAndNil(FTimerMap); 763 DisposeAEEventHandlerUPP(FOpenEventHandlerUPP); 764 DisposeAEEventHandlerUPP(FQuitEventHandlerUPP); 765 766 inherited Destroy; 767 CarbonWidgetSet := nil; 768 769 // if using Cocoa, release autorelease the pool 770 {$ifdef CarbonUseCocoa} 771 if pool <> nil then pool.Free; 772 {$endif} 773end; 774 775{------------------------------------------------------------------------------ 776 Method: TCarbonWidgetSet.RawImage_DescriptionFromCarbonBitmap 777 778 Creates a rawimage description for a carbonbitmap 779 ------------------------------------------------------------------------------} 780function TCarbonWidgetSet.RawImage_DescriptionFromCarbonBitmap(out ADesc: TRawImageDescription; ABitmap: TCarbonBitmap): Boolean; 781var 782 Prec, Shift, BPR: Byte; 783 AlphaInfo: CGImageAlphaInfo; 784begin 785 ADesc.Init; 786 787 case ABitmap.BitmapType of 788 cbtMono, cbtGray: ADesc.Format := ricfGray; 789 else 790 ADesc.Format := ricfRGBA; 791 end; 792 793 ADesc.Width := CGImageGetWidth(ABitmap.CGImage); 794 ADesc.Height := CGImageGetHeight(ABitmap.CGImage); 795 796 //ADesc.PaletteColorCount := 0; 797 798 ADesc.BitOrder := riboReversedBits; 799 ADesc.ByteOrder := riboMSBFirst; 800 801 BPR := CGImageGetBytesPerRow(ABitmap.CGImage) and $FF; 802 if BPR and $F = 0 then ADesc.LineEnd := rileDQWordBoundary // 128bit aligned 803 else if BPR and $7 = 0 then ADesc.LineEnd := rileQWordBoundary // 64bit aligned 804 else if BPR and $3 = 0 then ADesc.LineEnd := rileWordBoundary // 32bit aligned 805 else if BPR and $1 = 0 then ADesc.LineEnd := rileByteBoundary // 8bit aligned 806 else ADesc.LineEnd := rileTight; 807 808 ADesc.LineOrder := riloTopToBottom; 809 ADesc.BitsPerPixel := CGImageGetBitsPerPixel(ABitmap.CGImage); 810 811 ADesc.MaskBitOrder := riboReversedBits; 812 ADesc.MaskBitsPerPixel := 1; 813 ADesc.MaskLineEnd := rileByteBoundary; 814 // ADesc.MaskShift := 0; 815 816 Prec := CGImageGetBitsPerComponent(ABitmap.CGImage) and $FF; 817 AlphaInfo := CGImageGetAlphaInfo(ABitmap.CGImage); 818 819 if AlphaInfo <> kCGImageAlphaOnly 820 then begin 821 ADesc.RedPrec := Prec; 822 ADesc.GreenPrec := Prec; 823 ADesc.BluePrec := Prec; 824 end; 825 826 // gray or mono 827 if ADesc.Format = ricfGray then begin 828 ADesc.Depth := 1; 829 Exit; 830 end; 831 832 // alpha 833 case AlphaInfo of 834 kCGImageAlphaNone, 835 kCGImageAlphaNoneSkipLast, 836 kCGImageAlphaNoneSkipFirst: begin 837 ADesc.Depth := Prec * 3; 838 // ADesc.AlphaPrec := 0; 839 end; 840 else 841 ADesc.Depth := Prec * 4; 842 ADesc.AlphaPrec := Prec; 843 end; 844 845 case AlphaInfo of 846 kCGImageAlphaNone, 847 kCGImageAlphaNoneSkipLast: begin 848 // RGBx 849 Shift := 32 - Prec; 850 ADesc.RedShift := Shift; 851 Dec(Shift, Prec); 852 ADesc.GreenShift := Shift; 853 Dec(Shift, Prec); 854 ADesc.BlueShift := Shift; 855 end; 856 kCGImageAlphaNoneSkipFirst: begin 857 // xRGB 858 Shift := 0; 859 ADesc.BlueShift := Shift; 860 Inc(Shift, Prec); 861 ADesc.GreenShift := Shift; 862 Inc(Shift, Prec); 863 ADesc.RedShift := Shift; 864 end; 865 kCGImageAlphaPremultipliedFirst, 866 kCGImageAlphaFirst: begin 867 // ARGB 868 Shift := 32 - Prec; 869 ADesc.AlphaShift := Shift; 870 Dec(Shift, Prec); 871 ADesc.RedShift := Shift; 872 Dec(Shift, Prec); 873 ADesc.GreenShift := Shift; 874 Dec(Shift, Prec); 875 ADesc.BlueShift := Shift; 876 end; 877 kCGImageAlphaPremultipliedLast, 878 kCGImageAlphaLast: begin 879 // RGBA 880 Shift := 32 - Prec; 881 ADesc.RedShift := Shift; 882 Dec(Shift, Prec); 883 ADesc.GreenShift := Shift; 884 Dec(Shift, Prec); 885 ADesc.BlueShift := Shift; 886 Dec(Shift, Prec); 887 ADesc.AlphaShift := Shift; 888 end; 889 kCGImageAlphaOnly: begin 890 // A 891 //ADesc.AlphaShift := 0; 892 end; 893 end; 894 895 Result := True; 896end; 897 898{------------------------------------------------------------------------------ 899 Method: TCarbonWidgetSet.RawImage_FromCarbonBitmap 900 901 Creates a rawimage description for a carbonbitmap 902 ------------------------------------------------------------------------------} 903function TCarbonWidgetSet.RawImage_FromCarbonBitmap(out ARawImage: TRawImage; ABitmap, AMask: TCarbonBitmap; ARect: PRect = nil): Boolean; 904var Width, Height: Integer; 905 R: TRect; 906 WorkData: PByte = nil; 907 MaskData: PByte = nil; 908 MaskDataSize, WorkDataSize: PtrUInt; 909 Ptr: PByte; 910 911 function CreateSub(ARect: TRect; ABmp: TCarbonBitMap; BitsPerPixel: Integer; var ImageDataSize: PtrUInt): PByte; 912 var FullImageData, BytePtr: PByte; 913 SubImageBytesPerRow, DataSize: PtrUInt; 914 ShiftBits, RowCnt, RowByteCnt: Integer; 915 begin 916 917 SubImageBytesPerRow := (((ARect.Right - ARect.Left) * BitsPerPixel) + 7) div 8; 918 if (BitsPerPixel > 1) then 919 SubImageBytesPerRow := ((((Arect.Right - ARect.Left) * (BitsPerPixel div 8)) + $F) and not PtrUInt($F)); 920 DataSize := SubImageBytesPerRow {%H-}* (ARect.Bottom - ARect.Top); 921 Result := System.GetMem(DataSize); 922 if (Result = nil) then RaiseMemoryAllocationError; 923 924 BytePtr := Result; 925 ShiftBits := (ARect.Left * BitsPerPixel) mod 8; 926 FullImageData := ABmp.Data + ((ARect.Left * BitsPerPixel) div 8); 927 928 For RowCnt := 0 to ((ARect.Bottom - ARect.Top) - 1) do begin 929 For RowByteCnt := 0 to (SubImageBytesPerRow - 1) do begin 930 BytePtr^ := (Byte((PByte(FullImageData + RowByteCnt)^ Shl ShiftBits)) or 931 (PByte(FullImageData + RowByteCnt + 1)^ Shr (8 - ShiftBits))); 932 Inc(BytePtr); 933 end; 934 Inc(FullImageData, ABmp.BytesPerRow); 935 end; 936 ImageDataSize := DataSize; 937 end; 938 939begin 940 Result := False; 941 942 FillChar(ARawImage{%H-}, SizeOf(ARawImage), 0); 943 ARawImage.Init; 944 RawImage_DescriptionFromCarbonBitmap(ARawImage.Description, ABitmap); 945 946 if ARect = nil 947 then begin 948 Width := ABitmap.Width; 949 Height := ABitmap.Height; 950 end 951 else begin 952 R := ARect^; 953 Width := R.Right - R.Left; 954 Height := R.Bottom - R.Top; 955 end; 956 957 if Width > ABitmap.Width then 958 Width := ABitmap.Width; 959 960 if Height > ABitmap.Height then 961 Height := ABitmap.Height; 962 963 if (Width = ABitmap.Width) and (Height = ABitmap.Height) 964 then begin 965 WorkData := ABitmap.Data; 966 WorkDataSize := ABitmap.DataSize; 967 if AMask <> nil then begin 968 MaskData := AMask.Data; 969 MaskDataSize := AMask.DataSize; 970 end; 971 end 972 else begin 973 // TODO: fix CreateSub which is broken at least for one pixel (@ 32bpp) 974 // In the mean time, here is a shortcut which should be also 975 // faster than CreateSub. 976 // Only tested with bitmaps at 32 bits per pixel. See bug #23112 977 if (Width=1) and (Height=1) and (AMask=nil) then 978 begin 979 WorkDataSize := (ARawImage.Description.BitsPerPixel + 7) div 8; 980 WorkData := System.GetMem(WorkDataSize); 981 Ptr := ABitmap.Data; 982 inc(Ptr, ARawImage.Description.BytesPerLine * R.Top); 983 Inc(Ptr, WorkDataSize * R.Left); 984 System.Move(Ptr^, WorkData^, WorkDataSize); 985 end 986 else begin 987 WorkData := CreateSub(R, ABitmap, ARawImage.Description.BitsPerPixel, WorkDataSize); 988 if AMask <> nil then 989 MaskData := CreateSub(R, AMask, 1, MaskDataSize); 990 end; 991 end; 992 993 ARawImage.Description.Width := Width; 994 ARawImage.Description.Height := Height; 995 996 ARawImage.DataSize := WorkDataSize; 997 ReAllocMem(ARawImage.Data, ARawImage.DataSize); 998 if ARawImage.DataSize > 0 then 999 System.Move(WorkData^, ARawImage.Data^, ARawImage.DataSize); 1000 1001 if (WorkData <> ABitmap.Data) then 1002 FreeMem(WorkData); 1003 1004 Result := True; 1005 1006 if AMask = nil then 1007 begin 1008 ARawImage.Description.MaskBitsPerPixel := 0; 1009 Exit; 1010 end; 1011 1012 if AMask.Depth > 1 1013 then begin 1014 DebugLn('[WARNING] RawImage_FromCarbonBitmap: AMask.Depth > 1'); 1015 Exit; 1016 end; 1017 1018 ARawImage.Description.MaskBitsPerPixel := 1; 1019 ARawImage.Description.MaskShift := 0; 1020 ARawImage.Description.MaskLineEnd := rileByteBoundary; 1021 ARawImage.Description.MaskBitOrder := riboReversedBits; 1022 1023 ARawImage.MaskSize := MaskDataSize; 1024 ReAllocMem(ARawImage.Mask, ARawImage.MaskSize); 1025 if ARawImage.MaskSize > 0 then 1026 System.Move(MaskData^, ARawImage.Mask^, ARawImage.MaskSize); 1027 1028 if (MaskData <> AMask.Data) then 1029 FreeMem(MaskData); 1030 1031end; 1032 1033function TCarbonWidgetSet.RawImage_DescriptionToBitmapType( 1034 ADesc: TRawImageDescription; 1035 out bmpType: TCarbonBitmapType): Boolean; 1036begin 1037 Result := False; 1038 1039 if ADesc.Format = ricfGray 1040 then 1041 begin 1042 if ADesc.Depth = 1 then bmpType := cbtMono 1043 else bmpType := cbtGray; 1044 end 1045 else if ADesc.Depth = 1 1046 then bmpType := cbtMono 1047 else if ADesc.AlphaPrec <> 0 1048 then begin 1049 if ADesc.ByteOrder = riboMSBFirst 1050 then begin 1051 if (ADesc.AlphaShift = 24) 1052 and (ADesc.RedShift = 16) 1053 and (ADesc.GreenShift = 8 ) 1054 and (ADesc.BlueShift = 0 ) 1055 then bmpType := cbtARGB 1056 else 1057 if (ADesc.AlphaShift = 0) 1058 and (ADesc.RedShift = 24) 1059 and (ADesc.GreenShift = 16 ) 1060 and (ADesc.BlueShift = 8 ) 1061 then bmpType := cbtRGBA 1062 else 1063 if (ADesc.AlphaShift = 0 ) 1064 and (ADesc.RedShift = 8 ) 1065 and (ADesc.GreenShift = 16) 1066 and (ADesc.BlueShift = 24) 1067 then bmpType := cbtBGRA 1068 else Exit; 1069 end 1070 else begin 1071 if (ADesc.AlphaShift = 24) 1072 and (ADesc.RedShift = 16) 1073 and (ADesc.GreenShift = 8 ) 1074 and (ADesc.BlueShift = 0 ) 1075 then bmpType := cbtBGRA 1076 else 1077 if (ADesc.AlphaShift = 0 ) 1078 and (ADesc.RedShift = 8 ) 1079 and (ADesc.GreenShift = 16) 1080 and (ADesc.BlueShift = 24) 1081 then bmpType := cbtARGB 1082 else 1083 if (ADesc.AlphaShift = 24 ) 1084 and (ADesc.RedShift = 0 ) 1085 and (ADesc.GreenShift = 8) 1086 and (ADesc.BlueShift = 16) 1087 then bmpType := cbtRGBA 1088 else Exit; 1089 end; 1090 end 1091 else begin 1092 bmpType := cbtRGB; 1093 end; 1094 1095 Result := True; 1096end; 1097 1098{------------------------------------------------------------------------------ 1099 Method: TCarbonWidgetSet.GetImagePixelData 1100 1101 Used by RawImage_FromDevice. Copies the data from a CGImageRef into a local 1102 buffer. 1103 1104 The buffer is created using GetMem, and the caller is responsible for using 1105 FreeMem to free the returned pointer. 1106 1107 This function throws exceptions in case of errors and may return a nil pointer. 1108 ------------------------------------------------------------------------------} 1109function TCarbonWidgetSet.GetImagePixelData(AImage: CGImageRef; out bitmapByteCount: PtrUInt): Pointer; 1110var 1111 bitmapData: Pointer; 1112 context: CGContextRef = nil; 1113 colorSpace: CGColorSpaceRef; 1114 bitmapBytesPerRow, pixelsWide, pixelsHigh: PtrUInt; 1115 imageRect: CGRect; 1116begin 1117 Result := nil; 1118 1119 // Get image width, height. The entire image is used. 1120 pixelsWide := CGImageGetWidth(AImage); 1121 pixelsHigh := CGImageGetHeight(AImage); 1122 imageRect.origin.x := 0.0; 1123 imageRect.origin.y := 0.0; 1124 imageRect.size.width := pixelsWide; 1125 imageRect.size.height := pixelsHigh; 1126 1127 // The target format is fixed in ARGB, DQWord alignment, with 32-bits depth and 1128 // 8-bits per channel, the default image format on the LCL 1129 bitmapBytesPerRow := ((pixelsWide * 4) + $F) and not PtrUInt($F); 1130 bitmapByteCount := (bitmapBytesPerRow * pixelsHigh); 1131 1132 // Use the generic RGB color space. 1133 colorSpace := CGColorSpaceCreateWithName(kCGColorSpaceGenericRGB); 1134 if (colorSpace = nil) then RaiseColorSpaceError; 1135 1136 // Allocate memory for image data. This is the destination in memory 1137 // where any drawing to the bitmap context will be rendered. 1138 bitmapData := System.GetMem( bitmapByteCount ); 1139 if (bitmapData = nil) then RaiseMemoryAllocationError; 1140 1141 { Creates the bitmap context. 1142 1143 Regardless of what the source image format is, it will be converted 1144 over to the format specified here by CGBitmapContextCreate. } 1145 context := CGBitmapContextCreate(bitmapData, 1146 pixelsWide, 1147 pixelsHigh, 1148 8, // bits per component 1149 bitmapBytesPerRow, 1150 colorSpace, 1151 kCGImageAlphaNoneSkipFirst); // The function fails with kCGImageAlphaFirst 1152 if (context = nil) then 1153 begin 1154 System.FreeMem(bitmapData); 1155 RaiseContextCreationError; 1156 end; 1157 1158 // Draw the image to the bitmap context. Once we draw, the memory 1159 // allocated for the context for rendering will then contain the 1160 // raw image data in the specified color space. 1161 CGContextDrawImage(context, imageRect, AImage); 1162 1163 // Now we can get a pointer to the image data associated with the context. 1164 // ToDo: Verify if we should copy this data to a new buffer 1165 Result := CGBitmapContextGetData(context); 1166 1167 { Clean-up } 1168 CGColorSpaceRelease(colorSpace); 1169 CGContextRelease(context); 1170end; 1171 1172{------------------------------------------------------------------------------ 1173 Method: TCarbonWidgetSet.CreateThemeServices 1174 Returns: Theme Services object for Carbon interface 1175 ------------------------------------------------------------------------------} 1176function TCarbonWidgetSet.CreateThemeServices: TThemeServices; 1177begin 1178 Result := TCarbonThemeServices.Create; 1179end; 1180 1181{------------------------------------------------------------------------------ 1182 Method: TCarbonWidgetSet.PassCmdLineOptions 1183 1184 Not used 1185 ------------------------------------------------------------------------------} 1186procedure TCarbonWidgetSet.PassCmdLineOptions; 1187begin 1188 inherited PassCmdLineOptions; 1189end; 1190 1191{------------------------------------------------------------------------------ 1192 Method: TCarbonWidgetSet.SendCheckSynchronizeMessage 1193 ------------------------------------------------------------------------------} 1194procedure TCarbonWidgetSet.SendCheckSynchronizeMessage; 1195var 1196 EventSpec: EventTypeSpec; 1197 DummyEvent: EventRef; 1198begin 1199 if FMainEventQueue=nil then 1200 begin 1201 //DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage FMainEventQueue=nil'); 1202 exit; 1203 end; 1204 1205 {$IFDEF VerboseObject} 1206 DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage START'); 1207 {$ENDIF} 1208 1209 EventSpec := MakeEventSpec(LCLCarbonEventClass,LCLCarbonEventKindWake); 1210 DummyEvent:=nil; 1211 try 1212 if CreateEvent(nil, EventSpec.eventClass, EventSpec.eventKind, 1213 0{GetCurrentEventTime}, kEventAttributeNone, DummyEvent) <> noErr then 1214 begin 1215 {$IFDEF VerboseObject} 1216 DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage Create event FAILED'); 1217 {$ENDIF} 1218 Exit; 1219 end; 1220 1221 {$IFDEF VerboseObject} 1222 DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage GetMainEventQueue='+dbgs(GetMainEventQueue)); 1223 {$ENDIF} 1224 1225 if PostEventToQueue(FMainEventQueue, DummyEvent, 1226 kEventPriorityHigh) <> noErr then 1227 begin 1228 {$IFDEF VerboseObject} 1229 DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage Post event FAILED'); 1230 {$ENDIF} 1231 Exit; 1232 end; 1233 finally 1234 if DummyEvent <> nil then ReleaseEvent(DummyEvent); 1235 end; 1236 1237 {$IFDEF VerboseObject} 1238 DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage END'); 1239 {$ENDIF} 1240end; 1241 1242{------------------------------------------------------------------------------ 1243 Method: TCarbonWidgetSet.OnWakeMainThread 1244 Params: Sender 1245 ------------------------------------------------------------------------------} 1246procedure TCarbonWidgetSet.OnWakeMainThread(Sender: TObject); 1247begin 1248 // the code below would start waiting on the first app event to arrive. 1249 // however, if fAppLoop has not been initialized and we're in the main thread 1250 // we shouldn't wait for it, since signal is given from the main thread. 1251 if (GetThreadID=MainThreadID) and (not Assigned(fAppLoop)) then Exit; 1252 1253 // wait infinite for the first (dummy) event sent to the main event queue 1254 WaitFirstAppEvent; 1255 SendCheckSynchronizeMessage; 1256end; 1257 1258{------------------------------------------------------------------------------ 1259 Method: TCarbonWidgetSet.RegisterEvents 1260 Registers events for Carbon application 1261 ------------------------------------------------------------------------------} 1262procedure TCarbonWidgetSet.RegisterEvents; 1263var 1264 TmpSpec: EventTypeSpec; 1265const 1266 SName = 'RegisterEvents'; 1267begin 1268 //DebugLn('TCarbonWidgetSet.RegisterEvents'); 1269 TmpSpec := MakeEventSpec(kEventClassCommand, kEventCommandProcess); 1270 InstallApplicationEventHandler(RegisterEventHandler(@CarbonApp_CommandProcess), 1271 1, @TmpSpec, nil, @FAEventHandlerRef[0]); 1272 1273 TmpSpec := MakeEventSpec(kEventClassApplication, kEventAppShown); 1274 InstallApplicationEventHandler(RegisterEventHandler(@CarbonApp_Shown), 1275 1, @TmpSpec, nil, @FAEventHandlerRef[1]); 1276 1277 TmpSpec := MakeEventSpec(kEventClassApplication, kEventAppHidden); 1278 InstallApplicationEventHandler(RegisterEventHandler(@CarbonApp_Hidden), 1279 1, @TmpSpec, nil, @FAEventHandlerRef[2]); 1280 1281 TmpSpec := MakeEventSpec(kEventClassApplication, kEventAppDeactivated); 1282 InstallApplicationEventHandler(RegisterEventHandler(@CarbonApp_Deactivated), 1283 1, @TmpSpec, nil, @FAEventHandlerRef[3]); 1284 1285 TmpSpec := MakeEventSpec(kEventClassApplication, kEventAppActivated); 1286 InstallApplicationEventHandler(RegisterEventHandler(@CarbonApp_Activated), 1287 1, @TmpSpec, nil, @FAEventHandlerRef[4]); 1288 1289 TmpSpec := MakeEventSpec(LCLCarbonEventClass, LCLCarbonEventKindWake); 1290 InstallApplicationEventHandler(RegisterEventHandler(@CarbonApp_LazWake), 1291 1, @TmpSpec, nil, @FAEventHandlerRef[5]); 1292 1293 InstallReceiveHandler(@CarbonApp_DragReceive, nil, nil); 1294 1295 FOpenEventHandlerUPP := NewAEEventHandlerUPP(AEEventHandlerProcPtr(@CarbonApp_Open)); 1296 FQuitEventHandlerUPP := NewAEEventHandlerUPP(AEEventHandlerProcPtr(@CarbonApp_Quit)); 1297 OSError( 1298 AEInstallEventHandler(kCoreEventClass, kAEOpenDocuments, FOpenEventHandlerUPP, 0, False), 1299 Self, SName, 'AEInstallEventHandler'); 1300 OSError( 1301 AEInstallEventHandler(kCoreEventClass, kAEOpenContents, FOpenEventHandlerUPP, 0, False), 1302 Self, SName, 'AEInstallEventHandler'); 1303 OSError( 1304 AEInstallEventHandler(kCoreEventClass, kAEQuitApplication, FQuitEventHandlerUPP, 0, False), 1305 Self, SName, 'AEInstallEventHandler'); 1306end; 1307 1308 1309{------------------------------------------------------------------------------ 1310 Method: TCarbonWidgetSet.AppTerminate 1311 1312 Tells Carbon to halt the application 1313 ------------------------------------------------------------------------------} 1314procedure TCarbonWidgetSet.AppTerminate; 1315var i:integer; 1316const 1317 SName = 'AppTerminate'; 1318begin 1319 if FTerminating then Exit; 1320 {$IFDEF VerboseObject} 1321 DebugLn('TCarbonWidgetSet.AppTerminate'); 1322 {$ENDIF} 1323 FUserTerm:=True; 1324 QuitApplicationEventLoop; 1325 for i:=Low(FAEventHandlerRef) to High(FAEventHandlerRef) do 1326 OSError(MacOSALL.RemoveEventHandler(FAEventHandlerRef[i]), 1327 TClass(Self), SName, 'RemoveEventHandler'); 1328end; 1329 1330{------------------------------------------------------------------------------ 1331 Method: TCarbonWidgetSet.AppMinimize 1332 1333 Minimizes the whole application to the taskbar 1334 ------------------------------------------------------------------------------} 1335procedure TCarbonWidgetSet.AppMinimize; 1336var 1337 Proc: ProcessSerialNumber; 1338const 1339 SName = 'AppMinimize'; 1340begin 1341 {$IFDEF VerboseObject} 1342 DebugLn('TCarbonWidgetSet.AppMinimize'); 1343 {$ENDIF} 1344 1345 // hide process 1346 if OSError(GetCurrentProcess(Proc{%H-}), Self, SName, SGetCurrentProc) then Exit; 1347 OSError(ShowHideProcess(Proc, False), Self, SName, SShowHideProc); 1348end; 1349 1350{------------------------------------------------------------------------------ 1351 Method: TCarbonWidgetSet.AppRestore 1352 1353 Restores the whole minimized application from the taskbar 1354 ------------------------------------------------------------------------------} 1355procedure TCarbonWidgetSet.AppRestore; 1356var 1357 Proc: ProcessSerialNumber; 1358const 1359 SName = 'AppRestore'; 1360begin 1361 {$IFDEF VerboseObject} 1362 DebugLn('TCarbonWidgetSet.AppRestore'); 1363 {$ENDIF} 1364 1365 // show process 1366 if OSError(GetCurrentProcess(Proc{%H-}), Self, SName, SGetCurrentProc) then Exit; 1367 OSError(ShowHideProcess(Proc, True), Self, SName, SShowHideProc); 1368end; 1369 1370{------------------------------------------------------------------------------ 1371 Method: TCarbonWidgetSet.AppBringToFront 1372 1373 Brings the entire application on top of all other non-topmost programs 1374 ------------------------------------------------------------------------------} 1375procedure TCarbonWidgetSet.AppBringToFront; 1376var 1377 Proc: ProcessSerialNumber; 1378const SName = 'AppBringToFront'; 1379begin 1380 {$IFDEF VerboseObject} 1381 DebugLn('TCarbonWidgetSet.AppBringToFront'); 1382 {$ENDIF} 1383 1384 (* 1385 According to Carbon Development Tips & Tricks: 1386 34. How do I bring all my windows to the front? 1387 *) 1388 1389 if OSError(GetCurrentProcess(Proc{%H-}), Self, SName, SGetCurrentProc) then Exit; 1390 OSError(SetFrontProcess(Proc), Self, SName, 'SetFrontProcess'); 1391end; 1392 1393procedure TCarbonWidgetSet.AppSetIcon(const Small, Big: HICON); 1394begin 1395 if Big <> 0 then 1396 SetApplicationDockTileImage(TCarbonBitmap(Big).CGImage) 1397 else 1398 RestoreApplicationDockTileImage; 1399end; 1400 1401{------------------------------------------------------------------------------ 1402 Method: TCarbonWidgetSet.AppSetTitle 1403 Params: ATitle - New application title 1404 1405 Changes the application title 1406 ------------------------------------------------------------------------------} 1407procedure TCarbonWidgetSet.AppSetTitle(const ATitle: string); 1408begin 1409 // not supported 1410end; 1411 1412function TCarbonWidgetSet.GetLCLCapability(ACapability: TLCLCapability): PtrUInt; 1413begin 1414 case ACapability of 1415 lcCanDrawOutsideOnPaint, 1416 lcNeedMininimizeAppWithMainForm, 1417 lcApplicationTitle, 1418 lcFormIcon, 1419 lcReceivesLMClearCutCopyPasteReliably: 1420 Result := LCL_CAPABILITY_NO; 1421 lcAntialiasingEnabledByDefault: 1422 Result := LCL_CAPABILITY_YES; 1423 lcAccessibilitySupport: Result := LCL_CAPABILITY_YES; 1424 lcTransparentWindow: Result := LCL_CAPABILITY_YES; 1425 else 1426 Result := inherited; 1427 end; 1428end; 1429 1430{------------------------------------------------------------------------------ 1431 Method: TCarbonWidgetSet.LCLPlatform 1432 Returns: lpCarbon - enum value for Carbon widgetset 1433 ------------------------------------------------------------------------------} 1434function TCarbonWidgetSet.LCLPlatform: TLCLPlatform; 1435begin 1436 Result:= lpCarbon; 1437end; 1438 1439{------------------------------------------------------------------------------ 1440 Method: TCarbonWidgetSet.DCGetPixel 1441 Params: CanvasHandle - Canvas handle to get color from 1442 X, Y - Position 1443 Returns: Color of the specified pixel on the canvas 1444 ------------------------------------------------------------------------------} 1445function TCarbonWidgetSet.DCGetPixel(CanvasHandle: HDC; X, Y: integer 1446 ): TGraphicsColor; 1447begin 1448 Result := clNone; 1449 1450 {$IFDEF VerboseObject} 1451 DebugLn('TCarbonWidgetSet.DCGetPixel DC: ' + DbgS(CanvasHandle) + ' X: ' + DbgS(X) + ' Y: ' + DbgS(Y)); 1452 {$ENDIF} 1453 1454 if not CheckDC(CanvasHandle, 'DCGetPixel') then Exit; 1455 1456 Result := TCarbonDeviceContext(CanvasHandle).GetPixel(X, Y); 1457end; 1458 1459{------------------------------------------------------------------------------ 1460 Method: TCarbonWidgetSet.DCSetPixel 1461 Params: CanvasHandle - Canvas handle to get color from 1462 X, Y - Position 1463 AColor - New color for specified position 1464 1465 Sets the color of the specified pixel on the canvas 1466 ------------------------------------------------------------------------------} 1467procedure TCarbonWidgetSet.DCSetPixel(CanvasHandle: HDC; X, Y: integer; 1468 AColor: TGraphicsColor); 1469begin 1470 {$IFDEF VerboseObject} 1471 DebugLn('TCarbonWidgetSet.DCSetPixel DC: ' + DbgS(CanvasHandle) + ' X: ' + DbgS(X) + ' Y: ' + DbgS(Y) + 'Color: ' + DbgS(AColor)); 1472 {$ENDIF} 1473 1474 if not CheckDC(CanvasHandle, 'DCSetPixel') then Exit; 1475 1476 TCarbonDeviceContext(CanvasHandle).SetPixel(X, Y, AColor); 1477end; 1478 1479{------------------------------------------------------------------------------ 1480 Method: TCarbonWidgetSet.DCReDraw 1481 Params: CanvasHandle - Canvas handle to redraw 1482 1483 Redraws (the window of) a canvas 1484 ------------------------------------------------------------------------------} 1485procedure TCarbonWidgetSet.DCRedraw(CanvasHandle: HDC); 1486begin 1487 {$IFDEF VerboseObject} 1488 DebugLn('TCarbonWidgetSet.DCRedraw DC: ' + DbgS(CanvasHandle)); 1489 {$ENDIF} 1490 1491 if not CheckDC(CanvasHandle, 'DCRedraw') then Exit; 1492 1493 CGContextFlush(TCarbonContext(CanvasHandle).CGContext); 1494end; 1495 1496procedure TCarbonWidgetSet.DCSetAntialiasing(CanvasHandle: HDC; 1497 AEnabled: Boolean); 1498begin 1499 if not CheckDC(CanvasHandle, 'DCSetAntialiasing') then Exit; 1500 1501 TCarbonDeviceContext(CanvasHandle).SetAntialiasing(AEnabled); 1502end; 1503 1504{------------------------------------------------------------------------------ 1505 Method: TCarbonWidgetSet.SetDesigning 1506 Params: AComponent - Component to set designing 1507 1508 Not implemented! 1509 ------------------------------------------------------------------------------} 1510procedure TCarbonWidgetSet.SetDesigning(AComponent: TComponent); 1511begin 1512 1513end; 1514 1515{------------------------------------------------------------------------------ 1516 Method: TCarbonWidgetSet.IsHelpKey 1517 Params: Key - 1518 Shift - 1519 Returns: If the specified key is determined to show help in Carbon 1520 ------------------------------------------------------------------------------} 1521function TCarbonWidgetSet.IsHelpKey(Key: Word; Shift: TShiftState): Boolean; 1522begin 1523 Result := False; // help key is Cmd + ?, will be called directly on key press 1524end; 1525 1526{------------------------------------------------------------------------------ 1527 Method: TimerCallback 1528 Params: inTimer - Timer reference 1529 inUserData - User data passed when installing timer 1530 1531 Calls the timer function associated with specified timer 1532 ------------------------------------------------------------------------------} 1533procedure TimerCallback(inTimer: EventLoopTimerRef; {%H-}inUserData: UnivPtr); 1534var 1535 TimerFunc: TWSTimerProc; 1536begin 1537 {$IFDEF VerboseTimer} 1538 DebugLn('TimerCallback'); 1539 {$ENDIF} 1540 1541 if CarbonWidgetSet = nil then Exit; 1542 if CarbonWidgetSet.FTimerMap.GetData(inTimer, TimerFunc) then 1543 begin 1544 {$IFDEF VerboseTimer} 1545 DebugLn('TimerCallback Timer insta�led, calling func.'); 1546 {$ENDIF} 1547 1548 TimerFunc; 1549 end; 1550end; 1551 1552{------------------------------------------------------------------------------ 1553 Method: TCarbonWidgetSet.CreateTimer 1554 Params: Interval - New timer interval 1555 TimerFunc - New timer callback 1556 Returns: A Timer id 1557 1558 Creates new timer with specified interval and callback function 1559 ------------------------------------------------------------------------------} 1560function TCarbonWidgetSet.CreateTimer(Interval: integer; TimerFunc: TWSTimerProc): THandle; 1561var 1562 Timer: EventLoopTimerRef; 1563begin 1564 {$IFDEF VerboseTimer} 1565 DebugLn('TCarbonWidgetSet.CreateTimer Interval: ' + DbgS(Interval)); 1566 {$ENDIF} 1567 Result := 0; 1568 1569 if (Interval > 0) and (TimerFunc <> nil) then 1570 begin 1571 if OSError(InstallEventLoopTimer(GetMainEventLoop, 1572 Interval / 1000, Interval / 1000, // converts msec -> sec 1573 EventLoopTimerUPP(@TimerCallback), nil, Timer{%H-}), Self, 1574 'CreateTimer', 'InstallEventLoopTimer') then Exit; 1575 1576 FTimerMap.Add(Timer, TimerFunc); 1577 Result := {%H-}THandle(Timer) 1578 end; 1579 1580 {$IFDEF VerboseTimer} 1581 DebugLn('TCarbonWidgetSet.CreateTimer Result: ' + DbgS(Result)); 1582 {$ENDIF} 1583end; 1584 1585{------------------------------------------------------------------------------ 1586 Method: TCarbonWidgetSet.Destroy 1587 Params: TimerHandle - Timer id to destroy 1588 Returns: If the function succeeds 1589 1590 Destroys specified timer 1591 ------------------------------------------------------------------------------} 1592function TCarbonWidgetSet.DestroyTimer(TimerHandle: THandle): boolean; 1593begin 1594 {$IFDEF VerboseTimer} 1595 DebugLn('TCarbonWidgetSet.DestroyTimer Handle: ' + DbgS(TimerHandle)); 1596 {$ENDIF} 1597 1598 Result := FTimerMap.Delete(TimerHandle); 1599 1600 if Result then // valid timer 1601 OSError(RemoveEventLoopTimer({%H-}EventLoopTimerRef(TimerHandle)), Self, 1602 'DestroyTimer', 'RemoveEventLoopTimer'); 1603end; 1604 1605function TCarbonWidgetSet.PrepareUserEvent(Handle: HWND; Msg: Cardinal; 1606 wParam: WParam; lParam: LParam; out Target: EventTargetRef): EventRef; 1607var 1608 EventSpec: EventTypeSpec; 1609 AMessage: TLMessage; 1610 Widget: TCarbonWidget; 1611begin 1612 Result := nil; 1613 if FMainEventQueue = nil then Exit; 1614 1615 Widget := TCarbonWidget(Handle); 1616 1617 if Widget is TCarbonControl then 1618 Target := GetControlEventTarget(Widget.Widget) 1619 else 1620 if Widget is TCarbonWindow then 1621 Target := GetWindowEventTarget(TCarbonWindow(Widget).Window) 1622 else 1623 Exit; 1624 1625 EventSpec := MakeEventSpec(LCLCarbonEventClass, LCLCarbonEventKindUser); 1626 if CreateEvent(nil, EventSpec.eventClass, EventSpec.eventKind, 1627 0, kEventAttributeUserEvent, Result) <> noErr then 1628 Exit; 1629 1630 AMessage.Msg := Msg; 1631 AMessage.LParam := lParam; 1632 AMessage.WParam := wParam; 1633 AMessage.Result := 0; 1634 SetEventParameter(Result, MakeFourCC('wmsg'), 1635 MakeFourCC('wmsg'), SizeOf(TLMessage), 1636 @AMessage); 1637end; 1638 1639