paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-11-24 22:29:54 +01:00
Code Issues Packages Projects Releases Wiki Activity

Carbon intf:

Browse Source 
- patch #0008537 by Philip J. Hess - Adds basic TOpenDialog, TSaveDialog and TSelectDirectoryDialog
- debug and tracing info, OSError for checking Carbon calls as Philip J. Hess proposed
- started TMainMenu, TPopupMenu, Hints
- TabOrder, TabStop, focusing
- TGraphicControl and TCustomControl descendants improved 

git-svn-id: trunk@10828 -
This commit is contained in:
tombo 2007-03-29 13:50:41 +00:00
parent 4652c75ba9
commit c44f23e18d
23 changed files with 2114 additions and 634 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -2381,10 +2381,8 @@ lcl/interfaces/carbon/carbonlclintf.inc svneol=native#text/plain
lcl/interfaces/carbon/carbonlclintfh.inc svneol=native#text/plain
lcl/interfaces/carbon/carbonobject.inc svneol=native#text/plain
lcl/interfaces/carbon/carbonprivate.pp svneol=native#text/pascal
lcl/interfaces/carbon/carbonprivatecheckbox.inc svneol=native#text/plain
lcl/interfaces/carbon/carbonprivatecommon.inc svneol=native#text/plain
lcl/interfaces/carbon/carbonprivatecontrol.inc svneol=native#text/pascal
lcl/interfaces/carbon/carbonprivatehiview.inc svneol=native#text/pascal
lcl/interfaces/carbon/carbonprivatewindow.inc svneol=native#text/pascal
lcl/interfaces/carbon/carbonproc.pp svneol=native#text/pascal
lcl/interfaces/carbon/carbonstrings.pp svneol=native#text/pascal

16
lcl/interfaces/carbon/carboncanvas.pp
View File

@ -83,7 +83,6 @@ type
public
constructor Create;
destructor Destroy; override;
procedure Reset; override;
function SaveDC: Integer;
@ -91,6 +90,8 @@ type
function BeginTextRender(AStr: PChar; ACount: Integer; out ALayout: ATSUTextLayout): Boolean;
procedure EndTextRender(var ALayout: ATSUTextLayout);
procedure SetAntialiasing(AValue: Boolean);
public
property Size: TPoint read GetSize;
@ -411,7 +412,7 @@ begin
end;
{------------------------------------------------------------------------------
Name: TCarbonDeviceContext.EndTextRender
Method: TCarbonDeviceContext.EndTextRender
Params: ALayout - ATSU layout
Returns: Nothing
@ -426,6 +427,17 @@ begin
if ALayout <> nil then ATSUDisposeTextLayout(ALayout);
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.SetAntialiasing
Params: AValue - If should antialias
Sets whether device context should antialias
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.SetAntialiasing(AValue: Boolean);
begin
CGContextSetShouldAntialias(CGContext, CBool(AValue));
end;
{ TCarbonScreenContext }
function TCarbonScreenContext.GetSize: TPoint;

10
lcl/interfaces/carbon/carbongdiobjects.pp
View File

@ -560,7 +560,10 @@ begin
FDataSize := FBytesPerRow * FHeight;
System.GetMem(FData, FDataSize);
if AData <> nil then System.Move(AData^, FData^, FDataSize); // copy data
if AData <> nil then
System.Move(AData^, FData^, FDataSize) // copy data
else
FillDWord(FData^, FDataSize shr 2, 0); // clear bitmap
//DebugLn(Format('TCarbonBitmap.Create %d x %d Data: %d RowSize: %d Size: %d',
// [AWidth, AHeight, Integer(AData), DataRowSize, FDataSize]));
@ -804,7 +807,10 @@ end;
procedure TCarbonCursor.Install;
begin
DebugLn('TCarbonCursor.Install type: ', IntToStr(Ord(CursorType)));
{$IFDEF VerboseCursor}
DebugLn('TCarbonCursor.Install type: ', DbgS(Ord(CursorType)));
{$ENDIF}
case CursorType of
cctQDHardware:
if FQDHardwareCursorName <> '' then

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

@ -32,6 +32,21 @@ interface
{$ASSERTIONS ON}
{$endif}
// Show debug info when tracing:
{off $DEFINE DebugEventLoop}
{off $DEFINE VerboseObject} // Carbon object
{off $DEFINE VerboseTimer}
{off $DEFINE VerboseWinAPI} // Carbon WinAPI
{off $DEFINE VerboseLCLIntf} // Carbon LCLIntf
{off $DEFINE VerboseMouse}
{off $DEFINE VerboseCursor} // Carbon cursor
{off $DEFINE VerboseKeyboard}
{off $DEFINE VerbosePaint}
{off $DEFINE VerboseWSClass} // Carbon WS class
uses
// rtl+ftl
Types, Classes, SysUtils, Math, FPCAdds,
@ -72,6 +87,7 @@ type
procedure AppRestore; override;
procedure AppBringToFront; override;
function WidgetSetName: string; override;
procedure AttachMenuToWindow(AMenuObject: TComponent); Override;
function DCGetPixel(CanvasHandle: HDC; X, Y: integer): TGraphicsColor; override;
procedure DCSetPixel(CanvasHandle: HDC; X, Y: integer; AColor: TGraphicsColor); override;
@ -123,13 +139,14 @@ uses
// CarbonWSGrids,
// CarbonWSImgList,
// CarbonWSMaskEdit,
// CarbonWSMenus,
CarbonWSMenus,
// CarbonWSPairSplitter,
// CarbonWSSpin,
CarbonWSStdCtrls,
// CarbonWSToolwin,
////////////////////////////////////////////////////
CarbonDef, CarbonPrivate, CarbonProc, CarbonCanvas, CarbonGDIObjects,
CarbonMenus,
Buttons, StdCtrls, PairSplitter, ComCtrls, CListBox, Calendar, Arrow,
Spin, CommCtrl, ExtCtrls, FileCtrl, LResources;

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

@ -30,10 +30,19 @@
//##apiwiz##sps## // Do not remove
{------------------------------------------------------------------------------
Method: CreateStandardCursor
Params: ACursor - Cursor type
Returns: Cursor object in Carbon for the specified cursor type
------------------------------------------------------------------------------}
function TCarbonWidgetSet.CreateStandardCursor(ACursor: SmallInt): hCursor;
var
AThemeCursor: ThemeCursor;
begin
{$IFDEF VerboseLCLIntf}
DebugLn('TCarbonWidgetSet.CreateStandardCursor ACursor: ' + DbgS(ACursor));
{$ENDIF}
Result := 0;
if (ACursor >= crLow) and (ACursor <= crHigh) then
begin
@ -41,6 +50,10 @@ begin
if AThemeCursor <> kThemeUndefCursor then
Result := hCursor(TCarbonCursor.CreateThemed(AThemeCursor));
end;
{$IFDEF VerboseLCLIntf}
DebugLn('TCarbonWidgetSet.CreateStandardCursor Result: ' + DbgS(Result));
{$ENDIF}
end;
function TCarbonWidgetSet.DrawSplitter(DC: HDC; const ARect: TRect;
@ -71,9 +84,25 @@ begin
Result:=inherited GetControlConstraints(Constraints);
end;
{------------------------------------------------------------------------------
Method: GetLCLOwnerObject
Params: Handle - Handle of window
Returns: LCL control which has the specified widget
------------------------------------------------------------------------------}
function TCarbonWidgetSet.GetLCLOwnerObject(Handle: HWnd): TObject;
begin
Result:=inherited GetLCLOwnerObject(Handle);
{$IFDEF VerboseLCLIntf}
DebugLn('TCarbonWidgetSet.GetLCLOwnerObject Handle: ' + DbgS(Handle));
{$ENDIF}
Result := nil;
if not CheckWidget(Handle, 'TCarbonWidgetSet.GetLCLOwnerObject') then Exit;
Result := TCarbonWidget(Handle).LCLObject;
{$IFDEF VerboseLCLIntf}
DebugLn('TCarbonWidgetSet.GetLCLOwnerObject Result: ' + DbgS(Result));
{$ENDIF}
end;
function TCarbonWidgetSet.GetListBoxIndexAtY(ListBox: TComponent; y: integer
@ -93,6 +122,20 @@ begin
Result:=true;
end;
{------------------------------------------------------------------------------
Method: PromptUser
Params: DialogCaption - Dialog caption
DialogMessage - Dialog message text
DialogType - Type of dialog
Buttons - Pointer to button types
ButtonCount - Count of passed buttons
DefaultIndex - Index of default button
EscapeResult - Result value of escape
Returns: The result value of pushed button
Shows modal dialog with the specified caption, message and buttons and prompts
user to push one.
------------------------------------------------------------------------------}
function TCarbonWidgetSet.PromptUser(const DialogCaption : string;
const DialogMessage : string;
DialogType : LongInt;
@ -129,7 +172,7 @@ const
CancelKey = 'Cancel';
YesKey = 'Yes';
NoKey = 'No';
{Note: Not using Pointer(kAlertDefaultOKText) or Pointer(kAlertDefaultCancelText)
{ Note: Not using Pointer(kAlertDefaultOKText) or Pointer(kAlertDefaultCancelText)
since this just passes in -1, which tells button to use its normal text and
we need to override with Yes and No. If Localizable.strings file is in app
bundle's .lproj folder, will use localized strings for above keys if they
@ -150,12 +193,35 @@ var
AlertBtnIdx : DialogItemIndex;
begin
{$IFDEF VerboseLCLIntf}
DebugLn('TCarbonWidgetSet.PromptUser DialogCaption: ' + DialogCaption +
' DialogMessage: ' + DialogMessage + ' DialogType: ' + DbgS(DialogType) +
' ButtonCount: ' + DbgS(ButtonCount) + ' DefaultIndex: ' +
DbgS(DefaultIndex) + ' EscapeResult: ' + DbgS(EscapeResult));
{$ENDIF}
Result := -1;
if (ButtonCount > 4) or ((ButtonCount = 4) and not HasButton(idButtonHelp)) then
begin
// if the button count is bigger than 3 + help button we can not use
// native alert
{$IFDEF VerboseLCLIntf}
DebugLn('TCarbonWidgetSet.PromptUser Use LCL standard one.');
{$ENDIF}
Result := inherited;
{$IFDEF VerboseLCLIntf}
DebugLn('TCarbonWidgetSet.PromptUser LCL Result: ' + DbgS(Result));
{$ENDIF}
end;
{Initialize record}
ParamRec.version := kStdCFStringAlertVersionOne;
ParamRec.movable := True;
ParamRec.helpButton := False;
ParamRec.helpButton := HasButton(idButtonHelp);
ParamRec.defaultText := nil;
ParamRec.cancelText := nil;
ParamRec.otherText := nil;
@ -228,7 +294,6 @@ begin
end;
try
DebugLn('TCarbonWidgetSet.PromptUser: CreateStandardAlert');
CreateStandardAlert(AlertCode, CaptionStr, MessageStr, @ParamRec, AlertRef);
RunStandardAlert(AlertRef, nil, AlertBtnIdx);
@ -250,6 +315,10 @@ begin
FreeCFString(CaptionStr);
FreeCFString(MessageStr);
end;
{$IFDEF VerboseLCLIntf}
DebugLn('TCarbonWidgetSet.PromptUser Result: ' + DbgS(Result));
{$ENDIF}
end; {TCarbonWidgetSet.PromptUser}
function TCarbonWidgetSet.ReplaceBitmapMask(var Image, Mask: HBitmap;

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

@ -60,8 +60,11 @@ function QuitEventHandler(inHandlerCallRef: EventHandlerCallRef;
begin
Result := CallNextEventHandler(inHandlerCallRef, inEvent);
if Result <> noErr then Exit;
if (Widgetset <> nil) and TCarbonWidgetSet(Widgetset).FTerminating then Exit;
TCarbonWidgetSet(Widgetset).FTerminating := True;
if Application = nil then Exit;
Application.Terminate;
end;
@ -163,6 +166,10 @@ procedure TCarbonWidgetSet.AppInit(var ScreenInfo: TScreenInfo);
var
ScreenDC: HDC;
begin
{$IFDEF VerboseObject}
DebugLn('TCarbonWidgetSet.AppInit');
{$ENDIF}
WakeMainThread := @OnWakeMainThread;
// fill the screen info
@ -194,6 +201,10 @@ var
EventSpec: EventTypeSpec;
CurMainEventQueue: EventQueueRef;
begin
{$IFDEF VerboseObject}
DebugLn('TCarbonWidgetSet.AppRun');
{$ENDIF}
DummyEvent := nil;
// Create a UPP for EventLoopEventHandler and QuitEventHandler
@ -259,6 +270,10 @@ begin
finally
DisposeEventHandlerUPP(EventLoopUPP);
end;
{$IFDEF VerboseObject}
DebugLn('TCarbonWidgetSet.AppRun END');
{$ENDIF}
end;
{------------------------------------------------------------------------------
@ -275,17 +290,24 @@ var
CurEventClass: TEventInt;
CurEventKind: TEventInt;
begin
{$IFDEF VerboseObject}
DebugLn('TCarbonWidgetSet.AppProcessMessages');
{$ENDIF}
Target := GetEventDispatcherTarget;
CurEventClass.Chars[4] := #0;
CurEventKind.Chars[4] := #0;
repeat
if ReceiveNextEvent(0, nil, kEventDurationNoWait, True, Event) <> noErr then
Break;
if ReceiveNextEvent(0, nil, kEventDurationNoWait, True,
Event) <> noErr then Break;
CurEventClass.Int := GetEventClass(Event);
CurEventKind.Int := GetEventKind(Event);
{$IFDEF DebugEventLoop}
DebugLn('EventClass: "',CurEventClass.Chars,'" EventKind: ',IntToStr(CurEventKind.Int));
{$ENDIF}
if CurEventClass.Chars=LCLCarbonEventClass then begin
// internal carbon intf message
if (CurEventKind.Chars=LCLCarbonEventKindWake) and IsMultiThread then
@ -297,7 +319,12 @@ begin
SendEventToEventTarget(Event, Target);
ReleaseEvent(Event);
until Application.Terminated;
{$IFDEF VerboseObject}
DebugLn('TCarbonWidgetSet.AppProcessMessages END');
{$ENDIF}
end;
{------------------------------------------------------------------------------
@ -311,9 +338,14 @@ procedure TCarbonWidgetSet.AppWaitMessage;
var
Event: EventRef;
begin
{$IFDEF VerboseObject}
DebugLn('TCarbonWidgetSet.AppWaitMessage');
{$ENDIF}
// Simply wait forever for the next event.
// Don't pull it, so we can handle it later.
ReceiveNextEvent(0, nil, kEventDurationForever, False, Event);
OsError(ReceiveNextEvent(0, nil, kEventDurationForever, False, Event),
Self, 'AppWaitMessage', 'ReceiveNextEvent');
end;
{------------------------------------------------------------------------------
@ -365,30 +397,43 @@ var
begin
if fMainEventQueue=nil then exit;
//DebuglnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage ');
{$IFDEF VerboseObject}
DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage ');
{$ENDIF}
EventSpec := MakeEventSpec(LCLCarbonEventClass,LCLCarbonEventKindWake);
DummyEvent:=nil;
try
if CreateEvent(nil, EventSpec.eventClass, EventSpec.eventKind,
0{GetCurrentEventTime}, kEventAttributeNone,
DummyEvent) <> noErr
then begin
//DebuglnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage create event FAILED');
exit;
0{GetCurrentEventTime}, kEventAttributeNone, DummyEvent) <> noErr then
begin
{$IFDEF VerboseObject}
DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage Create event FAILED');
{$ENDIF}
Exit;
end;
//DebuglnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage GetMainEventQueue='+dbgs(GetMainEventQueue));
{$IFDEF VerboseObject}
DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage GetMainEventQueue='+dbgs(GetMainEventQueue));
{$ENDIF}
if PostEventToQueue(fMainEventQueue, DummyEvent,
kEventPriorityHigh) <> noErr
then begin
//DebuglnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage post event FAILED');
exit;
kEventPriorityHigh) <> noErr then
begin
{$IFDEF VerboseObject}
DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage Post event FAILED');
{$ENDIF}
Exit;
end;
finally
if DummyEvent<>nil then
ReleaseEvent(DummyEvent);
if DummyEvent <> nil then ReleaseEvent(DummyEvent);
end;
//DebuglnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage END');
{$IFDEF VerboseObject}
DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage END');
{$ENDIF}
end;
{------------------------------------------------------------------------------
@ -411,6 +456,10 @@ end;
procedure TCarbonWidgetSet.AppTerminate;
begin
if FTerminating then Exit;
{$IFDEF VerboseObject}
DebugLn('TCarbonWidgetSet.AppTerminate');
{$ENDIF}
QuitApplicationEventLoop;
end;
@ -423,7 +472,11 @@ end;
------------------------------------------------------------------------------}
procedure TCarbonWidgetSet.AppMinimize;
begin
CollapseAllWindows(True);
{$IFDEF VerboseObject}
DebugLn('TCarbonWidgetSet.AppMinimize');
{$ENDIF}
OSError(CollapseAllWindows(True), Self, 'AppMinimize', 'CollapseAllWindows');
end;
{------------------------------------------------------------------------------
@ -435,7 +488,11 @@ end;
------------------------------------------------------------------------------}
procedure TCarbonWidgetSet.AppRestore;
begin
CollapseAllWindows(False);
{$IFDEF VerboseObject}
DebugLn('TCarbonWidgetSet.AppRestore');
{$ENDIF}
OSError(CollapseAllWindows(False), Self, 'AppRestore', 'CollapseAllWindows');
end;
{------------------------------------------------------------------------------
@ -448,13 +505,19 @@ end;
procedure TCarbonWidgetSet.AppBringToFront;
var
Proc: ProcessSerialNumber;
const AName = 'AppBringToFront';
begin
{$IFDEF VerboseObject}
DebugLn('TCarbonWidgetSet.AppBringToFront');
{$ENDIF}
(*
According to Carbon Development Tips & Tricks:
34. How do I bring all my windows to the front?
*)
if GetCurrentProcess(Proc) = noErr then SetFrontProcess(Proc);
if OSError(GetCurrentProcess(Proc), Self, AName, 'GetCurrentProcess') then Exit;
OSError(SetFrontProcess(Proc), Self, AName, 'SetFrontProcess');
end;
{------------------------------------------------------------------------------
@ -467,24 +530,51 @@ begin
Result := 'carbon';
end;
{------------------------------------------------------------------------------
Method: TCarbonWidgetSet.AttachMenuToWindow
Params: AMenuObject - Menu
Attaches the menu of window to menu bar
TODO: change menu on activation
------------------------------------------------------------------------------}
procedure TCarbonWidgetSet.AttachMenuToWindow(AMenuObject: TComponent);
begin
{$IFDEF VerboseObject}
DebugLn('TCarbonWidgetSet.AttachMenuToWindow ' + AMenuObject.Name);
{$ENDIF}
if (AMenuObject is TMainMenu) and (TMainMenu(AMenuObject).Handle <> 0) then
begin
if not CheckMenu(TMainMenu(AMenuObject).Handle,
'TCarbonWidgetSet.AttachMenuToWindow') then Exit;
TCarbonMenu(TMainMenu(AMenuObject).Handle).AttachToMenuBar;
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonWidgetSet.DCGetPixel
Params: CanvasHandle - canvas handle to get color from
X, Y - position
Params: CanvasHandle - Canvas handle to get color from
X, Y - Position
Returns: Color of the specified pixel on the canvas
Not implemented!
------------------------------------------------------------------------------}
function TCarbonWidgetSet.DCGetPixel(CanvasHandle: HDC; X, Y: integer
): TGraphicsColor;
begin
{$IFDEF VerboseObject}
DebugLn('TCarbonWidgetSet.DCGetPixel DC: ' + DbgS(CanvasHandle) + ' X: ' + DbgS(X) + ' Y: ' + DbgS(Y));
{$ENDIF}
DebugLn('TCarbonWidgetSet.DCGetPixel TODO');
Result := clNone;
end;
{------------------------------------------------------------------------------
Method: TCarbonWidgetSet.DCSetPixel
Params: CanvasHandle - canvas handle to get color from
X, Y - position
AColor - new color for specified position
Params: CanvasHandle - Canvas handle to get color from
X, Y - Position
AColor - New color for specified position
Returns: Nothing
Sets the color of the specified pixel on the canvas
@ -493,29 +583,34 @@ end;
procedure TCarbonWidgetSet.DCSetPixel(CanvasHandle: HDC; X, Y: integer;
AColor: TGraphicsColor);
begin
{$IFDEF VerboseObject}
DebugLn('TCarbonWidgetSet.DCSetPixel DC: ' + DbgS(CanvasHandle) + ' X: ' + DbgS(X) + ' Y: ' + DbgS(Y) + 'Color: ' + DbgS(AColor));
{$ENDIF}
DebugLn('TCarbonWidgetSet.DCSetPixel TODO');
end;
{------------------------------------------------------------------------------
Method: TCarbonWidgetSet.DCReDraw
Params: CanvasHandle - canvas handle to redraw
Params: CanvasHandle - Canvas handle to redraw
Returns: Nothing
Redraws (the window of) a canvas
------------------------------------------------------------------------------}
procedure TCarbonWidgetSet.DCRedraw(CanvasHandle: HDC);
var
ADC: TCarbonControlContext;
begin
if not (TObject(CanvasHandle) is TCarbonControlContext) then Exit;
ADC := TCarbonControlContext(CanvasHandle);
{$IFDEF VerboseObject}
DebugLn('TCarbonWidgetSet.DCRedraw DC: ' + DbgS(CanvasHandle));
{$ENDIF}
CGContextFlush(ADC.CGContext);
if not CheckDC(CanvasHandle, 'DCRedraw') then Exit;
CGContextFlush(TCarbonContext(CanvasHandle).CGContext);
end;
{------------------------------------------------------------------------------
Method: TCarbonWidgetSet.SetDesigning
Params: AComponent - component to set designing
Params: AComponent - Component to set designing
Returns: Nothing
Not implemented!
@ -541,8 +636,8 @@ end;
{------------------------------------------------------------------------------
Method: TimerCallback
Params: inTimer - timer reference
inUserData - user data passed when installing timer
Params: inTimer - Timer reference
inUserData - User data passed when installing timer
Returns: Nothing
Calls the timer function associated with specified timer
@ -551,15 +646,25 @@ procedure TimerCallback(inTimer: EventLoopTimerRef; inUserData: UnivPtr);
var
TimerFunc: TFNTimerProc;
begin
{$IFDEF VerboseTimer}
DebugLn('TimerCallback');
{$ENDIF}
if CarbonWidgetSet = nil then Exit;
if CarbonWidgetSet.FTimerMap.GetData(inTimer, TimerFunc)
then TimerFunc;
if CarbonWidgetSet.FTimerMap.GetData(inTimer, TimerFunc) then
begin
{$IFDEF VerboseTimer}
DebugLn('TimerCallback Timer instaåled, calling func.');
{$ENDIF}
TimerFunc;
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonWidgetSet.CreateTimer
Params: Interval - new timer interval
TimerFunc - new timer callback
Params: Interval - New timer interval
TimerFunc - New timer callback
Returns: A Timer id
Creates new timer with specified interval and callback function
@ -568,17 +673,25 @@ function TCarbonWidgetSet.CreateTimer(Interval: integer; TimerFunc: TFNTimerProc
var
Timer: EventLoopTimerRef;
begin
{$IFDEF VerboseTimer}
DebugLn('TCarbonWidgetSet.CreateTimer Interval: ' + DbgS(Interval));
{$ENDIF}
Result := 0;
if (Interval > 0) and (TimerFunc <> nil) then
begin
if InstallEventLoopTimer(GetMainEventLoop,
if OSError(InstallEventLoopTimer(GetMainEventLoop,
Interval / 1000, Interval / 1000, // converts msec -> sec
EventLoopTimerUPP(@TimerCallback), nil, Timer) = noErr then
begin
FTimerMap.Add(Timer, TimerFunc);
Result := THandle(Timer);
end;
EventLoopTimerUPP(@TimerCallback), nil, Timer), Self,
'CreateTimer', 'InstallEventLoopTimer') then Exit;
FTimerMap.Add(Timer, TimerFunc);
Result := THandle(Timer)
end;
{$IFDEF VerboseTimer}
DebugLn('TCarbonWidgetSet.CreateTimer Result: ' + DbgS(Result));
{$ENDIF}
end;
{------------------------------------------------------------------------------
@ -590,7 +703,13 @@ end;
------------------------------------------------------------------------------}
function TCarbonWidgetSet.DestroyTimer(TimerHandle: THandle): boolean;
begin
{$IFDEF VerboseTimer}
DebugLn('TCarbonWidgetSet.DestroyTimer Handle: ' + DbgS(TimerHandle));
{$ENDIF}
Result := FTimerMap.Delete(TimerHandle);
if Result // valid timer
then RemoveEventLoopTimer(EventLoopTimerRef(TimerHandle));
if Result then // valid timer
OSError(RemoveEventLoopTimer(EventLoopTimerRef(TimerHandle)), Self,
'DestroyTimer', 'RemoveEventLoopTimer');
end;

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

@ -88,7 +88,7 @@ type
public
{ Frame:
= widget in controls without special frame control
- frame area control of control or window
- frame area control of control
- determines bounds of control
- processes only bounds changed event }
property Frame: ControlRef read GetFrame;
@ -126,6 +126,13 @@ type
function Update: Boolean; override;
end;
{ TCarbonHintWindow }
TCarbonHintWindow = class(TCarbonWindow)
protected
procedure CreateWidget(const AParams: TCreateParams); override;
end;
{ TCarbonCustomControl }
TCarbonCustomControl = class(TCarbonControl)
@ -365,6 +372,28 @@ var SavedMouseUpMsg: TLMMouse;
{$I carbonprivatecontrol.inc}
{$I carbonprivatewindow.inc}
{ TCarbonHintWindow }
procedure TCarbonHintWindow.CreateWidget(const AParams: TCreateParams);
var
Window: WindowRef;
MinSize, MaxSize: HISize;
begin
if CreateNewWindow(kHelpWindowClass,
kWindowCompositingAttribute or
kWindowHideOnSuspendAttribute or kWindowStandardHandlerAttribute,
ParamsToCarbonRect(AParams), Window) = noErr then
begin
Widget := Window;
SetWindowProperty(Widget, LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(Self), @Self);
SetControlProperty(Content, LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(Self), @Self);
end
else RaiseCreateWidgetError(LCLObject);
SetColor(LCLObject.Color);
end;
{ TCarbonCustomControl }
procedure TCarbonCustomControl.CreateWidget(const AParams: TCreateParams);
@ -1419,5 +1448,6 @@ begin
end;
end.

0
lcl/interfaces/carbon/carbonprivatecheckbox.inc
View File

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

@ -245,3 +245,134 @@ begin
end;
end;
end;
function CarbonCommon_ContextualMenuClick(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
var
Msg: TLMMouse;
P: TPoint;
begin
DebugLn('CarbonCommon_ContextualMenuClick: ', DbgSName(AWidget.LCLObject));
// Result := CallNextEventHandler(ANextHandler, AEvent);
P := AWidget.GetMousePos;
DebugLn('CarbonCommon_ContextualMenuClick: ', DbgS(P));
FillChar(Msg, SizeOf(TLMMouse), 0);
Msg.Msg := LM_CONTEXTMENU;
Msg.Pos.X := P.X;
Msg.Pos.Y := P.Y;
DeliverMessage(AWidget.LCLObject, Msg);
Result := noErr; // do not propagate
end;
function CarbonCommon_SetFocusPart(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
var
FocusPart: ControlPartCode;
begin
Result := CallNextEventHandler(ANextHandler, AEvent);
if GetEventParameter(AEvent, kEventParamControlPart, typeControlPartCode, nil,
SizeOf(ControlPartCode), nil, @FocusPart) <> noErr then Exit;
DebugLn('CarbonCommon_SetFocusPart: ', DbgSName(AWidget.LCLObject), ' ' +
IntToStr(Integer(FocusPart)));
if FocusPart <> kControlFocusNoPart then
LCLSendSetFocusMsg(AWidget.LCLObject)
else
LCLSendKillFocusMsg(AWidget.LCLObject);
end;
function CarbonCommon_GetNextFocusCandidate(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
var
StartControl, NextControl: ControlRef;
FocusPart: ControlPartCode;
TabIndex: Integer;
TabList: TFPList;
AControl: TCarbonWidget;
begin
DebugLn('CarbonCommon_GetNextFocusCandidate: ', DbgSName(AWidget.LCLObject));
//Result := CallNextEventHandler(ANextHandler, AEvent);
if GetEventParameter(AEvent, kEventParamStartControl, typeControlRef, nil,
SizeOf(ControlRef), nil, @StartControl) <> noErr then Exit;
if GetEventParameter(AEvent, kEventParamControlPart, typeControlPartCode, nil,
SizeOf(ControlPartCode), nil, @FocusPart) <> noErr then Exit;
TabIndex := 0;
TabList := TFPList.Create;
try
(AWidget.LCLObject.GetTopParent as TWinControl).GetTabOrderList(TabList);
AControl := GetCarbonWidget(StartControl);
if AControl <> nil then
begin
TabIndex := TabList.IndexOf(AControl.LCLObject);
if TabIndex >= 0 then
begin
if FocusPart = kControlFocusNextPart then
begin
Inc(TabIndex);
if TabIndex >= TabList.Count then TabIndex := 0;
end
else
begin
Dec(TabIndex);
if TabIndex < 0 then TabIndex := TabList.Count - 1;
end;
end
else TabIndex := 0;
end;
if TabIndex < TabList.Count then
NextControl := AsControlRef(TWinControl(TabList[TabIndex]).Handle)
else
NextControl := nil;
OSError(SetEventParameter(AEvent, kEventParamNextControl, typeControlRef,
SizeOf(ControlRef), @NextControl), 'CarbonCommon_GetNextFocusCandidate',
'SetEventParameter');
finally
TabList.Free;
end;
Result := noErr;
end;
function CarbonCommon_SetCursor(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
var
{
Msg: TLMessage;
}
ACursor: TCursor;
begin
// too much messages in terminal
// DebugLn('CarbonCommon_SetCursor: ', AWidget.LCLObject.Name);
CallNextEventHandler(ANextHandler, AEvent);
{
Paul Ishenin: maybe we should ask control about it cursor via LM_SetCursor ???
FillChar(Msg, SizeOf(Msg), 0);
Msg.msg := LM_SETCURSOR;
DeliverMessage(AWidget.LCLObject, Msg);
}
ACursor := Screen.Cursor;
if ACursor = crDefault then
begin
ACursor := AWidget.LCLObject.Cursor;
end;
WidgetSet.SetCursor(Screen.Cursors[ACursor]);
Result := noErr; // cursor was setted
end;

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

@ -19,62 +19,6 @@
// H A N D L E R S
// ==================================================================
function CarbonControl_SetFocusPart(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
//Focus: ControlTypeCode;
begin
DebugLn('CarbonControl_SetFocusPart: ', DbgSName(AWidget.LCLObject));
Result := CallNextEventHandler(ANextHandler, AEvent);
{if GetEventParameter(AEvent, kEventParamControlPart, typeControlPartCode, nil,
SizeOf(Boolean), nil, @Focus) <> noErr then Focus := kControlFocusNoPart;
FillChar(Msg, SizeOf(Msg), 0);
if Focus then Msg.msg := LM_SETFOCUS
else Msg.msg := LM_FILLFOCUS;
DeliverMessage(AWidget.LCLObject, Msg);}
end;
function CarbonControl_GetNextFocusCandidate(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
begin
DebugLn('CarbonControl_GetNextFocusCandidate: ', DbgSName(AWidget.LCLObject));
Result := CallNextEventHandler(ANextHandler, AEvent);
end;
function CarbonControl_SetCursor(ANextHandler: EventHandlerCallRef;
AEvent: EventRef;
AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
var
{
Msg: TLMessage;
}
ACursor: TCursor;
begin
// too much messages in terminal
// DebugLn('PrivateHiView_SetCursor: ', AWidget.LCLObject.Name);
CallNextEventHandler(ANextHandler, AEvent);
{
Paul Ishenin: maybe we should ask control about it cursor via LM_SetCursor ???
FillChar(Msg, SizeOf(Msg), 0);
Msg.msg := LM_SETCURSOR;
DeliverMessage(AWidget.LCLObject, Msg);
}
ACursor := Screen.Cursor;
if ACursor = crDefault then
begin
ACursor := AWidget.LCLObject.Cursor;
end;
WidgetSet.SetCursor(Screen.Cursors[ACursor]);
Result := noErr; // cursor was setted
end;
{------------------------------------------------------------------------------
Name: CarbonControl_Hit
Handles click and LM_MOUSEUP events
@ -226,6 +170,11 @@ begin
RegisterEventHandler(@CarbonCommon_BoundsChanged),
1, @TmpSpec, Pointer(Self), nil);
TmpSpec := MakeEventSpec(kEventClassControl, kEventControlContextualMenuClick);
InstallControlEventHandler(Widget,
RegisterEventHandler(@CarbonCommon_ContextualMenuClick),
1, @TmpSpec, Pointer(Self), nil);
TmpSpec := MakeEventSpec(kEventClassControl, kEventControlTrack);
InstallControlEventHandler(Widget,
RegisterEventHandler(@CarbonCommon_Track),
@ -240,19 +189,19 @@ begin
end;
TmpSpec := MakeEventSpec(kEventClassControl, kEventControlSetFocusPart);
InstallControlEventHandler(Widget,
RegisterEventHandler(@CarbonControl_SetFocusPart),
InstallControlEventHandler(Content,
RegisterEventHandler(@CarbonCommon_SetFocusPart),
1, @TmpSpec, Pointer(Self), nil);
TmpSpec := MakeEventSpec(kEventClassControl, kEventControlGetNextFocusCandidate);
InstallControlEventHandler(Widget,
RegisterEventHandler(@CarbonControl_GetNextFocusCandidate),
InstallControlEventHandler(Content,
RegisterEventHandler(@CarbonCommon_GetNextFocusCandidate),
1, @TmpSpec, Pointer(Self), nil);
// cursor set
TmpSpec := MakeEventSpec(kEventClassControl, kEventControlSetCursor);
InstallControlEventHandler(Widget,
RegisterEventHandler(@CarbonControl_SetCursor),
RegisterEventHandler(@CarbonCommon_SetCursor),
1, @TmpSpec, Pointer(Self), nil);
if cceHit in Events then
@ -307,13 +256,16 @@ begin
UnregisterEventHandler(@CarbonCommon_Dispose);
UnregisterEventHandler(@CarbonCommon_Draw);
UnregisterEventHandler(@CarbonCommon_BoundsChanged);
UnregisterEventHandler(@CarbonCommon_ContextualMenuClick);
UnregisterEventHandler(@CarbonCommon_Track);
if Content <> ControlRef(Widget) then
UnregisterEventHandler(@CarbonCommon_Track);
UnregisterEventHandler(@CarbonCommon_BoundsChanged);
UnregisterEventHandler(@CarbonControl_SetFocusPart);
UnregisterEventHandler(@CarbonControl_GetNextFocusCandidate);
UnregisterEventHandler(@CarbonControl_SetCursor);
UnregisterEventHandler(@CarbonCommon_SetFocusPart);
UnregisterEventHandler(@CarbonCommon_GetNextFocusCandidate);
UnregisterEventHandler(@CarbonCommon_SetCursor);
if cceHit in Events then
UnregisterEventHandler(@CarbonControl_Hit);
if cceValueChanged in Events then
@ -413,22 +365,18 @@ end;
function TCarbonControl.GetScreenBounds(var ARect: TRect): Boolean;
var
BoundsHIRect: HIRect;
BoundsRect: TRect;
BoundsRect: HIRect;
WindowRect: FPCMacOSAll.Rect;
begin
Result := False;
if not GetBounds(BoundsRect) then Exit;
OffsetRect(BoundsRect, -BoundsRect.Left, -BoundsRect.Left);
BoundsHIRect := RectToCGRect(BoundsRect);
if HIViewConvertRect(BoundsHIRect, Frame, nil) <> noErr then Exit;
if HIViewGetBounds(Frame, BoundsRect) <> noErr then Exit;
if HIViewConvertRect(BoundsRect, Frame, nil) <> noErr then Exit;
if GetWindowBounds(GetTopParentWindow, kWindowStructureRgn,
WindowRect) <> noErr then Exit;
ARect := CGRectToRect(BoundsHIRect);
ARect := CGRectToRect(BoundsRect);
OffsetRect(ARect, WindowRect.left, WindowRect.top);
Result := True;

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

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

@ -258,6 +258,8 @@ begin
else
// the LCL does not want the event propagated
Result := noErr;
NotifyApplicationUserInput(Msg.Message.Msg);
end;
function CarbonWindow_KeyboardProc(ANextHandler: EventHandlerCallRef;
@ -787,6 +789,27 @@ begin
RegisterEventHandler(@CarbonCommon_BoundsChanged),
1, @TmpSpec, Pointer(Self), nil);
TmpSpec := MakeEventSpec(kEventClassControl, kEventControlContextualMenuClick);
InstallControlEventHandler(Content,
RegisterEventHandler(@CarbonCommon_ContextualMenuClick),
1, @TmpSpec, Pointer(Self), nil);
TmpSpec := MakeEventSpec(kEventClassControl, kEventControlSetFocusPart);
InstallControlEventHandler(Content,
RegisterEventHandler(@CarbonCommon_SetFocusPart),
1, @TmpSpec, Pointer(Self), nil);
TmpSpec := MakeEventSpec(kEventClassControl, kEventControlGetNextFocusCandidate);
InstallControlEventHandler(Content,
RegisterEventHandler(@CarbonCommon_GetNextFocusCandidate),
1, @TmpSpec, Pointer(Self), nil);
// cursor set
TmpSpec := MakeEventSpec(kEventClassControl, kEventControlSetCursor);
InstallControlEventHandler(Content,
RegisterEventHandler(@CarbonCommon_SetCursor),
1, @TmpSpec, Pointer(Self), nil);
// cursor change
TmpSpec := MakeEventSpec(kEventClassWindow, kEventWindowCursorChange);
InstallWindowEventHandler(Widget,
@ -809,6 +832,10 @@ begin
UnregisterEventHandler(@CarbonCommon_Draw);
UnregisterEventHandler(@CarbonCommon_Track);
UnregisterEventHandler(@CarbonCommon_BoundsChanged);
UnregisterEventHandler(@CarbonCommon_ContextualMenuClick);
UnregisterEventHandler(@CarbonCommon_SetFocusPart);
UnregisterEventHandler(@CarbonCommon_GetNextFocusCandidate);
UnregisterEventHandler(@CarbonCommon_SetCursor);
UnregisterEventHandler(@CarbonCommon_CursorChange);
end;

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

@ -25,32 +25,38 @@
}
unit CarbonProc;
{$mode objfpc}{$H+}
interface
uses
FPCMacOSAll, Classes, LCLType, LCLProc, LCLClasses, LMessages,
FPCMacOSAll, Classes, Types, LCLType, LCLProc, LCLClasses, LMessages,
Controls, Forms, Avl_Tree, SysUtils, Graphics, Math, GraphType,
CarbonDef, CarbonPrivate;
type
TConvertResult = (trNoError, trNullSrc, trNullDest, trDestExhausted,
trInvalidChar, trUnfinishedChar);
TConvertOption = (toInvalidCharError, toInvalidCharToSymbol,
toUnfinishedCharError, toUnfinishedCharToSymbol);
TConvertOptions = set of TConvertOption;
function UTF8ToUTF16(const S: UTF8String): WideString;
CarbonDef, CarbonPrivate, CarbonMenus;
function AsControlRef(Handle: HWND): ControlRef; inline;
function AsWindowRef(Handle: HWND): WindowRef; inline;
function AsMenuRef(Handle: HMENU): MenuRef; inline;
function CheckWidget(const Handle: HWND; const DbgText: String; AName: String = ''): Boolean;
function CheckDC(const DC: HDC; const DbgText: String; AName: String = ''): Boolean;
function CheckGDIObject(const GDIObject: HGDIOBJ; const DbgText: String; AName: String = ''): Boolean;
function CheckBitmap(const Bitmap: HBITMAP; const DbgText: String; AName: String = ''): Boolean;
function CheckHandle(const AWinControl: TWinControl; const AClass: TClass; const DbgText: String): Boolean;
function CheckWidget(const Handle: HWND; const AMethodName: String; AParamName: String = ''): Boolean;
function CheckMenu(const Menu: HMENU; const AMethodName: String; AParamName: String = ''): Boolean;
function CheckDC(const DC: HDC; const AMethodName: String; AParamName: String = ''): Boolean;
function CheckGDIObject(const GDIObject: HGDIOBJ; const AMethodName: String; AParamName: String = ''): Boolean;
function CheckBitmap(const Bitmap: HBITMAP; const AMethodName: String; AParamName: String = ''): Boolean;
function CheckCursor(const Cursor: HCURSOR; const AMethodName: String; AParamName: String = ''): Boolean;
function OSError(AResult: OSStatus; const AMethodName, ACallName: String;
const AText: String = ''): Boolean;// inline;
function OSError(AResult: OSStatus; const AObject: TObject; const AMethodName, ACallName: String;
const AText: String = ''): Boolean;// inline;
function OSError(AResult: OSStatus; const AClass: TClass; const AMethodName, ACallName: String;
const AText: String = ''): Boolean;// inline;
function OSError(AResult: OSStatus; const AObject: TObject; const AMethodName, ACallName: String;
const AText: String; AValidResult: OSStatus): Boolean;// inline;
function GetCarbonWidget(AWidget: Pointer): TCarbonWidget;
function GetCarbonWindow(AWidget: WindowRef): TCarbonWindow;
@ -75,7 +81,13 @@ function GetCarbonRect(Left, Top, Width, Height: Integer): FPCMacOSAll.Rect;
function GetCarbonRect(const ARect: TRect): FPCMacOSAll.Rect;
function ParamsToCarbonRect(const AParams: TCreateParams): FPCMacOSAll.Rect;
type
CGRectArray = Array of CGRect;
function ExcludeRect(const A, B: TRect): CGRectArray;
function GetCGRect(X1, Y1, X2, Y2: Integer): CGRect;
function GetCGRectSorted(X1, Y1, X2, Y2: Integer): CGRect;
function RectToCGRect(const ARect: TRect): CGRect;
function CGRectToRect(const ARect: CGRect): TRect;
@ -86,6 +98,7 @@ function ColorToRGBColor(const AColor: TColor): RGBColor;
function RGBColorToColor(const AColor: RGBColor): TColor; inline;
function CreateCGColor(const AColor: TColor): CGColorRef;
function Dbgs(const ASize: TSize): string; overload;
function Dbgs(const ARect: FPCMacOSAll.Rect): string; overload;
function Dbgs(const AColor: FPCMacOSAll.RGBColor): string; overload;
@ -93,225 +106,6 @@ implementation
uses CarbonInt, CarbonCanvas, CarbonGDIObjects;
{------------------------------------------------------------------------------
Name: ConvertUTF8ToUTF16
Params: Dest - Pointer to destination string
DestWideCharCount - Wide char count allocated in destination string
Src - Pointer to source string
SrcCharCount - Char count allocated in source string
Options - Conversion options, if none is set, both
invalid and unfinished UTF-8 chars are skipped
toInvalidCharError - Stop on invalid UTF-8 char and report
error
toInvalidCharToSymbol - Replace invalid UTF-8 chars with '?'
toUnfinishedCharError - Stop on unfinished UTF-8 char and report
error
toUnfinishedCharToSymbol - Replace unfinished UTF-8 char with '?'
ActualWideCharCount - Actual wide char count converted from source
string to destination string
Returns:
trNoError - The string was successfully converted without
any error
trNullSrc - Pointer to source string is nil
trNullDest - Pointer to destination string is nil
trDestExhausted - Destination buffer size is not big enough to hold
converted string
trInvalidChar - Invalid UTF-8 char has occured
trUnfinishedChar - Unfinished UTF-8 char has occured
Converts the specified UTF-8 encoded string to UTF-16 encoded
------------------------------------------------------------------------------}
function ConvertUTF8ToUTF16(Dest: PWideChar; DestWideCharCount: SizeUInt;
Src: PChar; SrcCharCount: SizeUInt; Options: TConvertOptions;
out ActualWideCharCount: SizeUInt): TConvertResult;
var
DestI, SrcI: SizeUInt;
B1, B2, B3, B4: Byte;
W: Word;
C: Cardinal;
function UnfinishedCharError: Boolean;
begin
if toUnfinishedCharToSymbol in Options then
begin
Dest[DestI] := System.WideChar('?');
Inc(DestI);
Result := False;
end
else
if toUnfinishedCharError in Options then
begin
ConvertUTF8ToUTF16 := trUnfinishedChar;
Result := True;
end
else Result := False;
end;
function InvalidCharError(Count: Integer): Boolean; inline;
begin
if toInvalidCharToSymbol in Options then
begin
Dest[DestI] := System.WideChar('?');
Inc(DestI);
Dec(SrcI, Count);
Result := False;
end
else
if toInvalidCharError in Options then
begin
ConvertUTF8ToUTF16 := trUnfinishedChar;
Result := True;
end
else
begin
Dec(SrcI, Count);
Result := False;
end;
end;
begin
ActualWideCharCount := 0;
if not Assigned(Src) then
begin
Result := trNullSrc;
Exit;
end;
if not Assigned(Dest) then
begin
Result := trNullDest;
Exit;
end;
SrcI := 0;
DestI := 0;
while (DestI < DestWideCharCount) and (SrcI < SrcCharCount) do
begin
B1 := Byte(Src[SrcI]);
Inc(SrcI);
if B1 < 128 then // single byte UTF-8 char
begin
Dest[DestI] := System.WideChar(B1);
Inc(DestI);
end
else
begin
if SrcI >= SrcCharCount then
if UnfinishedCharError then Exit
else Break;
B2 := Byte(Src[SrcI]);
Inc(SrcI);
if (B1 and %11100000) = %11000000 then // double byte UTF-8 char
begin
if (B2 and %11000000) = %10000000 then
begin
Dest[DestI] := System.WideChar(((B1 and %00011111) shl 6) or (B2 and %00111111));
Inc(DestI);
end
else // invalid character, assume single byte UTF-8 char
if InvalidCharError(1) then Exit;
end
else
begin
if SrcI >= SrcCharCount then
if UnfinishedCharError then Exit
else Break;
B3 := Byte(Src[SrcI]);
Inc(SrcI);
if (B1 and %11110000) = %11100000 then // triple byte UTF-8 char
begin
if ((B2 and %11000000) = %10000000) and ((B3 and %11000000) = %10000000) then
begin
W := ((B1 and %00011111) shl 12) or ((B2 and %00111111) shl 6) or (B3 and %00111111);
if W < $D800 then // to single wide char UTF-16 char
begin
Dest[DestI] := System.WideChar(W);
Inc(DestI);
end
else // to double wide char UTF-16 char
begin
Dest[DestI] := System.WideChar($D800 or (W shr 10));
Inc(DestI);
if DestI >= DestWideCharCount then Break;
Dest[DestI] := System.WideChar($DC00 or (W and %0000001111111111));
Inc(DestI);
end;
end
else // invalid character, assume single byte UTF-8 char
if InvalidCharError(2) then Exit;
end
else
begin
if SrcI >= SrcCharCount then
if UnfinishedCharError then Exit
else Break;
B4 := Byte(Src[SrcI]);
Inc(SrcI);
if ((B1 and %11111000) = %11110000) and ((B2 and %11000000) = %10000000)
and ((B3 and %11000000) = %10000000) and ((B4 and %11000000) = %10000000) then
begin // 4 byte UTF-8 char
C := ((B1 and %00011111) shl 18) or ((B2 and %00111111) shl 12)
or ((B3 and %00111111) shl 6) or (B4 and %00111111);
// to double wide char UTF-16 char
Dest[DestI] := System.WideChar($D800 or (C shr 10));
Inc(DestI);
if DestI >= DestWideCharCount then Break;
Dest[DestI] := System.WideChar($DC00 or (C and %0000001111111111));
Inc(DestI);
end
else // invalid character, assume single byte UTF-8 char
if InvalidCharError(3) then Exit;
end;
end;
end;
end;
if DestI >= DestWideCharCount then
begin
DestI := DestWideCharCount - 1;
Result := trDestExhausted;
end
else
Result := trNoError;
Dest[DestI] := #0;
ActualWideCharCount := DestI + 1;
end;
{------------------------------------------------------------------------------
Name: UTF8ToUTF16
Params: S - Source UTF-8 string
Returns: UTF-16 encoded string
Converts the specified UTF-8 encoded string to UTF-16 encoded
------------------------------------------------------------------------------}
function UTF8ToUTF16(const S: UTF8String): WideString;
var
L: SizeUInt;
R: WideString;
begin
Result := '';
if S = '' then Exit;
SetLength(R, Length(S)); // bytes of UTF-8 string >= wide chars of UTF-16
if ConvertUTF8ToUTF16(PWideChar(R), Length(R) + 1, PChar(S), Length(S),
[toInvalidCharToSymbol], L) = trNoError then
begin
SetLength(R, L - 1);
Result := R;
end;
end;
{------------------------------------------------------------------------------
Name: AsControlRef
Params: Handle - Handle of window control
@ -323,7 +117,7 @@ begin
end;
{------------------------------------------------------------------------------
Name: AsControlRef
Name: AsWindowRef
Params: Handle - Handle of window
Returns: Carbon window
------------------------------------------------------------------------------}
@ -332,83 +126,290 @@ begin
Result := WindowRef(TCarbonWindow(Handle).Widget);
end;
{------------------------------------------------------------------------------
Name: AsMenuRef
Params: Handle - Handle of menu
Returns: Carbon menu
------------------------------------------------------------------------------}
function AsMenuRef(Handle: HMENU): MenuRef; inline;
begin
Result := TCarbonMenu(Handle).Menu;
end;
const
CarbonWSPrefix = 'TCarbonWidgetSet.';
{------------------------------------------------------------------------------
Name: CheckHandle
Params: AWinControl - Handle of window
AClass - Class
DbgText - Text to output on invalid DC
Returns: If the wincontrol handle is allocated and valid
------------------------------------------------------------------------------}
function CheckHandle(const AWinControl: TWinControl; const AClass: TClass;
const DbgText: String): Boolean;
begin
if AWinControl <> nil then
begin
if TObject(AWinControl.Handle) is TCarbonWidget then
begin
{$IFDEF VerboseWSClass}
DebugLn(AClass.ClassName + '.' + DbgText + ' for ' + AWinControl.Name);
{$ENDIF}
Result := True;
end
else
begin
Result := False;
DebugLn(AClass.ClassName + '.' + DbgText + ' for ' + AWinControl.Name +
' failed: Handle ' + DbgS(Integer(AWinControl.Handle)) + ' is invalid!');
end;
end
else
begin
Result := False;
DebugLn(AClass.ClassName + '.' + DbgText + ' for ' + AWinControl.Name +
' failed: WinControl is nil!');
end;
end;
{------------------------------------------------------------------------------
Name: CheckWidget
Params: Handle - Handle of window
DbgText - Text to output on invalid DC
Name - Param name
Params: Handle - Handle of window
AMethodName - Method name
AParamName - Param name
Returns: If the window is valid
------------------------------------------------------------------------------}
function CheckWidget(const Handle: HWND; const DbgText: String; AName: String): Boolean;
function CheckWidget(const Handle: HWND; const AMethodName: String;
AParamName: String): Boolean;
begin
if TObject(Handle) is TCarbonWidget then Result := True
else
begin
DebugLn(DbgText + Format(' error - invalid widget %s = %d!',
[AName, Integer(Handle)]));
if Pos('.', AMethodName) = 0 then
DebugLn(CarbonWSPrefix + AMethodName + ' Error - invalid widget ' +
AParamName + ' = ' + IntToStr(Integer(Handle)) + '!')
else
DebugLn(AMethodName + ' Error - invalid widget ' + AParamName + ' = ' +
IntToStr(Integer(Handle)) + '!');
Result := False;
end;
end;
{------------------------------------------------------------------------------
Name: CheckMenu
Params: Menu - Handle of menu
AMethodName - Method name
AParamName - Param name
Returns: If the menu is valid
------------------------------------------------------------------------------}
function CheckMenu(const Menu: HMENU; const AMethodName: String;
AParamName: String): Boolean;
begin
if TObject(Menu) is TCarbonMenu then Result := True
else
begin
if Pos('.', AMethodName) = 0 then
DebugLn(CarbonWSPrefix + AMethodName + ' Error - invalid menu ' +
AParamName + ' = ' + IntToStr(Integer(Menu)) + '!')
else
DebugLn(AMethodName + ' Error - invalid menu ' + AParamName + ' = ' +
IntToStr(Integer(Menu)) + '!');
Result := False;
end;
end;
{------------------------------------------------------------------------------
Name: CheckDC
Params: DC - Handle to a device context (TCarbonDeviceContext)
DbgText - Text to output on invalid DC
Name - Param name
Params: DC - Handle to a device context (TCarbonDeviceContext)
AMethodName - Method name
AParamName - Param name
Returns: If the DC is valid
------------------------------------------------------------------------------}
function CheckDC(const DC: HDC; const DbgText: String; AName: String): Boolean;
function CheckDC(const DC: HDC; const AMethodName: String;
AParamName: String): Boolean;
begin
if TObject(DC) is TCarbonDeviceContext then Result := True
else
begin
DebugLn(DbgText + Format(' error - invalid device context %s = %d!',
[AName, Integer(DC)]));
if Pos('.', AMethodName) = 0 then
DebugLn(CarbonWSPrefix + AMethodName + ' Error - invalid DC ' +
AParamName + ' = ' + IntToStr(Integer(DC)) + '!')
else
DebugLn(AMethodName + ' Error - invalid DC ' + AParamName + ' = ' +
IntToStr(Integer(DC)) + '!');
Result := False;
end;
end;
{------------------------------------------------------------------------------
Name: CheckGDIObject
Params: GDIObject - handle to a GDI Object (TCarbonFont, ...)
DbgText - Text to output on invalid GDIObject
Name - Param name
Params: GDIObject - Handle to a GDI Object (TCarbonFont, ...)
AMethodName - Method name
AParamName - Param name
Returns: If the GDIObject is valid
Remark: All handles for GDI objects must be pascal objects so we can
distinguish between them
------------------------------------------------------------------------------}
function CheckGDIObject(const GDIObject: HGDIOBJ; const DbgText: String;
AName: String): Boolean;
function CheckGDIObject(const GDIObject: HGDIOBJ; const AMethodName: String;
AParamName: String): Boolean;
begin
if TObject(GDIObject) is TCarbonGDIObject then Result := True
else
begin
DebugLn(DbgText + Format(' error - invalid GDI object %s = %d!',
[AName, Integer(GDIObject)]));
if Pos('.', AMethodName) = 0 then
DebugLn(CarbonWSPrefix + AMethodName + ' Error - invalid GDIObject ' +
AParamName + ' = ' + IntToStr(Integer(GDIObject)) + '!')
else
DebugLn(AMethodName + ' Error - invalid GDIObject ' + AParamName + ' = ' +
IntToStr(Integer(GDIObject)) + '!');
Result := False;
end;
end;
{------------------------------------------------------------------------------
Name: CheckBitmap
Params: Bitmap - handle to a bitmap (TCarbonBitmap)
DbgText - Text to output on invalid GDIObject
Name - Param name
Params: Bitmap - Handle to a bitmap (TCarbonBitmap)
AMethodName - Method name
AParamName - Param name
Returns: If the bitmap is valid
------------------------------------------------------------------------------}
function CheckBitmap(const Bitmap: HBITMAP; const DbgText: String;
AName: String): Boolean;
function CheckBitmap(const Bitmap: HBITMAP; const AMethodName: String;
AParamName: String): Boolean;
begin
if TObject(Bitmap) is TCarbonBitmap then Result := True
else
begin
DebugLn(DbgText + Format(' error - invalid bitmap %s = %d!',
[AName, Integer(Bitmap)]));
if Pos('.', AMethodName) = 0 then
DebugLn(CarbonWSPrefix + AMethodName + ' Error - invalid bitmap ' +
AParamName + ' = ' + IntToStr(Integer(Bitmap)) + '!')
else
DebugLn(AMethodName + ' Error - invalid bitmap ' + AParamName + ' = ' +
IntToStr(Integer(Bitmap)) + '!');
Result := False;
end;
end;
{------------------------------------------------------------------------------
Name: CheckCursor
Params: Cursor - Handle to a cursor (TCarbonCursor)
AMethodName - Method name
AParamName - Param name
Returns: If the cursor is valid
------------------------------------------------------------------------------}
function CheckCursor(const Cursor: HCURSOR; const AMethodName: String;
AParamName: String): Boolean;
begin
if TObject(Cursor) is TCarbonCursor then Result := True
else
begin
if Pos('.', AMethodName) = 0 then
DebugLn(CarbonWSPrefix + AMethodName + ' Error - invalid cursor ' +
AParamName + ' = ' + IntToStr(Integer(Cursor)) + '!')
else
DebugLn(AMethodName + ' Error - invalid cursor ' + AParamName + ' = ' +
IntToStr(Integer(Cursor)) + '!');
Result := False;
end;
end;
{------------------------------------------------------------------------------
Name: OSError
Params: AResult - Result of Carbon function call
AMethodName - Parent method name
ACallName - The Carbon function name
AText - Another text useful for debugging (param value, ...)
Returns: If an error was the result of calling the specified Carbon function
------------------------------------------------------------------------------}
function OSError(AResult: OSStatus; const AMethodName, ACallName: String;
const AText: String): Boolean;
begin
if AResult = noErr then Result := False
else
begin
Result := True;
DebugLn(AMethodName + ' Error: ' + ACallName + ' ' + AText +
' failed with result ' + DbgS(AResult));
end;
end;
{------------------------------------------------------------------------------
Name: OSError
Params: AResult - Result of Carbon function call
AObject - Method object
AMethodName - Parent method name
ACallName - The Carbon function name
AText - Another text useful for debugging (param value, ...)
Returns: If an error was the result of calling the specified Carbon function
------------------------------------------------------------------------------}
function OSError(AResult: OSStatus; const AObject: TObject;
const AMethodName, ACallName: String;
const AText: String = ''): Boolean;
begin
if AResult = noErr then Result := False
else
begin
Result := True;
DebugLn(AObject.ClassName + '.' + AMethodName + ' Error: ' + ACallName +
' ' + AText + ' failed with result ' + DbgS(AResult));
end;
end;
{------------------------------------------------------------------------------
Name: OSError
Params: AResult - Result of Carbon function call
AClass - Method object
AMethodName - Parent method name
ACallName - The Carbon function name
AText - Another text useful for debugging (param value, ...)
Returns: If an error was the result of calling the specified Carbon function
------------------------------------------------------------------------------}
function OSError(AResult: OSStatus; const AClass: TClass;
const AMethodName, ACallName: String;
const AText: String = ''): Boolean;
begin
if AResult = noErr then Result := False
else
begin
Result := True;
DebugLn(AClass.ClassName + '.' + AMethodName + ' Error: ' + ACallName +
' ' + AText + ' failed with result ' + DbgS(AResult));
end;
end;
{------------------------------------------------------------------------------
Name: OSError
Params: AResult - Result of Carbon function call
AObject - Method object
AMethodName - Parent method name
ACallName - The Carbon function name
AText - Another text useful for debugging (param value, ...)
AValidResult - Another result code that is valid like noErr
Returns: If an error was the result of calling the specified Carbon function
------------------------------------------------------------------------------}
function OSError(AResult: OSStatus; const AObject: TObject;
const AMethodName, ACallName: String;
const AText: String; AValidResult: OSStatus): Boolean;
begin
if (AResult = noErr) or (AResult = AValidResult) then Result := False
else
begin
Result := True;
DebugLn(AObject.ClassName + '.' + AMethodName + ' Error: ' + ACallName +
' ' + AText + ' failed with result ' + DbgS(AResult));
end;
end;
//=====================================================
// UPP mamanger
//=====================================================
@ -444,6 +445,7 @@ begin
inherited Destroy;
end;
{------------------------------------------------------------------------------
Name: GetCarbonWidget
Params: AWidget - Pointer to control or window widget
@ -544,8 +546,8 @@ end;
{------------------------------------------------------------------------------
Name: FindCarbonFontID
Params: FontName - The font name
Returns: Carbon font ID of fotn with the specified name
Params: FontName - The font name, UTF-8 encoded
Returns: Carbon font ID of font with the specified name
------------------------------------------------------------------------------}
function FindCarbonFontID(const FontName: String): ATSUFontID;
begin
@ -553,8 +555,9 @@ begin
if (FontName <> '') and not SameText(FontName, 'default') then
begin
ATSUFindFontFromName(@FontName[1], Length(FontName), kFontFamilyName,
kFontMacintoshPlatform, kFontRomanScript, kFontEnglishLanguage, Result);
ATSUFindFontFromName(@FontName[1], Length(FontName),
kFontFamilyName, kFontMacintoshPlatform, kFontRomanScript,
kFontEnglishLanguage, Result);
end;
end;
@ -776,11 +779,73 @@ begin
end;
{------------------------------------------------------------------------------
Name: RectToCGRect
Name: ExcludeRect
Params: A - Source rectangle
B - Rectangle to be excluded
Returns: Array of CGRect, which are product of exclusion rectangle B from
rectangle A.
Note: The returned rectangles may overlay.
------------------------------------------------------------------------------}
function ExcludeRect(const A, B: TRect): CGRectArray;
begin
SetLength(Result, 0);
if (A.Left >= A.Right) or (A.Top >= A.Bottom) then Exit;
SetLength(Result, 1);
Result[0] := RectToCGRect(A);
if (B.Left >= B.Right) or (B.Top >= B.Bottom) then Exit;
if (B.Left < A.Right) and (B.Right > A.Left)
and (B.Top < A.Bottom) and (B.Bottom > A.Top) then
begin // rectangles have intersection
SetLength(Result, 0);
if B.Top > A.Top then
begin
SetLength(Result, Succ(Length(Result)));
Result[High(Result)] := GetCGRect(A.Left, A.Top, A.Right, B.Top);
end;
if B.Bottom < A.Bottom then
begin
SetLength(Result, Succ(Length(Result)));
Result[High(Result)] := GetCGRect(A.Left, B.Bottom, A.Right, A.Bottom);
end;
if B.Left > A.Left then
begin
SetLength(Result, Succ(Length(Result)));
Result[High(Result)] := GetCGRect(A.Left, A.Top, B.Left, A.Bottom);
end;
if B.Right < A.Right then
begin
SetLength(Result, Succ(Length(Result)));
Result[High(Result)] := GetCGRect(B.Right, A.Top, A.Right, A.Bottom);
end;
end;
end;
{------------------------------------------------------------------------------
Name: GetCGRect
Params: X1, Y1, X2, Y2 - Rectangle coordinates
Returns: CGRect
------------------------------------------------------------------------------}
function GetCGRect(X1, Y1, X2, Y2: Integer): CGRect;
begin
Result.origin.x := X1;
Result.size.width := X2 - X1;
Result.origin.y := Y1;
Result.size.height := Y2 - Y1;
end;
{------------------------------------------------------------------------------
Name: GetCGRectSorted
Params: X1, Y1, X2, Y2 - Rectangle coordinates
Returns: CGRect, coordinates are sorted
------------------------------------------------------------------------------}
function GetCGRect(X1, Y1, X2, Y2: Integer): CGRect;
function GetCGRectSorted(X1, Y1, X2, Y2: Integer): CGRect;
begin
if X1 <= X2 then
begin
@ -908,21 +973,26 @@ begin
Result := CGColorCreate(RGBColorSpace, @F[0]);
end;
function Dbgs(const ASize: TSize): string;
begin
Result := 'cx: ' + IntToStr(ASize.cx) + ' cy: ' + IntToStr(ASize.cy);
end;
function Dbgs(const ARect: FPCMacOSAll.Rect): String;
begin
Result:=IntToStr(ARect.left)+','+IntToStr(ARect.top)
+','+IntToStr(ARect.right)+','+IntToStr(ARect.bottom);
Result := IntToStr(ARect.left) + ', ' + IntToStr(ARect.top)
+ ', ' + IntToStr(ARect.right) + ', ' + IntToStr(ARect.bottom);
end;
function Dbgs(const AColor: FPCMacOSAll.RGBColor): String;
begin
Result := 'R: ' + IntToHex(AColor.Red, 4)
+ 'G: ' + IntToHex(AColor.Green, 4)
+ 'B: ' + IntToHex(AColor.Blue, 4);
Result :=
'R: ' + IntToHex(AColor.Red, 4) +
' G: ' + IntToHex(AColor.Green, 4) +
' B: ' + IntToHex(AColor.Blue, 4);
end;
finalization
if UPPTree <> nil
then FreeAndNil(UPPTree);
if UPPTree <> nil then FreeAndNil(UPPTree);
end.

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

@ -46,6 +46,7 @@ type
constructor Create(AOwner: TCarbonComboBox);
procedure Clear; override;
procedure Delete(Index: Integer); override;
procedure Sort; override;
public
property Owner: TCarbonComboBox read FOwner;
end;
@ -212,6 +213,29 @@ begin
inherited Delete(Index);
HIComboBoxRemoveItemAtIndex(HIViewRef(FOwner.Widget), Index);
end;
{------------------------------------------------------------------------------
Method: TCarbonComboBoxStrings.Sort
Sorts the strings
------------------------------------------------------------------------------}
procedure TCarbonComboBoxStrings.Sort;
var
CFString: CFStringRef;
I: Integer;
begin
inherited Sort;
for I := 0 to Count - 1 do
begin
CreateCFString(Strings[I], CFString);
try
if HIComboBoxRemoveItemAtIndex(HIViewRef(FOwner.Widget), I) = noErr then
HIComboBoxInsertTextItemAtIndex(HIViewRef(FOwner.Widget), I, CFString);
finally
FreeCFString(CFString);
end;
end;
end;
{ TCarbonListBoxStrings }

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

File diff suppressed because it is too large Load Diff

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

@ -82,7 +82,7 @@ function EndPaint(Handle : hwnd; var PS : TPaintStruct): Integer; override;
procedure EnterCriticalSection(var CritSection: TCriticalSection); override;
function EnumFontFamilies(DC: HDC; Family:Pchar; EnumFontFamProc: FontEnumProc; LParam: Lparam): Longint; override;
function EnumFontFamiliesEx(DC: HDC; lpLogFont: PLogFont; Callback: FontEnumExProc; LParam: Lparam; flags: dword): Longint; override;
function ExcludeClipRect(dc: hdc; Left, Top, Right, Bottom : Integer) : Integer; override;
function ExcludeClipRect(DC: HDC; Left, Top, Right, Bottom : Integer) : Integer; override;
function ExtTextOut(DC: HDC; X, Y: Integer; Options: Longint; Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean; override;
function ExtSelectClipRGN(dc: hdc; rgn : hrgn; Mode : Longint) : Integer; override;
@ -162,7 +162,7 @@ function RadialArc(DC: HDC; Left, Top, Right, Bottom, sx, sy, ex, ey: Integer):
function RadialChord(DC: HDC; x1, y1, x2, y2, sx, sy, ex, ey: Integer): Boolean; override;
function RealizePalette(DC: HDC): Cardinal; override;
function Rectangle(DC: HDC; X1, Y1, X2, Y2: Integer): Boolean; override;
function RectVisible(dc : hdc; const ARect: TRect) : Boolean; override;
function RectVisible(DC: HDC; const ARect: TRect) : Boolean; override;
function RegroupMenuItem(hndMenu: HMENU; GroupIndex: integer): Boolean; override;
function ReleaseCapture : Boolean; override;
function ReleaseDC(HWnd: HWND; DC: HDC): Integer; override;
@ -185,7 +185,7 @@ function SetCapture(AHandle: HWND): HWND; override;
function SetCaretPos(X, Y: Integer): Boolean; override;
function SetCaretPosEx(Handle: HWnd; X, Y: Integer): Boolean; override;
function SetCaretRespondToFocus(handle: HWND; ShowHideOnFocus: boolean): Boolean; override;
function SetCursor(hCursor: HICON): HCURSOR; override;
function SetCursor(ACursor: HCURSOR): HCURSOR; override;
function SetFocus(HWnd: HWND): HWND; override;
function SetForegroundWindow(HWnd: HWND): boolean; override;
function SetProp(Handle: hwnd; Str : PChar; Data : Pointer) : Boolean; override;

6
lcl/interfaces/carbon/carbonwsbuttons.pp
View File

@ -99,7 +99,7 @@ end;
class procedure TCarbonWSButton.SetDefault(const AButton: TCustomButton;
ADefault: Boolean);
begin
if not WSCheckHandleAllocated(AButton, 'SetDefault') then Exit;
if not CheckHandle(AButton, Self, 'SetDefault') then Exit;
SetControlData(AsControlRef(AButton.Handle), kControlEntireControl,
kControlPushButtonDefaultTag, SizeOf(Boolean), @ADefault);
@ -135,7 +135,7 @@ class procedure TCarbonWSBitBtn.SetGlyph(const ABitBtn: TCustomBitBtn;
var
ContentInfo: ControlButtonContentInfo;
begin
if not WSCheckHandleAllocated(ABitBtn, 'SetGlyph') then Exit;
if not CheckHandle(ABitBtn, Self, 'SetGlyph') then Exit;
ContentInfo.contentType := kControlContentCGImageRef;
if AValue = nil then
@ -159,7 +159,7 @@ class procedure TCarbonWSBitBtn.SetLayout(const ABitBtn: TCustomBitBtn;
var
Placement: ControlButtonTextPlacement;
begin
if not WSCheckHandleAllocated(ABitBtn, 'SetLayout') then Exit;
if not CheckHandle(ABitBtn, Self, 'SetLayout') then Exit;
case AValue of
blGlyphLeft : Placement := kControlBevelButtonPlaceToRightOfGraphic;

10
lcl/interfaces/carbon/carbonwscomctrls.pp
View File

@ -180,7 +180,7 @@ end;
class procedure TCarbonWSProgressBar.ApplyChanges(
const AProgressBar: TCustomProgressBar);
begin
if not WSCheckHandleAllocated(AProgressBar, 'ApplyChanges') then Exit;
if not CheckHandle(AProgressBar, Self, 'ApplyChanges') then Exit;
TCarbonCustomBar(AProgressBar.Handle).SetData(AProgressBar.Position,
AProgressBar.Min, AProgressBar.Max);
@ -196,7 +196,7 @@ end;
class procedure TCarbonWSProgressBar.SetPosition(
const AProgressBar: TCustomProgressBar; const NewPosition: integer);
begin
if not WSCheckHandleAllocated(AProgressBar, 'SetPosition') then Exit;
if not CheckHandle(AProgressBar, Self, 'SetPosition') then Exit;
TCarbonCustomBar(AProgressBar.Handle).SetData(AProgressBar.Position);
end;
@ -227,7 +227,7 @@ class procedure TCarbonWSTrackBar.ApplyChanges(const ATrackBar: TCustomTrackBar)
var
CarbonTrackBar: TCarbonTrackBar;
begin
if not WSCheckHandleAllocated(ATrackBar, 'ApplyChanges') then Exit;
if not CheckHandle(ATrackBar, Self, 'ApplyChanges') then Exit;
CarbonTrackBar := TCarbonTrackBar(ATrackBar.Handle);
@ -246,7 +246,7 @@ class function TCarbonWSTrackBar.GetPosition(const ATrackBar: TCustomTrackBar
): integer;
begin
Result := 0;
if not WSCheckHandleAllocated(ATrackBar, 'GetPosition') then Exit;
if not CheckHandle(ATrackBar, Self, 'GetPosition') then Exit;
Result := TCarbonTrackBar(ATrackBar.Handle).GetPos;
end;
@ -261,7 +261,7 @@ end;
class procedure TCarbonWSTrackBar.SetPosition(const ATrackBar: TCustomTrackBar;
const NewPosition: integer);
begin
if not WSCheckHandleAllocated(ATrackBar, 'SetPosition') then Exit;
if not CheckHandle(ATrackBar, Self, 'SetPosition') then Exit;
TCarbonTrackBar(ATrackBar.Handle).SetData(ATrackBar.Position);
end;

31
lcl/interfaces/carbon/carbonwscontrols.pp
View File

@ -124,7 +124,7 @@ class procedure TCarbonWSWinControl.GetPreferredSize(const AWinControl: TWinCont
var
S: TPoint;
begin
if not WSCheckHandleAllocated(AWinControl, 'GetPreferredSize') then Exit;
if not CheckHandle(AWinControl, Self, 'GetPreferredSize') then Exit;
S := TCarbonWidget(AWinControl.Handle).GetPreferredSize;
PreferredWidth := S.X;
@ -143,7 +143,7 @@ class function TCarbonWSWinControl.GetText(const AWinControl: TWinControl;
var AText: String): Boolean;
begin
Result := False;
if not WSCheckHandleAllocated(AWinControl, 'GetText') then Exit;
if not CheckHandle(AWinControl, Self,'GetText') then Exit;
Result := TCarbonWidget(AWinControl.Handle).GetText(AText);
end;
@ -159,7 +159,7 @@ end;
class procedure TCarbonWSWinControl.SetBounds(const AWinControl: TWinControl;
const ALeft, ATop, AWidth, AHeight: Integer);
begin
if not WSCheckHandleAllocated(AWinControl, 'SetBounds') then Exit;
if not CheckHandle(AWinControl, Self, 'SetBounds') then Exit;
TCarbonWidget(AWinControl.Handle).SetBounds(Bounds(ALeft, ATop, AWidth, AHeight));
end;
@ -183,8 +183,8 @@ var
I, StopPos: Integer;
Child: TWinControl;
begin
if not WSCheckHandleAllocated(AWinControl, 'SetChildZPosition') then Exit;
if not WSCheckHandleAllocated(AChild, 'SetChildZPosition AChild') then Exit;
if not CheckHandle(AWinControl, Self, 'SetChildZPosition') then Exit;
if not CheckHandle(AChild, Self, 'SetChildZPosition AChild') then Exit;
RefView := nil;
if ANewPos <= 0 then // send behind all
@ -230,7 +230,7 @@ end;
------------------------------------------------------------------------------}
class procedure TCarbonWSWinControl.SetColor(const AWinControl: TWinControl);
begin
if not WSCheckHandleAllocated(AWinControl, 'SetColor') then Exit;
if not CheckHandle(AWinControl, Self, 'SetColor') then Exit;
TCarbonWidget(AWinControl.Handle).SetColor(AWinControl.Color);
end;
@ -246,7 +246,7 @@ end;
class procedure TCarbonWSWinControl.SetFont(const AWinControl: TWinControl;
const AFont: TFont);
begin
if not WSCheckHandleAllocated(AWinControl, 'SetFont') then Exit;
if not CheckHandle(AWinControl, Self, 'SetFont') then Exit;
TCarbonWidget(AWinControl.Handle).SetFont(AFont);
end;
@ -262,7 +262,7 @@ end;
class procedure TCarbonWSWinControl.SetText(const AWinControl: TWinControl;
const AText: String);
begin
if not WSCheckHandleAllocated(AWinControl, 'SetText') then Exit;
if not CheckHandle(AWinControl, Self, 'SetText') then Exit;
//DebugLn('TCarbonWSWinControl.SetText ',dbgsName(AWinControl),' ',AText);
TCarbonWidget(AWinControl.Handle).SetText(AText);
@ -277,7 +277,7 @@ end;
------------------------------------------------------------------------------}
class procedure TCarbonWSWinControl.Invalidate(const AWinControl: TWinControl);
begin
if not WSCheckHandleAllocated(AWinControl, 'Invalidate') then Exit;
if not CheckHandle(AWinControl, Self, 'Invalidate') then Exit;
TCarbonWidget(AWinControl.Handle).Invalidate;
end;
@ -291,7 +291,7 @@ end;
------------------------------------------------------------------------------}
class procedure TCarbonWSWinControl.ShowHide(const AWinControl: TWinControl);
begin
if not WSCheckHandleAllocated(AWinControl, 'ShowHide') then Exit;
if not CheckHandle(AWinControl, Self, 'ShowHide') then Exit;
TCarbonWidget(AWinControl.Handle).ShowHide(AWinControl.Visible);
end;
@ -305,8 +305,8 @@ end;
------------------------------------------------------------------------------}
class procedure TCarbonWSWinControl.AddControl(const AControl: TControl);
begin
if not WSCheckHandleAllocated(AControl as TWinControl, 'AddControl') then Exit;
if not WSCheckHandleAllocated(AControl.Parent, 'AddControl Parent') then Exit;
if not CheckHandle(AControl as TWinControl, Self, 'AddControl') then Exit;
if not CheckHandle(AControl.Parent, Self, 'AddControl Parent') then Exit;
// add frame control to content area
HIViewAddSubview(TCarbonWidget(AControl.Parent.Handle).Content,
@ -322,9 +322,8 @@ end;
------------------------------------------------------------------------------}
class procedure TCarbonWSWinControl.DestroyHandle(const AWinControl: TWinControl);
begin
if not WSCheckHandleAllocated(AWinControl, 'DestroyHandle') then Exit;
if not CheckHandle(AWinControl, Self, 'DestroyHandle') then Exit;
DebugLn('TCarbonWSWinControl.DestroyHandle ', DbgSName(AWinControl));
TCarbonWidget(AWinControl.Handle).Free;
end;
@ -340,7 +339,7 @@ class function TCarbonWSWinControl.GetClientBounds(const AWinControl: TWinContro
var ARect: TRect): Boolean;
begin
Result := False;
if not WSCheckHandleAllocated(AWinControl, 'GetClientBounds') then Exit;
if not CheckHandle(AWinControl, Self, 'GetClientBounds') then Exit;
Result := TCarbonWidget(AWinControl.Handle).GetClientRect(ARect);
end;
@ -357,7 +356,7 @@ class function TCarbonWSWinControl.GetClientRect(const AWinControl: TWinControl;
var ARect: TRect): Boolean;
begin
Result := False;
if not WSCheckHandleAllocated(AWinControl, 'GetClientRect') then Exit;
if not CheckHandle(AWinControl, Self, 'GetClientRect') then Exit;
Result := TCarbonWidget(AWinControl.Handle).GetClientRect(ARect);
if Result then OffsetRect(ARect, -ARect.Left, -ARect.Top);

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

@ -36,7 +36,7 @@ uses
// libs
FPCMacOSAll,
// LCL
Controls, Dialogs, LCLType, LCLProc,
SysUtils, Controls, Dialogs, LCLType, LCLProc,
// widgetset
WSLCLClasses, WSProc, WSDialogs,
// interface
@ -57,6 +57,7 @@ type
private
protected
public
class procedure ShowModal(const ACommonDialog: TCommonDialog); override;
end;
{ TCarbonWSOpenDialog }
@ -111,6 +112,155 @@ type
implementation
{ TCarbonWSFileDialog }
{------------------------------------------------------------------------------
Method: TCarbonWSFileDialog.ShowModal
Params: ACommonDialog - LCL common dialog
Shows a file dialog (open, save, slect directory) in Carbon interface. Sets
ACommonDialog.UserChoice to mrOK or mrCancel. If mrOK, also sets
ACommonDialog.FileName to first file selected and adds file(s) selected to
ACommonDialog.Files.
------------------------------------------------------------------------------}
class procedure TCarbonWSFileDialog.ShowModal(const ACommonDialog: TCommonDialog);
{
Called by Execute method of TOpenDialog, TSaveDialog and TSelectDirectoryDialog.
TODO: Figure out how to use dialog's InitialDir property.
TODO: Figure out how to pass UPP of a custom filter callback function as
inFilterProc to NavCreateGetFileDialog and pass FileDialog as
inClientData so callback function can access dialog's Filter property.
}
var
FileDialog: TFileDialog;
CreationOptions: NavDialogCreationOptions;
DialogRef: NavDialogRef;
DialogReply: NavReplyRecord;
FileCount: Integer;
FileIdx: Integer;
Keyword: AEKeyword;
FileDesc: AEDesc;
FileRef: FSRef;
FileURL: CFURLRef;
FileCFStr: CFStringRef;
const AName = 'TCarbonWSFileDialog.ShowModal';
begin
{$IFDEF VerboseWSClass}
DebugLn('TCarbonWSFileDialog.ShowModal for ' + ACommonDialog.Name);
{$ENDIF}
FileDialog := ACommonDialog as TFileDialog;
// Initialize record to default values
if OSError(NavGetDefaultDialogCreationOptions(CreationOptions),
AName, 'NavGetDefaultDialogCreationOptions') then Exit;
if FileDialog.Title <> '' then // Override dialog's default title?
CreateCFString(FileDialog.Title, CreationOptions.windowTitle);
FileDialog.UserChoice := mrCancel; // Return this if user cancels or we need to exit
try
if FileDialog is TSaveDialog then
begin // Checking for TSaveDialog first since it's descendent of TOpenDialog
CreateCFString(ExtractFileName(FileDialog.FileName),
CreationOptions.saveFileName); // Note doesn't like path
if ofOverwritePrompt in TOpenDialog(FileDialog).Options then
CreationOptions.optionFlags :=
CreationOptions.optionFlags xor kNavDontConfirmReplacement
else
CreationOptions.optionFlags :=
CreationOptions.optionFlags or kNavDontConfirmReplacement;
// Create Save dialog
if OSError(NavCreatePutFileDialog(@CreationOptions, 0, 0, nil, nil,
DialogRef), AName, 'NavCreatePutFileDialog') then Exit;
end
else
if FileDialog is TSelectDirectoryDialog then // Create Choose folder dialog
begin
if OSError(NavCreateChooseFolderDialog(@CreationOptions, nil, nil, nil,
DialogRef), AName, 'NavCreateChooseFolderDialog') then Exit;
end
else
if FileDialog is TOpenDialog then
begin
if not (ofAllowMultiSelect in TOpenDialog(FileDialog).Options) then
CreationOptions.optionFlags :=
CreationOptions.optionFlags xor kNavAllowMultipleFiles
else
CreationOptions.optionFlags :=
CreationOptions.optionFlags or kNavAllowMultipleFiles;
// Create Open dialog
if OSError(NavCreateGetFileDialog(@CreationOptions, nil, nil, nil, nil,
nil, DialogRef), AName, 'NavCreateGetFileDialog') then Exit;
end;
try
// Display dialog
if OSError(NavDialogRun(DialogRef), AName, 'NavDialogRun') then Exit;
if NavDialogGetUserAction(DialogRef) <> kNavUserActionCancel then // User OK?
begin
if OSError(NavDialogGetReply(DialogRef, DialogReply), AName,
'NavDialogGetReply') then Exit; // Get user's selection
if OSError(AECountItems(DialogReply.Selection, FileCount), AName,
'AECountItems') then Exit;
for FileIdx := 1 to FileCount do
begin
if OSError(AEGetNthDesc(DialogReply.Selection, FileIdx, typeFSRef,
@Keyword, FileDesc), AName, 'AEGetNthDesc') then Exit;
// Get file reference
if OSError(AEGetDescData(FileDesc, @FileRef, SizeOf(FSRef)), AName,
'AEGetDescData') then Exit;
if OSError(AEDisposeDesc(FileDesc), AName, 'AEDisposeDesc') then Exit;
FileURL := CFURLCreateFromFSRef(kCFAllocatorDefault, FileRef); // Get URL
FileCFStr := CFURLCopyFileSystemPath(FileURL, kCFURLPOSIXPathStyle); // Get path
FileDialog.Files.Add(CFStringToStr(FileCFStr));
FreeCFString(FileURL);
FreeCFString(FileCFStr);
// Note: Previous 5 lines replace next 2 lines and eliminate need
// to decide what size to make FileBuf array.
// See http://developer.apple.com/technotes/tn2002/tn2078.html
// FSRefMakePath(FileRef, @FileBuf, SizeOf(FileBuf)); {Get file path}
// FileDialog.Files.Add(string(FileBuf)); //FileBuf contains UTF8 C string
end;
FileDialog.FileName := FileDialog.Files.Strings[0];
if FileDialog is TSaveDialog then
FileDialog.FileName := FileDialog.FileName + PathDelim +
CFStringToStr(NavDialogGetSaveFileName(DialogRef));
{Note: Not at all clear from Apple docs that NavReplyRecord.Selection
returns only path to file's folder with Save dialog. Also, what they
mean by the "full file name" returned by NavDialogGetSaveFileName
must mean extension and not path to file's folder.}
// Dispose of data that record points to (?)
if OSError(NavDisposeReply(DialogReply), AName, 'NavDisposeReply') then
Exit;
FileDialog.UserChoice := mrOK;
end;
finally
NavDialogDispose(DialogRef); // Dispose of dialog
end;
finally
FreeCFString(CreationOptions.windowTitle);
FreeCFString(CreationOptions.saveFileName);
end;
end; {TCarbonWSFileDialog.ShowModal}
{ TCarbonWSColorDialog }
{------------------------------------------------------------------------------
@ -126,6 +276,10 @@ var
ColorInfo: ColorPickerInfo;
ColorDialog: TColorDialog;
begin
{$IFDEF VerboseWSClass}
DebugLn('TCarbonWSColorDialog.ShowModal for ' + ACommonDialog.Name);
{$ENDIF}
ACommonDialog.UserChoice := mrCancel;
ColorDialog := ACommonDialog as TColorDialog;
@ -141,13 +295,13 @@ begin
ColorInfo.colorProc := nil;
// ColorDialog.Title is ignored, ColorInfo.prompt is not shown anywhere
if PickColor(ColorInfo) = noErr then
if ColorInfo.newColorChosen then
begin
ColorDialog.Color := RGBColorToColor(
RGBColor(ColorInfo.theColor.color.rgb));
ACommonDialog.UserChoice := mrOK;
end;
if OSError(PickColor(ColorInfo), Self, 'ShowModal', 'PickColor') then Exit;
if ColorInfo.newColorChosen then
begin
ColorDialog.Color := RGBColorToColor(RGBColor(ColorInfo.theColor.color.rgb));
ACommonDialog.UserChoice := mrOK;
end;
end;
initialization
@ -159,7 +313,7 @@ initialization
// which actually implement something
////////////////////////////////////////////////////
// RegisterWSComponent(TCommonDialog, TCarbonWSCommonDialog);
// RegisterWSComponent(TFileDialog, TCarbonWSFileDialog);
RegisterWSComponent(TFileDialog, TCarbonWSFileDialog);
// RegisterWSComponent(TOpenDialog, TCarbonWSOpenDialog);
// RegisterWSComponent(TSaveDialog, TCarbonWSSaveDialog);
// RegisterWSComponent(TSelectDirectoryDialog, TCarbonWSSelectDirectoryDialog);

31
lcl/interfaces/carbon/carbonwsforms.pp
View File

@ -27,13 +27,13 @@ unit CarbonWSForms;
interface
uses
// libs
// Libs
FPCMacOSAll, CarbonUtils, CarbonExtra,
// LCL
Controls, Forms, Graphics, LCLType, LMessages, LCLProc, Classes,
// widgetset
// Widgetset
WSForms, WSLCLClasses, WSProc,
// interface
// Interface
CarbonDef, CarbonProc, CarbonPrivate,
CarbonWSControls;
@ -100,6 +100,7 @@ type
private
protected
public
class function CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): TLCLIntfHandle; override;
end;
{ TCarbonWSScreen }
@ -146,7 +147,7 @@ end;
------------------------------------------------------------------------------}
class procedure TCarbonWSCustomForm.CloseModal(const ACustomForm: TCustomForm);
begin
if not WSCheckHandleAllocated(ACustomForm, 'CloseModal') then Exit;
if not CheckHandle(ACustomForm, Self, 'CloseModal') then Exit;
FPCMacOSAll.SetWindowModality(AsWindowRef(ACustomForm.Handle),
kWindowModalityNone, nil);
@ -161,7 +162,7 @@ end;
------------------------------------------------------------------------------}
class procedure TCarbonWSCustomForm.ShowModal(const ACustomForm: TCustomForm);
begin
if not WSCheckHandleAllocated(ACustomForm, 'ShowModal') then Exit;
if not CheckHandle(ACustomForm, Self, 'ShowModal') then Exit;
SetWindowModality(AsWindowRef(ACustomForm.Handle),
kWindowModalityAppModal, nil);
@ -181,7 +182,7 @@ class procedure TCarbonWSCustomForm.SetBorderIcons(const AForm: TCustomForm;
var
AttrsSet, AttrsClear: WindowAttributes;
begin
if not WSCheckHandleAllocated(AForm, 'SetBorderIcons') then Exit;
if not CheckHandle(AForm, Self, 'SetBorderIcons') then Exit;
AttrsSet := 0;
AttrsClear := 0;
@ -211,6 +212,22 @@ begin
end;
{ TCarbonWSHintWindow }
{------------------------------------------------------------------------------
Method: TCarbonWSHintWindow.CreateHandle
Params: AWinControl - LCL control
AParams - Creation parameters
Returns: Handle to the window in Carbon interface
Creates new hint window in Carbon interface with the specified parameters
------------------------------------------------------------------------------}
class function TCarbonWSHintWindow.CreateHandle(const AWinControl: TWinControl;
const AParams: TCreateParams): TLCLIntfHandle;
begin
Result := TLCLIntfHandle(TCarbonHintWindow.Create(AWinControl, AParams));
end;
initialization
////////////////////////////////////////////////////
@ -225,7 +242,7 @@ initialization
// RegisterWSComponent(TFrame, TCarbonWSFrame);
RegisterWSComponent(TCustomForm, TCarbonWSCustomForm);
// RegisterWSComponent(TForm, TCarbonWSForm);
// RegisterWSComponent(THintWindow, TCarbonWSHintWindow);
RegisterWSComponent(THintWindow, TCarbonWSHintWindow);
// RegisterWSComponent(TScreen, TCarbonWSScreen);
// RegisterWSComponent(TApplicationProperties, TCarbonWSApplicationProperties);
////////////////////////////////////////////////////

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

@ -35,7 +35,15 @@ uses
////////////////////////////////////////////////////
// Menus,
////////////////////////////////////////////////////
WSMenus, WSLCLClasses;
// Libs
FPCMacOSAll, CarbonUtils, CarbonExtra,
// LCL
Controls, Forms, Menus, Graphics, LCLType, LMessages, LCLProc, Classes,
// Widgetset
WSMenus, WSLCLClasses,
// Interface
CarbonDef, CarbonProc, CarbonMenus,
CarbonWSControls;
type
@ -44,7 +52,19 @@ type
TCarbonWSMenuItem = class(TWSMenuItem)
private
protected
class function CheckMenuItem(const AMenuItem: TMenuItem;
const AMethodName: String; AParamName: String = ''): Boolean;
public
class procedure AttachMenu(const AMenuItem: TMenuItem); override;
class function CreateHandle(const AMenuItem: TMenuItem): HMENU; override;
class procedure DestroyHandle(const AMenuItem: TMenuItem); override;
class procedure SetCaption(const AMenuItem: TMenuItem; const ACaption: string); override;
class procedure SetShortCut(const AMenuItem: TMenuItem; const OldShortCut, NewShortCut: TShortCut); override;
class procedure SetVisible(const AMenuItem: TMenuItem; const Visible: boolean); override;
class function SetCheck(const AMenuItem: TMenuItem; const Checked: boolean): boolean; override;
class function SetEnable(const AMenuItem: TMenuItem; const Enabled: boolean): boolean; override;
class function SetRadioItem(const AMenuItem: TMenuItem; const RadioItem: boolean): boolean; override;
//class function SetRightJustify(const AMenuItem: TMenuItem; const Justified: boolean): boolean; override;
end;
{ TCarbonWSMenu }
@ -53,6 +73,7 @@ type
private
protected
public
class function CreateHandle(const AMenu: TMenu): HMENU; override;
end;
{ TCarbonWSMainMenu }
@ -69,11 +90,253 @@ type
private
protected
public
class procedure Popup(const APopupMenu: TPopupMenu; const X, Y: Integer); override;
end;
implementation
{ TCarbonWSMenu }
{------------------------------------------------------------------------------
Method: TCarbonWSMenu.CreateHandle
Params: AMenu - LCL menu
Returns: Handle to the menu in Carbon interface
Creates new menu in Carbon interface
------------------------------------------------------------------------------}
class function TCarbonWSMenu.CreateHandle(const AMenu: TMenu): HMENU;
begin
Result := HMENU(TCarbonMenu.Create(AMenu.Items, True));
end;
{ TCarbonWSMenuItem }
{------------------------------------------------------------------------------
Method: TCarbonWSMenu.CheckMenuItem
Params: AMenuItem - LCL menu item
AMethodName - Method name
AParamName - Param name
Returns: If the menu item is valid
------------------------------------------------------------------------------}
class function TCarbonWSMenuItem.CheckMenuItem(const AMenuItem: TMenuItem;
const AMethodName: String; AParamName: String): Boolean;
begin
if AMenuItem <> nil then
begin
if TObject(AMenuItem.Handle) is TCarbonMenu then
begin
{$IFDEF VerboseWSClass}
DebugLn(Self.ClassName + '.' + DbgText + ' ' + AParamName + ' for ' + AMenuItem.Name);
{$ENDIF}
Result := True;
end
else
begin
Result := False;
DebugLn(Self.ClassName + '.' + AMethodName + ' ' + AParamName + ' for ' +
AMenuItem.Name + ' failed: Handle ' +
DbgS(Integer(AMenuItem.Handle)) + ' is invalid!');
end;
end
else
begin
Result := False;
DebugLn(Self.ClassName + '.' + AMethodName + ' ' + AParamName + ' for ' +
AMenuItem.Name + ' failed: MenuItem is nil!');
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonWSMenuItem.AttachMenu
Params: AMenuItem - LCL menu item
Returns: Nothinh
Attaches menu item to its parent menu in Carbon interface
------------------------------------------------------------------------------}
class procedure TCarbonWSMenuItem.AttachMenu(const AMenuItem: TMenuItem);
begin
if not CheckMenuItem(AMenuItem, 'AttachMenu') then Exit;
if not CheckMenuItem(AMenuItem.Parent, 'AttachMenu', 'Parent') then Exit;
TCarbonMenu(AMenuItem.Parent.Handle).Add(TCarbonMenu(AMenuItem.Handle));
end;
{------------------------------------------------------------------------------
Method: TCarbonWSMenuItem.CreateHandle
Params: AMenuItem - LCL menu item
Returns: Handle to the menu item in Carbon interface
Creates new menu item in Carbon interface
------------------------------------------------------------------------------}
class function TCarbonWSMenuItem.CreateHandle(const AMenuItem: TMenuItem): HMENU;
begin
Result := HMENU(TCarbonMenu.Create(AMenuItem));
end;
{------------------------------------------------------------------------------
Method: TCarbonWSMenuItem.DestroyHandle
Params: AMenuItem - LCL menu item
Returns: Nothing
Destroys menu item in Carbon interface
------------------------------------------------------------------------------}
class procedure TCarbonWSMenuItem.DestroyHandle(const AMenuItem: TMenuItem);
begin
if not CheckMenuItem(AMenuItem, 'DestroyHandle') then Exit;
TCarbonMenu(AMenuItem.Handle).Free;
end;
{------------------------------------------------------------------------------
Method: TCarbonWSMenuItem.SetCaption
Params: AMenuItem - LCL menu item
ACaption - Menu item caption
Returns: Nothing
Sets the caption of menu item in Carbon interface
------------------------------------------------------------------------------}
class procedure TCarbonWSMenuItem.SetCaption(const AMenuItem: TMenuItem;
const ACaption: string);
begin
if not CheckMenuItem(AMenuItem, 'SetCaption') then Exit;
if not CheckMenuItem(AMenuItem.Parent, 'SetCaption', 'Parent') then Exit;
TCarbonMenu(AMenuItem.Handle).SetCaption(ACaption);
end;
{------------------------------------------------------------------------------
Method: TCarbonWSMenuItem.SetShortCut
Params: AMenuItem - LCL menu item
OldShortCut - Old shortcut
NewShortCut - New shortcut
Returns: Nothing
Sets the shortcut of menu item in Carbon interface
NOTE: only Command Key (ssCtrl) is supported
------------------------------------------------------------------------------}
class procedure TCarbonWSMenuItem.SetShortCut(const AMenuItem: TMenuItem;
const OldShortCut, NewShortCut: TShortCut);
var
Shift: TShiftState;
Key: Word;
begin
if not CheckMenuItem(AMenuItem, 'SetShortCut') then Exit;
if not CheckMenuItem(AMenuItem.Parent, 'SetShortCut', 'Parent') then Exit;
ShortCutToKey(NewShortCut, Key, Shift);
if not (ssCtrl in Shift) then
DebugLn('Note: Carbon menus supports only shortcuts with Ctrl!');
SetMenuItemCommandKey(AsMenuRef(AMenuItem.Parent.Handle),
AMenuItem.MenuIndex + 1, False, Key);
end;
{------------------------------------------------------------------------------
Method: TCarbonWSMenuItem.SetVisible
Params: AMenuItem - LCL menu item
Visible - Menu item visibility
Returns: Nothing
Sets the visibility of menu item in Carbon interface
------------------------------------------------------------------------------}
class procedure TCarbonWSMenuItem.SetVisible(const AMenuItem: TMenuItem;
const Visible: boolean);
begin
if not CheckMenuItem(AMenuItem, 'SetVisible') then Exit;
if not CheckMenuItem(AMenuItem.Parent, 'SetVisible', 'Parent') then Exit;
TCarbonMenu(AMenuItem.Handle).SetVisible(Visible);
end;
{------------------------------------------------------------------------------
Method: TCarbonWSMenuItem.SetCheck
Params: AMenuItem - LCL menu item
Checked - Menu item checked
Returns: If the function succeeds
Sets the check of menu item in Carbon interface
------------------------------------------------------------------------------}
class function TCarbonWSMenuItem.SetCheck(const AMenuItem: TMenuItem;
const Checked: boolean): boolean;
begin
Result := False;
if not CheckMenuItem(AMenuItem, 'SetCheck') then Exit;
if not CheckMenuItem(AMenuItem.Parent, 'SetCheck', 'Parent') then Exit;
if AMenuItem.Checked then
begin
{if AMenuItem.RadioItem then
SetItemMark(AsMenuRef(AMenuItem.Parent.Handle), AMenuItem.MenuIndex + 1,
Char(kDiamondCharCode)) // or kBulletCharCode
else
SetItemMark(AsMenuRef(AMenuItem.Parent.Handle), AMenuItem.MenuIndex + 1,
Char(kCheckCharCode));}
end
else
if AMenuItem.Count = 0 then
SetItemMark(AsMenuRef(AMenuItem.Parent.Handle), AMenuItem.MenuIndex + 1, #0);
FPCMacOSAll.CheckMenuItem(AsMenuRef(AMenuItem.Parent.Handle), AMenuItem.MenuIndex + 1,
AMenuItem.Checked);
Result := True;
end;
{------------------------------------------------------------------------------
Method: TCarbonWSMenuItem.SetEnable
Params: AMenuItem - LCL menu item
Enabled - Menu item enabled
Returns: If the function succeeds
Sets the enabled of menu item in Carbon interface
TODO: disable menu bar items
------------------------------------------------------------------------------}
class function TCarbonWSMenuItem.SetEnable(const AMenuItem: TMenuItem;
const Enabled: boolean): boolean;
begin
Result := False;
if not CheckMenuItem(AMenuItem, 'SetEnable') then Exit;
if not CheckMenuItem(AMenuItem.Parent, 'SetEnable', 'Parent') then Exit;
TCarbonMenu(AMenuItem.Handle).SetEnable(Enabled);
Result := True;
end;
{------------------------------------------------------------------------------
Method: TCarbonWSMenuItem.SetRadioItem
Params: AMenuItem - LCL menu item
RadioItem - Menu item has radio
Returns: If the function succeeds
Sets the radio behaviour of menu item in Carbon interface
------------------------------------------------------------------------------}
class function TCarbonWSMenuItem.SetRadioItem(const AMenuItem: TMenuItem;
const RadioItem: boolean): boolean;
begin
Result := SetCheck(AMenuItem, AMenuItem.Checked);
end;
{ TCarbonWSPopupMenu }
{------------------------------------------------------------------------------
Method: TCarbonWSPopupMenu.Popup
Params: APopupMenu - LCL popup menu
X, Y - Screen coordinates to popup
Returns: Nothing
Creates new menu in Carbon interface
------------------------------------------------------------------------------}
class procedure TCarbonWSPopupMenu.Popup(const APopupMenu: TPopupMenu; const X,
Y: integer);
begin
if not CheckMenu(APopupMenu.Handle, 'TCarbonWSPopupMenu.Popup') then Exit;
PopUpMenuSelect(AsMenuRef(APopupMenu.Handle), Y, X, 0);
end; // ^- order top, left is correct!
initialization
////////////////////////////////////////////////////
@ -82,9 +345,9 @@ initialization
// To improve speed, register only classes
// which actually implement something
////////////////////////////////////////////////////
// RegisterWSComponent(TMenuItem, TCarbonWSMenuItem);
// RegisterWSComponent(TMenu, TCarbonWSMenu);
RegisterWSComponent(TMenuItem, TCarbonWSMenuItem);
RegisterWSComponent(TMenu, TCarbonWSMenu);
// RegisterWSComponent(TMainMenu, TCarbonWSMainMenu);
// RegisterWSComponent(TPopupMenu, TCarbonWSPopupMenu);
RegisterWSComponent(TPopupMenu, TCarbonWSPopupMenu);
////////////////////////////////////////////////////
end.

74
lcl/interfaces/carbon/carbonwsstdctrls.pp
View File

@ -286,7 +286,7 @@ end;
------------------------------------------------------------------------------}
class procedure TCarbonWSScrollBar.SetParams(const AScrollBar: TCustomScrollBar);
begin
if not WSCheckHandleAllocated(AScrollBar, 'SetParams') then Exit;
if not CheckHandle(AScrollBar, Self, 'SetParams') then Exit;
TCarbonCustomBar(AScrollBar.Handle).SetData(AScrollBar.Position,
AScrollBar.Min, AScrollBar.Max, AScrollBar.PageSize);
@ -333,7 +333,7 @@ class function TCarbonWSCustomComboBox.GetSelStart(
const ACustomComboBox: TCustomComboBox): integer;
begin
Result := 0;
if not WSCheckHandleAllocated(ACustomComboBox, 'GetSelStart') then Exit;
if not CheckHandle(ACustomComboBox, Self, 'GetSelStart') then Exit;
TCarbonComboBox(ACustomComboBox.Handle).GetSelStart(Result);
end;
@ -347,7 +347,7 @@ class function TCarbonWSCustomComboBox.GetSelLength(
const ACustomComboBox: TCustomComboBox): integer;
begin
Result := 0;
if not WSCheckHandleAllocated(ACustomComboBox, 'GetSelLength') then Exit;
if not CheckHandle(ACustomComboBox, Self, 'GetSelLength') then Exit;
TCarbonComboBox(ACustomComboBox.Handle).GetSelLength(Result);
end;
@ -361,7 +361,7 @@ class function TCarbonWSCustomComboBox.GetItemIndex(
const ACustomComboBox: TCustomComboBox): integer;
begin
Result := -1;
if not WSCheckHandleAllocated(ACustomComboBox, 'GetItemIndex') then Exit;
if not CheckHandle(ACustomComboBox, Self, 'GetItemIndex') then Exit;
Result := TCarbonComboBox(ACustomComboBox.Handle).GetItemIndex;
end;
@ -375,7 +375,7 @@ class function TCarbonWSCustomComboBox.GetMaxLength(
const ACustomComboBox: TCustomComboBox): integer;
begin
Result := 0;
if not WSCheckHandleAllocated(ACustomComboBox, 'GetMaxLength') then Exit;
if not CheckHandle(ACustomComboBox, Self, 'GetMaxLength') then Exit;
Result := TCarbonComboBox(ACustomComboBox.Handle).MaxLength;
end;
@ -391,7 +391,7 @@ end;
class procedure TCarbonWSCustomComboBox.SetSelStart(
const ACustomComboBox: TCustomComboBox; NewStart: integer);
begin
if not WSCheckHandleAllocated(ACustomComboBox, 'SetSelStart') then Exit;
if not CheckHandle(ACustomComboBox, Self, 'SetSelStart') then Exit;
TCarbonComboBox(ACustomComboBox.Handle).SetSelStart(NewStart);
end;
@ -407,7 +407,7 @@ end;
class procedure TCarbonWSCustomComboBox.SetSelLength(
const ACustomComboBox: TCustomComboBox; NewLength: integer);
begin
if not WSCheckHandleAllocated(ACustomComboBox, 'SetSelLength') then Exit;
if not CheckHandle(ACustomComboBox, Self, 'SetSelLength') then Exit;
TCarbonComboBox(ACustomComboBox.Handle).SetSelLength(NewLength);
end;
@ -423,7 +423,7 @@ end;
class procedure TCarbonWSCustomComboBox.SetItemIndex(
const ACustomComboBox: TCustomComboBox; NewIndex: integer);
begin
if not WSCheckHandleAllocated(ACustomComboBox, 'SetItemIndex') then Exit;
if not CheckHandle(ACustomComboBox, Self, 'SetItemIndex') then Exit;
TCarbonComboBox(ACustomComboBox.Handle).SetItemIndex(NewIndex);
end;
@ -439,7 +439,7 @@ end;
class procedure TCarbonWSCustomComboBox.SetMaxLength(
const ACustomComboBox: TCustomComboBox; NewLength: integer);
begin
if not WSCheckHandleAllocated(ACustomComboBox, 'SetMaxLength') then Exit;
if not CheckHandle(ACustomComboBox, Self, 'SetMaxLength') then Exit;
// text is cropped in callback
TCarbonComboBox(ACustomComboBox.Handle).MaxLength := NewLength;
@ -454,7 +454,7 @@ class function TCarbonWSCustomComboBox.GetItems(
const ACustomComboBox: TCustomComboBox): TStrings;
begin
Result := nil;
if not WSCheckHandleAllocated(ACustomComboBox, 'GetItems') then Exit;
if not CheckHandle(ACustomComboBox, Self, 'GetItems') then Exit;
Result := TCarbonComboBoxStrings.Create(TCarbonComboBox(ACustomComboBox.Handle));
end;
@ -471,7 +471,7 @@ end;
class procedure TCarbonWSCustomComboBox.Sort(
const ACustomComboBox: TCustomComboBox; AList: TStrings; IsSorted: boolean);
begin
if not WSCheckHandleAllocated(ACustomComboBox, 'Sort') then Exit;
if not CheckHandle(ACustomComboBox, Self, 'Sort') then Exit;
TCarbonComboBoxStrings(AList).Sorted := IsSorted;
end;
@ -505,7 +505,7 @@ var
List: ListHandle;
begin
Result := 0;
if not WSCheckHandleAllocated(ACustomListBox, 'GetSelCount') then Exit;
if not CheckHandle(ACustomListBox, Self, 'GetSelCount') then Exit;
List := TCarbonListBox(ACustomListBox.Handle).List;
Item.h := 0;
@ -529,7 +529,7 @@ var
Item: Cell;
begin
Result := False;
if not WSCheckHandleAllocated(ACustomListBox, 'GetSelected') then Exit;
if not CheckHandle(ACustomListBox, Self, 'GetSelected') then Exit;
Item.h := 0;
Item.v := AIndex;
@ -545,7 +545,7 @@ class function TCarbonWSCustomListBox.GetStrings(
const ACustomListBox: TCustomListBox): TStrings;
begin
Result := nil;
if not WSCheckHandleAllocated(ACustomListBox, 'GetStrings') then Exit;
if not CheckHandle(ACustomListBox, Self, 'GetStrings') then Exit;
Result := TCarbonListBoxStrings.Create(TCarbonListBox(ACustomListBox.Handle));
end;
@ -559,7 +559,7 @@ class function TCarbonWSCustomListBox.GetItemIndex(
const ACustomListBox: TCustomListBox): integer;
begin
Result := -1;
if not WSCheckHandleAllocated(ACustomListBox, 'GetItemIndex') then Exit;
if not CheckHandle(ACustomListBox, Self, 'GetItemIndex') then Exit;
Result := TCarbonListBox(ACustomListBox.Handle).GetItemIndex;
end;
@ -575,7 +575,7 @@ var
Bounds: FPCMacOSAll.Rect;
begin
Result := 0;
if not WSCheckHandleAllocated(ACustomListBox, 'GetTopIndex') then Exit;
if not CheckHandle(ACustomListBox, Self, 'GetTopIndex') then Exit;
if GetListViewBounds(TCarbonListBox(ACustomListBox.Handle).List,
Bounds) <> nil then Result := Bounds.top;
@ -596,7 +596,7 @@ class procedure TCarbonWSCustomListBox.SelectItem(
var
Item: Cell;
begin
if not WSCheckHandleAllocated(ACustomListBox, 'SelectItem') then Exit;
if not CheckHandle(ACustomListBox, Self, 'SelectItem') then Exit;
Item.h := 0;
Item.v := AIndex;
@ -614,7 +614,7 @@ end;
class procedure TCarbonWSCustomListBox.SetItemIndex(
const ACustomListBox: TCustomListBox; const AIndex: integer);
begin
if not WSCheckHandleAllocated(ACustomListBox, 'SetItemIndex') then Exit;
if not CheckHandle(ACustomListBox, Self, 'SetItemIndex') then Exit;
TCarbonListBox(ACustomListBox.Handle).SetItemIndex(AIndex);
end;
@ -634,7 +634,7 @@ class procedure TCarbonWSCustomListBox.SetSelectionMode(
var
Options: OptionBits;
begin
if not WSCheckHandleAllocated(ACustomListBox, 'SetSelectionMode') then Exit;
if not CheckHandle(ACustomListBox, Self, 'SetSelectionMode') then Exit;
if AMultiSelect then
begin
@ -671,7 +671,7 @@ end;
class procedure TCarbonWSCustomListBox.SetSorted(
const ACustomListBox: TCustomListBox; AList: TStrings; ASorted: boolean);
begin
if not WSCheckHandleAllocated(ACustomListBox, 'SetSorted') then Exit;
if not CheckHandle(ACustomListBox, Self, 'SetSorted') then Exit;
TCarbonListBoxStrings(AList).Sorted := ASorted;
end;
@ -689,7 +689,7 @@ class procedure TCarbonWSCustomListBox.SetTopIndex(
var
Bounds: FPCMacOSAll.Rect;
begin
if not WSCheckHandleAllocated(ACustomListBox, 'SetTopIndex') then Exit;
if not CheckHandle(ACustomListBox, Self, 'SetTopIndex') then Exit;
if GetListViewBounds(TCarbonListBox(ACustomListBox.Handle).List,
Bounds) <> nil then
@ -724,7 +724,7 @@ end;
class function TCarbonWSCustomEdit.GetSelStart(const ACustomEdit: TCustomEdit): integer;
begin
Result := 0;
if not WSCheckHandleAllocated(ACustomEdit, 'GetSelStart') then Exit;
if not CheckHandle(ACustomEdit, Self, 'GetSelStart') then Exit;
TCarbonEdit(ACustomEdit.Handle).GetSelStart(Result);
end;
@ -737,7 +737,7 @@ end;
class function TCarbonWSCustomEdit.GetSelLength(const ACustomEdit: TCustomEdit): integer;
begin
Result := 0;
if not WSCheckHandleAllocated(ACustomEdit, 'GetSelLength') then Exit;
if not CheckHandle(ACustomEdit, Self, 'GetSelLength') then Exit;
TCarbonEdit(ACustomEdit.Handle).GetSelLength(Result);
end;
@ -781,7 +781,7 @@ end;
class procedure TCarbonWSCustomEdit.SetMaxLength(const ACustomEdit: TCustomEdit;
NewLength: integer);
begin
if not WSCheckHandleAllocated(ACustomEdit, 'SetMaxLength') then Exit;
if not CheckHandle(ACustomEdit, Self, 'SetMaxLength') then Exit;
// text is cropped in callback
TCarbonEdit(ACustomEdit.Handle).MaxLength := NewLength;
@ -798,7 +798,7 @@ end;
class procedure TCarbonWSCustomEdit.SetPasswordChar(const ACustomEdit: TCustomEdit;
NewChar: char);
begin
if not WSCheckHandleAllocated(ACustomEdit, 'SetPasswordChar') then Exit;
if not CheckHandle(ACustomEdit, Self, 'SetPasswordChar') then Exit;
if TCarbonEdit(ACustomEdit.Handle).IsPassword <> (NewChar <> #0) then
RecreateWnd(ACustomEdit);
@ -815,7 +815,7 @@ end;
class procedure TCarbonWSCustomEdit.SetReadOnly(const ACustomEdit: TCustomEdit;
NewReadOnly: boolean);
begin
if not WSCheckHandleAllocated(ACustomEdit, 'SetReadOnly') then Exit;
if not CheckHandle(ACustomEdit, Self, 'SetReadOnly') then Exit;
SetControlData(AsControlRef(ACustomEdit.Handle), kControlEntireControl,
kControlEditTextLockedTag, SizeOf(Boolean), @NewReadOnly);
@ -832,7 +832,7 @@ end;
class procedure TCarbonWSCustomEdit.SetSelStart(const ACustomEdit: TCustomEdit;
NewStart: integer);
begin
if not WSCheckHandleAllocated(ACustomEdit, 'SetSelStart') then Exit;
if not CheckHandle(ACustomEdit, Self, 'SetSelStart') then Exit;
TCarbonEdit(ACustomEdit.Handle).SetSelStart(NewStart);
end;
@ -848,7 +848,7 @@ end;
class procedure TCarbonWSCustomEdit.SetSelLength(const ACustomEdit: TCustomEdit;
NewLength: integer);
begin
if not WSCheckHandleAllocated(ACustomEdit, 'SetSelLength') then Exit;
if not CheckHandle(ACustomEdit, Self, 'SetSelLength') then Exit;
TCarbonEdit(ACustomEdit.Handle).SetSelLength(NewLength);
end;
@ -878,7 +878,7 @@ class function TCarbonWSCustomMemo.GetStrings(const ACustomMemo: TCustomMemo
): TStrings;
begin
Result := nil;
if not WSCheckHandleAllocated(ACustomMemo, 'GetStrings') then Exit;
if not CheckHandle(ACustomMemo, Self, 'GetStrings') then Exit;
Result := TCarbonMemoStrings.Create(TCarbonMemo(ACustomMemo.Handle));
end;
@ -896,7 +896,7 @@ class procedure TCarbonWSCustomMemo.AppendText(const ACustomMemo: TCustomMemo;
var
S: String;
begin
if not WSCheckHandleAllocated(ACustomMemo, 'AppendText') then Exit;
if not CheckHandle(ACustomMemo, Self, 'AppendText') then Exit;
if Length(AText) > 0 then
begin
@ -916,7 +916,7 @@ end;
class procedure TCarbonWSCustomMemo.SetPasswordChar(
const ACustomEdit: TCustomEdit; NewChar: char);
begin
if not WSCheckHandleAllocated(ACustomEdit, 'SetPasswordChar') then Exit;
if not CheckHandle(ACustomEdit, Self, 'SetPasswordChar') then Exit;
TXNEchoMode(HITextViewGetTXNObject(AsControlRef(ACustomEdit.Handle)),
UniChar(NewChar), CreateTextEncoding(kTextEncodingUnicodeDefault,
@ -936,7 +936,7 @@ end;
class procedure TCarbonWSCustomMemo.SetScrollbars(
const ACustomMemo: TCustomMemo; const NewScrollbars: TScrollStyle);
begin
if not WSCheckHandleAllocated(ACustomMemo, 'SetScrollbars') then Exit;
if not CheckHandle(ACustomMemo, Self, 'SetScrollbars') then Exit;
TCarbonMemo(ACustomMemo.Handle).ScrollBars := NewScrollbars;
end;
@ -955,7 +955,7 @@ var
Tag: TXNControlTag;
Data: TXNControlData;
begin
if not WSCheckHandleAllocated(ACustomEdit, 'SetReadOnly') then Exit;
if not CheckHandle(ACustomEdit, Self, 'SetReadOnly') then Exit;
Tag := kTXNNoUserIOTag;
if NewReadOnly then
@ -981,7 +981,7 @@ var
Tag: TXNControlTag;
Data: TXNControlData;
begin
if not WSCheckHandleAllocated(ACustomMemo, 'SetWordWrap') then Exit;
if not CheckHandle(ACustomMemo, Self, 'SetWordWrap') then Exit;
Tag := kTXNWordWrapStateTag;
if NewWordWrap then
@ -1022,7 +1022,7 @@ class function TCarbonWSCustomCheckBox.RetrieveState(
const ACustomCheckBox: TCustomCheckBox): TCheckBoxState;
begin
Result := cbUnchecked;
if not WSCheckHandleAllocated(ACustomCheckBox, 'RetrieveState') then Exit;
if not CheckHandle(ACustomCheckBox, Self, 'RetrieveState') then Exit;
case GetControl32BitValue(AsControlRef(ACustomCheckBox.Handle)) of
kControlCheckBoxCheckedValue : Result := cbChecked;
@ -1044,7 +1044,7 @@ class procedure TCarbonWSCustomCheckBox.SetState(
var
Value: UInt32;
begin
if not WSCheckHandleAllocated(ACustomCheckBox, 'SetState') then Exit;
if not CheckHandle(ACustomCheckBox, Self, 'SetState') then Exit;
case NewState of
cbChecked : Value := kControlCheckBoxCheckedValue;
@ -1117,7 +1117,7 @@ class procedure TCarbonWSCustomStaticText.SetAlignment(
var
FontStyle: ControlFontStyleRec;
begin
if not WSCheckHandleAllocated(ACustomStaticText, 'SetAlignment') then Exit;
if not CheckHandle(ACustomStaticText, Self, 'SetAlignment') then Exit;
// get static text font style and change only justification
GetControlData(AsControlRef(ACustomStaticText.Handle), kControlEntireControl,