Carbon intf: partially implemented TFontDialog

git-svn-id: trunk@11949 -

lcl/interfaces/carbon/carbongdiobjects.pp

@@ -83,7 +83,8 @@ type
     FLineRotation: Fixed;
   public
     constructor Create(AGlobal: Boolean); // default system font
-    constructor Create(ALogFont: TLogFont; AFaceName: String);
+    constructor Create(ALogFont: TLogFont; const AFaceName: String);
+    function CreateStyle(ALogFont: TLogFont; const AFaceName: String): ATSUStyle;
     destructor Destroy; override;
   public
     property LineRotation: Fixed read FLineRotation;
@@ -697,7 +698,23 @@ end;
 
   Creates Carbon font with the specified name and characteristics
  ------------------------------------------------------------------------------}
-constructor TCarbonFont.Create(ALogFont: TLogFont; AFaceName: String);
+constructor TCarbonFont.Create(ALogFont: TLogFont; const AFaceName: String);
+begin
+  inherited Create(False);
+  
+  FStyle := CreateStyle(ALogFont, AFaceName);
+  
+  // applied when creating text layout
+  FLineRotation := (ALogFont.lfEscapement shl 16) div 10;
+end;
+
+{------------------------------------------------------------------------------
+  Method:  TCarbonFont.CreateStyle
+  Params:  ALogFont  - Font characteristics
+           AFaceName - Name of the font
+  Returns: ATSUStyle for the specified font name and characteristics
+ ------------------------------------------------------------------------------}
+function TCarbonFont.CreateStyle(ALogFont: TLogFont; const AFaceName: String): ATSUStyle;
 var
   Attr: ATSUAttributeTag;
   M: ATSUTextMeasurement;
@@ -707,10 +724,11 @@ var
   ID: ATSUFontID;
 const
   SSetAttrs = 'ATSUSetAttributes';
+  SName = 'CreateStyle';
 begin
   inherited Create(False);
-  
-  OSError(ATSUCreateStyle(FStyle), Self, SCreate, SCreateStyle);
+
+  OSError(ATSUCreateStyle(Result), Self, SName, SCreateStyle);
 
   ID := FindCarbonFontID(AFaceName);
 
@@ -719,7 +737,7 @@ begin
     Attr := kATSUFontTag;
     A := @ID;
     S := SizeOf(ID);
-    OSError(ATSUSetAttributes(FStyle, 1, @Attr, @S, @A), Self, SCreate,
+    OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName,
       SSetAttrs, 'kATSUFontTag');
   end;
 
@@ -729,20 +747,17 @@ begin
     M := Abs(ALogFont.lfHeight) shl 16;
     A := @M;
     S := SizeOf(M);
-    OSError(ATSUSetAttributes(FStyle, 1, @Attr, @S, @A), Self, SCreate,
+    OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName,
       SSetAttrs, 'kATSUSizeTag');
   end;
 
-  // applied when creating text layout
-  FLineRotation := (ALogFont.lfEscapement shl 16) div 10;
-
   if ALogFont.lfWeight > FW_NORMAL then
   begin
     Attr := kATSUQDBoldfaceTag;
     B := True;
     A := @B;
     S := SizeOf(B);
-    OSError(ATSUSetAttributes(FStyle, 1, @Attr, @S, @A), Self, SCreate,
+    OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName,
       SSetAttrs, 'kATSUQDBoldfaceTag');
   end;
 
@@ -752,7 +767,7 @@ begin
     B := True;
     A := @B;
     S := SizeOf(B);
-    OSError(ATSUSetAttributes(FStyle, 1, @Attr, @S, @A), Self, SCreate, SSetAttrs,
+    OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName, SSetAttrs,
       'kATSUQDItalicTag');
   end;
 
@@ -762,7 +777,7 @@ begin
     B := True;
     A := @B;
     S := SizeOf(B);
-    OSError(ATSUSetAttributes(FStyle, 1, @Attr, @S, @A), Self, SCreate,
+    OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName,
       SSetAttrs, 'kATSUQDUnderlineTag');
   end;
 
@@ -772,7 +787,7 @@ begin
     B := True;
     A := @B;
     S := SizeOf(B);
-    OSError(ATSUSetAttributes(FStyle, 1, @Attr, @S, @A), Self, SCreate,
+    OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName,
       SSetAttrs, 'kATSUStyleStrikeThroughTag');
   end;
 end;

lcl/interfaces/carbon/carbonlclintf.inc

@@ -136,9 +136,15 @@ 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
-  Result:=inherited GetDesignerDC(WindowHandle);
+  // TODO: create frontmost control for designer context
+  Result := GetDC(WindowHandle);
 end;
 
 {------------------------------------------------------------------------------

lcl/interfaces/carbon/carbonproc.pp

@@ -66,6 +66,8 @@ function GetCarbonShiftState: TShiftState;
 function ShiftStateToModifiers(const Shift: TShiftState): Byte;
 
 function FindCarbonFontID(const FontName: String): ATSUFontID;
+function CarbonFontIDToFontName(ID: ATSUFontID): String;
+
 function FontStyleToQDStyle(const AStyle: TFontStyles): FPCMacOSAll.Style;
 
 procedure FillStandardDescription(out Desc: TRawImageDescription);
@@ -379,6 +381,35 @@ begin
   end;
 end;
 
+{------------------------------------------------------------------------------
+  Name:    CarbonFontIDToFontName
+  Params:  IS - Carbon font ID
+  Returns: The font name, UTF-8 encoded
+ ------------------------------------------------------------------------------}
+function CarbonFontIDToFontName(ID: ATSUFontID): String;
+var
+  NameLength: LongWord;
+  FontName: UTF8String;
+const
+  SName = 'CarbonFontIDToFontName';
+begin
+  Result := '';
+  
+  // retrieve font name length
+  if OSError(ATSUFindFontName(ID, kFontFamilyName, kFontMacintoshPlatform,
+    kFontRomanScript, kFontEnglishLanguage, NameLength, nil,
+    @NameLength, nil), SName, 'ATSUFindFontName', 'Length') then Exit;
+
+  SetLength(FontName, NameLength);
+
+  // retrieve font name
+  if OSError(ATSUFindFontName(ID, kFontFamilyName, kFontMacintoshPlatform,
+    kFontRomanScript, kFontEnglishLanguage, NameLength,
+    @FontName[1], @NameLength, nil), SName, 'ATSUFindFontName', 'Name') then Exit;
+    
+  Result := FontName;
+end;
+
 {------------------------------------------------------------------------------
   Name:    FontStyleToQDStyle
   Params:  AStyle - Font style

lcl/interfaces/carbon/carbonwinapi.inc

@@ -663,7 +663,7 @@ end;
 function TCarbonWidgetSet.EnumFontFamiliesEx(DC: HDC; lpLogFont: PLogFont;
   Callback: FontEnumExProc; LParam: Lparam; flags: dword): Longint;
 var
-  FamilyCount, NameLength: LongWord;
+  FamilyCount: LongWord;
   FamilyListPtr, PFamily: ^ATSUFontID;
   FontName: UTF8String;
   EnumLogFont: TEnumLogFontEx;
@@ -698,18 +698,7 @@ begin
       PFamily := FamilyListPtr;
       for I := 0 to Pred(FamilyCount) do
       begin
-        // retrieve font name length
-        if OSError(ATSUFindFontName(PFamily^, kFontFamilyName, kFontMacintoshPlatform,
-          kFontRomanScript, kFontEnglishLanguage, NameLength, nil,
-          @NameLength, nil), SName, 'ATSUFindFontName', 'Length') then Continue;
-        
-        SetLength(FontName, NameLength);
-
-        // retrieve font name, UTF-16 encoded
-        if OSError(ATSUFindFontName(PFamily^, kFontFamilyName, kFontMacintoshPlatform,
-          kFontRomanScript, kFontEnglishLanguage, NameLength,
-          @FontName[1], @NameLength, nil), SName, 'ATSUFindFontName', 'Name') then Continue;
-          
+        FontName := CarbonFontIDToFontName(PFamily^);
         if FontName <> '' then // execute callback
         begin
           FillChar(EnumLogFont, SizeOf(EnumLogFont), #0);

lcl/interfaces/carbon/carbonwsdialogs.pp

@@ -33,7 +33,7 @@ uses
   // libs
   FPCMacOSAll,
   // LCL
-  Classes, SysUtils, Controls, Dialogs, LCLType, LCLProc, Masks,
+  Classes, SysUtils, Controls, Dialogs, LCLType, LCLProc, Masks, Graphics,
   // widgetset
   WSLCLClasses, WSProc, WSDialogs,
   // LCL Carbon
@@ -105,13 +105,14 @@ type
   private
   protected
   public
+    class procedure ShowModal(const ACommonDialog: TCommonDialog); override;
   end;
 
 
 implementation
 
 uses
-  CarbonProc, CarbonDbgConsts;
+  CarbonProc, CarbonDbgConsts, CarbonInt, CarbonUtils, CarbonGDIObjects;
 
 { TCarbonWSFileDialog }
 
@@ -196,7 +197,6 @@ var
   FileURL: CFURLRef;
   FileCFStr: CFStringRef;
   Filters: TParseStringList;
-  I: Integer;
 begin
   {$IFDEF VerboseWSClass}
     DebugLn('TCarbonWSFileDialog.ShowModal for ' + ACommonDialog.Name);
@@ -378,6 +378,187 @@ begin
   end;
 end;
 
+var
+  FontDialog: TFontDialog;
+
+{ TCarbonWSFontDialog }
+
+function CarbonFontDialog_Selection(ANextHandler: EventHandlerCallRef;
+  AEvent: EventRef;
+  AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
+var
+  AFontDialog: TFontDialog;
+  ID: ATSUFontID;
+  Size: Fixed;
+  Color: RGBColor;
+  Style: FMFontStyle;
+const
+  SName = 'CarbonFontDialog_Selection';
+begin
+  {$IFDEF VerboseWSClass}
+    DebugLn('CarbonFontDialog_Selection: ', DbgSName(FontDialog));
+  {$ENDIF}
+
+  Result := CallNextEventHandler(ANextHandler, AEvent);
+
+  // get font panel settings
+    
+  if GetEventParameter(AEvent, kEventParamATSUFontID, typeATSUFontID,
+    nil, SizeOf(ID), nil, @ID) = noErr then
+  begin
+    DebugLn('ID: ' + DbgS(ID));
+    FontDialog.Font.Name := CarbonFontIDToFontName(ID);
+  end;
+  
+  if GetEventParameter(AEvent, kEventParamATSUFontSize, typeATSUSize,
+    nil, SizeOf(Size), nil, @Size) = noErr then
+  begin
+    DebugLn('Size: ' + DbgS(RoundFixed(Size)));
+    FontDialog.Font.Size := RoundFixed(Size);
+  end;
+  
+  if GetEventParameter(AEvent, kEventParamFontColor, typeFontColor,
+    nil, SizeOf(Color), nil, @Color) = noErr then
+  begin
+    DebugLn('Color: ' + DbgS(RGBColorToColor(Color)));
+    FontDialog.Font.Color := RGBColorToColor(Color);
+  end;
+  
+  if GetEventParameter(AEvent, kEventParamFMFontStyle, typeFMFontStyle,
+    nil, SizeOf(Style), nil, @Style) = noErr then
+  begin
+    DebugLn('Style: ' + DbgS(Style));
+    FontDialog.Font.Style := [];
+    if (Style and FPCMacOSAll.bold) > 0 then
+      FontDialog.Font.Style := FontDialog.Font.Style + [fsBold];
+    if (Style and FPCMacOSAll.italic) > 0 then
+      FontDialog.Font.Style := FontDialog.Font.Style + [fsItalic];
+    if (Style and FPCMacOSAll.underline) > 0 then
+      FontDialog.Font.Style := FontDialog.Font.Style + [fsUnderline];
+  end;
+  
+  // TODO: fsStrikeOut
+    
+  FontDialog.UserChoice := mrOK;
+end;
+
+function CarbonFontDialog_Close(ANextHandler: EventHandlerCallRef;
+  AEvent: EventRef;
+  AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF}
+var
+  AFontDialog: TFontDialog;
+begin
+  {$IFDEF VerboseWSClass}
+    DebugLn('CarbonFontDialog_Close: ', DbgSName(FontDialog));
+  {$ENDIF}
+
+  Result := CallNextEventHandler(ANextHandler, AEvent);
+  
+  CarbonWidgetSet.SetMainMenuEnabled(True);
+  
+  // hide font panel
+  if FPIsFontPanelVisible then
+    OSError(FPShowHideFontPanel, 'CarbonFontDialog_Close', 'FPShowHideFontPanel');
+end;
+
+{------------------------------------------------------------------------------
+  Method:  TCarbonWSFontDialog.ShowModal
+  Params:  ACommonDialog - LCL font dialog
+
+  Shows Carbon interface font panel
+ ------------------------------------------------------------------------------}
+class procedure TCarbonWSFontDialog.ShowModal(const ACommonDialog: TCommonDialog);
+var
+  AFontDialog: TFontDialog;
+  TmpSpec: EventTypeSpec;
+  Dialog: WindowRef;
+  Style: ATSUStyle;
+  ID: ATSUFontID;
+  M: ATSUTextMeasurement;
+  C: RGBColor;
+  Attr: ATSUAttributeTag;
+  S: ByteCount;
+  A: ATSUAttributeValuePtr;
+begin
+  {$IFDEF VerboseWSClass}
+    DebugLn('TCarbonWSFontDialog.ShowModal for ' + ACommonDialog.Name);
+  {$ENDIF}
+  
+  AFontDialog := ACommonDialog as TFontDialog;
+  AFontDialog.UserChoice := mrCancel;
+
+  if OSError(
+    CreateNewWindow(kModalWindowClass,
+      kWindowCompositingAttribute or kWindowStandardHandlerAttribute, GetCarbonRect(0, 0, 0, 0), Dialog),
+    Self, SShowModal, 'CreateNewWindow') then Exit;
+    
+  try
+    TmpSpec := MakeEventSpec(kEventClassFont, kEventFontPanelClosed);
+    InstallWindowEventHandler(Dialog,
+      RegisterEventHandler(@CarbonFontDialog_Close),
+      1, @TmpSpec, nil, nil);
+
+    TmpSpec := MakeEventSpec(kEventClassFont, kEventFontSelection);
+    InstallWindowEventHandler(Dialog,
+      RegisterEventHandler(@CarbonFontDialog_Selection),
+      1, @TmpSpec, nil, nil);
+
+
+    OSError(ATSUCreateAndCopyStyle(TCarbonFont(AFontDialog.Font.Handle).Style, Style),
+      Self, SShowModal, 'ATSUCreateAndCopyStyle');
+      
+    // force set font ID
+    if ATSUGetAttribute(Style, kATSUFontTag, SizeOf(ID), @ID, nil) = kATSUNotSetErr then
+    begin
+      Attr := kATSUFontTag;
+      A := @ID;
+      S := SizeOf(ID);
+      OSError(ATSUSetAttributes(Style, 1, @Attr, @S, @A), Self, SShowModal,
+        'ATSUSetAttributes', 'kATSUFontTag');
+    end;
+    
+    // force set font size
+    if ATSUGetAttribute(Style, kATSUSizeTag, SizeOf(M), @M, nil) = kATSUNotSetErr then
+    begin
+      Attr := kATSUSizeTag;
+      A := @M;
+      S := SizeOf(M);
+      OSError(ATSUSetAttributes(Style, 1, @Attr, @S, @A), Self, SShowModal,
+        'ATSUSetAttributes', 'kATSUSizeTag');
+    end;
+    
+    // force set font color
+    if ATSUGetAttribute(Style, kATSUColorTag, SizeOf(C), @C, nil) = kATSUNotSetErr then
+    begin
+      Attr := kATSUColorTag;
+      A := @C;
+      S := SizeOf(C);
+      OSError(ATSUSetAttributes(Style, 1, @Attr, @S, @A), Self, SShowModal,
+        'ATSUSetAttributes', 'kATSUSizeTag');
+    end;
+
+    if OSError(SetFontInfoForSelection(kFontSelectionATSUIType, 1,
+      @Style, GetWindowEventTarget(Dialog)),
+      Self, SShowModal, 'SetFontInfoForSelection') then Exit;
+
+    CarbonWidgetSet.SetMainMenuEnabled(False);
+
+    FontDialog := AFontDialog;
+    FPCMacOSAll.ShowWindow(Dialog);
+
+    // show font panel
+    if not FPIsFontPanelVisible then
+      OSError(FPShowHideFontPanel, Self, SShowModal, 'FPShowHideFontPanel');
+      
+    while FPIsFontPanelVisible do
+      CarbonWidgetSet.AppProcessMessages;
+
+  finally
+    DisposeWindow(Dialog);
+    CarbonWidgetSet.SetMainMenuEnabled(True);
+  end;
+end;
+
 initialization
 
 ////////////////////////////////////////////////////
@@ -393,6 +574,6 @@ initialization
 //  RegisterWSComponent(TSelectDirectoryDialog, TCarbonWSSelectDirectoryDialog);
   RegisterWSComponent(TColorDialog, TCarbonWSColorDialog);
 //  RegisterWSComponent(TColorButton, TCarbonWSColorButton);
-//  RegisterWSComponent(TFontDialog, TCarbonWSFontDialog);
+  RegisterWSComponent(TFontDialog, TCarbonWSFontDialog);
 ////////////////////////////////////////////////////
 end.