diff options
Diffstat (limited to 'gfx/x11/gfx_x11.pas')
| -rw-r--r-- | gfx/x11/gfx_x11.pas | 1865 |
1 files changed, 1865 insertions, 0 deletions
diff --git a/gfx/x11/gfx_x11.pas b/gfx/x11/gfx_x11.pas new file mode 100644 index 00000000..ac74f781 --- /dev/null +++ b/gfx/x11/gfx_x11.pas @@ -0,0 +1,1865 @@ +{ + fpGFX - Free Pascal Graphics Library + Copyright (C) 2000 - 2001 by + Areca Systems GmbH / Sebastian Guenther, sg@freepascal.org + + X11/XLib target implementation + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +} + + +unit GFX_X11; + +{$IFDEF Debug} + {$ASSERTIONS On} +{$ENDIF} + +{$mode objfpc}{$H+} + +{ Disable this, if you do not want Xft to be used for drawing text } +{.$Define XftSupport} + +interface + +uses + SysUtils, Classes, // FPC units + X, XLib, XUtil, // X11 units + {$IFDEF XftSupport} + unitxft; // Xft font support + {$ENDIF} + GfxBase, // fpGFX units + GELDirty; // fpGFX emulation layer + + +resourcestring + // X11 exception strings + SGCCreationFailed = 'Creation of X11 graphics context failed'; + SXCanvasInvalidFontClass = 'Tried to set font of class "%s" into X11 context; only TXFont is allowed.'; + SOpenDisplayFailed = 'Opening of display "%s" failed'; + SWindowCreationFailed = 'Creation of X11 window failed'; + SWindowUnsupportedPixelFormat = 'Window uses unsupported pixel format: %d bits per pixel'; + SNoDefaultFont = 'Unable to load default font'; + SIncompatibleCanvasForBlitting = 'Cannot blit from %s to %s'; + + +type + EX11Error = class(EGfxError); + TX11Canvas = class; + TX11Application = class; + + // Returns True if it 'ate' the event + TX11EventFilter = function (const AEvent: TXEvent): Boolean of object; + + { TX11Font } + + TX11Font = class(TFCustomFont) + private + FFontStruct: PXFontStruct; + public + constructor Create(const Descriptor: String); + destructor Destroy; override; + class function GetDefaultFontName(const AFontClass: TGfxFontClass): String; override; + property FontStruct: PXFontStruct read FFontStruct; + end; + + + PX11CanvasState = ^TX11CanvasState; + TX11CanvasState = record + Prev: PX11CanvasState; + Matrix: TGfxMatrix; + Region: TRegion; + Color: TGfxPixel; + Font: TFCustomFont; + end; + + + { TX11Canvas } + + TX11Canvas = class(TFCustomCanvas) + private + FHandle: X.TDrawable; + FGC: TGC; + FVisual: PVisual; + FRegion: TRegion; + FDefaultFont: PXFontStruct; + FFontStruct: PXFontStruct; + FStateStackpointer: PX11CanvasState; + FColormap: TColormap; + FCurColor: TGfxPixel; + FFont: TFCustomFont; + {$IFDEF XftSupport} + FXftDraw: PXftDraw; + {$ENDIF} + procedure Resized(NewWidth, NewHeight: Integer); + protected + function DoExcludeClipRect(const ARect: TRect): Boolean; override; + function DoIntersectClipRect(const ARect: TRect): Boolean; override; + function DoUnionClipRect(const ARect: TRect): Boolean; override; + function DoGetClipRect: TRect; override; + procedure DoDrawArc(const ARect: TRect; StartAngle, EndAngle: Single); override; + procedure DoDrawCircle(const ARect: TRect); override; + procedure DoDrawLine(const AFrom, ATo: TPoint); override; + procedure DoDrawRect(const ARect: TRect); override; + procedure DoDrawPoint(const APoint: TPoint); override; + procedure DoFillRect(const ARect: TRect); override; + procedure DoTextOut(const APosition: TPoint; const AText: String); override; + procedure DoCopyRect(ASource: TFCustomCanvas; const ASourceRect: TRect; const ADestPos: TPoint); override; + procedure DoMaskedCopyRect(ASource, AMask: TFCustomCanvas; const ASourceRect: TRect; const AMaskPos, ADestPos: TPoint); override; + procedure DoDrawImageRect(AImage: TFCustomImage; ASourceRect: TRect; const ADestPos: TPoint); override; + public + constructor Create(AColormap: TColormap; AXDrawable: X.TDrawable; ADefaultFont: PXFontStruct); + destructor Destroy; override; + function MapColor(const AColor: TGfxColor): TGfxPixel; override; + function FontCellHeight: Integer; override; + function TextExtent(const AText: String): TSize; override; + procedure SaveState; override; + procedure RestoreState; override; + procedure EmptyClipRect; override; + procedure SetColor_(AColor: TGfxPixel); override; + procedure SetFont(AFont: TFCustomFont); override; + procedure SetLineStyle(ALineStyle: TGfxLineStyle); override; + procedure DrawPolyLine(const Coords: array of TPoint); override; + property Handle: X.TDrawable read FHandle; + property GC: TGC read FGC; + property Visual: PVisual read FVisual; + property Colormap: TColormap read FColormap; + property Region: TRegion read FRegion; + end; + + + TX11WindowCanvas = class(TX11Canvas) + public + constructor Create(AColormap: TColormap; + AXDrawable: X.TDrawable; ADefaultFont: PXFontStruct); + end; + + + TX11PixmapCanvas = class(TX11Canvas) + public + constructor Create(AColormap: TColormap; + AHandle: TPixmap; APixelFormat: TGfxPixelFormat); + destructor Destroy; override; + end; + + + TX11MonoPixmapCanvas = class(TX11PixmapCanvas) + constructor Create(AColormap: TColormap; AHandle: TPixmap); + end; + + + TX11Image = class(TFCustomImage) + private + IsLocked: Boolean; + protected + FStride: LongWord; + FData: Pointer; + public + constructor Create(AWidth, AHeight: Integer; APixelFormat: TGfxPixelFormat); override; + destructor Destroy; override; + procedure Lock(var AData: Pointer; var AStride: LongWord); override; + procedure Unlock; override; + property Stride: LongWord read FStride; + property Data: Pointer read FData; + end; + + { TX11Screen } + + TX11Screen = class(TFCustomScreen) + private + FScreenIndex: Integer; + FScreenInfo: PScreen; + public + constructor Create; override; + property ScreenIndex: Integer read FScreenIndex; + property ScreenInfo: PScreen read FScreenInfo; + end; + + + TX11Window = class; + + + PXWindowListEntry = ^TXWindowListEntry; + TXWindowListEntry = record + GfxWindow: TFCustomWindow; + XWindowID: X.TWindow; + end; + + + { TX11Application } + + TX11Application = class(TFCustomApplication) + private + DoBreakRun: Boolean; + FDirtyList: TDirtyList; + FDisplayName: String; + FDefaultFont: PXFontStruct; + FEventFilter: TX11EventFilter; + Handle: PDisplay; + FWMProtocols: TAtom; // Atom for "WM_PROTOCOLS" + FWMDeleteWindow: TAtom; // Atom for "WM_DELETE_WINDOW" + FWMHints: TAtom; // Atom for "_MOTIF_WM_HINTS" + property DirtyList: TDirtyList read FDirtyList; + function FindWindowByXID(XWindowID: X.TWindow): PXWindowListEntry; + public + { default methods } + constructor Create; override; + destructor Destroy; override; + procedure AddWindow(AWindow: TFCustomWindow); override; + procedure Initialize(ADisplayName: String = ''); override; + procedure Run; override; + procedure Quit; override; + { properties } + property DisplayName: String read FDisplayName write FDisplayName; + property EventFilter: TX11EventFilter read FEventFilter write FEventFilter; + end; + + { TX11Window } + + TX11Window = class(TFCustomWindow) + private + FParent: TFCustomWindow; + FComposeStatus: TXComposeStatus; + FComposeBuffer: String[32]; + FCurCursorHandle: X.TCursor; + function StartComposing(const Event: TXKeyEvent): TKeySym; + procedure EndComposing; + procedure KeyPressed(var Event: TXKeyPressedEvent); message X.KeyPress; + procedure KeyReleased(var Event: TXKeyReleasedEvent); message X.KeyRelease; + procedure ButtonPressed(var Event: TXButtonPressedEvent); message X.ButtonPress; + procedure ButtonReleased(var Event: TXButtonReleasedEvent); message X.ButtonRelease; + procedure EnterWindow(var Event :TXEnterWindowEvent); message X.EnterNotify; + procedure LeaveWindow(var Event :TXLeaveWindowEvent); message X.LeaveNotify; + procedure PointerMoved(var Event: TXPointerMovedEvent); message X.MotionNotify; + procedure Expose(var Event: TXExposeEvent); message X.Expose; + procedure FocusIn(var Event: TXFocusInEvent); message X.FocusIn; + procedure FocusOut(var Event: TXFocusOutEvent); message X.FocusOut; + procedure Map(var Event: TXMapEvent); message X.MapNotify; + procedure Unmap(var Event: TXUnmapEvent); message X.UnmapNotify; + procedure Reparent(var Event: TXReparentEvent); message X.ReparentNotify; + procedure Configure(var Event: TXConfigureEvent); message X.ConfigureNotify; + procedure ClientMessage(var Event: TXClientMessageEvent); message X.ClientMessage; + protected + IsExposing: Boolean; + CanMaximize: Boolean; + function CreateXWindow(AParent: X.TWindow; ALeft, ATop: longint; AWidth, AHeight: longword; AVisual: PVisual; AValueMask: LongWord; const AAttr: TXSetWindowAttributes): X.TWindow; virtual; + function GetTitle: String; override; + function ConvertShiftState(AState: Cardinal): TShiftState; + function KeySymToKeycode(KeySym: TKeySym): Word; + procedure SetTitle(const ATitle: String); override; + procedure DoSetCursor; override; + procedure UpdateMotifWMHints; + public + constructor Create(AParent: TFCustomWindow; AWindowOptions: TGfxWindowOptions); + destructor Destroy; override; + procedure DefaultHandler(var Message); override; + procedure SetPosition(const APosition: TPoint); override; + procedure SetSize(const ASize: TSize); override; + procedure SetMinMaxSize(const AMinSize, AMaxSize: TSize); override; + procedure SetClientSize(const ASize: TSize); override; + procedure SetMinMaxClientSize(const AMinSize, AMaxSize: TSize); override; + procedure Show; override; + procedure Invalidate(const ARect: TRect); override; + procedure PaintInvalidRegion; override; + procedure CaptureMouse; override; + procedure ReleaseMouse; override; + end; + + +var + LeaderWindow: X.TWindow; + ClientLeaderAtom: TAtom; + +function RectToXRect(const ARect: TRect): TXRectangle; +function XRectToRect(const ARect: TXRectangle): TRect; +function GetXEventName(Event: LongInt): String; + + +implementation + +uses + GELImage, fpgfx; + +resourcestring + SFontCreationFailed = 'Could not create font with descriptor "%s"'; + +{ TX11Font } + +constructor TX11Font.Create(const Descriptor: String); +begin + inherited Create; + + FFontStruct := XLoadQueryFont(gApplication.Handle, PChar(Descriptor)); + if not Assigned(FFontStruct) then + raise EX11Error.CreateFmt(SFontCreationFailed, [Descriptor]); +end; + +destructor TX11Font.Destroy; +begin + if Assigned(FontStruct) then + begin + if FontStruct^.fid <> 0 then + XUnloadFont(gApplication.Handle, FontStruct^.fid); + XFreeFontInfo(nil, FontStruct, 0); + end; + inherited Destroy; +end; + +class function TX11Font.GetDefaultFontName(const AFontClass: TGfxFontClass): String; +const + FontNames: array[TGfxFontClass] of String = ( + 'times', 'bitstream vera sans', 'courier', 'symbol'); +begin + Result := FontNames[AFontClass]; +end; + + +{ TX11Canvas } + +constructor TX11Canvas.Create(AColormap: TColormap; AXDrawable: X.TDrawable; ADefaultFont: PXFontStruct); +var + DummyWnd: PWindow; + DummyInt: LongInt; + GCValues: XLib.TXGCValues; +begin + inherited Create; + FColormap := AColormap; + FHandle := AXDrawable; + FDefaultFont := ADefaultFont; + XGetGeometry(gApplication.Handle, Handle, @DummyWnd, @DummyInt, @DummyInt, + @FWidth, @FHeight, @DummyInt, @DummyInt); + + GCValues.graphics_exposures := False; + FGC := XCreateGC(gApplication.Handle, Handle, GCGraphicsExposures, @GCValues); + if not Assigned(GC) then + raise EX11Error.Create(SGCCreationFailed); + + XSetLineAttributes(gApplication.Handle, GC, 0, + LineSolid, CapNotLast, JoinMiter); + + FFontStruct := FDefaultFont; + if Assigned(FFontStruct) then + XSetFont(gApplication.Handle, GC, FFontStruct^.FID); + + FRegion := XCreateRegion; + Resized(Width, Height); // Set up a proper clipping region + + {$IFDEF XftSupport} + {$IFDEF BUFFERING} + FBufferWin := XdbeAllocateBackBufferName(gApplication, FWin, nil); + if FBufferWin > 0 then + FXftDrawBuffer := XftDrawCreate(gApplication.Handle, FBufferWin, + XDefaultVisual(gApplication.Handle, GfxDefaultScreen), + XDefaultColormap(gApplication.Handle, GfxDefaultScreen)); + {$ELSE} + // FBufferWin := -1; + // FXftDrawBuffer := nil; + {$ENDIF} + FXftDraw := XftDrawCreate(gApplication.Handle, Handle, + XDefaultVisual(gApplication.Handle, XDefaultScreen(gApplication.Handle)), + XDefaultColormap(gApplication.Handle, XDefaultScreen(gApplication.Handle))); + {$ENDIF XftSupport} +end; + +destructor TX11Canvas.Destroy; +begin + {$IFDEF XftSupport} + if FXftDraw <> nil then + XftDrawDestroy(FXftDraw); + {$ENDIF} + XDestroyRegion(Region); + if Assigned(GC) then + XFreeGC(gApplication.Handle, GC); + inherited Destroy; +end; + +procedure TX11Canvas.SaveState; +var + SavedState: PX11CanvasState; + NewRegion: TRegion; +begin + New(SavedState); + SavedState^.Prev := FStateStackpointer; + SavedState^.Matrix := Matrix; + SavedState^.Region := Region; + NewRegion := XCreateRegion; + XUnionRegion(Region, NewRegion, NewRegion); + FRegion := NewRegion; + SavedState^.Color := FCurColor; + SavedState^.Font := FFont; + FStateStackpointer := SavedState; +end; + +procedure TX11Canvas.RestoreState; +var + SavedState: PX11CanvasState; +begin + SavedState := FStateStackpointer; + FStateStackpointer := SavedState^.Prev; + Matrix := SavedState^.Matrix; + + XDestroyRegion(Region); + FRegion := SavedState^.Region; + XSetRegion(gApplication.Handle, GC, Region); + + SetColor_(SavedState^.Color); + SetFont(SavedState^.Font); + + Dispose(SavedState); +end; + +procedure TX11Canvas.EmptyClipRect; +begin + XDestroyRegion(Region); + FRegion := XCreateRegion; + XSetRegion(gApplication.Handle, GC, Region); +end; + +function TX11Canvas.DoExcludeClipRect(const ARect: TRect): Boolean; +var + RectRegion: TRegion; + XRect: TXRectangle; +begin + XRect := RectToXRect(ARect); + RectRegion := XCreateRegion; + XUnionRectWithRegion(@XRect, RectRegion, RectRegion); + XSubtractRegion(Region, RectRegion, Region); + XDestroyRegion(RectRegion); + XSetRegion(gApplication.Handle, GC, Region); + Result := XEmptyRegion(Region) = 0; +end; + +function TX11Canvas.DoIntersectClipRect(const ARect: TRect): Boolean; +var + RectRegion: TRegion; + XRect: TXRectangle; +begin + XRect := RectToXRect(ARect); + RectRegion := XCreateRegion; + XUnionRectWithRegion(@XRect, RectRegion, RectRegion); + XIntersectRegion(Region, RectRegion, Region); + XDestroyRegion(RectRegion); + XSetRegion(gApplication.Handle, GC, Region); + Result := XEmptyRegion(Region) = 0; +end; + +function TX11Canvas.DoUnionClipRect(const ARect: TRect): Boolean; +var + XRect: TXRectangle; +begin + XRect := RectToXRect(ARect); + XUnionRectWithRegion(@XRect, Region, Region); + XSetRegion(gApplication.Handle, GC, Region); + Result := XEmptyRegion(Region) = 0; +end; + +function TX11Canvas.DoGetClipRect: TRect; +var + XRect: TXRectangle; +begin + XClipBox(Region, @XRect); + Result := XRectToRect(XRect); +end; + +function TX11Canvas.MapColor(const AColor: TGfxColor): TGfxPixel; +var + Color: TXColor; +begin + Color.Pixel := 0; + Color.Red := AColor.Red; + Color.Green := AColor.Green; + Color.Blue := AColor.Blue; + XAllocColor(gApplication.Handle, Colormap, @Color); + Result := Color.Pixel; +end; + +procedure TX11Canvas.SetColor_(AColor: TGfxPixel); +begin + if AColor <> FCurColor then + begin + XSetForeground(gApplication.Handle, GC, AColor); + FCurColor := AColor; + end; +end; + +procedure TX11Canvas.SetFont(AFont: TFCustomFont); +begin + if AFont = FFont then + exit; + + FFont := AFont; + + if not Assigned(AFont) then + begin + if FFontStruct = FDefaultFont then + exit; + FFontStruct := FDefaultFont; + end else + begin + if not AFont.InheritsFrom(TX11Font) then + raise EGfxError.CreateFmt(SXCanvasInvalidFontClass, [AFont.ClassName]); + if TX11Font(AFont).FontStruct = FFontStruct then + exit; + FFontStruct := TX11Font(AFont).FontStruct; + end; + XSetFont(gApplication.Handle, GC, FFontStruct^.FID); +end; + +procedure TX11Canvas.SetLineStyle(ALineStyle: TGfxLineStyle); +const + DotDashes: array[0..1] of Char = #4#2; + { It was #1#1 which gives 1 pixel dots. Now it gives a 4 pixel line and a + 2 pixel space. } +begin + case ALineStyle of + lsSolid: + XSetLineAttributes(gApplication.Handle, GC, 0, + LineSolid, CapNotLast, JoinMiter); + lsDot: + begin + XSetLineAttributes(gApplication.Handle, GC, 0, + LineOnOffDash, CapNotLast, JoinMiter); + XSetDashes(gApplication.Handle, GC, 0, DotDashes, 2); + end; + end; +end; + + +procedure TX11Canvas.DoDrawArc(const ARect: TRect; StartAngle, EndAngle: Single); +begin + with ARect do + XDrawArc(gApplication.Handle, Handle, GC, + Left, Top, Right - Left - 1, Bottom - Top - 1, + Round(StartAngle * 64), Round((EndAngle - StartAngle) * 64)); +end; + + +procedure TX11Canvas.DoDrawCircle(const ARect: TRect); +begin + with ARect do + XDrawArc(gApplication.Handle, Handle, GC, + Left, Top, Right - Left - 1, Bottom - Top - 1, 0, 23040); +end; + + +procedure TX11Canvas.DoDrawLine(const AFrom, ATo: TPoint); +begin + XDrawLine(gApplication.Handle, Handle, GC, AFrom.x, AFrom.y, ATo.x, ATo.y); +end; + + +procedure TX11Canvas.DrawPolyLine(const Coords: array of TPoint); +var + Points: PXPoint; + CoordsIndex, PointsIndex: Integer; + Pt: TPoint; +begin + Points := nil; + GetMem(Points, (High(Coords) - Low(Coords) + 1) * SizeOf(TXPoint)); + CoordsIndex := Low(Coords); + PointsIndex := 0; + for CoordsIndex := Low(Coords) to High(Coords) do + begin + Pt := Transform(Coords[CoordsIndex]); + Points[PointsIndex].x := Pt.x; + Points[PointsIndex].y := Pt.y; + Inc(PointsIndex); + end; + + XDrawLines(gApplication.Handle, Handle, GC, Points, PointsIndex, CoordModeOrigin); + + FreeMem(Points); +end; + + +procedure TX11Canvas.DoDrawRect(const ARect: TRect); +begin + with ARect do + XDrawRectangle(gApplication.Handle, Handle, GC, Left, Top, + Right - Left - 1, Bottom - Top - 1); +end; + + +procedure TX11Canvas.DoDrawPoint(const APoint: TPoint); +begin + XDrawPoint(gApplication.Handle, Handle, GC, APoint.x, APoint.y); +end; + + +procedure TX11Canvas.DoFillRect(const ARect: TRect); +begin + with ARect do + XFillRectangle(gApplication.Handle, Handle, GC, Left, Top, + Right - Left, Bottom - Top); +end; + + +function TX11Canvas.FontCellHeight: Integer; +begin + {$note XftSupport needs to be handled here!!! } + Result := FFontStruct^.Ascent + FFontStruct^.Descent; +end; + + +function TX11Canvas.TextExtent(const AText: String): TSize; +var + Direction, FontAscent, FontDescent: LongInt; + CharStruct: TXCharStruct; +begin +// inherited; + if Length(AText) = 0 then + begin + Result.cx := 0; + Result.cy := 0; + end else + begin + XQueryTextExtents(gApplication.Handle, XGContextFromGC(GC), + PChar(AText), Length(AText), + @Direction, @FontAscent, @FontDescent, @CharStruct); + Result.cx := CharStruct.Width; + Result.cy := CharStruct.Ascent + CharStruct.Descent; + end; +end; + + +procedure TX11Canvas.DoTextOut(const APosition: TPoint; const AText: String); +var + WideText: PWideChar; + AnsiText: string; + Size: Integer; + {$IFDEF XftSupport} + fnt: PXftFont; + fntColor: TXftColor; + s: String16; + + procedure SetXftColor(c: TGfxPixel; var colxft: TXftColor); + begin + colxft.color.blue := (c and $000000FF) shl 8; + colxft.color.green := (c and $0000FF00); + colxft.color.red := (c and $00FF0000) shr 8; + + colxft.color.alpha := (c and $7F000000) shr 15; + colxft.color.alpha := colxft.color.alpha xor $FFFF; // invert: 0 in GfxColor means not translucent + + colxft.pixel := 0; + end; + + {$ENDIF} +begin + if Length(AText) < 1 then + Exit; //==> + + {$IFDEF XftSupport} + fnt := XftFontOpenName(gApplication.Handle, XDefaultScreen(gApplication.Handle), PChar('Sans-12')); + SetXftColor(FCurColor,fntColor); + s := u8(AText); +// XftDrawString8(FXftDraw, fntColor, fnt, APosition.x, Aposition.y, PChar(AText),Length(AText)); + XftDrawString16(FXftDraw, fntColor, fnt, APosition.x, Aposition.y * 3, @s[1], Length16(s)); + XftFontClose(gApplication.Handle, fnt); + {$ELSE} + XDrawString(gApplication.Handle, Handle, GC, APosition.x, + APosition.y + FFontStruct^.ascent, PChar(AText), Length(AText)); + +{ Size := Utf8ToUnicode(nil, PChar(AText), 0); + WideText := GetMem(Size * 2); + Utf8ToUnicode(WideText, PChar(AText), Size); + + XwcDrawText(gApplication.Handle, Handle, GC, APosition.x, + APosition.y + FFontStruct^.ascent, PXwcTextItem(WideText), Length(WideText)); + + FreeMem(WideText); +} + {$ENDIF} +end; + + +procedure TX11Canvas.DoCopyRect(ASource: TFCustomCanvas; const ASourceRect: TRect; + const ADestPos: TPoint); +var + DestPos: TPoint; + RealHeight: Integer; +begin + if not ASource.InheritsFrom(TX11Canvas) then + raise EX11Error.CreateFmt(SIncompatibleCanvasForBlitting, + [ASource.ClassName, Self.ClassName]); + + if (ASource <> Self) and (ASource.PixelFormat.FormatType = ftMono) then + begin + // !!!: This case will probably be removed completely very soon + RealHeight := ASourceRect.Bottom - ASourceRect.Top; + if DestPos.y + RealHeight > Height then + RealHeight := Height - ADestPos.y; + XSetClipMask(gApplication.Handle, GC, TX11Canvas(ASource).Handle); + XSetClipOrigin(gApplication.Handle, GC, ADestPos.x, ADestPos.y); + XFillRectangle(gApplication.Handle, Handle, GC, ADestPos.x, ADestPos.y, + ASource.Width, RealHeight); + // Restore old clipping settings + XSetClipOrigin(gApplication.Handle, GC, 0, 0); + XSetRegion(gApplication.Handle, GC, Region); + end else + XCopyArea(gApplication.Handle, TX11Canvas(ASource).Handle, Handle, GC, + ASourceRect.Left, ASourceRect.Top, + ASourceRect.Right - ASourceRect.Left, + ASourceRect.Bottom - ASourceRect.Top, ADestPos.x, ADestPos.y); +end; + + +procedure TX11Canvas.DoMaskedCopyRect(ASource, AMask: TFCustomCanvas; + const ASourceRect: TRect; const AMaskPos, ADestPos: TPoint); +var + RectWidth, RectHeight: Integer; + DestPos, MaskPos: TPoint; + SourceRect: TRect; +begin + if not ASource.InheritsFrom(TX11Canvas) then + raise EX11Error.CreateFmt(SIncompatibleCanvasForBlitting, + [ASource.ClassName, Self.ClassName]); + if not AMask.InheritsFrom(TX11MonoPixmapCanvas) then + raise EX11Error.CreateFmt(SIncompatibleCanvasForBlitting, + [AMask.ClassName, Self.ClassName]); + + RectWidth := ASourceRect.Right - ASourceRect.Left; + RectHeight := ASourceRect.Bottom - ASourceRect.Top; + + { !!!: Attention! The current implementation only clips to the ClipRect, + i.e. the outer bounds of the current clipping region. In other words, the + result is only correct for a simple rectangle clipping region. } + with DoGetClipRect do + begin + if (ADestPos.x + RectWidth <= Left) or (ADestPos.y + RectHeight <= Top) then + exit; + + DestPos := ADestPos; + MaskPos := AMaskPos; + SourceRect := ASourceRect; + + if DestPos.x < Left then + begin + Inc(MaskPos.x, Left - DestPos.x); + Inc(SourceRect.Left, Left - DestPos.x); + DestPos.x := Left; + end; + if DestPos.y < Top then + begin + Inc(MaskPos.y, Top - DestPos.y); + Inc(SourceRect.Top, Top - DestPos.y); + DestPos.y := Top; + end; + + if (DestPos.x >= Right) or (DestPos.y >= Bottom) then + exit; + + if DestPos.x + RectWidth > Right then + RectWidth := Right - DestPos.x; + if DestPos.y + RectHeight > Bottom then + RectHeight := Bottom - DestPos.y; + end; + + if (RectWidth <= 0) or (RectHeight <= 0) then + exit; + + + XSetClipMask(gApplication.Handle, GC, TX11Canvas(AMask).Handle); + XSetClipOrigin(gApplication.Handle, GC, + DestPos.x - MaskPos.x, DestPos.y - MaskPos.y); + + XCopyArea(gApplication.Handle, TX11Canvas(ASource).Handle, Handle, GC, + SourceRect.Left, SourceRect.Top, RectWidth, RectHeight, + DestPos.x, DestPos.y); + + // Restore old clipping settings + XSetClipOrigin(gApplication.Handle, GC, 0, 0); + XSetRegion(gApplication.Handle, GC, Region); +end; + +procedure TX11Canvas.DoDrawImageRect(AImage: TFCustomImage; ASourceRect: TRect; + const ADestPos: TPoint); +var + Image: XLib.PXImage; + ConvertFormat: TGfxPixelFormat; +begin + ASSERT(AImage.InheritsFrom(TX11Image)); + {$IFDEF Debug} + ASSERT(not TXImage(AImage).IsLocked); + {$ENDIF} + + // !!!: Add support for XF86 4 and XShm etc. to speed this up! + Image := XCreateImage(gApplication.Handle, Visual, + FormatTypeBPPTable[PixelFormat.FormatType], ZPixmap, 0, nil, + ASourceRect.Right - ASourceRect.Left, + ASourceRect.Bottom - ASourceRect.Top, 8, 0); + + { Here its necessary to alloc an extra byte, otherwise it will fail on 32-bits + machines, but still work on 64-bits machines. The cause of this is unknown. } + Image^.data := GetMem(Image^.bytes_per_line * (ASourceRect.Bottom - ASourceRect.Top) + 1); + + if (AImage.PixelFormat.FormatType = ftMono) and + Self.InheritsFrom(TX11MonoPixmapCanvas) then + // mirror the bits within all image data bytes...: + FlipMonoImageBits(ASourceRect, TX11Image(AImage).Data, + TX11Image(AImage).Stride, 0, 0, Image^.data, Image^.bytes_per_line) + else + begin + ConvertFormat := PixelFormat; + { !!!: The following is a workaround: At least the XFree86 X server for + ATI graphics adapters uses 32 bit padding per pixel for 24 bpp + images...?!? To be checked: Is this always the case or only for ATI? } + if ConvertFormat.FormatType = ftRGB24 then + ConvertFormat.FormatType := ftRGB32; + + ConvertImage(ASourceRect, AImage.PixelFormat, AImage.Palette, + TX11Image(AImage).Data, TX11Image(AImage).Stride, + 0, 0, ConvertFormat, Image^.data, Image^.bytes_per_line); + end; + + XPutImage(gApplication.Handle, Handle, GC, + Image, 0, 0, ADestPos.x, ADestPos.y, AImage.Width, AImage.Height); + + FreeMem(Image^.data); + Image^.data := nil; + XDestroyImage(Image); +end; + + +procedure TX11Canvas.Resized(NewWidth, NewHeight: Integer); +var + XRect: TXRectangle; +begin + FWidth := NewWidth; + FHeight := NewHeight; + + XDestroyRegion(Region); + XRect.x := 0; + XRect.y := 0; + XRect.Width := Width; + XRect.Height := Height; + FRegion := XCreateRegion; + XUnionRectWithRegion(@XRect, Region, Region); +end; + + +{ TX11WindowCanvas } + +constructor TX11WindowCanvas.Create(AColormap: TColormap; + AXDrawable: X.TDrawable; ADefaultFont: PXFontStruct); +var + Attr: XLib.TXWindowAttributes; +begin + inherited Create(AColormap, AXDrawable, ADefaultFont); + + XGetWindowAttributes(gApplication.Handle, Handle, @Attr); + FVisual := Attr.Visual; + + case Attr.Depth of + 1: PixelFormat.FormatType := ftMono; + 4: PixelFormat.FormatType := ftPal4; + 8: PixelFormat.FormatType := ftPal8; + 16: PixelFormat.FormatType := ftRGB16; + 24: PixelFormat.FormatType := ftRGB24; + 32: PixelFormat.FormatType := ftRGB32; + else + raise EX11Error.CreateFmt(SWindowUnsupportedPixelFormat, [Attr.Depth]); + end; + + if Attr.Depth >= 16 then + begin + PixelFormat.RedMask := Visual^.red_mask; + PixelFormat.GreenMask := Visual^.green_mask; + PixelFormat.BlueMask := Visual^.blue_mask; + end; +end; + + +{ TX11PixmapCanvas } + +constructor TX11PixmapCanvas.Create(AColormap: TColormap; + AHandle: TPixmap; APixelFormat: TGfxPixelFormat); +begin + inherited Create(AColormap, AHandle, nil); + FPixelFormat := APixelFormat; +end; + + +destructor TX11PixmapCanvas.Destroy; +begin + XFreePixmap(gApplication.Handle, Handle); + inherited Destroy; +end; + +{ TX11MonoPixmapCanvas } + +constructor TX11MonoPixmapCanvas.Create(AColormap: TColormap; AHandle: TPixmap); +begin + inherited Create(AColormap, AHandle, PixelFormatMono); +end; + +{ TX11Image } + +constructor TX11Image.Create(AWidth, AHeight: Integer; APixelFormat: TGfxPixelFormat); +begin + inherited Create(AWidth, AHeight, APixelFormat); + + case APixelFormat.FormatType of + ftMono: + FStride := (AWidth + 7) shr 3; + ftPal4, ftPal4A: + FStride := (AWidth + 1) and not 1; + else + FStride := AWidth * (FormatTypeBPPTable[APixelFormat.FormatType] shr 3); + end; + GetMem(FData, FStride * Height); +end; + +destructor TX11Image.Destroy; +begin + FreeMem(FData); + inherited Destroy; +end; + +procedure TX11Image.Lock(var AData: Pointer; var AStride: LongWord); +begin + ASSERT(not IsLocked); + IsLocked := True; + + AData := Data; + AStride := Stride; +end; + +procedure TX11Image.Unlock; +begin + ASSERT(IsLocked); + IsLocked := False; +end; + + +{ TX11Screen } + +constructor TX11Screen.Create; +begin + inherited Create; + +// FScreenIndex := AScreenIndex; +// FScreenInfo := XScreenOfDisplay(gApplication.Handle, ScreenIndex); +end; + + +{ TX11Application } + +constructor TX11Application.Create; +begin + inherited Create; + + FDirtyList := TDirtyList.Create; +end; + + +destructor TX11Application.Destroy; +var + i: Integer; + WindowListEntry: PXWindowListEntry; +begin + if Assigned(Forms) then + begin + for i := 0 to Forms.Count - 1 do + begin + WindowListEntry := PXWindowListEntry(Forms[i]); + WindowListEntry^.GfxWindow.Free; + Dispose(WindowListEntry); + end; + end; + + DirtyList.Free; + + if Assigned(FDefaultFont) then + begin + if FDefaultFont^.fid <> 0 then + XUnloadFont(Handle, FDefaultFont^.fid); + XFreeFontInfo(nil, FDefaultFont, 0); + end; + + if Assigned(Handle) then + XCloseDisplay(Handle); + + inherited Destroy; +end; + +procedure TX11Application.AddWindow(AWindow: TFCustomWindow); +var + WindowListEntry: PXWindowListEntry; +begin + New(WindowListEntry); + WindowListEntry^.GfxWindow := AWindow; + WindowListEntry^.XWindowID := AWindow.Handle; + Forms.Add(WindowListEntry); +end; + +procedure TX11Application.Run; +var + Event: TXEvent; + WindowListEntry: PXWindowListEntry; +begin + DoBreakRun := False; + + while (not (QuitWhenLastWindowCloses and (Forms.Count = 0))) and + (DoBreakRun = False) do + begin + if Assigned(OnIdle) or Assigned(DirtyList.First) then + begin + if not XCheckMaskEvent(Handle, MaxInt, @Event) then + begin + if Assigned(DirtyList.First) then DirtyList.PaintAll + else if Assigned(OnIdle) then OnIdle(Self); + + continue; + end; + end + else + XNextEvent(Handle, @Event); + + // if the event filter returns true then it ate the message + if Assigned(FEventFilter) and FEventFilter(Event) then continue; + + if Forms.Count = 0 then continue; + + // According to a comment in X.h, the valid event types start with 2! + if Event._type >= 2 then + begin + WindowListEntry := FindWindowByXID(Event.XAny.Window); + + if Event._type = X.DestroyNotify then + begin + Forms.Remove(WindowListEntry); + Dispose(WindowListEntry); + end + else if Assigned(WindowListEntry) then + begin + if Assigned(WindowListEntry^.GfxWindow) then + WindowListEntry^.GfxWindow.Dispatch(Event); + end + else + WriteLn('fpGFX/X11: Received X event "', GetXEventName(Event._type), + '" for unknown window'); + end; + end; + DoBreakRun := False; +end; + + +procedure TX11Application.Quit; +begin + DoBreakRun := True; +end; + + +function TX11Application.FindWindowByXID(XWindowID: X.TWindow): PXWindowListEntry; +var + i: Integer; +begin + for i := 0 to Forms.Count - 1 do + begin + Result := PXWindowListEntry(Forms[i]); + if Result^.XWindowID = XWindowID then + exit; + end; + Result := nil; +end; + +procedure TX11Application.Initialize(ADisplayName: String = ''); +begin + if Length(ADisplayName) = 0 then FDisplayName := XDisplayName(nil) + else FDisplayName := ADisplayName; + + Handle := XOpenDisplay(PChar(DisplayName)); + + if not Assigned(Handle) then + raise EX11Error.CreateFmt(SOpenDisplayFailed, [DisplayName]); + + FDefaultFont := XLoadQueryFont(Handle, + '-adobe-helvetica-medium-r-normal--*-120-*-*-*-*-iso8859-1'); + + if not Assigned(FDefaultFont) then + begin + FDefaultFont := XLoadQueryFont(Handle, 'fixed'); + if not Assigned(FDefaultFont) then + raise EX11Error.Create(SNoDefaultFont); + end; +end; + +{ TX11Window } + +{ Note, this only creates a window, it doesn't actually show the window. It + is still invisible. To make it visible, we need to call Show(). } +constructor TX11Window.Create(AParent: TFCustomWindow; + AWindowOptions: TGfxWindowOptions); +const + WindowHints: TXWMHints = ( + flags: InputHint or StateHint or WindowGroupHint; + input: True; + initial_state: NormalState; + icon_pixmap: 0; + icon_window: 0; + icon_x: 0; + icon_y: 0; + icon_mask: 0; + window_group: 0; + ); +var + Colormap: TColormap; + Attr: TXSetWindowAttributes; + SizeHints: TXSizeHints; + ClassHint: PXClassHint; + lParentHandle: X.TWindow; + mask: longword; +begin + inherited Create; + + WindowOptions := AWindowOptions; + FParent := AParent; + + + if (woX11SkipWMHints in WindowOptions) = False then + begin + if LeaderWindow = 0 then + begin + LeaderWindow := XCreateSimpleWindow(gApplication.Handle, + XDefaultRootWindow(gApplication.Handle), 10, 10, 10, 10, 0, 0, 0); + + ClassHint := XAllocClassHint; + ClassHint^.res_name := 'fpGFX'; // !!! use app name + ClassHint^.res_class := 'FpGFX'; + XSetWMProperties(gApplication.Handle, LeaderWindow, nil, nil, nil, 0, nil, nil, + ClassHint); + XFree(ClassHint); + ClientLeaderAtom := XInternAtom(gApplication.Handle, 'WM_CLIENT_LEADER', False); + end; + end; + + Colormap := XDefaultColormap(gApplication.Handle, XDefaultScreen(gApplication.Handle)); + Attr.Colormap := Colormap; + + SizeHints.flags := XUtil.PSize; + SizeHints.x := 0; + SizeHints.y := 0; + SizeHints.width := 200; + SizeHints.height := 200; + + { Make sure we use the correct parent handle } + if FParent <> nil then + lParentHandle := TX11Window(FParent).Handle + else + lParentHandle := XDefaultRootWindow(gApplication.Handle); + + { setup attributes and masks } + if (woBorderless in WindowOptions) or (woToolWindow in WindowOptions) or + (woPopup in WindowOptions) then + begin + Attr.Override_Redirect := longbool(1); // this removes window borders + mask := CWOverrideRedirect or CWColormap; + end + else + begin + Attr.Override_Redirect := longbool(0); + mask := CWColormap; + end; + + FHandle := CreateXWindow( + lParentHandle, // parent + SizeHints.x, SizeHints.x, // position (top, left) + SizeHints.width, SizeHints.height, // default size + XDefaultVisual(gApplication.Handle, XDefaultScreen(gApplication.Handle)), // visual + mask, + Attr); + + if FHandle = 0 then + raise EX11Error.Create(SWindowCreationFailed); + + XSelectInput(gApplication.Handle, FHandle, KeyPressMask or KeyReleaseMask + or ButtonPressMask or ButtonReleaseMask or EnterWindowMask + or LeaveWindowMask or PointerMotionMask or ExposureMask or FocusChangeMask + or StructureNotifyMask); + + if (woX11SkipWMHints in WindowOptions) = False then + begin + XSetStandardProperties(gApplication.Handle, Handle, nil, nil, 0, + argv, argc, @SizeHints); + + XSetWMNormalHints(gApplication.Handle, Handle, @SizeHints); + + WindowHints.flags := WindowGroupHint; + WindowHints.window_group := LeaderWindow; + XSetWMHints(gApplication.Handle, Handle, @WindowHints); + + XChangeProperty(gApplication.Handle, Handle, ClientLeaderAtom, 33, 32, + PropModeReplace, @LeaderWindow, 1); + + // We want to get a Client Message when the user tries to close this window + if gApplication.FWMProtocols = 0 then + gApplication.FWMProtocols := XInternAtom(gApplication.Handle, 'WM_PROTOCOLS', False); + if gApplication.FWMDeleteWindow = 0 then + gApplication.FWMDeleteWindow := XInternAtom(gApplication.Handle, 'WM_DELETE_WINDOW', False); + + // send close event instead of quitting the whole application... + XSetWMProtocols(gApplication.Handle, FHandle, @gApplication.FWMDeleteWindow, 1); + end; + + FCanvas := TX11WindowCanvas.Create(Colormap, Handle, gApplication.FDefaultFont); +end; + + +destructor TX11Window.Destroy; +begin + if Assigned(OnClose) then + OnClose(Self); + + gApplication.DirtyList.ClearQueueForWindow(Self); + + XDestroyWindow(gApplication.Handle, Handle); + Canvas.Free; + + gApplication.FindWindowByXID(Handle)^.GfxWindow := nil; + + if FCurCursorHandle <> 0 then + XFreeCursor(gApplication.Handle, FCurCursorHandle); + + inherited Destroy; +end; + + +procedure TX11Window.DefaultHandler(var Message); +begin + WriteLn('fpGFX/X11: Unhandled X11 event received: ', + GetXEventName(TXEvent(Message)._type)); +end; + + +procedure TX11Window.SetPosition(const APosition: TPoint); +var + Supplied: PtrInt; + SizeHints: PXSizeHints; +begin + SizeHints := XAllocSizeHints; + XGetWMNormalHints(gApplication.Handle, Handle, SizeHints, @Supplied); + SizeHints^.flags := SizeHints^.flags or PPosition; + SizeHints^.x := APosition.x; + SizeHints^.y := APosition.y; + XSetWMNormalHints(gApplication.Handle, Handle, SizeHints); + XFree(SizeHints); + XMoveWindow(gApplication.Handle, Handle, APosition.x, APosition.y); +end; + + +procedure TX11Window.SetSize(const ASize: TSize); +begin + // !!!: Implement this properly + WriteLn('fpGFX/X11: TXWindow.SetSize is not properly implemented yet'); + SetClientSize(ASize); +end; + + +procedure TX11Window.SetMinMaxSize(const AMinSize, AMaxSize: TSize); +begin + // !!!: Implement this properly + WriteLn('fpGFX/X11: TXWindow.SetMinMaxSize is not properly implemented yet'); + SetMinMaxClientSize(AMinSize, AMaxSize); +end; + + +procedure TX11Window.SetClientSize(const ASize: TSize); +var + ChangeMask: Cardinal; + Changes: TXWindowChanges; +begin + ChangeMask := 0; + + if ASize.cx <> ClientWidth then + begin + ChangeMask := CWWidth; + Changes.Width := ASize.cx; + end; + + if ASize.cy <> ClientHeight then + begin + ChangeMask := ChangeMask or CWHeight; + Changes.Height := ASize.cy; + end; + + if ChangeMask <> 0 then + XConfigureWindow(gApplication.Handle, Handle, ChangeMask, @Changes); +end; + + +procedure TX11Window.SetMinMaxClientSize(const AMinSize, AMaxSize: TSize); +var + Supplied: PtrInt; + SizeHints: PXSizeHints; +begin + CanMaximize := (AMaxSize.cx = 0) or (AMaxSize.cy = 0) or + (AMaxSize.cx > AMinSize.cx) or (AMaxSize.cy > AMinSize.cy); + UpdateMotifWMHints; + + SizeHints := XAllocSizeHints; + XGetWMNormalHints(gApplication.Handle, Handle, SizeHints, @Supplied); + with SizeHints^ do + begin + if (AMinSize.cx > 0) or (AMinSize.cy > 0) then + begin + flags := flags or PMinSize; + min_width := AMinSize.cx; + min_height := AMinSize.cy; + end else + flags := flags and not PMinSize; + + if (AMaxSize.cx > 0) or (AMaxSize.cy > 0) then + begin + flags := flags or PMaxSize; + if AMaxSize.cx > 0 then + max_width := AMaxSize.cx + else + max_width := 32767; + if AMaxSize.cy > 0 then + max_height := AMaxSize.cy + else + max_height := 32767; + end else + flags := flags and not PMaxSize; + end; + + XSetWMNormalHints(gApplication.Handle, Handle, SizeHints); + XFree(SizeHints); +end; + + +{ Makes the window visible and raises it to the top of the stack. } +procedure TX11Window.Show; +begin + XMapRaised(gApplication.Handle, Handle); +end; + + +procedure TX11Window.Invalidate(const ARect: TRect); +begin + gApplication.DirtyList.AddRect(Self, ARect); +end; + + +procedure TX11Window.PaintInvalidRegion; +begin + gApplication.DirtyList.PaintQueueForWindow(Self); +end; + + +procedure TX11Window.CaptureMouse; +begin + XGrabPointer(gApplication.Handle, Handle, False, ButtonPressMask or + ButtonReleaseMask or EnterWindowMask or LeaveWindowMask or + PointerMotionMask, GrabModeAsync, GrabModeAsync, 0, 0, CurrentTime); +end; + + +procedure TX11Window.ReleaseMouse; +begin + XUngrabPointer(gApplication.Handle, CurrentTime); +end; + + +// protected methods + +function TX11Window.GetTitle: String; +var + s: PChar; +begin + XFetchName(gApplication.Handle, Handle, @s); + Result := s; + XFree(s); +end; + + +procedure TX11Window.SetTitle(const ATitle: String); +begin + XStoreName(gApplication.Handle, Handle, PChar(ATitle)); +end; + + +procedure TX11Window.DoSetCursor; +const + CursorTable: array[TGfxCursor] of Integer = ( + -1, // crDefault + -2, // crNone !!!: not implemented + -1, // crArrow + 34, // crCross + 152, // crIBeam + 52, // crSize + 116, // crSizeNS + 108, // crSizeWE + 114, // crUpArrow + 150, // crHourGlass + 0, // crNoDrop + 92); // crHelp +var + ID: Integer; +begin + if FCurCursorHandle <> 0 then + XFreeCursor(gApplication.Handle, FCurCursorHandle); + ID := CursorTable[Cursor]; + if ID = -1 then + FCurCursorHandle := 0 + else + FCurCursorHandle := XCreateFontCursor(gApplication.Handle, ID); + XDefineCursor(gApplication.Handle, Handle, FCurCursorHandle); +end; + + +function TX11Window.ConvertShiftState(AState: Cardinal): TShiftState; +begin + Result := []; + if (AState and Button1Mask) <> 0 then + Include(Result, ssLeft); + if (AState and Button2Mask) <> 0 then + Include(Result, ssMiddle); + if (AState and Button3Mask) <> 0 then + Include(Result, ssRight); + if (AState and ShiftMask) <> 0 then + Include(Result, ssShift); + if (AState and LockMask) <> 0 then + Include(Result, ssCaps); + if (AState and ControlMask) <> 0 then + Include(Result, ssCtrl); + if (AState and Mod1Mask) <> 0 then + Include(Result, ssAlt); + if (AState and Mod2Mask) <> 0 then + Include(Result, ssNum); + if (AState and Mod4Mask) <> 0 then + Include(Result, ssSuper); + if (AState and Mod5Mask) <> 0 then + Include(Result, ssScroll); + if (AState and (1 shl 13)) <> 0 then + Include(Result, ssAltGr); +end; + +function TX11Window.KeySymToKeycode(KeySym: TKeySym): Word; +const + Table_20aX: array[$20a0..$20ac] of Word = (keyEcuSign, keyColonSign, + keyCruzeiroSign, keyFFrancSign, keyLiraSign, keyMillSign, keyNairaSign, + keyPesetaSign, keyRupeeSign, keyWonSign, keyNewSheqelSign, keyDongSign, + keyEuroSign); + Table_feXX: array[$fe50..$fe60] of Word = (keyDeadGrave, keyDeadAcute, + keyDeadCircumflex, keyDeadTilde, keyDeadMacron,keyDeadBreve, + keyDeadAbovedot, keyDeadDiaeresis, keyDeadRing, keyDeadDoubleacute, + keyDeadCaron, keyDeadCedilla, keyDeadOgonek, keyDeadIota, + keyDeadVoicedSound, keyDeadSemivoicedSound, keyDeadBelowdot); + Table_ff5X: array[$ff50..$ff58] of Word = (keyHome, keyLeft, keyUp, keyRight, + keyDown, keyPrior, keyNext, keyEnd, keyBegin); + Table_ff6X: array[$ff60..$ff6b] of Word = (keySelect, keyPrintScreen, + keyExecute, keyNIL, keyInsert, keyUndo, keyRedo, keyMenu, keyFind, + keyCancel, keyHelp, keyBreak); + Table_ff9X: array[$ff91..$ff9f] of Word = (keyPF1, keyPF2, keyPF3, keyPF4, + keyP7, keyP4, keyP8, keyP6, keyP2, keyP9, keyP3, keyP1, keyP5, keyP0, + keyPDecimal); + Table_ffeX: array[$ffe1..$ffee] of Word = (keyShiftL, keyShiftR, keyCtrlL, + keyCtrlR, keyCapsLock, keyShiftLock, keyMetaL, keyMetaR, keyAltL, keyAltR, + keySuperL, keySuperR, keyHyperL, keyHyperR); +begin + case KeySym of + 0..Ord('a')-1, Ord('z')+1..$bf, $f7: + Result := KeySym; + Ord('a')..Ord('z'), $c0..$f6, $f8..$ff: + Result := KeySym - 32; + $20a0..$20ac: Result := Table_20aX[KeySym]; + $fe20: Result := keyTab; + $fe50..$fe60: Result := Table_feXX[KeySym]; + $ff08: Result := keyBackspace; + $ff09: Result := keyTab; + $ff0a: Result := keyLinefeed; + $ff0b: Result := keyClear; + $ff0d: Result := keyReturn; + $ff13: Result := keyPause; + $ff14: Result := keyScrollLock; + $ff15: Result := keySysRq; + $ff1b: Result := keyEscape; + $ff50..$ff58: Result := Table_ff5X[KeySym]; + $ff60..$ff6b: Result := Table_ff6X[KeySym]; + $ff7e: Result := keyModeSwitch; + $ff7f: Result := keyNumLock; + $ff80: Result := keyPSpace; + $ff89: Result := keyPTab; + $ff8d: Result := keyPEnter; + $ff91..$ff9f: Result := Table_ff9X[KeySym]; + $ffaa: Result := keyPAsterisk; + $ffab: Result := keyPPlus; + $ffac: Result := keyPSeparator; + $ffad: Result := keyPMinus; + $ffae: Result := keyPDecimal; + $ffaf: Result := keyPSlash; + $ffb0..$ffb9: Result := keyP0 + KeySym - $ffb0; + $ffbd: Result := keyPEqual; + $ffbe..$ffe0: Result := keyF1 + KeySym - $ffbe; + $ffe1..$ffee: Result := Table_ffeX[KeySym]; + $ffff: Result := keyDelete; + else + Result := keyNIL; + end; +{$IFDEF Debug} + if Result = keyNIL then + WriteLn('fpGFX/X11: Unknown KeySym: $', IntToHex(KeySym, 4)); +{$ENDIF} +end; + + +procedure TX11Window.UpdateMotifWMHints; +type + PMotifWmHints = ^TMotifWmHints; + TMotifWmHints = packed record + Flags, Functions, Decorations: LongWord; + InputMode: LongInt; + Status: LongWord; + end; +const + MWM_HINTS_FUNCTIONS = 1; + MWM_HINTS_DECORATIONS = 2; + FuncAll = 1; + FuncResize = 2; + FuncMove = 4; + FuncMinimize = 8; + FuncMaximize = 16; + FuncClose = 32; + DecorAll = 1; + DecorBorder = 2; + DecorResizeH = 4; + DecorTitle = 8; + DecorMenu = 16; + DecorMinimize = 32; + DecorMaximize = 64; +var + PropType: TAtom; + PropFormat: LongInt; + PropItemCount, PropBytesAfter: LongWord; + Hints: PMotifWmHints; + NewHints: TMotifWmHints; +begin + if gApplication.FWMHints = 0 then + gApplication.FWMHints := + XInternAtom(gApplication.Handle, '_MOTIF_WM_HINTS', False); + + XGetWindowProperty(gApplication.Handle, Handle, + gApplication.FWMHints, 0, 5, False, AnyPropertyType, @PropType, + @PropFormat, @PropItemCount, @PropBytesAfter, @Hints); + + NewHints.Flags := MWM_HINTS_FUNCTIONS or MWM_HINTS_DECORATIONS; + NewHints.Functions := FuncResize or FuncMove or FuncMinimize or FuncClose; + + if (woToolWindow in WindowOptions) or (woWindow in WindowOptions) or + (woPopup in WindowOptions) then + NewHints.Decorations := DecorBorder or DecorTitle or DecorMenu or DecorMinimize + else + NewHints.Decorations := 0; + if CanMaximize then + begin + NewHints.Functions := NewHints.Functions or FuncMaximize; + NewHints.Decorations := NewHints.Decorations or DecorMaximize; + end; + + if Assigned(Hints) then + begin + Hints^.Flags := Hints^.Flags or NewHints.Flags; + Hints^.Decorations := NewHints.Decorations; + Hints^.Functions := NewHints.Functions; + end else + Hints := @NewHints; + + XChangeProperty(gApplication.Handle, Handle, + gApplication.FWMHints, gApplication.FWMHints, + 32, PropModeReplace, Pointer(Hints), 5); + if Hints <> @NewHints then + XFree(Hints); +end; + + +// private methods + +const + ButtonTable: array[1..3] of TMouseButton = (mbLeft, mbMiddle, mbRight); + + +function TX11Window.StartComposing(const Event: TXKeyEvent): TKeySym; +begin + SetLength(FComposeBuffer, + XLookupString(@Event, @FComposeBuffer[1], + SizeOf(FComposeBuffer) - 1, @Result, @FComposeStatus)); +end; + + +procedure TX11Window.EndComposing; +var + i: Integer; +begin + if Assigned(OnKeyChar) then + for i := 1 to Length(FComposeBuffer) do + OnKeyChar(Self, FComposeBuffer[i]); +end; + + +procedure TX11Window.KeyPressed(var Event: TXKeyPressedEvent); +var + KeySym: TKeySym; +begin + KeySym := StartComposing(Event); + if Assigned(OnKeyPressed) then + OnKeyPressed(Self, KeySymToKeycode(KeySym), ConvertShiftState(Event.State)); + + if (Event.State and (ControlMask or Mod1Mask)) = 0 then + EndComposing; +end; + + +procedure TX11Window.KeyReleased(var Event: TXKeyReleasedEvent); +var + KeySym: TKeySym; +begin + KeySym := StartComposing(Event); + if Assigned(OnKeyReleased) then + OnKeyReleased(Self, KeySymToKeycode(KeySym), + ConvertShiftState(Event.State)); + // Do not call EndComposing, as this would generate duplicate KeyChar events! +end; + + +procedure TX11Window.ButtonPressed(var Event: TXButtonPressedEvent); +var + Sum: Integer; + NewEvent: TXEvent; +begin + case Event.Button of + Button1..Button3: + if Assigned(OnMousePressed) then + OnMousePressed(Self, ButtonTable[Event.Button], + ConvertShiftState(Event.State), Point(Event.x, Event.y)); + Button4, Button5: // Mouse wheel message + begin + if Event.Button = Button4 then + Sum := -1 + else + Sum := 1; + + // Check for other mouse wheel messages in the queue + while XCheckTypedWindowEvent(gApplication.Handle, Handle, + X.ButtonPress, @NewEvent) do + begin + if NewEvent.xbutton.Button = 4 then + Dec(Sum) + else if NewEvent.xbutton.Button = 5 then + Inc(Sum) + else + begin + XPutBackEvent(gApplication.Handle, @NewEvent); + break; + end; + end; + + if Assigned(OnMouseWheel) then + OnMouseWheel(Self, ConvertShiftState(Event.State), + Sum, Point(Event.x, Event.y)); + end; + end; +end; + + +procedure TX11Window.ButtonReleased(var Event: TXButtonReleasedEvent); +begin + if (Event.Button >= 1) and (Event.Button <= 3) and + Assigned(OnMouseReleased) then + OnMouseReleased(Self, ButtonTable[Event.Button], + ConvertShiftState(Event.State), Point(Event.x, Event.y)); +end; + + +procedure TX11Window.EnterWindow(var Event: TXEnterWindowEvent); +begin + if Assigned(OnMouseEnter) then + OnMouseEnter(Self, ConvertShiftState(Event.State), Point(Event.x, Event.y)); +end; + + +procedure TX11Window.LeaveWindow(var Event: TXLeaveWindowEvent); +begin + if Assigned(OnMouseEnter) then + OnMouseLeave(Self); +end; + + +procedure TX11Window.PointerMoved(var Event: TXPointerMovedEvent); +begin + if Assigned(OnMouseMove) then + OnMouseMove(Self, ConvertShiftState(Event.State), Point(Event.x, Event.y)); +end; + + +procedure TX11Window.Expose(var Event: TXExposeEvent); +{var + IsNotEmpty: Boolean; +begin +WriteLn('Expose'); + if Assigned(OnPaint) then + with Event do + begin + if not IsExposing then + begin + IsExposing := True; + Canvas.SaveState; + Canvas.EmptyClipRect; + end; + IsNotEmpty := Canvas.UnionClipRect(Rect(x, y, x + Width, y + Height)); + if Count = 0 then + begin + if IsNotEmpty then + OnPaint(Self, Canvas.GetClipRect); + IsExposing := False; + Canvas.RestoreState; + end; + end; +end;} +var + r: TRect; +begin + with Event do + r := Rect(x, y, x + Width, y + Height); + gApplication.DirtyList.AddRect(Self, r); +end; + + +procedure TX11Window.FocusIn(var Event: TXFocusInEvent); +begin + if Assigned(OnFocusIn) then + OnFocusIn(Self); +end; + + +procedure TX11Window.FocusOut(var Event: TXFocusOutEvent); +begin + if Assigned(OnFocusOut) then + OnFocusOut(Self); +end; + + +procedure TX11Window.Map(var Event: TXMapEvent); +begin + if Assigned(OnShow) then + OnShow(Self); +end; + + +procedure TX11Window.Unmap(var Event: TXUnmapEvent); +begin + if Assigned(OnHide) then + OnHide(Self); +end; + + +procedure TX11Window.Reparent(var Event: TXReparentEvent); +begin + if Assigned(OnCreate) then + OnCreate(Self); +end; + + +procedure TX11Window.Configure(var Event: TXConfigureEvent); +begin + while XCheckTypedWindowEvent(gApplication.Handle, Handle, + X.ConfigureNotify, @Event) do; + + if (Event.x <> Left) or (Event.y <> Top) then + begin + FLeft := Event.x; + FTop := Event.y; + if Assigned(OnMove) then + OnMove(Self); + end; + if (Event.Width <> Width) or (Event.Height <> Height) then + begin + // !!!: The following 2 lines are _quite_ wrong... :) + FWidth := Event.Width; + FHeight := Event.Height; + FClientWidth := Event.Width; + FClientHeight := Event.Height; + TX11Canvas(Canvas).Resized(ClientWidth, ClientHeight); + if Assigned(OnResize) then + OnResize(Self); + end; +end; + + +procedure TX11Window.ClientMessage(var Event: TXClientMessageEvent); +begin + if Event.message_type = gApplication.FWMProtocols then + if Event.Data.l[0] = gApplication.FWMDeleteWindow then + begin + if CanClose then + Free; + end else + WriteLn('fpGFX/X11: Unknown client protocol message: ', Event.Data.l[0]) + else + WriteLn('fpGFX/X11: Unknown client message: ', Event.message_type); +end; + +function TX11Window.CreateXWindow(AParent: X.TWindow; ALeft, ATop: longint; AWidth, AHeight: longword; + AVisual: PVisual; AValueMask: LongWord; const AAttr: TXSetWindowAttributes): X.TWindow; +begin + Result := XCreateWindow( + gApplication.Handle, + AParent, // parent + ALeft, ATop, // position (top, left) + AWidth, AHeight, // size (width, height) + 0, // border size + CopyFromParent, // depth + InputOutput, // class + AVisual, // visual + AValueMask, + @AAttr); +end; + + +{ Global utility functions } + +function RectToXRect(const ARect: TRect): TXRectangle; +begin + Result.x := ARect.Left; + Result.y := ARect.Top; + Result.width := ARect.Right - ARect.Left; + Result.height := ARect.Bottom - ARect.Top; +end; + + +function XRectToRect(const ARect: TXRectangle): TRect; +begin + Result.Left := ARect.x; + Result.Top := ARect.y; + Result.Right := ARect.x + ARect.width; + Result.Bottom := ARect.y + ARect.height; +end; + + +function GetXEventName(Event: LongInt): String; +const + EventNames: array[2..34] of String = ( + 'KeyPress', 'KeyRelease', 'ButtonPress', 'ButtonRelease', 'MotionNotify', + 'EnterNotify', 'LeaveNotify', 'FocusIn', 'FocusOut', 'KeymapNotify', + 'Expose', 'GraphicsExpose', 'NoExpose', 'VisibilityNotify', 'CreateNotify', + 'DestroyNotify', 'UnmapNotify', 'MapNotify', 'MapRequest', 'ReparentNotify', + 'ConfigureNotify', 'ConfigureRequest', 'GravityNotify', 'ResizeRequest', + 'CirculateNotify', 'CirculateRequest', 'PropertyNotify', 'SelectionClear', + 'SelectionRequest', 'SelectionNotify', 'ColormapNotify', 'ClientMessage', + 'MappingNotify'); +begin + if (Event >= Low(EventNames)) and (Event <= High(EventNames)) then + Result := EventNames[Event] + else + Result := '#' + IntToStr(Event); +end; + +end. + + |