freepascal.compiler/packages/extra/ptc/x11/x11windowdisplayi.inc

Constructor TX11WindowDisplay.Create(ADisplay : PDisplay; AScreen : Integer; Const AFlags : TX11Flags);

Begin
  Inherited;
  FFocus := True;
  FX11InvisibleCursor := None;
  FCursorVisible := True;
End;

Destructor TX11WindowDisplay.Destroy;

Begin
  Close;
  Inherited Destroy;
End;

Procedure TX11WindowDisplay.Open(ATitle : AnsiString; AWidth, AHeight : Integer; Const AFormat : TPTCFormat);

Var
  tmpFormat : TPTCFormat;
  xgcv : TXGCValues;
  textprop : TXTextProperty;
  e : TXEvent;
  found : Boolean;
  attr : TXSetWindowAttributes;
  size_hints : PXSizeHints;
  tmpArea : TPTCArea;
  tmppchar : PChar;
  tmpArrayOfCLong : Array[1..1] Of clong;
  tmpPixmap : TPixmap;
  BlackColor : TXColor;
  BlankCursorData : Array[1..8] Of Byte = (0, 0, 0, 0, 0, 0, 0, 0);

Begin
  FHeight := AHeight;
  FWidth := AWidth;
  FDestX := 0;
  FDestY := 0;

  FFullScreen := PTC_X11_FULLSCREEN In FFlags;

  FFocus := True;

  FPreviousMousePositionSaved := False;

  FillChar(BlackColor, SizeOf(BlackColor), 0);
  BlackColor.red := 0;
  BlackColor.green := 0;
  BlackColor.blue := 0;

  { Create the mode switcher object }
  If (FModeSwitcher = Nil) And FFullScreen Then
    FModeSwitcher := CreateModeSwitcher;

  { Create the invisible cursor }
  tmpPixmap := XCreateBitmapFromData(FDisplay, RootWindow(FDisplay, FScreen), @BlankCursorData, 8, 8);
  Try
    FX11InvisibleCursor := XCreatePixmapCursor(FDisplay, tmpPixmap, tmpPixmap, @BlackColor, @BlackColor, 0, 0);
  Finally
    If tmpPixmap <> None Then
      XFreePixmap(FDisplay, tmpPixmap);
  End;

  { Check if we have that colour depth available.. Easy as there is no
    format conversion yet }
  tmpFormat := Nil;
  Try
    tmpFormat := GetX11Format(AFormat);
    FFormat.Assign(tmpFormat);
  Finally
    tmpFormat.Free;
  End;
  tmpFormat := Nil;

  { Create a window }
  FWindow := XCreateSimpleWindow(FDisplay, RootWindow(FDisplay, FScreen), 0, 0,
                AWidth, AHeight, 0, BlackPixel(FDisplay, FScreen),
                                    BlackPixel(FDisplay, FScreen));
  { Register the delete atom }
  FAtomClose := XInternAtom(FDisplay, 'WM_DELETE_WINDOW', False);
  X11Check(XSetWMProtocols(FDisplay, FWindow, @FAtomClose, 1), 'XSetWMProtocols');
  { Get graphics context }
  xgcv.graphics_exposures := False;
  FGC := XCreateGC(FDisplay, FWindow, GCGraphicsExposures, @xgcv);
  If FGC = Nil Then
    Raise TPTCError.Create('can''t create graphics context');
  { Set window title }
  tmppchar := PChar(ATitle);
  X11Check(XStringListToTextProperty(@tmppchar, 1, @textprop), 'XStringListToTextProperty');
  Try
    XSetWMName(FDisplay, FWindow, @textprop);
    XFlush(FDisplay);
  Finally
    XFree(textprop.value);
  End;

  { Set normal hints }
  size_hints := XAllocSizeHints;
  Try
    size_hints^.flags := PMinSize Or PBaseSize;
    size_hints^.min_width := AWidth;
    size_hints^.min_height := AHeight;
    size_hints^.base_width := AWidth;
    size_hints^.base_height := AHeight;
    If FFullScreen Then
    Begin
      size_hints^.flags := size_hints^.flags Or PWinGravity;
      size_hints^.win_gravity := StaticGravity;
    End
    Else
    Begin
      { not fullscreen - add maxsize limit=minsize, i.e. make window not resizable }
      size_hints^.flags := size_hints^.flags Or PMaxSize;
      size_hints^.max_width := AWidth;
      size_hints^.max_height := AHeight;
    End;
    XSetWMNormalHints(FDisplay, FWindow, size_hints);
    XFlush(FDisplay);
  Finally
    XFree(size_hints);
  End;

  { Set the _NET_WM_STATE property }
  If FFullScreen Then
  Begin
    tmpArrayOfCLong[1] := XInternAtom(FDisplay, '_NET_WM_STATE_FULLSCREEN', False);

    XChangeProperty(FDisplay, FWindow,
                    XInternAtom(FDisplay, '_NET_WM_STATE', False),
                    XA_ATOM,
                    32, PropModeReplace, @tmpArrayOfCLong, 1);
  End;

  { Map the window and wait for success }
  XSelectInput(FDisplay, FWindow, StructureNotifyMask);
  XMapRaised(FDisplay, FWindow);
  Repeat
    XNextEvent(FDisplay, @e);
    If e._type = MapNotify Then
      Break;
  Until False;
  { Get keyboard input and sync }
  XSelectInput(FDisplay, FWindow, KeyPressMask Or KeyReleaseMask Or
                                  StructureNotifyMask Or FocusChangeMask Or
                                  ButtonPressMask Or ButtonReleaseMask Or
                                  PointerMotionMask);
  XSync(FDisplay, False);
  { Create XImage using factory method }
  FPrimary := CreateImage(FDisplay, FScreen, FWidth, FHeight, FFormat);

  found := False;
  Repeat
    { Stupid loop. The key }
    { events were causing }
    { problems.. }
    found := XCheckMaskEvent(FDisplay, KeyPressMask Or KeyReleaseMask, @e);
  Until Not found;

  attr.backing_store := Always;
  XChangeWindowAttributes(FDisplay, FWindow, CWBackingStore, @attr);

  { Set clipping area }
  tmpArea := TPTCArea.Create(0, 0, FWidth, FHeight);
  Try
    FClip.Assign(tmpArea);
  Finally
    tmpArea.Free;
  End;

  { Installs the right colour map for 8 bit modes }
  CreateColormap;

  If FFullScreen Then
    EnterFullScreen;
End;

Procedure TX11WindowDisplay.Open(AWindow : TWindow; Const AFormat : TPTCFormat);

Begin
End;

Procedure TX11WindowDisplay.Open(AWindow : TWindow; Const AFormat : TPTCFormat; AX, AY, AWidth, AHeight : Integer);

Begin
End;

Procedure TX11WindowDisplay.Close;

Begin
  FreeAndNil(FModeSwitcher);

  {pthreads?!}
  If FCMap <> 0 Then
  Begin
    XFreeColormap(FDisplay, FCMap);
    FCMap := 0;
  End;

  { Destroy XImage and buffer }
  FreeAndNil(FPrimary);
  FreeMemAndNil(FColours);

  { Hide and destroy window }
  If (FWindow <> 0) And (Not (PTC_X11_LEAVE_WINDOW In FFlags)) Then
  Begin
    XUnmapWindow(FDisplay, FWindow);
    XSync(FDisplay, False);

    XDestroyWindow(FDisplay, FWindow);
  End;

  { Free the invisible cursor }
  If FX11InvisibleCursor <> None Then
  Begin
    XFreeCursor(FDisplay, FX11InvisibleCursor);
    FX11InvisibleCursor := None;
  End;
End;

Procedure TX11WindowDisplay.internal_ShowCursor(AVisible : Boolean);

Var
  attr : TXSetWindowAttributes;

Begin
  If AVisible Then
    attr.cursor := None { Use the normal cursor }
  Else
    attr.cursor := FX11InvisibleCursor; { Set the invisible cursor }

  XChangeWindowAttributes(FDisplay, FWindow, CWCursor, @attr);
End;

Procedure TX11WindowDisplay.SetCursor(AVisible : Boolean);

Begin
  FCursorVisible := AVisible;

  If FFocus Then
    internal_ShowCursor(FCursorVisible);
End;

Procedure TX11WindowDisplay.EnterFullScreen;

Begin
  { Try to switch mode }
  If Assigned(FModeSwitcher) Then
    FModeSwitcher.SetBestMode(FWidth, FHeight);

  XSync(FDisplay, False);

  { Center the image }
  FDestX := FModeSwitcher.Width Div 2 - FWidth Div 2;
  FDestY := FModeSwitcher.Height Div 2 - FHeight Div 2;
End;

Procedure TX11WindowDisplay.LeaveFullScreen;

Begin
  { Restore previous mode }
  If Assigned(FModeSwitcher) Then
    FModeSwitcher.RestorePreviousMode;

  XSync(FDisplay, False);
End;

Procedure TX11WindowDisplay.HandleChangeFocus(ANewFocus : Boolean);

Begin
  { No change? }
  If ANewFocus = FFocus Then
    Exit;

  FFocus := ANewFocus;
  If FFocus Then
  Begin
    { focus in }
    If FFullScreen Then
      EnterFullScreen;

    internal_ShowCursor(FCursorVisible);
  End
  Else
  Begin
    { focus out }
    If FFullScreen Then
      LeaveFullScreen;

    internal_ShowCursor(True);
  End;

  XSync(FDisplay, False);
End;

Procedure TX11WindowDisplay.HandleEvents;

Var
  e : TXEvent;
  NewFocus : Boolean;
  NewFocusSpecified : Boolean;

  Function UsefulEventsPending : Boolean;

  Var
    tmpEvent : TXEvent;

  Begin
    If XCheckTypedEvent(FDisplay, ClientMessage, @tmpEvent) Then
    Begin
      Result := True;
      XPutBackEvent(FDisplay, @tmpEvent);
      Exit;
    End;

    If XCheckMaskEvent(FDisplay, FocusChangeMask Or
                       KeyPressMask Or KeyReleaseMask Or
                       ButtonPressMask Or ButtonReleaseMask Or
                       PointerMotionMask Or ExposureMask, @tmpEvent) Then
    Begin
      Result := True;
      XPutBackEvent(FDisplay, @tmpEvent);
      Exit;
    End;

    Result := False;
  End;

  Procedure HandleKeyEvent;

  Var
    sym : TKeySym;
    sym_modded : TKeySym; { modifiers like shift are taken into account here }
    press : Boolean;
    alt, shift, ctrl : Boolean;
    uni : Integer;
    key : TPTCKeyEvent;
    buf : Array[1..16] Of Char;

  Begin
    sym := XLookupKeySym(@e.xkey, 0);
    XLookupString(@e.xkey, @buf, SizeOf(buf), @sym_modded, Nil);
    uni := X11ConvertKeySymToUnicode(sym_modded);
    alt := (e.xkey.state And Mod1Mask) <> 0;
    shift := (e.xkey.state And ShiftMask) <> 0;
    ctrl := (e.xkey.state And ControlMask) <> 0;
    If e._type = KeyPress Then
      press := True
    Else
      press := False;

    key := Nil;
    Case sym Shr 8 Of
      0 : key := TPTCKeyEvent.Create(FNormalKeys[sym And $FF], uni, alt, shift, ctrl, press);
      $FF : key := TPTCKeyEvent.Create(FFunctionKeys[sym And $FF], uni, alt, shift, ctrl, press);
      Else
        key := TPTCKeyEvent.Create;
    End;
    FEventQueue.AddEvent(key);
  End;

  Procedure HandleMouseEvent;

  Var
    x, y : cint;
    state : cuint;
    PTCMouseButtonState : TPTCMouseButtonState;

    button : TPTCMouseButton;
    before, after : Boolean;
    cstate : TPTCMouseButtonState;

  Begin
    Case e._type Of
      MotionNotify : Begin
        x := e.xmotion.x;
        y := e.xmotion.y;
        state := e.xmotion.state;
      End;
      ButtonPress, ButtonRelease : Begin
        x := e.xbutton.x;
        y := e.xbutton.y;
        state := e.xbutton.state;
        If e._type = ButtonPress Then
        Begin
          Case e.xbutton.button Of
            Button1 : state := state Or Button1Mask;
            Button2 : state := state Or Button2Mask;
            Button3 : state := state Or Button3Mask;
            Button4 : state := state Or Button4Mask;
            Button5 : state := state Or Button5Mask;
          End;
        End
        Else
        Begin
          Case e.xbutton.button Of
            Button1 : state := state And (Not Button1Mask);
            Button2 : state := state And (Not Button2Mask);
            Button3 : state := state And (Not Button3Mask);
            Button4 : state := state And (Not Button4Mask);
            Button5 : state := state And (Not Button5Mask);
          End;
        End;
      End;
      Else
        Raise TPTCError.Create('Internal Error');
    End;

    If (state And Button1Mask) = 0 Then
      PTCMouseButtonState := []
    Else
      PTCMouseButtonState := [PTCMouseButton1];
    If (state And Button2Mask) <> 0 Then
      PTCMouseButtonState := PTCMouseButtonState + [PTCMouseButton2];
    If (state And Button3Mask) <> 0 Then
      PTCMouseButtonState := PTCMouseButtonState + [PTCMouseButton3];
    If (state And Button4Mask) <> 0 Then
      PTCMouseButtonState := PTCMouseButtonState + [PTCMouseButton4];
    If (state And Button5Mask) <> 0 Then
      PTCMouseButtonState := PTCMouseButtonState + [PTCMouseButton5];

    If (x >= 0) And (x < FWidth) And (y >= 0) And (y < FHeight) Then
    Begin
      If Not FPreviousMousePositionSaved Then
      Begin
        FPreviousMouseX := x; { first DeltaX will be 0 }
        FPreviousMouseY := y; { first DeltaY will be 0 }
        FPreviousMouseButtonState := [];
      End;

      { movement? }
      If (x <> FPreviousMouseX) Or (y <> FPreviousMouseY) Then
        FEventQueue.AddEvent(TPTCMouseEvent.Create(x, y, x - FPreviousMouseX, y - FPreviousMouseY, FPreviousMouseButtonState));

      { button presses/releases? }
      cstate := FPreviousMouseButtonState;
      For button := Low(button) To High(button) Do
      Begin
        before := button In FPreviousMouseButtonState;
        after := button In PTCMouseButtonState;
        If after And (Not before) Then
        Begin
          { button was pressed }
          cstate := cstate + [button];
          FEventQueue.AddEvent(TPTCMouseButtonEvent.Create(x, y, 0, 0, cstate, True, button));
        End
        Else
          If before And (Not after) Then
          Begin
            { button was released }
            cstate := cstate - [button];
            FEventQueue.AddEvent(TPTCMouseButtonEvent.Create(x, y, 0, 0, cstate, False, button));
          End;
      End;

      FPreviousMouseX := x;
      FPreviousMouseY := y;
      FPreviousMouseButtonState := PTCMouseButtonState;
      FPreviousMousePositionSaved := True;
    End;
  End;

Begin
  NewFocusSpecified := False;
  While UsefulEventsPending Do
  Begin
    XNextEvent(FDisplay, @e);
    Case e._type Of
      FocusIn : Begin
        NewFocus := True;
        NewFocusSpecified := True;
      End;
      FocusOut : Begin
        NewFocus := False;
        NewFocusSpecified := True;
      End;
      ClientMessage : Begin
        If (e.xclient.format = 32) And (TAtom(e.xclient.data.l[0]) = FAtomClose) Then
          Halt(0);
      End;
      Expose : Begin
        {...}
      End;
      KeyPress, KeyRelease : HandleKeyEvent;
      ButtonPress, ButtonRelease, MotionNotify : HandleMouseEvent;
    End;
  End;
  If NewFocusSpecified Then
    HandleChangeFocus(NewFocus);
End;

Procedure TX11WindowDisplay.Update;

Begin
  FPrimary.Put(FWindow, FGC, FDestX, FDestY);

  HandleEvents;
End;

Procedure TX11WindowDisplay.Update(Const AArea : TPTCArea);

Var
  updatearea : TPTCArea;
  tmparea : TPTCArea;

Begin
  tmparea := TPTCArea.Create(0, 0, FWidth, FHeight);
  Try
    updatearea := TPTCClipper.Clip(tmparea, AArea);
    Try
      FPrimary.Put(FWindow, FGC, updatearea.Left, updatearea.Top,
                   FDestX + updatearea.Left, FDestY + updatearea.Top,
                   updatearea.Width, updatearea.Height);
    Finally
      updatearea.Free;
    End;
  Finally
    tmparea.Free;
  End;

  HandleEvents;
End;

Function TX11WindowDisplay.NextEvent(Var AEvent : TPTCEvent; AWait : Boolean; Const AEventMask : TPTCEventMask) : Boolean;

Var
  tmpEvent : TXEvent;

Begin
  FreeAndNil(AEvent);
  Repeat
    { process all events from the X queue and put them on our FEventQueue }
    HandleEvents;

    { try to find an event that matches the EventMask }
    AEvent := FEventQueue.NextEvent(AEventMask);

    If AWait And (AEvent = Nil) Then
    Begin
      { if the X event queue is empty, block until an event is received }
      XPeekEvent(FDisplay, @tmpEvent);
    End;
  Until (Not AWait) Or (AEvent <> Nil);
  Result := AEvent <> Nil;
End;

Function TX11WindowDisplay.PeekEvent(AWait : Boolean; Const AEventMask : TPTCEventMask) : TPTCEvent;

Var
  tmpEvent : TXEvent;

Begin
  Repeat
    { process all events from the X queue and put them on our FEventQueue }
    HandleEvents;

    { try to find an event that matches the EventMask }
    Result := FEventQueue.PeekEvent(AEventMask);

    If AWait And (Result = Nil) Then
    Begin
      { if the X event queue is empty, block until an event is received }
      XPeekEvent(FDisplay, @tmpEvent);
    End;
  Until (Not AWait) Or (Result <> Nil);
End;

Function TX11WindowDisplay.Lock : Pointer;

Begin
  Result := FPrimary.Lock;
End;

Procedure TX11WindowDisplay.unlock;

Begin
End;

Procedure TX11WindowDisplay.GetModes(Var AModes : TPTCModeDynArray);

Var
  current_desktop_format, tmpfmt : TPTCFormat;

Begin
  If FModeSwitcher = Nil Then
    FModeSwitcher := CreateModeSwitcher;

  current_desktop_format := Nil;
  tmpfmt := TPTCFormat.Create(8);
  Try
    current_desktop_format := GetX11Format(tmpfmt);

    FModeSwitcher.GetModes(AModes, current_desktop_format);
  Finally
    tmpfmt.Free;
    current_desktop_format.Free;
  End;
End;

Procedure TX11WindowDisplay.Palette(Const APalette : TPTCPalette);

Var
  pal : PUint32;
  i : Integer;

Begin
  pal := APalette.Data;
  If Not FFormat.Indexed Then
    Exit;
  For i := 0 To 255 Do
  Begin
    FColours[i].pixel := i;

    FColours[i].red := ((pal[i] Shr 16) And $FF) Shl 8;
    FColours[i].green := ((pal[i] Shr 8) And $FF) Shl 8;
    FColours[i].blue := (pal[i] And $FF) Shl 8;

    Byte(FColours[i].flags) := DoRed Or DoGreen Or DoBlue;
  End;
  XStoreColors(FDisplay, FCMap, FColours, 256);
End;

Function TX11WindowDisplay.GetPitch : Integer;

Begin
  Result := FPrimary.pitch;
End;

Function TX11WindowDisplay.CreateImage(ADisplay : PDisplay; AScreen, AWidth, AHeight : Integer;
                                       AFormat : TPTCFormat) : TX11Image;

Begin
  {$IFDEF ENABLE_X11_EXTENSION_XSHM}
  If (PTC_X11_TRY_XSHM In FFlags) And XShmQueryExtension(ADisplay) Then
  Begin
    Try
      LOG('trying to create a XShm image');
      Result := TX11ShmImage.Create(ADisplay, AScreen, AWidth, AHeight, AFormat);
      Exit;
    Except
      LOG('XShm failed');
    End;
  End;
  {$ENDIF ENABLE_X11_EXTENSION_XSHM}

  LOG('trying to create a normal image');
  Result := TX11NormalImage.Create(ADisplay, AScreen, AWidth, AHeight, AFormat);
End;

Function TX11WindowDisplay.CreateModeSwitcher : TX11Modes;

Begin
{$IFDEF ENABLE_X11_EXTENSION_XRANDR}
  If PTC_X11_TRY_XRANDR In FFlags Then
    Try
      LOG('trying to initialize the Xrandr mode switcher');
      Result := TX11ModesXrandr.Create(FDisplay, FScreen);
      Exit;
    Except
      LOG('Xrandr failed');
    End;
{$ENDIF ENABLE_X11_EXTENSION_XRANDR}

{$IFDEF ENABLE_X11_EXTENSION_XF86VIDMODE}
  If PTC_X11_TRY_XF86VIDMODE In FFlags Then
    Try
      LOG('trying to initialize the XF86VidMode mode switcher');
      Result := TX11ModesXF86VidMode.Create(FDisplay, FScreen);
      Exit;
    Except
      LOG('XF86VidMode failed');
    End;
{$ENDIF ENABLE_X11_EXTENSION_XF86VIDMODE}

  LOG('creating the standard NoModeSwitching mode switcher');
  Result := TX11ModesNoModeSwitching.Create(FDisplay, FScreen);
End;

Function TX11WindowDisplay.GetX11Window : TWindow;

Begin
  Result := FWindow;
End;

Function TX11WindowDisplay.GetX11GC : TGC;

Begin
  Result := FGC;
End;

Function TX11WindowDisplay.IsFullScreen : Boolean;

Begin
  Result := FFullScreen;
End;

Procedure TX11WindowDisplay.CreateColormap; { Register colour maps }

Var
  i : Integer;
  r, g, b : Single;

Begin
  If FFormat.Bits = 8 Then
  Begin
    FColours := GetMem(256 * SizeOf(TXColor));
    If FColours = Nil Then
      Raise TPTCError.Create('Cannot allocate colour map cells');
    FCMap := XCreateColormap(FDisplay, RootWindow(FDisplay, FScreen),
                             DefaultVisual(FDisplay, FScreen), AllocAll);
    If FCMap = 0 Then
      Raise TPTCError.Create('Cannot create colour map');
    XInstallColormap(FDisplay, FCMap);
    XSetWindowColormap(FDisplay, FWindow, FCMap);
  End
  Else
    FCMap := 0;

  { Set 332 palette, for now }
  If (FFormat.Bits = 8) And FFormat.Direct Then
  Begin
    {Taken from PTC 0.72, i hope it's fine}
    For i := 0 To 255 Do
    Begin
      r := ((i And $E0) Shr 5) * 255 / 7;
      g := ((i And $1C) Shr 2) * 255 / 7;
      b := (i And $03) * 255 / 3;

      FColours[i].pixel := i;

      FColours[i].red := Round(r) Shl 8;
      FColours[i].green := Round(g) Shl 8;
      FColours[i].blue := Round(b) Shl 8;

      Byte(FColours[i].flags) := DoRed Or DoGreen Or DoBlue;
    End;
    XStoreColors(FDisplay, FCMap, FColours, 256);
  End;
End;