utils/uutlCommon.pas

unit uutlCommon;

{ Package:      Utils
  Prefix:       utl - UTiLs
  Beschreibung: diese Unit implementiert allgemein nützliche nicht-generische Klassen }

{$mode objfpc}{$H+}
{$modeswitch nestedprocvars}

interface

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

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlStringStack = class(TStringList)
  public
    procedure Push(const aStr: String);
    function Pop: String;
    function Seek: String;
  end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlInterfaceNoRefCount = class(TObject, IUnknown)
  protected
     fRefCount : longint;
     { 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 RefCount: LongInt read fRefCount;
  end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  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;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlCheckSynchronizeEvent = class(TObject)
  private
    fEvent: TEvent;
    function WaitMainThread(const aTimeout: Cardinal): TWaitResult;
  public const
    MAIN_WAIT_GRANULARITY = 10;
  public
    procedure SetEvent;
    procedure ResetEvent;
    function WaitFor(const aTimeout: Cardinal): TWaitResult;

    constructor Create(const aEventAttributes: syncobjs.PSecurityAttributes;
      const aManualReset, aInitialState: Boolean; const aName: string);
    destructor Destroy; override;
  end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlBaseEventList = specialize TutlList<TutlCheckSynchronizeEvent>;
  TutlEventList = class(TutlBaseEventList)
  public
    function AddEvent(const aEventAttributes: syncobjs.PSecurityAttributes; const aManualReset,
      aInitialState: Boolean; const aName : string): TutlCheckSynchronizeEvent;
    function AddDefaultEvent: TutlCheckSynchronizeEvent;
    function WaitAll(const aTimeout: Cardinal): TWaitResult;

    constructor Create;
  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;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  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 utlEventEqual(const aEvent1, aEvent2): Boolean;
function utlFilterBuilder: IutlFilterBuilder;

implementation

uses
  {uutlTiming needs to be included after Windows because of GetTickCount64}
  uutlLogger{$IFDEF WINDOWS},Windows{$ENDIF}, uutlTiming;

{$IFNDEF WINDOWS}
function CharNext(const C: PChar): PChar;
begin
  //TODO: prüfen ob das für UnicodeString auch stimmt
  Result:= C;
  if Result^>#0 then
    inc(Result);
end;
{$IFEND}

function utlEventEqual(const aEvent1, aEvent2): Boolean;
begin
  result :=
    (TMethod(aEvent1).Code = TMethod(aEvent2).Code) and
    (TMethod(aEvent1).Data = TMethod(aEvent2).Data);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlStringStack//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlStringStack.Push(const aStr: String);
begin
  Insert(0, aStr);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStringStack.Pop: String;
begin
  result := '';
  if Count > 0 then begin
    result := Strings[0];
    Delete(0);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlStringStack.Seek: String;
begin
  result := '';
  if Count > 0 then
    result := Strings[0];
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlInterfaceNoRefCount///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlInterfaceNoRefCount.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 TutlInterfaceNoRefCount._AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
  result := InterLockedIncrement(fRefCount);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlInterfaceNoRefCount._Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
  result := InterLockedDecrement(fRefCount);
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
        P:= CharNext(P);
      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
          P:= CharNext(P);
        end;
        SetString(S, P1, P - P1);
      end;
      Add(S);
      while (P^<>#0) and (P^<>Delimiter) do begin
        P:= CharNext(P);
      end;
      if (P^<>#0) then
        P:= CharNext(P);
      if FSkipDelims then begin
        while (P^<>#0) and (P^=Delimiter) do begin
          P:= CharNext(P);
        end;
      end;
    end;
  finally
    EndUpdate;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlCheckSynchronizeEvent/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlCheckSynchronizeEvent.WaitMainThread(const aTimeout: Cardinal): TWaitResult;
var
  timeout: qword;
begin
  timeout:= GetTickCount64 + aTimeout;
  repeat
    result := fEvent.WaitFor(TutlCheckSynchronizeEvent.MAIN_WAIT_GRANULARITY);
    CheckSynchronize();
  until (result <> wrTimeout) or ((GetTickCount64 > timeout) and (aTimeout <> INFINITE));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlCheckSynchronizeEvent.SetEvent;
begin
  fEvent.SetEvent;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlCheckSynchronizeEvent.ResetEvent;
begin
  fEvent.ResetEvent;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlCheckSynchronizeEvent.WaitFor(const aTimeout: Cardinal): TWaitResult;
begin
  if (GetCurrentThreadId = MainThreadID) then
    result := WaitMainThread(aTimeout)
  else
    result := fEvent.WaitFor(aTimeout);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlCheckSynchronizeEvent.Create(const aEventAttributes: syncobjs.PSecurityAttributes;
  const aManualReset, aInitialState: Boolean; const aName: string);
begin
  inherited Create;
  fEvent := TEvent.Create(aEventAttributes, aManualReset, aInitialState, aName);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TutlCheckSynchronizeEvent.Destroy;
begin
  FreeAndNil(fEvent);
  inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlEventList/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlEventList.AddEvent(const aEventAttributes: syncobjs.PSecurityAttributes; const aManualReset,
  aInitialState: Boolean; const aName: string): TutlCheckSynchronizeEvent;
begin
  result := TutlCheckSynchronizeEvent.Create(aEventAttributes, aManualReset, aInitialState, aName);
  Add(result);
end;

function TutlEventList.AddDefaultEvent: TutlCheckSynchronizeEvent;
begin
  result := AddEvent(nil, true, false, '');
  result.ResetEvent;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlEventList.WaitAll(const aTimeout: Cardinal): TWaitResult;
var
  i: integer;
  timeout, tick: qword;
begin
  timeout := GetTickCount64 + aTimeout;
  for i := 0 to Count-1 do begin
    if (aTimeout <> INFINITE) then begin
      tick := GetTickCount64;
      if (tick >= timeout) then begin
        result := wrTimeout;
        exit;
      end else
        result := Items[i].WaitFor(timeout - tick);
    end else
      result := Items[i].WaitFor(INFINITE);
    if result <> wrSignaled then
      exit;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TutlEventList.Create;
begin
  inherited Create(true);
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;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//IutlFilterBuilder///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
type
  TFilterBuilderImpl = class(TInterfacedObject, IutlFilterBuilder)
  private type
    TFilterEntry = class
      Descr,
      Filter: String;
    end;
    TFilterList = specialize TutlList<TFilterEntry>;
  private
    fFilters: TFilterList;
  public
    constructor Create;
    destructor Destroy; override;
    function Add(aDescr, aMask: string; const aAppendFilterToDesc: boolean): IutlFilterBuilder;
    function AddFilter(aFilter: string): IutlFilterBuilder;
    function Compose(const aIncludeAllSupported: String = ''; const aIncludeAllFiles: String = ''): string;
  end;

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

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

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
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;

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

end.