{ $Id$ -------------------------------------------- carbonedits.pp - Carbon edit-like controls -------------------------------------------- ***************************************************************************** * * * This file is part of the Lazarus Component Library (LCL) * * * * See the file COPYING.modifiedLGPL.txt, included in this distribution, * * for details about the copyright. * * * * This program is distributed in the hope that it will be useful, * * but WITHOUT ANY WARRANTY; without even the implied warranty of * * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * * ***************************************************************************** } unit CarbonEdits; {$mode objfpc}{$H+} interface // defines {$I carbondefines.inc} uses // rtl+ftl Types, Classes, SysUtils, Math, Contnrs, // carbon bindings MacOSAll, // LCL LMessages, LCLMessageGlue, LCLProc, LCLType, Graphics, Controls, StdCtrls, ExtCtrls, Spin, // widgetset WSControls, WSLCLClasses, WSProc, // LCL Carbon CarbonDef, CarbonPrivate, CarbonGDIObjects, CarbonProc, CarbonDbgConsts, CarbonUtils; type { TCarbonControlWithEdit } TCarbonControlWithEdit = class(TCarbonControl) private FMaxLength: Integer; protected procedure LimitTextLength; procedure AdaptCharCase; function GetEditPart: ControlPartCode; virtual; procedure RegisterEvents; override; public procedure TextDidChange; virtual; procedure AllowMenuProcess(MenuHotKey: AnsiChar; State: TShiftState; var AllowMenu: Boolean); override; public function GetPreferredSize: TPoint; override; function GetSelStart(var ASelStart: Integer): Boolean; virtual; function GetSelLength(var ASelLength: Integer): Boolean; virtual; function SetSelStart(ASelStart: Integer): Boolean; virtual; function SetSelLength(ASelLength: Integer): Boolean; virtual; function GetText(var S: String): Boolean; override; function SetText(const S: String): Boolean; override; public property MaxLength: Integer read FMaxLength write FMaxLength; procedure SetReadOnly(AReadOnly: Boolean); virtual; end; { TCarbonComboBox } TCarbonComboBox = class(TCarbonControlWithEdit) private FItemIndex: Integer; FReadOnly: Boolean; FPopupMenu: MenuRef; FTimer: TTimer; FLastDroppedDown: Boolean; procedure DropDownTimer(Sender: TObject); // there is no drop down nor close up event in Carbon, we must check it with timer protected procedure RegisterEvents; override; procedure CreateWidget(const AParams: TCreateParams); override; procedure DestroyWidget; override; function GetEditPart: ControlPartCode; override; function GetPopupButtonMenu: MenuRef; public class function GetValidEvents: TCarbonControlEvents; override; procedure ListItemSelected(AIndex: Integer); virtual; procedure ValueChanged; override; procedure FocusSet; override; procedure TextDidChange; override; procedure BoundsChanged; override; public function GetText(var S: String): Boolean; override; function SetBounds(const ARect: TRect): Boolean; override; procedure SetReadOnly(AReadOnly: Boolean); override; function GetItemIndex: Integer; function SetItemIndex(AIndex: Integer): Boolean; procedure Insert(AIndex: Integer; const S: String); procedure Remove(AIndex: Integer); function DropDown(ADropDown: Boolean): Boolean; function IsDroppedDown: Boolean; end; { TCarbonCustomEdit } TCarbonCustomEdit = class(TCarbonControlWithEdit) public procedure SetPasswordChar(AChar: Char); virtual; abstract; function FilterKeyPress(SysKey: Boolean; const Char: TUTF8Char): Boolean; override; function GetCaretPos: TPoint; virtual; end; { TCarbonSpinEdit } TCarbonSpinEdit = class(TCarbonCustomEdit) private FUpDown: ControlRef; FValue: Double; FMin: Double; FMax: Double; FIncrement: Double; FDecimalPlaces: Integer; function UpDownThemeWidth: Integer; function FocusRectThemeOutset: Integer; function GetEditBounds(const ARect: HIRect): HIRect; function GetUpDownBounds(const ARect: HIRect): HIRect; protected procedure CreateWidget(const AParams: TCreateParams); override; procedure DestroyWidget; override; function GetFrame(Index: Integer): ControlRef; override; function GetFrameBounds(var ARect: TRect): Boolean; override; public class function GetFrameCount: Integer; override; class function GetValidEvents: TCarbonControlEvents; override; procedure TextDidChange; override; procedure DoAction(AControlPart: ControlPartCode); override; function SetBounds(const ARect: TRect): Boolean; override; procedure SetPasswordChar(AChar: Char); override; function SetText(const S: String): Boolean; override; public procedure UpdateControl; property Value: Double read FValue; end; { TCarbonEdit } TCarbonEdit = class(TCarbonCustomEdit) private FIsPassword : Boolean; // Native Carbon edit's bounds are changing "internal edit" control (not the frame) // // for this reason EditExtra* constants have been introduced. // // So the bounds of the frame a changed (for LCL compatibility); // // Howevr, GetFrameBounds cannot return correct value, if Bounds of the edit // // is smaller than EditExtraLeft + EditExtraRight, or EditExtraTop+EditExtraBottom // // Incorrect returned bounds is causes endless loop in LCL processing. // // For this reason "TooSmall" flag is introduced to return smaller size of the control // FTooSmall : Boolean; FSmallBounds : TRect; protected procedure CreateWidget(const AParams: TCreateParams); override; function GetFrameBounds(var r: TRect): Boolean; override; public procedure BoundsChanged; override; public function GetText(var S: String): Boolean; override; function SetText(const S: String): Boolean; override; function GetPreferredSize: TPoint; override; procedure SetPasswordChar(AChar: Char); override; function SetBounds(const ARect: TRect): Boolean; override; end; { TCarbonMemo } TCarbonMemo = class(TCarbonCustomEdit) private FScrollView: HIViewRef; FScrollBars: TScrollStyle; FDrawBorder: Boolean; FBorder: HIViewRef; procedure SetScrollBars(const AValue: TScrollStyle); protected function GetFrame(Index: Integer): ControlRef; override; procedure CreateWidget(const AParams: TCreateParams); override; procedure DestroyWidget; override; procedure GetLineOffset(AIndex: Integer; out AStart, AEnd: TXNOffset); function GetCreationOptions: TXNFrameOptions; virtual; function GetTXNSelection(var iStart, iEnd: Integer): Boolean; function SetTXNSelection(iStart, iEnd: Integer): Boolean; procedure RegisterEvents; override; public procedure BoundsChanged; override; procedure AllowMenuProcess(MenuHotKey: AnsiChar; State: TShiftState; var AllowMenu: Boolean); override; procedure TextDidChange; override; function GetTextObject: TXNObject; function FilterKeyPress(SysKey: Boolean; const Char: TUTF8Char): Boolean; override; procedure ProcessKeyEvent(const msg: TLMKey); override; function SetTXNControl(Tag: TXNControlTag; const Data: TXNControlData): Boolean; public function GetSelStart(var ASelStart: Integer): Boolean; override; function GetSelLength(var ASelLength: Integer): Boolean; override; function SetSelStart(ASelStart: Integer): Boolean; override; function SetSelLength(ASelLength: Integer): Boolean; override; procedure SetAlignment(AAlignment: TAlignment); procedure SetColor(const AColor: TColor); override; procedure SetFont(const AFont: TFont); override; procedure SetPasswordChar(AChar: Char); override; procedure SetReadOnly(AReadOnly: Boolean); override; procedure SetWordWrap(AWordWrap: Boolean); virtual; function SetText(const S: String): Boolean; override; procedure SetBorderVisible(ABorderVisbile: Boolean); virtual; function SetBounds(const ARect: TRect): Boolean; override; public function GetLineCount: Integer; function GetLine(AIndex: Integer): String; procedure DeleteLine(AIndex: Integer); procedure InsertLine(AIndex: Integer; const S: String); function GetCaretPos: TPoint; override; public property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars; property Border: HIViewRef read FBorder; property ScrollView: HIViewRef read FScrollView; end; implementation // Edit's frame bounds cannot be received or set directly by using HIViewGetFrame/HIViewSetFrame // http://lists.apple.com/archives/carbon-dev/2009/Jul/msg00044.html // Region can be used, but constants are used instead const EditExtraTop = 3; EditExtraBottom = 3; EditExtraLeft = 3; EditExtraRight = 3; { TCarbonControlWithEdit } {------------------------------------------------------------------------------ Name: CarbonTextField_DidChange Handles text change ------------------------------------------------------------------------------} function CarbonTextField_DidChange(ANextHandler: EventHandlerCallRef; AEvent: EventRef; AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} begin {$IFDEF VerboseControlEvent} DebugLn('CarbonTextField_DidChange: ', DbgSName(AWidget.LCLObject)); {$ENDIF} Result := CallNextEventHandler(ANextHandler, AEvent); (AWidget as TCarbonControlWithEdit).TextDidChange; end; {------------------------------------------------------------------------------ Method: TCarbonControlWithEdit.LimitTextLength Limits the text length to maximum length ------------------------------------------------------------------------------} procedure TCarbonControlWithEdit.LimitTextLength; var S: String; R: Boolean; SelStart: Integer; begin if MaxLength > 0 then begin if GetText(S) then if UTF8Length(S) > MaxLength then begin R := GetSelStart(SelStart); S := UTF8Copy(S, 1, MaxLength); if SetText(S) then if R then SetSelStart(SelStart); end; end; end; {------------------------------------------------------------------------------ Method: TCarbonControlWithEdit.AdaptCharCase Change text char case ------------------------------------------------------------------------------} procedure TCarbonControlWithEdit.AdaptCharCase; begin // TODO end; {------------------------------------------------------------------------------ Method: TCarbonControlWithEdit.GetEditPart Returns: Control part code of edit control ------------------------------------------------------------------------------} function TCarbonControlWithEdit.GetEditPart: ControlPartCode; begin Result := kControlEntireControl; end; {------------------------------------------------------------------------------ Method: TCarbonControlWithEdit.RegisterEvents Registers event handlers for control with edit ------------------------------------------------------------------------------} procedure TCarbonControlWithEdit.RegisterEvents; var TmpSpec: EventTypeSpec; begin inherited RegisterEvents; if GetEditPart >= 0 then begin TmpSpec := MakeEventSpec(kEventClassTextField, kEventTextDidChange); InstallControlEventHandler(Widget, RegisterEventHandler(@CarbonTextField_DidChange), 1, @TmpSpec, Pointer(Self), nil); end; end; procedure TCarbonControlWithEdit.AllowMenuProcess(MenuHotKey: AnsiChar; State: TShiftState; var AllowMenu: Boolean); { These characters seems to be hardcoded by apple to Edit controls. } { It doesn't seem possible to change the hotkeys. Even if there're } { some menu available with the same hotkey, still focused control } { has a priority over the menu } const MacHotChars = ['a','A','c','C','v','V','x','X','z','Z']; begin AllowMenu:=not ( (State = [ssMeta]) and (MenuHotKey in MacHotChars)) ; end; {------------------------------------------------------------------------------ Method: TCarbonControlWithEdit.TextDidChange Text changed event handler ------------------------------------------------------------------------------} procedure TCarbonControlWithEdit.TextDidChange; var Msg: TLMessage; begin // limit the text according to MaxLength LimitTextLength; // set char case TODO AdaptCharCase; FillChar(Msg, SizeOf(Msg), 0); Msg.Msg := CM_TEXTCHANGED; DeliverMessage(LCLObject, Msg); end; {------------------------------------------------------------------------------ Method: TCarbonControlWithEdit.GetPreferredSize Returns: The preffered size of control for autosizing or (0, 0) ------------------------------------------------------------------------------} function TCarbonControlWithEdit.GetPreferredSize: TPoint; begin Result := inherited GetPreferredSize; Result.X := 0; // do not autosize width of edit like controls end; {------------------------------------------------------------------------------ Method: TCarbonControlWithEdit.GetSelStart Params: ASelStart - Selection start Returns: If the function suceeds Gets the selection start from the edit part of control ------------------------------------------------------------------------------} function TCarbonControlWithEdit.GetSelStart(var ASelStart: Integer): Boolean; var SelData: ControlEditTextSelectionRec; begin Result := False; ASelStart := 0; if GetEditPart < 0 then Exit; if OSError( GetControlData(ControlRef(Widget), GetEditPart, kControlEditTextSelectionTag, SizeOf(ControlEditTextSelectionRec), @SelData, nil), Self, 'GetSelStart', SGetData) then Exit; ASelStart := SelData.SelStart; Result := True; end; {------------------------------------------------------------------------------ Method: TCarbonControlWithEdit.GetSelLength Params: ASelLength - Selection length Returns: If the function suceeds Gets the selection length from the edit part of control ------------------------------------------------------------------------------} function TCarbonControlWithEdit.GetSelLength(var ASelLength: Integer): Boolean; var SelData: ControlEditTextSelectionRec; begin Result := False; ASelLength := 0; if GetEditPart < 0 then Exit; if OSError( GetControlData(ControlRef(Widget), GetEditPart, kControlEditTextSelectionTag, SizeOf(ControlEditTextSelectionRec), @SelData, nil), Self, 'GetSelLength', SGetData) then Exit; ASelLength := SelData.SelEnd - SelData.SelStart; Result := True; end; {------------------------------------------------------------------------------ Method: TCarbonControlWithEdit.SetSelStart Params: ASelStart - Selection start Returns: If the function suceeds Sets the selection start of the edit part of control ------------------------------------------------------------------------------} function TCarbonControlWithEdit.SetSelStart(ASelStart: Integer): Boolean; var SelData: ControlEditTextSelectionRec; const SName = 'SetSelStart'; begin Result := False; if GetEditPart < 0 then Exit; if OSError( GetControlData(ControlRef(Widget), GetEditPart, kControlEditTextSelectionTag, SizeOf(ControlEditTextSelectionRec), @SelData, nil), Self, SName, SGetData) then Exit; if SelData.SelStart = ASelStart then begin Result := True; Exit; end; SelData.SelEnd := (SelData.SelEnd - SelData.SelStart) + ASelStart; SelData.SelStart := ASelStart; if OSError( SetControlData(ControlRef(Widget), GetEditPart, kControlEditTextSelectionTag, SizeOf(ControlEditTextSelectionRec), @SelData), Self, SName, SSetData) then Exit; Result := True; end; {------------------------------------------------------------------------------ Method: TCarbonControlWithEdit.SetSelLength Params: ASelLength - Selection length Returns: If the function suceeds Sets the selection length of the edit part of control ------------------------------------------------------------------------------} function TCarbonControlWithEdit.SetSelLength(ASelLength: Integer): Boolean; var SelData: ControlEditTextSelectionRec; const SName = 'SetSelLength'; begin Result := False; if GetEditPart < 0 then Exit; if OSError( GetControlData(ControlRef(Widget), GetEditPart, kControlEditTextSelectionTag, SizeOf(ControlEditTextSelectionRec), @SelData, nil), Self, SName, SGetData) then Exit; if SelData.SelEnd = SelData.SelStart + ASelLength then begin Result := True; Exit; end; SelData.SelEnd := SelData.SelStart + ASelLength; if OSError( SetControlData(ControlRef(Widget), GetEditPart, kControlEditTextSelectionTag, SizeOf(ControlEditTextSelectionRec), @SelData), Self, SName, SSetData) then Exit; Result := True; end; {------------------------------------------------------------------------------ Method: TCarbonControlWithEdit.GetText Params: S - Text Returns: If the function succeeds Gets the text of edit control ------------------------------------------------------------------------------} function TCarbonControlWithEdit.GetText(var S: String): Boolean; var CFString: CFStringRef; begin Result := False; S := ''; if GetEditPart < 0 then Exit; if OSError( GetControlData(ControlRef(Widget), GetEditPart, kControlEditTextCFStringTag, SizeOf(CFStringRef), @CFString, nil), Self, SGetText, SGetData) then Exit; try S := CFStringToStr(CFString); Result := True; finally FreeCFString(CFString); end; end; {------------------------------------------------------------------------------ Method: TCarbonControlWithEdit.SetText Params: S - New text Returns: If the function succeeds Sets the text of edit control ------------------------------------------------------------------------------} function TCarbonControlWithEdit.SetText(const S: String): Boolean; var CFString: CFStringRef; Res : Boolean; utf8 : String; begin Result := False; if GetEditPart < 0 then Exit; CreateCFString(S, CFString); Res:=Assigned(CFString); if not Res then begin // the string contains utf8 invalid characters. trying to convert it to utf8 first utf8:=AnsiToUtf8(S); CreateCFString(utf8, CFString); Res:=Assigned(CFString); // if CFString cannot be created even for the converted string, clear the content and return False if not Res then CreateCFString('', CFString); end; try if OSError( SetControlData(ControlRef(Widget), GetEditPart, kControlEditTextCFStringTag, SizeOf(CFStringRef), @CFString), Self, SSetText, SSetData) then Exit; Result := Res; finally FreeCFString(CFString); end; end; {------------------------------------------------------------------------------ Method: TCarbonControlWithEdit.SetReadOnly Params: AReadOnly - Read only behavior Sets the read only behavior of edit control ------------------------------------------------------------------------------} procedure TCarbonControlWithEdit.SetReadOnly(AReadOnly: Boolean); begin if GetEditPart < 0 then Exit; OSError(SetControlData(ControlRef(Widget), GetEditPart, kControlEditTextLockedTag, SizeOf(Boolean), @AReadOnly), Self, 'SetReadOnly', SSetData); end; { TCarbonComboBox } {------------------------------------------------------------------------------ Name: CarbonComboBox_ListItemSelected Handles combo box list item change ------------------------------------------------------------------------------} function CarbonComboBox_ListItemSelected(ANextHandler: EventHandlerCallRef; AEvent: EventRef; AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} var Index: CFIndex; begin {$IFDEF VerboseControlEvent} DebugLn('CarbonComboBox_ListItemSelected: ', DbgSName(AWidget.LCLObject)); {$ENDIF} Result := CallNextEventHandler(ANextHandler, AEvent); // get selected item index if OSError( GetEventParameter(AEvent, kEventParamComboBoxListSelectedItemIndex, typeCFIndex, nil, SizeOf(CFIndex), nil, @Index), 'CarbonComboBox_ListItemSelected', SGetEvent, 'kEventParamComboBoxListSelectedItemIndex') then Index := -1; (AWidget as TCarbonComboBox).ListItemSelected(Index); end; {------------------------------------------------------------------------------ Name: CarbonComboBox_MenuOpening Handles combo box menu open event ------------------------------------------------------------------------------} function CarbonComboBox_MenuOpening(ANextHandler: EventHandlerCallRef; AEvent: EventRef; AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} begin {$IFDEF VerboseControlEvent} DebugLn('CarbonComboBox_MenuOpening: ', DbgSName(AWidget.LCLObject)); {$ENDIF} Result := CallNextEventHandler(ANextHandler, AEvent); LCLSendDropDownMsg(AWidget.LCLObject); end; {------------------------------------------------------------------------------ Name: CarbonComboBox_MenuClosed Handles combo box menu closed event ------------------------------------------------------------------------------} function CarbonComboBox_MenuClosed(ANextHandler: EventHandlerCallRef; AEvent: EventRef; AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} begin {$IFDEF VerboseControlEvent} DebugLn('CarbonComboBox_MenuClosed: ', DbgSName(AWidget.LCLObject)); {$ENDIF} Result := CallNextEventHandler(ANextHandler, AEvent); LCLSendCloseUpMsg(AWidget.LCLObject); end; procedure TCarbonComboBox.DropDownTimer(Sender: TObject); var D: Boolean; begin D := IsDroppedDown; if D <> FLastDroppedDown then begin FLastDroppedDown := D; if FLastDroppedDown then LCLSendDropDownMsg(LCLObject) else LCLSendCloseUpMsg(LCLObject); end; end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.RegisterEvents Registers event handlers for combo box ------------------------------------------------------------------------------} procedure TCarbonComboBox.RegisterEvents; var TmpSpec: EventTypeSpec; begin inherited RegisterEvents; TmpSpec := MakeEventSpec(kEventClassHIComboBox, kEventComboBoxListItemSelected); InstallControlEventHandler(Widget, RegisterEventHandler(@CarbonComboBox_ListItemSelected), 1, @TmpSpec, Pointer(Self), nil); end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.CreateWidget Params: AParams - Creation parameters Creates Carbon combo box ------------------------------------------------------------------------------} procedure TCarbonComboBox.CreateWidget(const AParams: TCreateParams); var CFString: CFStringRef; TmpSpec: EventTypeSpec; begin FReadOnly := (LCLObject as TCustomComboBox).ReadOnly; FLastDroppedDown := False; if FReadOnly then begin if OSError( CreatePopupButtonControl(GetTopParentWindow, ParamsToCarbonRect(AParams), nil, -12345, False, 0, popupTitleLeftJust, Normal, Widget), Self, SCreateWidget, 'CreatePopupButtonControl')then RaiseCreateWidgetError(LCLObject); OSError(CreateNewMenu(0, kMenuAttrAutoDisable, FPopupMenu), Self, SCreateWidget, 'CreateNewMenu'); TmpSpec := MakeEventSpec(kEventClassMenu, kEventMenuOpening); InstallMenuEventHandler(FPopupMenu, RegisterEventHandler(@CarbonComboBox_MenuOpening), 1, @TmpSpec, Pointer(Self), nil); TmpSpec := MakeEventSpec(kEventClassMenu, kEventMenuClosed); InstallMenuEventHandler(FPopupMenu, RegisterEventHandler(@CarbonComboBox_MenuClosed), 1, @TmpSpec, Pointer(Self), nil); OSError( SetControlData(ControlRef(Widget), kControlEntireControl, kControlPopupButtonOwnedMenuRefTag, SizeOf(MenuRef), @FPopupMenu), Self, SCreateWidget, SSetData); // count of popup button items is initially zero SetMaximum(0); end else begin CreateCFString(AParams.Caption, CFString); try if OSError(HIComboBoxCreate(ParamsToHIRect(AParams), CFString, nil, nil, kHIComboBoxAutoSizeListAttribute or kHIComboBoxAutoDisclosureAttribute, Widget), Self, SCreateWidget, 'HIComboBoxCreate')then RaiseCreateWidgetError(LCLObject); finally FreeCFString(CFString); end; FreeAndNil(FTimer); FTimer := TTimer.Create(nil); FTimer.Interval := 200; FTimer.OnTimer := @DropDownTimer; end; FItemIndex := -1; FMaxLength := 0; inherited; end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.DestroyWidget Destroys Carbon combo box ------------------------------------------------------------------------------} procedure TCarbonComboBox.DestroyWidget; begin if FReadOnly then DisposeMenu(FPopupMenu) else begin if FTimer.Enabled then DropDownTimer(nil); FTimer.Free; end; inherited DestroyWidget; end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.GetEditPart Returns: Control part code of edit control ------------------------------------------------------------------------------} function TCarbonComboBox.GetEditPart: ControlPartCode; begin if FReadOnly then Result := -1 else Result := kHIComboBoxEditTextPart; end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.GetPopupButtonMenu Returns: Popup Button menu ------------------------------------------------------------------------------} function TCarbonComboBox.GetPopupButtonMenu: MenuRef; begin Result := FPopupMenu; end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.GetValidEvents Returns: Set of events with installed handlers ------------------------------------------------------------------------------} class function TCarbonComboBox.GetValidEvents: TCarbonControlEvents; begin Result := inherited GetValidEvents + [cceValueChanged]; end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.ListItemSelected Params: AIndex - Index of selected item List item selected event handler ------------------------------------------------------------------------------} procedure TCarbonComboBox.ListItemSelected(AIndex: Integer); begin if FItemIndex <> AIndex then begin FItemIndex := AIndex; LCLSendSelectionChangedMsg(LCLObject); // Fire OnChange event LCLSendChangedMsg(LCLObject); end; end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.ValueChanged Value changed event handler ------------------------------------------------------------------------------} procedure TCarbonComboBox.ValueChanged; begin writeln('crb: ', LCLObject.Name,' value changed!'); if FReadOnly then ListItemSelected(GetValue - 1); end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.FocusSet Handles set focus ------------------------------------------------------------------------------} procedure TCarbonComboBox.FocusSet; begin inherited; // fire OnGetitems (LCLObject as TCustomComboBox).IntfGetItems; end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.TextDidChange Text changed event handler ------------------------------------------------------------------------------} procedure TCarbonComboBox.TextDidChange; begin inherited TextDidChange; // TComboBox needs LM_CHANGED message type SendSimpleMessage(LCLObject, LM_CHANGED); end; const // values are used from Interface Builder StdComboBoxNormalSize = 20; StdComboBoxSmallSize = 17; StdComboBoxTinySize = 0; // 14 StdPopupButtonNormalSize = 20; StdPopupButtonSmallSize = 17; StdPopupButtonTinySize = 0; // 16 procedure TCarbonComboBox.BoundsChanged; begin inherited BoundsChanged; if FReadOnly then SetControlViewStyle(Widget, StdPopupButtonTinySize, StdPopupButtonSmallSize, StdPopupButtonNormalSize) else SetControlViewStyle(Widget, StdComboBoxTinySize, StdComboBoxSmallSize, StdComboBoxNormalSize); end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.GetText Params: S - Text Returns: If the function succeeds Gets the text of combo box ------------------------------------------------------------------------------} function TCarbonComboBox.GetText(var S: String): Boolean; var ComboBox: TCustomComboBox; begin if FReadOnly then begin ComboBox := LCLObject as TCustomComboBox; if (FItemIndex >= 0) and (FItemIndex < ComboBox.Items.Count) then S := ComboBox.Items[FItemIndex] else S := ''; Result := True; end else Result := inherited GetText(S); end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.SetBounds Params: ARect - Record for control coordinates Returns: If function succeeds Sets the control bounding rectangle relative to the client origin of its parent ------------------------------------------------------------------------------} function TCarbonComboBox.SetBounds(const ARect: TRect): Boolean; var R: TRect; begin R := ARect; R.Bottom := R.Top + GetPreferredSize.Y; Result := inherited SetBounds(R); end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.SetReadOnly Params: AReadOnly - Read only behavior Sets the read only behavior of combo box ------------------------------------------------------------------------------} procedure TCarbonComboBox.SetReadOnly(AReadOnly: Boolean); begin if AReadOnly <> FReadOnly then RecreateWnd(LCLObject); end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.GetItemIndex Returns: The current item selected index ------------------------------------------------------------------------------} function TCarbonComboBox.GetItemIndex: Integer; begin Result := FItemIndex; end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.SetItemIndex Params: AIndex - New item index Changes currently selected item ------------------------------------------------------------------------------} function TCarbonComboBox.SetItemIndex(AIndex: Integer): Boolean; begin Result := False; //DebugLn('TCarbonComboBox.SetItemIndex New: ' + DbgS(AIndex) + ' Prev: ' + DbgS(FItemIndex)); if AIndex <> FItemIndex then begin if FReadOnly then SetValue(AIndex + 1) else begin if AIndex = -1 then begin FItemIndex := -1; Result := SetText(''); end else begin FItemIndex := AIndex; Result := SetText((LCLObject as TCustomComboBox).Items[AIndex]); end; end; end else Result := True; end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.Insert Params: AIndex - Item index S - Item text Inserts item with the specified text at index ------------------------------------------------------------------------------} procedure TCarbonComboBox.Insert(AIndex: Integer; const S: String); var CFString: CFStringRef; begin CreateCFString(S, CFString); try if FReadOnly then begin OSError(InsertMenuItemTextWithCFString(GetPopupButtonMenu, CFString, AIndex, kMenuItemAttrIgnoreMeta, 0), Self, 'Inset', 'InsertMenuItemTextWithCFString'); SetMaximum((LCLObject as TCustomComboBox).Items.Count); end else begin OSError(HIComboBoxInsertTextItemAtIndex(HIViewRef(Widget), AIndex, CFString), Self, 'Insert', 'HIComboBoxInsertTextItemAtIndex'); end; finally FreeCFString(CFString); end; end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.Remove Params: AIndex - Item index Removes item with the specified index ------------------------------------------------------------------------------} procedure TCarbonComboBox.Remove(AIndex: Integer); begin if FReadOnly then begin DeleteMenuItem(GetPopupButtonMenu, AIndex + 1); SetMaximum((LCLObject as TCustomComboBox).Items.Count); end else begin OSError(HIComboBoxRemoveItemAtIndex(HIViewRef(Widget), AIndex), Self, 'Remove', 'HIComboBoxRemoveItemAtIndex'); end; end; {------------------------------------------------------------------------------ Method: TCarbonComboBox.DropDown Params: ADropDown - Drop down Returns: If the function succeeds Shows or hides drop down list ------------------------------------------------------------------------------} function TCarbonComboBox.DropDown(ADropDown: Boolean): Boolean; begin Result := False; if FReadOnly then begin //P := LCLObject.ClientToScreen(Classes.Point(0, 0)); //PopUpMenuSelect(FPopupMenu, P.Y, P.X, FItemIndex + 1); DebugLn('TCarbonComboBox.DropDown for DropDownList TODO'); Exit; end; if OSError(HIComboBoxSetListVisible(ControlRef(Widget), ADropDown), Self, 'DropDown', 'HIComboBoxSetListVisible') then Exit; Result := True; end; function TCarbonComboBox.IsDroppedDown: Boolean; begin Result := HIComboBoxIsListVisible(ControlRef(Widget)); end; { TCarbonCustomEdit } {------------------------------------------------------------------------------ Method: TCarbonCustomEdit.FilterKeyPress Filters key presses from being send to Carbon control ------------------------------------------------------------------------------} function TCarbonCustomEdit.FilterKeyPress(SysKey: Boolean; const Char: TUTF8Char): Boolean; begin Result := (Char = #13); end; function TCarbonCustomEdit.GetCaretPos: TPoint; var x : Integer; begin Result.Y := 0; if not GetSelStart(x) then x := 0; Result.X := x; end; { TCarbonSpinEdit } {------------------------------------------------------------------------------ Method: TCarbonSpinEdit.UpDownThemeWidth Returns: UpDown theme width ------------------------------------------------------------------------------} function TCarbonSpinEdit.UpDownThemeWidth: Integer; begin Result := GetCarbonThemeMetric(kThemeMetricLittleArrowsWidth, 13); end; {------------------------------------------------------------------------------ Method: TCarbonSpinEdit.FocusRectThemeOutset Returns: Focus rectangle theme outset ------------------------------------------------------------------------------} function TCarbonSpinEdit.FocusRectThemeOutset: Integer; begin Result := GetCarbonThemeMetric(kThemeMetricFocusRectOutset, 4); end; {------------------------------------------------------------------------------ Method: TCarbonSpinEdit.GetEditBounds Params: ARect - Bounding rect Returns: Bounding rect for edit ------------------------------------------------------------------------------} function TCarbonSpinEdit.GetEditBounds(const ARect: HIRect): HIRect; var H: Single; begin if LCLObject.AutoSize then begin // apply edit preffered height if autosize H := GetPreferredSize.y; if H = 0 then H := ARect.size.height; end else H := ARect.size.height; Result.origin.x := ARect.origin.x; Result.origin.y := ARect.origin.y + (ARect.size.height - H) / 2; Result.size.width := ARect.size.width - (UpDownThemeWidth + 2 * FocusRectThemeOutset); Result.size.height := H; end; {------------------------------------------------------------------------------ Method: TCarbonSpinEdit.GetUpDownBounds Params: ARect - Bounding rect Returns: Bounding rect for updown ------------------------------------------------------------------------------} function TCarbonSpinEdit.GetUpDownBounds(const ARect: HIRect): HIRect; begin Result.origin.x := ARect.origin.x + ARect.size.width - (UpDownThemeWidth); Result.origin.y := ARect.origin.y; Result.size.width := UpDownThemeWidth; Result.size.height := ARect.size.height; end; {------------------------------------------------------------------------------ Method: TCarbonSpinEdit.CreateWidget Params: AParams - Creation parameters Creates Carbon spin edit ------------------------------------------------------------------------------} procedure TCarbonSpinEdit.CreateWidget(const AParams: TCreateParams); var CFString: CFStringRef; const SingleLine: Boolean = True; begin CreateCFString(AParams.Caption, CFString); try if OSError( CreateEditUniCodeTextControl(GetTopParentWindow, HIRectToCarbonRect(GetEditBounds(ParamsToHIRect(AParams))), CFString, False, nil, Widget), Self, SCreateWidget, 'CreateEditUniCodeTextControl') then RaiseCreateWidgetError(LCLObject); finally FreeCFString(CFString); end; // set edit single line OSError( SetControlData(Widget, kControlEntireControl, kControlEditTextSingleLineTag, SizeOf(Boolean), @SingleLine), Self, SCreateWidget, SSetData); // bug: #14634 // for some reason, OSX 10.5, arrows don't work properly, with // value = 1, min = 0, max = 2. Only lower button is visually pressed (painted). // changed to: value = 0, min = -5, max = 5 if OSError( CreateLittleArrowsControl(GetTopParentWindow, HIRectToCarbonRect(GetUpDownBounds(ParamsToHIRect(AParams))), 0, -5, 5, 1, FUpDown), Self, SCreateWidget, 'CreateLittleArrowsControl') then RaiseCreateWidgetError(LCLObject); AddControlPart(FUpDown); inherited; UpdateControl; end; {------------------------------------------------------------------------------ Method: TCarbonSpinEdit.DestroyWidget Destroys Carbon spin edit ------------------------------------------------------------------------------} procedure TCarbonSpinEdit.DestroyWidget; begin DisposeControl(FUpDown); inherited; end; {------------------------------------------------------------------------------ Method: TCarbonSpinEdit.GetFrame Params: Frame index Returns: Frame area control ------------------------------------------------------------------------------} function TCarbonSpinEdit.GetFrame(Index: Integer): ControlRef; begin case Index of 0: Result := ControlRef(Widget); 1: Result := FUpDown; end; end; {------------------------------------------------------------------------------ Method: TCarbonSpinEdit.GetFrameBounds Params: ARect - Rectangle Returns: If function succeeds Returns the control bounding rectangle relative to the client origin of its parent ------------------------------------------------------------------------------} function TCarbonSpinEdit.GetFrameBounds(var ARect: TRect): Boolean; begin Result := False; if inherited GetFrameBounds(ARect) then begin // add updown width ARect.Right := ARect.Right + (UpDownThemeWidth + 2 * FocusRectThemeOutset); Result := True; end; end; {------------------------------------------------------------------------------ Method: TCarbonSpinEdit.GetFrameCount Returns: Count of control frames ------------------------------------------------------------------------------} class function TCarbonSpinEdit.GetFrameCount: Integer; begin Result := 2; end; {------------------------------------------------------------------------------ Method: TCarbonSpinEdit.GetValidEvents Returns: Set of events with installed handlers ------------------------------------------------------------------------------} class function TCarbonSpinEdit.GetValidEvents: TCarbonControlEvents; begin Result := inherited GetValidEvents + [cceDoAction]; end; {------------------------------------------------------------------------------ Method: TCarbonSpinEdit.TextDidChange Text changed event handler ------------------------------------------------------------------------------} procedure TCarbonSpinEdit.TextDidChange; begin FValue := (LCLObject as TCustomFloatSpinEdit).StrToValue( (LCLObject as TCustomFloatSpinEdit).Text); inherited TextDidChange; end; {------------------------------------------------------------------------------ Method: TCarbonSpinEdit.DoAction Params: AControlPart - Control part to perform the action Action event handler ------------------------------------------------------------------------------} procedure TCarbonSpinEdit.DoAction(AControlPart: ControlPartCode); begin case AControlPart of kControlUpButtonPart: FValue := FValue + FIncrement; kControlDownButtonPart: FValue := FValue - FIncrement; end; FValue := (LCLObject as TCustomFloatSpinEdit).GetLimitedValue(FValue); inherited SetText((LCLObject as TCustomFloatSpinEdit).ValueToStr(FValue)); inherited TextDidChange; end; {------------------------------------------------------------------------------ Method: TCarbonSpinEdit.SetBounds Params: ARect - Record for control coordinates Returns: If function succeeds Sets the control bounding rectangle relative to the client origin of its parent ------------------------------------------------------------------------------} function TCarbonSpinEdit.SetBounds(const ARect: TRect): Boolean; begin Result := False; if OSError( HIViewSetFrame(Widget, GetEditBounds(RectToCGRect(ARect))), Self, SSetBounds, SViewFrame) then Exit; if OSError(HIViewSetFrame(FUpDown, GetUpDownBounds(RectToCGRect(ARect))), Self, SSetBounds, SViewFrame) then Exit; Result := True; end; {------------------------------------------------------------------------------ Method: TCarbonSpinEdit.SetPasswordChar Params: AChar - New password char Sets the new password char of Carbon edit ------------------------------------------------------------------------------} procedure TCarbonSpinEdit.SetPasswordChar(AChar: Char); begin // not supported end; {------------------------------------------------------------------------------ Method: TCarbonControlWithEdit.SetText Params: S - New text Returns: If the function succeeds Sets the text of edit control ------------------------------------------------------------------------------} function TCarbonSpinEdit.SetText(const S: String): Boolean; begin FValue := (LCLObject as TCustomFloatSpinEdit).StrToValue(S); Result := inherited SetText(S); end; {------------------------------------------------------------------------------ Method: TCarbonSpinEdit.UpdateControl Updates the value, min, max and increment of Carbon spin edit ------------------------------------------------------------------------------} procedure TCarbonSpinEdit.UpdateControl; var SpinEdit: TCustomFloatSpinEdit; begin SpinEdit := (LCLObject as TCustomFloatSpinEdit); FValue := SpinEdit.Value; FMin := SpinEdit.MinValue; FMax := SpinEdit.MaxValue; FIncrement := SpinEdit.Increment; FDecimalPlaces := SpinEdit.DecimalPlaces; // update edit text inherited SetText((LCLObject as TCustomFloatSpinEdit).ValueToStr(FValue)); end; { TCarbonEdit } {------------------------------------------------------------------------------ Method: TCarbonEdit.CreateWidget Params: AParams - Creation parameters Creates Carbon edit ------------------------------------------------------------------------------} procedure TCarbonEdit.CreateWidget(const AParams: TCreateParams); var Edit: TCustomEdit; Control: ControlRef; CFString: CFStringRef; SingleLine: Boolean = True; begin Edit := LCLObject as TCustomEdit; CreateCFString(AParams.Caption, CFString); try if OSError( CreateEditUniCodeTextControl(GetTopParentWindow, ParamsToCarbonRect(AParams), CFString, (Edit.PasswordChar <> #0), nil, Control), Self, SCreateWidget, 'CreateEditUniCodeTextControl') then RaiseCreateWidgetError(LCLObject); Widget := Control; inherited; finally FreeCFString(CFString); end; // set edit single line OSError( SetControlData(Control, kControlEntireControl, kControlEditTextSingleLineTag, SizeOf(Boolean), @SingleLine), Self, SCreateWidget, SSetData); FIsPassword := Edit.PasswordChar <> #0; FMaxLength := Edit.MaxLength; end; const // values are used from Interface Builder StdEditNormalSize = 16; StdEditSmallSize = 13; StdEditTinySize = 0; // 9 procedure TCarbonEdit.BoundsChanged; begin inherited BoundsChanged; SetControlViewStyle(Widget, StdEditTinySize, StdEditSmallSize, StdEditNormalSize); end; {------------------------------------------------------------------------------ Method: TCarbonEdit.GetText Params: S - Text Returns: If the function succeeds Gets the text of edit control ------------------------------------------------------------------------------} function TCarbonEdit.GetText(var S: String): Boolean; var CFString: CFStringRef; begin if not FIsPassword then Result := inherited GetText(S) else begin Result := False; if OSError( GetControlData(ControlRef(Widget), GetEditPart, kControlEditTextPasswordCFStringTag, SizeOf(CFStringRef), @CFString, nil), Self, SGetText, SGetData) then Exit; try S := CFStringToStr(CFString); Result := True; finally FreeCFString(CFString); end; end; end; {------------------------------------------------------------------------------ Method: TCarbonEdit.SetText Params: S - New text Returns: If the function succeeds Sets the text of edit control ------------------------------------------------------------------------------} function TCarbonEdit.SetText(const S: String): Boolean; var CFString: CFStringRef; begin if not FIsPassword then Result := inherited SetText(S) else begin Result := False; CreateCFString(S, CFString); try if OSError( SetControlData(ControlRef(Widget), GetEditPart, kControlEditTextPasswordCFStringTag, SizeOf(CFStringRef), @CFString), Self, SSetText, SSetData) then Exit; Result := True; finally FreeCFString(CFString); end; end; end; function TCarbonEdit.GetPreferredSize: TPoint; begin Result:=inherited GetPreferredSize; inc(Result.Y, EditExtraBottom+EditExtraTop); end; {------------------------------------------------------------------------------ Method: TCarbonEdit.SetPasswordChar Params: AChar - New password char Sets the new password char of Carbon edit ------------------------------------------------------------------------------} procedure TCarbonEdit.SetPasswordChar(AChar: Char); begin if FIsPassword <> (AChar <> #0) then RecreateWnd(LCLObject); end; function TCarbonEdit.SetBounds(const ARect: TRect): Boolean; var r : TRect; begin r := ARect; inc(r.Top, EditExtraTop); dec(r.Bottom, EditExtraBottom); inc(r.Left, EditExtraLeft); dec(r.Right, EditExtraRight); FTooSmall:=(r.Right= GetLineCount then begin AStart := kTXNEndOffset; AEnd := kTXNEndOffset; Exit; end; O := HITextViewGetTXNObject(ControlRef(Widget)); if TXNDataSize(O) = 0 then Exit; if OSError(TXNGetLineMetrics(O, AIndex, W, H), Self, SName, 'TXNGetLineMetrics') then Exit; if OSError(TXNOffsetToHIPoint(O, 0, P), Self, SName, 'TXNOffsetToHIPoint') then Exit; LineTop := P.y + AIndex * Fix2X(H); LineBottom := LineTop + Fix2X(H); // find line offset with bisection TextStart := 0; TextEnd := TXNDataSize(O) div 2; repeat Line := (TextStart + TextEnd) div 2; if OSError(TXNOffsetToHIPoint(O, Line, P), Self, SName, 'TXNOffsetToHIPoint') then Exit; if P.y < LineTop then TextStart := Line + 1 else TextEnd := Line; if (P.y >= LineTop) and (P.y < LineBottom) then Break; until TextEnd < TextStart; LineTop := P.y; // find line start offset AStart := Line; while AStart > 0 do begin if OSError(TXNOffsetToHIPoint(O, AStart - 1, P), Self, SName, 'TXNOffsetToHIPoint') then Exit; if P.y <> LineTop then Break; Dec(AStart); end; // find line end offset AEnd := Line; TextEnd := TXNDataSize(O) div 2; while AEnd < TextEnd do begin if OSError(TXNOffsetToHIPoint(O, AEnd + 1, P), Self, SName, 'TXNOffsetToHIPoint') then Exit; if P.y <> LineTop then Break; Inc(AEnd); end; end; function TCarbonMemo.GetCreationOptions: TXNFrameOptions; begin Result := kTXNMonostyledTextMask // disable more font styles or kTXNDontDrawSelectionWhenInactiveMask // hide selection, when inactive or kOutputTextInUnicodeEncodingMask end; {------------------------------------------------------------------------------ Method: TCarbonMemo.TextDidChange Text changed event handler ------------------------------------------------------------------------------} procedure TCarbonMemo.TextDidChange; var Msg: TLMessage; begin // limit the text according to MaxLength LimitTextLength; AdaptCharCase; FillChar(Msg, SizeOf(Msg), 0); Msg.Msg := CM_TEXTCHANGED; DeliverMessage(LCLObject, Msg); end; function TCarbonMemo.GetTextObject: TXNObject; begin if not Assigned(Content) then Result := nil else Result := HITextViewGetTXNObject(Content); end; {------------------------------------------------------------------------------ Method: TCarbonMemo.SetTXNControl Params: Tag - Tag Data - Tag data Sets the control data of TXN object in Carbon interface ------------------------------------------------------------------------------} function TCarbonMemo.SetTXNControl(Tag: TXNControlTag; const Data: TXNControlData): Boolean; begin Result := False; if OSError(TXNSetTXNObjectControls(HITextViewGetTXNObject(ControlRef(Widget)), False, 1, @Tag, @Data), Self, 'SetTXNControl', SSetTXNControls) then Exit; Result := True; end; function TCarbonMemo.GetTXNSelection(var iStart, iEnd: Integer): Boolean; var ist, ien : TXNOffset; begin TXNGetSelection(HITextViewGetTXNObject(ControlRef(Widget)), ist, ien); iStart := Integer(ist); iEnd := Integer(ien); Result := true; end; function TCarbonMemo.SetTXNSelection(iStart, iEnd: Integer): Boolean; begin Result := not OSError( TXNSetSelection( HITextViewGetTXNObject(Widget), iStart, iEnd), Self, 'SetSelSTart', 'SetTXNSelection', ''); if Result then Invalidate(nil); end; procedure TCarbonMemo.BoundsChanged; var r : CGRect; begin inherited BoundsChanged; HIViewGetFrame(FBorder, r); if FDrawBorder then begin //todo: use themed metrics for TextFrame, instead of hard-coded values! r.origin.x:=1; r.origin.y:=1; r.size.width:=r.size.width-2; r.size.height:=r.size.height-2; end else begin r.origin.x:=0; r.origin.y:=0; end; HIViewSetFrame(FScrollView, r); end; function CarbonMemoBorder_Resized(ANextHandler: EventHandlerCallRef; AEvent: EventRef; AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} begin Result:=CallNextEventHandler(ANextHandler, AEvent); if Assigned(AWidget) then TCarbonMemo(AWidget).BoundsChanged; end; function CarbonMemoBorder_Draw(ANextHandler: EventHandlerCallRef; AEvent: EventRef; AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} var ctx : CGContextRef; cg : CGRect; clips : array [0..1] of CGRect; frm : HIThemeFrameDrawInfo; const ScrollSz = 16; begin Result:=CallNextEventHandler(ANextHandler, AEvent); if Assigned(AWidget) then begin if OSError( GetEventParameter(AEvent, kEventParamCGContextRef, typeCGContextRef, nil, SizeOf(CGContextRef), nil, @ctx), 'CarbonMemoBorder_Draw', SGetEvent, 'kEventParamCGContextRef') then Exit; if not Assigned(ctx) then Exit; HIViewGetBounds(TCarbonMemo(AWidget).FBorder, cg); cg.origin.x:=0.5; cg.origin.y:=0.5; cg.size.width:=cg.size.width-2; cg.size.height:=cg.size.height-1; if TCarbonMemo(AWidget).FDrawBorder then begin if TCarbonMemo(AWidget).ScrollBars in [ssBoth] then begin clips[0].origin.x:=0; clips[0].origin.y:=0; clips[0].size.width:=cg.size.width+2; clips[0].size.height:=cg.size.height-ScrollSz+1; clips[1].origin.x:=0; clips[1].origin.y:=cg.size.height-ScrollSz; clips[1].size.width:=cg.size.width-ScrollSz+2; clips[1].size.height:=ScrollSz+1; CGContextClipToRects(ctx, @clips, 2); end; FillChar(frm, sizeof(frm), 0); frm.kind:=kHIThemeFrameTextFieldSquare; frm.state:=kThemeStateActive; HIThemeDrawFrame( cg, frm, ctx, 0); end; end; end; procedure TCarbonMemo.RegisterEvents; var TmpSpec: EventTypeSpec; begin inherited RegisterEvents; if GetEditPart >= 0 then begin TmpSpec := MakeEventSpec(kEventClassControl, kEventControlBoundsChanged); InstallControlEventHandler(FBorder, RegisterEventHandler(@CarbonMemoBorder_Resized), 1, @TmpSpec, Pointer(Self), nil); TmpSpec := MakeEventSpec(kEventClassControl, kEventControlDraw); InstallControlEventHandler(FBorder, RegisterEventHandler(@CarbonMemoBorder_Draw), 1, @TmpSpec, Pointer(Self), nil); end; end; procedure TCarbonMemo.AllowMenuProcess(MenuHotKey: AnsiChar; State: TShiftState; var AllowMenu: Boolean); begin AllowMenu:=True; end; function TCarbonMemo.GetSelStart(var ASelStart: Integer): Boolean; var iEnd : Integer; begin Result := GetTXNSelection(ASelStart, iEnd); end; function TCarbonMemo.GetSelLength(var ASelLength: Integer): Boolean; var iStart : integer; begin Result := GetTXNSelection(iStart, ASelLength); dec(ASelLength, iStart); end; function TCarbonMemo.SetSelStart(ASelStart: Integer): Boolean; var iStart : integer; iEnd : integer; begin Result := GetTXNSelection(iStart, iEnd); if not Result then begin iStart := 0; iEnd := iStart; Result := true; end; Result := SetTXNSelection(ASelStart, ASelStart+iEnd-iStart); end; function TCarbonMemo.SetSelLength(ASelLength: Integer): Boolean; var iStart : integer; iEnd : integer; begin Result := GetTXNSelection(iStart, iEnd); if not Result then begin iStart := 0; Result := true; end; if ASelLength < 0 then iEnd := kTXNEndOffset else iEnd := iStart + ASelLength; Result := SetTXNSelection(iStart, iEnd); end; {------------------------------------------------------------------------------ Method: TCarbonMemo.SetAlignment Params: AAlignment - New alignment Sets the alignment of memo in Carbon interface ------------------------------------------------------------------------------} procedure TCarbonMemo.SetAlignment(AAlignment: TAlignment); var Data: TXNControlData; begin case AAlignment of taLeftJustify: Data.uValue := UInt32(kTXNFlushLeft); taRightJustify: Data.uValue := UInt32(kTXNFlushRight); taCenter: Data.uValue := UInt32(kTXNCenter); end; SetTXNControl(kTXNJustificationTag, Data); Invalidate; end; {------------------------------------------------------------------------------ Method: TCarbonMemo.SetColor Params: AColor - New color Sets the color of memo ------------------------------------------------------------------------------} procedure TCarbonMemo.SetColor(const AColor: TColor); var CGColor: CGColorRef; begin if AColor = clDefault then CGColor := CreateCGColor(LCLObject.GetDefaultColor(dctBrush)) else CGColor := CreateCGColor(AColor); try OSError(HITextViewSetBackgroundColor(HIViewRef(Widget), CGColor), Self, SSetColor, 'HITextViewSetBackgroundColor'); finally CGColorRelease(CGColor); end; end; {------------------------------------------------------------------------------ Method: TCarbonMemo.SetFont Params: AFont - New font Sets the font of memo ------------------------------------------------------------------------------} procedure TCarbonMemo.SetFont(const AFont: TFont); var Attrs: Array [0..3] of TXNTypeAttributes; FontColor: RGBColor; SavedStyle: ATSUStyle; const SName = 'SetFont'; begin // font name Attrs[0].tag := kATSUFontTag; Attrs[0].size := SizeOf(ATSUFontID); Attrs[0].data.dataValue := FindCarbonFontID(AFont.Name); // font color FontColor := ColorToRGBColor(AFont.Color); Attrs[1].tag := kTXNQDFontColorAttribute; Attrs[1].size := kTXNQDFontColorAttributeSize; Attrs[1].data.dataPtr := @FontColor; // font size Attrs[2].tag := kTXNQDFontSizeAttribute; Attrs[2].size := kTXNQDFontSizeAttributeSize; Attrs[2].data.dataValue := AFont.Size; ATSUCreateAndCopyStyle(TCarbonFont(AFont.Reference.Handle).Style, SavedStyle); try // set font color if AFont.Color = clDefault then TCarbonFont(AFont.Reference.Handle).SetColor(LCLObject.GetDefaultColor(dctFont)) else TCarbonFont(AFont.Reference.Handle).SetColor(AFont.Color); // font style Attrs[3].tag := kTXNATSUIStyle; Attrs[3].size := kTXNATSUIStyleSize; Attrs[3].data.dataPtr := Pointer(TCarbonFont(AFont.Reference.Handle).Style); // apply OSError( TXNSetTypeAttributes(HITextViewGetTXNObject(ControlRef(Widget)), 4, @Attrs[0], kTXNStartOffset, kTXNEndOffset), Self, SName, 'TXNSetTypeAttributes'); finally ATSUCopyAttributes(SavedStyle, TCarbonFont(AFont.Reference.Handle).Style); ATSUDisposeStyle(SavedStyle); end; // invalidate control Invalidate; end; {------------------------------------------------------------------------------ Method: TCarbonMemo.SetPasswordChar Params: AChar - New password char Sets the new password char of Carbon memo ------------------------------------------------------------------------------} procedure TCarbonMemo.SetPasswordChar(AChar: Char); begin OSError( TXNEchoMode(HITextViewGetTXNObject(ControlRef(Widget)), UniChar(AChar), CreateTextEncoding(kTextEncodingUnicodeDefault, kUnicodeNoSubset, kUnicodeUTF8Format), AChar <> #0), Self, 'SetPasswordChar', 'TXNEchoMode'); Invalidate; end; {------------------------------------------------------------------------------ Method: TCarbonMemo.SetReadOnly Params: AReadOnly - Read only behavior Sets the read only behavior of Carbon memo ------------------------------------------------------------------------------} procedure TCarbonMemo.SetReadOnly(AReadOnly: Boolean); var Data: TXNControlData; begin if AReadOnly then Data.uValue := UInt32(kTXNReadOnly) else Data.uValue := UInt32(kTXNReadWrite); SetTXNControl(kTXNNoUserIOTag, Data); end; {------------------------------------------------------------------------------ Method: TCarbonMemo.SetWordWrap Params: AWordWrap - New word wrap Sets the word wrap of Carbon memo ------------------------------------------------------------------------------} procedure TCarbonMemo.SetWordWrap(AWordWrap: Boolean); var Data: TXNControlData; begin if AWordWrap then Data.uValue := UInt32(kTXNAutoWrap) else Data.uValue := UInt32(kTXNNoAutoWrap); SetTXNControl(kTXNWordWrapStateTag, Data); Invalidate; end; function TCarbonMemo.SetText(const S: String): Boolean; begin Result:=inherited SetText(S); Invalidate; end; procedure TCarbonMemo.SetBorderVisible(ABorderVisbile:Boolean); begin FDrawBorder:=ABorderVisbile; BoundsChanged; end; function TCarbonMemo.SetBounds(const ARect:TRect):Boolean; var r : TRect; begin Result:=inherited SetBounds(ARect); BoundsChanged; GetBounds(r); end; {------------------------------------------------------------------------------ Method: TCarbonMemo.GetLineCount Returns: Memo line count ------------------------------------------------------------------------------} function TCarbonMemo.GetLineCount: Integer; var C: ItemCount; S: Integer; O: TXNObject; begin Result := 0; O := HITextViewGetTXNObject(ControlRef(Widget)); if not OSError(TXNGetLineCount(O, C), Self, 'GetLineCount', 'TXNGetLineCount') then begin Result := C; S := TXNDataSize(O); if S = 0 then Dec(Result); end; end; {------------------------------------------------------------------------------ Method: TCarbonMemo.GetLine Returns: Memo line text ------------------------------------------------------------------------------} function TCarbonMemo.GetLine(AIndex: Integer): String; var AStart, AEnd: TXNOffset; Data: MacOSAll.Handle; W: WideString; begin Result := ''; GetLineOffset(AIndex, AStart, AEnd); if OSError(TXNGetData(HITextViewGetTXNObject(ControlRef(Widget)), AStart, AEnd, Data), Self, 'GetLine', 'TXNGetData') then Exit; W := PWideChar(Data^); Result := UTF16ToUTF8(Copy(W, 0, GetHandleSize(Data) div 2)); // remove CRLF if (Result <> '') and (Result[Length(Result)] in [#10, #13]) then Delete(Result, Length(Result), 1); if (Result <> '') and (Result[Length(Result)] in [#10, #13]) then Delete(Result, Length(Result), 1); DisposeHandle(Data); end; {------------------------------------------------------------------------------ Method: TCarbonMemo.DeleteLine ------------------------------------------------------------------------------} procedure TCarbonMemo.DeleteLine(AIndex: Integer); var AStart, AEnd: TXNOffset; begin GetLineOffset(AIndex, AStart, AEnd); // remove line end if (AIndex = 0) and (GetLineCount > 1) then Inc(AEnd) else if AIndex > 0 then Dec(AStart); OSError(TXNSetData(HITextViewGetTXNObject(ControlRef(Widget)), kTXNUnicodeTextData, nil, 0, AStart, AEnd), Self, 'DeleteLine', 'TXNSetData'); end; {------------------------------------------------------------------------------ Method: TCarbonMemo.InsertLine ------------------------------------------------------------------------------} procedure TCarbonMemo.InsertLine(AIndex: Integer; const S: String); var AStart, AEnd: TXNOffset; W: WideString; const // Carbon Line ending should be MacOS classic rather than Unix compatible, see #16267 CarbonEoln = #13; begin if AIndex < 0 then AIndex := 0; W := UTF8ToUTF16(S); if GetLineCount = 0 then AStart := 0 else if AIndex < GetLineCount then begin GetLineOffset(AIndex, AStart, AEnd); W := W + CarbonEoln; end else begin GetLineOffset(GetLineCount - 1, AStart, AEnd); W := CarbonEoln + W; AStart := AEnd; end; OSError(TXNSetData(HITextViewGetTXNObject(ControlRef(Widget)), kTXNUnicodeTextData, @W[1], Length(W) * 2, AStart, AStart), Self, 'InsertLine', 'TXNSetData'); end; function TCarbonMemo.GetCaretPos: TPoint; var obj : TXNObject; r : HIRect; cnt : ItemCount; i, ly : Integer; yofs : Integer; fw,fh : Fixed; ofs : TXNOffset; ofs2 : TXNOffset; crtpnt : HIPoint; begin Result.X := 0; Result.Y := 0; obj:=HITextViewGetTXNObject(Widget); if not Assigned(obj) then Exit; {looking for the Y-pos} TXNGetHIRect(obj, kTXNTextRectKey, r); TXNGetSelection(obj, ofs, ofs2); TXNOffsetToHIPoint(obj, ofs, crtpnt); yofs := Round(crtpnt.y); TXNGetLineCount(obj, cnt); i := 0; ly := Round(r.origin.y); while (i < cnt) and (ly < yofs) do begin TXNGetLineMetrics(obj, i, fw, fh); inc(i); inc(ly, Fix2Long(fh)); end; Result.Y := i; {looking for the X-pos} crtpnt.X := 0; TXNHIPointToOffset(obj, crtpnt, ofs2); Result.X := ofs-ofs2; end; {------------------------------------------------------------------------------ Method: TCarbonMemo.FilterKeyPress Filters key presses from being send to Carbon control ------------------------------------------------------------------------------} function TCarbonMemo.FilterKeyPress(SysKey: Boolean; const Char: TUTF8Char): Boolean; begin Result := False; end; procedure TCarbonMemo.ProcessKeyEvent(const msg: TLMKey); var txn : TXNObject; begin // CarbonEdit does action on every LM_SYSKEYDOWN // But text view does copy/paste action only on LM_SYSUPDOWN (because HICommand is generated on KeyUp event) // to avoid double processing (on HICommand and KeyUP event), copy/paste operations should be done on KeyDown event... // this's actually LCL (win) memo emulation if (msg.Msg = CN_SYSKEYDOWN) then begin case msg.CharCode of VK_C: if (msg.KeyData and (MK_Shift or MK_Control) = 0) then begin txn := GetTextObject; if Assigned(txn) then TXNCopy(txn); end; VK_V: if (msg.KeyData and (MK_Shift or MK_Control) = 0) then begin txn := GetTextObject; if Assigned(txn) then TXNPaste(txn); end; VK_X: if (msg.KeyData and (MK_Shift or MK_Control) = 0) then begin txn := GetTextObject; if Assigned(txn) then TXNCut(txn); end; VK_Z: if ((msg.KeyData and MK_Control) = 0) then begin txn := GetTextObject; if Assigned(txn) then if msg.KeyData and MK_Shift > 0 then TXNRedo(txn) else TXNUndo(txn); end; end; {of case} end; end; end.