JarUnPacker/prereq/ANB ST CP/data/VCLEx.pas

unit VCLEx;
{$MODE Delphi}
{$codepage UTF8}
interface
uses ShellApi, windows, sysutils, strutils, LazFileUtils, LazUTF8;
type IntEx = {$IFDEF Win64}Int64{$ELSE}Integer{$ENDIF};
     TWaitEvent = procedure;
     TOSPlatform = (ospUnknown, ospWin32, ospWin64);
     TPrivilegeState = (psError, psLimitedUser, psAdmin);
     Percent = 0..100;
     TRandomRange = (rrUpperCasesLetters, rrLowerCasesLetters, rrNumbers, rrStandartSymbols);
     TRandomRanges = set of TRandomRange;
//stdcalls
function IntToBool (const AInt: IntEx): Boolean; STDCALL;
function BoolToInt (const ABool: Boolean): IntEx; STDCALL;
function CopyDirectory (const AFromDir, AToDir: String; const AFlags: Word = FOF_FILESONLY): Boolean; STDCALL;
function MoveDirectory (const AFromDir, AToDir: String; const AFlags: Word = FOF_FILESONLY): Boolean; STDCALL;
function DelDirectory (const ADir: String; const AFlags: Word = FOF_SILENT or FOF_NOCONFIRMATION): Boolean; STDCALL;
procedure WaitEx (const AMs: Int64; OnWait: TWaitEvent); STDCALL;
procedure Wait (const AMs: Int64); STDCALL;
function GetBuildPlatform: TOSPlatform; STDCALL;
function GetWindowsUserPrivilege: TPrivilegeState; STDCALL;
function ExtractUpDir(const ADir: String; var VSuccess: Boolean): String; STDCALL;
function GetAnyFileType (const AFileName: UTF8String): UTF8String; STDCALL;
function FileSizeToStr (const AFS: Int64; const AScaleCaptions: array of String): String; OVERLOAD; STDCALL;
function FileSizeToStr (const AFS: Int64): String; OVERLOAD; STDCALL;
function GetRandomString (const sLength: Integer; const ARange: TRandomRanges = [rrUpperCasesLetters, rrLowerCasesLetters]; const AIncludedSymbols: String = ''; const AExcludedSymbols: String = ''): String; STDCALL;
implementation
function IntToBool (const AInt: IntEx): Boolean;
begin
if AInt >= 0 then
 Result:= True
 else
 Result:= False;
end;
function BoolToInt (const ABool: Boolean): IntEx;
begin
if ABool then
 Result:= 1
 else
 Result:= -1;
end;
//from http://www.delphiworld.narod.ru/base/copy_del_move_dir.html
function CopyDirectory (const AFromDir, AToDir: String; const AFlags: Word = FOF_FILESONLY): Boolean;
var fos: TSHFileOpStruct;
begin
with fos do
 begin
 wFunc:= FO_COPY;
 fFlags:= AFlags;
 pFrom:= PChar(AFromDir + #0);
 pTo:= PChar(AToDir);
 end;
Result:= (0 = SHFileOperation(fos));
end;
function MoveDirectory (const AFromDir, AToDir: String; const AFlags: Word = FOF_FILESONLY): Boolean;
var fos: TSHFileOpStruct;
begin
with fos do
 begin
 wFunc:= FO_MOVE;
 fFlags:= AFlags;
 pFrom:= PChar(AFromDir + #0);
 pTo:= PChar(AToDir);
 end;
Result:= (0 = SHFileOperation(fos));
end;
function DelDirectory (const ADir: String; const AFlags: Word = FOF_SILENT or FOF_NOCONFIRMATION): Boolean;
var
  fos: TSHFileOpStruct;
begin
with fos do
 begin
 wFunc:= FO_DELETE;
 fFlags:= AFlags;
 pFrom:= PChar(ADir + #0);
 end;
Result:= (0 = SHFileOperation(fos));
end;
//---
procedure WaitEx (const AMs: Int64; OnWait: TWaitEvent);
var STime: Int64;
begin
STime:= GetTickCount64;
repeat
  OnWait;
  until (GetTickCount64 - STime) = AMs;
end;
procedure Wait (const AMs: Int64);
 procedure MyWait;
 begin
 end;
begin
WaitEx(AMs, @MyWait);
end;
//GetBuildPlatform
function GetBuildPlatform: TOSPlatform;
begin
Result:= ospUnknown;
if LowerCase({$I %FPCTARGETOS%}) = 'win32' then
 Result:= ospWin32;
if LowerCase({$I %FPCTARGETOS%}) = 'win64' then
 Result:= ospWin64;
end;
//GetWindowsUserPrivilege
function GetWindowsUserPrivilege: TPrivilegeState;
const SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5));
      SECURITY_BUILTIN_DOMAIN_RID = $00000020;
      DOMAIN_ALIAS_RID_ADMINS = $00000220;
      SECURITY_MANDATORY_HIGH_RID = $00003000;
      TokenIntegrityLevel = 25;
var hAccessToken: THandle;
    ptgGroups: PTokenGroups;
    dwInfoBufferSize: DWORD;
    psidAdministrators: PSID;
    I: Integer;
    SubAuthority: DWORD;
begin
Result:= psError;
if Win32Platform <> VER_PLATFORM_WIN32_NT then
 Exit;
if not OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, hAccessToken) then
 if not OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, hAccessToken) then
  Exit;
try
 GetMem(ptgGroups, 1024);
 try
  if Win32MajorVersion < 6 then
   begin
   if not GetTokenInformation(hAccessToken, TokenGroups, ptgGroups, 1024, dwInfoBufferSize) then
    Exit;
   AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, psidAdministrators);
   try
    Result:= psLimitedUser;
    for I:= 0 to ptgGroups.GroupCount - 1 do
     if EqualSid(psidAdministrators, ptgGroups.Groups[I].Sid) then
      begin
      Result:= psAdmin;
      Break;
      end;
    finally
    FreeSid(psidAdministrators);
    end;
   end
   else
   begin
   if GetTokenInformation(hAccessToken, TTokenInformationClass(TokenIntegrityLevel), ptgGroups, 1024, dwInfoBufferSize) and IsValidSid(PSIDAndAttributes(ptgGroups)^.Sid) then
    begin
    Result:= psLimitedUser;
    SubAuthority:= GetSidSubAuthorityCount(PSIDAndAttributes(ptgGroups)^.Sid)^ - 1;
    if GetSidSubAuthority(PSIDAndAttributes(ptgGroups)^.Sid, SubAuthority)^ >= SECURITY_MANDATORY_HIGH_RID then
     Result:= psAdmin;
    end;
   end;
  finally
  FreeMem(ptgGroups);
  end;
 finally
 CloseHandle(hAccessToken);
 end;
end;
function ExtractUpDir (const ADir: String; var VSuccess: Boolean): String;
var CurrDelim, NextDelim: Integer;
    s, Str: String;
begin
Str:= ExcludeTrailingBackslash(ADir);
if Length(ADir) < 4 then
 begin
 VSuccess:= false;
 Result:= ADir;
 Exit;
 end;
s:= '';
CurrDelim:= 1;
repeat
 NextDelim:= PosEx('\', Str, CurrDelim);
 if NextDelim = 0 then
  NextDelim:= Length(Str) + 1;
 if NextDelim < Length(Str) then
  s:= s + Copy(Str, CurrDelim, NextDelim - CurrDelim) + '\';
 CurrDelim:= NextDelim + 1;
 until (CurrDelim > Length(Str));
VSuccess:= DirectoryExistsUTF8(s);
Result:= s;
end;
function GetAnyFileType (const AFileName: UTF8String): UTF8String;
var FileInfo: TSHFILEINFO;
begin
Result:= '';
FillChar(FileInfo, SizeOf(FileInfo), 0);
if (SHGetFileInfo(PChar(ExtractFileExt(AFileName)), FILE_ATTRIBUTE_NORMAL, FileInfo, SizeOf(FileInfo), SHGFI_TYPENAME or SHGFI_USEFILEATTRIBUTES) <> 0) then
 Result:= AnsiToUtf8(FileInfo.szTypeName);
end;
function FileSizeToStr (const AFS: Int64; const AScaleCaptions: array of String): String;
var ARSize: Real;
begin
if AFS < 1024 then
 begin
 Result:= Format('%d ' + AScaleCaptions[0], [AFS]);
 Exit;
 end;
if AFS < 1048576 then
 begin
 ARSize:= Round((AFS / 1024)*100)/100;
 Result:= FloatToStr(ARSize) + ' ' + AScaleCaptions[1];
 Exit;
 end;
if AFS < 1073741824 then
 begin
 ARSize:= Round((AFS / 1048576)*100)/100;
 Result:= FloatToStr(ARSize) + ' ' + AScaleCaptions[2];
 Exit;
 end;
ARSize:= Round((AFS / 1073741824)*100)/100;
Result:= FloatToStr(ARSize) + ' ' + AScaleCaptions[3];
end;
function FileSizeToStr (const AFS: Int64): String;
begin
Result:= FileSizeToStr(AFS, ['Byte', 'KB', 'MB', 'GB']);
end;
function GetRandomString (const sLength: Integer; const ARange: TRandomRanges = [rrUpperCasesLetters, rrLowerCasesLetters]; const AIncludedSymbols: String = ''; const AExcludedSymbols: String = ''): String;
const UpperCaseChars = 'ABCDEFGHIKLMNOPQRSTUVWXYZ';
      LowerCaseChars = 'abcdefghiklmnopqrstuvwxyz';
      NumbersChars = '0123456789';
      SymbolsChars = '!"#$%&''()*+,-.:;<=>?@\]^_`{|}~';
var i, j: Integer;
    Chars: String;
begin
SetLength (Result, sLength);
Chars:= AIncludedSymbols;
if rrUpperCasesLetters in ARange then
 Chars:= Chars + UpperCaseChars;
if rrLowerCasesLetters in ARange then
 Chars:= Chars + LowerCaseChars;
if rrNumbers in ARange then
 Chars:= Chars + NumbersChars;
if rrStandartSymbols in ARange then
 Chars:= Chars + SymbolsChars;
if Length(AExcludedSymbols) > 0 then
 for i:= 1 to Length(AExcludedSymbols) do
  begin
  j:= Pos(AExcludedSymbols[i], Chars);
  if j > 0 then
   Delete(Chars, j, 1);
  end;
for i:= 1 to sLength do
 Result[i]:= Chars[Random(Length(Chars))+1];
end;
end.