lazarus/lcl/interfaces/carbon/carbonlclintf.inc

{%MainUnit carbonint.pas}

{ $Id$ }
{******************************************************************************
  All Carbon interface communication implementations.
  This are the implementation of the overrides of the Carbon Interface for the
  methods defined in the
  lcl/include/lclintf.inc


  !! Keep alphabetical !!

 ******************************************************************************
 Implementation
 ******************************************************************************

 *****************************************************************************
 *                                                                           *
 *  This file is part of the Lazarus Component Library (LCL)                 *
 *                                                                           *
 *  See the file COPYING.modifiedLGPL, 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.                     *
 *                                                                           *
 *****************************************************************************
}

//##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
    AThemeCursor := CursorToThemeCursor[TCursor(ACursor)];
    if AThemeCursor <> kThemeUndefCursor then
      Result := hCursor(TCarbonCursor.CreateThemed(AThemeCursor,
        TCursor(ACursor) = crDefault));
  end;
  
  {$IFDEF VerboseLCLIntf}
    DebugLn('TCarbonWidgetSet.CreateStandardCursor Result: ' + DbgS(Result));
  {$ENDIF}
end;

{------------------------------------------------------------------------------
  Method:  DrawArrow
  Params:  Arrow  - LCL arrow
           Canvas - LCL canvas

  Draws the arrow on the specified canvas
 ------------------------------------------------------------------------------}
procedure TCarbonWidgetSet.DrawArrow(Arrow: TComponent; Canvas: TPersistent);
var
  ArrowCanvas: TCanvas;
  P: Array [0..2] of TPoint;
  R: TRect;
  S: Integer;
begin
  {$IFDEF VerboseLCLIntf}
    DebugLn('TCarbonWidgetSet.DrawArrow Arrow: ' + DbgS(Arrow));
  {$ENDIF}
  
  R := TControl(Arrow).ClientRect;
  InflateRect(R, -1, -1);
  // arrow bounds are square
  S := Min(R.Right - R.Left, R.Bottom - R.Top);
  R := Bounds((R.Left + R.Right - S) div 2, (R.Top + R.Bottom - S) div 2, S, S);

  ArrowCanvas := TCanvas(Canvas);
  ArrowCanvas.Brush.Color := clBlack;
  ArrowCanvas.Pen.Color := clBlack;
  
  case Ord(TArrow(Arrow).ArrowType) of
    0: // up
      begin
        P[0] := Classes.Point(R.Left, R.Bottom);
        P[1] := Classes.Point((R.Left + R.Right) div 2, R.Top);
        P[2] := R.BottomRight;
      end;
    1: // down
      begin
        P[0] := R.TopLeft;
        P[1] := Classes.Point(R.Right, R.Top);
        P[2] := Classes.Point((R.Left + R.Right) div 2, R.Bottom);
      end;
    2: // left
      begin
        P[0] := R.BottomRight;
        P[1] := Classes.Point(R.Left, (R.Top + R.Bottom) div 2);
        P[2] := Classes.Point(R.Right, R.Top);
      end;
    3: // right
      begin
        P[0] := R.TopLeft;
        P[1] := Classes.Point(R.Right, (R.Top + R.Bottom) div 2);
        P[2] := Classes.Point(R.Left, R.Bottom);
      end;
  end;
  
  ArrowCanvas.Polygon(P);
end;

function TCarbonWidgetSet.ExtUTF8Out(DC: HDC; X, Y: Integer; Options: Longint;
  Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean;
begin
  Result:=inherited ExtUTF8Out(DC, X, Y, Options, Rect, Str, Count, Dx);
end;

function TCarbonWidgetSet.FontCanUTF8(Font: HFont): boolean;
begin
  Result:=inherited FontCanUTF8(Font);
end;

function TCarbonWidgetSet.GetAcceleratorString(const AVKey: Byte;
  const AShiftState: TShiftState): String;
begin
  Result:=inherited GetAcceleratorString(AVKey, AShiftState);
end;

function TCarbonWidgetSet.GetControlConstraints(Constraints: TObject): boolean;
begin
  Result:=inherited GetControlConstraints(Constraints);
end;

{------------------------------------------------------------------------------
  Method:  GetDesignerDC
  Params:  WindowHandle - Handle of window
  Returns: Device context for window designer
 ------------------------------------------------------------------------------}
function TCarbonWidgetSet.GetDesignerDC(WindowHandle: HWND): HDC;
begin
  // TODO: create frontmost control for designer context
  Result := GetDC(WindowHandle);
end;

{------------------------------------------------------------------------------
  Method:  GetLCLOwnerObject
  Params:  Handle - Handle of window
  Returns: LCL control which has the specified widget
 ------------------------------------------------------------------------------}
function TCarbonWidgetSet.GetLCLOwnerObject(Handle: HWnd): TObject;
begin
  {$IFDEF VerboseLCLIntf}
    DebugLn('TCarbonWidgetSet.GetLCLOwnerObject Handle: ' + DbgS(Handle));
  {$ENDIF}
  
  Result := nil;
  if not CheckWidget(Handle, 'GetLCLOwnerObject') then Exit;
  
  Result := TCarbonWidget(Handle).LCLObject;
  
  {$IFDEF VerboseLCLIntf}
    DebugLn('TCarbonWidgetSet.GetLCLOwnerObject Result: ' + DbgS(Result));
  {$ENDIF}
end;

{------------------------------------------------------------------------------
  Method:  IntfSendsUTF8KeyPress
  Returns: If the interface sends UTF-8 key press events
 ------------------------------------------------------------------------------}
function TCarbonWidgetSet.IntfSendsUTF8KeyPress: boolean;
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;
                                           Buttons       : PLongInt;
                                           ButtonCount   : LongInt;
                                           DefaultIndex  : LongInt;
                                           EscapeResult  : LongInt) : LongInt;
 {Implements MessageDlg.
  Carbon's standard alert box only supports 3 buttons (plus optional
  help button).
  Note that alert's help button is not supported at this time since no help context
  is passed to this method.}
  
  // returns first found button ID from passed buttons in dialog buttons
  function FindButton(AButtons: Array of LongInt): LongInt;
  var
    I, J: Integer;
  begin
    for I := Low(AButtons) to High(AButtons) do
      for J := 0 to ButtonCount -1 do
      begin
        if AButtons[I] = Buttons[J] then
        begin
          Result := AButtons[I];
          Exit;
        end;
      end;
  end;
  
const
  ButtonCaption: Array [idButtonOk..idButtonNoToAll] of String =
    ('OK', 'Cancel', ''{Help}, 'Yes', 'No', 'Close', 'Abort', 'Retry', 'Ignore',
     'All', 'Yes To All', 'No To All');
{ 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
  are defined in .strings file.}
var
  ParamRec    : AlertStdCFStringAlertParamRec;
  CFString    : CFStringRef;
  ButtonID    : Integer;
  RightBtnID  : LongInt;
  MiddleBtnID : LongInt;
  LeftBtnID   : LongInt;
  CaptionStr  : CFStringRef;
  MessageStr  : CFStringRef;
  AlertCode   : AlertType;
  AlertRef    : DialogRef;
  AlertBtnIdx : DialogItemIndex;
  I: Integer;

const SName = 'PromptUser';
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 (FindButton([idButtonHelp]) > 0)) 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}
    
    Exit;
  end;

  {Initialize record}
  ParamRec.version := kStdCFStringAlertVersionOne;
  ParamRec.movable := True;
  ParamRec.helpButton := False;
  ParamRec.defaultText := nil;
  ParamRec.cancelText := nil;
  ParamRec.otherText := nil;
  ParamRec.defaultButton := kAlertStdAlertOKButton;  {Right button}
  ParamRec.cancelButton := kAlertStdAlertCancelButton;
  ParamRec.position := kWindowDefaultPosition;
  ParamRec.flags := 0; 

  {English defaults to use if no Localizable.strings translations to use}
  {Convert LCL "id" button values to Carbon values}

  ButtonID := 0;
  for I := 0 to ButtonCount - 1 do
  begin
    if Buttons[I] = idButtonHelp then ParamRec.helpButton := True
    else
    begin
      if (Buttons[I] < Low(ButtonCaption)) or (Buttons[I] > High(ButtonCaption)) then
      begin
        DebugLn('TCarbonWidgetSet.PromptUser Invalid button ID: ' + DbgS(Buttons[I]));
        Continue;
      end;
      
      CreateCFString(ButtonCaption[Buttons[I]], CFString);
      try
        case ButtonID of
          0: // set right button caption and result
            begin
              ParamRec.defaultText := CFCopyLocalizedString(CFString, nil);
              RightBtnID := Buttons[I];
            end;
          1: // set middle button caption and result
            begin
              ParamRec.cancelText := CFCopyLocalizedString(CFString, nil);
              MiddleBtnID := Buttons[I];
            end;
          2: // set left button caption and result
            begin
              ParamRec.otherText := CFCopyLocalizedString(CFString, nil);
              LeftBtnID := Buttons[I];
              
              // set cancel to left button if exists
              ParamRec.cancelButton := kAlertStdAlertOtherButton;
            end;
        end;
      finally
        FreeCFString(CFString);
      end;
      
      Inc(ButtonID);
    end;
  end;

  CreateCFString(DialogCaption, CaptionStr);
  CreateCFString(DialogMessage, MessageStr);

  {Note: kAlertCautionAlert displays alert icon and app's icon.
         kAlertStopAlert and kAlertNoteAlert only display app's icon.
         kAlertPlainAlert doesn't display any icon.}
  case DialogType of
    idDialogWarning : AlertCode := kAlertCautionAlert;
    idDialogError   : AlertCode := kAlertCautionAlert;
    idDialogInfo    : AlertCode := kAlertNoteAlert;
    idDialogConfirm : AlertCode := kAlertNoteAlert;
  else
    AlertCode := kAlertNoteAlert;
  end;

  try
    if OSError(CreateStandardAlert(AlertCode, CaptionStr, MessageStr, @ParamRec, AlertRef),
      Self, SName, 'CreateStandardAlert') then Exit;
      
    if OSError(RunStandardAlert(AlertRef, nil, AlertBtnIdx), Self, SName,
      'RunStandardAlert') then Exit;

    {Convert Carbon result to LCL "id" dialog result}
    case AlertBtnIdx of
      kAlertStdAlertOKButton     : Result := RightBtnID;
      kAlertStdAlertCancelButton : Result := MiddleBtnID;
      kAlertStdAlertOtherButton  : Result := LeftBtnID;
    end;

  finally
    FreeCFString(ParamRec.defaultText);
    FreeCFString(ParamRec.cancelText);
    FreeCFString(ParamRec.otherText);
    FreeCFString(CaptionStr);
    FreeCFString(MessageStr);
  end;
  
  {$IFDEF VerboseLCLIntf}
    DebugLn('TCarbonWidgetSet.PromptUser Result: ' + DbgS(Result));
  {$ENDIF}
end;  {TCarbonWidgetSet.PromptUser}

{------------------------------------------------------------------------------
  Function: RawImage_CreateBitmaps
  Params: ARawImage: Source raw image
          ABitmap:   Destination bitmap object
          AMask:     Destination mask object
          ASkipMask: When set, no mask is created
  Returns:

 ------------------------------------------------------------------------------}
function TCarbonWidgetSet.RawImage_CreateBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean): Boolean;
const
  ALIGNMAP: array[TRawImageLineEnd] of TCarbonBitmapAlignment = (cbaByte, cbaByte, cbaWord, cbaDWord, cbaQWord, cbaDQWord);
var
  ADesc: TRawImageDescription absolute ARawImage.Description;
  bmpType: TCarbonBitmapType;
begin
  Result := False;

  if ADesc.Format = ricfGray
  then bmpType := cbtGray
  else if ADesc.Depth = 1
  then bmpType := cbtMono
  else if ADesc.AlphaPrec <> 0
  then begin
    if ADesc.ByteOrder = riboMSBFirst
    then begin
      if  (ADesc.AlphaShift = 24)
      and (ADesc.RedShift   = 16)
      and (ADesc.GreenShift = 8 )
      and (ADesc.BlueShift  = 0 )
      then bmpType := cbtARGB
      else
      if  (ADesc.AlphaShift = 0 )
      and (ADesc.RedShift   = 8 )
      and (ADesc.GreenShift = 16)
      and (ADesc.BlueShift  = 24)
      then bmpType := cbtBGRA
      else Exit;
    end
    else begin
      if  (ADesc.AlphaShift = 24)
      and (ADesc.RedShift   = 16)
      and (ADesc.GreenShift = 8 )
      and (ADesc.BlueShift  = 0 )
      then bmpType := cbtBGRA
      else
      if  (ADesc.AlphaShift = 0 )
      and (ADesc.RedShift   = 8 )
      and (ADesc.GreenShift = 16)
      and (ADesc.BlueShift  = 24)
      then bmpType := cbtARGB
      else Exit;
    end;
  end
  else begin
    bmpType := cbtRGB;
  end;

  ABitmap := HBITMAP(TCarbonBitmap.Create(ADesc.Width, ADesc.Height, ADesc.Depth, ADesc.BitsPerPixel, ALIGNMAP[ADesc.LineEnd], bmpType, ARawImage.Data));

  if ASkipMask or (ADesc.MaskBitsPerPixel = 0)
  then AMask := 0
  else AMask := HBITMAP(TCarbonBitmap.Create(ADesc.Width, ADesc.Height, 1, ADesc.MaskBitsPerPixel, ALIGNMAP[ADesc.MaskLineEnd], cbtMask, ARawImage.Mask));

  Result := True;
end;

{------------------------------------------------------------------------------
  Function: RawImage_DescriptionFromBitmap
  Params: ABitmap:
          ADesc:
  Returns:

  Describes the inner format utilized by Carbon and specific information
  for the specified bitmap
 ------------------------------------------------------------------------------}
function TCarbonWidgetSet.RawImage_DescriptionFromBitmap(ABitmap: HBITMAP; out ADesc: TRawImageDescription): Boolean;
begin
  if CheckBitmap(ABitmap, 'RawImage_DescriptionFromBitmap')
  then Result := RawImage_DescriptionFromCarbonBitmap(ADesc, TCarbonBitmap(ABitmap))
  else Result := False;
end;


{------------------------------------------------------------------------------
  Function: RawImage_DescriptionFromDevice
  Params: ADC:   - Handle to device context
          ADesc: - Pointer to raw image description
  Returns: True if success

  Retrieves the standard image format utilized by Carbon
 ------------------------------------------------------------------------------}
function TCarbonWidgetSet.RawImage_DescriptionFromDevice(ADC: HDC; out ADesc: TRawImageDescription): Boolean;
var
  P: TPoint;
begin
  Result := False;

  FillStandardDescription(ADesc);
  if (ADC <> 0) and CheckDC(ADC, 'RawImage_DescriptionFromDevice')
  then begin
    P := TCarbonDeviceContext(ADC).Size;
    ADesc.Width := P.X;
    ADesc.Height := P.Y
  end;

  Result := True;
end;

{------------------------------------------------------------------------------
  Function: RawImage_FromBitmap
  Params: ARawImage: Image to create
          ABitmap:   Source bitmap
          AMask:     Source mask
          ARect:     Source rect (TODO)
  Returns: True if the function succeeds

  Creates a raw image from the specified bitmap
 ------------------------------------------------------------------------------}
function TCarbonWidgetSet.RawImage_FromBitmap(out ARawImage: TRawImage; ABitmap, AMask: HBITMAP; const ARect: TRect): Boolean;
begin
  if CheckBitmap(ABitmap, 'RawImage_FromBitmap')
  and ((AMask = 0) or CheckBitmap(AMask, 'RawImage_FromBitmap (mask)'))
  then Result := RawImage_FromCarbonBitmap(ARawImage, TCarbonBitmap(ABitmap), TCarbonBitmap(AMask), ARect)
  else Result := False;
end;

{------------------------------------------------------------------------------
  Function: RawImage_FromDevice
  Params: ARawImage: Image to create
          ADC:       Source dc
          ARect:     Source rect (TODO)

  Returns: True if the function succeeds

  Creates a raw image from the specified devicecontext
 ------------------------------------------------------------------------------}
function TCarbonWidgetSet.RawImage_FromDevice(out ARawImage: TRawImage; ADC: HDC; const ARect: TRect): Boolean;
var
  CBC: TCarbonBitmapContext absolute ADC;
begin
  Result := False;
  if not CheckDC(ADC, 'RawImage_FromDevice') then Exit;
  if not (CBC is TCarbonBitmapContext)
  then begin
    DebugLn('[WARNING] RawImage_FromDevice: DC is not a CarbonBitmapContext');
    Exit;
  end;

  Result := RawImage_FromCarbonBitmap(ARawImage, CBC.Bitmap, nil, ARect)
end;

{------------------------------------------------------------------------------
  Method:  SetMainMenuEnabled
  Params:  AEnabled

  Enables/disables main menu
 ------------------------------------------------------------------------------}
procedure TCarbonWidgetSet.SetMainMenuEnabled(AEnabled: Boolean);
begin
  {$IFDEF VerboseLCLIntf}
    DebugLn('TCarbonWidgetSet.SetMainMenuEnabled AEnabled: ' + DbgS(AEnabled));
  {$ENDIF}
  
  if FMainMenu <> nil then
  begin
    if csDesigning in FMainMenu.ComponentState then Exit;
    if FMainMenu.Items.HandleAllocated then
    begin
      TCarbonMenu(FMainMenu.Items.Handle).SetEnable(AEnabled);
    end;
  end;
end;

{------------------------------------------------------------------------------
  Method:  TCarbonWidgetSet.SetRootMenu
  Params:  AMenu - Main menu

  Sets the menu to menu bar
 ------------------------------------------------------------------------------}
procedure TCarbonWidgetSet.SetRootMenu(const AMenu: TMainMenu);
begin
  {$IFDEF VerboseLCLIntf}
    DebugLn('TCarbonWidgetSet.SetRootMenu AMenu: ' + DbgS(AMenu));
  {$ENDIF}
  
  if (AMenu <> nil) and not (csDesigning in AMenu.ComponentState) and
    AMenu.HandleAllocated then
  begin

    if not CheckMenu(AMenu.Handle, 'SetRootMenu') then Exit;

    TCarbonMenu(AMenu.Handle).AttachToMenuBar;
    
    FMainMenu := AMenu;
  end;
end;

{------------------------------------------------------------------------------
  Method:  SetCaptureWidget
  Params:  AWidget - Carbon widget to capture

  Sets captured Carbon widget
 ------------------------------------------------------------------------------}
procedure TCarbonWidgetSet.SetCaptureWidget(const AWidget: HWND);
begin
  {$IFDEF VerboseLCLIntf}
    DebugLn('TCarbonWidgetSet.SetCaptureWidget AWidget: ' + DbgS(AWidget));
  {$ENDIF}
  
  if AWidget <> FCaptureWidget then
  begin
    FCaptureWidget := AWidget;
    
    if FCaptureWidget <> 0 then
      LCLSendCaptureChangedMsg(TCarbonWidget(FCaptureWidget).LCLObject);
  end;
end;

//##apiwiz##eps##   // Do not remove, no wizard declaration after this line

// included by carbonint.pas