Monday, May 9, 2011

Boyer-Moore Horspool return all occurrences in one go

First I would like to say that I'm sorry for not posting for quite some time now, but thanks to Simon H. who found a bug in original algorithm found here, I've managed to also extend the function to return all occurrences of a pattern in a string, without further introduction here's the code!
type
  TFSResults = array of Integer;

function FindStringMulti(const Value, Pattern: string;
  const CaseSensitive: Boolean = True;
  const StartPos: Integer = 1): TFSResults;
var
  Index: Integer;
  jIndex: Integer;
  kIndex: Integer;
  LLenPattern: Integer;
  LLenValue: Integer;
  LSkipTable: array[Char] of Integer;
  LChar: Char;

    function __SameChar: Boolean;
    begin
      if CaseSensitive then
        Result := (Value[Index] = Pattern[jIndex])
      else
        Result := (CompareText(Value[Index], Pattern[jIndex]) = 0);
    end; // function __SameChar: Boolean;

begin
  LLenPattern := Length(Pattern);
  if LLenPattern = 0 then
    Exit;
  for LChar := Low(Char) to High(Char) do
    LSkipTable[LChar] := LLenPattern;
  if CaseSensitive then begin
    for kIndex := 1 to LLenPattern -1 do
      LSkipTable[Pattern[kIndex]] := LLenPattern -kIndex;
  end else begin
    for kIndex := 1 to LLenPattern -1 do
      LSkipTable[Windows.CharLower(@Pattern[kIndex])^] := LLenPattern -kIndex;
  end; // if CaseSensitive then begin
  kIndex := LLenPattern + (StartPos -1);
  LLenValue := Length(Value);
  while (kIndex <= LLenValue) do begin
    Index := kIndex;
    jIndex := LLenPattern;
    while (jIndex >= 1) do begin
      if __SameChar then begin
        jIndex := jIndex -1;
        Index := Index -1;
      end else
        jIndex := -1;
      if jIndex = 0 then begin
        SetLength(Result, Length(Result) +1);
        Result[High(Result)] := Index +1;
        jIndex := -1;
      end; // if jIndex = 0 then begin
      kIndex := kIndex + LSkipTable[Value[kIndex]];
    end; // while (jIndex >= 1) do begin
  end; // while (kIndex <= LLenValue) do begin
end;

Enjoy!

Wednesday, February 2, 2011

Breaking News: 1st November 2011 RAD Studio deal!

Here's something that leaked from Embarcadero's future plans:
As of 1st November 2011 Embarcadero is proud to announce the release of Embarcadero RAD Studio XE Second Edition for as low as $100,— per year developer license. We will also include some new community based free services for registered customers, the services are: ednMigrate, ednBlogger, ednHelp.

What is included in the Embarcadero RAD Studio XE Second Edition:
- Delphi XE SE
- C++ Builder XE SE
- Rad PHP XE SE
- Delphi Prism XE SE
- cross platform: Windows, Mac and Linux
- full source code for VCL, RTL
- over 200 demo applications to help you get started
- latest updates included in the license

What is ednMigrate:
ednMigrate is a new community based service available for Embarcadero registered customers that will help you migrate your code from a earlier version of Delphi for example to the latest, you don't have to worry anymore about code compatibility.
You can access ednMigrate at http://ednmigrate.embarcadero.com/ and log in using your Embarcadero customer account.

What is ednBlogger:
We know that you want to share your knowledge with other developers, therefore Embarcadero will host your blog free of charge(applicable for customers only) for any Embarcadero product.
You can access ednBlogger at http://ednblogger.embarcadero.com/ and log in using your Embarcadero customer account.

What is ednHelp:
ednHelp is a new community based service available for Embarcadero registered customers that will host questions and answers related to application development, you can ask and answer as many questions as you like, the service is free of charge for all customers.
You can access ednHelp at http://ednhelp.embarcadero.com/ and log in using your Embarcadero customer account.

We have done everything we could in order to provide you with best prices for independent developers, students, new companies and existing customers:
Here are our latest prices:
TargetPrice
Independent Developers $200,—/year
Students $100,—/year
New companies $100,—/developer first year and $150,—/year starting from 2nd year
Existing customers $150,—/year
Schools $50,—/year
If you would like to do a test drive of any of our products before purchasing you can do so by navigating to http://testdrive.embarcadero.com/ select a product to download and don't forget that you can always write us a feedback at http://testdrive.embarcadero.com/feedback/ if you care to help us improve our services.

Because Embarcadero truly cares about it's customers, as of 1st February 2012 we will hold conferences all around the world so that developers can have a taste of latest technologies or share their knowledge, this is also a good opportunity for new businesses to find partners or students and independent developers to find jobs.
OK, OK you got me, it's NOT true, unfortunately... but it would be nice if Embarcadero would do something similar not the "Starter edition" stuff... which I personally disagree with it, first because it comes without source code or debugger(ewww...) and second because the price is still pretty high for students for example.
Personal appeal to Embarcadero, let's support schools and students shall we guys?! in some schools in Romania the pascal language is STILL present, however I'm NOT sure if that will be true in 1 or 2 years from now, given the fact that Microsoft is doing a terrific job spreading it's software all around the world, I would NOT be surprised if they will have Visual Studio in most schools.

And another thing, I get more than 60% of my blog hits from searches like "Delphi distiller", "Delphi XE distiller" and similar keywords, what does THAT mean to Embarcadero?! shit load of customers and money TOTALLY WASTED, is Embarcadero that rich?! probably...

One more thing, before people will start criticise me, please DO NOT THINK that $140,— per start edition or whatever the price is or will be is NOT a lot of money, you don't take into account countries that have thousands of Delphi developers which earn ~$500,—/month or less, so yes $140,— might not be a lot for US or European citizens but for other parts of the world it is.

Tuesday, February 1, 2011

Laptop specific functions

First I would like to thank each and every one of the developers from stackoverflow who helped me out in detecting if application is running on laptop by answering my question.
I have pushed the envelop further by defining some helper functions which retrieves laptop specific information and some other as well, so without further introduction here's the unit that I've wrote, feel free to use it in commercial and/or personal applications AT YOUR OWN RISK of course, also if you find some flaws(high probability -- haven't tested enough) please feel free to drop a comment.
unit uDGMobileUtils;

interface

(*******************************************************************************

  Author:
    Dorin Duminica

  Note:
    That Parts of the code are Copyright© of Microsoft Corporation.
    All Rights Reserved.

  Disclaimer:
    Using the following code represents your acknowledgement that YOU TAKE
    FULL RESPONSABILITY of any damage it can and/or might cause to your
    system, country, pets, etc.

  Requirements:
    According to Microsoft the following code should work starting from
    Windows 2000 Professional and Server

*******************************************************************************)

uses
  Windows;

{$Z4} // required in order to have 4 byte enumerated type

type
  SYSTEM_POWER_STATE =(
    PowerSystemUnspecified,
    PowerSystemWorking,
    PowerSystemSleeping1,
    PowerSystemSleeping2,
    PowerSystemSleeping3,
    PowerSystemHibernate,
    PowerSystemShutdown,
    PowerSystemMaximum);

{$Z1} // restore enumerated type to 1 byte

const
  SYSTEM_POWER_STATE_NAMES: array[SYSTEM_POWER_STATE] of string = (
    'Unspecified',
    'Working',
    'Sleeping 1',
    'Sleeping 2',
    'Sleeping 3',
    'Hibernate',
    'Shutdown',
    'Maximum');

type
  BATTERY_REPORTING_SCALE = record
    Granularity: ULONG;
    Capacity: ULONG;
  end;

  PBATTERY_REPORTING_SCALE = ^BATTERY_REPORTING_SCALE;

type
  SYSTEM_POWER_CAPABILITIES = record
    // If this member is TRUE, there is a system power button.
    PowerButtonPresent: Boolean;
    // If this member is TRUE, there is a system sleep button.
    SleepButtonPresent: Boolean;
    // If this member is TRUE, there is a lid switch.
    LidPresent: Boolean;
    // for S1 —> S5 check microsoft site
    SystemS1: Boolean;
    SystemS2: Boolean;
    SystemS3: Boolean;
    SystemS4: Boolean;
    SystemS5: Boolean;
    // If this member is TRUE, the operating system supports power off state S5 (soft off).
    HiberFilePresent: Boolean;
    // If this member is TRUE, the system supports wake capabilities.
    FullWake: Boolean;
    // If this member is TRUE, the system supports video display dimming capabilities.
    VideoDimPresent: Boolean;
    // If this member is TRUE, the system supports APM BIOS power management features.
    ApmPresent: Boolean;
    // If this member is TRUE, there is an uninterruptible power supply (UPS).
    UpsPresent: Boolean;
    // If this member is TRUE, the system supports thermal zones.
    ThermalControl: Boolean;
    // If this member is TRUE, the system supports processor throttling.
    ProcessorThrottle: Boolean;
    // The minimum level of system processor throttling supported,
    // expressed as a percentage.
    ProcessorMinThrottle: UCHAR;
    // The maximum level of system processor throttling supported,
    // expressed as a percentage.
    ProcessorMaxThrottle: UCHAR;
    // If this member is TRUE, the system supports the hybrid sleep state.
    // Windows Server 2003 and Windows XP:  Hybrid sleep is not supported.
    // Windows 2000:  This member is not supported.
    FastSystemS4: Boolean;
    // reserved
    spare2: array [0 .. 3] of UCHAR;
    // If this member is TRUE, the system supports allowing the removal of power
    // to fixed disk devices.
    DiskSpinDown: Boolean;
    // reserved
    spare3: array [0 .. 7] of UCHAR;
    // If this member is TRUE, there are one or more batteries in the system.
    SystemBatteriesPresent: Boolean;
    // If this member is TRUE, the system batteries are short-term.
    // Short-term batteries are used in uninterruptible power supplies (UPS).
    BatteriesAreShortTerm: Boolean;
    // A BATTERY_REPORTING_SCALE structure that contains information about
    // how system battery metrics are reported.
    BatteryScale: array [0 .. 2] of BATTERY_REPORTING_SCALE;
    // The lowest system sleep state (Sx) that will generate a wake event when
    // the system is on AC power. This member must be one of the
    // SYSTEM_POWER_STATE enumeration type values.
    AcOnLineWake: SYSTEM_POWER_STATE;
    // The lowest system sleep state (Sx) that will generate a wake event via
    // the lid switch. This member must be one of the SYSTEM_POWER_STATE
    // enumeration type values.
    SoftLidWake: SYSTEM_POWER_STATE;
    // To wake the computer using the RTC, the operating system must also
    // support waking from the sleep state the computer is in when the RTC
    // generates the wake event. Therefore, the effective lowest sleep state
    // from which an RTC wake event can wake the computer is the lowest sleep
    // state supported by the operating system that is equal to or higher than
    // the value of RtcWake. To determine the sleep states that the operating
    // system supports, check the SystemS1, SystemS2, SystemS3, and SystemS4 members.
    RtcWake: SYSTEM_POWER_STATE;
    // The minimum allowable system power state supporting wake events.
    // This member must be one of the SYSTEM_POWER_STATE enumeration type values.
    // Note that this state may change as different device drivers are
    // installed on the system.
    MinDeviceWakeState: SYSTEM_POWER_STATE;
    // The default system power state used if an application calls
    // RequestWakeupLatency with LT_LOWEST_LATENCY. This member must be one of
    // the SYSTEM_POWER_STATE enumeration type values.
    DefaultLowLatencyWake: SYSTEM_POWER_STATE;
  end;

  PSYSTEM_POWER_CAPABILITIES = ^SYSTEM_POWER_CAPABILITIES;

type
  TACLineStatus = (
    // battery
    acsOffline = 0,
    // plugged in
    acsOnline = 1,
    acsUnknown = 255);

type
  TBatteryState = (
    // High—the battery capacity is at more than 66 percent
    bsHigh = 1,
    // Low—the battery capacity is at less than 33 percent
    bsLow = 2,
    // Critical—the battery capacity is at less than five percent
    bsCritical = 4,
    bsCharging = 8,
    bsNoSystemBattery = 128,
    // Unknown status—unable to read the battery flag information
    bsUnknown = 255);

  TBatteryStatus = set of TBatteryState;

  function GetPwrCapabilities(lpSystemPowerCapabilities: PSYSTEM_POWER_CAPABILITIES): Boolean; stdcall;
  function IsAdminOverrideActive: Boolean; stdcall;
  function IsPwrHibernateAllowed: Boolean; stdcall;
  function IsPwrShutdownAllowed: Boolean; stdcall;
  function IsPwrSuspendAllowed: Boolean; stdcall;

  // utility
  function IsLidPresent: Boolean;
  function IsRunningMobile: Boolean;
  function IsRunningOnBattery: Boolean;
  function IsPowerBtnPresent: Boolean;
  function IsApmPresent: Boolean;
  function IsUpsPresent: Boolean;
  function IsThermalControl: Boolean;
  function GetACLineStatus: TACLineStatus;
  function GetACLineStatusName(const AACLineStatus: TACLineStatus): string;
  function GetBatteryStatus: TBatteryStatus;
  function GetBatteryStateName(const ABatteryState: TBatteryState): string;
  function GetBatteryStatusStr(const ABatteryState: TBatteryStatus;
    const ADelimiter: Char = ','): string;
  function GetBatteryLifePercent: Byte;
  function GetBatteryLifeTime: DWORD;
  function GetBatteryLifeTimeFull: DWORD;
  function GetNumberOfProcessors: DWORD;
  function GetSystemPowerStateName(const ASystemPowerState: SYSTEM_POWER_STATE): string;

implementation

uses
  SysUtils,
  Classes;

const
  powrproflib = 'powrprof.dll';

function GetPwrCapabilities(lpSystemPowerCapabilities: PSYSTEM_POWER_CAPABILITIES): Boolean; external powrproflib name 'GetPwrCapabilities';
function IsAdminOverrideActive: Boolean; external powrproflib name 'IsAdminOverrideActive';
function IsPwrHibernateAllowed: Boolean; external powrproflib name 'IsPwrHibernateAllowed';
function IsPwrShutdownAllowed: Boolean; external powrproflib name 'IsPwrShutdownAllowed';
function IsPwrSuspendAllowed: Boolean; external powrproflib name 'IsPwrSuspendAllowed';

function IsLidPresent: Boolean;
var
  LSYSTEM_POWER_CAPABILITIES: SYSTEM_POWER_CAPABILITIES;
begin
  Result := GetPwrCapabilities(@LSYSTEM_POWER_CAPABILITIES);
  if Result then
    Result := LSYSTEM_POWER_CAPABILITIES.LidPresent;
end;

function IsRunningMobile: Boolean;
begin
  Result := IsLidPresent or IsRunningOnBattery;
end;

function IsRunningOnBattery: Boolean;
begin
  Result := (GetACLineStatus = acsOffline);
end;

function IsPowerBtnPresent: Boolean;
var
  LSYSTEM_POWER_CAPABILITIES: SYSTEM_POWER_CAPABILITIES;
begin
  Result := GetPwrCapabilities(@LSYSTEM_POWER_CAPABILITIES);
  if Result then
    Result := LSYSTEM_POWER_CAPABILITIES.PowerButtonPresent;
end;

function IsApmPresent: Boolean;
var
  LSYSTEM_POWER_CAPABILITIES: SYSTEM_POWER_CAPABILITIES;
begin
  Result := GetPwrCapabilities(@LSYSTEM_POWER_CAPABILITIES);
  if Result then
    Result := LSYSTEM_POWER_CAPABILITIES.ApmPresent;
end;

function IsUpsPresent: Boolean;
var
  LSYSTEM_POWER_CAPABILITIES: SYSTEM_POWER_CAPABILITIES;
begin
  Result := GetPwrCapabilities(@LSYSTEM_POWER_CAPABILITIES);
  if Result then
    Result := LSYSTEM_POWER_CAPABILITIES.UpsPresent;
end;

function IsThermalControl: Boolean;
var
  LSYSTEM_POWER_CAPABILITIES: SYSTEM_POWER_CAPABILITIES;
begin
  Result := GetPwrCapabilities(@LSYSTEM_POWER_CAPABILITIES);
  if Result then
    Result := LSYSTEM_POWER_CAPABILITIES.ThermalControl;
end;

function GetACLineStatus: TACLineStatus;
var
  LSystemPowerStatus: TSystemPowerStatus;
begin
  Result := acsUnknown;
  if GetSystemPowerStatus(LSystemPowerStatus) then
    Result := TACLineStatus(LSystemPowerStatus.ACLineStatus);
end;

function GetACLineStatusName(const AACLineStatus: TACLineStatus): string;
begin
  Result := 'Unknown';
  case AACLineStatus of
    acsOffline: Result := 'Offline';
    acsOnline: Result := 'Online';
  end; // case AACLineStatus of
end;

function GetBatteryStatus: TBatteryStatus;
var
  LSystemPowerStatus: TSystemPowerStatus;

    procedure CheckState(const ABatteryState: TBatteryState);
    begin
      if (LSystemPowerStatus.BatteryFlag and Ord(ABatteryState)) = Ord(ABatteryState) then
        Include(Result, ABatteryState);
    end; // procedure CheckState(const ABatteryState: TBatteryState);

begin
  Result := [];
  if GetSystemPowerStatus(LSystemPowerStatus) then begin
    CheckState(bsHigh);
    CheckState(bsLow);
    CheckState(bsCritical);
    CheckState(bsCharging);
    CheckState(bsNoSystemBattery);
    CheckState(bsUnknown);
  end else
    Result := [bsUnknown];
end;

function GetBatteryStateName(const ABatteryState: TBatteryState): string;
begin
  case ABatteryState of
    bsHigh: Result := 'High';
    bsLow: Result := 'Low';
    bsCritical: Result := 'Critical';
    bsCharging: Result := 'Charging';
    bsNoSystemBattery: Result := 'No system battery';
    bsUnknown: Result := 'Unknown';
  end; // case ABatteryState of
end;

function GetBatteryStatusStr(const ABatteryState: TBatteryStatus;
  const ADelimiter: Char): string;
var
  LBatteryState: TBatteryState;
  LNames: TStringList;
begin
  Result := EmptyStr;
  LNames := TStringList.Create;
  try
    LNames.Delimiter := ADelimiter;
    for LBatteryState in ABatteryState do
      LNames.Add(GetBatteryStateName(LBatteryState));
    Result := LNames.DelimitedText;
  finally
    FreeAndNil(LNames);
  end; // tryf
end;

function GetBatteryLifePercent: Byte;
var
  LSystemPowerStatus: TSystemPowerStatus;
begin
  Result := 0;
  if GetSystemPowerStatus(LSystemPowerStatus) then
    // The percentage of full battery charge remaining.
    // This value in the range 0 to 100 or 255 if status is unknown.
    Result := LSystemPowerStatus.BatteryLifePercent;
end;

function GetBatteryLifeTime: DWORD;
var
  LSystemPowerStatus: TSystemPowerStatus;
begin
  Result := DWORD(-1);
  if GetSystemPowerStatus(LSystemPowerStatus) then
    // The number of seconds of battery life remaining,
    // or –1 if remaining seconds are unknown.
    Result := LSystemPowerStatus.BatteryLifeTime;
end;

function GetBatteryLifeTimeFull: DWORD;
var
  LSystemPowerStatus: TSystemPowerStatus;
begin
  Result := DWORD(-1);
  if GetSystemPowerStatus(LSystemPowerStatus) then
    // The number of seconds of battery life when at full charge,
    // or –1 if full battery lifetime is unknown.
    Result := LSystemPowerStatus.BatteryFullLifeTime;
end;

function GetNumberOfProcessors: DWORD;
var
  LSystemInfo: TSystemInfo;
begin
  GetSystemInfo(LSystemInfo);
  // number of processor means number of threads
  // i.e. a processor with 4 cores can have 8 threads
  Result := LSystemInfo.dwNumberOfProcessors;
end;

function GetSystemPowerStateName(const ASystemPowerState: SYSTEM_POWER_STATE): string;
begin
  Result := SYSTEM_POWER_STATE_NAMES[ASystemPowerState];
end;

end.
How to use it:
a) drop a memo and a button on the form, rename the memo to "edInfo"
b) double-click the button and copy-paste the following code
procedure TForm1.Button1Click(Sender: TObject);

  procedure AddBool(const s: string; const Value: Boolean);
  begin
    edInfo.Lines.Add(Format('%s = %s', [s, BoolToStr(Value, True)]));
  end; // procedure AddBool(const s: string; const Value: Boolean);

  procedure AddString(const s, Value: string);
  begin
     edInfo.Lines.Add(Format('%s = %s', [s, Value]));
  end; // procedure AddString(const s, Value: string);

  procedure AddPercent(const s: string; const Value: Byte);
  begin
    edInfo.Lines.Add(Format('%s = %d%%', [s, Value]));
  end; // procedure AddPercent(const s: string; const Value: Byte);

  procedure AddSeconds(const s: string; const Value: DWORD);
  begin
    edInfo.Lines.Add(Format('%s = %d sec.', [s, Value]));
  end; // procedure AddSeconds(const s: string; const Value: DWORD);

  procedure AddDWord(const s: string; const Value: DWORD);
  begin
    edInfo.Lines.Add(Format('%s = %d', [s, Value]));
  end; // procedure AddDWord(const s: string; const Value: DWORD);

begin
  edInfo.Clear;
  AddBool('IsLidPresent', IsLidPresent);
  AddBool('IsRunningMobile', IsRunningMobile);
  AddBool('IsRunningOnBattery', IsRunningOnBattery);
  AddBool('IsPowerBtnPresent', IsPowerBtnPresent);
  AddBool('IsApmPresent', IsApmPresent);
  AddBool('IsUpsPresent', IsUpsPresent);
  AddBool('IsThermalControl', IsThermalControl);
  AddString('GetACLineStatus', GetACLineStatusName(GetACLineStatus));
  AddString('GetBatteryStatusStr', GetBatteryStatusStr(GetBatteryStatus));
  AddPercent('GetBatteryLifePercent', GetBatteryLifePercent);
  // if GetBatteryLifeTime = -1 it means that laptop is either plugged in OR
  // it is running on battery for a few seconds -- Windows did NOT detect
  // yet or it can't tell for certain how many seconds left
  // also the value might increase in a couple of seconds
  AddSeconds('GetBatteryLifeTime', GetBatteryLifeTime);
  // in my tests GetBatteryLifeTimeFull retrieves only -1 it might have something
  // to do with the fact that my laptop is only a couple of days old
  // or something fails -- I'm NOT 100% sure on this, please feel free to comment
  AddSeconds('GetBatteryLifeTimeFull', GetBatteryLifeTimeFull);
  AddDWord('GetNumberOfProcessors', GetNumberOfProcessors);
end;
c) and last but not least HAVE FUN!!

Wednesday, January 26, 2011

Fun with DWM


Sooo... you like the "Peak preview" of Windows 7?! If so, then I bet you would want to play with it in your Delphi application, correct?! cool! here's how you do it in a few steps:

a) create a new VCL forms application;
b) add Dwmapi to uses clause;
c) copy and paste and paste from the following code;

unit Unit1;

interface

uses
  Windows,
  Messages,
  SysUtils,
  Variants,
  Classes,
  Graphics,
  Controls,
  Forms,
  Dialogs,
  Dwmapi,
  StdCtrls,
  ExtCtrls,
  Generics.Collections;

type
  TDGWindow = record
    StrCaption: string;
    StrClassName: string;
    Handle: HWND;
  end;

  TDGWindowList = class(TList);

type
  TfrmMain = class(TForm)
    Panel1: TPanel;
    lbWindows: TListBox;
    bnRefresh: TButton;
    bnPreview: TButton;
    procedure FormDestroy(Sender: TObject);
    procedure bnRefreshClick(Sender: TObject);
    procedure bnPreviewClick(Sender: TObject);
    procedure lbWindowsDblClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    FWindowList: TDGWindowList;
    FTumbnail: HTHUMBNAIL;
    FPreviewEnabled: Boolean;
  private
    procedure PreviewWindow(const ASource, ADest: HWND; const ARect: TRect);
    procedure PreviewDisable;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}

function FindWindowExtd(partialTitle: string): HWND;
var
  hWndTemp: hWnd;
  iLenText: Integer;
  cTitletemp: array [0..254] of Char;
  sTitleTemp: string;
begin
  hWndTemp := FindWindow(nil, nil);
  while hWndTemp <> 0 do begin
    iLenText := GetWindowText(hWndTemp, cTitletemp, 255);
    sTitleTemp := cTitletemp;
    sTitleTemp := UpperCase(copy( sTitleTemp, 1, iLenText));
    partialTitle := UpperCase(partialTitle);
    if pos( partialTitle, sTitleTemp ) <> 0 then
      Break;
    hWndTemp := GetWindow(hWndTemp, GW_HWNDNEXT);
  end;
  result := hWndTemp;
end;

procedure TfrmMain.bnPreviewClick(Sender: TObject);
var
  Index: Integer;
  LRect: TRect;
begin
  Index := lbWindows.ItemIndex;
  if Index < 0 then
    Exit;
  LRect := Rect(5, 5,
    Self.Width -Panel1.Width -20,
    Self.Height -10);
  PreviewWindow(
    FWindowList[Index].Handle,
    Self.Handle,
    LRect);
end;

procedure TfrmMain.bnRefreshClick(Sender: TObject);
var
  LHDesktop: HWND;
  LHWindow: HWND;
  LHParent: HWND;
  LExStyle: DWORD;
  LBuffer: array[0..255] of char;
  LWindow: TDGWindow;
begin
  lbWindows.Items.BeginUpdate;
  lbWindows.Items.Clear;
  FWindowList.Clear;
  LHDesktop := GetDeskTopWindow;
  LHWindow := GetWindow(LHDesktop, GW_CHILD);
  while LHWindow <> 0 do begin
    LWindow.Handle := LHWindow;
    GetWindowText(LHWindow, LBuffer, Length(LBuffer));
    LHParent := GetWindowLong(LHWindow, GWL_HWNDPARENT);
    LExStyle := GetWindowLong(LHWindow, GWL_EXSTYLE);
    if IsWindowVisible(LHWindow) and (LBuffer <> EmptyStr) and
        ((LHParent = 0) or (LHParent = LHDesktop)) and
        ((LExStyle and WS_EX_TOOLWINDOW = 0) or (LExStyle and WS_EX_APPWINDOW <> 0))
        then begin
      lbWindows.Items.Add(LBuffer);
      LWindow.StrCaption := LBuffer;
      GetClassName(LHWindow, LBuffer, Length(LBuffer));
      LWindow.StrClassName := LBuffer;
      FWindowList.Add(LWindow);
    end; // if IsWindowVisible(LHWindow) and (LBuffer <> EmptyStr) and ...
    LHWindow := GetWindow(LHWindow, GW_HWNDNEXT);
  end; // while LHWindow <> 0 do begin
  lbWindows.Items.EndUpdate;
  if lbWindows.Items.Count > 0 then
    lbWindows.ItemIndex := 0;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  FPreviewEnabled := False;
  FWindowList := TDGWindowList.Create;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  FWindowList.Clear;
  FreeAndNil(FWindowList);
  PreviewDisable;
end;

procedure TfrmMain.lbWindowsDblClick(Sender: TObject);
begin
  bnPreview.Click;
end;

procedure TfrmMain.PreviewDisable;
begin
  if FPreviewEnabled then
    FPreviewEnabled := NOT Succeeded(DwmUnregisterThumbnail(FTumbnail));
end;

procedure TfrmMain.PreviewWindow(const ASource, ADest: HWND; const ARect: TRect);
var
  LResult: HRESULT;
  LThumpProp: DWM_THUMBNAIL_PROPERTIES;
begin
  if NOT DwmCompositionEnabled then begin
    MessageDlg('DWM composition is NOT enabled.', mtWarning, [mbOK], 0);
    Exit;
  end; // if NOT DwmCompositionEnabled then begin
  PreviewDisable;
  FPreviewEnabled := Succeeded(DwmRegisterThumbnail(ADest, ASource, @FTumbnail));
  if FPreviewEnabled then begin
    LThumpProp.dwFlags := DWM_TNP_SOURCECLIENTAREAONLY or DWM_TNP_VISIBLE or
      DWM_TNP_OPACITY or DWM_TNP_RECTDESTINATION;
    LThumpProp.fSourceClientAreaOnly := False;
    LThumpProp.fVisible := True;
    LThumpProp.opacity := 200;
    LThumpProp.rcDestination := ARect;
    LResult := DwmUpdateThumbnailProperties(FTumbnail, LThumpProp);
    FPreviewEnabled := (LResult = S_OK);
  end else
    MessageDlg('Cannot link to window  ' + IntToStr(ASource), mtError, [mbOK], 0);
end;

end.
or you simply download the demo application.
d) have fun!!

Saturday, January 15, 2011

uDGVMUtils version 1.1 thanks to Chee Meng

Thanks to Chee Meng I've added a detection scheme for Virtual Box.
Please let me know of any scenario in which a function fails to return properly so that I can modify the code.
unit uDGVMUtils;

interface

(*******************************************************************************

  uDGVMUtils -- is an attempt to create one of the best virtual machine
    detector methods, feel free to contribute in any way you wish.

  Version 1.1, 2010-01-15

  Copyright© you are free to use it for comercial, private or both purposes

  Contributors:
    Dorin Duminica
    Chee Meng

*******************************************************************************)

type
  TVMWareVersion = (
    vvExpress = 1,
    vvESX,
    vvGSX,
    vvWorkstation,
    vvUnknown,
    vvNative);

const
  VMWARE_VERSION_STRINGS: array [TVMWareVersion] of string = (
    'Express',
    'ESX',
    'GSX',
    'Workstation',
    'Unknown',
    'Native');

type
  TVirtualMachineType = (
    vmNative,
    vmVMWare,
    vmWine,
    vmVirtualPC,
    vmVirtualBox);

const
  VIRTUALMACHINE_STRINGS: array[TVirtualMachineType] of string = (
    'Native',
    'VMWare',
    'Wine',
    'Virtual PC',
    'Virtual Box');

function IsRunningVMWare(var AVMWareVersion: TVMWareVersion): Boolean; overload;
function IsRunningVMWare: Boolean; overload;
function IsRunningWine(var AWineVersion: string): Boolean; overload;
function IsRunningWine: Boolean; overload;
function IsRunningVirtualPC: Boolean;
function IsRunningVBox: Boolean;
function IsRunningVM(var AVMVersion: string): Boolean; overload;
function IsRunningVM: Boolean; overload;

implementation

uses
  SysUtils,
  Windows;

function IsRunningVMWare(var AVMWareVersion: TVMWareVersion): Boolean;
const
  CVMWARE_FLAG = $564D5868;
var
  LFlag: Cardinal;
  LVersion: Cardinal;
begin
  LFlag := 0;
  try
    asm
      push eax
      push ebx
      push ecx
      push edx

      mov eax, 'VMXh'
      mov ecx, 0Ah
      mov dx, 'VX'

      in eax, dx

      mov LFlag, ebx
      mov LVersion, ecx

      pop edx
      pop ecx
      pop ebx
      pop eax
    end;
  except
//  uncomment next two lines if you wish to see exception
//    on E: Exception do
//      ShowMessage(E.message);
  end; // trye
  if LFlag = CVMWARE_FLAG then begin
    Result := True;
    case LVersion of
      1: AVMWareVersion := vvExpress;
      2: AVMWareVersion := vvESX;
      3: AVMWareVersion := vvGSX;
      4: AVMWareVersion := vvWorkstation;
      else
        AVMWareVersion := vvUnknown;
    end
  end else begin
    Result := False;
    AVMWareVersion := vvNative;
  end; // if LFlag = CVMWARE_FLAG then begin
end;

function IsRunningVMWare: Boolean;
var
  LVMWareVersion: TVMWareVersion;
begin
  Result := IsRunningVMWare(LVMWareVersion);
end;

function IsRunningWine(var AWineVersion: string): Boolean;
type
  TWineGetVersion = function: PAnsiChar;{$IFDEF Win32}stdcall;{$ENDIF}
  TWineNTToUnixFileName = procedure (P1: Pointer; P2: Pointer);{$IFDEF Win32}stdcall;{$ENDIF}
var
  LHandle: THandle;
  LWineGetVersion: TWineGetVersion;
  LWineNTToUnixFileName: TWineNTToUnixFileName;
begin
  Result := False;
  AWineVersion := 'Unknown';
  LHandle := LoadLibrary('ntdll.dll');
  if LHandle > 32 then begin
    LWineGetVersion := GetProcAddress(LHandle, 'wine_get_version');
    LWineNTToUnixFileName := GetProcAddress(LHandle, 'wine_nt_to_unix_file_name');
    if Assigned(LWineGetVersion) or Assigned(LWineNTToUnixFileName) then begin
      Result := True;
      if Assigned(LWineGetVersion) then
        AWineVersion := StrPas(LWineGetVersion);
    end; // if Assigned(LWineGetVersion) or ...
    FreeLibrary(LHandle);
  end; // if LHandle > 32 then begin
end;

function IsRunningWine: Boolean;
var
  LWineVersion: string;
begin
  Result := IsRunningWine(LWineVersion);
end;

function IsRunningVirtualPC: Boolean;
asm
  push ebp;
  mov ebp, esp;

  mov ecx, offset @exception_handler;

  push ebx;
  push ecx;

  push dword ptr fs:[0];
  mov dword ptr fs:[0], esp;

  mov ebx, 0; // Flag
  mov eax, 1; // VPC function number

  // call VPC
  db $0F, $3F, $07, $0B

  mov eax, dword ptr ss:[esp];
  mov dword ptr fs:[0], eax;

  add esp, 8;

  test ebx, ebx;

  setz al;

  lea esp, dword ptr ss:[ebp-4];
  mov ebx, dword ptr ss:[esp];
  mov ebp, dword ptr ss:[esp+4];

  add esp, 8;

  jmp @ret1;

  @exception_handler:
  mov ecx, [esp+0Ch];
  mov dword ptr [ecx+0A4h], -1; // EBX = -1 ->; not running, ebx = 0 -> running
  add dword ptr [ecx+0B8h], 4; // ->; skip past the call to VPC
  xor eax, eax; // exception is handled

  @ret1:
end;

function IsRunningVBox: Boolean;

  function Test1: Boolean;
  var
    LHandle: Cardinal;
  begin
    Result := False;
    try
      LHandle := LoadLibrary('VBoxHook.dll');
      Result := (LHandle <> 0);
      if Result then
        FreeLibrary(LHandle);
    except
    end; // trye
  end; // function Test1: Boolean;

  function Test2: Boolean;
  var
    LHandle: Cardinal;
  begin
    Result := False;
    try
      LHandle := CreateFile(
        '\\\\.\\\VBoxMiniRdrDN',
        GENERIC_READ,
        FILE_SHARE_READ,
        NIL,
        OPEN_EXISTING,
        FILE_ATTRIBUTE_NORMAL,
        0);
      Result := (LHandle <> INVALID_HANDLE_VALUE);
      if Result then
        CloseHandle(LHandle);
    except
    end; // trye
  end; // function Test2: Boolean;

begin
  Result := Test1 or Test2;
end;

function IsRunningVM(var AVMVersion: string): Boolean;
begin
  AVMVersion := VIRTUALMACHINE_STRINGS[vmNative];
  Result := True;
  if IsRunningWine then
    AVMVersion := VIRTUALMACHINE_STRINGS[vmWine]
  else
    if IsRunningVMWare then
      AVMVersion := VIRTUALMACHINE_STRINGS[vmVMWare]
    else
      if IsRunningVirtualPC then
        AVMVersion := VIRTUALMACHINE_STRINGS[vmWine]
      else
        if IsRunningVBox then
          AVMVersion := VIRTUALMACHINE_STRINGS[vmVirtualBox]
        else begin
          AVMVersion := VIRTUALMACHINE_STRINGS[vmNative];
          Result := False;
        end;
end;

function IsRunningVM: Boolean;
var
  LVMVersion: string;
begin
  Result := IsRunningVM(LVMVersion);
end;

end.
HAVE FUN

Wednesday, January 12, 2011

Is your app running in a virtual machine?

Here's an extremely simple unit that will check if your application is running under VMWare, Wine and or Virtual PC:
unit uDGVMUtils;

interface

type
  TVMWareVersion = (
    vvExpress = 1,
    vvESX,
    vvGSX,
    vvWorkstation,
    vvUnknown,
    vvNative);

const
  VMWARE_VERSION_STRINGS: array [TVMWareVersion] of string = (
    'Express',
    'ESX',
    'GSX',
    'Workstation',
    'Unknown',
    'Native');

type
  TVirtualMachineType = (
    vmNative,
    vmVMWare,
    vmWine,
    vmVirtualPC);

const
  VIRTUALMACHINE_STRINGS: array[TVirtualMachineType] of string = (
    'Native',
    'VMWare',
    'Wine',
    'Virtual PC');

function IsRunningVMWare(var AVMWareVersion: TVMWareVersion): Boolean; overload;
function IsRunningVMWare: Boolean; overload;
function IsRunningWine(var AWineVersion: string): Boolean; overload;
function IsRunningWine: Boolean; overload;
function IsRunningVirtualPC: Boolean;
function IsRunningVM(var AVMVersion: string): Boolean; overload;
function IsRunningVM: Boolean; overload;

implementation

uses
  SysUtils,
  Windows;

function IsRunningVMWare(var AVMWareVersion: TVMWareVersion): Boolean;
const
  CVMWARE_FLAG = $564D5868;
var
  LFlag: Cardinal;
  LVersion: Cardinal;
begin
  LFlag := 0;
  try
    asm
      push eax
      push ebx
      push ecx
      push edx

      mov eax, 'VMXh'
      mov ecx, 0Ah
      mov dx, 'VX'

      in eax, dx

      mov LFlag, ebx
      mov LVersion, ecx

      pop edx
      pop ecx
      pop ebx
      pop eax
    end;
  except
//  uncomment next two lines if you wish to see exception
//    on E: Exception do
//      ShowMessage(E.message);
  end; // trye
  if LFlag = CVMWARE_FLAG then begin
    Result := True;
    case LVersion of
      1: AVMWareVersion := vvExpress;
      2: AVMWareVersion := vvESX;
      3: AVMWareVersion := vvGSX;
      4: AVMWareVersion := vvWorkstation;
      else
        AVMWareVersion := vvUnknown;
    end
  end else begin
    Result := False;
    AVMWareVersion := vvNative;
  end; // if LFlag = CVMWARE_FLAG then begin
end;

function IsRunningVMWare: Boolean;
var
  LVMWareVersion: TVMWareVersion;
begin
  Result := IsRunningVMWare(LVMWareVersion);
end;

function IsRunningWine(var AWineVersion: string): Boolean;
type
  TWineGetVersion = function: PAnsiChar;{$IFDEF Win32}stdcall;{$ENDIF}
  TWineNTToUnixFileName = procedure (P1: Pointer; P2: Pointer);{$IFDEF Win32}stdcall;{$ENDIF}
var
  LHandle: THandle;
  LWineGetVersion: TWineGetVersion;
  LWineNTToUnixFileName: TWineNTToUnixFileName;
begin
  Result := False;
  AWineVersion := 'Unknown';
  LHandle := LoadLibrary('ntdll.dll');
  if LHandle > 32 then begin
    LWineGetVersion := GetProcAddress(LHandle, 'wine_get_version');
    LWineNTToUnixFileName := GetProcAddress(LHandle, 'wine_nt_to_unix_file_name');
    if Assigned(LWineGetVersion) or Assigned(LWineNTToUnixFileName) then begin
      Result := True;
      if Assigned(LWineGetVersion) then
        AWineVersion := StrPas(LWineGetVersion);
    end; // if Assigned(LWineGetVersion) or ...
    FreeLibrary(LHandle);
  end; // if LHandle > 32 then begin
end;

function IsRunningWine: Boolean;
var
  LWineVersion: string;
begin
  Result := IsRunningWine(LWineVersion);
end;

function IsRunningVirtualPC: Boolean;
asm
  push ebp;
  mov ebp, esp;

  mov ecx, offset @exception_handler;

  push ebx;
  push ecx;

  push dword ptr fs:[0];
  mov dword ptr fs:[0], esp;

  mov ebx, 0; // Flag
  mov eax, 1; // VPC function number

  // call VPC
  db $0F, $3F, $07, $0B

  mov eax, dword ptr ss:[esp];
  mov dword ptr fs:[0], eax;

  add esp, 8;

  test ebx, ebx;

  setz al;

  lea esp, dword ptr ss:[ebp-4];
  mov ebx, dword ptr ss:[esp];
  mov ebp, dword ptr ss:[esp+4];

  add esp, 8;

  jmp @ret1;

  @exception_handler:
  mov ecx, [esp+0Ch];
  mov dword ptr [ecx+0A4h], -1; // EBX = -1 ->; not running, ebx = 0 -> running
  add dword ptr [ecx+0B8h], 4; // ->; skip past the call to VPC
  xor eax, eax; // exception is handled

  @ret1:
end;

function IsRunningVM(var AVMVersion: string): Boolean;
begin
  AVMVersion := VIRTUALMACHINE_STRINGS[vmNative];
  Result := True;
  if IsRunningWine then
    AVMVersion := VIRTUALMACHINE_STRINGS[vmWine]
  else
    if IsRunningVMWare then
      AVMVersion := VIRTUALMACHINE_STRINGS[vmVMWare]
    else
      if IsRunningVirtualPC then
        AVMVersion := VIRTUALMACHINE_STRINGS[vmVirtualPC]
      else begin
        AVMVersion := VIRTUALMACHINE_STRINGS[vmNative];        
        Result := False;
      end;
end;

function IsRunningVM: Boolean;
var
  LVMVersion: string;
begin
  Result := IsRunningVM(LVMVersion);
end;

end.
usage:
add uDGVMUtils to uses clause and:
// check if running in a virtual machine
var
LVMVersion: string;
begin
ShowMessageFmt('%s, VM name: %s', [BoolToStr(IsRunningVM(LVMVersion), True), LVMVersion]);
end;

// check if running in wine
var
LWine: Boolean;
LWineVersion: string;
begin
ShowMessageFmt('Wine: %s, Wine ver.: %s', [BoolToStr(IsRunningWine(LWineVersion), True), LWineVersion]);
end;

you get the picture, have fun!!

Saturday, January 8, 2011

Client activity information in PostgreSQL

In most of my projects I use PostgreSQL as database, I'm sure that if you see what you get for free, most of you will turn to it, anyhu' this post is about getting information from database, such as:
- databases to which has connections to it;
- current queries ran on X database and the timestamp when the query was started;
- ID's of processes;
- user name of connected clients;
- port on which each client is connected;
- client IP address;
- based upon above information we can get more special info regarding active connections;

In order to see all of the above, run this query on the database:
SELECT * FROM PG_STAT_ACTIVITY;
The reason I was interested in this kind of information is that from time to time the database structure changes, therefore I need to run queries on previous database structures in order to fulfill latest needs, sooo... in order to upgrade the database I require that NO one else besides my "upgrade" application is connected to the database, therefore I run the following query in order to see to how many connections I have to X database, if the number of connections is greater than 1(if I'm connected to the database, I will be counted as well) then the application will wait until the number of connections to X database reaches 1 and then run the update queries, the query that I'm using is:
SELECT DATNAME AS "Database", COUNT(*) AS "ConnectionCount" FROM PG_STAT_ACTIVITY GROUP BY "Database";
and this will result in showing:








Database ConnectionCount
X db 2
Y db 70
etc.
Well that's about all that I wanted to point out for now, do you have any special queries you run on a PostgreSQL database and want to share? comment bellow and I will put above this final thought like:
Name:
SQL QUERY

Saturday, January 1, 2011

Happy new year!!

I wish you all a happy new year!!
Saale Nao Mubbarak
Gelukkige nuwe jaar
Gezuar Vitin e Ri
Snorhavor Nor Tari
Kul 'am wa antum bikhair
Sheta Brikhta
Yeni Iliniz Mubarek!
Noki saal mubarrak bibi
Shuvo Nabo Barsho
Bloavezh Mat
×åñòèòà Íîâà Ãîäèíà
Soursdey Chhnam Tmei
FELIÇ ANY NOU
Nuo bazzor bekkunore
Xin Nian Kuai Le
Pace e Salute
Sretna Nova godina!
Blwyddyn Newydd Dda
Šťastný Nový rok
Godt Nytår
Ufaaveri Aa Aharakah Edhen
GELUKKIG NIEUWJAAR!
Kiortame pivdluaritlo
Felican Novan Jaron
Head uut aastat!
MELKAM ADDIS AMET YIHUNELIWO!
RUHUS HADUSH AMET
Onnellista Uutta Vuotta
Bonne Annee
Bliadhna mhath ur
Bo Nadal e Feliz Aninovo
Prosit Neujahr
GILOTSAVT AKHAL TSELS!
Kenourios Chronos
Nutan Varshbhinandan
Hauoli Makahiki Hou
L'Shannah Tovah
Naye Varsha Ki Shubhkamanyen
Sun Leen Fai Lok
Boldog Új Évet Kivánok
Selamat Tahun Baru
Sal -e- no mobarak
Sanah Jadidah
Bliain nua fe mhaise dhuit
Felice anno nuovo
Akimashite Omedetto Gozaimasu
Asegwas Amegaz
Hosa Varushadha Shubhashayagalu
SOMWAKA OMOYIA OMUYA
Snem Thymmai Basuk Iaphi
Sua Sdei tfnam tmei
Saehae Bock Mani ba deu sei yo!
NEWROZ PIROZBE
Laimīgo Jauno Gadu!
Laimingu Naujuju Metu
Sabai dee pee mai
Srekjna Nova Godina
Tratry ny taona
Selamat Tahun Baru
Nveen Varshachy Shubhechcha
Puthuvatsara Aashamsakal
Kum Thar Chibai
Is-Sena t-Tajba
Nawa Barsha ko Shuvakamana
Godt Nyttår
Nua Barshara Subhechha
Nupela yia i go long yu
Masaganang Bayung Banua
Nawai Kall Mo Mubarak Shah
Sal -e- no mobarak
Manigong Bagong Taon!
Szczesliwego Nowego Roku
Feliz Ano Novo
Nave sal di mubarak
AN NOU FERICIT
S Novim Godom
Manuia le Tausaga Fou
Sretna nova godina
Nayou Saal Mubbarak Hoje
Subha Aluth Awrudhak Vewa
Nawan Saal Shala Mubarak Theevay
Stastny Novy rok
sreèno novo leto
Iyo Sanad Cusub Oo Fiican!
Feliz Ano ~Nuevo
Heri Za Mwaka Mpyaº
GOTT NYTT ÅR!
Warsa Enggal
Eniya Puthandu Nalvazhthukkal
Losar Tashi Delek
Noothana samvatsara shubhakankshalu
Sawadee Pee Mai
Yeni Yiliniz Kutlu Olsun
Shchastlyvoho Novoho Roku
Naya Saal Mubbarak Ho
Yangi Yil Bilan
Chuc Mung Tan Nien
Blwyddyn Newydd Dda!

Blogroll(General programming and Delphi feeds)