1 {
2 *****************************************************************************
3 * gtk3objects.pas *
4 * ----------------- *
5 * *
6 * *
7 *****************************************************************************
8
9 *****************************************************************************
10 This file is part of the Lazarus Component Library (LCL)
11
12 See the file COPYING.modifiedLGPL.txt, included in this distribution,
13 for details about the license.
14 *****************************************************************************
15 }
16 unit gtk3objects;
17 {$i gtk3defines.inc}
18 {$mode objfpc}
19 {$H+}
20
21 interface
22
23 uses
24 Classes, SysUtils, Graphics, types, LCLType, LCLProc, LazUTF8, IntegerList,
25 LazGtk3, LazGdk3, LazGObject2, LazPango1, LazPangoCairo1, LazGdkPixbuf2,
26 LazGLib2, LazCairo1, FPCanvas;
27
28 type
29 TGtk3DeviceContext = class;
30
31 { TGtk3Object }
32
33 TGtk3Object = class(TObject)
34 private
35 FUpdateCount: Integer;
36 public
37 constructor Create; virtual; overload;
38 procedure Release; virtual;
39 procedure BeginUpdate; virtual;
40 procedure EndUpdate; virtual;
InUpdatenull41 function InUpdate: Boolean;
42 end;
43
44 { TGtk3ContextObject }
45
46 TGtk3ContextObject = class(TGtk3Object)
47 private
48 FShared: Boolean;
49 public
50 constructor Create; override;
51 property Shared: Boolean read FShared write FShared;
52 end;
53
54 { TGtk3Font }
55
56 TGtk3Font = class(TGtk3ContextObject)
57 private
58 FLayout: PPangoLayout;
59 FLogFont: TLogFont;
60 FFontName: String;
61 FHandle: PPangoFontDescription;
62 procedure SetFontName(AValue: String);
63 public
64 constructor Create(ACairo: Pcairo_t; AWidget: PGtkWidget = nil);
65 constructor Create(ALogFont: TLogFont; ALongFontName: String);
66 destructor Destroy; override;
67 property FontName: String read FFontName write SetFontName;
68 property Handle: PPangoFontDescription read FHandle;
69 property Layout: PPangoLayout read FLayout;
70 property LogFont: TLogFont read FLogFont;
71 end;
72
73 { TGtk3Brush }
74
75 TGtk3Brush = class(TGtk3ContextObject)
76 private
77 FColor: TColor;
78 FContext: TGtk3DeviceContext;
79 FStyle: LongWord;
GetColornull80 function GetColor: TColor;
81 procedure SetColor(AValue: TColor);
82 procedure SetStyle(AValue: cardinal);
83 public
84 LogBrush: TLogBrush;
85 constructor Create; override;
86 property Color: TColor read GetColor write SetColor;
87 property Context: TGtk3DeviceContext read FContext write FContext;
88 property Style: LongWord read FStyle write SetStyle;
89 end;
90
91 { TGtk3Pen }
92
93 TGtk3Pen = class(TGtk3ContextObject)
94 private
95 FCosmetic: Boolean;
96 FEndCap: TPenEndCap;
97 FJoinStyle: TPenJoinStyle;
98 FPenMode: TPenMode;
99 FStyle: TFPPenStyle;
100 FWidth: Integer;
101 FColor: TColor;
102 FContext: TGtk3DeviceContext;
103 FIsExtPen: Boolean;
GetColornull104 function GetColor: TColor;
GetWidthnull105 function GetWidth: Integer;
106 procedure SetColor(AValue: TColor);
107 procedure setCosmetic(b: Boolean);
108 procedure SetEndCap(AValue: TPenEndCap);
109 procedure SetJoinStyle(AValue: TPenJoinStyle);
110 procedure SetPenMode(AValue: TPenMode);
111 procedure SetStyle(AValue: TFPPenStyle);
112 procedure setWidth(p1: Integer);
113 public
114 LogPen: TLogPen;
115 constructor Create; override;
116 property Color: TColor read GetColor write SetColor;
117 property Context: TGtk3DeviceContext read FContext write FContext;
118
119 property Cosmetic: Boolean read FCosmetic write SetCosmetic;
120 property EndCap: TPenEndCap read FEndCap write SetEndCap;
121 property IsExtPen: Boolean read FIsExtPen write FIsExtPen;
122 property JoinStyle: TPenJoinStyle read FJoinStyle write SetJoinStyle;
123 property Mode: TPenMode read FPenMode write SetPenMode;
124 property Style: TFPPenStyle read FStyle write SetStyle;
125 property Width: Integer read GetWidth write SetWidth;
126 end;
127
128 { TGtk3Region }
129
130 TGtk3Region = class(TGtk3ContextObject)
131 private
132 FHandle: Pcairo_region_t;
133 public
134 property Handle: Pcairo_region_t read FHandle write FHandle;
135 constructor Create(CreateHandle: Boolean); virtual; overload;
136 constructor Create(CreateHandle: Boolean; X1,Y1,X2,Y2: Integer); virtual; overload;
137 destructor Destroy; override;
GetExtentsnull138 function GetExtents: TRect;
ContainsRectnull139 function ContainsRect(ARect: TRect): Boolean;
ContainsPointnull140 function ContainsPoint(APoint: TPoint): Boolean;
141 end;
142
143 { TGtk3Image }
144
145 TGtk3Image = class(TGtk3ContextObject)
146 private
147 FData: PByte;
148 FDataOwner: Boolean;
149 FHandle: PGdkPixbuf;
150 FFormat : cairo_format_t;
151 public
152 constructor Create; override;
153 constructor Create(vHandle: PGdkPixbuf); overload;
154 constructor Create(AData: PByte; width: Integer; height: Integer; format: cairo_format_t; const ADataOwner: Boolean = False); overload;
155 constructor Create(AData: PByte; width: Integer; height: Integer; bytesPerLine: Integer; format: cairo_format_t; const ADataOwner: Boolean = False); overload;
156 destructor Destroy; override;
157 procedure CopyFrom(AImage: PGdkPixbuf; x, y, w, h: integer);
heightnull158 function height: Integer;
widthnull159 function width: Integer;
depthnull160 function depth: Integer;
dotsPerMeterXnull161 function dotsPerMeterX: Integer;
dotsPerMeterYnull162 function dotsPerMeterY: Integer;
bitsnull163 function bits: PByte;
numBytesnull164 function numBytes: LongWord;
bytesPerLinenull165 function bytesPerLine: Integer;
getFormatnull166 function getFormat: cairo_format_t;
167 property Handle: PGdkPixbuf read FHandle;
168 end;
169
170 { TGtk3Cursor }
171
172 TGtk3Cursor = class(TGtk3ContextObject)
173 // TODO
174 end;
175
176 { TGtk3DeviceContext }
177
178 TGtk3DeviceContext = class (TGtk3Object)
179 private
180 FBrush: TGtk3Brush;
181 FFont: TGtk3Font;
182 FvImage: TGtk3Image;
183 FCanRelease: Boolean;
184 FCurrentBrush: TGtk3Brush;
185 FCurrentFont: TGtk3Font;
186 FCurrentImage: TGtk3Image;
187 FCurrentTextColor: TColorRef;
188 FCurrentRegion: TGtk3Region;
189 FOwnsCairo: Boolean;
190 FOwnsSurface: Boolean;
191 FPen: TGtk3Pen;
192 FvClipRect: TRect;
193 FCurrentPen: TGtk3Pen;
194 FBkMode: Integer;
GetBkModenull195 function GetBkMode: Integer;
getBrushnull196 function getBrush: TGtk3Brush;
GetFontnull197 function GetFont: TGtk3Font;
GetOffsetnull198 function GetOffset: TPoint;
getPennull199 function getPen: TGtk3Pen;
GetvImagenull200 function GetvImage: TGtk3Image;
201 procedure SetBkMode(AValue: Integer);
202 procedure setBrush(AValue: TGtk3Brush);
203 procedure SetCurrentTextColor(AValue: TColorRef);
204 procedure SetFont(AValue: TGtk3Font);
205 procedure SetOffset(AValue: TPoint);
206 procedure setPen(AValue: TGtk3Pen);
207 procedure SetvImage(AValue: TGtk3Image);
SXnull208 function SX(const x: double): Double;
SYnull209 function SY(const y: double): Double;
SX2null210 function SX2(const x: double): Double;
SY2null211 function SY2(const y: double): Double;
212 procedure ApplyBrush;
213 procedure ApplyFont;
214 procedure ApplyPen;
215 procedure FillAndStroke;
216 public
217 CairoSurface: Pcairo_surface_t;
218 Widget: Pcairo_t;
219 Parent: PGtkWidget;
220 Window: PGdkWindow;
221 ParentPixmap: PGdkPixbuf;
222 fncOrigin:TPoint; // non-client area offsets surface origin
223 constructor Create(AWidget: PGtkWidget; const APaintEvent: Boolean = False); virtual;
224 constructor Create(AWindow: PGdkWindow; const APaintEvent: Boolean); virtual;
225 constructor CreateFromCairo(AWidget: PGtkWidget; ACairo: PCairo_t); virtual;
226 destructor Destroy; override;
227 procedure CreateObjects;
228 procedure DeleteObjects;
229 public
230 procedure drawPoint(x1: Integer; y1: Integer);
231 procedure drawRect(x1: Integer; y1: Integer; w: Integer; h: Integer; const AFill: Boolean);
232 procedure drawRoundRect(x, y, w, h, rx, ry: Integer);
233 procedure drawText(x: Integer; y: Integer; s: String); overload;
234 procedure drawText(x,y,w,h,flags: Integer; s: String); overload;
235 procedure drawLine(x1: Integer; y1: Integer; x2: Integer; y2: Integer);
236 procedure drawEllipse(x: Integer; y: Integer; w: Integer; h: Integer);
237 procedure drawSurface(targetRect: PRect; Surface: Pcairo_surface_t; sourceRect: PRect;
238 mask: PGdkPixBuf; maskRect: PRect);
239 procedure drawImage(targetRect: PRect; image: PGdkPixBuf; sourceRect: PRect;
240 mask: PGdkPixBuf; maskRect: PRect);
241 procedure drawPixmap(p: PPoint; pm: PGdkPixbuf; sr: PRect);
242 procedure drawPolyLine(P: PPoint; NumPts: Integer);
243 procedure drawPolygon(P: PPoint; NumPts: Integer; FillRule: integer);
244 procedure drawPolyBezier(P: PPoint; NumPoints: Integer; Filled, Continuous: boolean);
245 procedure EllipseArcPath(CX, CY, RX, RY: Double; Angle1, Angle2: Double; Clockwise, Continuous: Boolean);
246 procedure eraseRect(ARect: PRect);
247 procedure fillRect(ARect: PRect; ABrush: HBRUSH); overload;
248 procedure fillRect(x, y, w, h: Integer; ABrush: HBRUSH); overload;
249 procedure fillRect(x, y, w, h: Integer); overload;
RoundRectnull250 function RoundRect(X1, Y1, X2, Y2: Integer; RX, RY: Integer): Boolean;
251
getBppnull252 function getBpp: integer;
getDepthnull253 function getDepth: integer;
getDeviceSizenull254 function getDeviceSize: TPoint;
LineTonull255 function LineTo(const X, Y: Integer): Boolean;
MoveTonull256 function MoveTo(const X, Y: Integer; OldPoint: PPoint): Boolean;
SetClipRegionnull257 function SetClipRegion(ARgn: TGtk3Region): Integer;
258 procedure SetSourceColor(AColor: TColor);
259 procedure SetCurrentBrush(ABrush: TGtk3Brush);
260 procedure SetCurrentFont(AFont: TGtk3Font);
261 procedure SetCurrentPen(APen: TGtk3Pen);
262 procedure SetCurrentImage(AImage: TGtk3Image);
263 procedure SetImage(AImage: TGtk3Image);
ResetClipnull264 function ResetClip: Integer;
265 procedure TranslateCairoToDevice;
266 procedure Translate(APoint: TPoint);
267 property BkMode: Integer read GetBkMode write SetBkMode;
268 property CanRelease: Boolean read FCanRelease write FCanRelease;
269 property CurrentBrush: TGtk3Brush read FCurrentBrush;
270 property CurrentFont: TGtk3Font read FCurrentFont;
271 property CurrentImage: TGtk3Image read FCurrentImage;
272 property CurrentPen: TGtk3Pen read FCurrentPen;
273 property CurrentRegion: TGtk3Region read FCurrentRegion;
274 property CurrentTextColor: TColorRef read FCurrentTextColor write SetCurrentTextColor;
275 property Offset: TPoint read GetOffset write SetOffset;
276 property OwnsSurface: Boolean read FOwnsSurface;
277 property vBrush: TGtk3Brush read getBrush write setBrush;
278 property vClipRect: TRect read FvClipRect write FvClipRect;
279 property vFont: TGtk3Font read GetFont write SetFont;
280 property vImage: TGtk3Image read GetvImage write SetvImage;
281 property vPen: TGtk3Pen read getPen write setPen;
282 end;
283
CheckBitmapnull284 function CheckBitmap(const ABitmap: HBITMAP; const AMethodName: String;
285 AParamName: String = ''): Boolean;
286 procedure Gtk3WordWrap(DC: HDC; AText: PChar;
287 MaxWidthInPixel: integer; out Lines: PPChar; out LineCount: integer);
288
Gtk3DefaultContextnull289 function Gtk3DefaultContext: TGtk3DeviceContext;
Gtk3ScreenContextnull290 function Gtk3ScreenContext: TGtk3DeviceContext;
291
292 implementation
293 uses math, gtk3int, gtk3procs;
294
295 const
296 Dash_Dash: array [0..1] of double = (18, 6); //____ ____
297 Dash_Dot: array [0..1] of double = (3, 3); //.........
298 Dash_DashDot: array [0..3] of double = (9, 6, 3, 6); //__ . __ .
299 Dash_DashDotDot: array [0..5] of double = (9, 3, 3, 3, 3, 3); //__ . . __
300
301 var
302 FDefaultContext: TGtk3DeviceContext = nil;
303 FScreenContext: TGtk3DeviceContext = nil;
304
Gtk3DefaultContextnull305 function Gtk3DefaultContext: TGtk3DeviceContext;
306 begin
307 if FDefaultContext = nil then
308 FDefaultContext := TGtk3DeviceContext.Create(PGtkWidget(nil), False);
309 Result := FDefaultContext;
310 end;
311
Gtk3ScreenContextnull312 function Gtk3ScreenContext: TGtk3DeviceContext;
313 begin
314 if FScreenContext = nil then
315 FScreenContext := TGtk3DeviceContext.Create(gdk_get_default_root_window, False);
316 Result := FScreenContext;
317 end;
318
319 {------------------------------------------------------------------------------
320 Name: CheckBitmap
321 Params: Bitmap - Handle to a bitmap (TGtk3Image)
322 AMethodName - Method name
323 AParamName - Param name
324 Returns: If the bitmap is valid
325 ------------------------------------------------------------------------------}
CheckBitmapnull326 function CheckBitmap(const ABitmap: HBITMAP; const AMethodName: String;
327 AParamName: String): Boolean;
328 begin
329 Result := TObject(ABitmap) is TGtk3Image;
330 if Result then Exit;
331
332 if Pos('.', AMethodName) = 0 then
333 DebugLn('Gtk3WidgetSet ' + AMethodName + ' Error - invalid bitmap ' +
334 AParamName + ' = ' + DbgS(ABitmap) + '!')
335 else
336 DebugLn(AMethodName + ' Error - invalid bitmap ' + AParamName + ' = ' +
337 DbgS(ABitmap) + '!');
338 end;
339
340 procedure TColorToRGB(AColor: TColor; out R, G, B: double);
341 begin
342 R := (AColor and $FF) / 255;
343 G := ((AColor shr 8) and $FF) / 255;
344 B := ((AColor shr 16) and $FF) / 255;
345 end;
346
347 { TGtk3ContextObject }
348
349 constructor TGtk3ContextObject.Create;
350 begin
351 inherited Create;
352 FShared := False;
353 end;
354
355 { TGtk3Region }
356
357 constructor TGtk3Region.Create(CreateHandle: Boolean);
358 begin
359 inherited Create;
360 FHandle := cairo_region_create;
361 end;
362
363 constructor TGtk3Region.Create(CreateHandle: Boolean; X1, Y1, X2, Y2: Integer);
364 var
365 ARect: Tcairo_rectangle_int_t;
366 begin
367 inherited Create;
368 FHandle := nil;
369 ARect.x := x1;
370 ARect.y := y1;
371 ARect.width := x2 - x1;
372 ARect.height := y2 - y1;
373 FHandle := cairo_region_create_rectangle(@ARect);
374 end;
375
376 destructor TGtk3Region.Destroy;
377 begin
378 if Assigned(FHandle) then
379 begin
380 cairo_region_destroy(FHandle);
381 FHandle := nil;
382 end;
383 inherited Destroy;
384 end;
385
TGtk3Region.GetExtentsnull386 function TGtk3Region.GetExtents: TRect;
387 var
388 ARect: Tcairo_rectangle_int_t;
389 begin
390 Result := Rect(0, 0, 0, 0);
391 if Assigned(FHandle) then
392 begin
393 cairo_region_get_extents(FHandle, @ARect);
394 Result.Left := ARect.x;
395 Result.Top := ARect.y;
396 Result.Right := ARect.width + ARect.x;
397 Result.Bottom := ARect.height + ARect.y;
398 end;
399 end;
400
ContainsRectnull401 function TGtk3Region.ContainsRect(ARect: TRect): Boolean;
402 var
403 ACairoRect: Tcairo_rectangle_int_t;
404 begin
405 with ACairoRect do
406 begin
407 x := ARect.Left;
408 y := ARect.Top;
409 width := ARect.Right - ARect.Left;
410 height := ARect.Bottom - ARect.Top;
411 end;
412 Result := cairo_region_contains_rectangle(FHandle, @ACairoRect) = CAIRO_REGION_OVERLAP_IN;
413 end;
414
TGtk3Region.ContainsPointnull415 function TGtk3Region.ContainsPoint(APoint: TPoint): Boolean;
416 begin
417 Result := cairo_region_contains_point(FHandle, APoint.x, APoint.y);
418 end;
419
420 { TGtk3Font }
421
422 procedure TGtk3Font.SetFontName(AValue: String);
423 begin
424 if FFontName=AValue then Exit;
425 FFontName:=AValue;
426 end;
427
428 constructor TGtk3Font.Create(ACairo: Pcairo_t; AWidget: PGtkWidget);
429 var
430 AContext: PPangoContext;
431 AOwnsContext: Boolean;
432 begin
433 inherited Create;
434 AOwnsContext := not Gtk3IsWidget(AWidget);
435 if not AOwnsContext then
436 begin
437 AContext := gtk_widget_get_pango_context(AWidget);
438 // DebugLn('TGtk3Font.Create AContext created from widget ....context=',dbgHex(PtrUInt(AContext)));
439 end else
440 begin
441 AContext := pango_cairo_create_context(ACairo);
442 // DebugLn('TGtk3Font.Create AContext created from pango cairo ....');
443 end;
444 FHandle := pango_font_description_copy(pango_context_get_font_description(AContext));
445 FFontName := pango_font_description_get_family(FHandle);
446
447 FLayout := pango_layout_new(AContext);
448 if FHandle^.get_size_is_absolute then
449 begin
450 FHandle^.set_absolute_size(FHandle^.get_size);
451 // writeln('**TGtk3Font.Create size is absolute ',FFontName,' size ',FHandle^.get_size);
452 end else
453 begin
454 // writeln('*TGtk3Font.Create size is not absolute ',FFontName,' size ',FHandle^.get_size);
455 end;
456
457 FLayout^.set_font_description(FHandle);
458 // writeln('TGtk3Font.Create1 ',FFontName);
459 if AOwnsContext then
460 g_object_unref(AContext);
461 // writeln('TGtk3Font.Create1 ',FFontName);
462 end;
463
464 constructor TGtk3Font.Create(ALogFont: TLogFont; ALongFontName: String);
465 var
466 AContext: PPangoContext;
467 ADescription: PPangoFontDescription;
468 begin
469 FLogFont := ALogFont;
470 FFontName := ALogFont.lfFaceName;
471 AContext := gdk_pango_context_get;
472 if IsFontNameDefault(FFontName) or (FFontName = '') then
473 begin
474 if Gtk3WidgetSet.DefaultAppFontName <> '' then
475 FHandle := pango_font_description_from_string(PgChar(Gtk3WidgetSet.DefaultAppFontName))
476 else
477 begin
478 ADescription := pango_context_get_font_description(AContext);
479 FHandle := pango_font_description_copy(ADescription);
480 end;
481 FFontName := FHandle^.get_family;
482 end else
483 begin
484 FHandle := pango_font_description_from_string(PgChar(FFontName));
485 FFontName := FHandle^.get_family;
486 end;
487 if ALogFont.lfHeight <> 0 then
488 FHandle^.set_absolute_size(Abs(ALogFont.lfHeight) * PANGO_SCALE);
489
490 if ALogFont.lfItalic > 0 then
491 FHandle^.set_style(PANGO_STYLE_ITALIC);
492
493 FHandle^.set_weight(ALogFont.lfWeight);
494
495 FLayout := pango_layout_new(AContext);
496 FLayout^.set_font_description(FHandle);
497
498 g_object_unref(AContext);
499 end;
500
501 destructor TGtk3Font.Destroy;
502 begin
503 if Assigned(FLayout) then
504 begin
505 g_object_unref(FLayout);
506 FLayout := nil;
507 end;
508 if Assigned(FHandle) then
509 begin
510 pango_font_description_free(FHandle);
511 FHandle := nil;
512 end;
513 inherited Destroy;
514 end;
515
516 { TGtk3Object }
517
518 constructor TGtk3Object.Create;
519 begin
520 FUpdateCount := 0;
521 end;
522
523 procedure TGtk3Object.Release;
524 begin
525 Free;
526 end;
527
528 procedure TGtk3Object.BeginUpdate;
529 begin
530 inc(FUpdateCount);
531 end;
532
533 procedure TGtk3Object.EndUpdate;
534 begin
535 if FUpdateCount > 0 then
536 dec(FUpdateCount);
537 end;
538
TGtk3Object.InUpdatenull539 function TGtk3Object.InUpdate: Boolean;
540 begin
541 Result := FUpdateCount > 0;
542 end;
543
544 { TGtk3Image }
545
546 constructor TGtk3Image.Create;
547 var
548 ACairo: Pcairo_t;
549 ASurface: Pcairo_surface_t;
550 ARect: TGdkRectangle;
551 begin
552 {$IFDEF VerboseGtk3DeviceContext}
553 DebugLn('TGtk3Image.Create 1');
554 {$ENDIF}
555 inherited Create;
556 ACairo := gdk_cairo_create(gdk_get_default_root_window);
557 gdk_cairo_get_clip_rectangle(ACairo, @ARect);
558 ASurface := cairo_image_surface_create(CAIRO_FORMAT_ARGB32, ARect.width, ARect.height);
559 try
560 FHandle := gdk_pixbuf_get_from_surface(ASurface, 0 ,0, ARect.Width, ARect.Height);
561 finally
562 cairo_surface_destroy(ASurface);
563 end;
564 FData := nil;
565 FDataOwner := False;
566 FFormat := CAIRO_FORMAT_ARGB32;
567 end;
568
569 constructor TGtk3Image.Create(vHandle: PGdkPixbuf);
570 begin
571 {$IFDEF VerboseGtk3DeviceContext}
572 DebugLn('TGtk3Image.Create 2 vHandle=',dbgs(vHandle),' channels ',dbgs(vHandle^.get_n_channels),' bps ',dbgs(vHandle^.get_bits_per_sample),' has_alpha=',dbgs(vHandle^.get_has_alpha));
573 {$ENDIF}
574 inherited Create;
575 FHandle := vHandle^.copy;
576 FData := nil;
577 FDataOwner := False;
578
579 if FHandle^.get_has_alpha then
580 FFormat := CAIRO_FORMAT_ARGB32
581 else
582 FFormat := CAIRO_FORMAT_RGB24;
583 end;
584
585 constructor TGtk3Image.Create(AData: PByte; width: Integer; height: Integer;
586 format: cairo_format_t; const ADataOwner: Boolean);
587 var
588 ASurface: Pcairo_surface_t;
589 w,h: Integer;
590 begin
591 {$IFDEF VerboseGtk3DeviceContext}
592 DebugLn('TGtk3Image.Create 3 AData=',dbgs(AData <> nil),' format=',dbgs(Ord(format)),' w=',dbgs(width),' h=',dbgs(height),' dataowner=',dbgs(ADataOwner));
593 {$ENDIF}
594 FFormat := format;
595 FData := AData;
596 FDataOwner := ADataOwner;
597 if FData = nil then
598 begin
599 w := width;
600 h := height;
601 if w <= 0 then
602 w := 16;
603 if h <= 0 then
604 h := 16;
605
606 ASurface := cairo_image_surface_create(format, w, h);
607 try
608 FHandle := gdk_pixbuf_get_from_surface(ASurface, 0 ,0, w, h);
609 finally
610 cairo_surface_destroy(ASurface);
611 end;
612 gdk_pixbuf_fill(FHandle, 0);
613 end else
614 begin
615 FHandle := TGdkPixbuf.new_from_data(AData, GDK_COLORSPACE_RGB, format=CAIRO_FORMAT_ARGB32, 8, width, height, 0, nil, nil);
616 end;
617 (*
618 if FData = nil then
619 begin
620 FHandle := QImage_create(width, height, format);
621 QImage_fill(FHandle, 0);
622 end
623 else
624 begin
625 FHandle := QImage_create(FData, width, height, format);
626 if format=QImageFormat_Mono then
627 QImage_setNumColors(FHandle, 2);
628 end;
629 *)
630
631 end;
632
633 constructor TGtk3Image.Create(AData: PByte; width: Integer; height: Integer;
634 bytesPerLine: Integer; format: cairo_format_t; const ADataOwner: Boolean);
635 var
636 ASurface: Pcairo_surface_t;
637 w, h: Integer;
638 begin
639 {$ifdef VerboseGtk3DeviceContext}
640 DebugLn('TGtk3Image.Create 4 AData=',dbgs(AData <> nil),' format=',dbgs(Ord(format)),' w=',dbgs(width),' h=',dbgs(height),' dataowner=',dbgs(ADataOwner),' bpl=',dbgs(bytesPerLine));
641 {$endif}
642 inherited Create;
643 FFormat := format;
644 FData := AData;
645 FDataOwner := ADataOwner;
646
647 if FData = nil then
648 begin
649 w := width;
650 h := height;
651 if (w <= 0) then
652 w := 16;
653 if (h <= 0) then
654 h := 16;
655 ASurface := cairo_image_surface_create(format, w, h);
656 try
657 FHandle := gdk_pixbuf_get_from_surface(ASurface, 0 ,0, w, h);
658 finally
659 cairo_surface_destroy(ASurface);
660 end;
661 gdk_pixbuf_fill(FHandle, 0);
662 end else
663 begin
664 FHandle := TGdkPixbuf.new_from_data(AData, GDK_COLORSPACE_RGB, format=CAIRO_FORMAT_ARGB32, 8, width, height, bytesPerLine, nil, nil);
665 end;
666 end;
667
668 destructor TGtk3Image.Destroy;
669 begin
670 if FHandle <> nil then
671 begin
672 FHandle^.unref;
673 FHandle := nil;
674 end;
675 if (FDataOwner) and (FData <> nil) then
676 FreeMem(FData);
677
678 inherited Destroy;
679 end;
680
681 procedure TGtk3Image.CopyFrom(AImage: PGdkPixbuf; x, y, w, h: integer);
682 begin
683 if FHandle = nil then
684 begin
685 DebugLn('*TGtk3Image.CopyFrom create subpixbuf ...');
686 FHandle := gdk_pixbuf_new_subpixbuf(AImage, x, y, w, h);
687 //TODO: must
688 // FHandle := gdk_pixbuf_copy(AImage);
689 end else
690 begin
691 DebugLn('*TGtk3Image.CopyFrom AImage ...');
692 g_object_unref(FHandle);
693 FHandle := gdk_pixbuf_new_subpixbuf(AImage, x, y, w, h);
694 // gdk_pixbuf_copy_area(AImage, x, y, w, h, FHandle, 0, 0);
695 end;
696 end;
697
TGtk3Image.heightnull698 function TGtk3Image.height: Integer;
699 begin
700 Result := FHandle^.get_height;
701 end;
702
widthnull703 function TGtk3Image.width: Integer;
704 begin
705 Result := FHandle^.get_width;
706 end;
707
TGtk3Image.depthnull708 function TGtk3Image.depth: Integer;
709 var
710 AOption: Pgchar;
711 i: Integer;
712 begin
713 Result := 32;
714 AOption := FHandle^.get_option('depth');
715 if AOption <> nil then
716 begin
717 TryStrToInt(StrPas(AOption), Result);
718 end;
719 end;
720
TGtk3Image.dotsPerMeterXnull721 function TGtk3Image.dotsPerMeterX: Integer;
722 begin
723 Result := 0;
724 end;
725
TGtk3Image.dotsPerMeterYnull726 function TGtk3Image.dotsPerMeterY: Integer;
727 begin
728 Result := 0;
729 end;
730
bitsnull731 function TGtk3Image.bits: PByte;
732 begin
733 Result := FHandle^.pixels;
734 end;
735
numBytesnull736 function TGtk3Image.numBytes: LongWord;
737 begin
738 Result := FHandle^.get_byte_length;
739 end;
740
TGtk3Image.bytesPerLinenull741 function TGtk3Image.bytesPerLine: Integer;
742 begin
743 Result := FHandle^.rowstride;
744 end;
745
TGtk3Image.getFormatnull746 function TGtk3Image.getFormat: cairo_format_t;
747 begin
748 Result := FFormat;
749 end;
750
751 { TGtk3Pen }
752
GetColornull753 function TGtk3Pen.GetColor: TColor;
754 begin
755 Result := FColor;
756 end;
757
TGtk3Pen.GetWidthnull758 function TGtk3Pen.GetWidth: Integer;
759 begin
760 Result := FWidth;
761 end;
762
763 procedure TGtk3Pen.SetColor(AValue: TColor);
764 var
765 ARed, AGreen, ABlue: Double;
766 begin
767 FColor := AValue;
768 ColorToCairoRGB(FColor, ARed, AGreen, ABlue);
769 if Assigned(FContext) and Assigned(FContext.Widget) then
770 cairo_set_source_rgb(FContext.Widget, ARed, AGreen, ABlue);
771 end;
772
773 procedure TGtk3Pen.SetEndCap(AValue: TPenEndCap);
774 begin
775 FEndCap := AValue;
776 end;
777
778 procedure TGtk3Pen.SetJoinStyle(AValue: TPenJoinStyle);
779 begin
780 FJoinStyle:=AValue;
781 end;
782
783 procedure TGtk3Pen.SetPenMode(AValue: TPenMode);
784 begin
785 if FPenMode=AValue then Exit;
786 FPenMode:=AValue;
787 end;
788
789 procedure TGtk3Pen.SetStyle(AValue: TFPPenStyle);
790 begin
791 FStyle := AValue;
792 end;
793
794 constructor TGtk3Pen.Create;
795 begin
796 inherited Create;
797 FillChar(LogPen, SizeOf(LogPen), #0);
798 FIsExtPen := False;
799 FContext := nil;
800 FColor := clBlack;
801 FCosmetic := True;
802 FWidth := 0;
803 FStyle := psSolid;
804 FEndCap := pecFlat;
805 FJoinStyle := pjsRound;
806 FPenMode := pmCopy; // default pen mode
807 end;
808
809 procedure TGtk3Pen.setCosmetic(b: Boolean);
810 begin
811 FCosmetic := B;
812 if Assigned(FContext) and Assigned(FContext.Widget) then
813 begin
814 if b then
815 cairo_set_line_width(FContext.Widget, 0)
816 else
817 cairo_set_line_width(FContext.Widget, 1);
818 end;
819 end;
820
821 procedure TGtk3Pen.setWidth(p1: Integer);
822 begin
823 FWidth := p1;
824 if Assigned(FContext) then
825 cairo_set_line_width(FContext.Widget, p1);
826 end;
827
828 { TGtk3Brush }
829
GetColornull830 function TGtk3Brush.GetColor: TColor;
831 begin
832 Result := FColor;
833 end;
834
835 procedure TGtk3Brush.SetColor(AValue: TColor);
836 var
837 ARed, AGreen, ABlue: Double;
838 begin
839 FColor := AValue;
840 ColorToCairoRGB(FColor, ARed, AGreen, ABlue);
841 if Assigned(FContext) then
842 cairo_set_source_rgb(FContext.Widget, ARed, AGreen, ABlue);
843 end;
844
845 procedure TGtk3Brush.SetStyle(AValue: cardinal);
846 begin
847 if FStyle=AValue then Exit;
848 FStyle:=AValue;
849 end;
850
851 constructor TGtk3Brush.Create;
852 begin
853 inherited Create;
854 {$note IMPORTANT TODO: use cairo_pattern_t for brush }
855 // cairo_pattern_create_for_surface();
856 FContext := nil;
857 FColor := clNone;
858 FillChar(LogBrush, SizeOf(TLogBrush), #0);
859 end;
860
861 { TGtk3DeviceContext }
862
TGtk3DeviceContext.getBrushnull863 function TGtk3DeviceContext.getBrush: TGtk3Brush;
864 begin
865 Result := FBrush;
866 end;
867
TGtk3DeviceContext.GetBkModenull868 function TGtk3DeviceContext.GetBkMode: Integer;
869 begin
870 Result := FBkMode;
871 end;
872
GetFontnull873 function TGtk3DeviceContext.GetFont: TGtk3Font;
874 begin
875 Result := FFont;
876 end;
877
GetOffsetnull878 function TGtk3DeviceContext.GetOffset: TPoint;
879 var
880 dx,dy: Double;
881 begin
882 cairo_surface_get_device_offset(cairo_get_target(Widget), @dx, @dy);
883 Result := Point(Round(dx), Round(dy));
884 end;
885
TGtk3DeviceContext.getPennull886 function TGtk3DeviceContext.getPen: TGtk3Pen;
887 begin
888 Result := FPen;
889 end;
890
TGtk3DeviceContext.GetvImagenull891 function TGtk3DeviceContext.GetvImage: TGtk3Image;
892 begin
893 Result := FvImage;
894 end;
895
896 procedure TGtk3DeviceContext.SetBkMode(AValue: Integer);
897 begin
898 FBkMode := AValue;
899 end;
900
901 procedure TGtk3DeviceContext.setBrush(AValue: TGtk3Brush);
902 begin
903 if Assigned(FBrush) then
904 FBrush.Free;
905 FBrush := AValue;
906 end;
907
908 procedure TGtk3DeviceContext.SetCurrentTextColor(AValue: TColorRef);
909 begin
910 if FCurrentTextColor=AValue then Exit;
911 FCurrentTextColor:=AValue;
912 end;
913
914 procedure TGtk3DeviceContext.SetFont(AValue: TGtk3Font);
915 begin
916 if Assigned(FFont) then
917 FFont.Free;
918 FFont := AValue;
919 end;
920
921 procedure TGtk3DeviceContext.SetOffset(AValue: TPoint);
922 var
923 dx, dy: Double;
924 begin
925 dx := AValue.X;
926 dy := AValue.Y;
927 cairo_surface_set_device_offset(cairo_get_target(Widget), dx, dy);
928 end;
929
930 procedure TGtk3DeviceContext.setPen(AValue: TGtk3Pen);
931 begin
932 if Assigned(FPen) then
933 FPen.Free;
934 FPen := AValue;
935 end;
936
937 procedure TGtk3DeviceContext.SetvImage(AValue: TGtk3Image);
938 begin
939 if Assigned(FvImage) then
940 FvImage.Free;
941 FvImage.Free;
942 end;
943
TGtk3DeviceContext.SXnull944 function TGtk3DeviceContext.SX(const x: double): Double;
945 begin
946 Result := 1*(x+vClipRect.Left);
947 end;
948
TGtk3DeviceContext.SYnull949 function TGtk3DeviceContext.SY(const y: double): Double;
950 begin
951 Result := 1*(y+vClipRect.Top);
952 end;
953
TGtk3DeviceContext.SX2null954 function TGtk3DeviceContext.SX2(const x: double): Double;
955 begin
956 Result := x;
957 end;
958
TGtk3DeviceContext.SY2null959 function TGtk3DeviceContext.SY2(const y: double): Double;
960 begin
961 Result := y;
962 end;
963
964 procedure TGtk3DeviceContext.ApplyBrush;
965 begin
966 if FBkMode = TRANSPARENT then
967 begin
968 DebugLn('TGtk3DeviceContext.ApplyBrush setting transparent source');
969 //cairo_set_source_surface(Widget, CairoSurface, 0 , 0);
970 end else
971 SetSourceColor(FCurrentBrush.Color);
972 end;
973
974 procedure TGtk3DeviceContext.ApplyFont;
975 var
976 AFont: TGtk3Font;
977 begin
978 if Assigned(FCurrentFont) then
979 AFont := FCurrentFont
980 else
981 AFont := FFont;
982
983 end;
984
985 procedure TGtk3DeviceContext.ApplyPen;
986 procedure SetDash(d: array of double);
987 begin
988 cairo_set_dash(Widget, @d, High(d)+1, 0);
989 end;
990 var
991 cap: cairo_line_cap_t;
992 w: Double;
993 begin
994 SetSourceColor(FCurrentPen.Color);
995 case FCurrentPen.Mode of
996 pmBlack: begin
997 SetSourceColor(clBlack);
998 cairo_set_operator(Widget, CAIRO_OPERATOR_OVER);
999 end;
1000 pmWhite: begin
1001 SetSourceColor(clWhite);
1002 cairo_set_operator(Widget, CAIRO_OPERATOR_OVER);
1003 end;
1004 pmCopy: cairo_set_operator(Widget, CAIRO_OPERATOR_OVER);
1005 pmXor: cairo_set_operator(Widget, CAIRO_OPERATOR_XOR);
1006 pmNotXor: cairo_set_operator(Widget, CAIRO_OPERATOR_XOR);
1007 {pmNop,
1008 pmNot,
1009 pmCopy,
1010 pmNotCopy,
1011 pmMergePenNot,
1012 pmMaskPenNot,
1013 pmMergeNotPen,
1014 pmMaskNotPen,
1015 pmMerge,
1016 pmNotMerge,
1017 pmMask,
1018 pmNotMask,}
1019 else
1020 cairo_set_operator(Widget, CAIRO_OPERATOR_OVER);
1021 end;
1022
1023 if FCurrentPen.Cosmetic then
1024 cairo_set_line_width(Widget, 1.0)
1025 else
1026 begin
1027 w := FCurrentPen.Width;
1028 if w = 0 then
1029 w := 0.5;
1030 cairo_set_line_width(Widget, w {* ScaleX}); //line_width is diameter of the pen circle
1031 end;
1032
1033 case FCurrentPen.Style of
1034 psSolid: cairo_set_dash(Widget, nil, 0, 0);
1035 psDash: SetDash(Dash_Dash);
1036 psDot: SetDash(Dash_Dot);
1037 psDashDot: SetDash(Dash_DashDot);
1038 psDashDotDot: SetDash(Dash_DashDotDot);
1039 else
1040 cairo_set_dash(Widget, nil, 0, 0);
1041 end;
1042
1043 case FCurrentPen.EndCap of
1044 pecRound: cap := CAIRO_LINE_CAP_ROUND;
1045 pecSquare: cap := CAIRO_LINE_CAP_SQUARE;
1046 pecFlat: cap := CAIRO_LINE_CAP_BUTT;
1047 end;
1048
1049 // dashed patterns do not look ok combined with round or squared caps
1050 // make it flat until a solution is found
1051 case FCurrentPen.Style of
1052 psDash, psDot, psDashDot, psDashDotDot:
1053 cap := CAIRO_LINE_CAP_BUTT
1054 end;
1055 cairo_set_line_cap(Widget, cap);
1056
1057 case FCurrentPen.JoinStyle of
1058 pjsRound: cairo_set_line_join(Widget, CAIRO_LINE_JOIN_ROUND);
1059 pjsBevel: cairo_set_line_join(Widget, CAIRO_LINE_JOIN_BEVEL);
1060 pjsMiter: cairo_set_line_join(Widget, CAIRO_LINE_JOIN_MITER);
1061 end;
1062 end;
1063
1064 constructor TGtk3DeviceContext.Create(AWidget: PGtkWidget;
1065 const APaintEvent: Boolean);
1066 var
1067 W: gint;
1068 H: gint;
1069 ARect: TGdkRectangle;
1070 AWindow: PGdkWindow;
1071 x: gint;
1072 y: gint;
1073 begin
1074 {$ifdef VerboseGtk3DeviceContext}
1075 WriteLn('TGtk3DeviceContext.Create (',
1076 ' WidgetHandle: ', dbghex(PtrInt(AWidget)),
1077 ' FromPaintEvent:',BoolToStr(APaintEvent),' )');
1078 {$endif}
1079 inherited Create;
1080 FvClipRect := Rect(0, 0, 0, 0);
1081 Window := nil;
1082 Parent := nil;
1083 ParentPixmap := nil;
1084 CairoSurface := nil;
1085 // FMetrics := nil;
1086 // SelFont := nil;
1087 // SelBrush := nil;
1088 // SelPen := nil;
1089 FCanRelease := False;
1090 FOwnsCairo := True;
1091 FOwnsSurface := False;
1092 FCurrentTextColor := clBlack;
1093
1094 if AWidget = nil then
1095 begin
1096 AWindow := gdk_get_default_root_window;
1097 AWindow^.get_geometry(@x, @y, @w, @h);
1098 w:=1; h:=1;
1099 // ParentPixmap := gdk_pixbuf_get_from_window(AWindow, x, y, w, h);
1100 // Widget := gdk_cairo_create(AWindow);
1101 // gdk_cairo_set_source_pixbuf(Widget, ParentPixmap, 0, 0);
1102 CairoSurface := cairo_image_surface_create(CAIRO_FORMAT_RGB24, w, h);
1103 Widget := cairo_create(CairoSurface);
1104 ParentPixmap := gdk_pixbuf_get_from_surface(CairoSurface, 0, 0, 1, 1);
1105 FOwnsSurface := True;
1106 end else
1107 begin
1108 Parent := AWidget;
1109 if not APaintEvent then
1110 begin
1111 {avoid paints on null pixmaps !}
1112 W := gtk_widget_get_allocated_width(AWidget);
1113 H := gtk_widget_get_allocated_height(AWidget);
1114 if W <= 0 then W := 1;
1115 if H <= 0 then H := 1;
1116 Widget := gdk_cairo_create(gtk_widget_get_window(AWidget));
1117 end else
1118 begin
1119 W := gtk_widget_get_allocated_width(AWidget);
1120 H := gtk_widget_get_allocated_height(AWidget);
1121 if W <= 0 then W := 1;
1122 if H <= 0 then H := 1;
1123 Widget := gdk_cairo_create(gtk_widget_get_window(AWidget));
1124 end;
1125 end;
1126 if not FOwnsSurface then
1127 CairoSurface := cairo_get_target(Widget);
1128 CreateObjects;
1129 (*
1130 FRopMode := R2_COPYPEN;
1131 FOwnPainter := True;
1132 CreateObjects;
1133 FPenPos.X := 0;
1134 FPenPos.Y := 0;
1135 *)
1136 end;
1137
1138 constructor TGtk3DeviceContext.Create(AWindow: PGdkWindow;
1139 const APaintEvent: Boolean);
1140 var
1141 x, y, w, h: gint;
1142 begin
1143 {$ifdef VerboseGtk3DeviceContext}
1144 WriteLn('TGtk3DeviceContext.Create (',
1145 ' WindowHandle: ', dbghex(PtrInt(AWindow)),
1146 ' FromPaintEvent:',BoolToStr(APaintEvent),' )');
1147 {$endif}
1148 inherited Create;
1149 FvClipRect := Rect(0, 0, 0, 0);
1150 Parent := nil;
1151 ParentPixmap := nil;
1152 CairoSurface := nil;
1153 Window := AWindow;
1154 FOwnsSurface := False;
1155 FCanRelease := False;
1156 FOwnsCairo := True;
1157 FCurrentTextColor := clBlack;
1158 AWindow^.get_geometry(@x, @y, @w, @h);
1159 // ParentPixmap := gdk_pixbuf_get_from_window(AWindow, x, y, w, h);
1160 Widget := gdk_cairo_create(AWindow);
1161 // gdk_cairo_set_source_pixbuf(Widget, ParentPixmap, 0, 0);
1162 gdk_cairo_set_source_window(Widget, AWindow, 0, 0);
1163 CairoSurface := cairo_get_target(Widget);
1164 CreateObjects;
1165 end;
1166
1167 constructor TGtk3DeviceContext.CreateFromCairo(AWidget: PGtkWidget;
1168 ACairo: PCairo_t);
1169 var
1170 AGdkRect: TGdkRectangle;
1171 begin
1172 {$ifdef VerboseGtk3DeviceContext}
1173 WriteLn('TGtk3DeviceContext.CreateFromCairo (',
1174 ' WidgetHandle: ', dbghex(PtrInt(AWidget)),
1175 ' FromPaintEvent:',BoolToStr(True),' )');
1176 {$endif}
1177 inherited Create;
1178 FOwnsCairo := False;
1179 Window := nil;
1180 Parent := AWidget;
1181 ParentPixmap := nil;
1182 CairoSurface := nil;
1183 FOwnsSurface := False;
1184 FCurrentTextColor := clBlack;
1185 gdk_cairo_get_clip_rectangle(ACairo, @AGdkRect);
1186 FvClipRect := RectFromGdkRect(AGdkRect);
1187 Widget := ACairo;
1188 CairoSurface := cairo_get_target(Widget);
1189 CreateObjects;
1190 end;
1191
1192 destructor TGtk3DeviceContext.Destroy;
1193 begin
1194 {$ifdef VerboseGtk3DeviceContext}
1195 WriteLn('TGtk3DeviceContext.Destroy ',dbgHex(PtrUInt(Self)));
1196 {$endif}
1197 DeleteObjects;
1198 if FOwnsCairo and (Widget <> nil) then
1199 cairo_destroy(Widget);
1200 if (ParentPixmap <> nil) then
1201 g_object_unref(ParentPixmap);
1202 if FOwnsSurface and (CairoSurface <> nil) then
1203 cairo_surface_destroy(CairoSurface);
1204 Parent := nil;
1205 Widget := nil;
1206 ParentPixmap := nil;
1207 CairoSurface := nil;
1208 Window := nil;
1209 inherited Destroy;
1210 end;
1211
1212 procedure TGtk3DeviceContext.CreateObjects;
1213 var
1214 Matrix:cairo_matrix_t;
1215 begin
1216 FBkMode := TRANSPARENT;
1217 FCurrentImage := nil;
1218 FCurrentRegion := nil;
1219 FBrush := TGtk3Brush.Create;
1220 FBrush.Context := Self;
1221 FBrush.Color := clNone;
1222 FBrush.Style := BS_SOLID;
1223 FPen := TGtk3Pen.Create;
1224 FPen.Context := Self;
1225 FPen.Color := clBlack;
1226 FCurrentPen := FPen;
1227 FCurrentBrush := FBrush;
1228 FFont := TGtk3Font.Create(Widget, Parent);
1229 FCurrentFont := FFont;
1230 FvImage := TGtk3Image.Create(nil, 1, 1, 8, CAIRO_FORMAT_ARGB32);
1231 FCurrentImage := FvImage;
1232
1233 cairo_get_matrix(Widget, @Matrix);
1234 // widget with menu or other non-client exclusions have offset in trasform matrix
1235 fncOrigin:=Point(round(Matrix.x0),round(Matrix.y0));
1236 end;
1237
1238 procedure TGtk3DeviceContext.DeleteObjects;
1239 begin
1240 if Assigned(FBrush) then
1241 FreeAndNil(FBrush);
1242 if Assigned(FPen) then
1243 FreeAndNil(FPen);
1244 if Assigned(FFont) then
1245 FreeAndNil(FFont);
1246 if Assigned(FvImage) then
1247 FreeAndNil(FvImage);
1248 end;
1249
1250 procedure TGtk3DeviceContext.drawPoint(x1: Integer; y1: Integer);
1251 begin
1252 applyPen;
1253 cairo_move_to(Widget , x1, y1);
1254 cairo_line_to(Widget, x1, y1);
1255 cairo_stroke(Widget);
1256 end;
1257
1258 procedure TGtk3DeviceContext.drawRect(x1: Integer; y1: Integer; w: Integer;
1259 h: Integer; const AFill: Boolean);
1260 begin
1261 cairo_save(Widget);
1262 try
1263 applyPen;
1264 // strange about adding +1 -1 to rectangle, but this works ok.
1265 //cairo_rectangle(Widget, x1 + 1, y1 + 1, w - 1, h -1);
1266 cairo_rectangle(Widget, x1, y1, w, h);
1267 if AFill then
1268 begin
1269 cairo_stroke_preserve(Widget);
1270 applyBrush;
1271 cairo_fill_preserve(Widget);
1272 end else
1273 cairo_stroke(Widget);
1274 finally
1275 cairo_restore(Widget);
1276 end;
1277 end;
1278
1279 procedure TGtk3DeviceContext.drawRoundRect(x, y, w, h, rx, ry: Integer);
1280 begin
1281 RoundRect(x, y, w, h, rx, ry);
1282 end;
1283
1284 procedure TGtk3DeviceContext.drawText(x: Integer; y: Integer; s: String);
1285 var
1286 e: cairo_font_extents_t;
1287 R: Double;
1288 G: Double;
1289 B: Double;
1290 begin
1291 cairo_save(Widget);
1292 try
1293 // TranslateCairoToDevice;
1294 // cairo_surface_get_device_offset(CairoSurface, @dx, @dy);
1295 cairo_font_extents(Widget, @e);
1296 if e.ascent <> 0 then
1297 begin
1298 // writeln('EXTENTS !!!! ',Format('%2.2n',[e.ascent]));
1299 end;
1300 cairo_move_to(Widget, x, y {+ e.ascent});
1301 // writeln('DevOffset ',Format('dx %2.2n dy %2.2n x %d y %d text %s',
1302 // [dx, dy, x, y, s]));
1303 // pango_renderer_activate();
1304 // pango_cairo_show_layout(Widget, Layout);
1305 ColorToCairoRGB(TColor(CurrentTextColor), R, G , B);
1306 cairo_set_source_rgb(Widget, R, G, B);
1307 // writeln('DRAWINGTEXT ',S,' WITH R=',dbgs(R),' G=',dbgs(G),' B=',dbgs(B));
1308 FCurrentFont.Layout^.set_text(PChar(S), length(S));
1309 // writeln('Family: ',FCurrentFont.Handle^.get_family,' size ',FCurrentFont.Handle^.get_size,' weight ',FCurrentFont.Handle^.get_weight);
1310 pango_cairo_show_layout(Widget, FCurrentFont.Layout);
1311 finally
1312 cairo_restore(Widget);
1313 end;
1314 end;
1315
1316 procedure TGtk3DeviceContext.drawText(x, y, w, h, flags: Integer; s: String
1317 );
1318 var
1319 e: cairo_font_extents_t;
1320 R: Double;
1321 G: Double;
1322 B: Double;
1323 // dx, dy: Double;
1324 begin
1325 cairo_save(Widget);
1326 try
1327 // TranslateCairoToDevice;
1328 // cairo_surface_get_device_offset(CairoSurface, @dx, @dy);
1329 cairo_font_extents(Widget, @e);
1330 if e.ascent <> 0 then
1331 begin
1332 // writeln('2.EXTENTS !!!! ',Format('%2.2n',[e.ascent]));
1333 end;
1334 cairo_move_to(Widget, x, y + e.ascent);
1335 ColorToCairoRGB(CurrentTextColor, R, G , B);
1336 cairo_set_source_rgb(Widget, R, G, B);
1337 // cairo_show_text(Widget, PChar(s));
1338 FCurrentFont.Layout^.set_text(PChar(S), length(S));
1339 pango_cairo_show_layout(Widget, FCurrentFont.Layout);
1340 finally
1341 cairo_restore(Widget);
1342 end;
1343
1344 end;
1345
1346 procedure TGtk3DeviceContext.drawLine(x1: Integer; y1: Integer; x2: Integer;
1347 y2: Integer);
1348 begin
1349 ApplyPen;
1350 cairo_move_to(Widget, x1, y1);
1351 cairo_line_to(Widget, x2, y2);
1352 end;
1353
1354 procedure TGtk3DeviceContext.drawEllipse(x: Integer; y: Integer; w: Integer;
1355 h: Integer);
1356 begin
1357
1358 end;
1359
1360 procedure TGtk3DeviceContext.drawSurface(targetRect: PRect;
1361 Surface: Pcairo_surface_t; sourceRect: PRect; mask: PGdkPixBuf;
1362 maskRect: PRect);
1363 var
1364 M: cairo_matrix_t;
1365 begin
1366 {$IFDEF VerboseGtk3DeviceContext}
1367 DebugLn('TGtk3DeviceContext.DrawSurface ');
1368 {$ENDIF}
1369 cairo_save(Widget);
1370 try
1371 with targetRect^ do
1372 cairo_rectangle(Widget, Left, Top, Right - Left, Bottom - Top);
1373 cairo_set_source_surface(Widget, Surface, 0, 0);
1374 cairo_matrix_init_identity(@M);
1375 cairo_matrix_translate(@M, SourceRect^.Left, SourceRect^.Top);
1376 cairo_matrix_scale(@M, (sourceRect^.Right-sourceRect^.Left) / (targetRect^.Right-targetRect^.Left),
1377 (sourceRect^.Bottom-sourceRect^.Top) / (targetRect^.Bottom-targetRect^.Top));
1378 cairo_matrix_translate(@M, -targetRect^.Left, -targetRect^.Top);
1379 cairo_pattern_set_matrix(cairo_get_source(Widget), @M);
1380 cairo_clip(Widget);
1381 cairo_paint(Widget);
1382 finally
1383 cairo_restore(Widget);
1384 end;
1385 end;
1386
1387 procedure TGtk3DeviceContext.drawImage(targetRect: PRect; image: PGdkPixBuf;
1388 sourceRect: PRect; mask: PGdkPixBuf; maskRect: PRect);
1389 var
1390 pm: PGdkPixbuf;
1391 AData: PByte;
1392 ASurface: Pcairo_surface_t;
1393 begin
1394 {$IFDEF VerboseGtk3DeviceContext}
1395 DebugLn('TGtk3DeviceContext.DrawImage ');
1396 {$ENDIF}
1397 cairo_save(Widget);
1398 try
1399 pm := Image;
1400 // AData := PByte(gdk_pixbuf_get_pixels(pm));
1401 // ASurface := cairo_image_surface_create_for_data(AData, CAIRO_FORMAT_ARGB32, gdk_pixbuf_get_width(pm), gdk_pixbuf_get_height(pm), gdk_pixbuf_get_rowstride(pm));
1402 // cairo_set_source_surface(Widget, ASurface, targetRect^.Left, targetRect^.Top);
1403 gdk_cairo_set_source_pixbuf(Widget, Image, 0, 0);
1404 cairo_paint(Widget);
1405 finally
1406 // cairo_surface_destroy(ASurface);
1407 cairo_restore(Widget);
1408 end;
1409 end;
1410
1411 procedure TGtk3DeviceContext.drawPixmap(p: PPoint; pm: PGdkPixbuf; sr: PRect);
1412 var
1413 AImage: PGtkImage;
1414 ASurface: Pcairo_surface_t;
1415 AData: PByte;
1416 begin
1417 {$IFDEF VerboseGtk3DeviceContext}
1418 DebugLn('TGtk3DeviceContext.DrawPixmap ');
1419 {$ENDIF}
1420 cairo_save(Widget);
1421 try
1422 AData := PByte(gdk_pixbuf_get_pixels(pm));
1423 ASurface := cairo_image_surface_create_for_data(AData, CAIRO_FORMAT_ARGB32, gdk_pixbuf_get_width(pm), gdk_pixbuf_get_height(pm), gdk_pixbuf_get_rowstride(pm));
1424 cairo_set_source_surface(Widget, ASurface, sr^.Left, sr^.Top);
1425 cairo_paint(Widget);
1426 finally
1427 cairo_surface_destroy(ASurface);
1428 cairo_restore(Widget);
1429 end;
1430 end;
1431
1432 procedure TGtk3DeviceContext.drawPolyLine(P: PPoint; NumPts: Integer);
1433 const
1434 PixelOffset = 0.5;
1435 var
1436 i: Integer;
1437 begin
1438 cairo_save(Widget);
1439 try
1440 ApplyPen;
1441 cairo_move_to(Widget, P[0].X+PixelOffset, P[0].Y+PixelOffset);
1442 for i := 1 to NumPts-1 do
1443 cairo_line_to(Widget, P[i].X+PixelOffset, P[i].Y+PixelOffset);
1444 cairo_stroke(Widget);
1445 finally
1446 cairo_restore(Widget);
1447 end;
1448
1449 end;
1450
1451 procedure TGtk3DeviceContext.drawPolygon(P: PPoint; NumPts: Integer;
1452 FillRule: integer);
1453 var
1454 i: Integer;
1455 const
1456 PixelOffset = 0.5;
1457 begin
1458 cairo_save(Widget);
1459 try
1460 // first apply the fill because the line is drawn over the filled area after
1461 applyBrush;
1462 cairo_set_fill_rule(Widget, cairo_fill_rule_t(FillRule));
1463 // + Offset is so the center of the pixel is used.
1464 cairo_move_to(Widget, P[0].X+PixelOffset, P[0].Y+PixelOffset);
1465 for i := 1 to NumPts-1 do
1466 cairo_line_to(Widget, P[i].X+PixelOffset, P[i].Y+PixelOffset);
1467
1468 cairo_close_path(Widget);
1469 cairo_fill_preserve(Widget);
1470
1471 // now draw the line
1472 ApplyPen;
1473 //cairo_set_antialias(widget, CAIRO_ANTIALIAS_SUBPIXEL);
1474 cairo_move_to(Widget, P[0].X+PixelOffset, P[0].Y+PixelOffset);
1475 for i := 1 to NumPts-1 do
1476 cairo_line_to(Widget, P[i].X+PixelOffset, P[i].Y+PixelOffset);
1477 cairo_close_path(Widget);
1478 cairo_stroke_preserve(Widget);
1479 finally
1480 cairo_restore(Widget);
1481 end;
1482 end;
1483
1484 procedure TGtk3DeviceContext.drawPolyBezier(P: PPoint; NumPoints: Integer; Filled, Continuous: boolean);
1485 var
1486 i: Integer;
1487 const
1488 PixelOffset = 0.5;
1489 begin
1490 // 3 points per curve + a starting point for the first curve
1491 if (NumPoints < 4) then
1492 Exit;
1493
1494 cairo_save(Widget);
1495 try
1496 ApplyPen;
1497
1498 i := 0;
1499 // we need 3 points left for continuous and 4 for not continous
1500 while i < NumPoints-1 - (3 + ord(not Continuous)) do
1501 begin
1502 if (i = 0) or Not Continuous then
1503 begin
1504 cairo_move_to(Widget, P[i].X+PixelOffset, P[i].Y+PixelOffset); // start point
1505 Inc(i);
1506 end;
1507 cairo_curve_to(Widget,
1508 P[i].X+PixelOffset, P[i].Y+PixelOffset, // control point 1
1509 P[i+1].X+PixelOffset, P[i+1].Y+PixelOffset, // control point 2
1510 P[i+2].X+PixelOffset, P[i+2].Y+PixelOffset); // end point and start point of next
1511 Inc(i, 3);
1512 end;
1513 cairo_stroke_preserve(Widget);
1514
1515 if Filled then
1516 begin
1517 ApplyBrush;
1518 // join start and end points
1519 cairo_close_path(Widget);
1520 cairo_fill(Widget);
1521 end;
1522
1523 finally
1524 cairo_restore(Widget);
1525 end;
1526 end;
1527
1528 procedure TGtk3DeviceContext.eraseRect(ARect: PRect);
1529 begin
1530 // cairo_surface_
1531 end;
1532
1533 procedure TGtk3DeviceContext.fillRect(ARect: PRect; ABrush: HBRUSH);
1534 begin
1535 with ARect^ do
1536 fillRect(Left, Top, Right - Left, Bottom - Top, ABrush);
1537 end;
1538
1539 procedure TGtk3DeviceContext.fillRect(x, y, w, h: Integer; ABrush: HBRUSH);
1540 var
1541 devx, devy, dx, dy, dw, dh: Double;
1542 ATarget: Pcairo_surface_t;
1543 ANewSurface: Pcairo_surface_t;
1544 ACairo: Pcairo_t;
1545 ATempBrush: TGtk3Brush;
1546 begin
1547 {$ifdef VerboseGtk3DeviceContext}
1548 // WriteLn('TGtk3DeviceContext.fillRect ',Format('x %d y %d w %d h %d',[x, y, w, h]));
1549 {$endif}
1550
1551 cairo_save(Widget);
1552 ATempBrush := nil;
1553 if ABrush <> 0 then
1554 begin
1555 ATempBrush := FCurrentBrush;
1556 fBkMode:=OPAQUE;
1557 SetCurrentBrush(TGtk3Brush(ABrush));
1558 end;
1559
1560 applyBrush;
1561 cairo_rectangle(Widget, x, y, w, h);
1562 cairo_stroke_preserve(Widget);
1563 cairo_fill(Widget);
1564 // cairo_clip(Widget);
1565
1566 // cairo_fill_preserve(Widget);
1567 if ABrush <> 0 then
1568 SetCurrentBrush(ATempBrush);
1569 cairo_restore(Widget);
1570
1571 // ATarget := cairo_get_target(Widget);
1572 (*
1573 cairo_save(Widget);
1574 dx := x;
1575 dy := y;
1576 dw := w;
1577 dh := h;
1578 ANewSurface := cairo_surface_create_similar(ATarget, cairo_surface_get_content(ATarget), w, h);
1579 cairo_set_source_surface(Widget, ANewSurface, x , y);
1580 cairo_clip(Widget);
1581 vBrush.SetColor(clRed);
1582 cairo_rectangle(Widget, dx, dy, dw, dh);
1583 cairo_fill(Widget);
1584 cairo_surface_destroy(ANewSurface);
1585 cairo_restore(Widget);
1586 *)
1587 end;
1588
1589 procedure TGtk3DeviceContext.fillRect(x, y, w, h: Integer);
1590 begin
1591 fillRect(x, y, w, h , 0);
1592 end;
1593
1594 procedure TGtk3DeviceContext.FillAndStroke;
1595 begin
1596 if Assigned(FCurrentBrush) and (FCurrentBrush.Style <> BS_NULL) then
1597 begin
1598 ApplyBrush;
1599 if Assigned(FCurrentPen) and (FCurrentPen.Style = psClear) then
1600 cairo_fill(Widget)
1601 else
1602 cairo_fill_preserve(Widget);
1603 end;
1604 if Assigned(FCurrentPen) and (FCurrentPen.Style <> psClear) then
1605 begin
1606 ApplyPen;
1607 cairo_stroke(Widget);
1608 end;
1609 end;
1610
1611 procedure TGtk3DeviceContext.EllipseArcPath(CX, CY, RX, RY: Double; Angle1, Angle2: Double; Clockwise, Continuous: Boolean);
1612 begin
1613 if (RX=0) or (RY=0) then //cairo_scale do not likes zero params
1614 Exit;
1615 cairo_save(Widget);
1616 try
1617 cairo_translate(Widget, SX(CX), SY(CY));
1618 cairo_scale(Widget, SX2(RX), SY2(RY));
1619 if not Continuous then
1620 cairo_move_to(Widget, cos(Angle1), sin(Angle1)); //Move to arcs starting point
1621 if Clockwise then
1622 cairo_arc(Widget, 0, 0, 1, Angle1, Angle2)
1623 else
1624 cairo_arc_negative(Widget, 0, 0, 1, Angle1, Angle2);
1625 finally
1626 cairo_restore(Widget);
1627 end;
1628 end;
1629
RoundRectnull1630 function TGtk3DeviceContext.RoundRect(X1, Y1, X2, Y2: Integer; RX, RY: Integer
1631 ): Boolean;
1632 var
1633 DX: Double;
1634 DY: Double;
1635 Pt: TPoint;
1636 begin
1637 Result := False;
1638 cairo_surface_get_device_offset(cairo_get_target(Widget), @DX, @DY);
1639 cairo_translate(Widget, DX, DY);
1640 try
1641 cairo_move_to(Widget, SX(X1+RX), SY(Y1));
1642 cairo_line_to(Widget, SX(X2-RX), SY(Y1));
1643 EllipseArcPath(X2-RX, Y1+RY, RX, RY, -PI/2, 0, True, True);
1644 cairo_line_to(Widget, SX(X2), SY(Y2-RY));
1645 EllipseArcPath(X2-RX, Y2-RY, RX, RY, 0, PI/2, True, True);
1646 cairo_line_to(Widget, SX(X1+RX), SY(Y2));
1647 EllipseArcPath(X1+RX, Y2-RY, RX, RY, PI/2, PI, True, True);
1648 cairo_line_to(Widget, SX(X1), SY(Y1+RX));
1649 EllipseArcPath(X1+RX, Y1+RY, RX, RY, PI, PI*1.5, True, True);
1650 FillAndStroke;
1651 Result := True;
1652 finally
1653 cairo_translate(Widget, -DX, -DY);
1654 end;
1655 end;
1656
getBppnull1657 function TGtk3DeviceContext.getBpp: integer;
1658 var
1659 AVisual: PGdkVisual;
1660 begin
1661 if (Parent <> nil) and (Parent^.get_has_window) then
1662 begin
1663 AVisual := gdk_window_get_visual(Parent^.get_window);
1664 Result := gdk_visual_get_bits_per_rgb(AVisual);
1665 g_object_unref(AVisual);
1666 end else
1667 if (ParentPixmap <> nil) and (Parent = nil) then
1668 begin
1669 Result := ParentPixmap^.get_bits_per_sample;
1670 end else
1671 begin
1672 AVisual := gdk_window_get_visual(gdk_get_default_root_window);
1673 Result := gdk_visual_get_bits_per_rgb(AVisual);
1674 g_object_unref(AVisual);
1675 end;
1676 end;
1677
TGtk3DeviceContext.getDepthnull1678 function TGtk3DeviceContext.getDepth: integer;
1679 var
1680 AVisual: PGdkVisual;
1681 begin
1682 Result := 0;
1683 if (Parent <> nil) and Gtk3IsGdkWindow(Parent^.get_window) then
1684 begin
1685 AVisual := gdk_window_get_visual(Parent^.get_window);
1686 if Gtk3IsGdkVisual(AVisual) then
1687 begin
1688 Result := gdk_visual_get_depth(AVisual);
1689 exit;
1690 end;
1691 end;
1692 AVisual := gdk_window_get_visual(gdk_get_default_root_window);
1693 if Gtk3IsGdkVisual(AVisual) then
1694 begin
1695 Result := gdk_visual_get_depth(AVisual);
1696 end;
1697 end;
1698
TGtk3DeviceContext.getDeviceSizenull1699 function TGtk3DeviceContext.getDeviceSize: TPoint;
1700 begin
1701 Result := Point(0 , 0);
1702 if Parent <> nil then
1703 begin
1704 Result.y := Parent^.get_allocated_height;
1705 Result.x := Parent^.get_allocated_width;
1706 end else
1707 if ParentPixmap <> nil then
1708 begin
1709 Result.y := ParentPixmap^.height;
1710 Result.x := ParentPixmap^.width;
1711 end else
1712 if Gtk3IsGdkWindow(Window) then
1713 begin
1714 Result.X := Window^.get_width;
1715 Result.y := Window^.get_height;
1716 end;
1717 end;
1718
LineTonull1719 function TGtk3DeviceContext.LineTo(const X, Y: Integer): Boolean;
1720 begin
1721 if not Assigned(Widget) then
1722 exit(False);
1723 ApplyPen;
1724 cairo_line_to(Widget, X, Y);
1725 cairo_stroke(Widget);
1726 Result := True;
1727 end;
1728
MoveTonull1729 function TGtk3DeviceContext.MoveTo(const X, Y: Integer; OldPoint: PPoint
1730 ): Boolean;
1731 var
1732 dx: Double;
1733 dy: Double;
1734 begin
1735 if not Assigned(Widget) then
1736 exit(False);
1737 if OldPoint <> nil then
1738 begin
1739 cairo_get_current_point(Widget, @dx, @dy);
1740 OldPoint^.X := Round(dx);
1741 OldPoint^.Y := Round(dy);
1742 end;
1743 cairo_move_to(Widget, X, Y);
1744 Result := True;
1745 end;
1746
SetClipRegionnull1747 function TGtk3DeviceContext.SetClipRegion(ARgn: TGtk3Region): Integer;
1748 begin
1749 Result := SimpleRegion;
1750 if Assigned(Widget) then
1751 begin
1752 cairo_reset_clip(Widget);
1753 gdk_cairo_region(Self.Widget, ARgn.FHandle);
1754 cairo_clip(Widget);
1755 end;
1756 end;
1757
1758 procedure TGtk3DeviceContext.SetSourceColor(AColor: TColor);
1759 var
1760 R, G, B: double;
1761 begin
1762 TColorToRGB(AColor, R, G, B);
1763 cairo_set_source_rgb(Widget, R, G, B);
1764 end;
1765
1766 procedure TGtk3DeviceContext.SetCurrentBrush(ABrush: TGtk3Brush);
1767 begin
1768 FCurrentBrush := ABrush;
1769 end;
1770
1771 procedure TGtk3DeviceContext.SetCurrentFont(AFont: TGtk3Font);
1772 begin
1773 FCurrentFont := AFont;
1774 end;
1775
1776 procedure TGtk3DeviceContext.SetCurrentPen(APen: TGtk3Pen);
1777 begin
1778 FCurrentPen := APen;
1779 end;
1780
1781 procedure TGtk3DeviceContext.SetCurrentImage(AImage: TGtk3Image);
1782 begin
1783 FCurrentImage := AImage;
1784 end;
1785
1786 procedure TGtk3DeviceContext.SetImage(AImage: TGtk3Image);
1787 var
1788 APixBuf: PGdkPixbuf;
1789 begin
1790 FCurrentImage := AImage;
1791 cairo_destroy(Widget);
1792 APixBuf := AImage.Handle;
1793 if not Gtk3IsGdkPixbuf(APixBuf) then
1794 begin
1795 DebugLn('ERROR: TGtk3DeviceContext.SetImage image handle isn''t PGdkPixbuf.');
1796 exit;
1797 end;
1798 (*
1799 DebugLn('TGtk3DeviceContext.SetImage w=',dbgs(APixBuf^.width),' h=',dbgs(APixBuf^.height),
1800 ' RowStride ',dbgs(APixBuf^.rowstride),' BPS=',dbgs(APixBuf^.get_bits_per_sample),
1801 ' BLEN ',dbgs(APixbuf^.get_byte_length),' channels ',dbgs(APixBuf^.get_n_channels),
1802 ' ALPHA ',dbgs(APixbuf^.get_has_alpha));
1803 *)
1804 if FOwnsSurface and (CairoSurface <> nil) then
1805 cairo_surface_destroy(CairoSurface);
1806 CairoSurface := cairo_image_surface_create_for_data(APixBuf^.pixels,
1807 AImage.getFormat,
1808 APixBuf^.get_width,
1809 APixBuf^.get_height,
1810 APixBuf^.rowstride);
1811 Widget := cairo_create(CairoSurface);
1812 FOwnsSurface := true;
1813 end;
1814
ResetClipnull1815 function TGtk3DeviceContext.ResetClip: Integer;
1816 begin
1817 Result := NullRegion;
1818 if Assigned(Widget) then
1819 cairo_reset_clip(Widget);
1820 end;
1821
1822 procedure TGtk3DeviceContext.TranslateCairoToDevice;
1823 var
1824 Pt: TPoint;
1825 begin
1826 Pt := Offset;
1827 Translate(Pt);
1828 end;
1829
1830 procedure TGtk3DeviceContext.Translate(APoint: TPoint);
1831 begin
1832 cairo_translate(Widget, APoint.X, APoint.Y);
1833 end;
1834
1835
1836 //various routines for text , copied from gtk2.
1837
1838 {-------------------------------------------------------------------------------
1839 function RemoveAmpersands(Src: PChar; LineLength : Longint) : PChar;
1840
1841 Creates a new PChar removing all escaping ampersands.
1842 -------------------------------------------------------------------------------}
RemoveAmpersandsnull1843 function RemoveAmpersands(Src: PChar; LineLength : Longint) : PChar;
1844 var
1845 i, j: Longint;
1846 ShortenChars, NewLength, SrcLength: integer;
1847 begin
1848 // count ampersands and find first ampersand
1849 ShortenChars:= 0; // chars to delete
1850 SrcLength:= LineLength;
1851
1852 { Look for amperands. If found, check if it is an escaped ampersand.
1853 If it is, don't count it in. }
1854 i:=0;
1855 while i<SrcLength do
1856 begin
1857 if Src[i] = '&' then
1858 begin
1859 if (i < SrcLength - 1) and (Src[i+1] = '&') then
1860 begin
1861 // escaping ampersand found
1862 inc(ShortenChars);
1863 inc(i,2);
1864 Continue;
1865 end
1866 else
1867 inc(ShortenChars);
1868 end;
1869 inc(i);
1870 end;
1871 // create new PChar
1872 NewLength:= SrcLength - ShortenChars;
1873
1874 Result:=StrAlloc(NewLength+1); // +1 for #0 char at end
1875
1876 // copy string without ampersands
1877 i:=0;
1878 j:=0;
1879 while (j < NewLength) do begin
1880 if Src[i] <> '&' then begin
1881 // copy normal char
1882 Result[j]:= Src[i];
1883 end else begin
1884 // ampersand
1885 if (i < (SrcLength - 1)) and (Src[i+1] = '&') then begin
1886 // escaping ampersand found
1887 inc(i);
1888 Result[j]:='&';
1889 end else
1890 // delete single ampersand
1891 dec(j);
1892 end;
1893 Inc(i);
1894 Inc(j);
1895 end;
1896 Result[NewLength]:=#0;
1897 end;
1898
1899 {-------------------------------------------------------------------------------
1900 function GetTextExtentIgnoringAmpersands(TheFont: PGDKFont;
1901 Str : PChar; StrLength: integer;
1902 MaxWidth: Longint; lbearing, rbearing, width, ascent, descent : Pgint);
1903
1904 Gets text extent of a string, ignoring escaped Ampersands.
1905 That means, ampersands are not counted.
1906 Negative MaxWidth means no limit.
1907 -------------------------------------------------------------------------------}
1908 procedure GetTextExtentIgnoringAmpersands(TheFont: TGtk3Font;
1909 Str : PChar; StrLength: integer;
1910 lbearing, rbearing, width, ascent, descent : Pgint);
1911 var
1912 NewStr : PChar;
1913 i: integer;
1914 AInkRect: TPangoRectangle;
1915 ALogicalRect: TPangoRectangle;
1916 AMetrics: PPangoFontMetrics;
1917 ACharWidth: gint;
1918 begin
1919 NewStr:=Str;
1920 // first check if Str contains an ampersand:
1921 if (Str<>nil) then
1922 begin
1923 i:=0;
1924 while (Str[i]<>'&') and (i<StrLength) do inc(i);
1925 if i<StrLength then
1926 begin
1927 NewStr := RemoveAmpersands(Str, StrLength);
1928 StrLength:=StrLen(NewStr);
1929 end;
1930 end;
1931 TheFont.Layout^.set_text(Str, StrLength);
1932
1933 // TheFont.Layout^.get_extents(@AInkRect, @ALogicalRect);
1934
1935 AMetrics := pango_context_get_metrics(TheFont.Layout^.get_context, TheFont.Handle, TheFont.Layout^.get_context^.get_language);
1936 // if not Gtk3IsPangoFontMetrics(PGObject(AMetrics)) then
1937 // exit;
1938 if AMetrics = nil then
1939 begin
1940 Debugln('WARNING: GetTextExtentIgnoringAmpersands AMetrics=nil');
1941 exit;
1942 end;
1943
1944 if ascent <> nil then
1945 ascent^ := AMetrics^.get_ascent;
1946 if descent <> nil then
1947 descent^ := AMetrics^.get_descent;
1948 if width <> nil then
1949 begin
1950 ACharWidth := AMetrics^.get_approximate_char_width;
1951 width^ := (StrLength * ACharWidth) div PANGO_SCALE;
1952 end;
1953 // PANGO_PIXELS(char_width)
1954
1955 // lBearing^ := 0;
1956 // rBearing^ := 0;
1957 // gdk_text_extents(TheFont, NewStr, StrLength,
1958 // lbearing, rBearing, width, ascent, descent);
1959 if NewStr<>Str then
1960 StrDispose(NewStr);
1961 AMetrics^.unref;
1962 end;
1963
1964 {------------------------------------------------------------------------------
1965 procedure Gtk3WordWrap(DC: HDC; AText: PChar; MaxWidthInPixel: integer;
1966 var Lines: PPChar; var LineCount: integer); virtual;
1967
1968 Breaks AText into several lines and creates a list of PChar. The last entry
1969 will be nil.
1970 Lines break at new line chars and at spaces if a line is longer than
1971 MaxWidthInPixel or in a word.
1972 Lines will be one memory block so that you can free the list and all lines
1973 with FreeMem(Lines).
1974 ------------------------------------------------------------------------------}
1975 procedure Gtk3WordWrap(DC: HDC; AText: PChar;
1976 MaxWidthInPixel: integer; out Lines: PPChar; out LineCount: integer);
1977 var
1978 UseFont: TGtk3Font;
1979
GetLineWidthInPixelnull1980 function GetLineWidthInPixel(LineStart, LineLen: integer): integer;
1981 var
1982 width: LongInt;
1983 begin
1984 GetTextExtentIgnoringAmpersands(UseFont, @AText[LineStart], LineLen,
1985 nil, nil, @width, nil, nil);
1986 Result := Width;
1987 end;
1988
FindLineEndnull1989 function FindLineEnd(LineStart: integer): integer;
1990 var
1991 CharLen,
1992 LineStop,
1993 LineWidth, WordWidth, WordEnd, CharWidth: integer;
1994 begin
1995 // first search line break or text break
1996 Result:=LineStart;
1997 while not (AText[Result] in [#0,#10,#13]) do inc(Result);
1998 if Result<=LineStart+1 then exit;
1999 lineStop:=Result;
2000
2001 // get current line width in pixel
2002 LineWidth:=GetLineWidthInPixel(LineStart,Result-LineStart);
2003 if LineWidth>MaxWidthInPixel then
2004 begin
2005 // line too long
2006 // -> add words till line size reached
2007 LineWidth:=0;
2008 WordEnd:=LineStart;
2009 WordWidth:=0;
2010 repeat
2011 Result:=WordEnd;
2012 inc(LineWidth,WordWidth);
2013 // find word start
2014 while AText[WordEnd] in [' ',#9] do inc(WordEnd);
2015 // find word end
2016 while not (AText[WordEnd] in [#0,' ',#9,#10,#13]) do inc(WordEnd);
2017 // calculate word width
2018 WordWidth:=GetLineWidthInPixel(Result,WordEnd-Result);
2019 until LineWidth+WordWidth>MaxWidthInPixel;
2020 if LineWidth=0 then
2021 begin
2022 // the first word is longer than the maximum width
2023 // -> add chars till line size reached
2024 Result:=LineStart;
2025 LineWidth:=0;
2026 repeat
2027 charLen:=UTF8CodepointSize(@AText[result]);
2028 CharWidth:=GetLineWidthInPixel(Result,charLen);
2029 inc(LineWidth,CharWidth);
2030 if LineWidth>MaxWidthInPixel then break;
2031 if result>=lineStop then break;
2032 inc(Result,charLen);
2033 until false;
2034 // at least one char
2035 if Result=LineStart then begin
2036 charLen:=UTF8CodepointSize(@AText[result]);
2037 inc(Result,charLen);
2038 end;
2039 end;
2040 end;
2041 end;
2042
IsEmptyTextnull2043 function IsEmptyText: boolean;
2044 begin
2045 if (AText=nil) or (AText[0]=#0) then
2046 begin
2047 // no text
2048 GetMem(Lines,SizeOf(PChar));
2049 Lines[0]:=nil;
2050 LineCount:=0;
2051 Result:=true;
2052 end else
2053 Result:=false;
2054 end;
2055
2056 procedure InitFont;
2057 begin
2058 UseFont := TGtk3DeviceContext(DC).CurrentFont;
2059 end;
2060
2061 var
2062 LinesList: TIntegerList;
2063 LineStart, LineEnd, LineLen: integer;
2064 ArraySize, TotalSize: integer;
2065 i: integer;
2066 CurLineEntry: PPChar;
2067 CurLineStart: PChar;
2068 begin
2069 if IsEmptyText then
2070 begin
2071 Lines:=nil;
2072 LineCount:=0;
2073 exit;
2074 end;
2075 InitFont;
2076 LinesList:=TIntegerList.Create;
2077 LineStart:=0;
2078
2079 // find all line starts and line ends
2080 repeat
2081 LinesList.Add(LineStart);
2082 // find line end
2083 LineEnd:=FindLineEnd(LineStart);
2084 LinesList.Add(LineEnd);
2085 // find next line start
2086 LineStart:=LineEnd;
2087 if AText[LineStart] in [#10,#13] then
2088 begin
2089 // skip new line chars
2090 inc(LineStart);
2091 if (AText[LineStart] in [#10,#13])
2092 and (AText[LineStart]<>AText[LineStart-1]) then
2093 inc(LineStart);
2094 end else
2095 if AText[LineStart] in [' ',#9] then
2096 begin
2097 // skip space
2098 while AText[LineStart] in [' ',#9] do
2099 inc(LineStart);
2100 end;
2101 until AText[LineStart]=#0;
2102
2103 // create mem block for 'Lines': array of PChar + all lines
2104 LineCount:=LinesList.Count shr 1;
2105 ArraySize:=(LineCount+1)*SizeOf(PChar);
2106 TotalSize:=ArraySize;
2107 i:=0;
2108 while i<LinesList.Count do
2109 begin
2110 // add LineEnd - LineStart + 1 for the #0
2111 LineLen:=LinesList[i+1]-LinesList[i]+1;
2112 inc(TotalSize,LineLen);
2113 inc(i,2);
2114 end;
2115 GetMem(Lines,TotalSize);
2116 FillChar(Lines^,TotalSize,0);
2117
2118 // create Lines
2119 CurLineEntry:=Lines;
2120 CurLineStart:=PChar(CurLineEntry)+ArraySize;
2121 i:=0;
2122 while i<LinesList.Count do
2123 begin
2124 // set the pointer to the start of the current line
2125 CurLineEntry[i shr 1]:=CurLineStart;
2126 // copy the line
2127 LineStart:=LinesList[i];
2128 LineEnd:=LinesList[i+1];
2129 LineLen:=LineEnd-LineStart;
2130 if LineLen>0 then
2131 Move(AText[LineStart],CurLineStart^,LineLen);
2132 inc(CurLineStart,LineLen);
2133 // add #0 as line end
2134 CurLineStart^:=#0;
2135 inc(CurLineStart);
2136 // next line
2137 inc(i,2);
2138 end;
2139 if {%H-}PtrUInt(CurLineStart)-{%H-}PtrUInt(Lines)<>TotalSize then
2140 RaiseGDBException('Gtk3WordWrap Consistency Error:'
2141 +' Lines+TotalSize<>CurLineStart');
2142 CurLineEntry[i shr 1]:=nil;
2143
2144 LinesList.Free;
2145 end;
2146
2147 end.
2148