1
0
mirror of https://github.com/moparisthebest/Simba synced 2024-08-13 16:53:59 -04:00
Simba/Units/MMLCore/window.pas

752 lines
21 KiB
ObjectPascal

{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer
MML is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
MML 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. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with MML. If not, see <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
Window class for the Mufasa Macro Library
}
unit Window;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, mufasatypes,
{$IFDEF MSWINDOWS}
windows, // For windows API
{$ENDIF}
graphics,
LCLType,
bitmaps,
LCLIntf // for ReleaseDC and such
{$IFDEF LINUX}, xlib, x, xutil, ctypes{$ENDIF};
type
{
TMWindow Class handles all interaction with the Operating System Display
Getting Window ID's, Window Bitmap Data, Window Size.
It also abstracts data allocation from the user. Downside is there can't
be more than one Data in memory.
EG: One uses ReturnData, but must Free the data with FreeReturnData;
If one calls ReturnData, one must first free the ReturnData, before
calling ReturnData again.
}
TMWindow = class(TObject)
function GetColor(x,y : integer) : TColor;
function ReturnData(xs, ys, width, height: Integer): TRetData;
procedure FreeReturnData;
procedure GetDimensions(out W, H: Integer);
function GetDimensionBox(out Box : TBox) : boolean;
function CopyClientToBitmap(xs, ys, xe, ye: integer): TBitmap;
procedure ActivateClient;
{$IFDEF LINUX}
function SetTarget(XWindow: x.TWindow): integer; overload;
{$ENDIF}
{$IFDEF MSWINDOWS}
function UpdateDrawBitmap:boolean;
{$ENDIF}
function SetTarget(Window: THandle; NewType: TTargetWindowMode): integer; overload;
function SetTarget(ArrPtr: PRGB32; Size: TPoint): integer; overload;
function SetTarget(Bitmap : TMufasaBitmap) : integer;overload;
procedure SetWindow(Window: TMWindow);
procedure SetDesktop;
procedure OnTargetBitmapDestroy( Bitmap : TMufasaBitmap);
{
Freeze Client Feature.
This will force the MWindow unit to Store the current Client's
data in whatever internal structure it will use, and returndata /
copyclienttobitmap will not renew this data until Unfreeze() is
called.
}
function Freeze: boolean;
function Unfreeze: boolean;
constructor Create;
destructor Destroy; override;
private
FreezeState: Boolean;
FrozenData : PRGB32;
FrozenSize : TPoint;
TargetBitmap : TMufasaBitmap;
public
// Target Window Mode.
TargetMode: TTargetWindowMode;
{$IFDEF MSWINDOWS}
//Target handle; HWND
TargetHandle : Hwnd;
DrawBmpDataPtr : PRGB32;
DesktopHWND : Hwnd;
DesktopDC : HDC;
//Works on linux as well, test it out
TargetDC : HDC;
DrawBitmap : TBitmap;
DrawBmpW,DrawBmpH : integer;
{$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;
// 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;
{$ELSE}
{$ENDIF}
ArrayPtr: PRGB32;
ArraySize: TPoint;
property Frozen: boolean read FreezeState;
end;
implementation
uses
Client, // For the Client Class
windowutil, // For utilities such as XImageToRawImage
GraphType // For TRawImage
;
constructor TMWindow.Create;
begin
inherited Create;
Self.FrozenData:= nil;
Self.FrozenSize := Classes.Point(-1,-1);
Self.FreezeState := False;
Self.ArrayPtr := nil;
Self.ArraySize := Classes.Point(-1, -1);
{$IFDEF MSWINDOWS}
Self.DrawBitmap := TBitmap.Create;
Self.DrawBitmap.PixelFormat:= pf32bit;
Self.TargetMode:= w_Window;
Self.TargetHandle:= 0;
Self.TargetDC := 0;
Self.DesktopHWND:= GetDesktopWindow;
Self.DesktopDC:= GetDC(0);
Self.SetDesktop;
Self.UpdateDrawBitmap;
{$ENDIF}
{$IFDEF LINUX}
Self.XImageFreed:=True;
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;
{$ENDIF}
end;
destructor TMWindow.Destroy;
begin
if FreezeState then
if FrozenData <> nil then
FreeMem(FrozenData);
{$IFDEF LINUX}
XCloseDisplay(Self.XDisplay);
{$ENDIF}
{$IFDEF MSWINDOWS}
if TargetMode = w_Window then
ReleaseDC(TargetHandle,TargetDC);
DrawBitmap.Free;
{$ENDIF}
inherited;
end;
procedure TMWindow.SetWindow(Window: TMWindow);
begin
case Window.TargetMode of
w_BMP :
Self.SetTarget(Window.TargetBitmap);
w_Window, w_HDC:
{$IFDEF WINDOWS}
Self.SetTarget(Window.TargetHandle, Window.TargetMode);
{$ELSE}
writeln('TMWindow.SetWindow - Handle not supported');
{$ENDIF}
// I don't think array can ever be set at this point.
// Let's just add it anyway. ;)
w_ArrayPtr:
Self.SetTarget(Window.ArrayPtr, Window.ArraySize);
w_XWindow:
{$IFDEF LINUX}
Self.SetTarget(Window.CurWindow);
{$ELSE}
writeln('TMWindow.SetWindow - XImage not supported');
{$ENDIF}
end;
end;
procedure TMWindow.SetDesktop;
begin
{$IFDEF LINUX}
Self.SetTarget(Self.DesktopWindow);
{$ELSE}
Self.SetTarget(Self.DesktopHWND, w_Window);
{$ENDIF}
end;
procedure TMWindow.OnTargetBitmapDestroy(Bitmap: TMufasaBitmap);
begin
Self.SetDesktop;
writeln('Our current bitmap is being freed! Defaulting to Desktop.');
// raise Exception.CreateFmt('Our targetbitmap has been destroyed, what now?',[]);
end;
function TMWindow.GetColor(x, y: integer): TColor;
begin
{$IFDEF WINDOWS}
if Self.TargetMode = w_Window then
Result := GetPixel(Self.TargetDC,x,y)
else
{$ENDIF}
begin
with ReturnData(x,y,1,1) do
Result := RGBToColor(Ptr[0].r,Ptr[0].g,Ptr[0].b);
FreeReturnData;
end;
end;
function TMWindow.ReturnData(xs, ys, width, height: Integer): TRetData;
var
{$IFDEF LINUX}
Old_Handler: TXErrorHandler;
{$ENDIF}
TmpData: PRGB32;
w,h : integer;
begin
Self.GetDimensions(w,h);
if (xs < 0) or (xs + width > w) or (ys < 0) or (ys + height > h) then
raise Exception.CreateFMT('TMWindow.ReturnData: The parameters passed are wrong; xs,ys %d,%d width,height %d,%d',[xs,ys,width,height]);
if Self.Frozen then
begin;
TmpData := Self.FrozenData;
Result.RowLen:= Self.FrozenSize.x;
Result.IncPtrWith:= Result.RowLen - width;
Inc(TmpData, ys * Result.RowLen + xs);
Result.Ptr:= tmpData;
end else
case Self.TargetMode of
w_BMP :
begin;
// Copy the pointer as we will perform operations on it.
TmpData := TargetBitmap.FData;
// Increase the pointer to the specified start of the data.
Result.RowLen:= TargetBitmap.Width;
Result.IncPtrWith:= Result.RowLen - width;
Inc(TmpData, ys * Result.RowLen + xs);
Result.Ptr := TmpData;
end;
w_Window:
begin
{$IFDEF MSWINDOWS}
BitBlt(Self.DrawBitmap.Canvas.Handle,0,0, width, height, Self.TargetDC, xs,ys, SRCCOPY);
Result.Ptr:= Self.DrawBmpDataPtr;
Result.IncPtrWith:= DrawBmpW - Width;
Result.RowLen:= DrawBmpW;
{$ENDIF}
end;
w_XWindow:
begin
{$IFDEF LINUX}
if not Self.XImageFreed then
Raise Exception.CreateFmt('ReturnData was called again without freeing'+
' the previously used data. Do not forget to'+
' call FreeReturnData', []);
{ 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));
raise Exception.CreateFMT('TMWindow.ReturnData: ReturnData: XGetImage Error', []);
Result.Ptr := nil;
Result.IncPtrWith := 0;
XSetErrorHandler(Old_Handler);
Exit;
end;
//WriteLn(IntToStr(Self.XWindowImage^.width) + ', ' + IntToStr(Self.XWindowImage^.height));
Result.Ptr := PRGB32(Self.XWindowImage^.data);
Result.IncPtrWith := 0;
Result.RowLen := width;
Self.XImageFreed:=False;
XSetErrorHandler(Old_Handler);
{$ELSE}
raise Exception.createFMT('ReturnData: You cannot use ' +
'the XImage mode on Windows.', []);
{$ENDIF}
end;
w_ArrayPtr:
begin
// Copy the pointer as we will perform operations on it.
TmpData := Self.ArrayPtr;
// Increase the pointer to the specified start of the data.
Result.RowLen:= Self.ArraySize.x;
Result.IncPtrWith:= Result.RowLen - width;
Inc(TmpData, ys * Result.RowLen + xs);
Result.Ptr := TmpData;
end;
end;
end;
procedure TMWindow.FreeReturnData;
begin
if (Self.TargetMode <> w_XWindow) or FreezeState then
Exit;
{$IFDEF LINUX}
if not Self.XImageFreed then
begin
Self.XImageFreed:=True;
if(QWord(Self.XWindowImage) <> 0) then // 0, nil?
begin
XDestroyImage(Self.XWindowImage);
end;
end;
{$ENDIF}
end;
// This will draw the ENTIRE client to a bitmap.
// And ReturnData / CopyClientToBitmap will always use this bitmap.
// They must NEVER update, unless Unfreeze is called.
// I am not entirely sure how to do this, yet.
// Best option for now seems to copy the entire data to a PRGB32,
// and use it like the ArrPtr mode.
// I currently added "Frozen", "FreezeState", "Freeze" and "Unfreeze".
// We will have to either "abuse" the current system, and set the client to
// PtrArray mode, or edit in some extra variables.
// (We will still need extra variables to remember the old mode,
// to which we will switch back with Unfreeze.)
// Several ways to do it, what's the best way?
// Also, should a box be passed to Freeze, or should we just copy the entire
// client?
function TMWindow.Freeze: Boolean;
var
w,h,x,y : integer;
PtrReturn : TRetData;
begin
if Self.FreezeState then
raise Exception.CreateFMT('TMWindow.Freeze: The window is already frozen.',[]);
Result := true;
Self.GetDimensions(w,h);
Self.FrozenSize := Classes.Point(w,h);
PtrReturn := Self.ReturnData(0,0,w,h);
GetMem(Self.FrozenData, w * h * sizeof(TRGB32));
Move(PtrReturn.Ptr[0], FrozenData[0], w*h*sizeof(TRGB32));
Self.FreeReturnData;
Self.FreezeState:=True;
end;
function TMWindow.Unfreeze: Boolean;
begin
if Self.FreezeState = false then
raise Exception.CreateFMT('TMWindow.Unfreeze: The window is not frozen.',[]);
FreeMem(Self.FrozenData);
Self.FrozenData := nil;
Result := True;
Self.FreezeState:=False;
end;
// Bugged. For params other than 0, 0, ClientWidth, ClientHeight
// if other type than w_XImage
// Also possibly thread bugged
function TMWindow.CopyClientToBitmap(xs, ys, xe, ye: integer): TBitmap;
var
w,h: Integer;
ww, hh: Integer;
Raw: TRawImage;
Bmp: TBitmap;
y : integer;
TempData : PRGB32;
{$IFDEF LINUX}
Old_Handler: TXErrorHandler;
Img: PXImage;
{$ENDIF}
begin
Self.GetDimensions(w, h);
ww := xe-xs;
hh := ye-ys;
if(xs < 0) or (ys < 0) or (xe >= W) or (ye >= H) then
Raise Exception.CreateFMT('CopyClientToBitmap TMWindow: Faulty coordinates (%d,%d)(%d,%d); Width/Height is (%d,%d)',[xs,ys,xe,ye,w,h]);
if Self.Frozen then
begin;
TempData:= GetMem((ww + 1) * (hh + 1) * sizeof(TRGB32));
for y := ys to ye do
Move(Self.FrozenData[y*Self.FrozenSize.x],TempData[(y-ys) * (ww+1)],(ww+1) * SizeOf(TRGB32));
ArrDataToRawImage(TempData,Classes.Point(ww + 1,hh + 1),Raw);
Bmp := TBitmap.Create;
Bmp.LoadFromRawImage(Raw,true);
Result := bmp;
end else
case Self.TargetMode Of
w_Window:
begin
{$IFDEF MSWINDOWS}
Result := TBitmap.Create;
Result.SetSize(ww+1,hh+1);
BitBlt(result.canvas.handle,0,0,ww+1,hh+1,
self.TargetDC,xs,ys, SRCCOPY);
{$ENDIF}
end;
w_XWindow:
begin
{$IFDEF LINUX}
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
Img := XGetImage(Self.XDisplay, Self.curWindow, xs, ys, ww+1, hh+1, AllPlanes, ZPixmap);
XImageToRawImage(Img, Raw);
Bmp := TBitmap.Create;
Bmp.LoadFromRawImage(Raw, False);
Result := Bmp;
XDestroyImage(Img);
XSetErrorHandler(Old_Handler);
{$ELSE}
raise Exception.createFMT('CopyClientToBitmap: You cannot use ' +
'the XImage mode on Windows.', []);
{$ENDIF}
end;
w_ArrayPtr:
begin
TempData:= GetMem((ww + 1) * (hh + 1) * sizeof(trgb32));
for y := ys to ye do
Move(Self.ArrayPtr[y*Self.ArraySize.x],TempData[(y-ys) * (ww+1)],(ww+1) * SizeOf(TRGB32));
ArrDataToRawImage(TempData,Classes.Point(ww+1,hh+1),Raw);
Bmp := TBitmap.Create;
Bmp.LoadFromRawImage(Raw,true);
Result := bmp;
end;
w_BMP:
begin
TempData:= GetMem((ww + 1) * (hh + 1) * sizeof(trgb32));
for y := ys to ye do
Move(TargetBitmap.FData[y*w],TempData[(y-ys) * (ww+1)],(ww+1) * SizeOf(TRGB32));
ArrDataToRawImage(TempData,Classes.Point(ww+1,hh+1),Raw);
Bmp := TBitmap.Create;
Bmp.LoadFromRawImage(Raw,true);
Result := bmp;
end;
end;
end;
procedure TMWindow.ActivateClient;
{$IFDEF LINUX}
var
Old_Handler: TXErrorHandler;
{$ENDIF}
begin
{$IFDEF MSWINDOWS}
if TargetMode = w_Window then
SetForegroundWindow(Self.TargetHandle);
{$ENDIF}
{$IFDEF LINUX}
if TargetMode = w_XWindow then
begin;
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
XSetInputFocus(Self.XDisplay,Self.CurWindow,RevertToParent,CurrentTime);
XFlush(Self.XDisplay);
XSetErrorHandler(Old_Handler);
end;
{$ENDIF}
end;
{$IFDEF MSWINDOWS} //Probably need one for Linux as well
function TMWindow.UpdateDrawBitmap :boolean;
var
w,h : integer;
BmpInfo : Windows.TBitmap;
begin
GetDimensions(w,h);
DrawBitmap.SetSize(w,h);
// DrawBitmap.PixelFormat:=
DrawBmpW := w;
DrawBmpH := h;
GetObject(DrawBitmap.Handle, SizeOf(BmpInfo), @BmpInfo);
DrawBmpDataPtr := BmpInfo.bmBits;
end;
{$ENDIF}
procedure TMWindow.GetDimensions(out W, H: Integer);
{$IFDEF LINUX}
var
Attrib: TXWindowAttributes;
newx,newy : integer;
childwindow : x.TWindow;
Old_Handler: TXErrorHandler;
{$ENDIF}
{$IFDEF MSWINDOWS}
var
Rect : TRect;
{$ENDIF}
begin
if Frozen then
begin;
w := FrozenSize.x;
h := FrozenSize.y;
end else
case TargetMode of
w_BMP :
begin
w := TargetBitmap.Width;
h := TargetBitmap.Height;
end;
w_Window:
begin
{$IFDEF MSWINDOWS}
GetWindowRect(Self.TargetHandle, Rect);
w:= Rect.Right - Rect.Left;
h:= Rect.Bottom - Rect.Top;
{$ENDIF}
end;
w_XWindow:
begin
{$IFDEF LINUX}
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
if XGetWindowAttributes(Self.XDisplay, Self.CurWindow, @Attrib) <> 0 Then
begin
{ I don't think we need this XTranslateCoordinates... :D }
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}
raise Exception.createFMT('GetDimensions: You cannot use ' +
'the XImage mode on Windows.', []);
{$ENDIF}
end;
w_ArrayPtr:
begin
W := Self.ArraySize.X;
H := Self.ArraySize.Y;
end;
end;
end;
function TMWindow.GetDimensionBox(out Box : TBox) : boolean;
function IntToTBox(x1,y1,x2,y2 : integer) : TBox;inline;
begin;
result.x1 := x1;
result.y1 := y1;
result.x2 := x2;
result.y2 := y2;
end;
{$IFDEF LINUX}
var
Attrib: TXWindowAttributes;
newx,newy : integer;
childwindow : x.TWindow;
Old_Handler: TXErrorHandler;
{$ENDIF}
{$IFDEF MSWINDOWS}
var
Rect : TRect;
{$ENDIF}
begin
result := false;
case TargetMode of
w_Window:
begin
{$IFDEF MSWINDOWS}
result := true;
GetWindowRect(Self.TargetHandle, Rect);
box := IntToTBox(Rect.Left,Rect.top,Rect.Right - 1,Rect.Bottom - 1);
{$ENDIF}
end;
w_XWindow:
begin
{$IFDEF LINUX}
result := true;
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
if XGetWindowAttributes(Self.XDisplay, Self.CurWindow, @Attrib) <> 0 Then
begin
{ I don't think we need this XTranslateCoordinates... :D }
XTranslateCoordinates(Self.XDisplay, Self.CurWindow, Self.DesktopWindow, 0,0, @newx, @newy, @childwindow);
box := IntToTBox(Attrib.x,Attrib.y,Attrib.x + Attrib.Width -1,Attrib.y +Attrib.Height-1 );
end else
box := IntToTBox(-1,-1,-1,-1);
XSetErrorHandler(Old_Handler);
{$ELSE}
raise Exception.createFMT('GetDimensions: You cannot use ' +
'the XImage mode on Windows.', []);
{$ENDIF}
end;
end;
end;
{$IFDEF LINUX}
function TMWindow.SetTarget(XWindow: x.TWindow): integer; overload;
var
Old_Handler: TXErrorHandler;
begin
if Self.Frozen then
raise Exception.CreateFMT('You cannot set a target when Frozen',[]);
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 Self.Frozen then
raise Exception.CreateFMT('You cannot set a target when Frozen',[]);
if NewType in [ w_XWindow, w_ArrayPtr ] then
raise Exception.createFMT('SetTarget: Invalid new type.', []);
case NewType of
w_Window :
begin;
{$IFDEF MSWINDOWS}
//We had the desktop as target -> Not freeing that DC!
if not Self.TargetDC= Self.DesktopDC then
ReleaseDC(Self.TargetHandle,Self.TargetDC);
Self.TargetHandle := Window;
if Window = Self.DesktopHWND then
Self.TargetDC := DesktopDC
else
Self.TargetDC := GetWindowDC(Window);
{$ENDIF}
end;
end;
{$IFDEF MSWINDOWS}
UpdateDrawBitmap;
{$ENDIF}
end;
{
This functionality is very BETA.
We have no way to send events to a window, so we should probably use the
desktop window?
eg: In mouse/keys: if Self.TargetMode not in [w_Window, w_XWindow], send it
to the desktop.
}
function TMWindow.SetTarget(ArrPtr: PRGB32; Size: TPoint): integer; overload;
begin
if Self.Frozen then
raise Exception.CreateFMT('You cannot set a target when Frozen',[]);
If Self.TargetMode = w_XWindow then
Self.FreeReturnData;
Self.ArrayPtr := ArrPtr;
Self.ArraySize := Size;
Self.TargetMode:= w_ArrayPtr;
{$IFDEF LINUX}
Self.CurWindow := Self.DesktopWindow;
{$ENDIF}
{$IFDEF WINDOWS}
Self.TargetHandle:= windows.GetDesktopWindow;
{$ENDIF}
end;
function TMWindow.SetTarget(Bitmap: TMufasaBitmap): integer;
begin
if Self.Frozen then
raise Exception.CreateFMT('You cannot set a target when Frozen',[]);
TargetBitmap := Bitmap;
self.TargetMode:= w_BMP;
Bitmap.OnDestroy:= @OnTargetBitmapDestroy;
end;
end.