Mega Code Archive
Get Windows Version
<![CDATA[
Title: Get Windows Version
Question: Class to extract Windows version information. Includes Service pack Info and other extended information.
Answer:
unit MW_WinVersion;
interface
{$REGION 'Documentation'}
// =============================================================================
// UltraRAD Components
// Mike Heydon 2009
//
// Return Extended information of Windows Version
//
// =============================================================================
{$ENDREGION}
uses Windows, SysUtils, Registry, MW_Unicode;
// See end of article for MW_Unicode
{$REGION 'Types and Classes'}
type
{ TWindowsVersion Class }
TWindowsVersion = class(TObject)
public type
TWindowsOSType = (winUnknown,win31,win95,win95OSR2,winNT,win98,
win98se,winME,win2000,winXP,win2003,winVista,win7);
TWindowsOSClass = (cWorkstation,cServer);
strict private const
VER_NT_WORKSTATION : integer = $1;
VER_NT_DOMAIN_CONTROLLER : integer = $2;
VER_NT_SERVER : integer = $3;
VER_WORKSTATION_NT : integer = $40000000;
VER_SUITE_SMALLBUSINESS : integer = $1; // Microsoft Small Business Server
VER_SUITE_ENTERPRISE : integer = $2; // Win2k Adv Server or .Net Enterprise Server
VER_SUITE_BACKOFFICE : integer = $4; // Microsoft Backoffice
VER_SUITE_COMMUNICATIONS : integer = $8;
VER_SUITE_TERMINAL : integer = $10; // Terminal Services is installed.
VER_SUITE_SBUS_RESTRICTED : integer = $20;
VER_SUITE_EMBEDDEDNT : integer = $40;
VER_SUITE_DATACENTER : integer = $80; // Win2k Datacenter
VER_SUITE_SINGLEUSERTS : integer = $100; // Terminal server in remote admin mode
VER_SUITE_PERSONAL : integer = $200;
VER_SUITE_BLADE : integer = $400; // Microsoft .Net webserver installed
// Vista Related
VER_KERNELDLL = 'Kernel32.dll';
VER_VISTACALL = 'GetProductInfo';
VER_MSVISTA = 'Windows Vista (%s)';
VER_MSWIN7 = 'Windows 7 (%s)';
// Vista Product Constants
VER_BUSINESS = $00000006;
VER_BUSINESS_N = $00000010;
VER_CLUSTER_SERVER = $00000012;
VER_DATACENTER_SERVER = $00000008;
VER_DATACENTER_SERVER_CORE = $0000000C;
VER_DATACENTER_SERVER_CORE_V = $00000027;
VER_DATACENTER_SERVER_V = $00000025;
VER_ENTERPRISE = $00000004;
VER_ENTERPRISE_N = $0000001B;
VER_ENTERPRISE_SERVER = $0000000A;
VER_ENTERPRISE_SERVER_CORE = $0000000E;
VER_ENTERPRISE_SERVER_V = $00000026;
VER_ENTERPRISE_SERVER_CORE_V = $00000029;
VER_ENTERPRISE_SERVER_IA64 = $0000000F;
VER_HOME_BASIC = $00000002;
VER_HOME_BASIVER_N = $00000005;
VER_HOME_PREMIUM = $00000003;
VER_HOME_PREMIUM_N = $0000001A;
VER_HOME_SERVER = $00000013;
VER_SERVER_FOR_SMALLBUSINESS = $00000018;
VER_SMALLBUSINESS_SERVER = $00000009;
VER_SMALLBUSINESS_SERVER_PREMIUM = $00000019;
VER_MEDIUMBUSINESS_SERVER_MANAGEMENT = $0000001E;
VER_MEDIUMBUSINESS_SERVER_MESSAGING = $00000020;
VER_MEDIUMBUSINESS_SERVER_SECURITY = $0000001F;
VER_STANDARD_SERVER = $00000007;
VER_STANDARD_SERVER_V = $00000024;
VER_STANDARD_SERVER_CORE = $0000000D;
VER_STANDARD_SERVER_CORE_V = $00000028;
VER_STARTER = $0000000B;
VER_STORAGE_ENTERPRISE_SERVER = $00000017;
VER_STORAGE_EXPRESS_SERVER = $00000014;
VER_STORAGE_STANDARD_SERVER = $00000015;
VER_STORAGE_WORKGROUP_SERVER = $00000016;
VER_UNDEFINED = $00000000;
VER_ULTIMATE = $00000001;
VER_ULTIMATE_N = $0000001C;
VER_WEB_SERVER = $00000011;
VER_WEB_SERVER_CORE = $0000001D;
VER_UNLICENSED = $ABCDABCD;
strict private type
TGetProductInfoAPI = function(dwOSMajorVersion,dwOSMinorVersion,
dwSpMajorVersion,dwSpMinorVersion : DWORD;
pdwReturnedProductType : PDWORD) : BOOL stdcall;
POSVersionInfoEx = ^TOSVersionInfoEx;
TOSVersionInfoEx = packed record
dwOSVersionInfoSize : DWORD;
dwMajorVersion : DWORD;
dwMinorVersion : DWORD;
dwBuildNumber : DWORD;
dwPlatformId : DWORD;
{$IFDEF UNICODE}
szCSDVersion : array [0..127] of WideChar;
{$ELSE}
szCSDVersion : array [0..127] of AnsiChar;
{$ENDIF}
wServicePackMajor : word;
wServicePackMinor : word;
wSuiteMask : word;
wProductType : byte;
wReserved : byte;
end;
strict private
FSPackName,
FSpackStr,FClassName,
FVerStr,FOpSysName : string;
FOpSysType : TWindowsOSType;
FVerBuild,
FVerMajor,FVerMinor,
FSPackMajor,FSPackMinor : longword;
FClassType : TWindowsOSClass;
procedure _GetWinVersion;
procedure _GetVistaVersion;
function _GetVistaApiPointer : pointer;
function _IsVista : boolean;
public
constructor Create;
property OpSysName : string read FOpSysName;
property OpSysType : TWindowsOSType read FOpSysType;
property OpSysVerStr : string read FVerStr;
property OpSysVerMajor : longword read FVerMajor;
property OpSysVerMinor : longword read FVerMinor;
property OpSysBuild : longword read FVerBuild;
property SPackName : string read FSPackName;
property SPackVerStr : string read FSPackStr;
property SPackVerMajor : longword read FSPackMajor;
property SPackVerMinor : longword read FSPackMinor;
property OpSysClassName : string read FClassName;
property OpSysClassType : TWindowsOSClass read FClassType;
end;
{$ENDREGION}
// -----------------------------------------------------------------------------implementation
{$REGION 'Constructor and Internals'}
constructor TWindowsVersion.Create;
begin
inherited Create;
_GetWinVersion;
if _IsVista then _GetVistaVersion
end;
function TWindowsVersion._GetVistaApiPointer : pointer;
var pResult : pointer;
begin
pResult := GetProcAddress(GetModuleHandle(VER_KERNELDLL),VER_VISTACALL);
Result := pResult;
end;
// ==================================================
// Returns true is Vista is the operating system.
// This will detect even in in emulation mode
// ==================================================
function TWindowsVersion._IsVista : boolean;
var pResult : pointer;
begin
pResult := _GetVistaApiPointer;
Result := Assigned(pResult);
end;
{$ENDREGION}
{$REGION 'Windows up to 2003'}
procedure TWindowsVersion._GetWinVersion;
var rInfo : TOSVersionInfoEx;
pVer : POSVersionInfo;
bIsExtended : boolean;
oReg : TRegistry;
sData : string;
begin
// Try calling GetVersionEx using the new OSVERSIONINFOEX structure.
// If that fails, try using the old OSVERSIONINFO structure.
ZeroMemory(@rInfo,SizeOf(TOSVersionInfoEx));
rInfo.dwOSVersionInfoSize := sizeof(TOSVersionInfoEx);
pVer := @rInfo;
bIsExtended := GetVersionEx(pVer^);
if not bIsExtended then begin
rInfo.dwOSVersionInfoSize := sizeof(TOSVersionInfo);
if not GetVersionEx(pVer^) then raise
Exception.Create('TWindowsVersion() - Unable to determine Version');
end;
FVerStr := Format('%d.%d',[rInfo.dwMajorVersion,rInfo.dwMinorVersion]);
FVerMajor := rInfo.dwMajorVersion;
FVerMinor := rInfo.dwMinorVersion;
FVerBuild := rInfo.dwBuildNumber;
FSPackStr := Format('%d.%d',[rInfo.wServicePackMajor,rInfo.wServicePackMinor]);
FSPackMajor := rInfo.wServicePackMajor;
FSPackMinor := rInfo.wServicePackMinor;
case rInfo.dwPlatformId of
// Test for the Windows NT product family.
VER_PLATFORM_WIN32_NT:
begin
// Test for the specific product family.
if (rInfo.dwMajorVersion = 5) then begin
case rInfo.dwMinorVersion of
0 : begin
FOpSysName := 'Microsoft Windows 2000';
FOpSysType := win2000;
end;
1 : begin
FOpSysName := 'Microsoft Windows XP';
FOpSysType := winXP;
end;
2 : begin
FOpSysName := 'Microsoft Windows Server 2003';
FOpSysType := win2003;
end;
end;
end;
if (rInfo.dwMajorVersion = 4) then begin
FOpSysName := 'Microsoft Windows NT';
FOpSysType := winNT;
end;
// Test for specific product on Windows NT 4.0 SP6 and later.
if bIsExtended then begin
// Test for the workstation type.
if (rInfo.wProductType = VER_NT_WORKSTATION) then begin
FClassType := cWorkstation;
if(rInfo.dwMajorVersion = 4) then
FClassName := 'Workstation 4.0'
else if boolean((rInfo.wSuiteMask and VER_SUITE_PERSONAL)) then
FClassName := 'Home Edition'
else
FClassName := 'Professional';
end
// test for the server type.
else if (rInfo.wProductType = VER_NT_SERVER) then begin
FClassType:= cServer;
if rInfo.dwMajorVersion = 5 then begin
case rInfo.dwMinorVersion of
0 : begin // 2000 server
FOpSysName := 'Microsoft Windows Server 2000';
if boolean((rInfo.wSuiteMask and VER_SUITE_DATACENTER)) then
FClassname := 'Datacenter Server'
else if boolean((rInfo.wSuiteMask and VER_SUITE_ENTERPRISE)) then
FClassName := 'Advanced Server'
else
FClassName := 'Server';
end;
1 : begin // 2003 server
if boolean((rInfo.wSuiteMask and VER_SUITE_DATACENTER)) then
FClassName := 'Datacenter Edition'
else if (rInfo.wSuiteMask and VER_SUITE_ENTERPRISE) = 0 then
FClassName := 'Enterprise Edition'
else if (rInfo.wSuitemask = VER_SUITE_BLADE) then
FClassName := 'Web Edition'
else
FClassName := 'Standard Edition';
end;
end;
end
// windows nt 4.0
else begin
if boolean((rInfo.wSuiteMask and VER_SUITE_ENTERPRISE)) then
FClassName := 'Server 4.0 Enterprise Edition'
else
FClassName := 'Server 4.0';
end;
end;
end
// Test for specific product on Windows NT 4.0 SP5 and earlier
else begin
oReg := TRegistry.Create;
oReg.RootKey := HKEY_LOCAL_MACHINE;
oReg.OpenKey('SYSTEM\CurrentControlSet\Control\ProductOptions',false);
sData := UpperCase(oReg.ReadString('ProductType'));
oReg.CloseKey;
FreeAndNil(oReg);
if sData = 'WINNT' then
FClassName := 'Workstation'
else if sData = 'SERVERNT' then
FClassName := 'Server'
else if sData = 'LANMANNT' then
FClassName := 'Advanced Server';
FClassName := FClassName + Format(' %d.%d ',[rInfo.dwMajorVersion,rInfo.dwMinorVersion] );
end;
// Display service pack (if any) and build number.
if (rInfo.dwMajorVersion = 4) and
AnsiSameText(rInfo.szCSDVersion,'Service Pack 6') then begin
oReg := TRegistry.Create;
oReg.RootKey := HKEY_LOCAL_MACHINE;
// Test for SP6 versus SP6a.
if oReg.OpenKey('SOFTWARE\Microsoft\Windows NT\CurrentVersion\Hotfix\Q246009',false) then
FSPackName := Format('Service Pack 6a (Build %d)',[rInfo.dwBuildNumber and $FFFF])
else
FSPackName := Format('%s (Build %d)',[rInfo.szCSDVersion,rInfo.dwBuildNumber and $FFFF]);
oReg.CloseKey;
FreeAndNil(oReg);
end
// Windows NT 3.51 and earlier or Windows 2000 and later
else
FSPackName := Format('%s (Build %d)',[rInfo.szCSDVersion,rInfo.dwBuildNumber and $FFFF]);
end;
// Test for the Windows 95 product family.
VER_PLATFORM_WIN32_WINDOWS :
begin
FClassType := cWorkstation;
FSPackName := rInfo.szCSDVersion;
if rInfo.dwMajorVersion = 4 then begin
case rInfo.dwMinorVersion of
0 : begin
FOpSysName := 'Microsoft Windows 95';
FOpSysType := win95;
if (rInfo.szCSDVersion[1] = 'C') or
(rInfo.szCSDVersion[1] = 'B') then begin
FClassName := 'OSR2';
FOpSysType := win95OSR2;
end;
end;
10 : begin
FOpSysName := 'Microsoft Windows 98';
FOpSysType := win98;
if (rInfo.szCSDVersion[1] = 'A') then begin
FClassName := 'SE';
FOpSysType := win98se;
end;
end;
90 : begin
FOpSysName := 'Microsoft Windows Millennium';
FOpSysType := winME;
end;
end;
end;
end;
VER_PLATFORM_WIN32s :
begin
FOpSysName := 'Microsoft Win32s';
FClassType := cWorkstation;
FOpSysType := win31;
end;
end;
FSPackName := trim(FSPackName);
end;
{$ENDREGION}
{$REGION 'Vista'}
procedure TWindowsVersion._GetVistaVersion;
var GetProductInfoAPI : TGetProductInfoAPI;
pFunction : pointer;
iProdType : DWORD;
sName : string;
begin
sName := '';
pFunction := _GetVistaApiPointer;
if Assigned(pFunction) then begin
case FVerMinor of
0 : begin
FOpSysName := 'Micosoft Vista';
FOpSysType := winVista;
end;
1 : begin
FOpSysName := 'Micosoft Windows 7';
FOpSysType := win7;
end;
end;
@GetProductInfoAPI := pFunction;
if GetProductInfoAPI(6,0,0,0,@iProdType) then begin
case iProdType of
VER_BUSINESS : sName := 'Business Edition';
VER_BUSINESS_N : sName := 'Business Edition';
VER_CLUSTER_SERVER : sName := 'Cluster Server Edition';
VER_DATACENTER_SERVER : sName := 'Server Datacenter Edition (full installation)';
VER_DATACENTER_SERVER_CORE : sName := 'Server Datacenter Edition (core installation)';
VER_DATACENTER_SERVER_CORE_V : sName := 'Server Datacenter Edition without Hyper-V (core installation)';
VER_DATACENTER_SERVER_V : sName := 'Server Datacenter Edition without Hyper-V (full installation)';
VER_ENTERPRISE : sName := 'Enterprise Edition';
VER_ENTERPRISE_N : sName := 'Enterprise Edition';
VER_ENTERPRISE_SERVER : sName := 'Server Enterprise Edition (full installation)';
VER_ENTERPRISE_SERVER_CORE : sName := 'Server Enterprise Edition (core installation)';
VER_ENTERPRISE_SERVER_V : sName := 'Server Enterprise Edition without Hyper-V (full installation)';
VER_ENTERPRISE_SERVER_CORE_V : sName := 'Server Enterprise Edition without Hyper-V (core installation)';
VER_ENTERPRISE_SERVER_IA64 : sName := 'Server Enterprise Edition for Itanium-based Systems';
VER_HOME_BASIC : sName := 'Home Basic Edition';
VER_HOME_BASIVER_N : sName := 'Home Basic Edition';
VER_HOME_PREMIUM : sName := 'Home Premium Edition';
VER_HOME_PREMIUM_N : sName := 'Home Premium Edition';
VER_HOME_SERVER : sName := 'Home Server Edition';
VER_SERVER_FOR_SMALLBUSINESS : sName := 'Server for Small Business Edition';
VER_SMALLBUSINESS_SERVER : sName := 'Small Business Server';
VER_SMALLBUSINESS_SERVER_PREMIUM : sName := 'Small Business Server Premium Edition';
VER_MEDIUMBUSINESS_SERVER_MANAGEMENT : sName := 'Windows Essential Business Server Management Server';
VER_MEDIUMBUSINESS_SERVER_MESSAGING : sName := 'Windows Essential Business Server Messaging Server';
VER_MEDIUMBUSINESS_SERVER_SECURITY : sName := 'Windows Essential Business Server Security Server';
VER_STANDARD_SERVER : sName := 'Server Standard Edition (full installation)';
VER_STANDARD_SERVER_V : sName := 'Server Standard Edition without Hyper-V (full installation)';
VER_STANDARD_SERVER_CORE : sName := 'Server Standard Edition (core installation)';
VER_STANDARD_SERVER_CORE_V : sName := 'Server Standard Edition without Hyper-V (core installation)';
VER_STARTER : sName := 'Starter Edition';
VER_STORAGE_ENTERPRISE_SERVER : sName := 'Storage Server Enterprise Edition';
VER_STORAGE_EXPRESS_SERVER : sName := 'Storage Server Express Edition';
VER_STORAGE_STANDARD_SERVER : sName := 'Storage Server Standard Edition';
VER_STORAGE_WORKGROUP_SERVER : sName := 'Storage Server Workgroup Edition';
VER_UNDEFINED : sName := 'An unknown product';
VER_ULTIMATE : sName := 'Ultimate Edition';
VER_ULTIMATE_N : sName := 'Ultimate Edition';
VER_WEB_SERVER : sName := 'Web Server Edition';
VER_WEB_SERVER_CORE : sName := 'Web Server Edition (core installation)';
VER_UNLICENSED : sName := 'Unlicensed product';
end;
case FVerMinor of
0 : FClassName := Format(VER_MSVISTA,[sName]);
1 : FClassName := Format(VER_MSWIN7,[sName]);
end;
end;
end;
end;
{$ENDREGION}
end.
// Code for MW_Unicode
unit MW_Unicode;
interface
{$REGION 'Documentation'}
// ================================================================================
// UltraRAD Components
// Mike Heydon 2009
//
// Unicode Tools Unit that handles system.string types in both D2009 Unicode and
// D2007 Ansi strings. Both ANSI and Unicode will compile and work transparently using
// this module if used correctly.
//
// NOTES :
// -------
// Be aware of D2009 when concating widestring buffers with a single char string eg. '=' as the
// compiler will give an error about coverting short strings and will fail at runtime with an
// "Access Violation". It seems to be that the compiler takes the 1 char string as a char as
// opposed to a string.
//
// Take the following declaration .. var a1,a2 : array [0..512] of char;
//
// Statement D2007 D2009
// ---------------- ------- ------------------------------
// a1 + '=' + a2; OK Compiler and Runtime Errors
// a1 + '==' a2; OK OK
//
// Solution that works for both D2007 and D2009
// var sEqual : string;
// sEqual := '=';
// a1 + sEqual + a2;
//
//
// Constants ..
// ------------
// CHAR_SIZE - Character Size, will set itself to (1 for = D2007) and (2 for = D2009)
//
// Static language functions ..
// ----------------------------
// StrSize(const AString : string) - Returns size of string in bytes as opposed to length
// AnsiToUni(const AString : AnsiString) - Returns Unicode string of Ansi without warnings.
// UniToAnsi(const AString : string) - Returns Ansi string of Unicode without warnings.
// IsUnicode : boolean; - Used to determine if default string is Unicode or ANSI
// at runtime. Compile time checking can be obtained by
// {$IFDEF UNICODE} ...
// MemberOf(AChar : char; ACharSet : set of AnsiChar) - Handles the reduction of warning messages
// that occur with "if cVar in ['a'..'z'] ..."
//
// Classes ..
// ----------
// TByteBuffer - Creates a a simple static byte array buffer that can be used as pointers to
// API calls or I/O functions. The Delphi dynamic "TBytes : array of byte" does not
// always react in the way you think when passing it as a buffer to API or I/O calls.
// TByteBuffer uses GetMem and FreeMem as opposed to SetLength(arr,x) and thus
// passes a TRUE pointer to the actual data. TBytes will sometimes act as a pointer
// to a pointer to the data.
//
//
// TStringBuffer - Creates an static byte array buffer that can be used as pointers to
// LPSTR and LPWSTR in Windows API calls. The class can be created via a string,
// in which case the size and type is automatically set for the version, or
// manually sized with manual type for generic buffers. In D2009 api calls such as
// CreateProcess() typically fail if the pchar pointers are NOT static structures.
// ie. string constants, dynamic strings, referenced strings or arrays will FAIL
// with access violations. Most of D2009 API calls now use PWideChar as opposed
// to D2007 wich used mainly PAnsiChar.
//
// Address Returns a pointer to the static buffer, can be type cast to PChar etc.
// Value[Index] Used to read or set individual bytes of the array.
// ToString Returns a string representation of the buffer dependant on BufferType.
// BufferSize Returns the size of the buffer array in bytes
// Assign Assigns the contents of a memory pointer to Buffer for Buffer length bytes.
// NOTE : No checking for memory walk. Assigned pointer must contain and own valid
// memory for Buffer size.
//
// Expample ...
//
// CreateProcess in Delphi 2009 causes Access Violation if a normal PChar of a string
// variable is passed and the CommandLine argument. It requires a static as opposed
// to a dynamic structure pointer. ReadFile also uses the buffer as ansi, but will
// convert to ansi or unicode string automativally depending on Delphi version
//
// class procedure WinMisc.ExecConsolePipe(const AConsoleCommand : string;
// AList : TStrings;
// ATimeoutSeconds : integer = 15);
// var rSecurity : TSecurityAttributes;
// hReadPipe,hWritePipe : THandle;
// rStart : TStartUpInfo;
// rProcessInfo : TProcessInformation;
// iLoop : integer;
// oBuffer,oCommand : TStringBuffer;
// iBytesRead,iApprunning : DWORD;
// begin
// ATimeoutSeconds := abs(ATimeoutSeconds) * 10;
// iLoop := 0;
// AList.Clear;
// AList.BeginUpdate;
// rSecurity.nlength := SizeOf(TSecurityAttributes);
// rSecurity.binherithandle := true;
// rSecurity.lpsecuritydescriptor := nil;
//
// if Createpipe(hReadPipe,hWritePipe,@rSecurity, 0) then begin
// FillChar(rStart,Sizeof(rStart),#0);
// rStart.cb := SizeOf(rStart);
// rStart.hStdOutput := hWritePipe;
// rStart.hStdInput := hReadPipe;
// rStart.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
// rStart.wShowWindow := SW_HIDE;
// oCommand := TStringBuffer.Create(AConsoleCommand);
//
// try
// if CreateProcess(nil,oCommand.Address,@rSecurity,@rSecurity,true,
// NORMAL_PRIORITY_CLASS,nil,nil,rStart,
// rProcessInfo) then begin
// repeat
// inc(iLoop);
// iApprunning := WaitForSingleObject(rProcessInfo.hProcess,100);
// Application.ProcessMessages;
// until (iApprunning WAIT_TIMEOUT) or (iLoop ATimeoutSeconds);
//
// oBuffer := TStringBuffer.Create(C_DOSBUFFER,btAnsi);
//
// repeat
// iBytesRead := 0;
// ReadFile(hReadPipe,oBuffer.Address^,C_DOSBUFFER,iBytesRead,nil);
// oBuffer.Value[iBytesRead] := 0;
// AList.Text := AList.Text + oBuffer.ToString;
// until (iBytesRead C_DOSBUFFER);
//
// FreeAndNil(oBuffer);
// end;
// except
// end;
//
// FreeAndNil(oCommand);
// CloseHandle(rProcessInfo.hProcess);
// CloseHandle(rProcessInfo.hThread);
// CloseHandle(hReadPipe);
// CloseHandle(hWritePipe);
// end;
//
// AList.EndUpdate;
// end;
//
// UniToAnsi() and AnsiToUni() is also actually faster than letting the compiler do the
// conversion for you (with warning message), plus the code will read EXACTLY what you are
// intending to do with the Unicode and Ansistring conversions.
//
// Timings of a 50,000 loop with stringlength og 1600 characters.
//
// UNI to ANSI
// --------------------------
// ASSEMBLER Millisecs 297 // eg. szString := UniToAnsi(sString);
//
// LOOP CODE Millisecs 1004 // eg. for i := 1 to length(szString) do
// sResult[i] := AnsiChar(sString[i]);
//
// IMPLICIT Millisecs 334 // eg. szString := sString; (Compiler will emit warining}
//
//
// ANSI to UNI
// --------------------------
// ASSEMBLER Millisecs 428 // eg. sString := AnsiToUni(szString);
//
// LOOP CODE Millisecs 833 // eg. for i := 1 to length(sString) do
// szResult[i] := char(szString[i]);
//
// IMPLICIT Millisecs 433 // eg. sString := szString; (Compiler will emit warining}
//
// =================================================================================================
{$ENDREGION}
uses SysUtils;
const
CHAR_SIZE = SizeOf(char);
{$REGION 'Types and Classes'}
type
{ TStringBuffer Class }
TStringBuffer = class(TObject)
strict private type
PByteArray = ^TByteArray;
TByteArray = array [0..0] of byte;
PWordArray = ^TWordArray;
TWordArray = array [0..0] of word;
TBufferType = (btAnsi,btUnicode);
strict private
FBufferType : TBufferType;
FBufLen : integer;
FBuffer : PByteArray;
function GetFAddress : pointer;
procedure SetFValue(AIndex : integer; AValue : byte);
function GetFValue(AIndex : integer) : byte;
function _GetString : string;
public
constructor Create(const AString : string); overload;
constructor Create(ABufferSize : integer; ABufferType : TBufferType); overload;
destructor Destroy; override;
function ToString : string; {$IFDEF UNICODE} override; {$ENDIF}
function BufferAsAnsi : AnsiString;
{$IFDEF UNICODE}
function BufferAsUni : string;
{$ELSE}
function BufferAsUni : WideString;
{$ENDIF}
procedure Assign(ABufferPointer : pointer);
procedure FillBytes(AValue : byte);
procedure FillWords(AValue : word);
// Properties
property Address : pointer read GetFAddress;
property Value[AIndex : integer] : byte read GetFValue write SetFValue;
property BufferSize : integer read FBufLen;
end;
{ TByteBuffer Class }
TByteBuffer = class(TObject)
strict private type
PByteArray = ^TByteArray;
TByteArray = array [0..0] of byte;
strict private
FBufLen : integer;
FBuffer : PByteArray;
function GetFAddress : pointer;
procedure SetFValue(AIndex : integer; AValue : byte);
function GetFValue(AIndex : integer) : byte;
public
constructor Create(ABufferSize : integer);
destructor Destroy; override;
procedure Assign(ABufferPointer : pointer);
procedure FillBytes(AValue : byte);
// Properties
property Address : pointer read GetFAddress;
property Value[AIndex : integer] : byte read GetFValue write SetFValue;
property BufferSize : integer read FBufLen;
end;
{$ENDREGION}
// Function Prototypes
function StrSize(const AString : string) : integer; inline;
function AnsiToUni(const AString : AnsiString) : string; {$IFNDEF UNICODE} inline; {$ENDIF}
function UniToAnsi(const AString : string) : AnsiString; {$IFNDEF UNICODE} inline; {$ENDIF}
function IsUnicode : boolean; inline;
function MemberOf(AChar : char; ACharSet : TSysCharSet) : boolean; inline;
// ------------------------------------------------------------------------------------------------
implementation
{$REGION 'Public Functions'}
// -------------------------------------------------------------------------------------------------
// =================================================================
// Returns true if version default string is Unicode at runtime
// =================================================================
function IsUnicode : boolean; inline;
begin
Result := (CHAR_SIZE 1);
end;
// =================================================
// Get size of string in bytes based on char size
// ie. Unicode char=2 and Ansi char=1 bytes
// =================================================
function StrSize(const AString : string) : integer; inline;
begin
{$IFDEF UNICODE}
Result := length(AString) shl 1;
{$ELSE}
Result := length(AString);
{$ENDIF}
end;
// =======================================================================
// Convert an ANSI to a Unicode string (or Ansi if D2007)
// without generating warnings
// The ASSEMBLER routine is an optimised version of ....
//
// function AnsiToUni(const AString : AnsiString) : string;
// var sResult : string;
// {$IFDEF UNICODE}
// i : integer;
// {$ENDIF}
// begin
// {$IFDEF UNICODE}
// SetLength(sResult,length(AString));
// for i := 1 to length(AString) do sResult[i] := char(AString[i]);
// {$ELSE}
// sResult := AString;
// {$ENDIF}
//
// Result := sResult;
// end;
//
// =======================================================================
function AnsiToUni(const AString : AnsiString) : string; {$IFNDEF UNICODE} inline; {$ENDIF}
var sResult : string;
begin
{$IFDEF UNICODE}
if AString = '' then
sResult := ''
else begin
SetLength(sResult,length(AString));
asm
push esi // Save CPU states
push edi
push ebx
lea ebx,[AString] // Get address of source ANSI AString
mov esi,[ebx] // Set pointer register to the address AString
lea ebx,[sResult] // Get address of dest UNI sResult
mov edi,[ebx] // Set pointer register to address of rResult
mov ecx,dword ptr [edi - 4] // Store length of ANSI sResult in bytes
cld // Set move direction to forward
@Loop:
movsb // Copy byte from source to target
mov byte ptr [edi],0 // Make it a PWideChar
inc edi // Add 1 for PWideChar, esi is autoinc
dec ecx // Decrement counter
jnz @Loop // Do until all bytes copied
pop ebx // Restore CPU states
pop edi
pop esi
end;
end;
{$ELSE}
sResult := AString;
{$ENDIF}
Result := sResult;
end;
// ===========================================================================
// Convert a Unicode to an ANSI (or Ansi if D2007)
// without generating warnings
// The ASSEMBLER routine is an optimised version of ....
//
// function UniToAnsi(const AString : string) : AnsiString;
// var sResult : AnsiString;
// {$IFDEF UNICODE}
// i : integer;
// {$ENDIF}
// begin
// {$IFDEF UNICODE}
// SetLength(sResult,length(AString));
// for i := 1 to length(AString) do sResult[i] := AnsiChar(AString[i]);
// {$ELSE}
// sResult := sResult;
// {$ENDIF}
//
// Result := sResult;
// end;
//
// ===========================================================================
function UniToAnsi(const AString : string) : AnsiString; {$IFNDEF UNICODE} inline; {$ENDIF}
var sResult : AnsiString;
begin
{$IFDEF UNICODE}
if AString = '' then
sResult := ''
else begin
SetLength(sResult,length(AString));
asm
push esi // Save CPU states
push edi
push ebx
lea ebx,[AString] // Get address of source UNI AString
mov esi,[ebx] // Set pointer register to the address AString
lea ebx,[sResult] // Get address of dest ANSI sResult
mov edi,[ebx] // Set pointer register to address of rResult
mov ecx,dword ptr [edi - 4] // Store length of ANSI sResult in bytes
cld // Set move direction to forward
@Loop:
movsb // Copy byte from source to target
inc esi // Add 1 for PWideChar, edi is autoinc
dec ecx // Decrement counter
jnz @Loop // Do until all bytes copied
pop ebx // Restore CPU states
pop edi
pop esi
end;
end;
{$ELSE}
sResult := AString;
{$ENDIF}
Result := sResult;
end;
// =================================================================================
// Vallidate a char in a set. Note Unicode chars above #254 are NOT considered
// to be part on any set and are ignored by this function.
//
// In the following code Delphi 2009 will generate a warning. MemberOf() does
// not generate any warning and will correctly in both 2007 and 2009
//
// var c : char;
// s : TSysCharSet;
// begin
// c := '9';
// s := ['1'..'9'];
//
// if c in s then showmessage('Ok');
// { **** [DCC Warning] WideChar reduced to byte char in set expressions.... }
//
// { No Warning and processes transparent to version
// if MemberOf(c,s) then showmessage('Ok');
//
// end;
// =================================================================================
function MemberOf(AChar : char; ACharSet : TSysCharSet) : boolean; inline;
begin
{$IFDEF UNICODE}
Result := CharInSet(AChar,ACharSet);
{$ELSE}
Result := AChar in ACharSet;
{$ENDIF}
end;
{$ENDREGION}
{$REGION 'TStringBuffer Class'}
// -------------------------------------------------------------------------------------------------
constructor TStringBuffer.Create(const AString : string);
var cNull : char;
iStrLen : integer;
begin
inherited Create;
// Set buffer type depending on compiler version
// D2007 string will be ANSI, D2009 string will be Unicode by default
if CHAR_SIZE = 1 then
FBufferType := btAnsi
else
FBufferType := btUnicode;
cNull := #0;
iStrLen := StrSize(AString);
// Allow for terminating #0
FBufLen := iStrLen + CHAR_SIZE;
GetMem(FBuffer,FBufLen);
move(AString[1],FBuffer^[0],iStrLen);
// Add terminating #0
move(cNull,FBuffer^[iStrLen],CHAR_SIZE);
end;
// ===================================================================
// Manually create character buffer by specifying size in bytes and
// what type of char is stored in the buffer.
// ===================================================================
constructor TStringBuffer.Create(ABufferSize : integer; ABufferType : TBufferType);
begin
inherited Create;
FBufferType := ABufferType;
FBufLen := ABufferSize;
// Unicode needs 2 bytes per char, buffer cannot be odd number.
if (FBufferType = btUnicode) and Odd(FBufLen) then inc(FBufLen);
GetMem(FBuffer,FBufLen);
FillChar(FBuffer^[0],FBufLen,0);
end;
destructor TStringBuffer.Destroy;
begin
FreeMem(FBuffer);
inherited Destroy;
end;
// ================================================================================
// Return a pointer to char buffer. This pointer is compatible with LPSTR,LPWSTR,
// PWIDECHAR and PANSICHAR as used by windows API calls.
// ================================================================================
function TStringBuffer.GetFAddress : pointer;
begin
// Point to first byte of array structure
Result := @FBuffer^[0];
end;
// ===============================================================
// Get and Set the array element char value by index property
// NOTE : No checking for index out of bounds!
// ===============================================================
procedure TStringBuffer.SetFValue(AIndex : integer; AValue : byte);
begin
FBuffer^[AIndex] := AValue;
end;
function TStringBuffer.GetFValue(AIndex : integer) : byte;
begin
Result := FBuffer^[AIndex];
end;
// =========================================================================================
// System.String representation of the buffer depending on buffer storage type and
// system.string being Unicode or Ansi string.
// The buffer is represented as 1 byte ANSI or 2 byte Unicode. The buffer will auto convert
// to a Delphi system.string type depending on version.
//
// D2007 will return an ANSI string
// D2009 will retuen a Unicode string
// =========================================================================================
function TStringBuffer._GetString : string;
var sResult : string;
i,iIdx,iChars : integer;
pBuffer : PWordArray;
begin
if FBufferType = btAnsi then
iChars := FBufLen
else
iChars := FBufLen div CHAR_SIZE;
SetLength(sResult,iChars);
iIdx := 0;
// Buffer is one byte ansi sdata
if FBufferType = btAnsi then begin
for i := 0 to FBufLen - 1 do begin
if FBuffer^[i] = 0 then
break
else begin
inc(iIdx);
sResult[iIdx] := char(FBuffer^[i]);
end;
end;
end
else begin
// Buffer is 2 byte unicode data, process as WORD array
pBuffer := @FBuffer^[0];
for i := 0 to (FBufLen div 2) - 1 do begin
if pBuffer^[i] = 0 then
break
else begin
inc(iIdx);
sResult[iIdx] := char(pBuffer^[i]);
end;
end;
end;
SetLength(sResult,iIdx);
Result := sResult;
end;
function TStringBuffer.ToString : string;
begin
Result := _GetString;
end;
// ====================================================================
// Manually return an AnsiString value regardless of compiler version
// based on the buffer storage type.
// ====================================================================
function TStringBuffer.BufferAsAnsi : AnsiString;
var sResult : AnsiString;
i,iIdx,iChars : integer;
pBuffer : PWordArray;
begin
if FBufferType = btAnsi then
iChars := FBufLen
else
iChars := FBufLen div CHAR_SIZE;
SetLength(sResult,iChars);
iIdx := 0;
// Buffer is one byte ansi sdata
if FBufferType = btAnsi then begin
for i := 0 to FBufLen - 1 do begin
if FBuffer^[i] = 0 then
break
else begin
inc(iIdx);
sResult[iIdx] := AnsiChar(FBuffer^[i]);
end;
end;
end
else begin
// Buffer is 2 byte unicode data, process as WORD array
pBuffer := @FBuffer^[0];
for i := 0 to (FBufLen div 2) - 1 do begin
if pBuffer^[i] = 0 then
break
else begin
inc(iIdx);
sResult[iIdx] := AnsiChar(pBuffer^[i]);
end;
end;
end;
SetLength(sResult,iIdx);
Result := sResult;
end;
// ========================================================================
// Manually return a Unicode value regardless of compiler version
// based on the buffer storage type.
// NOTE : D2007 will return a type WideString
// This is not usually used in D2007 but included for coppleteness
// ========================================================================
{$IFDEF UNICODE}
function TStringBuffer.BufferAsUni : string;
begin
Result := _GetString;
end;
{$ELSE}
function TStringBuffer.BufferAsUni : WideString;
var sResult : WideString;
sBuffer : string;
i : integer;
begin
sBuffer := _GetString;
SetLength(sResult,length(sBuffer));
for i := 1 to length(sBuffer) do sResult[i] := WideChar(sBuffer[i]);
Result := sResult;
end;
{$ENDIF}
// ========================================================================
// Copy the contents of one TStringBuffer into another for the size
// of this classes buffer.
// NOTE : No bound checks are performed!
// ========================================================================
procedure TStringBuffer.Assign(ABufferPointer : pointer);
begin
move(ABufferPointer^,FBuffer^[0],FBufLen);
end;
procedure TStringBuffer.FillBytes(AValue : byte);
begin
FillChar(FBuffer^[0],FBufLen,AValue);
end;
procedure TStringBuffer.FillWords(AValue : word);
var i : integer;
pBuffer : PWordArray;
begin
if odd(FBuflen) then
raise Exception.Create('Base64.FillWords() - Buffer is not a multiple of WORD.')
else begin
pBuffer := @FBuffer^[0];
for i := 0 to (FBufLen div 2) - 1 do pBuffer^[i] := AValue;
end;
end;
{$ENDREGION}
{$REGION 'TByteBuffer Class'}
// -------------------------------------------------------------------------------------------------
constructor TByteBuffer.Create(ABufferSize : integer);
begin
inherited Create;
FBufLen := ABufferSize;
GetMem(FBuffer,FBufLen);
FillChar(FBuffer^[0],FBufLen,0);
end;
destructor TByteBuffer.Destroy;
begin
FreeMem(FBuffer);
inherited Destroy;
end;
// ================================================================================
// Return a pointer to buffer.
// ================================================================================
function TByteBuffer.GetFAddress : pointer;
begin
// Point to first byte of array structure
Result := @FBuffer^[0];
end;
// ===============================================================
// Get and Set the array element char value by index property
// NOTE : No checking for index out of bounds!
// ===============================================================
procedure TByteBuffer.SetFValue(AIndex : integer; AValue : byte);
begin
FBuffer^[AIndex] := AValue;
end;
function TByteBuffer.GetFValue(AIndex : integer) : byte;
begin
Result := FBuffer^[AIndex];
end;
// ========================================================================
// Copy the contents of one TByteBuffer into another for the size
// of this classes buffer.
// NOTE : No bound checks are performed!
// ========================================================================
procedure TByteBuffer.Assign(ABufferPointer : pointer);
begin
move(ABufferPointer^,FBuffer^[0],FBufLen);
end;
procedure TByteBuffer.FillBytes(AValue : byte);
begin
FillChar(FBuffer^[0],FBufLen,AValue);
end;
{$ENDREGION}
end.
]]>