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!!
Hi Dorin, you may want to also have include detection for VirtualBox, one of the methods used is described here http://onhacks.org/lang/en/2009/10/21/detecting-virtualbox/
ReplyDeleteHi Chee, thank you for the link, however I'm not sure that the registry is a good solution but it might just do the trick...
ReplyDeleteThat's true. Perhaps this is a better way http://www.gedzac.com/rrlf.dr.eof.eZine/articles/WarGame/vboxdetect.html
ReplyDeleteIt detects for the presence of a pseudo device. Enjoy! :)
Thank you Chee, now that's more like it!! please see last post.
ReplyDeleteI can't reach http://onhacks.org/lang/en/2009/10/21/detecting-virtualbox/ while http://www.gedzac.com/rrlf.dr.eof.eZine/articles/WarGame/vboxdetect.html said "This domain has expired."
ReplyDeleteI've modified this unit to include virtual box, here's the link http://www.delphigeist.com/2011/01/udgvmutils-version-11-thanks-to-chee.html
Delete