{ 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 . 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)); Result.Ptr := nil; Result.IncPtrWith := 0; XSetErrorHandler(Old_Handler); raise Exception.CreateFMT('TMWindow.ReturnData: ReturnData: XGetImage Error', []); 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; //Remove? 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; // Set's input focus on Linux, does not mean the window will look `active', but // it surely is. Try typing something after ActivateClient. 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} 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} // Returns dimensions of the Window 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; // Make this use GetDimensions, ray...? 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; // Set target to X-Window {$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} // Set target to Windows Window 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; // Set target to Bitmap 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.