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

{$IFDEF XStringListToTextProperty_notyetimplemented_in_xutil_pp}
Function XStringListToTextProperty(list : PPChar; count : Integer;
                                   text_prop_return : PXTextProperty) : TStatus; CDecl; External;
{$ENDIF}

Constructor TX11WindowDisplay.Create;

Begin
  m_has_shm := False;
  m_primary := Nil;
  m_window := 0;
  m_colours := Nil;
  m_keypressed := False;
  Inherited Create;
//  XSHM_LoadLibrary;

{$IFDEF HAVE_X11_EXTENSIONS_XSHM}
  m_has_shm := True;
{$ENDIF HAVE_X11_EXTENSIONS_XSHM}
End;

Destructor TX11WindowDisplay.Destroy;

Begin
  close;
//  XSHM_UnloadLibrary;
  Inherited Destroy;
End;

Procedure TX11WindowDisplay.open(title : String; _width, _height : Integer; Const _format : TPTCFormat; disp : PDisplay; screen : Integer);

Var
  tmpFormat : TPTCFormat;
  xgcv : TXGCValues;
  textprop : TXTextProperty;
  e : TXEvent;
  found : Boolean;
  attr : TXSetWindowAttributes;
  size_hints : PXSizeHints;
  tmpArea : TPTCArea;
  tmppchar : PChar;

Begin
  m_disp := disp;
  m_screen := DefaultScreen(disp);
  m_height := _height;
  m_width := _width;
  m_destx := 0;
  m_desty := 0;
  { Check if we have that colour depth available.. Easy as there is no
    format conversion yet }
  tmpFormat := Nil;
  Try
    tmpFormat := getFormat(_format);
    m_format.ASSign(tmpFormat);
  Finally
    tmpFormat.Free;
  End;
  tmpFormat := Nil;
  { Create a window }
  m_window := XCreateSimpleWindow(m_disp, DefaultRootWindow(m_disp), 0, 0,
                _width, _height, 0, BlackPixel(m_disp, DefaultScreen(m_disp)),
		                    BlackPixel(m_disp, DefaultScreen(m_disp)));
  { Register the delete atom }
  m_atom_close := XInternAtom(m_disp, 'WM_DELETE_WINDOW', False);
  X11Check(XSetWMProtocols(m_disp, m_window, @m_atom_close, 1), 'XSetWMProtocols');
  { Get graphics context }
  xgcv.graphics_exposures := False;
  m_gc := XCreateGC(m_disp, m_window, GCGraphicsExposures, @xgcv);
  If m_gc = Nil Then
    Raise TPTCError.Create('can''t create graphics context');
  { Set window title }
  tmppchar := PChar(title);
  X11Check(XStringListToTextProperty(@tmppchar, 1, @textprop), 'XStringListToTextProperty');
  Try
    XSetWMName(m_disp, m_window, @textprop);
    XFlush(m_disp);
  Finally
    XFree(textprop.value);
  End;
  { Set normal hints }
  size_hints := XAllocSizeHints;
  Try
    size_hints^.flags := PBaseSize;
    size_hints^.base_width := _width;
    size_hints^.base_height := _height;
    XSetWMNormalHints(m_disp, m_window, size_hints);
    XFlush(m_disp);
  Finally
    XFree(size_hints);
  End;
  { Map the window and wait for success }
  XSelectInput(m_disp, m_window, StructureNotifyMask);
  XMapRaised(m_disp, m_window);
  Repeat
    XNextEvent(disp, @e);
    If e._type = MapNotify Then
      Break;
  Until False;
  { Get keyboard input and sync }
  XSelectInput(m_disp, m_window, KeyPressMask Or KeyReleaseMask Or
                                 StructureNotifyMask Or
				 ButtonPressMask Or ButtonReleaseMask Or
				 PointerMotionMask);
  XSync(m_disp, False);
  { Create XImage using factory method }
  m_primary := createImage(m_disp, m_screen, m_width, m_height, m_format);
  
  found := False;
  Repeat
    { Stupid loop. The key }
    { events were causing }
    { problems.. }
    found := XCheckMaskEvent(m_disp, KeyPressMask Or KeyReleaseMask, @e);
  Until Not found;
  
  attr.backing_store := Always;
  XChangeWindowAttributes(m_disp, m_window, CWBackingStore, @attr);
  
  { Set clipping area }
  tmpArea := TPTCArea.Create(0, 0, m_width, m_height);
  Try
    m_clip.ASSign(tmpArea);
  Finally
    tmpArea.Free;
  End;
  
  { Installs the right colour map for 8 bit modes }
  createColormap;

  {ifdef PTHREADS...}
End;

Procedure TX11WindowDisplay.open(disp : PDisplay; screen : Integer; w : TWindow; Const _format : TPTCFormat);

Begin
End;

Procedure TX11WindowDisplay.open(disp : PDisplay; screen : Integer; _window : TWindow; Const _format : TPTCFormat; x, y, w, h : Integer);

Begin
End;

Procedure TX11WindowDisplay.close;

Begin
  {pthreads?!}
  If m_cmap <> 0 Then
  Begin
    XFreeColormap(m_disp, m_cmap);
    m_cmap := 0;
  End;
  
  { Destroy XImage and buffer }
  FreeAndNil(m_primary);
  FreeMemAndNil(m_colours);
  
  { Hide and destroy window }
  If (m_window <> 0) And ((m_flags And PTC_X11_LEAVE_WINDOW) = 0) Then
  Begin
    XUnmapWindow(m_disp, m_window);
    XSync(m_disp, False);
    
    XDestroyWindow(m_disp, m_window);
  End;
End;

Procedure TX11WindowDisplay.update;

Var
  e : TXEvent;

Begin
  m_primary.put(m_window, m_gc, m_destx, m_desty);
  {ifndef pthreads}
  If XCheckTypedEvent(m_disp, ClientMessage, @e) Then
  Begin
    If (e.xclient.format = 32) And (TAtom(e.xclient.data.l[0]) = m_atom_close) Then
      Halt(0);
  End;
  {endif}
End;

Procedure TX11WindowDisplay.update(Const _area : TPTCArea);

Var
  e : TXEvent;
  updatearea : TPTCArea;
  tmparea : TPTCArea;

Begin
  tmparea := TPTCArea.Create(0, 0, m_width, m_height);
  Try
    updatearea := TPTCClipper.clip(tmparea, _area);
    Try
      m_primary.put(m_window, m_gc, updatearea.left, updatearea.top,
                    m_destx + updatearea.left, m_desty + updatearea.top,
		    updatearea.width, updatearea.height);
    Finally
      updatearea.Free;
    End;
  Finally
    tmparea.Free;
  End;
  
  {ifndef pthreads}
  If XCheckTypedEvent(m_disp, ClientMessage, @e) Then
  Begin
    If (e.xclient.format = 32) And (TAtom(e.xclient.data.l[0]) = m_atom_close) Then
      Halt(0);
  End;
  {endif}
End;

Procedure TX11WindowDisplay.internal_ReadKey(k : TPTCKey);

Var
  e : TXEvent;
  sym : TKeySym;
  press : Boolean;
  alt, shift, ctrl : Boolean;
  uni : Integer;
  tmpkey : TPTCKey;

Begin
  XMaskEvent(m_disp, KeyPressMask Or KeyReleaseMask, @e); { Blocks and waits }
  If (e._type <> KeyPress) And (e._type <> KeyRelease) Then
    Raise TPTCError.Create('XMaskEvent returned event <> KeyPress/KeyRelease');
  
{  XLookupString(@e.xkey, Nil, 0, @sym, Nil);}
  sym := XLookupKeySym(@e.xkey, 0);
  uni := X11ConvertKeySymToUnicode(sym);
  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;

  tmpkey := Nil;
  Try
    Case sym Shr 8 Of
      0 : tmpkey := TPTCKey.Create(m_normalkeys[sym And $FF], uni, alt, shift, ctrl, press);
      $FF : tmpkey := TPTCKey.Create(m_functionkeys[sym And $FF], uni, alt, shift, ctrl, press);
      Else
        tmpkey := TPTCKey.Create;
    End;
    k.ASSign(tmpkey);
  Finally
    tmpkey.Free;
  End;
End;

Function TX11WindowDisplay.internal_PeekKey(k : TPTCKey) : Boolean;

Var
  e : TXEvent;

Begin
  If XCheckMaskEvent(m_disp, KeyPressMask Or KeyReleaseMask, @e) Then
  Begin
    XPutBackEvent(m_disp, @e); { Simulate "normal" kbhit behaviour }
    XPutBackEvent(m_disp, @e); { i.e. leave the buffer intact }
    internal_ReadKey(k);
    Result := True;
  End
  Else
    Result := False;
End;

Function TX11WindowDisplay.lock : Pointer;

Begin
  lock := m_primary.lock;
End;

Procedure TX11WindowDisplay.unlock;

Begin
End;

Procedure TX11WindowDisplay.palette(Const _palette : TPTCPalette);

Var
  pal : Pint32;
  i : Integer;

Begin
  pal := _palette.data;
  If Not m_format.indexed Then
    Exit;
  For i := 0 To 255 Do
  Begin
    m_colours[i].pixel := i;

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

    Byte(m_colours[i].flags) := DoRed Or DoGreen Or DoBlue;
  End;
  XStoreColors(m_disp, m_cmap, m_colours, 256);
End;

Function TX11WindowDisplay.pitch : Integer;

Begin
  pitch := m_primary.pitch;
End;

Function TX11WindowDisplay.createImage(disp : PDisplay; screen, _width, _height : Integer;
                                       _format : TPTCFormat) : TX11Image;

{$IFDEF HAVE_X11_EXTENSIONS_XSHM}
Var
  tmp : TX11Image;
{$ENDIF}

Begin
  {todo: shm}
  {$IFDEF HAVE_X11_EXTENSIONS_XSHM}
  If m_has_shm And XShmQueryExtension(disp) Then
  Begin
    Try
      tmp := TX11SHMImage.Create(disp, screen, _width, _height, _format);
    Except
      On e : TPTCError Do
        tmp := TX11NormalImage.Create(disp, screen, _width, _height, _format);
    End;
    createImage := tmp;
  End
  Else
  {$ENDIF}
  createImage := TX11NormalImage.Create(disp, screen, _width, _height, _format);
End;

Function TX11WindowDisplay.getX11Window : TWindow;

Begin
  getX11Window := m_window;
End;

Function TX11WindowDisplay.getX11GC : TGC;

Begin
  getX11GC := m_gc;
End;

Procedure TX11WindowDisplay.createColormap; { Register colour maps }

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

Begin
  If m_format.bits = 8 Then
  Begin
    m_colours := GetMem(256 * SizeOf(TXColor));
    If m_colours = Nil Then
      Raise TPTCError.Create('Cannot allocate colour map cells');
    m_cmap := XCreateColormap(m_disp, RootWindow(m_disp, m_screen),
                              DefaultVisual(m_disp, m_screen), AllocAll);
    If m_cmap = 0 Then
      Raise TPTCError.Create('Cannot create colour map');
    XInstallColormap(m_disp, m_cmap);
    XSetWindowColormap(m_disp, m_window, m_cmap);
  End
  Else
    m_cmap := 0;

  { Set 332 palette, for now }
  If (m_format.bits = 8) And m_format.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;
      
      m_colours[i].pixel := i;
      
      m_colours[i].red := Round(r) Shl 8;
      m_colours[i].green := Round(g) Shl 8;
      m_colours[i].blue := Round(b) Shl 8;
      
      Byte(m_colours[i].flags) := DoRed Or DoGreen Or DoBlue;
    End;
    XStoreColors(m_disp, m_cmap, m_colours, 256);
  End;
End;