1{                 ------------------------------------------
2                  carbongdiobjects.pp  -  Carbon GDI objects
3                  ------------------------------------------
4
5 *****************************************************************************
6  This file is part of the Lazarus Component Library (LCL)
7
8  See the file COPYING.modifiedLGPL.txt, included in this distribution,
9  for details about the license.
10 *****************************************************************************
11}
12unit CarbonGDIObjects;
13
14{$mode objfpc}{$H+}
15{.$define DumpRegion}
16interface
17
18// defines
19{$I carbondefines.inc}
20
21uses
22 // rtl+fcl
23  Types, Classes, SysUtils, Math,
24 // carbon bindings
25  MacOSAll,
26 // LCL
27  LCLProc, LCLType, GraphType, Graphics, Controls, Forms, ExtCtrls,
28 // LCL Carbon
29 {$ifdef DebugBitmaps}
30  CarbonDebug,
31 {$endif}
32  CarbonDef;
33
34type
35  TCarbonBitmap = class;
36
37  { TCarbonGDIObject }
38
39  TCarbonGDIObject = class
40  private
41    FSelCount: Integer;
42    FGlobal: Boolean;
43  public
44    constructor Create(AGlobal: Boolean);
45
46    procedure Select;
47    procedure Unselect;
48
49    property Global: Boolean read FGlobal;
50    property SelCount: Integer read FSelCount;
51  end;
52
53  { TCarbonRegion }
54
55  TCarbonRegion = class(TCarbonGDIObject)
56  private
57    FShape: HIShapeRef;
58  public
59    constructor Create;
60    constructor Create(const X1, Y1, X2, Y2: Integer);
61    constructor Create(Points: PPoint; NumPts: Integer; FillMode: Integer);
62    constructor CreateEllipse(X1, Y1, X2, Y2: Integer);
63    destructor Destroy; override;
64
65    procedure Apply(ADC: TCarbonContext);
66    function GetBounds: TRect;
67    function GetType: Integer;
68    function ContainsPoint(const P: TPoint): Boolean;
69    procedure SetShape(AShape: HIShapeRef);
70    function CombineWith(ARegion: TCarbonRegion; CombineMode: Integer): Integer;
71    procedure Offset(dx, dy: Integer);
72    function GetShapeCopy: HIShapeRef;
73    procedure MakeMutable;
74  public
75    property Shape: HIShapeRef read FShape write SetShape;
76  end;
77
78  TCarbonFont = class;
79
80  { TCarbonTextLayout }
81
82  TCarbonTextLayout = class
83  private
84    FTextBefore: ATSUTextMeasurement;
85    FTextAfter: ATSUTextMeasurement;
86    FAscent: ATSUTextMeasurement;
87    FDescent: ATSUTextMeasurement;
88    FLineRotation: Fixed;
89  public
90    procedure Apply(ADC: TCarbonContext); virtual; abstract;
91    function Draw(X, Y: Integer; DX: PInteger; DXCount: Integer): Boolean; virtual; abstract;
92    procedure Release; virtual;
93
94    function GetHeight: Integer;
95    function GetWidth: Integer;
96    function GetDrawBounds(X, Y: Integer): CGRect;
97
98    property TextBefore: ATSUTextMeasurement read FTextBefore;
99    property TextAfter: ATSUTextMeasurement read FTextAfter;
100    property Ascent: ATSUTextMeasurement read FAscent;
101    property Descent: ATSUTextMeasurement read FDescent;
102  end;
103
104  { TCarbonTextLayoutBuffer }
105
106  TCarbonTextLayoutBuffer = class(TCarbonTextLayout)
107  private
108    FLayout: ATSUTextLayout;
109    FWidget: HIViewRef;
110    FTextBuffer: WideString;
111    FDC: TCarbonContext;
112    FDXCount: Integer;
113    FDX: PInteger;
114    Idx: Integer;
115  protected
116    procedure DoJustify(iLineRef: ATSULineRef; var Handled: Boolean);
117  public
118    constructor Create(const Text: String; Font: TCarbonFont; TextFractional: Boolean);
119    procedure Apply(ADC: TCarbonContext); override;
120    function Draw(X, Y: Integer; DX: PInteger; DXCount: Integer): Boolean; override;
121    procedure Release; override;
122
123    property Layout: ATSUTextLayout read FLayout;
124    property TextBuffer: WideString read FTextBuffer;
125  end;
126
127  { TCarbonTextLayoutArray }
128
129  TCarbonTextLayoutArray = class(TCarbonTextLayout)
130  private
131    FText: String;
132    FFont: TCarbonFont;
133  public
134    constructor Create(const Text: String; Font: TCarbonFont);
135    procedure Apply(ADC: TCarbonContext); override;
136    function Draw(X, Y: Integer; DX: PInteger; DXCount: Integer): Boolean; override;
137  end;
138
139  { TCarbonFont }
140
141  TCarbonFont = class(TCarbonGDIObject)
142  private
143    FStyle: ATSUStyle;
144    FLineRotation: Fixed;
145    FCachedLayouts: Array of TCarbonTextLayoutBuffer;
146  public
147    constructor Create(AGlobal: Boolean); // default system font
148    constructor Create(ALogFont: TLogFont; const AFaceName: String);
149    function CreateStyle(ALogFont: TLogFont; const AFaceName: String): ATSUStyle;
150    procedure QueryStyle(ALogFont: PLogFont);
151    destructor Destroy; override;
152    procedure SetColor(AColor: TColor);
153
154    function CreateTextLayout(const Text: String; TextFractional: Boolean): TCarbonTextLayout;
155  public
156    property LineRotation: Fixed read FLineRotation;
157    property Style: ATSUStyle read FStyle;
158  end;
159
160  { TCarbonColorObject }
161
162  TCarbonColorObject = class(TCarbonGDIObject)
163  private
164    FR, FG, FB: Byte;
165    FA: Boolean; // alpha: True - solid, False - clear
166    function GetColorRef: TColorRef;
167  public
168    constructor Create(const AColor: TColor; ASolid, AGlobal: Boolean);
169    procedure SetColor(const AColor: TColor; ASolid: Boolean);
170    procedure GetRGBA(AROP2: Integer; out AR, AG, AB, AA: Single);
171    function CreateCGColor: CGColorRef;
172
173    property Red: Byte read FR write FR;
174    property Green: Byte read FG write FG;
175    property Blue: Byte read FB write FB;
176    property Solid: Boolean read FA write FA;
177    property ColorRef: TColorRef read GetColorRef;
178  end;
179
180  { TCarbonBrush }
181
182  TCarbonBrush = class(TCarbonColorObject)
183  private
184    FCGPattern: CGPatternRef;
185    FColored: Boolean;
186    FBitmap: TCarbonBitmap;
187  protected
188    procedure SetHatchStyle(AHatch: PtrInt);
189    procedure SetBitmap(ABitmap: TCarbonBitmap);
190  public
191    constructor Create(AGlobal: Boolean); // create default brush
192    constructor Create(ALogBrush: TLogBrush);
193    destructor Destroy; override;
194    procedure Apply(ADC: TCarbonContext; UseROP2: Boolean = True);
195  end;
196
197const
198  // Paul Ishenin:
199  // pen shapes are compared with windows shapes and now a bit to bit equal
200  CarbonDashStyle: Array [0..1] of Single = (3, 1);
201  CarbonDotStyle: Array [0..1] of Single = (1, 1);
202  CarbonDashDotStyle: Array [0..3] of Single = (3, 1, 1, 1);
203  CarbonDashDotDotStyle: Array [0..5] of Single = (3, 1, 1, 1, 1, 1);
204
205type
206  TCarbonDashes = array of Float32;
207
208  { TCarbonPen }
209
210  TCarbonPen = class(TCarbonColorObject)
211  private
212    FWidth: Integer;
213    FStyle: LongWord;
214    FIsExtPen: Boolean;
215    FIsGeometric: Boolean;
216    FEndCap: CGLineCap;
217    FJoinStyle: CGLineJoin;
218   public
219    Dashes: TCarbonDashes;
220    constructor Create(AGlobal: Boolean); // create default pen
221    constructor Create(ALogPen: TLogPen);
222    constructor Create(dwPenStyle, dwWidth: DWord; const lplb: TLogBrush; dwStyleCount: DWord; lpStyle: PDWord);
223    procedure Apply(ADC: TCarbonContext; UseROP2: Boolean = True);
224
225    property Width: Integer read FWidth;
226    property Style: LongWord read FStyle;
227    property IsExtPen: Boolean read FIsExtPen;
228    property IsGeometric: Boolean read FIsGeometric;
229    property JoinStyle: CGLineJoin read FJoinStyle;
230    property CapStyle: CGLineCap read FEndCap;
231  end;
232
233  { TCarbonBitmap }
234
235  TCarbonBitmapAlignment = (
236    cbaByte,  // each line starts at byte boundary.
237    cbaWord,  // each line starts at word (16bit) boundary
238    cbaDWord, // each line starts at double word (32bit) boundary
239    cbaQWord, // each line starts at quad word (64bit) boundary
240    cbaDQWord // each line starts at double quad word (128bit) boundary
241  );
242
243  TCarbonBitmapType = (
244    cbtMono,  // mask or mono bitmap
245    cbtGray,  // grayscale bitmap
246    cbtRGB,   // color bitmap 8-8-8 R-G-B
247    cbtARGB,  // color bitmap with alpha channel first 8-8-8-8 A-R-G-B
248    cbtRGBA,  // color bitmap with alpha channel last 8-8-8-8 R-G-B-A
249    cbtBGR,   // color bitmap 8-8-8 B-G-R (windows compatible)
250    cbtBGRA   // color bitmap with alpha channel 8-8-8-8 B-G-R-A (windows compatible)
251  );
252const
253  cbtMask = cbtMono;
254
255
256type
257  TCarbonBitmap = class(TCarbonGDIObject)
258  private
259    FData: Pointer;
260    FAlignment: TCarbonBitmapAlignment;
261    FFreeData: Boolean;
262    FDataSize: Integer;
263    FBytesPerRow: Integer;
264    FDepth: Byte;
265    FBitsPerPixel: Byte;
266    FWidth: Integer;
267    FHeight: Integer;
268    FType: TCarbonBitmapType;
269    FCGImage: CGImageRef;
270    function GetBitsPerComponent: Integer;
271    function GetColorSpace: CGColorSpaceRef;
272    function GetInfo: CGBitmapInfo;
273    procedure SetCGImage(const AValue: CGImageRef);
274  public
275    constructor Create(AWidth, AHeight, ADepth, ABitsPerPixel: Integer;
276      AAlignment: TCarbonBitmapAlignment; AType: TCarbonBitmapType;
277      AData: Pointer; ACopyData: Boolean = True);
278    constructor Create(ABitmap: TCarbonBitmap);
279    destructor Destroy; override;
280    procedure SetInfo(AWidth, AHeight, ADepth, ABitsPerPixel: Integer;
281      AAlignment: TCarbonBitmapAlignment; AType: TCarbonBitmapType);
282    procedure UpdateImage;
283    procedure UpdateInfo;
284    function CreateSubImage(const ARect: TRect): CGImageRef;
285    function CreateMaskImage(const ARect: TRect): CGImageRef;
286    function CreateMaskedImage(AMask: TCarbonBitmap): CGImageRef;
287    function CreateMaskedImage(AMask: TCarbonBitmap; const ARect: TRect): CGImageRef;
288    procedure AddMask(AMask: TCarbonBitmap);
289  public
290    property BitsPerComponent: Integer read GetBitsPerComponent;
291    property BitmapType: TCarbonBitmapType read FType;
292    property BytesPerRow: Integer read FBytesPerRow;
293    property CGImage: CGImageRef read FCGImage write SetCGImage;
294    property ColorSpace: CGColorSpaceRef read GetColorSpace;
295    property Data: Pointer read FData;
296    property DataSize: Integer read FDataSize;
297    property Depth: Byte read FDepth;
298    property Info: CGBitmapInfo read GetInfo;
299    property Width: Integer read FWidth;
300    property Height: Integer read FHeight;
301  end;
302
303const
304  kThemeUndefCursor = ThemeCursor(-1); // undefined mac theme cursor
305
306  CursorToThemeCursor: array[crLow..crHigh] of ThemeCursor =
307    ({crSizeSE      } kThemeResizeRightCursor, {!!}
308     {crSizeS       } kThemeResizeDownCursor,
309     {crSizeSW      } kThemeResizeLeftCursor, {!!}
310     {crSizeE       } kThemeResizeRightCursor,
311     {crSizeW       } kThemeResizeLeftCursor,
312     {crSizeNE      } kThemeResizeRightCursor, {!!}
313     {crSizeN       } kThemeResizeUpCursor,
314     {crSizeNW      } kThemeResizeLeftCursor, {!!}
315     {crSizeAll     } kThemeUndefCursor,           // will be loaded from resource
316     {crHandPoint   } kThemePointingHandCursor,
317     {crHelp        } kThemeUndefCursor,           // will be loaded from resource
318     {crAppStart    } kThemeSpinningCursor,
319     {crNo          } kThemeUndefCursor,
320     {crSQLWait     } kThemeUndefCursor,           // will be loaded from resource
321     {crMultiDrag   } kThemeUndefCursor,           // will be loaded from resource
322     {crVSplit      } kThemeResizeUpDownCursor,
323     {crHSplit      } kThemeResizeLeftRightCursor,
324     {crNoDrop      } kThemeNotAllowedCursor,
325     {crDrag        } kThemeCopyArrowCursor,
326     {crHourGlass   } kThemeSpinningCursor,
327     {crUpArrow     } kThemeUndefCursor,           // will be loaded from resource
328     {crSizeWE      } kThemeResizeLeftRightCursor,
329     {crSizeNWSE    } kThemeResizeLeftRightCursor, {!!}
330     {crSizeNS      } kThemeResizeUpDownCursor, {!!}
331     {crSizeNESW    } kThemeResizeLeftRightCursor, {!!}
332     {undefined     } kThemeArrowCursor, {!!}
333     {crIBeam       } kThemeIBeamCursor,
334     {crCross       } kThemeCrossCursor,
335     {crArrow       } kThemeArrowCursor,
336     {crNone        } kThemeUndefCursor,
337     {crDefault     } kThemeArrowCursor);
338
339type
340  TCarbonCursorType =
341  (
342    cctUnknown,    // undefined
343    cctQDHardware, // QuickDraw hardware cursor
344    cctQDColor,    // QuickDraw Color cursor
345    cctTheme,      // theme cursor
346    cctAnimated,   // animated theme cursor
347    cctWait        // special wait cursor
348  );
349  { TCarbonCursor }
350
351  TCarbonCursor = class(TCarbonGDIObject)
352  private
353    FCursorType: TCarbonCursorType;
354    FDefault: Boolean;
355    FThemeCursor: ThemeCursor;
356    // animation
357    FAnimationStep: Integer;
358    FTaskID: MPTaskID;
359    // color cursors
360    FQDColorCursorHandle: CCrsrHandle;
361    FQDHardwareCursorName: String;
362    FPixmapHandle: PixmapHandle;
363    // animated color cursors
364    FAnimationFrames: array of record
365      QDColorCursorHandle: CCrsrHandle;
366      QDHardwareCursorName: String;
367      PixmapHandle: PixmapHandle;
368    end;
369    FAnimationTimer: TTimer;
370    procedure CreateThread;
371    procedure DestroyThread;
372    procedure StepQDAnimation(Sender: TObject);
373  protected
374    procedure CreateHardwareCursor(ABitmap: TCarbonBitmap; AHotSpot: Point);
375    procedure CreateColorCursor(ABitmap: TCarbonBitmap; AHotSpot: Point);
376    procedure DestroyCursor;
377  public
378    constructor Create;
379    constructor CreateAnimatedFromInfo(AInfo: PIconInfo; ACount: Integer);
380    constructor CreateFromInfo(AInfo: PIconInfo);
381    constructor CreateThemed(AThemeCursor: ThemeCursor; ADefault: Boolean = False);
382    destructor Destroy; override;
383
384    procedure Install;
385    procedure UnInstall;
386    function StepAnimation: Boolean;
387    class function HardwareCursorsSupported: Boolean;
388  public
389    property CursorType: TCarbonCursorType read FCursorType;
390    property Default: Boolean read FDefault;
391  end;
392
393function CheckGDIObject(const GDIObject: HGDIOBJ; const AMethodName: String; AParamName: String = ''): Boolean;
394function CheckBitmap(const Bitmap: HBITMAP; const AMethodName: String; AParamName: String = ''): Boolean;
395function CheckCursor(const Cursor: HCURSOR; const AMethodName: String; AParamName: String = ''): Boolean;
396
397function FloodFillBitmap(const Bitmap: TCarbonBitmap; X,Y: Integer; {%H-}ABorderColor, FillColor: TColor; {%H-}isBorderColor: Boolean): Boolean;
398
399var
400  StockSystemFont: TCarbonFont;
401  StockNullBrush: TCarbonBrush;
402  WhiteBrush: TCarbonBrush;
403  BlackPen: TCarbonPen;
404
405  DefaultFont: TCarbonFont;
406  DefaultBrush: TCarbonBrush;
407  DefaultPen: TCarbonPen;
408
409  DefaultBitmap: TCarbonBitmap; // 1 x 1 bitmap for default context
410
411implementation
412
413uses
414  LazUTF8, CarbonInt, CarbonProc, CarbonCanvas, CarbonDbgConsts;
415
416const
417  BITMAPINFOMAP: array[TCarbonBitmapType] of CGBitmapInfo = (
418    {cbtMask} kCGImageAlphaNone,
419    {cbtGray} kCGImageAlphaNone,
420    {cbtRGB}  kCGImageAlphaNoneSkipFirst,
421    {cbtARGB} kCGImageAlphaFirst,
422    {cbtRGBA} kCGImageAlphaLast,
423    {cbtBGR}  kCGImageAlphaNoneSkipFirst or kCGBitmapByteOrder32Little,
424    {cbtBGRA} kCGImageAlphaFirst or kCGBitmapByteOrder32Little
425  );
426
427type
428
429  { TScanObject }
430
431  TScanObject = class
432    Shape: HIShapeRef;
433    fX, fY, fW, fH: Integer;
434    Data: Pointer;
435    Context: CGContextRef;
436    constructor create(aShape: HIShapeRef; aX, aY, aW, aH: Integer);
437    destructor destroy; override;
438    procedure AddPart(X1, X2, Y: Integer);
439    function Setup: boolean;
440    procedure Scan;
441    procedure ScanConvex;
442  end;
443
444
445constructor TScanObject.create(aShape: HIShapeRef; aX, aY, aW, aH: Integer);
446begin
447  inherited Create;
448  Shape := aShape;
449  fX := aX;
450  fY := aY;
451  fW := aW;
452  fH := aH;
453end;
454
455
456destructor TScanObject.destroy;
457begin
458  if Context<>nil then
459    CGContextRelease(Context);
460  if Data<>nil then
461    System.Freemem(Data);
462  inherited Destroy;
463end;
464
465function TScanObject.Setup: boolean;
466begin
467  System.GetMem(Data, fW * fH);
468  System.FillChar(Data^, fW * fH, 0);
469  try
470    Context := CGBitmapContextCreate(Data, fW, fH, 8, fW, GrayColorSpace, kCGImageAlphaNone);
471    CGContextSetShouldAntialias(Context, 0); // disable anti-aliasing
472    CGContextSetGrayFillColor(Context, 1.0, 1.0); // draw white polygon
473    CGContextTranslateCTM(Context, -fx, -fy); // Translate origin so we draw at 0,0
474    result := true;
475  except
476    result := false;
477  end;
478end;
479
480procedure TScanObject.AddPart(X1, X2, Y: Integer);
481var
482  R: HIShapeRef;
483begin
484  //DebugLn('AddPart:' + DbgS(X1) + ' - ' + DbgS(X2) + ', ' + DbgS(Y));
485  R := HIShapeCreateWithRect(GetCGRect(X1, Y, X2, Y + 1));
486  OSError(HIShapeUnion(Shape, R, Shape), Self, 'AddPart', 'HIShapeUnion');
487  CFRelease(R);
488end;
489
490procedure TScanObject.Scan;
491var
492  PData: PByte;
493  X, Y, SX: Integer;
494  LC, C: Byte;
495  {$ifdef DumpRegion}
496  Line: string;
497  {$endif}
498begin
499  // scan shape
500  {$ifdef DumpRegion}
501  DebugLn;
502  DebugLn('SCAN: X=%d Y=%d W=%d H=%d',[fX,fY,fW,fH]);
503  SetLength(Line, fW);
504  {$endif}
505
506  PData := Data;
507  for Y := 0 to Pred(fH) do
508  begin
509    LC := 0; // edge is black
510    Sx := -1;
511    for X := 0 to Pred(fW) do
512    begin
513      C := PData^;
514      {$ifdef DumpRegion}
515      Line[X + 1] := Chr(Ord('0') + C div 255);
516      {$endif}
517
518      if (C = $FF) and (LC = 0) then
519        SX := X; // start of painted row part
520      if (SX>=0) and (LC = $FF) and ((C = 0) or (x=Pred(fw))) then
521        // end of painted row part (SX, X)
522        AddPart(fx + SX, fx + X,  fy + Pred(fH) - Y);
523
524      LC := C;
525      Inc(PData);
526    end;
527    {$ifdef DumpRegion}
528    DebugLn('%.3d: %s',[Pred(fH) - Y,Line]);
529    {$endif}
530  end;
531end;
532
533procedure TScanObject.ScanConvex;
534var
535  PData, P: PByte;
536  X, Xe, Y, SX,EX: Integer;
537  {$ifdef DumpRegion}
538  Line: string;
539  {$endif}
540  found, noted: boolean;
541begin
542  // scan shape
543  {$ifdef DumpRegion}
544  DebugLn;
545  DebugLn('SCANCONVEX: X=%d Y=%d W=%d H=%d',[fX,fY,fW,fH]);
546  SetLength(Line, fW);
547  {$endif}
548
549  noted := false;
550  PData := Data;
551  for Y := 0 to Pred(fH) do
552  begin
553    P := PData;
554    {$ifdef DumpRegion}
555    for X:=0 to Pred(fW) do Line[X+1] := Chr(Ord('0') + P[X] div 255);
556    {$endif}
557    SX := -1; EX := -1;
558    for X := 0 to Pred(fW) do
559    begin
560      Xe := Pred(fW)-X;
561      if (SX=-1) and (P[X]=$FF) then SX := X;
562      if (EX=-1) and (P[Xe]=$FF) then EX := Xe;
563      found := (EX>=0) and (SX>=0);
564      if found or (Xe<=X) then
565        break;
566    end;
567    // just in case ....
568    if not found then
569    begin
570      if (Sx>=0) then begin Ex := Pred(fW); found := true; end;
571      if (Ex>=0) then begin Sx := 0; found := true; end;
572      if not noted and found then begin
573        noted := true;
574        DebugLn('NOTE: ScanObj: broken convex!');
575      end;
576    end;
577
578    inc(PData, fW);
579    if found then
580      AddPart(fX + SX, fX + Ex + 1,  fY + Pred(fH) - Y);
581    {$ifdef DumpRegion}
582    DebugLn('%.3d: %s did=%s',[Pred(fH) - Y,Line,dbgs(found)]);
583    {$endif}
584  end;
585end;
586
587
588{------------------------------------------------------------------------------
589  Name:    CheckGDIObject
590  Params:  GDIObject   - Handle to a GDI Object (TCarbonFont, ...)
591           AMethodName - Method name
592           AParamName  - Param name
593  Returns: If the GDIObject is valid
594
595  Remark: All handles for GDI objects must be pascal objects so we can
596 distinguish between them
597 ------------------------------------------------------------------------------}
598function CheckGDIObject(const GDIObject: HGDIOBJ; const AMethodName: String;
599  AParamName: String): Boolean;
600begin
601  if TObject(GDIObject) is TCarbonGDIObject then Result := True
602  else
603  begin
604    Result := False;
605
606    if Pos('.', AMethodName) = 0 then
607      DebugLn(SCarbonWSPrefix + AMethodName + ' Error - invalid GDIObject ' +
608        AParamName + ' = ' + DbgS(GDIObject) + '!')
609    else
610      DebugLn(AMethodName + ' Error - invalid GDIObject ' + AParamName + ' = ' +
611        DbgS(GDIObject) + '!');
612  end;
613end;
614
615{------------------------------------------------------------------------------
616  Name:    CheckBitmap
617  Params:  Bitmap      - Handle to a bitmap (TCarbonBitmap)
618           AMethodName - Method name
619           AParamName  - Param name
620  Returns: If the bitmap is valid
621 ------------------------------------------------------------------------------}
622function CheckBitmap(const Bitmap: HBITMAP; const AMethodName: String;
623  AParamName: String): Boolean;
624begin
625  if TObject(Bitmap) is TCarbonBitmap then Result := True
626  else
627  begin
628    Result := False;
629
630    if Pos('.', AMethodName) = 0 then
631      DebugLn(SCarbonWSPrefix + AMethodName + ' Error - invalid bitmap ' +
632        AParamName + ' = ' + DbgS(Bitmap) + '!')
633    else
634      DebugLn(AMethodName + ' Error - invalid bitmap ' + AParamName + ' = ' +
635        DbgS(Bitmap) + '!');
636  end;
637end;
638
639{------------------------------------------------------------------------------
640  Name:    CheckCursor
641  Params:  Cursor      - Handle to a cursor (TCarbonCursor)
642           AMethodName - Method name
643           AParamName  - Param name
644  Returns: If the cursor is valid
645 ------------------------------------------------------------------------------}
646function CheckCursor(const Cursor: HCURSOR; const AMethodName: String;
647  AParamName: String): Boolean;
648begin
649  if TObject(Cursor) is TCarbonCursor then Result := True
650  else
651  begin
652    Result := False;
653
654    if Pos('.', AMethodName) = 0 then
655      DebugLn(SCarbonWSPrefix + AMethodName + ' Error - invalid cursor ' +
656        AParamName + ' = ' + DbgS(Cursor) + '!')
657    else
658      DebugLn(AMethodName + ' Error - invalid cursor ' + AParamName + ' = ' +
659        DbgS(Cursor) + '!');
660  end;
661end;
662
663type
664  THardwareCursorsAvailability =
665  (
666    hcaUndef,
667    hcaAvailable,
668    hcaUnavailable
669  );
670
671const
672// missed error codes
673  kQDNoColorHWCursorSupport = -3951;
674  {%H-}kQDCursorAlreadyRegistered = -3952;
675  {%H-}kQDCursorNotRegistered = -3953;
676  {%H-}kQDCorruptPICTDataErr = -3954;
677
678  kThemeCursorAnimationDelay = 70;
679  LazarusCursorInfix = '_lazarus_';
680
681var
682  MHardwareCursorsSupported: THardwareCursorsAvailability = hcaUndef;
683
684{------------------------------------------------------------------------------
685  Name: AnimationCursorHandler
686  Handles cursor animation steps
687 ------------------------------------------------------------------------------}
688function AnimationCursorHandler(parameter: UnivPtr): OSStatus;
689  {$IFDEF darwin}mwpascal;{$ENDIF}
690begin
691  Result := noErr;
692  while True do
693  begin
694    if TCarbonCursor(parameter).StepAnimation then
695      Sleep(kThemeCursorAnimationDelay) else
696      break;
697  end;
698end;
699
700{ TCarbonGDIObject }
701
702{------------------------------------------------------------------------------
703  Method:  TCarbonGDIObject.Create
704  Params:  AGlobal - Global
705
706  Creates custom GDI object
707 ------------------------------------------------------------------------------}
708constructor TCarbonGDIObject.Create(AGlobal: Boolean);
709begin
710  FSelCount := 0;
711  FGlobal := AGlobal;
712end;
713
714{------------------------------------------------------------------------------
715  Method:  TCarbonGDIObject.Select
716
717  Selects custom GDI object
718 ------------------------------------------------------------------------------}
719procedure TCarbonGDIObject.Select;
720begin
721  if FGlobal then Exit;
722  Inc(FSelCount);
723end;
724
725{------------------------------------------------------------------------------
726  Method:  TCarbonGDIObject.Unselect
727
728  Unselects custom GDI object
729 ------------------------------------------------------------------------------}
730procedure TCarbonGDIObject.Unselect;
731begin
732  if FGlobal then Exit;
733  if FSelCount > 0 then
734    Dec(FSelCount)
735  else
736  begin
737    DebugLn('TCarbonGDIObject.Unselect Error - ', DbgSName(Self), ' SelCount = ',
738      DbgS(FSelCount), '!');
739  end;
740end;
741
742{ TCarbonRegion }
743
744{------------------------------------------------------------------------------
745  Method:  TCarbonRegion.Create
746
747  Creates a new empty Carbon region
748 ------------------------------------------------------------------------------}
749constructor TCarbonRegion.Create;
750begin
751  inherited Create(False);
752
753  FShape := HIShapeCreateEmpty;
754end;
755
756{------------------------------------------------------------------------------
757  Method:  TCarbonRegion.Create
758  Params:  X1, Y1, X2, Y2 - Region bounding rectangle
759
760  Creates a new rectangular Carbon region
761 ------------------------------------------------------------------------------}
762constructor TCarbonRegion.Create(const X1, Y1, X2, Y2: Integer);
763begin
764  inherited Create(False);
765
766  FShape := HIShapeCreateWithRect(GetCGRectSorted(X1, Y1, X2, Y2));
767end;
768
769{------------------------------------------------------------------------------
770  Method:  TCarbonRegion.Create
771  Params:  Points   - Pointer to array of polygon points
772           NumPts   - Number of points passed
773           FillMode - Filling mode
774
775  Creates a new polygonal Carbon region from the specified points
776 ------------------------------------------------------------------------------}
777constructor TCarbonRegion.Create(Points: PPoint; NumPts: Integer;
778  FillMode: Integer);
779var
780  Bounds: TRect;
781  ScanObj: TScanObject;
782  P: PPoint;
783  I, W, H: Integer;
784
785  function GetPolygonBounds: TRect;
786  var
787    I: Integer;
788  begin
789    P := Points;
790    Result := Classes.Rect(P^.X, P^.Y, P^.X, P^.Y);
791    for I := 1 to NumPts - 1 do
792    begin
793      Inc(P);
794      if P^.X < Result.Left then Result.Left := P^.X;
795      if P^.X > Result.Right then Result.Right := P^.X;
796      if P^.Y < Result.Top then Result.Top := P^.Y;
797      if P^.Y > Result.Bottom then Result.Bottom := P^.Y;
798    end;
799  end;
800
801begin
802  inherited Create(False);
803
804(*
805  The passed polygon is drawed into grayscale context, the region is constructed
806  per rows from rectangles of drawed polygon parts.
807  *)
808
809  FShape := HIShapeCreateMutable;
810
811  if (NumPts <= 2) or (Points = nil) then Exit;
812  Bounds := GetPolygonBounds;
813  // DebugLn('TCarbonRegion.Create Bounds:' + DbgS(Bounds));
814  W := Bounds.Right - Bounds.Left + 2;
815  H := Bounds.Bottom - Bounds.Top + 2;
816
817  if (W <= 0) or (H <= 0) then Exit;
818
819  ScanObj := TScanObject.create(FShape, Bounds.Left, Bounds.Top, W, H);
820  try
821    if ScanObj.Setup then begin
822      // draw object to scan
823      P := Points;
824      CGContextBeginPath(ScanObj.Context);
825      CGContextMoveToPoint(ScanObj.Context, P^.X, P^.Y);
826      for I := 1 to NumPts - 1 do
827      begin
828        Inc(P);
829        CGContextAddLineToPoint(ScanObj.Context, P^.X, P^.Y);
830      end;
831      CGContextClosePath(ScanObj.Context);
832      if FillMode = ALTERNATE then
833        CGContextEOFillPath(ScanObj.Context)
834      else
835        CGContextFillPath(ScanObj.Context);
836
837      // scan object in current path
838      ScanObj.Scan;
839    end;
840  finally
841    ScanObj.free;
842  end;
843end;
844
845constructor TCarbonRegion.CreateEllipse(X1, Y1, X2, Y2: Integer);
846var
847  R: CGRect;
848  ScanObj: TScanObject;
849  i: Integer;
850begin
851  FShape := HIShapeCreateMutable;
852
853  if X2<X1 then begin i:=X1; X1:=X2; X2:=i; end;
854  if Y2<Y1 then begin i:=Y1; Y1:=Y2; Y2:=i; end;
855
856  R := getCGRect(X1, Y1, X2, Y2);
857  R.origin.x := R.origin.x + 0.5;
858  R.origin.y := R.origin.y + 0.5;
859  R.size.width := R.size.width - 1;
860  R.size.height := R.size.height - 1;
861
862  with R do
863  ScanObj := TScanObject.create(FShape, X1, Y1, X2-X1+1, Y2-Y1+1);
864  try
865    with ScanObj do
866    if Setup then begin
867      CGContextSetGrayStrokeColor(Context, 1.0, 1.0); // draw white stroke
868      CGContextSetGrayFillColor(Context, 0.0, 0.0); // draw black fill
869      CGContextBeginPath(Context);
870      CGContextAddEllipseInRect(Context, R);
871      CGContextDrawPath(Context, kCGPathFillStroke);
872      // scan object in current path
873      ScanConvex;
874    end;
875  finally
876    ScanObj.free;
877  end;
878
879end;
880
881{------------------------------------------------------------------------------
882  Method:  TCarbonRegion.Destroy
883
884  Destroys Carbon region
885 ------------------------------------------------------------------------------}
886destructor TCarbonRegion.Destroy;
887begin
888  CFRelease(FShape);
889
890  inherited Destroy;
891end;
892
893{------------------------------------------------------------------------------
894  Method:  TCarbonRegion.Apply
895  Params:  ADC - Context to apply to
896
897  Applies region to the specified context
898  Note: Clipping region is only reducing
899 ------------------------------------------------------------------------------}
900procedure TCarbonRegion.Apply(ADC: TCarbonContext);
901var
902  DeviceShape: HIShapeRef;
903begin
904  if ADC = nil then Exit;
905  if ADC.CGContext = nil then Exit;
906  DeviceShape := HIShapeCreateMutableCopy(Shape);
907  try
908    with ADC.GetLogicalOffset do
909      HIShapeOffset(DeviceShape, -X, -Y);
910    if HIShapeIsEmpty(DeviceShape) or OSError(HIShapeReplacePathInCGContext(DeviceShape, ADC.CGContext),
911      Self, 'Apply', 'HIShapeReplacePathInCGContext') then Exit;
912    CGContextClip(ADC.CGContext);
913  finally
914    CFRelease(DeviceShape);
915  end;
916end;
917
918{------------------------------------------------------------------------------
919  Method:  TCarbonRegion.GetBounds
920  Returns: The bounding box of Carbon region
921 ------------------------------------------------------------------------------}
922function TCarbonRegion.GetBounds: TRect;
923var
924  R: HIRect;
925begin
926  if HIShapeGetBounds(FShape, R{%H-}) = nil then
927  begin
928    DebugLn('TCarbonRegion.GetBounds Error!');
929    Exit;
930  end;
931
932  Result := CGRectToRect(R);
933end;
934
935{------------------------------------------------------------------------------
936  Method:  TCarbonRegion.GetType
937  Returns: The type of Carbon region
938 ------------------------------------------------------------------------------}
939function TCarbonRegion.GetType: Integer;
940begin
941  Result := ERROR;
942  if HIShapeIsEmpty(FShape) then
943    Result := NULLREGION
944  else
945  if HIShapeIsRectangular(FShape) then
946    Result := SIMPLEREGION
947  else
948    Result := COMPLEXREGION;
949end;
950
951{------------------------------------------------------------------------------
952  Method:  TCarbonRegion.ContainsPoint
953  Params:  P - Point
954  Returns: If the specified point lies in Carbon region
955 ------------------------------------------------------------------------------}
956function TCarbonRegion.ContainsPoint(const P: TPoint): Boolean;
957begin
958  Result := HIShapeContainsPoint(FShape, PointToHIPoint(P));
959end;
960
961procedure TCarbonRegion.SetShape(AShape: HIShapeRef);
962begin
963  if Assigned(FShape) then CFRelease(FShape);
964  FShape := AShape;
965end;
966
967function TCarbonRegion.CombineWith(ARegion: TCarbonRegion; CombineMode: Integer): Integer;
968var
969  sh1, sh2: HIShapeRef;
970const
971  MinCoord=-35000;
972  MaxSize=65000;
973begin
974  if not Assigned(ARegion) then
975    Result := LCLType.Error
976  else
977  begin
978    if (CombineMode in [RGN_AND, RGN_OR, RGN_XOR]) and HIShapeIsEmpty(FShape) then
979      CombineMode := RGN_COPY;
980
981    case CombineMode of
982      RGN_AND:
983        begin
984          Shape := HIShapeCreateIntersection(FShape, ARegion.Shape);
985          Result := GetType;
986        end;
987      RGN_XOR:
988      begin
989        sh1 := HIShapeCreateUnion(FShape, ARegion.Shape);
990        sh2 := HIShapeCreateIntersection(FShape, ARegion.Shape);
991        Shape := HIShapeCreateDifference(sh1, sh2);
992        CFRelease(sh1);
993        CFRelease(sh2);
994        Result := GetType;
995      end;
996      RGN_OR:
997        begin
998          Shape := HIShapeCreateUnion(FShape, ARegion.Shape);
999          Result := GetType;
1000        end;
1001      RGN_DIFF:
1002      begin
1003        if HIShapeIsEmpty(FShape) then
1004          {HIShapeCreateDifference doesn't work properly if original shape is empty}
1005          {to simulate "emptieness" very big shape is created }
1006          Shape := HIShapeCreateWithRect(GetCGRect(MinCoord, MinCoord, MaxSize, MaxSize)); // create clip nothing.
1007
1008        Shape := HIShapeCreateDifference(FShape, ARegion.Shape);
1009        Result := GetType;
1010      end;
1011      RGN_COPY:
1012        begin
1013          Shape := HIShapeCreateCopy(ARegion.Shape);
1014          Result := GetType;
1015        end
1016    else
1017      Result := LCLType.Error;
1018    end;
1019  end;
1020end;
1021
1022procedure TCarbonRegion.Offset(dx, dy: Integer);
1023begin
1024  MakeMutable;
1025  HIShapeOffset(FShape, dx, dy);
1026end;
1027
1028function TCarbonRegion.GetShapeCopy: HIShapeRef;
1029begin
1030  Result := HIShapeCreateCopy(Shape);
1031end;
1032
1033procedure TCarbonRegion.MakeMutable;
1034begin
1035  Shape := HIShapeCreateMutableCopy(Shape);
1036end;
1037
1038{ TCarbonTextLayout }
1039
1040procedure TCarbonTextLayout.Release;
1041begin
1042  Free;
1043end;
1044
1045function TCarbonTextLayout.GetHeight: Integer;
1046begin
1047  Result := RoundFixed(Descent + Ascent);
1048end;
1049
1050function TCarbonTextLayout.GetWidth: Integer;
1051begin
1052  Result := RoundFixed(TextAfter - TextBefore);
1053end;
1054
1055function TCarbonTextLayout.GetDrawBounds(X, Y: Integer): CGRect;
1056begin
1057  Result := GetCGRectSorted(X - RoundFixed(FTextBefore),
1058    -Y, X + RoundFixed(FTextAfter), -Y - RoundFixed(FAscent + FDescent));
1059end;
1060
1061
1062{------------------------------------------------------------------------------
1063  Method:  TCarbonTextLayoutBuffer.Create
1064  Params:  Text           - UTF-8 text
1065           Font           - Text font
1066           TextFractional
1067
1068  Creates new Carbon text layout with buffer
1069 ------------------------------------------------------------------------------}
1070constructor TCarbonTextLayoutBuffer.Create(const Text: String; Font: TCarbonFont; TextFractional: Boolean);
1071var
1072  TextStyle: ATSUStyle;
1073  TextLength: LongWord;
1074  Tag: ATSUAttributeTag;
1075  DataSize: ByteCount;
1076  Options: ATSLineLayoutOptions;
1077  PValue: ATSUAttributeValuePtr;
1078begin
1079  // keep copy of text
1080  FTextBuffer := UTF8ToUTF16(Text);
1081  if FTextBuffer='' then
1082    FTextBuffer:=#0#0;
1083  TextStyle := Font.Style;
1084
1085  // create text layout
1086  TextLength := kATSUToTextEnd;
1087  if OSError(ATSUCreateTextLayoutWithTextPtr(ConstUniCharArrayPtr(@FTextBuffer[1]),
1088      kATSUFromTextBeginning, kATSUToTextEnd, Length(FTextBuffer), 1, @TextLength,
1089      @TextStyle, FLayout), Self, SCreate, 'ATSUCreateTextLayoutWithTextPtr') then Exit;
1090
1091  // set layout line orientation
1092  Tag := kATSULineRotationTag;
1093  DataSize := SizeOf(Fixed);
1094
1095  FLineRotation := Font.LineRotation;
1096  PValue := @(FLineRotation);
1097  if OSError(ATSUSetLayoutControls(FLayout, 1, @Tag, @DataSize, @PValue),
1098    Self, SCreate, 'ATSUSetLayoutControls', 'LineRotation') then Exit;
1099
1100  if not TextFractional then
1101  begin
1102    // disable fractional positions of glyphs in layout
1103    Tag := kATSULineLayoutOptionsTag;
1104    DataSize := SizeOf(ATSLineLayoutOptions);
1105
1106    Options := kATSLineFractDisable or kATSLineDisableAutoAdjustDisplayPos or
1107      kATSLineDisableAllLayoutOperations or kATSLineUseDeviceMetrics;
1108    PValue := @Options;
1109    if OSError(ATSUSetLayoutControls(FLayout, 1, @Tag, @DataSize, @PValue),
1110      Self, SCreate, 'ATSUSetLayoutControls', 'LineLayoutOptions') then Exit;
1111  end;
1112
1113  FDC := nil;
1114  FWidget := nil;
1115
1116  // allow font substitution for exotic glyphs
1117  OSError(ATSUSetTransientFontMatching(FLayout, True), Self, SCreate,
1118    'ATSUSetTransientFontMatching');
1119end;
1120
1121{------------------------------------------------------------------------------
1122  Method:  TCarbonTextLayoutBuffer.Apply
1123  Params:  ADC     - Context to apply to
1124
1125  Applies text layout to the specified context
1126 ------------------------------------------------------------------------------}
1127procedure TCarbonTextLayoutBuffer.Apply(ADC: TCarbonContext);
1128var
1129  Tag: ATSUAttributeTag;
1130  DataSize: ByteCount;
1131  PValue: ATSUAttributeValuePtr;
1132begin
1133  // check if must reset layout to new context
1134  if FDC = ADC then
1135  begin
1136    if (ADC is TCarbonControlContext) then
1137    begin
1138      if FWidget = (ADC as TCarbonControlContext).Owner.Content then Exit;
1139    end
1140    else
1141      if FWidget = nil then Exit;
1142  end;
1143
1144  FDC := ADC;
1145  if ADC is TCarbonControlContext then
1146    FWidget := (ADC as TCarbonControlContext).Owner.Content
1147  else
1148    FWidget := nil;
1149
1150  // set layout context
1151  Tag := kATSUCGContextTag;
1152  DataSize := SizeOf(CGContextRef);
1153
1154  PValue := @(ADC.CGContext);
1155  if OSError(ATSUSetLayoutControls(FLayout, 1, @Tag, @DataSize, @PValue),
1156    Self, 'Apply', 'ATSUSetLayoutControls', 'CGContext') then Exit;
1157
1158  // get text ascent
1159  if OSError(
1160    ATSUGetUnjustifiedBounds(FLayout, kATSUFromTextBeginning, kATSUToTextEnd,
1161      FTextBefore, FTextAfter, FAscent, FDescent),
1162    Self, 'Apply', SGetUnjustifiedBounds) then Exit;
1163end;
1164
1165
1166function ATSUCallback({%H-}iCurrentOperation: ATSULayoutOperationSelector; iLineRef: ATSULineRef; iRefCon: UInt32; {%H-}iOperationCallbackParameterPtr: UnivPtr;
1167  var oCallbackStatus: ATSULayoutOperationCallbackStatus ): OSStatus; {$ifdef DARWIN}mwpascal;{$endif}
1168var
1169  Buffer  : TCarbonTextLayoutBuffer;
1170  Handled : Boolean;
1171begin
1172  Result := noErr;
1173  Buffer := TCarbonTextLayoutBuffer(iRefCon);
1174  oCallbackStatus:=kATSULayoutOperationCallbackStatusHandled;
1175
1176  if Assigned(Buffer) then begin
1177    Handled:=false;
1178    Buffer.DoJustify(iLineRef, Handled);
1179  end;
1180end;
1181
1182procedure TCarbonTextLayoutBuffer.DoJustify(iLineRef: ATSULineRef; var Handled: Boolean);
1183type
1184	ATSLayoutRecord1 = packed record
1185		glyphID: ATSGlyphRef;
1186		flags: ATSGlyphInfoFlags;
1187		originalOffset: ByteCount;
1188		realPos: Fixed;
1189	end;
1190
1191type
1192  TATSLayoutRecordArray = array [Word] of ATSLayoutRecord1;
1193  PATSLayoutRecordArray = ^TATSLayoutRecordArray;
1194var
1195  i, ofs  : Integer;
1196  Layouts   : PATSLayoutRecordArray;
1197  LayCount  : ItemCount;
1198begin
1199  if not Assigned(FDX) or (FDXCount=0) then Exit;
1200  Laycount:=0;
1201  ATSUDirectGetLayoutDataArrayPtrFromLineRef( iLineRef,
1202    kATSUDirectDataLayoutRecordATSLayoutRecordVersion1, true, @Layouts, Laycount);
1203  if Assigned(Layouts) and (Laycount>0) then
1204  begin
1205    ofs:=0;
1206    for i:=0 to Min(FDXCount, LayCount)-1 do
1207    begin
1208      Layouts^[i].realPos:=Long2Fix(ofs);
1209      inc(ofs, FDX[i]);
1210    end;
1211  end;
1212  ATSUDirectReleaseLayoutDataArrayPtr(iLineRef, kATSUDirectDataLayoutRecordATSLayoutRecordCurrent, @Layouts );
1213  Handled:=True;
1214end;
1215
1216function TCarbonTextLayoutBuffer.Draw(X, Y: Integer; Dx: PInteger; DXCount: Integer): Boolean;
1217var
1218  MX, MY: ATSUTextMeasurement;
1219  A: Single;
1220  theTag    : ATSUAttributeTag;
1221  theSize   : ByteCount;
1222  theValue  : ATSUAttributeValuePtr;
1223  OverSpec  : ATSULayoutOperationOverrideSpecifier;
1224begin
1225  Result := False;
1226
1227  if FLineRotation <> 0 then
1228  begin
1229    A := FLineRotation * (PI / ($10000 * 180));
1230    MX := Round(Ascent * Sin(A));
1231    MY := Round(Ascent - Ascent * Cos(A));
1232  end
1233  else
1234  begin
1235    MX := 0;
1236    MY := 0;
1237  end;
1238
1239  if Assigned(Dx) then begin
1240    FDX := Dx;
1241    FDxCount := DXCount;
1242    idx:=0;
1243    OverSpec.operationSelector := kATSULayoutOperationPostLayoutAdjustment;
1244    OverSpec.overrideUPP := NewATSUDirectLayoutOperationOverrideUPP(@ATSUCallback);
1245    theTag := kATSULayoutOperationOverrideTag;
1246    theSize := sizeof (ATSULayoutOperationOverrideSpecifier);
1247    theValue := @OverSpec;
1248    ATSUSetTextLayoutRefCon(FLayout, UInt32(Self));
1249    ATSUSetLayoutControls (FLayout, 1, @theTag, @theSize, @theValue);
1250  end else begin
1251    FDX:=nil;
1252    FDXCount:=0;
1253  end;
1254
1255  if OSError(ATSUDrawText(FLayout, kATSUFromTextBeginning, kATSUToTextEnd,
1256      X shl 16 - FTextBefore + MX, -(Y shl 16) - FAscent + MY),
1257    Self, 'Draw', 'ATSUDrawText') then Exit;
1258
1259  if Assigned(Dx) then begin
1260    DisposeATSUDirectLayoutOperationOverrideUPP(OverSpec.overrideUPP);
1261    OverSpec.overrideUPP := nil;
1262    ATSUSetLayoutControls (FLayout, 1, @theTag, @theSize, @theValue);
1263    fDX := nil;
1264  end;
1265
1266  Result := True;
1267end;
1268
1269{------------------------------------------------------------------------------
1270  Method:  TCarbonTextLayoutBuffer.Release
1271
1272  Releases text layout
1273 ------------------------------------------------------------------------------}
1274procedure TCarbonTextLayoutBuffer.Release;
1275begin
1276  if FLayout <> nil then
1277    OSError(ATSUDisposeTextLayout(FLayout), Self, 'Release', 'ATSUDisposeTextLayout');
1278
1279  inherited;
1280end;
1281
1282{ TCarbonTextLayoutArray }
1283
1284{------------------------------------------------------------------------------
1285  Method:  TCarbonTextLayoutArray.Create
1286  Params:  Text           - UTF-8 text
1287           Font           - Text font
1288
1289  Creates new Carbon text layout array
1290 ------------------------------------------------------------------------------}
1291constructor TCarbonTextLayoutArray.Create(const Text: String; Font: TCarbonFont);
1292begin
1293  FText := Text;
1294  FFont := Font;
1295end;
1296
1297{------------------------------------------------------------------------------
1298  Method:  TCarbonTextLayoutArray.Apply
1299  Params:  ADC     - Context to apply to
1300
1301  Applies text layout to the specified context
1302 ------------------------------------------------------------------------------}
1303procedure TCarbonTextLayoutArray.Apply(ADC: TCarbonContext);
1304var
1305  I: Integer;
1306begin
1307  FAscent := 0;
1308  FDescent := 0;
1309  FTextBefore := 0;
1310  FTextAfter := 0;
1311
1312  for I := 1 to Length(FText) do
1313  begin
1314    FFont.FCachedLayouts[Ord(FText[I])].Apply(ADC);
1315
1316    if I = 1 then
1317    begin
1318      FAscent := FFont.FCachedLayouts[Ord(FText[1])].FAscent;
1319      FDescent := FFont.FCachedLayouts[Ord(FText[1])].FDescent;
1320      FTextBefore := FFont.FCachedLayouts[Ord(FText[1])].FTextBefore;
1321      FTextAfter := FTextBefore;
1322    end;
1323    FTextAfter := FTextAfter + Long2Fix(FFont.FCachedLayouts[Ord(FText[I])].GetWidth);
1324  end;
1325end;
1326
1327function TCarbonTextLayoutArray.Draw(X, Y: Integer; Dx: PInteger; DXCount: Integer): Boolean;
1328var
1329  I   : Integer;
1330  ix  : Integer;
1331begin
1332  Result := False;
1333  ix := 0;
1334  for I := 1 to Length(FText) do
1335  begin
1336    Result := FFont.FCachedLayouts[Ord(FText[I])].Draw(X, Y, nil, 0);
1337    if Assigned(dx) and (ix < DXCount) then
1338    begin
1339      Inc(X, Dx[ix]);
1340      inc(ix);
1341    end
1342    else
1343      Inc(X, FFont.FCachedLayouts[Ord(FText[I])].GetWidth);
1344  end;
1345
1346  Result := True;
1347end;
1348
1349{ TCarbonFont }
1350
1351{------------------------------------------------------------------------------
1352  Method:  TCarbonFont.Create
1353  Params:  AGlobal
1354
1355  Creates default Carbon font
1356 ------------------------------------------------------------------------------}
1357constructor TCarbonFont.Create(AGlobal: Boolean);
1358begin
1359  inherited Create(AGlobal);
1360
1361  FStyle := DefaultTextStyle;
1362  FLineRotation := 0;
1363end;
1364
1365{------------------------------------------------------------------------------
1366  Method:  TCarbonFont.Create
1367  Params:  ALogFont  - Font characteristics
1368           AFaceName - Name of the font
1369
1370  Creates Carbon font with the specified name and characteristics
1371 ------------------------------------------------------------------------------}
1372constructor TCarbonFont.Create(ALogFont: TLogFont; const AFaceName: String);
1373begin
1374  inherited Create(False);
1375
1376  FStyle := CreateStyle(ALogFont, AFaceName);
1377
1378  // applied when creating text layout
1379  FLineRotation := (ALogFont.lfEscapement shl 16) div 10;
1380end;
1381
1382{------------------------------------------------------------------------------
1383  Method:  TCarbonFont.CreateStyle
1384  Params:  ALogFont  - Font characteristics
1385           AFaceName - Name of the font
1386  Returns: ATSUStyle for the specified font name and characteristics
1387 ------------------------------------------------------------------------------}
1388function TCarbonFont.CreateStyle(ALogFont: TLogFont; const AFaceName: String): ATSUStyle;
1389var
1390  Attr: ATSUAttributeTag;
1391  M: ATSUTextMeasurement;
1392  O: ATSStyleRenderingOptions;
1393  B: Boolean;
1394  S: ByteCount;
1395  A: ATSUAttributeValuePtr;
1396  ID: ATSUFontID;
1397  H: Integer;
1398  Bold, Italic: Boolean;
1399const
1400  SSetAttrs = 'ATSUSetAttributes';
1401  SName = 'CreateStyle';
1402  ATSStyleRenderingOption: Array [NONANTIALIASED_QUALITY..ANTIALIASED_QUALITY] of
1403    ATSStyleRenderingOptions = (kATSStyleNoAntiAliasing, kATSStyleApplyAntiAliasing);
1404begin
1405  inherited Create(False);
1406
1407  Result:=nil;
1408  OSError(ATSUCreateStyle(Result), Self, SName, SCreateStyle);
1409
1410  Bold := ALogFont.lfWeight > FW_NORMAL;
1411  Italic := ALogFont.lfItalic > 0;
1412  ID := FindCarbonFontID(AFaceName, Bold, Italic, (ALogFont.lfPitchAndFamily and FIXED_PITCH) <> 0);
1413
1414  if ID <> 0 then
1415  begin
1416    Attr := kATSUFontTag;
1417    A := @ID;
1418    S := SizeOf(ID);
1419    OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName,
1420      SSetAttrs, 'kATSUFontTag');
1421  end;
1422
1423  if ALogFont.lfHeight = 0
1424    then H := CarbonDefaultFontSize
1425    else H := ALogFont.lfHeight;
1426
1427  Attr := kATSUSizeTag;
1428  M := Abs(H) shl 16;
1429  A := @M;
1430  S := SizeOf(M);
1431  OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName,
1432    SSetAttrs, 'kATSUSizeTag');
1433
1434  if Bold then
1435  begin
1436    Attr := kATSUQDBoldfaceTag;
1437    B := True;
1438    A := @B;
1439    S := SizeOf(B);
1440    OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName,
1441      SSetAttrs, 'kATSUQDBoldfaceTag');
1442  end;
1443
1444  if Italic then
1445  begin
1446    Attr := kATSUQDItalicTag;
1447    B := True;
1448    A := @B;
1449    S := SizeOf(B);
1450    OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName, SSetAttrs,
1451      'kATSUQDItalicTag');
1452  end;
1453
1454  if ALogFont.lfUnderline > 0 then
1455  begin
1456    Attr := kATSUQDUnderlineTag;
1457    B := True;
1458    A := @B;
1459    S := SizeOf(B);
1460    OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName,
1461      SSetAttrs, 'kATSUQDUnderlineTag');
1462  end;
1463
1464  if ALogFont.lfStrikeOut > 0 then
1465  begin
1466    Attr := kATSUStyleStrikeThroughTag;
1467    B := True;
1468    A := @B;
1469    S := SizeOf(B);
1470    OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName,
1471      SSetAttrs, 'kATSUStyleStrikeThroughTag');
1472  end;
1473
1474  if (ALogFont.lfQuality >= NONANTIALIASED_QUALITY) and
1475    (ALogFont.lfQuality <= ANTIALIASED_QUALITY) then
1476  begin
1477    Attr := kATSUStyleRenderingOptionsTag;
1478    O := ATSStyleRenderingOption[ALogFont.lfQuality];
1479    A := @O;
1480    S := SizeOf(O);
1481    OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName,
1482      SSetAttrs, 'kATSUStyleRenderingOptionsTag');
1483  end;
1484end;
1485
1486{------------------------------------------------------------------------------
1487  Method:  TCarbonFont.QueryStyle
1488  Params:  ALogFont  - Font characteristics
1489 ------------------------------------------------------------------------------}
1490procedure TCarbonFont.QueryStyle(ALogFont: PLogFont);
1491var
1492  Attr: ATSUAttributeTag;
1493  M: ATSUTextMeasurement;
1494  O: ATSStyleRenderingOptions;
1495  B: Boolean;
1496  S: ByteCount;
1497  A: ATSUAttributeValuePtr;
1498  ID: ATSUFontID;
1499  Ascent, Leading, Descent: Integer;
1500const
1501  SGetAttr = 'ATSUGetAttribute';
1502  SName = 'QueryStyle';
1503
1504begin
1505
1506  Attr := kATSUFontTag;
1507  A := @ID;
1508  S := SizeOf(ID);
1509  OSError(ATSUGetAttribute(Style, Attr, S, A, nil), Self, SName,
1510      SGetAttr, 'kATSUFontTag', kATSUNotSetErr);
1511
1512  ALogFont^.lfFaceName := CarbonFontIDTOFontName(ID);
1513
1514
1515  A := @M;
1516  S := SizeOf(M);
1517  OSError(ATSUGetAttribute(Style, kATSUAscentTag, S, A, nil), Self, SName,
1518      SGetAttr, 'kATSUAscentTag', kATSUNotSetErr);
1519  Ascent := (M shr 16);
1520
1521  OSError(ATSUGetAttribute(Style, kATSULeadingTag, S, A, nil), Self, SName,
1522      SGetAttr, 'kATSULeadingTag', kATSUNotSetErr);
1523  Leading := (M shr 16);
1524
1525  OSError(ATSUGetAttribute(Style, kATSUDescentTag, S, A, nil), Self, SName,
1526      SGetAttr, 'kATSUDescentTag', kATSUNotSetErr);
1527  Descent := (M shr 16);
1528
1529  ALogFont^.lfHeight := Ascent + Leading + Descent;
1530
1531
1532  Attr := kATSUQDBoldfaceTag;
1533  A := @B;
1534  S := SizeOf(B);
1535  OSError(ATSUGetAttribute(Style, Attr, S, A, nil), Self, SName,
1536      SGetAttr, 'kATSUQDBoldfaceTag', kATSUNotSetErr);
1537
1538  if B then ALogFont^.lfWeight := FW_BOLD else ALogFont^.lfWeight := FW_NORMAL;
1539
1540
1541  Attr := kATSUQDItalicTag;
1542  A := @B;
1543  S := SizeOf(B);
1544  OSError(ATSUGetAttribute(Style, Attr, S, A, nil), Self, SName, SGetAttr,
1545      'kATSUQDItalicTag', kATSUNotSetErr);
1546
1547  if B then ALogFont^.lfItalic := 1 else ALogFont^.lfItalic := 0;
1548
1549
1550  Attr := kATSUQDUnderlineTag;
1551  A := @B;
1552  S := SizeOf(B);
1553  OSError(ATSUGetAttribute(Style, Attr, S, A, nil), Self, SName,
1554      SGetAttr, 'kATSUQDUnderlineTag', kATSUNotSetErr);
1555
1556  if B then ALogFont^.lfUnderline := 1 else ALogFont^.lfUnderLine := 0;
1557
1558
1559  Attr := kATSUStyleStrikeThroughTag;
1560  A := @B;
1561  S := SizeOf(B);
1562  OSError(ATSUGetAttribute(Style, Attr, S, A, nil), Self, SName,
1563      SGetAttr, 'kATSUStyleStrikeThroughTag', kATSUNotSetErr);
1564
1565  if B then ALogFont^.lfStrikeOut := 1 else ALogFont^.lfStrikeOut := 0;
1566
1567
1568  Attr := kATSUStyleRenderingOptionsTag;
1569  A := @O;
1570  S := SizeOf(O);
1571  OSError(ATSUGetAttribute(Style, Attr, S, A, nil), Self, SName,
1572      SGetAttr, 'kATSUStyleRenderingOptionsTag', kATSUNotSetErr);
1573
1574  case O of
1575	kATSStyleApplyAntiAliasing:	ALogFont^.lfQuality := ANTIALIASED_QUALITY;
1576	kATSStyleNoAntiAliasing:	ALogFont^.lfQuality := NONANTIALIASED_QUALITY;
1577  else
1578	ALogFont^.lfQuality := DEFAULT_QUALITY;
1579  end;
1580end;
1581
1582{------------------------------------------------------------------------------
1583  Method:  TCarbonFont.Destroy
1584
1585  Frees Carbon font
1586 ------------------------------------------------------------------------------}
1587destructor TCarbonFont.Destroy;
1588var
1589  I: Integer;
1590begin
1591  if FStyle <> DefaultTextStyle then
1592    OSError(ATSUDisposeStyle(FStyle), Self, SDestroy, SDisposeStyle);
1593  for I := 0 to High(FCachedLayouts) do
1594    if FCachedLayouts[I] <> nil then FCachedLayouts[I].Release;
1595
1596  inherited;
1597end;
1598
1599{------------------------------------------------------------------------------
1600  Method:  TCarbonFont.SetColor
1601  Params:  AColor  - Font color
1602
1603  Chnage font style color
1604 ------------------------------------------------------------------------------}
1605procedure TCarbonFont.SetColor(AColor: TColor);
1606var
1607  Attr: ATSUAttributeTag;
1608  S: ByteCount;
1609  A: ATSUAttributeValuePtr;
1610  C: RGBColor;
1611begin
1612  C := ColorToRGBColor(AColor);
1613
1614  Attr := kATSUColorTag;
1615  A := @C;
1616  S := SizeOf(C);
1617  OSError(ATSUSetAttributes(Style, 1, @Attr, @S, @A), Self, SSetColor,
1618    'ATSUSetAttributes');
1619end;
1620
1621function TCarbonFont.CreateTextLayout(const Text: String;
1622  TextFractional: Boolean): TCarbonTextLayout;
1623
1624  function IsTextASCII: Boolean;
1625  var
1626    I: Integer;
1627    C: Byte;
1628  begin
1629    Result := False;
1630
1631    for I := 1 to Length(Text) do
1632    begin
1633      C := Ord(Text[I]);
1634      if (C > 127) or (C = 10) or (C = 13) then Exit;
1635    end;
1636
1637    Result := True;
1638  end;
1639var
1640  I, J, L: Integer;
1641  C: Byte;
1642begin
1643  if (FLineRotation <> 0) or TextFractional or not IsTextASCII then
1644    Result := TCarbonTextLayoutBuffer.Create(Text, Self, TextFractional)
1645  else
1646  begin
1647    for I := 1 to Length(Text) do
1648    begin
1649      C := Ord(Text[I]);
1650      if C > High(FCachedLayouts) then
1651      begin
1652        L := Length(FCachedLayouts);
1653        SetLength(FCachedLayouts, C + 1);
1654        for J := L to C do FCachedLayouts[J] := nil;
1655      end;
1656
1657      if FCachedLayouts[C] = nil then
1658        FCachedLayouts[C] := TCarbonTextLayoutBuffer.Create(Text[I], Self, TextFractional);
1659    end;
1660
1661    Result := TCarbontextLayoutArray.Create(Text, Self);
1662  end;
1663end;
1664
1665{ TCarbonColorObject }
1666
1667function TCarbonColorObject.GetColorRef: TColorRef;
1668begin
1669  Result := TColorRef(RGBToColor(FR, FG, FB));
1670end;
1671
1672{------------------------------------------------------------------------------
1673  Method:  TCarbonColorObject.Create
1674  Params:  AColor  - Color
1675           ASolid  - Opacity
1676           AGlobal - Global
1677
1678  Creates Carbon color object
1679 ------------------------------------------------------------------------------}
1680constructor TCarbonColorObject.Create(const AColor: TColor; ASolid, AGlobal: Boolean);
1681begin
1682  inherited Create(AGlobal);
1683
1684  SetColor(AColor, ASolid);
1685end;
1686
1687{------------------------------------------------------------------------------
1688  Method:  TCarbonColorObject.SetColor
1689  Params:  AColor - Color
1690           ASolid - Opacity
1691
1692  Sets the color and opacity
1693 ------------------------------------------------------------------------------}
1694procedure TCarbonColorObject.SetColor(const AColor: TColor; ASolid: Boolean);
1695begin
1696  RedGreenBlue(ColorToRGB(AColor), FR, FG, FB);
1697  FA := ASolid;
1698end;
1699
1700{------------------------------------------------------------------------------
1701  Method:  TCarbonColorObject.GetRGBA
1702  Params:  AROP2 - Binary raster operation
1703           AR, AG, AB, AA - Red, green, blue, alpha component of color
1704
1705  Gets the individual color components according to the binary raster operation
1706 ------------------------------------------------------------------------------}
1707procedure TCarbonColorObject.GetRGBA(AROP2: Integer; out AR, AG, AB, AA: Single);
1708begin
1709  case AROP2 of
1710    R2_BLACK:
1711    begin
1712      AR := 0;
1713      AG := 0;
1714      AB := 0;
1715      AA := Byte(FA);
1716    end;
1717    R2_WHITE:
1718    begin
1719      AR := 1;
1720      AG := 1;
1721      AB := 1;
1722      AA := Byte(FA);
1723    end;
1724    R2_NOP:
1725    begin
1726      AR := 1;
1727      AG := 1;
1728      AB := 1;
1729      AA := 0;
1730    end;
1731    R2_NOT:
1732    begin
1733      AR := 1;
1734      AG := 1;
1735      AB := 1;
1736      AA := Byte(FA);
1737    end;
1738    R2_NOTXORPEN, R2_NOTCOPYPEN:
1739    begin
1740      AR := (255 - FR) / 255;
1741      AG := (255 - FG) / 255;
1742      AB := (255 - FB) / 255;
1743      AA := Byte(FA);
1744    end;
1745  else // copy
1746    begin
1747      AR := FR / 255;
1748      AG := FG / 255;
1749      AB := FB / 255;
1750      AA := Byte(FA);
1751    end;
1752  end;
1753end;
1754
1755{------------------------------------------------------------------------------
1756  Method:  TCarbonColorObject.CreateCGColor
1757  Returns: CGColor
1758 ------------------------------------------------------------------------------}
1759function TCarbonColorObject.CreateCGColor: CGColorRef;
1760var
1761  F: Array [0..3] of Single;
1762begin
1763  F[0] := FR / 255;
1764  F[1] := FG / 255;
1765  F[2] := FB / 255;
1766  F[3] := Byte(FA);
1767
1768  Result := CGColorCreate(RGBColorSpace, @F[0]);
1769end;
1770
1771{ TCarbonBrush }
1772
1773procedure DrawBitmapPattern(info: UnivPtr; c: CGContextRef); MWPascal;
1774var
1775  ABrush: TCarbonBrush absolute info;
1776  AImage: CGImageRef;
1777begin
1778  AImage := ABrush.FBitmap.CGImage;
1779  CGContextDrawImage(c, GetCGRect(0, 0, CGImageGetWidth(AImage), CGImageGetHeight(AImage)),
1780    AImage);
1781end;
1782
1783procedure TCarbonBrush.SetHatchStyle(AHatch: PtrInt);
1784const
1785  HATCH_DATA: array[HS_HORIZONTAL..HS_DIAGCROSS] of array[0..7] of Byte =
1786 (
1787 { HS_HORIZONTAL } ($FF, $FF, $FF, $00, $FF, $FF, $FF, $FF),
1788 { HS_VERTICAL   } ($F7, $F7, $F7, $F7, $F7, $F7, $F7, $F7),
1789 { HS_FDIAGONAL  } ($7F, $BF, $DF, $EF, $F7, $FB, $FD, $FE),
1790 { HS_BDIAGONAL  } ($FE, $FD, $FB, $F7, $EF, $DF, $BF, $7F),
1791 { HS_CROSS      } ($F7, $F7, $F7, $00, $F7, $F7, $F7, $F7),
1792 { HS_DIAGCROSS  } ($7E, $BD, $DB, $E7, $E7, $DB, $BD, $7E)
1793  );
1794var
1795  ACallBacks: CGPatternCallbacks;
1796begin
1797  if AHatch in [HS_HORIZONTAL..HS_DIAGCROSS] then
1798  begin
1799    FillChar(ACallBacks{%H-}, SizeOf(ACallBacks), 0);
1800    ACallBacks.drawPattern := @DrawBitmapPattern;
1801    FBitmap := TCarbonBitmap.Create(8, 8, 1, 1, cbaByte, cbtMask, @HATCH_DATA[AHatch]);
1802    FColored := False;
1803    FCGPattern := CGPatternCreate(Self, GetCGRect(0, 0, 8, 8),
1804      CGAffineTransformIdentity, 8, 8, kCGPatternTilingConstantSpacing,
1805      Ord(FColored), ACallBacks);
1806  end;
1807end;
1808
1809procedure TCarbonBrush.SetBitmap(ABitmap: TCarbonBitmap);
1810var
1811  AWidth, AHeight: Integer;
1812  ACallBacks: CGPatternCallbacks;
1813begin
1814  AWidth := ABitmap.Width;
1815  AHeight := ABitmap.Height;
1816  FillChar(ACallBacks{%H-}, SizeOf(ACallBacks), 0);
1817  ACallBacks.drawPattern := @DrawBitmapPattern;
1818  FBitmap := TCarbonBitmap.Create(ABitmap);
1819  FColored := True;
1820  FCGPattern := CGPatternCreate(Self, GetCGRect(0, 0, AWidth, AHeight),
1821    CGAffineTransformIdentity, AWidth, AHeight, kCGPatternTilingConstantSpacing,
1822    Ord(FColored), ACallBacks);
1823end;
1824
1825{------------------------------------------------------------------------------
1826  Method:  TCarbonBrush.Create
1827  Params:  AGlobal
1828
1829  Creates default Carbon brush
1830 ------------------------------------------------------------------------------}
1831constructor TCarbonBrush.Create(AGlobal: Boolean);
1832begin
1833  inherited Create(clWhite, True, AGlobal);
1834  FCGPattern := nil;
1835  FBitmap := nil;
1836end;
1837
1838{------------------------------------------------------------------------------
1839  Method:  TCarbonBrush.Create
1840  Params:  ALogBrush - Brush characteristics
1841
1842  Creates Carbon brush with the specified characteristics
1843 ------------------------------------------------------------------------------}
1844constructor TCarbonBrush.Create(ALogBrush: TLogBrush);
1845begin
1846  FCGPattern := nil;
1847  FBitmap := nil;
1848  case ALogBrush.lbStyle of
1849    BS_SOLID:
1850        inherited Create(ColorToRGB(TColor(ALogBrush.lbColor)), True, False);
1851    BS_HATCHED:        // Hatched brush.
1852      begin
1853        inherited Create(ColorToRGB(TColor(ALogBrush.lbColor)), True, False);
1854        SetHatchStyle(ALogBrush.lbHatch);
1855      end;
1856    BS_DIBPATTERN,
1857    BS_DIBPATTERN8X8,
1858    BS_DIBPATTERNPT,
1859    BS_PATTERN,
1860    BS_PATTERN8X8:
1861      begin
1862        inherited Create(ColorToRGB(TColor(ALogBrush.lbColor)), False, False);
1863        SetBitmap(TCarbonBitmap(ALogBrush.lbHatch));
1864      end
1865    else
1866      inherited Create(ColorToRGB(TColor(ALogBrush.lbColor)), False, False);
1867  end;
1868end;
1869
1870destructor TCarbonBrush.Destroy;
1871begin
1872  if FCGPattern <> nil then
1873    CGPatternRelease(FCGPattern);
1874  FBitmap.Free;
1875  inherited Destroy;
1876end;
1877
1878{------------------------------------------------------------------------------
1879  Method:  TCarbonBrush.Apply
1880  Params:  ADC     - Context to apply to
1881           UseROP2 - Consider binary raster operation?
1882
1883  Applies brush to the specified context
1884 ------------------------------------------------------------------------------}
1885procedure TCarbonBrush.Apply(ADC: TCarbonContext; UseROP2: Boolean);
1886var
1887  RGBA: array[0..3] of Single;
1888  AROP2: Integer;
1889  APatternSpace: CGColorSpaceRef;
1890  BaseSpace : CGColorSpaceRef;
1891begin
1892  if ADC = nil then Exit;
1893  if ADC.CGContext = nil then Exit;
1894
1895  if UseROP2 then
1896    AROP2 := (ADC as TCarbonDeviceContext).ROP2
1897  else
1898    AROP2 := R2_COPYPEN;
1899
1900  GetRGBA(AROP2, RGBA[0], RGBA[1], RGBA[2], RGBA[3]);
1901
1902  // Blend Mode is set via TCarbonPen.Apply()
1903  //if AROP2 <> R2_NOT then
1904  //  CGContextSetBlendMode(ADC.CGContext, kCGBlendModeNormal)
1905  //else
1906  //  CGContextSetBlendMode(ADC.CGContext, kCGBlendModeDifference);
1907
1908  if FCGPattern <> nil then
1909  begin
1910    if not FColored then
1911      BaseSpace:=CGColorSpaceCreateDeviceRGB
1912    else
1913    begin
1914      BaseSpace:=nil;
1915      RGBA[0] := 1.0;
1916    end;
1917    APatternSpace := CGColorSpaceCreatePattern(BaseSpace);
1918    CGContextSetFillColorSpace(ADC.CGContext, APatternSpace);
1919    CGColorSpaceRelease(APatternSpace);
1920    if Assigned(BaseSpace) then CGColorSpaceRelease(BaseSpace);
1921    CGContextSetFillPattern(ADC.CGcontext, FCGPattern, @RGBA[0]);
1922  end
1923  else
1924    CGContextSetRGBFillColor(ADC.CGContext, RGBA[0], RGBA[1], RGBA[2], RGBA[3]);
1925end;
1926
1927{ TCarbonPen }
1928
1929{------------------------------------------------------------------------------
1930  Method:  TCarbonPen.Create
1931  Params:  AGlobal
1932
1933  Creates default Carbon pen
1934 ------------------------------------------------------------------------------}
1935constructor TCarbonPen.Create(AGlobal: Boolean);
1936begin
1937  inherited Create(clBlack, True, AGlobal);
1938  FStyle := PS_SOLID;
1939  FWidth := 1;
1940  FIsExtPen := False;
1941  Dashes := nil;
1942end;
1943
1944{------------------------------------------------------------------------------
1945  Method:  TCarbonPen.Create
1946  Params:  ALogPen - Pen characteristics
1947
1948  Creates Carbon pen with the specified characteristics
1949 ------------------------------------------------------------------------------}
1950constructor TCarbonPen.Create(ALogPen: TLogPen);
1951begin
1952  case ALogPen.lopnStyle of
1953    PS_SOLID..PS_DASHDOTDOT,
1954    PS_INSIDEFRAME:
1955      begin
1956        inherited Create(ColorToRGB(TColor(ALogPen.lopnColor)), True, False);
1957        FWidth := Max(1, ALogPen.lopnWidth.x);
1958      end;
1959    else
1960    begin
1961      inherited Create(ColorToRGB(TColor(ALogPen.lopnColor)), False, False);
1962      FWidth := 1;
1963    end;
1964  end;
1965
1966  FStyle := ALogPen.lopnStyle;
1967end;
1968
1969constructor TCarbonPen.Create(dwPenStyle, dwWidth: DWord; const lplb: TLogBrush; dwStyleCount: DWord; lpStyle: PDWord);
1970var
1971  i: integer;
1972begin
1973  case dwPenStyle and PS_STYLE_MASK of
1974    PS_SOLID..PS_DASHDOTDOT,
1975    PS_USERSTYLE:
1976      begin
1977        inherited Create(ColorToRGB(TColor(lplb.lbColor)), True, False);
1978      end;
1979    else
1980    begin
1981      inherited Create(ColorToRGB(TColor(lplb.lbColor)), False, False);
1982    end;
1983  end;
1984
1985  FIsExtPen := True;
1986  FIsGeometric := (dwPenStyle and PS_TYPE_MASK) = PS_GEOMETRIC;
1987
1988  if IsGeometric then
1989  begin
1990    case dwPenStyle and PS_JOIN_MASK of
1991      PS_JOIN_ROUND: FJoinStyle := kCGLineJoinRound;
1992      PS_JOIN_BEVEL: FJoinStyle := kCGLineJoinBevel;
1993      PS_JOIN_MITER: FJoinStyle := kCGLineJoinMiter;
1994    end;
1995
1996    case dwPenStyle and PS_ENDCAP_MASK of
1997      PS_ENDCAP_ROUND: FEndCap := kCGLineCapRound;
1998      PS_ENDCAP_SQUARE: FEndCap := kCGLineCapSquare;
1999      PS_ENDCAP_FLAT: FEndCap := kCGLineCapButt;
2000    end;
2001    FWidth := Max(1, dwWidth);
2002  end
2003  else
2004    FWidth := 1;
2005
2006  if (dwPenStyle and PS_STYLE_MASK) = PS_USERSTYLE then
2007  begin
2008    SetLength(Dashes, dwStyleCount);
2009    for i := 0 to dwStyleCount - 1 do
2010      Dashes[i] := lpStyle[i];
2011  end;
2012
2013  FStyle := dwPenStyle and PS_STYLE_MASK;
2014end;
2015
2016{------------------------------------------------------------------------------
2017  Method:  TCarbonPen.Apply
2018  Params:  ADC     - Context to apply to
2019           UseROP2 - Consider binary raster operation?
2020
2021  Applies pen to the specified context
2022 ------------------------------------------------------------------------------}
2023procedure TCarbonPen.Apply(ADC: TCarbonContext; UseROP2: Boolean);
2024
2025  function GetDashes(Source: TCarbonDashes): TCarbonDashes;
2026  var
2027    i: Integer;
2028  begin
2029    Result := Source;
2030    for i := Low(Result) to High(Result) do
2031      Result[i] := Result[i] * FWidth;
2032  end;
2033
2034var
2035  AR, AG, AB, AA: Single;
2036  AROP2: Integer;
2037  ADashes: TCarbonDashes;
2038  blendmode: CGBlendMode;
2039begin
2040  if ADC = nil then Exit;
2041  if ADC.CGContext = nil then Exit;
2042
2043  if UseROP2 then AROP2 := (ADC as TCarbonDeviceContext).ROP2
2044  else AROP2 := R2_COPYPEN;
2045
2046  GetRGBA(AROP2, AR, AG, AB, AA);
2047
2048  case AROP2 of
2049    R2_NOT:       blendmode := kCGBlendModeDifference;
2050    R2_NOTXORPEN: blendmode := kCGBlendModeExclusion;
2051    R2_XORPEN:    blendmode := kCGBlendModeDifference;
2052  else
2053    blendmode := kCGBlendModeNormal;
2054  end;
2055  CGContextSetBlendMode(ADC.CGContext, blendmode);
2056
2057  CGContextSetRGBStrokeColor(ADC.CGContext, AR, AG, AB, AA);
2058  CGContextSetLineWidth(ADC.CGContext, FWidth);
2059
2060  if IsExtPen then
2061  begin
2062    if IsGeometric then
2063    begin
2064      CGContextSetLineCap(ADC.CGContext, FEndCap);
2065      CGContextSetLineJoin(ADC.CGContext, FJoinStyle);
2066    end;
2067  end;
2068
2069  case FStyle of
2070    PS_DASH:
2071      begin
2072        ADashes := GetDashes(CarbonDashStyle);
2073        CGContextSetLineDash(ADC.CGContext, 0, @ADashes[0], Length(ADashes));
2074      end;
2075    PS_DOT:
2076      begin
2077        ADashes := GetDashes(CarbonDotStyle);
2078        CGContextSetLineDash(ADC.CGContext, 0, @ADashes[0], Length(ADashes));
2079      end;
2080    PS_DASHDOT:
2081      begin
2082        ADashes := GetDashes(CarbonDashDotStyle);
2083        CGContextSetLineDash(ADC.CGContext, 0, @ADashes[0], Length(ADashes));
2084      end;
2085    PS_DASHDOTDOT:
2086      begin
2087        ADashes := GetDashes(CarbonDashDotDotStyle);
2088        CGContextSetLineDash(ADC.CGContext, 0, @ADashes[0], Length(ADashes));
2089      end;
2090    PS_USERSTYLE:
2091      if Length(Dashes) = 0 then
2092        CGContextSetLineDash(ADC.CGContext, 0, nil, Length(Dashes))
2093      else
2094      CGContextSetLineDash(ADC.CGContext, 0, @Dashes[0], Length(Dashes));
2095  else
2096    CGContextSetLineDash(ADC.CGContext, 0, nil, 0);
2097  end;
2098end;
2099
2100{ TCarbonBitmap }
2101
2102{------------------------------------------------------------------------------
2103  Method:  TCarbonBitmap.GetBitsPerComponent
2104  Returns: Bitmap bits per component
2105 ------------------------------------------------------------------------------}
2106function TCarbonBitmap.GetBitsPerComponent: Integer;
2107begin
2108  case FType of
2109    cbtMask,
2110    cbtGray: Result := FDepth;
2111    cbtRGB,
2112    cbtBGR:  Result := FDepth div 3;
2113    cbtARGB,
2114    cbtRGBA,
2115    cbtBGRA: Result := FDepth shr 2;
2116  else
2117    Result := 0;
2118  end;
2119end;
2120
2121{------------------------------------------------------------------------------
2122  Method:  TCarbonBitmap.GetColorSpace
2123  Returns: The colorspace for this type of bitmap
2124 ------------------------------------------------------------------------------}
2125function TCarbonBitmap.GetColorSpace: CGColorSpaceRef;
2126begin
2127  if FType in [cbtMask, cbtGray]
2128  then Result := GrayColorSpace
2129  else Result := RGBColorSpace
2130end;
2131
2132{------------------------------------------------------------------------------
2133  Method:  TCarbonBitmap.GetInfo
2134  Returns: The CGBitmapInfo for this type of bitmap
2135 ------------------------------------------------------------------------------}
2136function TCarbonBitmap.GetInfo: CGBitmapInfo;
2137begin
2138  Result := BITMAPINFOMAP[FType];
2139end;
2140
2141procedure TCarbonBitmap.SetCGImage(const AValue: CGImageRef);
2142begin
2143  if FCGImage = AValue then
2144    Exit;
2145
2146  if FCGImage <> nil then
2147    CGImageRelease(FCGImage);
2148
2149  FCGImage := AValue;
2150
2151  UpdateInfo;
2152end;
2153
2154{------------------------------------------------------------------------------
2155  Method:  TCarbonBitmap.Create
2156  Params:  AWidth        - Bitmap width
2157           AHeight       - Bitmap height
2158           ADepth        - Significant bits per pixel
2159           ABitsPerPixel - The number of allocated bits per pixel (can be larger than depth)
2160           AAlignment    - Alignment of the data for each row
2161           ABytesPerRow  - The number of bytes between rows
2162           ACopyData     - Copy supplied bitmap data (OPTIONAL)
2163
2164  Creates Carbon bitmap with the specified characteristics
2165 ------------------------------------------------------------------------------}
2166constructor TCarbonBitmap.Create(AWidth, AHeight, ADepth, ABitsPerPixel: Integer;
2167  AAlignment: TCarbonBitmapAlignment; AType: TCarbonBitmapType; AData: Pointer;
2168  ACopyData: Boolean);
2169begin
2170  inherited Create(False);
2171
2172  FCGImage := nil;
2173
2174  SetInfo(AWidth, AHeight, ADepth, ABitsPerPixel, AAlignment, AType);
2175
2176  if (AData = nil) or ACopyData then
2177  begin
2178    System.GetMem(FData, FDataSize);
2179    FFreeData := True;
2180    if AData <> nil then
2181      System.Move(AData^, FData^, FDataSize) // copy data
2182    else
2183      FillDWord(FData^, FDataSize shr 2, 0); // clear bitmap
2184  end
2185  else
2186  begin
2187    FData := AData;
2188    FFreeData := False;
2189  end;
2190
2191//DebugLn(Format('TCarbonBitmap.Create %d x %d Data: %d RowSize: %d Size: %d',
2192//  [AWidth, AHeight, Integer(AData), DataRowSize, FDataSize]));
2193
2194  UpdateImage;
2195
2196  //DbgDumpImage(FCGImage, 'TCarbonBitmap.Create');
2197end;
2198
2199{------------------------------------------------------------------------------
2200  Method:  TCarbonBitmap.Create
2201  Params:  ABitmap - Source bitmap
2202
2203  Creates Carbon bitmap as a copy of specified bitmap
2204 ------------------------------------------------------------------------------}
2205constructor TCarbonBitmap.Create(ABitmap: TCarbonBitmap);
2206begin
2207  Create(ABitmap.Width, ABitmap.Height, ABitmap.Depth, ABitmap.FBitsPerPixel,
2208    ABitmap.FAlignment, ABitmap.FType, ABitmap.Data);
2209end;
2210
2211{------------------------------------------------------------------------------
2212  Method:  TCarbonBitmap.Destroy
2213
2214  Frees Carbon bitmap
2215 ------------------------------------------------------------------------------}
2216destructor TCarbonBitmap.Destroy;
2217begin
2218  CGImageRelease(FCGImage);
2219  if FFreeData then System.FreeMem(FData);
2220
2221  inherited Destroy;
2222end;
2223
2224procedure TCarbonBitmap.SetInfo(AWidth, AHeight, ADepth,
2225  ABitsPerPixel: Integer; AAlignment: TCarbonBitmapAlignment;
2226  AType: TCarbonBitmapType);
2227const
2228  ALIGNBITS: array[TCarbonBitmapAlignment] of Integer = (0, 1, 3, 7, $F);
2229var
2230  M: Integer;
2231begin
2232  if AWidth < 1 then AWidth := 1;
2233  if AHeight < 1 then AHeight := 1;
2234  FWidth := AWidth;
2235  FHeight := AHeight;
2236  FDepth := ADepth;
2237  FBitsPerPixel := ABitsPerPixel;
2238  FType := AType;
2239  FAlignment := AAlignment;
2240
2241  //todo: FDepth should not be Zero. Need to find out what's causing it.
2242  if (FType in [cbtMono, cbtGray]) and (FDepth=0) then
2243    FDepth:=FBitsPerPixel;
2244
2245  FBytesPerRow := ((AWidth * ABitsPerPixel) + 7) shr 3;
2246  M := FBytesPerRow and ALIGNBITS[AAlignment];
2247  if M <> 0 then Inc(FBytesPerRow, ALIGNBITS[AAlignment] + 1 - M);
2248
2249  FDataSize := FBytesPerRow * FHeight;
2250end;
2251
2252{------------------------------------------------------------------------------
2253  Method:  TCarbonBitmap.UpdateImage
2254
2255  Updates Carbon bitmap
2256 ------------------------------------------------------------------------------}
2257procedure TCarbonBitmap.UpdateImage;
2258var
2259  CGDataProvider: CGDataProviderRef;
2260begin
2261  // we have a data and description and we need to build CGImage
2262
2263  if FData = nil then Exit;
2264  if FCGImage <> nil then CGImageRelease(FCGImage);
2265
2266  CGDataProvider := CGDataProviderCreateWithData(nil, FData, FDataSize, nil);
2267  try
2268    if FType = cbtMask
2269    then FCGImage := CGImageMaskCreate(FWidth, FHeight, GetBitsPerComponent,
2270           FBitsPerPixel, FBytesPerRow, CGDataProvider, nil, 0)
2271    else FCGImage := CGImageCreate(FWidth, FHeight, GetBitsPerComponent,
2272           FBitsPerPixel, FBytesPerRow, GetColorSpace, BITMAPINFOMAP[FType],
2273           CGDataProvider, nil, 0, kCGRenderingIntentDefault);
2274  finally
2275    CGDataProviderRelease(CGDataProvider);
2276  end;
2277end;
2278
2279procedure TCarbonBitmap.UpdateInfo;
2280const
2281  ALIGNMAP: array[TRawImageLineEnd] of TCarbonBitmapAlignment = (cbaByte, cbaByte, cbaWord, cbaDWord, cbaQWord, cbaDQWord);
2282var
2283  ADesc: TRawImageDescription;
2284  AType: TCarbonBitmapType;
2285  ADataSize: PtrUInt;
2286begin
2287  // we have a CGImage and we need to update all info related to that image
2288
2289  if FFreeData then System.FreeMem(FData);
2290  FData := nil;
2291  FFreeData := True;
2292
2293  if not CarbonWidgetSet.RawImage_DescriptionFromCarbonBitmap(ADesc, Self) then
2294    Exit;
2295
2296  if not CarbonWidgetSet.RawImage_DescriptionToBitmapType(ADesc, AType) then
2297    Exit;
2298
2299  SetInfo(ADesc.Width, ADesc.Height, ADesc.Depth, ADesc.BitsPerPixel,
2300    ALIGNMAP[ADesc.LineEnd], AType);
2301
2302  FData := CarbonWidgetSet.GetImagePixelData(FCGImage, ADataSize);
2303  FDataSize := FDataSize;
2304end;
2305
2306{------------------------------------------------------------------------------
2307  Method:  TCarbonBitmap.CreateSubImage
2308  Returns: New image ref to portion of image data according to the rect
2309 ------------------------------------------------------------------------------}
2310function TCarbonBitmap.CreateSubImage(const ARect: TRect): CGImageRef;
2311begin
2312  if CGImage = nil then Result := nil
2313  else Result := CGImageCreateWithImageInRect(CGImage, RectToCGRect(ARect));
2314end;
2315
2316{------------------------------------------------------------------------------
2317  Method:  TCarbonBitmap.CreateMaskImage
2318  Returns: New mask image ref to portion of image data according to the rect
2319 ------------------------------------------------------------------------------}
2320function TCarbonBitmap.CreateMaskImage(const ARect: TRect): CGImageRef;
2321var
2322  CGDataProvider: CGDataProviderRef;
2323  Mask: CGImageRef;
2324begin
2325  CGDataProvider := CGDataProviderCreateWithData(nil, FData, FDataSize, nil);
2326  try
2327    Mask := CGImageMaskCreate(FWidth, FHeight, FBitsPerPixel,
2328      FBitsPerPixel, FBytesPerRow, CGDataProvider, nil, 0);
2329    Result := CGImageCreateWithImageInRect(Mask, RectToCGRect(ARect));
2330  finally
2331    CGDataProviderRelease(CGDataProvider);
2332    CGImageRelease(Mask);
2333  end;
2334end;
2335
2336{------------------------------------------------------------------------------
2337  Method:  TCarbonBitmap.CreateMaskedImage
2338  Returns: New image ref to masked image data
2339 ------------------------------------------------------------------------------}
2340function TCarbonBitmap.CreateMaskedImage(AMask: TCarbonBitmap): CGImageRef;
2341begin
2342  Result := CreateMaskedImage(AMask, Classes.Rect(0, 0, Width, Height));
2343end;
2344
2345{------------------------------------------------------------------------------
2346  Method:  TCarbonBitmap.CreateMaskedImage
2347  Returns: New image ref to portion of masked image data according to the rect
2348 ------------------------------------------------------------------------------}
2349function TCarbonBitmap.CreateMaskedImage(AMask: TCarbonBitmap;
2350  const ARect: TRect): CGImageRef;
2351var
2352  CGSubImage: CGImageRef;
2353  CGSubMaskImage: CGImageRef;
2354begin
2355  Result := nil;
2356  if CGImage = nil then Exit;
2357  if (AMask <> nil) and (AMask.CGImage <> nil) then
2358  begin
2359    CGSubImage := CreateSubImage(ARect);
2360    CGSubMaskImage := AMask.CreateMaskImage(ARect);
2361    try
2362      Result := CGImageCreateWithMask(CGSubImage, CGSubMaskImage);
2363    finally
2364      CGImageRelease(CGSubMaskImage);
2365      CGImageRelease(CGSubImage);
2366    end;
2367  end
2368  else
2369    Result := CreateSubImage(ARect);
2370end;
2371
2372procedure TCarbonBitmap.AddMask(AMask: TCarbonBitmap);
2373begin
2374  if AMask = nil then
2375    Exit;
2376
2377  CGImage := CreateMaskedImage(AMask);
2378end;
2379
2380{ TCarbonCursor }
2381
2382{------------------------------------------------------------------------------
2383  Method:  TCarbonCursor.Create
2384
2385  Creates Carbon cursor
2386 ------------------------------------------------------------------------------}
2387constructor TCarbonCursor.Create;
2388begin
2389  inherited Create(False);
2390
2391  FCursorType := cctUnknown;
2392  FThemeCursor := 0;
2393  FAnimationStep := 0;
2394  FQDHardwareCursorName := '';
2395  FPixmapHandle := nil;
2396end;
2397
2398{------------------------------------------------------------------------------
2399  Method:  TCarbonCursor.CreateThread
2400
2401  Creates cursor animation thread
2402 ------------------------------------------------------------------------------}
2403procedure TCarbonCursor.CreateThread;
2404begin
2405  FTaskID := nil;
2406  OSError(MPCreateTask(@AnimationCursorHandler, Self, 0, nil, nil, nil, 0, @FTaskID),
2407    Self, 'CreateThread', 'MPCreateTask');
2408end;
2409
2410{------------------------------------------------------------------------------
2411  Method:  TCarbonCursor.DestroyThread
2412
2413  Destroys cursor animation thread
2414 ------------------------------------------------------------------------------}
2415procedure TCarbonCursor.DestroyThread;
2416begin
2417  OSError(MPTerminateTask(FTaskID, noErr), Self, 'DestroyThread', 'MPTerminateTask');
2418  FTaskID := nil;
2419end;
2420
2421{------------------------------------------------------------------------------
2422  Method:  TCarbonCursor.CreateHardwareCursor
2423  Params:  ABitmap  - Cursor image
2424           AHotSpot - Hot spot position
2425
2426  Creates new hardware cursor
2427 ------------------------------------------------------------------------------}
2428procedure TCarbonCursor.CreateHardwareCursor(ABitmap: TCarbonBitmap; AHotSpot: Point);
2429var
2430  B: Rect;
2431begin
2432  FCursorType := cctQDHardware;
2433
2434  B.top := 0;
2435  B.left := 0;
2436  B.bottom := ABitmap.Height;
2437  B.right := ABitmap.Width;
2438
2439  FPixmapHandle := PixMapHandle(NewHandleClear(SizeOf(PixMap)));
2440  // tell that this is pixmap (bit 15 := 1)
2441  FPixmapHandle^^.rowBytes := SInt16(ABitmap.BytesPerRow or $8000);
2442  FPixmapHandle^^.bounds := B;
2443  FPixmapHandle^^.pmVersion := 0;
2444  FPixmapHandle^^.packType := 0;
2445  FPixmapHandle^^.packSize := 0;
2446  FPixmapHandle^^.hRes := $00480000; // 72 dpi
2447  FPixmapHandle^^.vRes := $00480000; // 72 dpi
2448  FPixmapHandle^^.pixelType := RGBDirect;
2449  FPixmapHandle^^.cmpSize := ABitmap.BitsPerComponent;
2450  FPixmapHandle^^.cmpCount := ABitmap.Depth div FPixmapHandle^^.cmpSize;  // $AARRGGBB
2451  FPixmapHandle^^.pixelSize := ABitmap.FBitsPerPixel; // depth
2452  FPixmapHandle^^.pmTable := nil;
2453  FPixmapHandle^^.baseAddr := Ptr(ABitmap.Data);
2454
2455  FQDHardwareCursorName := Application.Title + LazarusCursorInfix + IntToStr(Integer(FPixmapHandle));
2456  OSError(
2457    QDRegisterNamedPixMapCursor(FPixmapHandle, nil, AHotSpot, PChar(FQDHardwareCursorName)),
2458    Self, 'CreateHardwareCursor', 'QDRegisterNamedPixMapCursor');
2459end;
2460
2461{------------------------------------------------------------------------------
2462  Method:  TCarbonCursor.CreateColorCursor
2463  Params:  ABitmap  - Cursor image
2464           AHotSpot - Hot spot position
2465
2466  Creates new color cursor
2467 ------------------------------------------------------------------------------}
2468procedure TCarbonCursor.CreateColorCursor(ABitmap: TCarbonBitmap; AHotSpot: Point);
2469var
2470  Bounds: Rect;
2471  i, j, rowBytes: integer;
2472  SrcRowPtr, SrcPtr, DstRowPtr: PByte;
2473  RowMask, RowData, Bit: UInt16;
2474begin
2475  FCursorType := cctQDColor;
2476  Bounds.top := 0;
2477  Bounds.left := 0;
2478  Bounds.bottom := 16;
2479  Bounds.right := 16;
2480
2481  FPixmapHandle := PixMapHandle(NewHandleClear(SizeOf(PixMap)));
2482  FPixmapHandle^^.baseAddr := nil;
2483  FPixmapHandle^^.bounds := Bounds;
2484  FPixmapHandle^^.pmVersion := 0;
2485  FPixmapHandle^^.packType := 0;
2486  FPixmapHandle^^.packSize := 0;
2487  FPixmapHandle^^.hRes := $00480000; // 72 dpi
2488  FPixmapHandle^^.vRes := $00480000; // 72 dpi
2489  FPixmapHandle^^.pixelType := RGBDirect;
2490  FPixmapHandle^^.cmpSize := ABitmap.BitsPerComponent;
2491  FPixmapHandle^^.cmpCount := ABitmap.Depth div FPixmapHandle^^.cmpSize;  // $AARRGGBB
2492  FPixmapHandle^^.pixelSize := ABitmap.FBitsPerPixel; // depth
2493  rowBytes := FPixmapHandle^^.Bounds.right * (FPixmapHandle^^.pixelSize shr 3);
2494  // tell that this is pixmap (bit 15 := 1)
2495  FPixmapHandle^^.rowBytes := SInt16(rowBytes or $8000);
2496  FPixmapHandle^^.pmTable := nil;
2497
2498  // create cursor handle
2499  FQDColorCursorHandle := CCrsrHandle(NewHandleClear(SizeOf(CCrsr)));
2500  FQDColorCursorHandle^^.crsrType := SInt16($8001); // color cursor ($8000 - bw)
2501  FQDColorCursorHandle^^.crsrMap := FPixmapHandle;
2502  FQDColorCursorHandle^^.crsrXData := nil;
2503  FQDColorCursorHandle^^.crsrXValid := 0;
2504  FQDColorCursorHandle^^.crsrXHandle := nil;
2505  FQDColorCursorHandle^^.crsrHotspot.h := Min(15, AHotSpot.h);
2506  FQDColorCursorHandle^^.crsrHotspot.v := Min(15, AHotSpot.v);
2507  FQDColorCursorHandle^^.crsrXTable := 0;
2508  FQDColorCursorHandle^^.crsrID := GetCTSeed;
2509
2510  // handle for data with size = rowBytes * height
2511  FQDColorCursorHandle^^.crsrData := NewHandleClear(rowBytes * FPixmapHandle^^.bounds.bottom);
2512
2513  // fill cursor bitmap and mask
2514  SrcRowPtr := ABitmap.Data;
2515  DstRowPtr := PByte(FQDColorCursorHandle^^.crsrData^);
2516  for i := 0 to 15 do
2517  begin
2518    RowMask := 0;
2519    RowData := 0;
2520    Bit := $8000;
2521    SrcPtr := SrcRowPtr;
2522    System.Move(SrcPtr^, DstRowPtr^, 16 * 4);
2523    for j := 0 to 15 do
2524    begin
2525      // check alpha
2526      if SrcPtr[0] and $FF = 0 then
2527        RowData := RowData or Bit
2528      else
2529        RowMask := RowMask or Bit;
2530
2531      Bit := Bit shr 1;
2532      Inc(SrcPtr, 4);
2533    end;
2534 {$IFDEF ENDIAN_BIG}
2535    FQDColorCursorHandle^^.crsrMask[i] := SInt16(RowMask);
2536    FQDColorCursorHandle^^.crsr1Data[i] := SInt16(RowData);
2537 {$ELSE}
2538    FQDColorCursorHandle^^.crsrMask[i] := SInt16(CFSwapInt16(RowMask));
2539    FQDColorCursorHandle^^.crsr1Data[i] := SInt16(CFSwapInt16(RowData));
2540 {$ENDIF}
2541    Inc(SrcRowPtr, ABitmap.BytesPerRow);
2542    Inc(DstRowPtr, rowBytes);
2543  end;
2544end;
2545
2546
2547{------------------------------------------------------------------------------
2548  Method:  TCarbonCursor.CreateFromInfo
2549  Params:  AInfo - Array of cursor info
2550           ACount - Number of items in array
2551
2552  Creates new cursor from the specified info
2553 ------------------------------------------------------------------------------}
2554constructor TCarbonCursor.CreateAnimatedFromInfo(AInfo: PIconInfo; ACount: Integer);
2555var
2556  i: Integer;
2557begin
2558  FAnimationTimer := TTimer.Create(nil);
2559  FAnimationTimer.Enabled := False;
2560  FAnimationTimer.Interval := 150;//kThemeCursorAnimationDelay;
2561  FAnimationTimer.OnTimer := @StepQDAnimation;
2562  SetLength(FAnimationFrames, ACount);
2563  for i := 0 to ACount - 1 do begin
2564    CreateFromInfo(AInfo);
2565    FAnimationFrames[i].QDColorCursorHandle := FQDColorCursorHandle;
2566    FAnimationFrames[i].QDHardwareCursorName := FQDHardwareCursorName;
2567    FAnimationFrames[i].PixmapHandle := FPixmapHandle;
2568    Inc(AInfo);
2569  end;
2570end;
2571
2572{------------------------------------------------------------------------------
2573  Method:  TCarbonCursor.CreateFromInfo
2574  Params:  AInfo - Cusrsor info
2575
2576  Creates new cursor from the specified info
2577 ------------------------------------------------------------------------------}
2578constructor TCarbonCursor.CreateFromInfo(AInfo: PIconInfo);
2579var
2580  AHotspot: Point;
2581  AMaskedBitmap: TCarbonBitmap;
2582begin
2583  Create;
2584
2585  if (AInfo^.hbmColor = 0) or not (TObject(AInfo^.hbmColor) is TCarbonBitmap) then
2586    Exit;
2587
2588  AHotspot.h := AInfo^.xHotspot;
2589  AHotspot.v := AInfo^.yHotspot;
2590
2591  AMaskedBitmap := TCarbonBitmap(AInfo^.hbmColor);
2592  if (AInfo^.hbmMask <> 0) then
2593  begin
2594    AMaskedBitmap := TCarbonBitmap.Create(AMaskedBitmap);
2595    AMaskedBitmap.AddMask(TCarbonBitmap(AInfo^.hbmMask));
2596  end;
2597
2598  if HardwareCursorsSupported then
2599    CreateHardwareCursor(AMaskedBitmap, AHotSpot)
2600  else
2601    CreateColorCursor(AMaskedBitmap, AHotSpot);
2602
2603   if (AInfo^.hbmMask <> 0) then
2604     AMaskedBitmap.Free;
2605end;
2606
2607{------------------------------------------------------------------------------
2608  Method:  TCarbonCursor.CreateThemed
2609  Params:  AThemeCursor - Theme cursor kind
2610
2611  Creates new theme cursor
2612 ------------------------------------------------------------------------------}
2613constructor TCarbonCursor.CreateThemed(AThemeCursor: ThemeCursor;
2614  ADefault: Boolean);
2615const
2616  kThemeCursorTypeMap: array[kThemeArrowCursor..22] of TCarbonCursorType =
2617  (
2618    cctTheme,    // kThemeArrowCursor
2619    cctTheme,    // kThemeCopyArrowCursor
2620    cctTheme,    // kThemeAliasArrowCursor
2621    cctTheme,    // kThemeContextualMenuArrowCursor
2622    cctTheme,    // kThemeIBeamCursor
2623    cctTheme,    // kThemeCrossCursor
2624    cctTheme,    // kThemePlusCursor
2625    cctAnimated, // kThemeWatchCursor
2626    cctTheme,    // kThemeClosedHandCursor
2627    cctTheme,    // kThemeOpenHandCursor
2628    cctTheme,    // kThemePointingHandCursor
2629    cctAnimated, // kThemeCountingUpHandCursor
2630    cctAnimated, // kThemeCountingDownHandCursor
2631    cctAnimated, // kThemeCountingUpAndDownHandCursor
2632    cctWait,     // kThemeSpinningCursor (!!! obsolte and thats why we should use wait instead)
2633    cctTheme,    // kThemeResizeLeftCursor
2634    cctTheme,    // kThemeResizeRightCursor
2635    cctTheme,    // kThemeResizeLeftRightCursor
2636    cctTheme,    // kThemeNotAllowedCursor
2637    cctTheme,    // kThemeResizeUpCursor
2638    cctTheme,    // kThemeResizeDownCursor
2639    cctTheme,    // kThemeResizeUpDownCursor
2640    cctTheme     // kThemePoofCursor
2641  );
2642begin
2643  Create;
2644  FDefault := ADefault;
2645  FThemeCursor := AThemeCursor;
2646  if (AThemeCursor {%H-}>= Low(kThemeCursorTypeMap)) and
2647     (AThemeCursor <= High(kThemeCursorTypeMap)) then
2648    FCursorType := kThemeCursorTypeMap[FThemeCursor] else
2649    FCursorType := cctTheme;
2650end;
2651
2652
2653{------------------------------------------------------------------------------
2654  Method:  TCarbonCursor.Destroy
2655
2656  Frees QuickDraw cursor
2657 ------------------------------------------------------------------------------}
2658procedure TCarbonCursor.DestroyCursor;
2659begin
2660  case CursorType of
2661    cctQDHardware:
2662      if FQDHardwareCursorName <> '' then
2663      begin
2664        OSError(QDUnregisterNamedPixmapCursor(PChar(FQDHardwareCursorName)),
2665          Self, SDestroy, 'QDUnregisterNamedPixmapCursor');
2666
2667        FPixmapHandle^^.baseAddr := nil;
2668        DisposePixMap(FPixmapHandle);
2669      end;
2670    cctQDColor:
2671      DisposeCCursor(FQDColorCursorHandle);  // suppose pixmap will be disposed too
2672  end;
2673end;
2674
2675{------------------------------------------------------------------------------
2676  Method:  TCarbonCursor.Destroy
2677
2678  Frees Carbon cursor
2679 ------------------------------------------------------------------------------}
2680destructor TCarbonCursor.Destroy;
2681var
2682  i: Integer;
2683begin
2684  UnInstall;
2685
2686  if FAnimationFrames <> nil then
2687  begin
2688    FAnimationTimer.Free;
2689    for i := 0 to Length(FAnimationFrames) - 1 do
2690    begin
2691      FQDColorCursorHandle := FAnimationFrames[i].QDColorCursorHandle;
2692      FQDHardwareCursorName := FAnimationFrames[i].QDHardwareCursorName;
2693      FPixmapHandle := FAnimationFrames[i].PixmapHandle;
2694      DestroyCursor;
2695    end;
2696  end
2697  else
2698    DestroyCursor;
2699
2700  inherited Destroy;
2701end;
2702
2703{------------------------------------------------------------------------------
2704  Method:  TCarbonCursor.Install
2705
2706  Installs Carbon cursor
2707 ------------------------------------------------------------------------------}
2708procedure TCarbonCursor.Install;
2709const
2710  SName = 'Install';
2711begin
2712  {$IFDEF VerboseCursor}
2713    DebugLn('TCarbonCursor.Install type: ', DbgS(Ord(CursorType)));
2714  {$ENDIF}
2715
2716  if FAnimationTimer <> nil then
2717  begin
2718    FAnimationStep := 0;
2719    FAnimationTimer.Enabled := True;
2720  end;
2721  case CursorType of
2722    cctQDHardware:
2723      if FQDHardwareCursorName <> '' then
2724        OSError(QDSetNamedPixmapCursor(PChar(FQDHardwareCursorName)),
2725          Self, SName, 'QDSetNamedPixmapCursor');
2726    cctQDColor:
2727      SetCCursor(FQDColorCursorHandle);
2728    cctTheme:
2729      OSError(SetThemeCursor(FThemeCursor),
2730        Self, SName, 'SetThemeCursor');
2731    cctAnimated:
2732      begin
2733        FAnimationStep := 0;
2734        CreateThread;
2735      end;
2736    cctWait:
2737      QDDisplayWaitCursor(True);
2738    else
2739      DebugLn('[TCarbonCursor.Apply] !!! Unknown cursor type');
2740  end;
2741end;
2742
2743{------------------------------------------------------------------------------
2744  Method:  TCarbonCursor.UnInstall
2745
2746  Uninstalls Carbon cursor
2747 ------------------------------------------------------------------------------}
2748procedure TCarbonCursor.UnInstall;
2749begin
2750  case CursorType of
2751    cctWait: QDDisplayWaitCursor(False);
2752    cctAnimated: DestroyThread;
2753    cctQDColor, cctQDHardware:
2754      if FAnimationTimer <> nil then
2755        FAnimationTimer.Enabled := False;
2756  end;
2757end;
2758
2759{------------------------------------------------------------------------------
2760  Method:  TCarbonCursor.StepAnimation
2761  Returns: If the function succeeds
2762
2763  Steps Carbon cursor animation
2764 ------------------------------------------------------------------------------}
2765function TCarbonCursor.StepAnimation: Boolean;
2766begin
2767  Result := SetAnimatedThemeCursor(FThemeCursor, FAnimationStep) <> themeBadCursorIndexErr;
2768  if Result then
2769  begin
2770    inc(FAnimationStep);
2771  end else
2772  begin
2773    FCursorType := cctTheme;
2774    SetThemeCursor(FThemeCursor);
2775  end;
2776end;
2777
2778{------------------------------------------------------------------------------
2779  Method:  TCarbonCursor.StepQDAnimation
2780
2781  Steps Carbon QuickDraw cursor animation
2782 ------------------------------------------------------------------------------}
2783procedure TCarbonCursor.StepQDAnimation(Sender: TObject);
2784begin
2785  case CursorType of
2786    cctQDHardware:
2787      with FAnimationFrames[FAnimationStep] do
2788        if QDHardwareCursorName <> '' then
2789          OSError(QDSetNamedPixmapCursor(PChar(QDHardwareCursorName)),
2790            Self, 'StepAnimation', 'QDSetNamedPixmapCursor');
2791    cctQDColor:
2792      SetCCursor(FAnimationFrames[FAnimationStep].QDColorCursorHandle);
2793  end;
2794  FAnimationStep := (FAnimationStep + 1) mod Length(FAnimationFrames);
2795end;
2796
2797{------------------------------------------------------------------------------
2798  Method:  TCarbonCursor.HardwareCursorsSupported
2799  Returns: If hardware cursors are supported
2800 ------------------------------------------------------------------------------}
2801class function TCarbonCursor.HardwareCursorsSupported: Boolean;
2802var
2803  P: Point;
2804  ATestCursorName: String;
2805  ATempPixmap: PixmapHandle;
2806begin
2807  if MHardwareCursorsSupported = hcaUndef then
2808  begin
2809    ATestCursorName := Application.Title + LazarusCursorInfix + 'test';
2810    P.v := 0;
2811    P.h := 0;
2812
2813    ATempPixmap := PixMapHandle(NewHandleClear(SizeOf(PixMap)));
2814    if QDRegisterNamedPixMapCursor(ATempPixmap, nil, P, PChar(ATestCursorName)) = kQDNoColorHWCursorSupport then
2815      MHardwareCursorsSupported := hcaUnavailable else
2816      MHardwareCursorsSupported := hcaAvailable;
2817    QDUnregisterNamedPixmapCursor(PChar(ATestCursorName));
2818    DisposePixMap(ATempPixmap);
2819  end;
2820  Result := MHardwareCursorsSupported = hcaAvailable;
2821end;
2822
2823function GetScanLine(Bitmap: TCarbonBitmap; Line: Integer): PByteArray;
2824begin
2825  if (Line>=Bitmap.Height) or (Line<0) then Result:=nil
2826  else Result:=PByteArray(@PByteArray(Bitmap.Data)^[ Bitmap.BytesPerRow*Line ]);
2827end;
2828
2829type
2830  TColorPos = record
2831    ri  : Byte;
2832    gi  : Byte;
2833    bi  : Byte;
2834    ai  : Byte;
2835  end;
2836
2837procedure GetRGBA24(Bitmap: TCarbonBitmap; X,Y: Integer; out r,g,b,a: Byte; const pos: TColorPos);
2838var
2839  line  : PByteArray;
2840begin
2841  line:=GetScanLine(Bitmap, Y);
2842  if not Assigned(line) then begin
2843    r:=0;g:=0;b:=0;a:=$FF;
2844    Exit;
2845  end;
2846  r:=line^[x*3+pos.ri];
2847  g:=line^[x*3+pos.gi];
2848  b:=line^[x*3+pos.bi];
2849  a:=255;
2850end;
2851
2852procedure SetRGBA24(Bitmap: TCarbonBitmap; X,Y: Integer; r,g,b,{%H-}a: Byte; const pos: TColorPos);
2853var
2854  line  : PByteArray;
2855begin
2856  line:=GetScanLine(Bitmap, Y);
2857  if not Assigned(line) then Exit;
2858  line^[x*3+pos.ri]:=r;
2859  line^[x*3+pos.gi]:=g;
2860  line^[x*3+pos.bi]:=b;
2861end;
2862
2863procedure GetRGBA32(Bitmap: TCarbonBitmap; X,Y: Integer; out r,g,b,a: Byte; const pos: TColorPos);
2864var
2865  line  : PByteArray;
2866begin
2867  line:=GetScanLine(Bitmap, Y);
2868  if not Assigned(line) then begin
2869    r:=0;g:=0;b:=0;a:=$FF;
2870    Exit;
2871  end;
2872  r:=line^[x*4+pos.ri];
2873  g:=line^[x*4+pos.gi];
2874  b:=line^[x*4+pos.bi];
2875  a:=line^[x*4+pos.ai];
2876end;
2877
2878procedure SetRGBA32(Bitmap: TCarbonBitmap; X,Y: Integer; r,g,b,a: Byte; const pos: TColorPos);
2879var
2880  line  : PByteArray;
2881begin
2882  line:=GetScanLine(Bitmap, Y);
2883  if not Assigned(line) then Exit;
2884  line^[x*4+pos.ri]:=r;
2885  line^[x*4+pos.gi]:=g;
2886  line^[x*4+pos.bi]:=b;
2887  line^[x*4+pos.ai]:=a;
2888end;
2889
2890//todo: add support for non 24-32 bit images
2891//todo: faster and better code!
2892//todo: support for iBorderColor (currently ignored both ABorderColor and isBorderColor settings)
2893function FloodFillBitmap(const Bitmap: TCarbonBitmap; X,Y: Integer; ABorderColor, FillColor: TColor; isBorderColor: Boolean): Boolean;
2894var
2895  sr, sg, sb, sa  : Byte;
2896  tr, tg, tb, ta  : Byte;
2897  r,g,b,a : Byte;
2898  data  : array of TPoint;
2899  cnt   : Integer;
2900  i,j   : Integer;
2901  k     : Integer;
2902  clpos : TColorPos;
2903  FillColorRef: TColorRef;
2904const
2905  LEPos : TColorPos = (ri:1;gi:2;bi:3;ai:0);
2906const
2907  dx : array [0..3] of Integer = (-1,1,0,0);
2908  dy : array [0..3] of Integer = (0,0,-1,1);
2909var
2910  GetRGBA: procedure (Bitmap: TCarbonBitmap; X,Y: Integer; out r,g,b,a: Byte; const pos: TColorPos);
2911  SetRGBA: procedure (Bitmap: TCarbonBitmap; X,Y: Integer; r,g,b,a: Byte; const pos: TColorPos);
2912begin
2913  FillColorRef:=ColorToRGB(FillColor);
2914  r:=FillColorRef and $FF;
2915  g:=(FillColorRef shr 8) and $FF;
2916  b:=(FillColorRef shr 16) and $FF;
2917  a:=$FF;
2918  GetRGBA:=nil;
2919  SetRGBA:=nil;
2920  clpos:=LEPos; //todo: Little endian, big endian or bitmap specific
2921  if Bitmap.BitsPerComponent=8 then
2922  begin
2923    if Bitmap.FBitsPerPixel=32 then
2924    begin
2925      GetRGBA:=@GetRGBA32;
2926      SetRGBA:=@SetRGBA32;
2927    end else
2928    begin
2929      GetRGBA:=@GetRGBA24;
2930      SetRGBA:=@SetRGBA24;
2931    end;
2932  end;
2933  Result:=Assigned(GetRGBA);
2934  if not Result then Exit;
2935
2936  try
2937    GetRGBA(Bitmap, x,y, sr, sg, sb, sa, clpos);
2938    if (sr=r) and (sg=g) and (sb=b) then Exit;
2939    SetLength(data, Bitmap.Width*Bitmap.Height);
2940    cnt:=1;
2941    data[0].x:=x;
2942    data[0].y:=y;
2943    SetRGBA(Bitmap, x,y, r, g, b, a, clPos);
2944
2945    while cnt>0 do
2946    begin
2947      x:=data[0].x;
2948      y:=data[0].y;
2949      for k:=0 to 3 do
2950      begin
2951        i:=x+dx[k];
2952        j:=y+dy[k];
2953        if (i<0) or (j<0) or (i>=Bitmap.Width) or (j>=Bitmap.Height) then Continue;
2954        GetRGBA(Bitmap, i,j, tr, tg, tb, ta, clPos);
2955        if (tr=sr) and (tg=sg) and (tb=sb) then
2956        begin
2957          SetRGBA(Bitmap, i,j, r, g, b, a, clPos);
2958          data[cnt].X:=i;
2959          data[cnt].Y:=j;
2960          inc(cnt);
2961        end;
2962      end;
2963      dec(cnt);
2964      data[0]:=data[cnt];
2965    end;
2966  finally
2967    Bitmap.UpdateImage;
2968  end;
2969end;
2970
2971var
2972  LogBrush: TLogBrush;
2973
2974initialization
2975
2976  InitCursor;
2977
2978  StockSystemFont := TCarbonFont.Create(True);
2979
2980  LogBrush.lbStyle := BS_NULL;
2981  LogBrush.lbColor := 0;
2982  StockNullBrush := TCarbonBrush.Create(LogBrush);
2983
2984  WhiteBrush := TCarbonBrush.Create(True);
2985  BlackPen := TCarbonPen.Create(True);
2986
2987  DefaultFont := TCarbonFont.Create(True);
2988
2989  DefaultBrush := TCarbonBrush.Create(True);
2990  DefaultPen := TCarbonPen.Create(True);
2991
2992  DefaultContext := TCarbonBitmapContext.Create;
2993  DefaultBitmap := TCarbonBitmap.Create(1, 1, 32, 32, cbaDQWord, cbtARGB, nil);
2994  DefaultContext.Bitmap := DefaultBitmap;
2995
2996  ScreenContext := TCarbonScreenContext.Create;
2997  ScreenContext.CGContext := DefaultContext.CGContext; // workaround
2998
2999finalization
3000  DefaultContext.Free;
3001  ScreenContext.Free;
3002
3003  DefaultBrush.Free;
3004  DefaultPen.Free;
3005
3006  DefaultFont.Free;
3007
3008  BlackPen.Free;
3009  WhiteBrush.Free;
3010
3011  StockNullBrush.Free;
3012  StockSystemFont.Free;
3013
3014  DefaultBitmap.Free;
3015
3016end.
3017