utils/uutlCommon.pas

unit uutlCommon;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, versionresource, versiontypes, typinfo
  {$IFDEF UNIX}, unixtype, pthreads {$ENDIF};

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlInterfacedObject = class(TObject, IUnknown)
  protected
    fRefCount: longint;
    fAutoFree: Boolean;

    { implement methods of IUnknown }
    function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
    function _AddRef: longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual;
    function _Release: longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual;

  public
    property AutoFree: Boolean read fAutoFree write fAutoFree;
    property RefCount: LongInt read fRefCount;

    procedure AfterConstruction; override;

    constructor Create;

  public
    class function NewInstance: TObject; override;
  end;
  TutlInterfaceNoRefCount = TutlInterfacedObject;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlCSVList = class(TStringList)
  private
    fSkipDelims: boolean;

    function GetStrictDelText: string;
    procedure SetStrictDelText(const Value: string);

  public
    property StrictDelimitedText: string read GetStrictDelText write SetStrictDelText;
    // Skip repeated delims instead of reading empty lines?
    property SkipDelims: Boolean read fSkipDelims write fSkipDelims;
  end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlVersionInfo = class(TObject)
  private
    fVersionRes: TVersionResource;
    function GetFixedInfo: TVersionFixedInfo;
    function GetStringFileInfo: TVersionStringFileInfo;
    function GetVarFileInfo: TVersionVarFileInfo;
  public
    property FixedInfo:      TVersionFixedInfo      read GetFixedInfo;
    property StringFileInfo: TVersionStringFileInfo read GetStringFileInfo;
    property VarFileInfo:    TVersionVarFileInfo    read GetVarFileInfo;

    function Load(const aInstance: THandle): Boolean;

    constructor Create;
    destructor Destroy; override;
  end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  EInternal = class(Exception);
  EOutOfRangeException = class(Exception)
  private
    fMin: Integer;
    fMax: Integer;
    fIndex: Integer;

  public
    property Min:   Integer read fMin;
    property Max:   Integer read fMax;
    property Index: Integer read fIndex;

    constructor Create(const aIndex, aMin, aMax: Integer);
    constructor Create(const aMsg: String; const aIndex, aMin, aMax: Integer);
  end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  IutlFilterBuilder = interface['{BC5039C7-42E7-428F-A3E7-DDF7757B1907}']
    function Add(aDescr, aMask: string; const aAppendFilterToDesc: boolean = true): IutlFilterBuilder;
    function AddFilter(aFilter: string): IutlFilterBuilder;
    function Compose(const aIncludeAllSupported: String = ''; const aIncludeAllFiles: String = ''): string;
  end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function  Supports              (const aInstance: TObject; const aClass: TClass; out aObj): Boolean; overload;
function  GetTickCount64        (): QWord;
function  GetMicroTime          (): QWord;
function  GetPlatformIdentitfier(): String;

function  utlRateLimited    (const Reference: QWord; const Interval: QWord): boolean;
function  utlFinalizeObject (var obj; const aTypeInfo: PTypeInfo; const aFreeObject: Boolean): Boolean;
function  utlFilterBuilder  (): IutlFilterBuilder;
function  utlBitCount       (const aValue: DWord): Integer;

implementation

uses
  {$IFDEF WINDOWS}
  Windows,
  {$ELSE}
  Unix, BaseUnix,
  {$ENDIF}
  uutlGenerics;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
type
  TFilterBuilderImpl = class(
    TInterfacedObject,
    IutlFilterBuilder)
  private type
    TFilterEntry = class
      Descr,
      Filter: String;
    end;
    TFilterList = specialize TutlList<TFilterEntry>;

  private
    fFilters: TFilterList;

  public
    function Add      (aDescr, aMask: string; const aAppendFilterToDesc: boolean): IutlFilterBuilder;
    function AddFilter(aFilter: string): IutlFilterBuilder;
    function Compose  (const aIncludeAllSupported: String = ''; const aIncludeAllFiles: String = ''): string;

    constructor Create;
    destructor Destroy; override;
  end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//Helper Methods////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function Supports(const aInstance: TObject; const aClass: TClass; out aObj): Boolean;
begin
  result := Assigned(aInstance) and aInstance.InheritsFrom(aClass);
  if result
    then TObject(aObj) := aInstance
    else TObject(aObj) := nil;
end;

{$IF DEFINED(WINDOWS)}
var
  PERF_FREQ: Int64;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function GetTickCount64: QWord;
begin
  // GetTickCount64 is better, but we need to check the Windows version to use it
  Result := Windows.GetTickCount();
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function GetMicroTime: QWord;
var
  pc: Int64;
begin
  pc := 0;
  QueryPerformanceCounter(pc);
  result := (pc * 1000*1000) div PERF_FREQ;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
{$ELSEIF DEFINED(UNIX)}
function GetTickCount64: QWord;
var
  tp: TTimeVal;
begin
  fpgettimeofday(@tp, nil);
  Result := (Int64(tp.tv_sec) * 1000) + (tp.tv_usec div 1000);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function GetMicroTime: QWord;
var
  tp: TTimeVal;
begin
  fpgettimeofday(@tp, nil);
  Result := (Int64(tp.tv_sec) * 1000*1000) + tp.tv_usec;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
{$ELSE}
function GetTickCount64: QWord;
begin
  Result := Trunc(Now * 24 * 60 * 60 * 1000);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function GetMicroTime: QWord;
begin
  Result := Trunc(Now * 24 * 60 * 60 * 1000*1000);
end;
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function GetPlatformIdentitfier: String;

  {$IFDEF WINDOWS}
  function GetWindowsVersionStr(const aDefault: String): string;
  var
    osv: TOSVERSIONINFO;
    ver: cardinal;
  begin
    result := aDefault;
    osv.dwOSVersionInfoSize := SizeOf(osv);
    if GetVersionEx(osv) then begin
      ver := MAKELONG(osv.dwMinorVersion, osv.dwMajorVersion);
      // positive overflow: if system is newer, always detect as newest we knew instead of failing
      if ver >= $000A0000 then
        result := '10'
      else if ver >= $00060003 then
        result := '8_1'
      else if ver >= $00060002 then
        result := '8'
      else if ver >= $00060001 then
        result := '7'
      else if ver >= $00060000 then
        result := 'Vista'
      else if ver >= $00050002 then
        result := '2003'
      else if ver >= $00050001 then
        result := 'XP'
      else if ver >= $00050000 then
        result := '2000'
      else if ver >= $00040000 then
        result := 'NT4';
      // ignore NT3, hmkay?;
    end;
  end;
  {$ENDIF}

var
  os,ver,arch: string;
begin
  result := '';
  os   := '';
  ver  := 'generic';
  arch := '';
  {$IF DEFINED(WINDOWS)}
    os  := 'mswin';
    ver := GetWindowsVersionStr(ver);
  {$ELSEIF DEFINED(LINUX)}
    os  := 'linux';
    {$Warning System Version String missing!}
  {$ENDIF}

  {$IF DEFINED(CPUX86)}
    arch := 'x86';
  {$ELSEIF DEFINED(cpux86_64)}
    arch := 'x64';
  {$ELSE}
    {$ERROR Unknown Architecture!}
  {$ENDIF}
  result := Format('%s-%s-%s', [os, ver, arch]);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function utlRateLimited(const Reference: QWord; const Interval: QWord): boolean;
begin
  Result := GetMicroTime - Reference > Interval;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function utlFinalizeObject(var obj; const aTypeInfo: PTypeInfo; const aFreeObject: Boolean): Boolean;
var
  o: TObject;
begin
  result := true;
  case aTypeInfo^.Kind of
    tkClass: begin
      if (aFreeObject) then begin
        o := TObject(obj);
        Pointer(obj) := nil;
        if Assigned(o) then
          o.Free;
      end;
    end;

    tkInterface: begin
      IUnknown(obj) := nil;
    end;

    tkAString: begin
      AnsiString(Obj) := '';
    end;

    tkUString: begin
      UnicodeString(Obj) := '';
    end;

    tkString: begin
      String(Obj) := '';
    end;

  else
    result := false;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function utlFilterBuilder: IutlFilterBuilder;
begin
  result := TFilterBuilderImpl.Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function utlBitCount(const aValue: DWord): Integer;
var
  t: DWord;
begin
  t := aValue - ((aValue shr 1) and &33333333333)
              - ((aValue shr 2) and &11111111111);
  result := ((t + (t shr 3)) and &30707070707) mod 63;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlInterfacedObject///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlInterfacedObject.QueryInterface(constref iid: tguid; out obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
  if getinterface(iid,obj) then
     result:=S_OK
   else
     result:=longint(E_NOINTERFACE);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlInterfacedObject._AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
  _AddRef := interlockedincrement(fRefCount);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlInterfacedObject._Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
  _Release := InterLockedDecrement(fRefCount);
  if (_Release = 0) and fAutoFree then
    Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlInterfacedObject.AfterConstruction;
begin
  inherited AfterConstruction;
  InterLockedDecrement(fRefCount);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlInterfacedObject.Create;
begin
  inherited Create;
  fAutoFree := false;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlInterfacedObject.NewInstance: TObject;
begin
  result := inherited NewInstance;
  if Assigned(result) then
    TutlInterfacedObject(result).fRefCount := 1;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlCSVList///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlCSVList.GetStrictDelText: string;
var
  S: string;
  I, J, Cnt: Integer;
  q: boolean;
  LDelimiters: TSysCharSet;
begin
  Cnt := GetCount;
  if (Cnt = 1) and (Get(0) = '') then
    Result := QuoteChar + QuoteChar
  else
  begin
    Result := '';
    LDelimiters := [QuoteChar, Delimiter];
    for I := 0 to Cnt - 1 do
    begin
      S := Get(I);
      q:= false;
      if S>'' then begin
        for J:= 1 to length(S) do
          if S[J] in LDelimiters then begin
            q:= true;
            break;
          end;
        if q then S := AnsiQuotedStr(S, QuoteChar);
      end else
        S := AnsiQuotedStr(S, QuoteChar);
      Result := Result + S + Delimiter;
    end;
    System.Delete(Result, Length(Result), 1);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlCSVList.SetStrictDelText(const Value: string);
var
  S: String;
  P, P1: PChar;
begin
  BeginUpdate;
  try
    Clear;
    P:= PChar(Value);
    if fSkipDelims then begin
      while (P^<>#0) and (P^=Delimiter) do begin
        {$IFDEF LINUX}inc(P){$ELSE}P:= CharNext(P){$ENDIF};
      end;
    end;
    while (P^<>#0) do begin
      if (P^ = QuoteChar) then begin
        S:= AnsiExtractQuotedStr(P, QuoteChar);
      end else begin
        P1:= P;
        while (P^<>#0) and (P^<>Delimiter) do begin
          {$IFDEF LINUX}inc(P){$ELSE}P:= CharNext(P){$ENDIF};
        end;
        SetString(S, P1, P - P1);
      end;
      Add(S);
      while (P^<>#0) and (P^<>Delimiter) do begin
        {$IFDEF LINUX}inc(P){$ELSE}P:= CharNext(P){$ENDIF};
      end;
      if (P^<>#0) then
        {$IFDEF LINUX}inc(P){$ELSE}P:= CharNext(P){$ENDIF};
      if fSkipDelims then begin
        while (P^<>#0) and (P^=Delimiter) do begin
          {$IFDEF LINUX}inc(P){$ELSE}P:= CharNext(P){$ENDIF};
        end;
      end;
    end;
  finally
    EndUpdate;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlVersionInfo///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlVersionInfo.GetFixedInfo: TVersionFixedInfo;
begin
  result := fVersionRes.FixedInfo;
end;

function TutlVersionInfo.GetStringFileInfo: TVersionStringFileInfo;
begin
  result := fVersionRes.StringFileInfo;
end;

function TutlVersionInfo.GetVarFileInfo: TVersionVarFileInfo;
begin
  result := fVersionRes.VarFileInfo;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlVersionInfo.Load(const aInstance: THandle): Boolean;
var
  Stream: TResourceStream;
begin
  result := false;
  if (FindResource(aInstance, PChar(PtrInt(1)), PChar(RT_VERSION)) = 0) then
      exit;
  Stream := TResourceStream.CreateFromID(aInstance, 1, PChar(RT_VERSION));
  try
    fVersionRes.SetCustomRawDataStream(Stream);
    fVersionRes.FixedInfo;// access some property to force load from the stream
    fVersionRes.SetCustomRawDataStream(nil);
  finally
    Stream.Free;
  end;
  result := true;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlVersionInfo.Create;
begin
  inherited Create;
  fVersionRes := TVersionResource.Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TutlVersionInfo.Destroy;
begin
  FreeAndNil(fVersionRes);
  inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//EOutOfRange///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor EOutOfRangeException.Create(const aIndex, aMin, aMax: Integer);
begin
  Create('', aIndex, aMin, aMax);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor EOutOfRangeException.Create(const aMsg: String; const aIndex, aMin, aMax: Integer);
var
  s: String;
begin
  fIndex := aIndex;
  fMin   := aMin;
  fMax   := aMax;
  s := Format('index (%d) out of range (%d:%d)', [fIndex, fMin, fMax]);
  if (aMsg <> '') then
    s := s + ': ' + aMsg;
  inherited Create(s);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlFilterBuilder///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TFilterBuilderImpl.Compose(const aIncludeAllSupported: String; const aIncludeAllFiles: String): string;
var
  s: String;
  e: TFilterEntry;
begin
  result := '';
  if (aIncludeAllSupported>'') and (fFilters.Count > 0) then begin
    s:= '';
    for e in fFilters do begin
      if s>'' then
        s += ';';
      s += e.Filter;
    end;
    Result+= Format('%s|%s', [aIncludeAllSupported, s, s]);
  end;

  for e in fFilters do begin
    if Result>'' then
      Result += '|';
    Result+= Format('%s|%s', [e.Descr, e.Filter]);
  end;

  if aIncludeAllFiles > '' then begin
    if Result>'' then
      Result += '|';
    Result+= Format('%s|%s', [aIncludeAllFiles, '*.*']);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TFilterBuilderImpl.Add(aDescr, aMask: string; const aAppendFilterToDesc: boolean): IutlFilterBuilder;
var
  e: TFilterEntry;
begin
  result := Self;
  e:= TFilterEntry.Create;
  if aAppendFilterToDesc then
    e.Descr:= Format('%s (%s)', [aDescr, aMask])
  else
    e.Descr:= aDescr;
  e.Filter:= aMask;
  fFilters.Add(e);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TFilterBuilderImpl.AddFilter(aFilter: string): IutlFilterBuilder;
var
  c: integer;
begin
  c:= Pos('|', aFilter);
  if c > 0 then
    result := (Self as IutlFilterBuilder).Add(Copy(aFilter, 1, c-1), Copy(aFilter, c+1, Maxint))
  else
    result := (Self as IutlFilterBuilder).Add(aFilter, aFilter, false);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TFilterBuilderImpl.Create;
begin
  inherited Create;
  fFilters:= TFilterList.Create(true);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TFilterBuilderImpl.Destroy;
begin
  FreeAndNil(fFilters);
  inherited Destroy;
end;

initialization
{$IF DEFINED(WINDOWS)}
  PERF_FREQ := 0;
  QueryPerformanceFrequency(PERF_FREQ);
{$ENDIF}

end.