mirror of
https://github.com/moparisthebest/Simba
synced 2024-08-13 16:53:59 -04:00
Made some MSWindows only changed, more will follow.
git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@10 3f818213-9676-44b0-a9b4-5e4c4e03d09d
This commit is contained in:
Raymond
parent
93916bf9c1
commit
abb0020dc5
@ -1,154 +1,251 @@
|
||||
unit Input;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils,
|
||||
mufasatypes, // for common mufasa types
|
||||
windowutil // for mufasa window utils
|
||||
{$IFDEF LINUX}
|
||||
,x, xlib // for X* stuff
|
||||
{$ENDIF};
|
||||
type
|
||||
TMInput = class(TObject)
|
||||
constructor Create(Client: TObject);
|
||||
destructor Destroy; override;
|
||||
|
||||
procedure GetMousePos(var X, Y: Integer);
|
||||
procedure SetMousePos(X, Y: Integer);
|
||||
procedure MouseButtonAction(X, Y: Integer; mClick: TClickType; mPress: TMousePress);
|
||||
procedure ClickMouse(X, Y: Integer; mClick: TClickType);
|
||||
function IsMouseButtonDown(mType: TClickType): Boolean;
|
||||
|
||||
public
|
||||
Client: TObject;
|
||||
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
Client;
|
||||
|
||||
constructor TMInput.Create(Client: TObject);
|
||||
begin
|
||||
inherited Create;
|
||||
Self.Client := Client;
|
||||
end;
|
||||
|
||||
destructor TMInput.Destroy;
|
||||
begin
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TMInput.GetMousePos(var X, Y: Integer);
|
||||
{$IFDEF LINUX}
|
||||
var
|
||||
b:integer;
|
||||
root, child: twindow;
|
||||
xmask: Cardinal;
|
||||
Old_Handler: TXErrorHandler;
|
||||
{$ENDIF}
|
||||
begin
|
||||
{$IFDEF LINUX}
|
||||
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
|
||||
XQueryPointer(TClient(Client).MWindow.XDisplay,TClient(Client).MWindow.CurWindow,@root,@child,@b,@b,@x,@y,@xmask);
|
||||
XSetErrorHandler(Old_Handler);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TMInput.SetMousePos(X, Y: Integer);
|
||||
{$IFDEF LINUX}
|
||||
var
|
||||
Old_Handler: TXErrorHandler;
|
||||
{$ENDIF}
|
||||
begin
|
||||
{$IFDEF LINUX}
|
||||
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
|
||||
XWarpPointer(TClient(Client).MWindow.XDisplay, 0, TClient(Client).MWindow.CurWindow, 0, 0, 0, 0, X, Y);
|
||||
XFlush(TClient(Client).MWindow.XDisplay);
|
||||
XSetErrorHandler(Old_Handler);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TMInput.MouseButtonAction(X, Y: Integer; mClick: TClickType; mPress: TMousePress);
|
||||
{$IFDEF LINUX}
|
||||
var
|
||||
event : TXEvent;
|
||||
Garbage : QWord;
|
||||
Old_Handler: TXErrorHandler;
|
||||
{$ENDIF}
|
||||
|
||||
begin
|
||||
Self.SetMousePos(X, Y);
|
||||
{$IFDEF LINUX}
|
||||
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
|
||||
|
||||
FillChar(event,sizeof(TXevent),0);
|
||||
|
||||
if mPress = mouse_Down then
|
||||
Event._type:= ButtonPress
|
||||
else
|
||||
Event._type:= ButtonRelease;
|
||||
|
||||
case mClick of
|
||||
mouse_Left: Event.xbutton.button:= Button1;
|
||||
mouse_Middle: Event.xbutton.button:= Button2;
|
||||
mouse_Right: Event.xbutton.button:= Button3;
|
||||
end;
|
||||
|
||||
event.xbutton.send_event := 1;
|
||||
event.xbutton.same_screen:= 1;
|
||||
event.xbutton.subwindow:= 0;
|
||||
event.xbutton.root := TClient(Client).MWindow.DesktopWindow;
|
||||
event.xbutton.window := TClient(Client).MWindow.CurWindow;
|
||||
event.xbutton.x_root:= x;
|
||||
event.xbutton.y_root:= y;
|
||||
event.xbutton.x := x;
|
||||
event.xbutton.y := y;
|
||||
event.xbutton.state:= 0;
|
||||
if(XSendEvent(TClient(Client).MWindow.XDisplay, PointerWindow, True, $fff, @event) = 0) then
|
||||
Writeln('Errorrrr :-(');
|
||||
XFlush(TClient(Client).MWindow.XDisplay);
|
||||
|
||||
XSetErrorHandler(Old_Handler);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
// ff omzetten naar MouseButtonDown(), en dan Click gewoon down en dan up.
|
||||
// holdmouse releasemouse
|
||||
procedure TMInput.ClickMouse(X, Y: Integer; mClick: TClickType);
|
||||
|
||||
begin
|
||||
Self.MouseButtonAction(X, Y, mClick, mouse_Down);
|
||||
Self.MouseButtonAction(X, Y, mClick, mouse_Up);
|
||||
end;
|
||||
|
||||
function TMInput.IsMouseButtonDown(mType: TClickType): Boolean;
|
||||
{$IFDEF LINUX}
|
||||
var
|
||||
rootx, rooty, x, y:integer;
|
||||
root, child: twindow;
|
||||
xmask: Cardinal;
|
||||
Old_Handler: TXErrorHandler;
|
||||
{$ENDIF}
|
||||
begin
|
||||
{$IFDEF LINUX}
|
||||
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
|
||||
XQueryPointer(TClient(Client).MWindow.XDisplay,TClient(Client).MWindow.CurWindow,@root,@child,@rootx,@rooty,@x,@y,@xmask);
|
||||
|
||||
case mType of
|
||||
mouse_Left: Result := (xmask and Button1Mask) <> 0;
|
||||
mouse_Middle: Result := (xmask and Button2Mask) <> 0;
|
||||
mouse_Right: Result := (xmask and Button3Mask) <> 0;
|
||||
end;
|
||||
|
||||
XSetErrorHandler(Old_Handler);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
unit Input;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils,
|
||||
mufasatypes, // for common mufasa types
|
||||
windowutil // for mufasa window utils
|
||||
{$IFDEF LINUX}
|
||||
,x, xlib // for X* stuff
|
||||
{$ENDIF};
|
||||
type
|
||||
TMInput = class(TObject)
|
||||
constructor Create(Client: TObject);
|
||||
destructor Destroy; override;
|
||||
|
||||
procedure GetMousePos(var X, Y: Integer);
|
||||
procedure SetMousePos(X, Y: Integer);
|
||||
procedure MouseButtonAction(x,y : integer; mClick: TClickType; mPress: TMousePress);
|
||||
procedure ClickMouse(X, Y: Integer; mClick: TClickType);
|
||||
function IsMouseButtonDown(mType: TClickType): Boolean;
|
||||
|
||||
public
|
||||
Client: TObject;
|
||||
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
Client{$IFDEF MSWINDOWS},windows{$ENDIF};
|
||||
|
||||
{$IFDEF MSWINDOWS}
|
||||
type
|
||||
PMouseInput = ^TMouseInput;
|
||||
tagMOUSEINPUT = packed record
|
||||
dx: Longint;
|
||||
dy: Longint;
|
||||
mouseData: DWORD;
|
||||
dwFlags: DWORD;
|
||||
time: DWORD;
|
||||
dwExtraInfo: DWORD;
|
||||
end;
|
||||
TMouseInput = tagMOUSEINPUT;
|
||||
|
||||
PKeybdInput = ^TKeybdInput;
|
||||
tagKEYBDINPUT = packed record
|
||||
wVk: WORD;
|
||||
wScan: WORD;
|
||||
dwFlags: DWORD;
|
||||
time: DWORD;
|
||||
dwExtraInfo: DWORD;
|
||||
end;
|
||||
TKeybdInput = tagKEYBDINPUT;
|
||||
|
||||
PHardwareInput = ^THardwareInput;
|
||||
tagHARDWAREINPUT = packed record
|
||||
uMsg: DWORD;
|
||||
wParamL: WORD;
|
||||
wParamH: WORD;
|
||||
end;
|
||||
THardwareInput = tagHARDWAREINPUT;
|
||||
PInput = ^TInput;
|
||||
tagINPUT = packed record
|
||||
Itype: DWORD;
|
||||
case Integer of
|
||||
0: (mi: TMouseInput);
|
||||
1: (ki: TKeybdInput);
|
||||
2: (hi: THardwareInput);
|
||||
end;
|
||||
TInput = tagINPUT;
|
||||
const
|
||||
INPUT_MOUSE = 0;
|
||||
INPUT_KEYBOARD = 1;
|
||||
INPUT_HARDWARE = 2;
|
||||
|
||||
{Mouse}
|
||||
function SendInput(cInputs: UINT; var pInputs: TInput; cbSize: Integer): UINT; stdcall; external user32 name 'SendInput';
|
||||
{$ENDIF}
|
||||
|
||||
constructor TMInput.Create(Client: TObject);
|
||||
begin
|
||||
inherited Create;
|
||||
Self.Client := Client;
|
||||
end;
|
||||
|
||||
destructor TMInput.Destroy;
|
||||
begin
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TMInput.GetMousePos(var X, Y: Integer);
|
||||
{$IFDEF LINUX}
|
||||
var
|
||||
b:integer;
|
||||
root, child: twindow;
|
||||
xmask: Cardinal;
|
||||
Old_Handler: TXErrorHandler;
|
||||
{$ENDIF}
|
||||
{$IFDEF MSWINDOWS}
|
||||
var
|
||||
MousePoint : TPoint;
|
||||
{$ENDIF}
|
||||
begin
|
||||
{$IFDEF MSWINDOWS}
|
||||
Windows.GetCursorPos(MousePoint);
|
||||
Windows.ScreenToClient( TClient(Client).MWindow.TargetHandle, MousePoint);
|
||||
x := MousePoint.x;
|
||||
y := MousePoint.y;
|
||||
{$ENDIF}
|
||||
{$IFDEF LINUX}
|
||||
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
|
||||
XQueryPointer(TClient(Client).MWindow.XDisplay,TClient(Client).MWindow.CurWindow,@root,@child,@b,@b,@x,@y,@xmask);
|
||||
XSetErrorHandler(Old_Handler);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TMInput.SetMousePos(X, Y: Integer);
|
||||
{$IFDEF LINUX}
|
||||
var
|
||||
Old_Handler: TXErrorHandler;
|
||||
{$ENDIF}
|
||||
{$IFDEF MSWINDOWS}
|
||||
var
|
||||
rect : TRect;
|
||||
{$ENDIF}
|
||||
begin
|
||||
{$IFDEF MSWINDOWS}
|
||||
GetWindowRect(TClient(Client).MWindow.TargetHandle, Rect);
|
||||
Windows.SetCursorPos(x + Rect.Left, y + Rect.Top);
|
||||
{$ENDIF}
|
||||
{$IFDEF LINUX}
|
||||
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
|
||||
XWarpPointer(TClient(Client).MWindow.XDisplay, 0, TClient(Client).MWindow.CurWindow, 0, 0, 0, 0, X, Y);
|
||||
XFlush(TClient(Client).MWindow.XDisplay);
|
||||
XSetErrorHandler(Old_Handler);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TMInput.MouseButtonAction(x,y : integer; mClick: TClickType; mPress: TMousePress);
|
||||
{$IFDEF LINUX}
|
||||
var
|
||||
event : TXEvent;
|
||||
Garbage : QWord;
|
||||
Old_Handler: TXErrorHandler;
|
||||
{$ENDIF}
|
||||
{$IFDEF MSWINDOWS}
|
||||
var
|
||||
Input : TInput;
|
||||
Rect : TRect;
|
||||
{$ENDIF}
|
||||
begin;
|
||||
{$IFDEF MSWINDOWS}
|
||||
GetWindowRect(TClient(Client).MWindow.TargetHandle, Rect);
|
||||
Input.Itype:= INPUT_MOUSE;
|
||||
Input.mi.dx:= x + Rect.left;
|
||||
Input.mi.dy:= y + Rect.Top;
|
||||
if mPress = mouse_Down then
|
||||
begin;
|
||||
case mClick of
|
||||
Mouse_Left: Input.mi.dwFlags:= MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTDOWN;
|
||||
Mouse_Middle: Input.mi.dwFlags:= MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MIDDLEDOWN;
|
||||
Mouse_Right: Input.mi.dwFlags:= MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_RIGHTDOWN;
|
||||
end;
|
||||
end else
|
||||
case mClick of
|
||||
Mouse_Left: Input.mi.dwFlags:= MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTUP;
|
||||
Mouse_Middle: Input.mi.dwFlags:= MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MIDDLEUP;
|
||||
Mouse_Right: Input.mi.dwFlags:= MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_RIGHTUP;
|
||||
end;
|
||||
SendInput(1,Input, sizeof(Input));
|
||||
{$ENDIF}
|
||||
{$IFDEF LINUX}
|
||||
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
|
||||
|
||||
FillChar(event,sizeof(TXevent),0);
|
||||
|
||||
if mPress = mouse_Down then
|
||||
Event._type:= ButtonPress
|
||||
else
|
||||
Event._type:= ButtonRelease;
|
||||
|
||||
case mClick of
|
||||
mouse_Left: Event.xbutton.button:= Button1;
|
||||
mouse_Middle: Event.xbutton.button:= Button2;
|
||||
mouse_Right: Event.xbutton.button:= Button3;
|
||||
end;
|
||||
|
||||
event.xbutton.send_event := 1;
|
||||
event.xbutton.same_screen:= 1;
|
||||
event.xbutton.subwindow:= 0;
|
||||
event.xbutton.root := TClient(Client).MWindow.DesktopWindow;
|
||||
event.xbutton.window := TClient(Client).MWindow.CurWindow;
|
||||
event.xbutton.x_root:= x;
|
||||
event.xbutton.y_root:= y;
|
||||
event.xbutton.x := x;
|
||||
event.xbutton.y := y;
|
||||
event.xbutton.state:= 0;
|
||||
if(XSendEvent(TClient(Client).MWindow.XDisplay, PointerWindow, True, $fff, @event) = 0) then
|
||||
Writeln('Errorrrr :-(');
|
||||
XFlush(TClient(Client).MWindow.XDisplay);
|
||||
|
||||
XSetErrorHandler(Old_Handler);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
// ff omzetten naar MouseButtonDown(), en dan Click gewoon down en dan up.
|
||||
// holdmouse releasemouse
|
||||
procedure TMInput.ClickMouse(X, Y: Integer; mClick: TClickType);
|
||||
|
||||
begin
|
||||
Self.SetMousePos(x,y);
|
||||
Self.MouseButtonAction(X, Y, mClick, mouse_Down);
|
||||
Self.MouseButtonAction(X, Y, mClick, mouse_Up);
|
||||
end;
|
||||
|
||||
function TMInput.IsMouseButtonDown(mType: TClickType): Boolean;
|
||||
{$IFDEF LINUX}
|
||||
var
|
||||
rootx, rooty, x, y:integer;
|
||||
root, child: twindow;
|
||||
xmask: Cardinal;
|
||||
Old_Handler: TXErrorHandler;
|
||||
{$ENDIF}
|
||||
begin
|
||||
{$IFDEF MSWINDOWS}
|
||||
case mType of
|
||||
Mouse_Left: Result := (GetAsyncKeyState(VK_LBUTTON) <> 0);
|
||||
Mouse_Middle: Result := (GetAsyncKeyState(VK_MBUTTON) <> 0)
|
||||
Mouse_Right: Result := (GetAsyncKeyState(VK_RBUTTON) <> 0)
|
||||
end;
|
||||
{$ENDIF}
|
||||
{$IFDEF LINUX}
|
||||
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
|
||||
XQueryPointer(TClient(Client).MWindow.XDisplay,TClient(Client).MWindow.CurWindow,@root,@child,@rootx,@rooty,@x,@y,@xmask);
|
||||
|
||||
case mType of
|
||||
mouse_Left: Result := (xmask and Button1Mask) <> 0;
|
||||
mouse_Middle: Result := (xmask and Button2Mask) <> 0;
|
||||
mouse_Right: Result := (xmask and Button3Mask) <> 0;
|
||||
end;
|
||||
|
||||
XSetErrorHandler(Old_Handler);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
|
||||
@ -1,289 +1,294 @@
|
||||
unit Window;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, mufasatypes, graphics,
|
||||
LCLType
|
||||
|
||||
{$IFDEF LINUX}, xlib, x, xutil, ctypes{$ENDIF};
|
||||
|
||||
type
|
||||
TMWindow = class(TObject)
|
||||
function ReturnData(xs, ys, width, height: Integer): PRGB32;
|
||||
procedure FreeReturnData;
|
||||
procedure GetDimensions(var W, H: Integer);
|
||||
function CopyClientToBitmap(xs, ys, xe, ye: integer): TBitmap;
|
||||
|
||||
{$IFDEF LINUX}
|
||||
function SetTarget(XWindow: x.TWindow): integer; overload;
|
||||
{$ENDIF}
|
||||
|
||||
function SetTarget(Window: THandle; NewType: TTargetWindowMode): integer; overload;
|
||||
function SetTarget(ArrPtr: PRGB32): integer; overload;
|
||||
|
||||
constructor Create(Client: TObject);
|
||||
destructor Destroy; override;
|
||||
public
|
||||
// Reference to client.
|
||||
Client: TObject;
|
||||
|
||||
// Target Window Mode.
|
||||
TargetMode: TTargetWindowMode;
|
||||
|
||||
{$IFDEF LINUX}
|
||||
// X Display
|
||||
XDisplay: PDisplay;
|
||||
|
||||
// Connection Number
|
||||
XConnectionNumber: Integer;
|
||||
|
||||
// X Window
|
||||
CurWindow: x.TWindow;
|
||||
|
||||
// Desktop Window
|
||||
DesktopWindow: x.TWindow;
|
||||
|
||||
// X Screen
|
||||
XScreen: PScreen;
|
||||
|
||||
// X Screen Number
|
||||
XScreenNum: Integer;
|
||||
|
||||
// The X Image pointer.
|
||||
XWindowImage: PXImage;
|
||||
|
||||
{$IFDEF M_MEMORY_DEBUG}
|
||||
// XImageFreed should be True if there is currently no
|
||||
// XImage loaded. If one is loaded, XImageFreed is true.
|
||||
|
||||
// If ReturnData is called while XImageFreed is false,
|
||||
// we throw an exception.
|
||||
// Same for FreeReturnData with XImageFreed true.
|
||||
XImageFreed: Boolean;
|
||||
{$ENDIF}
|
||||
|
||||
{$ELSE}
|
||||
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
Client, // For the Client Class
|
||||
windowutil, // For utilities such as XImageToRawImage
|
||||
GraphType // For TRawImage
|
||||
;
|
||||
|
||||
constructor TMWindow.Create(Client: TObject);
|
||||
begin
|
||||
inherited Create;
|
||||
Self.Client := Client;
|
||||
{$IFDEF LINUX}
|
||||
Self.TargetMode := w_XWindow;
|
||||
|
||||
Self.XDisplay := XOpenDisplay(nil);
|
||||
if Self.XDisplay = nil then
|
||||
begin
|
||||
// throw Exception
|
||||
end;
|
||||
Self.XConnectionNumber:= ConnectionNumber(Self.XDisplay);
|
||||
Self.XScreen := XDefaultScreenOfDisplay(Self.XDisplay);
|
||||
Self.XScreenNum:= DefaultScreen(Self.XDisplay);
|
||||
|
||||
// The Root Window is the Desktop. :-)
|
||||
Self.DesktopWindow:= RootWindow(Self.XDisplay, Self.XScreenNum);
|
||||
Self.CurWindow:= Self.DesktopWindow;
|
||||
|
||||
{$ELSE}
|
||||
// Set Target mode for windows.
|
||||
{$ENDIF}
|
||||
|
||||
end;
|
||||
|
||||
destructor TMWindow.Destroy;
|
||||
begin
|
||||
|
||||
{$IFDEF LINUX}
|
||||
XCloseDisplay(Self.XDisplay);
|
||||
{$ENDIF}
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
function TMWindow.ReturnData(xs, ys, width, height: Integer): PRGB32;
|
||||
{$IFDEF LINUX}
|
||||
var
|
||||
Old_Handler: TXErrorHandler;
|
||||
{$ENDIF}
|
||||
begin
|
||||
case Self.TargetMode of
|
||||
w_XWindow:
|
||||
begin
|
||||
{$IFDEF LINUX}
|
||||
{ Should be this. }
|
||||
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
|
||||
|
||||
Self.XWindowImage := XGetImage(Self.XDisplay, Self.curWindow, xs, ys, width, height, AllPlanes, ZPixmap);
|
||||
if QWord(Self.XWindowImage) = 0 then
|
||||
begin
|
||||
Writeln('ReturnData: XGetImage Error. Dumping data now:');
|
||||
Writeln('xs, ys, width, height: ' + inttostr(xs) + ', ' + inttostr(ys) +
|
||||
', ' + inttostr(width) + ', ' + inttostr(height));
|
||||
Result := nil;
|
||||
XSetErrorHandler(Old_Handler);
|
||||
Exit;
|
||||
end;
|
||||
WriteLn(IntToStr(Self.XWindowImage^.width) + ', ' + IntToStr(Self.XWindowImage^.height));
|
||||
Result := PRGB32(Self.XWindowImage^.data);
|
||||
|
||||
XSetErrorHandler(Old_Handler);
|
||||
{$ELSE}
|
||||
WriteLn('Windows doesn''t support XImage');
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMWindow.FreeReturnData;
|
||||
begin
|
||||
if Self.TargetMode <> w_XWindow then
|
||||
begin
|
||||
// throw exception.
|
||||
exit;
|
||||
end;
|
||||
{$IFDEF LINUX}
|
||||
if(QWord(Self.XWindowImage) <> 0) then // 0, nil?
|
||||
begin
|
||||
XDestroyImage(Self.XWindowImage);
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function TMWindow.CopyClientToBitmap(xs, ys, xe, ye: integer): TBitmap;
|
||||
{$IFDEF LINUX}
|
||||
var
|
||||
Old_Handler: TXErrorHandler;
|
||||
w, h, ww, hh: Integer;
|
||||
Img: PXImage;
|
||||
Raw: TRawImage;
|
||||
Bmp: TBitmap;
|
||||
{$ENDIF}
|
||||
begin
|
||||
Self.GetDimensions(w, h);
|
||||
writeln(inttostr(xs) + ', ' + inttostr(ys) + ' : ' + inttostr(xe) + ', ' +
|
||||
inttostr(ye));
|
||||
ww := xe-xs;
|
||||
hh := ye-ys;
|
||||
|
||||
case Self.TargetMode Of
|
||||
w_XWindow:
|
||||
begin
|
||||
{$IFDEF LINUX}
|
||||
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
|
||||
|
||||
if(xs < 0) or (ys < 0) or (xe > W) or (ye > H) then
|
||||
begin
|
||||
writeln('Faulty coordinates');
|
||||
XSetErrorHandler(Old_Handler);
|
||||
exit;
|
||||
end;
|
||||
|
||||
Img := XGetImage(Self.XDisplay, Self.curWindow, xs, ys, ww, hh, AllPlanes, ZPixmap);
|
||||
XImageToRawImage(Img, Raw);
|
||||
|
||||
Bmp := TBitmap.Create;
|
||||
Bmp.LoadFromRawImage(Raw, False);
|
||||
Result := Bmp;
|
||||
|
||||
{
|
||||
If you want to use some internal Bitmap system, BitBlt to it here.
|
||||
Don't forget to free Bmp!
|
||||
}
|
||||
//lclintf.BitBlt(Bmps[bitmap].Canvas.Handle, 0, 0, ww + 1, hh + 1, Bmp.Canvas.Handle, xs, ys, SRCCOPY);
|
||||
//Bmp.Free;
|
||||
|
||||
XDestroyImage(Img);
|
||||
XSetErrorHandler(Old_Handler);
|
||||
{$ELSE}
|
||||
writeln('Windows and tXWindow');
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMWindow.GetDimensions(var W, H: Integer);
|
||||
{$IFDEF LINUX}
|
||||
var
|
||||
Attrib: TXWindowAttributes;
|
||||
newx,newy : integer;
|
||||
childwindow : x.TWindow;
|
||||
Old_Handler: TXErrorHandler;
|
||||
{$ENDIF}
|
||||
begin
|
||||
case TargetMode of
|
||||
w_Window:
|
||||
begin
|
||||
end;
|
||||
w_XWindow:
|
||||
begin
|
||||
{$IFDEF LINUX}
|
||||
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
|
||||
if XGetWindowAttributes(Self.XDisplay, Self.CurWindow, @Attrib) <> 0 Then
|
||||
begin
|
||||
XTranslateCoordinates(Self.XDisplay, Self.CurWindow, Self.DesktopWindow, 0,0, @newx, @newy, @childwindow);
|
||||
W := Attrib.Width;
|
||||
H := Attrib.Height;
|
||||
end else
|
||||
begin
|
||||
W := -1;
|
||||
H := -1;
|
||||
end;
|
||||
XSetErrorHandler(Old_Handler);
|
||||
{$ELSE}
|
||||
WriteLn('You dummy! How are you going to use w_XWindow on non Linux systems?');
|
||||
{$ENDIF}
|
||||
end;
|
||||
w_ArrayPtr:
|
||||
begin
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TMWindow.SetTarget(XWindow: x.TWindow): integer; overload;
|
||||
{$IFDEF LINUX}
|
||||
var
|
||||
Old_Handler: TXErrorHandler;
|
||||
{$ENDIF}
|
||||
begin
|
||||
{$IFDEF LINUX}
|
||||
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
|
||||
Self.CurWindow := XWindow;
|
||||
Self.TargetMode:= w_XWindow;
|
||||
XSetErrorHandler(Old_Handler);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function TMWindow.SetTarget(Window: THandle; NewType: TTargetWindowMode): integer; overload;
|
||||
begin
|
||||
if NewType in [ w_XWindow, w_ArrayPtr ] then
|
||||
begin
|
||||
// throw exception
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
function TMWindow.SetTarget(ArrPtr: PRGB32): integer; overload;
|
||||
begin
|
||||
|
||||
Self.TargetMode:= w_ArrayPtr;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
unit Window;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, mufasatypes, graphics,
|
||||
LCLType
|
||||
|
||||
{$IFDEF LINUX}, xlib, x, xutil, ctypes{$ENDIF};
|
||||
|
||||
type
|
||||
TMWindow = class(TObject)
|
||||
function ReturnData(xs, ys, width, height: Integer): PRGB32;
|
||||
procedure FreeReturnData;
|
||||
procedure GetDimensions(var W, H: Integer);
|
||||
function CopyClientToBitmap(xs, ys, xe, ye: integer): TBitmap;
|
||||
|
||||
{$IFDEF LINUX}
|
||||
function SetTarget(XWindow: x.TWindow): integer; overload;
|
||||
{$ENDIF}
|
||||
|
||||
function SetTarget(Window: THandle; NewType: TTargetWindowMode): integer; overload;
|
||||
function SetTarget(ArrPtr: PRGB32): integer; overload;
|
||||
|
||||
constructor Create(Client: TObject);
|
||||
destructor Destroy; override;
|
||||
public
|
||||
// Reference to client.
|
||||
Client: TObject;
|
||||
|
||||
// Target Window Mode.
|
||||
TargetMode: TTargetWindowMode;
|
||||
|
||||
{$IFDEF MSWINDOWS}
|
||||
//Target handle; HWND
|
||||
TargetHandle : Hwnd;
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF LINUX}
|
||||
// X Display
|
||||
XDisplay: PDisplay;
|
||||
|
||||
// Connection Number
|
||||
XConnectionNumber: Integer;
|
||||
|
||||
// X Window
|
||||
CurWindow: x.TWindow;
|
||||
|
||||
// Desktop Window
|
||||
DesktopWindow: x.TWindow;
|
||||
|
||||
// X Screen
|
||||
XScreen: PScreen;
|
||||
|
||||
// X Screen Number
|
||||
XScreenNum: Integer;
|
||||
|
||||
// The X Image pointer.
|
||||
XWindowImage: PXImage;
|
||||
|
||||
{$IFDEF M_MEMORY_DEBUG}
|
||||
// XImageFreed should be True if there is currently no
|
||||
// XImage loaded. If one is loaded, XImageFreed is true.
|
||||
|
||||
// If ReturnData is called while XImageFreed is false,
|
||||
// we throw an exception.
|
||||
// Same for FreeReturnData with XImageFreed true.
|
||||
XImageFreed: Boolean;
|
||||
{$ENDIF}
|
||||
|
||||
{$ELSE}
|
||||
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
Client, // For the Client Class
|
||||
windowutil, // For utilities such as XImageToRawImage
|
||||
GraphType // For TRawImage
|
||||
;
|
||||
|
||||
constructor TMWindow.Create(Client: TObject);
|
||||
begin
|
||||
inherited Create;
|
||||
Self.Client := Client;
|
||||
{$IFDEF LINUX}
|
||||
Self.TargetMode := w_XWindow;
|
||||
|
||||
Self.XDisplay := XOpenDisplay(nil);
|
||||
if Self.XDisplay = nil then
|
||||
begin
|
||||
// throw Exception
|
||||
end;
|
||||
Self.XConnectionNumber:= ConnectionNumber(Self.XDisplay);
|
||||
Self.XScreen := XDefaultScreenOfDisplay(Self.XDisplay);
|
||||
Self.XScreenNum:= DefaultScreen(Self.XDisplay);
|
||||
|
||||
// The Root Window is the Desktop. :-)
|
||||
Self.DesktopWindow:= RootWindow(Self.XDisplay, Self.XScreenNum);
|
||||
Self.CurWindow:= Self.DesktopWindow;
|
||||
|
||||
{$ELSE}
|
||||
// Set Target mode for windows.
|
||||
{$ENDIF}
|
||||
|
||||
end;
|
||||
|
||||
destructor TMWindow.Destroy;
|
||||
begin
|
||||
|
||||
{$IFDEF LINUX}
|
||||
XCloseDisplay(Self.XDisplay);
|
||||
{$ENDIF}
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
function TMWindow.ReturnData(xs, ys, width, height: Integer): PRGB32;
|
||||
{$IFDEF LINUX}
|
||||
var
|
||||
Old_Handler: TXErrorHandler;
|
||||
{$ENDIF}
|
||||
begin
|
||||
case Self.TargetMode of
|
||||
w_XWindow:
|
||||
begin
|
||||
{$IFDEF LINUX}
|
||||
{ Should be this. }
|
||||
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
|
||||
|
||||
Self.XWindowImage := XGetImage(Self.XDisplay, Self.curWindow, xs, ys, width, height, AllPlanes, ZPixmap);
|
||||
if QWord(Self.XWindowImage) = 0 then
|
||||
begin
|
||||
Writeln('ReturnData: XGetImage Error. Dumping data now:');
|
||||
Writeln('xs, ys, width, height: ' + inttostr(xs) + ', ' + inttostr(ys) +
|
||||
', ' + inttostr(width) + ', ' + inttostr(height));
|
||||
Result := nil;
|
||||
XSetErrorHandler(Old_Handler);
|
||||
Exit;
|
||||
end;
|
||||
WriteLn(IntToStr(Self.XWindowImage^.width) + ', ' + IntToStr(Self.XWindowImage^.height));
|
||||
Result := PRGB32(Self.XWindowImage^.data);
|
||||
|
||||
XSetErrorHandler(Old_Handler);
|
||||
{$ELSE}
|
||||
WriteLn('Windows doesn''t support XImage');
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMWindow.FreeReturnData;
|
||||
begin
|
||||
if Self.TargetMode <> w_XWindow then
|
||||
begin
|
||||
// throw exception.
|
||||
exit;
|
||||
end;
|
||||
{$IFDEF LINUX}
|
||||
if(QWord(Self.XWindowImage) <> 0) then // 0, nil?
|
||||
begin
|
||||
XDestroyImage(Self.XWindowImage);
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function TMWindow.CopyClientToBitmap(xs, ys, xe, ye: integer): TBitmap;
|
||||
var
|
||||
w,h : Integer;
|
||||
ww, hh: Integer;
|
||||
{$IFDEF LINUX}
|
||||
Old_Handler: TXErrorHandler;
|
||||
Img: PXImage;
|
||||
Raw: TRawImage;
|
||||
Bmp: TBitmap;
|
||||
{$ENDIF}
|
||||
|
||||
begin
|
||||
Self.GetDimensions(w, h);
|
||||
writeln(inttostr(xs) + ', ' + inttostr(ys) + ' : ' + inttostr(xe) + ', ' +
|
||||
inttostr(ye));
|
||||
ww := xe-xs;
|
||||
hh := ye-ys;
|
||||
|
||||
case Self.TargetMode Of
|
||||
w_XWindow:
|
||||
begin
|
||||
{$IFDEF LINUX}
|
||||
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
|
||||
|
||||
if(xs < 0) or (ys < 0) or (xe > W) or (ye > H) then
|
||||
begin
|
||||
writeln('Faulty coordinates');
|
||||
XSetErrorHandler(Old_Handler);
|
||||
exit;
|
||||
end;
|
||||
|
||||
Img := XGetImage(Self.XDisplay, Self.curWindow, xs, ys, ww, hh, AllPlanes, ZPixmap);
|
||||
XImageToRawImage(Img, Raw);
|
||||
|
||||
Bmp := TBitmap.Create;
|
||||
Bmp.LoadFromRawImage(Raw, False);
|
||||
Result := Bmp;
|
||||
|
||||
{
|
||||
If you want to use some internal Bitmap system, BitBlt to it here.
|
||||
Don't forget to free Bmp!
|
||||
}
|
||||
//lclintf.BitBlt(Bmps[bitmap].Canvas.Handle, 0, 0, ww + 1, hh + 1, Bmp.Canvas.Handle, xs, ys, SRCCOPY);
|
||||
//Bmp.Free;
|
||||
|
||||
XDestroyImage(Img);
|
||||
XSetErrorHandler(Old_Handler);
|
||||
{$ELSE}
|
||||
writeln('Windows and tXWindow');
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMWindow.GetDimensions(var W, H: Integer);
|
||||
{$IFDEF LINUX}
|
||||
var
|
||||
Attrib: TXWindowAttributes;
|
||||
newx,newy : integer;
|
||||
childwindow : x.TWindow;
|
||||
Old_Handler: TXErrorHandler;
|
||||
{$ENDIF}
|
||||
begin
|
||||
case TargetMode of
|
||||
w_Window:
|
||||
begin
|
||||
end;
|
||||
w_XWindow:
|
||||
begin
|
||||
{$IFDEF LINUX}
|
||||
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
|
||||
if XGetWindowAttributes(Self.XDisplay, Self.CurWindow, @Attrib) <> 0 Then
|
||||
begin
|
||||
XTranslateCoordinates(Self.XDisplay, Self.CurWindow, Self.DesktopWindow, 0,0, @newx, @newy, @childwindow);
|
||||
W := Attrib.Width;
|
||||
H := Attrib.Height;
|
||||
end else
|
||||
begin
|
||||
W := -1;
|
||||
H := -1;
|
||||
end;
|
||||
XSetErrorHandler(Old_Handler);
|
||||
{$ELSE}
|
||||
WriteLn('You dummy! How are you going to use w_XWindow on non Linux systems?');
|
||||
{$ENDIF}
|
||||
end;
|
||||
w_ArrayPtr:
|
||||
begin
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{$IFDEF LINUX}
|
||||
function TMWindow.SetTarget(XWindow: x.TWindow): integer; overload;
|
||||
var
|
||||
Old_Handler: TXErrorHandler;
|
||||
begin
|
||||
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
|
||||
Self.CurWindow := XWindow;
|
||||
Self.TargetMode:= w_XWindow;
|
||||
XSetErrorHandler(Old_Handler);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
function TMWindow.SetTarget(Window: THandle; NewType: TTargetWindowMode): integer; overload;
|
||||
begin
|
||||
if NewType in [ w_XWindow, w_ArrayPtr ] then
|
||||
begin
|
||||
// throw exception
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
function TMWindow.SetTarget(ArrPtr: PRGB32): integer; overload;
|
||||
begin
|
||||
|
||||
Self.TargetMode:= w_ArrayPtr;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user