source: trunk/Packages/Graphics32/GR32_Backends_LCL_Carbon.pas

Last change on this file was 2, checked in by chronos, 6 years ago
File size: 17.7 KB
Line 
1unit GR32_Backends_LCL_Carbon;
2
3(* ***** BEGIN LICENSE BLOCK *****
4 * Version: MPL 1.1 or LGPL 2.1 with linking exception
5 *
6 * The contents of this file are subject to the Mozilla Public License Version
7 * 1.1 (the "License"); you may not use this file except in compliance with
8 * the License. You may obtain a copy of the License at
9 * http://www.mozilla.org/MPL/
10 *
11 * Software distributed under the License is distributed on an "AS IS" basis,
12 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13 * for the specific language governing rights and limitations under the
14 * License.
15 *
16 * Alternatively, the contents of this file may be used under the terms of the
17 * Free Pascal modified version of the GNU Lesser General Public License
18 * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions
19 * of this license are applicable instead of those above.
20 * Please see the file LICENSE.txt for additional information concerning this
21 * license.
22 *
23 * The Original Code is Backend Extension for Graphics32
24 *
25 * The Initial Developer of the Original Code is
26 * Felipe Monteiro de Carvalho <felipemonteiro.carvalho@gmail.com>
27 *
28 * Portions created by the Initial Developer are Copyright (C) 2007-2012
29 * the Initial Developer. All Rights Reserved.
30 *
31 * Contributor(s):
32 *
33 * ***** END LICENSE BLOCK ***** *)
34
35interface
36
37{$I GR32.inc}
38
39uses
40 { RTL and LCL }
41 LCLIntf, LCLType, types, Controls, SysUtils, Classes, Graphics,
42 { Graphics 32 }
43 GR32, GR32_Backends, GR32_Containers, GR32_Image,
44 { Carbon bindings }
45 MacOSAll,
46 { Carbon lcl interface }
47 CarbonCanvas, CarbonPrivate;
48
49const
50 STR_GenericRGBProfilePath = '/System/Library/ColorSync/Profiles/Generic RGB Profile.icc';
51
52type
53
54 { TLCLBackend }
55
56 TLCLBackend = class(TCustomBackend,
57 IPaintSupport, IDeviceContextSupport,
58 ITextSupport, IFontSupport, ICanvasSupport)
59 private
60 FFont: TFont;
61 FCanvas: TCanvas;
62 FOnFontChange: TNotifyEvent;
63 FOnCanvasChange: TNotifyEvent;
64
65 { Carbon specific variables }
66 Stride: Integer;
67 FWidth, FHeight: Cardinal;
68 FProfile: CMProfileRef;
69 FColorSpace: CGColorSpaceRef;
70 FContext: CGContextRef;
71 FCanvasHandle: TCarbonDeviceContext;
72
73 { Functions to easely generate carbon structures }
74 function GetCarbonRect(Left, Top, Width, Height: Integer): MacOSAll.Rect;
75 function GetCGRect(Left, Top, Width, Height: Integer): MacOSAll.CGRect; overload;
76 function GetCGRect(SrcRect: TRect): MacOSAll.CGRect; overload;
77 protected
78 { BITS_GETTER }
79 function GetBits: PColor32Array; override;
80
81 procedure InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean); override;
82 procedure FinalizeSurface; override;
83
84 public
85 constructor Create; override;
86 destructor Destroy; override;
87
88 procedure Changed; override;
89
90 function Empty: Boolean; override;
91 public
92 { IPaintSupport }
93 procedure ImageNeeded;
94 procedure CheckPixmap;
95 procedure DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList; ACanvas: TCanvas; APaintBox: TCustomPaintBox32);
96
97 { IDeviceContextSupport }
98 function GetHandle: HDC;
99
100 procedure Draw(const DstRect, SrcRect: TRect; hSrc: HDC); overload;
101 procedure DrawTo(hDst: HDC; DstX, DstY: Integer); overload;
102 procedure DrawTo(hDst: HDC; const DstRect, SrcRect: TRect); overload;
103
104 property Handle: HDC read GetHandle;
105
106 { ITextSupport }
107 procedure Textout(X, Y: Integer; const Text: string); overload;
108 procedure Textout(X, Y: Integer; const ClipRect: TRect; const Text: string); overload;
109 procedure Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string); overload;
110 function TextExtent(const Text: string): TSize;
111
112 procedure TextoutW(X, Y: Integer; const Text: Widestring); overload;
113 procedure TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring); overload;
114 procedure TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring); overload;
115 function TextExtentW(const Text: Widestring): TSize;
116
117 { IFontSupport }
118 function GetOnFontChange: TNotifyEvent;
119 procedure SetOnFontChange(Handler: TNotifyEvent);
120 function GetFont: TFont;
121 procedure SetFont(const Font: TFont);
122 procedure UpdateFont;
123
124 property Font: TFont read GetFont write SetFont;
125 property OnFontChange: TNotifyEvent read FOnFontChange write FOnFontChange;
126
127 { ICanvasSupport }
128 function GetCanvasChange: TNotifyEvent;
129 procedure SetCanvasChange(Handler: TNotifyEvent);
130 function GetCanvas: TCanvas;
131
132 procedure DeleteCanvas;
133 function CanvasAllocated: Boolean;
134
135 property Canvas: TCanvas read GetCanvas;
136 property OnCanvasChange: TNotifyEvent read GetCanvasChange write SetCanvasChange;
137 end;
138
139implementation
140
141uses
142 GR32_LowLevel;
143
144var
145 StockFont: TFont;
146
147{ TLCLBackend }
148
149function TLCLBackend.GetCarbonRect(Left, Top, Width, Height: Integer): MacOSAll.Rect;
150begin
151 Result.Left := Left;
152 Result.Top := Top;
153 Result.Right := Left + Width;
154 Result.Bottom := Top + Height;
155end;
156
157function TLCLBackend.GetCGRect(Left, Top, Width, Height: Integer): MacOSAll.CGRect;
158begin
159 Result.Origin.X := Left;
160 Result.Origin.Y := Top;
161 Result.Size.Width := Width;
162 Result.Size.Height := Height;
163end;
164
165function TLCLBackend.GetCGRect(SrcRect: TRect): MacOSAll.CGRect;
166begin
167 Result.Origin.X := SrcRect.Left;
168 Result.Origin.Y := SrcRect.Top;
169 Result.Size.Width := SrcRect.Right - SrcRect.Left;
170 Result.Size.Height := SrcRect.Bottom - SrcRect.Top;
171end;
172
173constructor TLCLBackend.Create;
174var
175 loc: CMProfileLocation;
176 status: OSStatus;
177begin
178 {$IFDEF VerboseGR32Carbon}
179 WriteLn('[TLCLBackend.Create]', ' Self: ', IntToHex(PtrUInt(Self), 8));
180 {$ENDIF}
181
182 inherited;
183
184 { Creates a standard font }
185
186 FFont := TFont.Create;
187
188 { Creates a generic color profile }
189
190 loc.locType := cmPathBasedProfile;
191 loc.u.pathLoc.path := STR_GenericRGBProfilePath;
192
193 status := CMOpenProfile(FProfile, loc);
194
195 if status <> noErr then raise Exception.Create('Couldn''t create the generic profile');
196
197 { Creates a generic color space }
198
199 FColorSpace := CGColorSpaceCreateWithPlatformColorSpace(FProfile);
200
201 if FColorSpace = nil then raise Exception.Create('Couldn''t create the generic RGB color space');
202end;
203
204destructor TLCLBackend.Destroy;
205begin
206 {$IFDEF VerboseGR32Carbon}
207 WriteLn('[TLCLBackend.Destroy]',
208 ' Self: ', IntToHex(PtrUInt(Self), 8));
209 {$ENDIF}
210
211 { Deallocates the standard font }
212
213 FFont.Free;
214
215 { Closes the profile }
216
217 CMCloseProfile(FProfile);
218
219 inherited;
220end;
221
222function TLCLBackend.GetBits: PColor32Array;
223begin
224 Result := FBits;
225end;
226
227procedure TLCLBackend.InitializeSurface(NewWidth, NewHeight: Integer; ClearBuffer: Boolean);
228begin
229 {$IFDEF VerboseGR32Carbon}
230 WriteLn('[TLCLBackend.InitializeSurface] BEGIN',
231 ' Self: ', IntToHex(PtrUInt(Self), 8),
232 ' NewWidth: ', NewWidth,
233 ' NewHeight: ', NewHeight
234 );
235 {$ENDIF}
236
237 { We allocate our own memory for the image }
238 Stride := NewWidth * 4;
239 FBits := System.GetMem(NewHeight * Stride);
240
241 if FBits = nil then
242 raise Exception.Create('[TLCLBackend.InitializeSurface] ERROR FBits = nil');
243
244 { Creates a device context for our raw image area }
245
246 FContext := CGBitmapContextCreate(FBits,
247 NewWidth, NewHeight, 8, Stride, FColorSpace,
248 kCGImageAlphaNoneSkipFirst or kCGBitmapByteOrder32Little);
249
250 if FContext = nil then
251 raise Exception.Create('[TLCLBackend.InitializeSurface] ERROR FContext = nil');
252
253 { flip and offset CTM to upper left corner }
254 CGContextTranslateCTM(FContext, 0, NewHeight);
255 CGContextScaleCTM(FContext, 1, -1);
256
257 FWidth := NewWidth;
258 FHeight := NewHeight;
259
260 { clear the image }
261 if ClearBuffer then
262 FillLongword(FBits[0], NewWidth * NewHeight, clBlack32);
263
264 {$IFDEF VerboseGR32Carbon}
265 WriteLn('[TLCLBackend.InitializeSurface] END');
266 {$ENDIF}
267end;
268
269procedure TLCLBackend.FinalizeSurface;
270begin
271 {$IFDEF VerboseGR32Carbon}
272 WriteLn('[TLCLBackend.FinalizeSurface]',
273 ' Self: ', IntToHex(PtrUInt(Self), 8));
274 {$ENDIF}
275
276 if Assigned(FBits) then System.FreeMem(FBits);
277 FBits := nil;
278
279 if Assigned(FContext) then CGContextRelease(FContext);
280 FContext := nil;
281end;
282
283procedure TLCLBackend.Changed;
284begin
285 inherited;
286end;
287
288function TLCLBackend.Empty: Boolean;
289begin
290 Result := (FContext = nil) or (FBits = nil);
291end;
292
293{ IPaintSupport }
294
295procedure TLCLBackend.ImageNeeded;
296begin
297
298end;
299
300procedure TLCLBackend.CheckPixmap;
301begin
302
303end;
304
305procedure TLCLBackend.DoPaint(ABuffer: TBitmap32; AInvalidRects: TRectList;
306 ACanvas: TCanvas; APaintBox: TCustomPaintBox32);
307var
308 ImageRef: CGImageRef;
309begin
310 {$IFDEF VerboseGR32Carbon}
311 WriteLn('[TLCLBackend.DoPaint]',
312 ' Self: ', IntToHex(PtrUInt(Self), 8));
313 {$ENDIF}
314
315 { CGContextDrawImage is also possible, but it doesn't flip the image }
316 ImageRef := CGBitmapContextCreateImage(FContext);
317 try
318 HIViewDrawCGImage(
319 TCarbonDeviceContext(ACanvas.Handle).CGContext,
320 GetCGRect(0, 0, FWidth, FHeight), imageRef);
321 finally
322 if Assigned(ImageRef) then
323 CGImageRelease(ImageRef);
324 end;
325end;
326
327{ IDeviceContextSupport }
328
329function TLCLBackend.GetHandle: HDC;
330begin
331 {$IFDEF VerboseGR32Carbon}
332 WriteLn('[TLCLBackend.GetHandle]',
333 ' Self: ', IntToHex(PtrUInt(Self), 8));
334 {$ENDIF}
335
336 if not Assigned(FCanvas) then GetCanvas;
337
338 Result := FCanvas.Handle;
339end;
340
341procedure TLCLBackend.Draw(const DstRect, SrcRect: TRect; hSrc: HDC);
342var
343 original, subsection: CGImageRef;
344 CGDstRect, CGSrcRect: CGRect;
345 ExternalContext: CGContextRef;
346begin
347 {$IFDEF VerboseGR32Carbon}
348 WriteLn('[TLCLBackend.Draw]',
349 ' Self: ', IntToHex(PtrUInt(Self), 8));
350 {$ENDIF}
351
352 // Gets the external context
353 if (hSrc = 0) then Exit;
354 ExternalContext := TCarbonDeviceContext(hSrc).CGContext;
355
356 // Converts the rectangles to CoreGraphics rectangles
357 CGDstRect := GetCGRect(DstRect);
358 CGSrcRect := GetCGRect(SrcRect);
359
360 // Gets an image handle that represents the subsection
361 original := CGBitmapContextCreateImage(ExternalContext);
362 subsection := CGImageCreateWithImageInRect(original, CGSrcRect);
363 CGImageRelease(original);
364
365 { We need to make adjustments to the CTM so the painting is done correctly }
366 CGContextSaveGState(FContext);
367 try
368 CGContextTranslateCTM(FContext, 0, FOwner.Height);
369 CGContextScaleCTM(FContext, 1, -1);
370 CGContextTranslateCTM(FContext, 0, -CGDstRect.origin.y);
371 CGDstRect.origin.y := 0;
372
373 { Draw the subsection }
374 CGContextDrawImage(FContext, CGDstRect, subsection);
375 finally
376 { reset the CTM to the old values }
377 CGContextRestoreGState(FContext);
378 end;
379
380 // Release the subsection
381 CGImageRelease(subsection);
382end;
383
384procedure TLCLBackend.DrawTo(hDst: HDC; DstX, DstY: Integer);
385var
386 DstRect, SrcRect: TRect;
387begin
388 {$IFDEF VerboseGR32Carbon}
389 WriteLn('[TLCLBackend.DrawTo]',
390 ' Self: ', IntToHex(PtrUInt(Self), 8));
391 {$ENDIF}
392
393 DstRect.Left := DstX;
394 DstRect.Top := DstY;
395 DstRect.Right := FOwner.Width + DstX;
396 DstRect.Bottom := FOwner.Height + DstY;
397
398 SrcRect.Left := 0;
399 SrcRect.Top := 0;
400 SrcRect.Right := FOwner.Width;
401 SrcRect.Bottom := FOwner.Height;
402
403 DrawTo(hDst, DstRect, SrcRect);
404end;
405
406procedure TLCLBackend.DrawTo(hDst: HDC; const DstRect, SrcRect: TRect);
407var
408 original, subsection: CGImageRef;
409 CGDstRect, CGSrcRect: CGRect;
410 ExternalContext: CGContextRef;
411begin
412 {$IFDEF VerboseGR32Carbon}
413 WriteLn('[TLCLBackend.DrawTo with rects]',
414 ' Self: ', IntToHex(PtrUInt(Self), 8));
415 {$ENDIF}
416
417 // Gets the external context
418 if (hDst = 0) then Exit;
419 ExternalContext := TCarbonDeviceContext(hDst).CGContext;
420
421 // Converts the rectangles to CoreGraphics rectangles
422 CGDstRect := GetCGRect(DstRect);
423 CGSrcRect := GetCGRect(SrcRect);
424
425 // Gets an image handle that represents the subsection
426 original := CGBitmapContextCreateImage(FContext);
427 subsection := CGImageCreateWithImageInRect(original, CGSrcRect);
428 CGImageRelease(original);
429
430 { We need to make adjustments to the CTM so the painting is done correctly }
431 CGContextSaveGState(ExternalContext);
432 try
433 CGContextTranslateCTM(ExternalContext, 0, FOwner.Height);
434 CGContextScaleCTM(ExternalContext, 1, -1);
435 CGContextTranslateCTM(ExternalContext, 0, -CGDstRect.origin.y);
436 CGDstRect.origin.y := 0;
437
438 { Draw the subsection }
439 CGContextDrawImage(ExternalContext, CGDstRect, subsection);
440 finally
441 { reset the CTM to the old values }
442 CGContextRestoreGState(ExternalContext);
443 end;
444
445 // Release the subsection
446 CGImageRelease(subsection);
447end;
448
449{ ITextSupport }
450
451procedure TLCLBackend.Textout(X, Y: Integer; const Text: string);
452begin
453 {$IFDEF VerboseGR32Carbon}
454 WriteLn('[TLCLBackend.Textout]', ' Self: ', IntToHex(PtrUInt(Self), 8));
455 {$ENDIF}
456
457 if not Assigned(FCanvas) then GetCanvas;
458
459 UpdateFont;
460
461 if not FOwner.MeasuringMode then
462 FCanvas.TextOut(X, Y, Text);
463
464 FOwner.Changed;
465end;
466
467procedure TLCLBackend.Textout(X, Y: Integer; const ClipRect: TRect; const Text: string);
468begin
469 {$IFDEF VerboseGR32Carbon}
470 WriteLn('[TLCLBackend.Textout with ClipRect]', ' Self: ',
471 IntToHex(PtrUInt(Self), 8));
472 {$ENDIF}
473
474 if not Assigned(FCanvas) then GetCanvas;
475
476 UpdateFont;
477
478 LCLIntf.ExtTextOut(FCanvas.Handle, X, Y, ETO_CLIPPED, @ClipRect, PChar(Text),
479 Length(Text), nil);
480end;
481
482procedure TLCLBackend.Textout(var DstRect: TRect; const Flags: Cardinal; const Text: string);
483begin
484 {$IFDEF VerboseGR32Carbon}
485 WriteLn('[TLCLBackend.Textout with Flags]',
486 ' Self: ', IntToHex(PtrUInt(Self), 8));
487 {$ENDIF}
488
489 if not Assigned(FCanvas) then GetCanvas;
490
491 UpdateFont;
492
493 LCLIntf.DrawText(FCanvas.Handle, PChar(Text), Length(Text), DstRect, Flags);
494end;
495
496function TLCLBackend.TextExtent(const Text: string): TSize;
497begin
498 {$IFDEF VerboseGR32Carbon}
499 WriteLn('[TLCLBackend.TextExtent]',
500 ' Self: ', IntToHex(PtrUInt(Self), 8));
501 {$ENDIF}
502
503 if not Assigned(FCanvas) then GetCanvas;
504
505 UpdateFont;
506
507 Result := FCanvas.TextExtent(Text);
508end;
509
510{ Carbon uses UTF-8, so all W functions are converted to UTF-8 ones }
511
512procedure TLCLBackend.TextoutW(X, Y: Integer; const Text: Widestring);
513begin
514 TextOut(X, Y, Utf8Encode(Text));
515end;
516
517procedure TLCLBackend.TextoutW(X, Y: Integer; const ClipRect: TRect; const Text: Widestring);
518begin
519 TextOut(X, Y, ClipRect, Utf8Encode(Text));
520end;
521
522procedure TLCLBackend.TextoutW(var DstRect: TRect; const Flags: Cardinal; const Text: Widestring);
523begin
524 TextOut(DstRect, Flags, Utf8Encode(Text));
525end;
526
527function TLCLBackend.TextExtentW(const Text: Widestring): TSize;
528begin
529 Result := TextExtent(Utf8Encode(Text));
530end;
531
532{ IFontSupport }
533
534function TLCLBackend.GetOnFontChange: TNotifyEvent;
535begin
536 {$IFDEF VerboseGR32Carbon}
537 WriteLn('[TLCLBackend.GetOnFontChange]',
538 ' Self: ', IntToHex(PtrUInt(Self), 8));
539 {$ENDIF}
540
541 Result := FFont.OnChange;
542end;
543
544procedure TLCLBackend.SetOnFontChange(Handler: TNotifyEvent);
545begin
546 {$IFDEF VerboseGR32Carbon}
547 WriteLn('[TLCLBackend.SetOnFontChange]',
548 ' Self: ', IntToHex(PtrUInt(Self), 8));
549 {$ENDIF}
550
551 FFont.OnChange := Handler;
552end;
553
554function TLCLBackend.GetFont: TFont;
555begin
556 {$IFDEF VerboseGR32Carbon}
557 WriteLn('[TLCLBackend.GetFont]',
558 ' Self: ', IntToHex(PtrUInt(Self), 8));
559 {$ENDIF}
560
561 Result := FFont;
562end;
563
564procedure TLCLBackend.SetFont(const Font: TFont);
565begin
566 {$IFDEF VerboseGR32Carbon}
567 WriteLn('[TLCLBackend.SetFont]',
568 ' Self: ', IntToHex(PtrUInt(Self), 8));
569 {$ENDIF}
570
571 FFont.Assign(Font);
572end;
573
574procedure TLCLBackend.UpdateFont;
575begin
576 {$IFDEF VerboseGR32Carbon}
577 WriteLn('[TLCLBackend.UpdateFont]',
578 ' Self: ', IntToHex(PtrUInt(Self), 8));
579 {$ENDIF}
580
581 FFont.OnChange := FOnFontChange;
582
583 if Assigned(FCanvas) then FCanvas.Font := FFont;
584end;
585
586{ ICanvasSupport }
587
588function TLCLBackend.GetCanvasChange: TNotifyEvent;
589begin
590 {$IFDEF VerboseGR32Carbon}
591 WriteLn('[TLCLBackend.GetCanvasChange]',
592 ' Self: ', IntToHex(PtrUInt(Self), 8));
593 {$ENDIF}
594
595 Result := FOnCanvasChange;
596end;
597
598procedure TLCLBackend.SetCanvasChange(Handler: TNotifyEvent);
599begin
600 {$IFDEF VerboseGR32Carbon}
601 WriteLn('[TLCLBackend.SetCanvasChange]',
602 ' Self: ', IntToHex(PtrUInt(Self), 8));
603 {$ENDIF}
604
605 FOnCanvasChange := Handler;
606end;
607
608function TLCLBackend.GetCanvas: TCanvas;
609begin
610 {$IFDEF VerboseGR32Carbon}
611 WriteLn('[TLCLBackend.GetCanvas] BEGIN',
612 ' Self: ', IntToHex(PtrUInt(Self), 8));
613 {$ENDIF}
614
615 if FCanvas = nil then
616 begin
617 FCanvas := TCanvas.Create;
618
619 FCanvasHandle := TCarbonDeviceContext.Create;
620 FCanvasHandle.CGContext := FContext;
621
622 FCanvas.Handle := HDC(FCanvasHandle);
623 FCanvas.OnChange := FOnCanvasChange;
624
625 FCanvas.Font := FFont;
626 end;
627
628 Result := FCanvas;
629
630 {$IFDEF VerboseGR32Carbon}
631 WriteLn('[TLCLBackend.GetCanvas] END');
632 {$ENDIF}
633end;
634
635procedure TLCLBackend.DeleteCanvas;
636begin
637 {$IFDEF VerboseGR32Carbon}
638 WriteLn('[TLCLBackend.DeleteCanvas]',
639 ' Self: ', IntToHex(PtrUInt(Self), 8),
640 ' FCanvas: ', PtrUInt(FCanvas));
641 {$ENDIF}
642
643 if Assigned(FCanvas) then
644 begin
645 FCanvas.Handle := 0;
646
647 FCanvas.Free;
648
649 FCanvas := nil;
650 end;
651end;
652
653function TLCLBackend.CanvasAllocated: Boolean;
654begin
655 Result := (FCanvas <> nil);
656
657 {$IFDEF VerboseGR32Carbon}
658 WriteLn('[TLCLBackend.CanvasAllocated]',
659 ' Self: ', IntToHex(PtrUInt(Self), 8),
660 ' FCanvas: ', PtrUInt(FCanvas));
661 {$ENDIF}
662end;
663
664initialization
665 StockFont := TFont.Create;
666
667finalization
668 StockFont.Free;
669
670end.
Note: See TracBrowser for help on using the repository browser.