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

Const
{$WARNING this belongs to the ipc unit}
  IPC_PRIVATE = 0;

Constructor TX11Image.Create(ADisplay : PDisplay; AScreen, AWidth, AHeight : Integer; AFormat : TPTCFormat);

Begin
  FWidth := AWidth;
  FHeight := AHeight;
  FDisplay := ADisplay;
End;

Constructor TX11NormalImage.Create(ADisplay : PDisplay; AScreen, AWidth, AHeight : Integer; AFormat : TPTCFormat);

Var
  xpad, xpitch : Integer;
  tmp_FPixels : PChar;

Begin
  Inherited;

  xpad := AFormat.Bits;
  If AFormat.Bits = 24 Then
    xpad := 32;
  xpitch := AWidth * AFormat.Bits Div 8;
  Inc(xpitch, 3);
  xpitch := xpitch And (Not 3);
  FPixels := GetMem(xpitch * AHeight);
  Pointer(tmp_FPixels) := Pointer(FPixels);
  FImage := XCreateImage(ADisplay, DefaultVisual(ADisplay, AScreen),
                         DefaultDepth(ADisplay, AScreen),
                         ZPixmap, 0, tmp_FPixels,
                         AWidth, AHeight, xpad, 0);
  If FImage = Nil Then
    Raise TPTCError.Create('cannot create XImage');
End;

Destructor TX11NormalImage.Destroy;

Begin
  If FImage <> Nil Then
  Begin
    { Restore XImage's buffer pointer }
    FImage^.data := Nil;
    XDestroyImage(FImage);
  End;

  If FPixels <> Nil Then
    FreeMem(FPixels);

  Inherited Destroy;
End;

Procedure TX11NormalImage.Put(AWindow : TWindow; AGC : TGC; AX, AY : Integer);

Begin
  XPutImage(FDisplay, AWindow, AGC, FImage, 0, 0, AX, AY, FWidth, FHeight);
  XSync(FDisplay, False);
End;

Procedure TX11NormalImage.Put(AWindow : TWindow; AGC : TGC; ASX, ASY, ADX, ADY,
                    AWidth, AHeight : Integer);

Begin
  XPutImage(FDisplay, AWindow, AGC, FImage, ASX, ASY, ADX, ADY, AWidth, AHeight);
  XSync(FDisplay, False);
End;

Function TX11NormalImage.Lock : Pointer;

Begin
  Result := FPixels;
End;

Function TX11NormalImage.Pitch : Integer;

Begin
  Result := FImage^.bytes_per_line;
End;

Function TX11NormalImage.Name : String;

Begin
  Result := 'XImage';
End;

{$IFDEF ENABLE_X11_EXTENSION_XSHM}

Var
  Fshm_error : Boolean;
  Fshm_oldhandler : Function(disp : PDisplay; xev : PXErrorEvent) : Integer; CDecl;

Function Fshm_errorhandler(disp : PDisplay; xev : PXErrorEvent) : Integer; CDecl;

Begin
  If xev^.error_code=BadAccess Then
  Begin
    Fshm_error := True;
    Result := 0;
  End
  Else
    Result := Fshm_oldhandler(disp, xev);
End;

Constructor TX11ShmImage.Create(ADisplay : PDisplay; AScreen, AWidth, AHeight : Integer; AFormat : TPTCFormat);

Begin
  Inherited;

  FShmInfo.shmid := -1;
  FShmInfo.shmaddr := Pointer(-1);
  FImage := XShmCreateImage(ADisplay, DefaultVisual(ADisplay, AScreen),
                            DefaultDepth(ADisplay, AScreen),
                            ZPixmap, Nil, @FShmInfo, AWidth, AHeight);
  If FImage = Nil Then
    Raise TPTCError.Create('cannot create SHM image');

  FShmInfo.shmid := shmget(IPC_PRIVATE, FImage^.bytes_per_line * FImage^.height,
                           IPC_CREAT Or &777);
  If FShmInfo.shmid = -1 Then
    Raise TPTCError.Create('cannot get shared memory segment');

  FShmInfo.shmaddr := shmat(FShmInfo.shmid, Nil, 0);
  FShmInfo.readOnly := False;
  FImage^.data := FShmInfo.shmaddr;

  If Pointer(FShmInfo.shmaddr) = Pointer(-1) Then
    Raise TPTCError.Create('cannot allocate shared memory');

  // Try and attach the segment to the server. Bugfix: Have to catch
  // bad access errors in case it runs over the net.
  Fshm_error := False;
  Fshm_oldhandler := XSetErrorHandler(@Fshm_errorhandler);
  Try
    If XShmAttach(ADisplay, @FShmInfo) = 0 Then
      Raise TPTCError.Create('cannot attach shared memory segment to display');

    XSync(ADisplay, False);
    If Fshm_error Then
      Raise TPTCError.Create('cannot attach shared memory segment to display');
    FShmAttached := True;
  Finally
    XSetErrorHandler(Fshm_oldhandler);
  End;
End;

Destructor TX11ShmImage.Destroy;

Begin
  If FShmAttached Then
  Begin
    XShmDetach(FDisplay, @FShmInfo);
    XSync(FDisplay, False);
  End;
  If FImage <> Nil Then
    XDestroyImage(FImage);
  If Pointer(FShmInfo.shmaddr) <> Pointer(-1) Then
    shmdt(FShmInfo.shmaddr);
  If FShmInfo.shmid <> -1 Then
    shmctl(FShmInfo.shmid, IPC_RMID, Nil);

  Inherited Destroy;
End;

Procedure TX11ShmImage.Put(AWindow : TWindow; AGC : TGC; AX, AY : Integer);

Begin
  XShmPutImage(FDisplay, AWindow, AGC, FImage, 0, 0, AX, AY, FWidth, FHeight, False);
  XSync(FDisplay, False);
End;

Procedure TX11ShmImage.Put(AWindow : TWindow; AGC : TGC; ASX, ASY, ADX, ADY,
                    AWidth, AHeight : Integer);

Begin
  XShmPutImage(FDisplay, AWindow, AGC, FImage, ASX, ASY, ADX, ADY, FWidth, FHeight, False);
  XSync(FDisplay, False);
End;

Function TX11ShmImage.Lock : Pointer;

Begin
  Result := Pointer(FShmInfo.shmaddr);
End;

Function TX11ShmImage.Pitch : Integer;

Begin
  Result := FImage^.bytes_per_line;
End;

Function TX11ShmImage.Name : String;

Begin
  Result := 'MIT-Shm';
End;
{$ENDIF ENABLE_X11_EXTENSION_XSHM}