|
- 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.
|