Changeset 21 for trunk/Packages/Common/Common.pas

Timestamp:

Apr 3, 2025, 10:49:00 PM (2 weeks ago)

Author:

chronos

Message:

• Modified: Updated Common package.

File:

• trunk/Packages/Common/Common.pas (moved) (moved from trunk/Packages/Common/UCommon.pas ) (20 diffs)

trunk/Packages/Common/Common.pas ¶

@@ -1 @@
-unit UCommon;
-
-{$mode delphi}
+unit Common;
 
 interface
 
 uses
-  {$ifdef Windows}Windows,{$endif}
-  {$ifdef Linux}baseunix,{$endif}
-  Classes, SysUtils, StrUtils, Dialogs, Process, LCLIntf,
-  FileUtil; //, ShFolder, ShellAPI;
+  {$IFDEF WINDOWS}Windows,{$ENDIF}
+  {$IFDEF UNIX}baseunix,{$ENDIF}
+  Classes, SysUtils, StrUtils, Dialogs, Process, LCLIntf, Graphics,
+  FileUtil, Generics.Collections; //, ShFolder, ShellAPI;
 
 type
   TArrayOfByte = array of Byte;
-  TArrayOfString = array of string;
   TExceptionEvent = procedure(Sender: TObject; E: Exception) of object;
 
@@ -28 +25 @@
     unfDNSDomainName = 11);
 
+  TFilterMethod = function (FileName: string): Boolean of object;
+  TFileNameMethod = procedure (FileName: string) of object;
+
 var
   ExceptionHandler: TExceptionEvent;
   DLLHandle1: HModule;
 
-{$IFDEF Windows}
-  GetUserNameEx: procedure (NameFormat: DWORD;
-    lpNameBuffer: LPSTR; nSize: PULONG); stdcall;
-{$ENDIF}
-
-function IntToBin(Data: Int64; Count: Byte): string;
+  {$IFDEF WINDOWS}
+    GetUserNameEx: procedure (NameFormat: DWORD;
+      lpNameBuffer: LPSTR; nSize: PULONG); stdcall;
+  {$ENDIF}
+
+const
+  clLightBlue = TColor($FF8080);
+  clLightGreen = TColor($80FF80);
+  clLightRed = TColor($8080FF);
+
+function AddLeadingZeroes(const aNumber, Length : integer) : string;
 function BinToInt(BinStr: string): Int64;
-function TryHexToInt(Data: string; var Value: Integer): Boolean;
-function TryBinToInt(Data: string; var Value: Integer): Boolean;
 function BinToHexString(Source: AnsiString): string;
 //function DelTree(DirName : string): Boolean;
@@ -46 +49 @@
 function BCDToInt(Value: Byte): Byte;
 function CompareByteArray(Data1, Data2: TArrayOfByte): Boolean;
+procedure CopyStringArray(Dest: TStringArray; Source: array of string);
+function CombinePaths(Path1, Path2: string): string;
+function ComputerName: string;
+procedure DeleteFiles(APath, AFileSpec: string);
+function EndsWith(Text, What: string): Boolean;
+function Explode(Separator: Char; Data: string): TStringArray;
+procedure ExecuteProgram(Executable: string; Parameters: array of string;
+  Environment: array of string; CurrentDirectory: string = '');
+procedure ExecuteProgramOutput(Executable: string; Parameters: array of string;
+  Environment: array of string; out Output, Error: string;
+  out ExitCode: Integer; CurrentDirectory: string = '');
+procedure FileDialogUpdateFilterFileType(FileDialog: TOpenDialog);
+procedure FreeThenNil(var Obj);
+function GetDirCount(Dir: string): Integer;
 function GetUserName: string;
-function LoggedOnUserNameEx(Format: TUserNameFormat): string;
-function SplitString(var Text: string; Count: Word): string;
 function GetBitCount(Variable: QWord; MaxIndex: Integer): Integer;
 function GetBit(Variable: QWord; Index: Byte): Boolean;
+function GetStringPart(var Text: string; Separator: string): string;
+function GetEnvironmentVariables: TStringArray;
+function GenerateNewName(OldName: string): string;
+function GetFileFilterItemExt(Filter: string; Index: Integer): string;
+function IntToBin(Data: Int64; Count: Byte): string;
+function Implode(Separator: string; List: TList<string>): string; overload;
+function Implode(Separator: string; List: array of string): string; overload;
+function Implode(Separator: string; List: TStringList; Around: string = ''): string; overload;
+function LastPos(const SubStr: String; const S: String): Integer;
+function LoadFileToStr(const FileName: TFileName): AnsiString;
+function LoggedOnUserNameEx(Format: TUserNameFormat): string;
+function MergeArray(A, B: array of string): TStringArray;
+function OccurenceOfChar(What: Char; Where: string): Integer;
+procedure OpenWebPage(URL: string);
+procedure OpenEmail(Email: string);
+procedure OpenFileInShell(FileName: string);
+function PosFromIndex(SubStr: string; Text: string;
+  StartIndex: Integer): Integer;
+function PosFromIndexReverse(SubStr: string; Text: string;
+  StartIndex: Integer): Integer;
+function RemoveQuotes(Text: string): string;
+procedure SaveStringToFile(S, FileName: string);
 procedure SetBit(var Variable: Int64; Index: Byte; State: Boolean); overload;
 procedure SetBit(var Variable: QWord; Index: Byte; State: Boolean); overload;
 procedure SetBit(var Variable: Cardinal; Index: Byte; State: Boolean); overload;
 procedure SetBit(var Variable: Word; Index: Byte; State: Boolean); overload;
-function AddLeadingZeroes(const aNumber, Length : integer) : string;
-function LastPos(const SubStr: String; const S: String): Integer;
-function GenerateNewName(OldName: string): string;
-function GetFileFilterItemExt(Filter: string; Index: Integer): string;
-procedure FileDialogUpdateFilterFileType(FileDialog: TOpenDialog);
-procedure DeleteFiles(APath, AFileSpec: string);
-procedure OpenWebPage(URL: string);
-procedure OpenFileInShell(FileName: string);
-procedure ExecuteProgram(CommandLine: string);
-procedure FreeThenNil(var Obj);
-function RemoveQuotes(Text: string): string;
-function ComputerName: string;
-function OccurenceOfChar(What: Char; Where: string): Integer;
-function GetDirCount(Dir: string): Integer;
-function MergeArray(A, B: array of string): TArrayOfString;
-function LoadFileToStr(const FileName: TFileName): AnsiString;
+procedure SearchFiles(AList: TStrings; Dir: string;
+  FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil);
+procedure SortStrings(Strings: TStrings);
+function SplitString(var Text: string; Count: Word): string;
+function StripTags(const S: string): string;
+function StartsWith(Text, What: string): Boolean;
+function TryHexToInt(Data: string; out Value: Integer): Boolean;
+function TryBinToInt(Data: string; out Value: Integer): Boolean;
 
 
 implementation
 
-function BinToInt(BinStr : string) : Int64;
-var
-  i : byte;
-  RetVar : Int64;
+resourcestring
+  SExecutionError = 'Excution error: %s (exit code: %d)';
+
+function StartsWith(Text, What: string): Boolean;
+begin
+  Result := Copy(Text, 1, Length(Text)) = What;
+end;
+
+function EndsWith(Text, What: string): Boolean;
+begin
+  Result := Copy(Text, Length(Text) - Length(What) + 1, MaxInt) = What;
+end;
+
+function BinToInt(BinStr: string): Int64;
+var
+  I: Byte;
+  RetVar: Int64;
 begin
   BinStr := UpperCase(BinStr);
-  if BinStr[length(BinStr)] = 'B' then Delete(BinStr,length(BinStr),1);
+  if BinStr[length(BinStr)] = 'B' then Delete(BinStr, Length(BinStr), 1);
   RetVar := 0;
-  for i := 1 to length(BinStr) do begin
-    if not (BinStr[i] in ['0','1']) then begin
+  for I := 1 to Length(BinStr) do begin
+    if not (BinStr[I] in ['0','1']) then begin
       RetVar := 0;
       Break;
     end;
-    RetVar := (RetVar shl 1) + (byte(BinStr[i]) and 1) ;
+    RetVar := (RetVar shl 1) + (Byte(BinStr[I]) and 1);
   end;
 
@@ -98 +140 @@
   I: Integer;
 begin
+  Result := '';
   for I := 1 to Length(Source) do begin
     Result := Result + LowerCase(IntToHex(Ord(Source[I]), 2));
   end;
 end;
-
 
 procedure DeleteFiles(APath, AFileSpec: string);
@@ -112 +154 @@
   Path := IncludeTrailingPathDelimiter(APath);
 
-  Find := FindFirst(UTF8Decode(Path + AFileSpec), faAnyFile xor faDirectory, SearchRec);
+  Find := FindFirst(Path + AFileSpec, faAnyFile xor faDirectory, SearchRec);
   while Find = 0 do begin
-    DeleteFile(Path + UTF8Encode(SearchRec.Name));
+    DeleteFile(Path + SearchRec.Name);
 
     Find := SysUtils.FindNext(SearchRec);
@@ -120 +162 @@
   FindClose(SearchRec);
 end;
-
 
 function GetFileFilterItemExt(Filter: string; Index: Integer): string;
@@ -143 +184 @@
   if FileExt <> '.*' then
     FileDialog.FileName := ChangeFileExt(FileDialog.FileName, FileExt)
+end;
+
+function GetEnvironmentVariables: TStringArray;
+var
+  I: Integer;
+begin
+  Result := Default(TStringArray);
+  SetLength(Result, GetEnvironmentVariableCount);
+  for I := 0 to GetEnvironmentVariableCount - 1 do
+    Result[I] := GetEnvironmentString(I);
 end;
 
@@ -185 +236 @@
 end;*)
 
+function Implode(Separator: string; List: array of string): string;
+var
+  I: Integer;
+begin
+  Result := '';
+  for I := 0 to Length(List) - 1 do begin
+    Result := Result + List[I];
+    if I < Length(List) - 1 then Result := Result + Separator;
+  end;
+end;
+
+function Implode(Separator: string; List: TStringList; Around: string = ''): string;
+var
+  I: Integer;
+begin
+  Result := '';
+  for I := 0 to List.Count - 1 do begin
+    Result := Result + Around + List[I] + Around;
+    if I < List.Count - 1 then Result := Result + Separator;
+  end;
+end;
+
 function LastPos(const SubStr: String; const S: String): Integer;
 begin
@@ -230 +303 @@
 end;
 
-function TryHexToInt(Data: string; var Value: Integer): Boolean;
+function TryHexToInt(Data: string; out Value: Integer): Boolean;
 var
   I: Integer;
@@ -246 +319 @@
 end;
 
-function TryBinToInt(Data: string; var Value: Integer): Boolean;
+function TryBinToInt(Data: string; out Value: Integer): Boolean;
 var
   I: Integer;
@@ -274 +347 @@
 end;
 
-function Explode(Separator: char; Data: string): TArrayOfString;
-begin
-  SetLength(Result, 0);
-  while Pos(Separator, Data) > 0 do begin
+function Explode(Separator: Char; Data: string): TStringArray;
+var
+  Index: Integer;
+begin
+  Result := Default(TStringArray);
+  repeat
+    Index := Pos(Separator, Data);
+    if Index > 0 then begin
+      SetLength(Result, Length(Result) + 1);
+      Result[High(Result)] := Copy(Data, 1, Index - 1);
+      Delete(Data, 1, Index);
+    end else Break;
+  until False;
+  if Data <> '' then begin
     SetLength(Result, Length(Result) + 1);
-    Result[High(Result)] := Copy(Data, 1, Pos(Separator, Data) - 1);
-    Delete(Data, 1, Pos(Separator, Data));
-  end;
-  SetLength(Result, Length(Result) + 1);
-  Result[High(Result)] := Data;
-end;
-
-{$IFDEF Windows}
+    Result[High(Result)] := Data;
+  end;
+end;
+
+function Implode(Separator: string; List: TList<string>): string;
+var
+  I: Integer;
+begin
+  Result := '';
+  for I := 0 to List.Count - 1 do begin
+    Result := Result + List[I];
+    if I < List.Count - 1 then Result := Result + Separator;
+  end;
+end;
+
+{$IFDEF WINDOWS}
 function GetUserName: string;
 const
@@ -294 +385 @@
 begin
   L := MAX_USERNAME_LENGTH + 2;
+  Result := Default(string);
   SetLength(Result, L);
   if Windows.GetUserName(PChar(Result), L) and (L > 0) then begin
@@ -307 +399 @@
   end;
 end;
-{$endif}
+{$ENDIF}
 
 function ComputerName: string;
-{$ifdef mswindows}
+{$IFDEF WINDOWS}
 const
  INFO_BUFFER_SIZE = 32767;
@@ -325 +417 @@
   end;
 end;
-{$endif}
-{$ifdef unix}
+{$ENDIF}
+{$IFDEF UNIX}
 var
   Name: UtsName;
 begin
+  Name := Default(UtsName);
   fpuname(Name);
   Result := Name.Nodename;
 end;
-{$endif}
-
-{$ifdef windows}
+{$ENDIF}
+
+{$IFDEF WINDOWS}
 function LoggedOnUserNameEx(Format: TUserNameFormat): string;
 const
@@ -413 +506 @@
 procedure LoadLibraries;
 begin
-  {$IFDEF Windows}
+  {$IFDEF WINDOWS}
   DLLHandle1 := LoadLibrary('secur32.dll');
   if DLLHandle1 <> 0 then
@@ -424 +517 @@
 procedure FreeLibraries;
 begin
-  {$IFDEF Windows}
+  {$IFDEF WINDOWS}
   if DLLHandle1 <> 0 then FreeLibrary(DLLHandle1);
   {$ENDIF}
 end;
 
-procedure ExecuteProgram(CommandLine: string);
+procedure ExecuteProgram(Executable: string; Parameters: array of string;
+  Environment: array of string; CurrentDirectory: string = '');
 var
   Process: TProcess;
-begin
+  I: Integer;
+begin
+  Process := TProcess.Create(nil);
   try
-    Process := TProcess.Create(nil);
-    Process.CommandLine := CommandLine;
+    Process.Executable := Executable;
+    for I := 0 to Length(Parameters) - 1 do
+      Process.Parameters.Add(Parameters[I]);
+    for I := 0 to Length(Environment) - 1 do
+      Process.Environment.Add(Environment[I]);
+    Process.CurrentDirectory := CurrentDirectory;
+    Process.ShowWindow := swoHIDE;
     Process.Options := [poNoConsole];
     Process.Execute;
@@ -443 +544 @@
 end;
 
+procedure ExecuteProgramOutput(Executable: string; Parameters: array of string;
+  Environment: array of string; out Output, Error: string; out ExitCode: Integer;
+  CurrentDirectory: string);
+var
+  Process: TProcess;
+  I: Integer;
+  ReadCount: Integer;
+  Buffer: string;
+const
+  BufferSize = 1000;
+begin
+  Process := TProcess.Create(nil);
+  try
+    Process.Executable := Executable;
+    for I := 0 to Length(Parameters) - 1 do
+      Process.Parameters.Add(Parameters[I]);
+    for I := 0 to Length(Environment) - 1 do
+      Process.Environment.Add(Environment[I]);
+    Process.CurrentDirectory := CurrentDirectory;
+    Process.ShowWindow := swoHIDE;
+    Process.Options := [poNoConsole, poUsePipes];
+    Process.Execute;
+
+    Output := '';
+    Error := '';
+    Buffer := '';
+    SetLength(Buffer, BufferSize);
+    while Process.Running do begin
+      if Process.Output.NumBytesAvailable > 0 then begin
+        ReadCount := Process.Output.Read(Buffer[1], Length(Buffer));
+        Output := Output + Copy(Buffer, 1, ReadCount);
+      end;
+
+      if Process.Stderr.NumBytesAvailable > 0 then begin
+        ReadCount := Process.Stderr.Read(Buffer[1], Length(Buffer));
+        Error := Error + Copy(Buffer, 1, ReadCount)
+      end;
+
+      Sleep(10);
+    end;
+
+    if Process.Output.NumBytesAvailable > 0 then begin
+      ReadCount := Process.Output.Read(Buffer[1], Length(Buffer));
+      Output := Output + Copy(Buffer, 1, ReadCount);
+    end;
+
+    if Process.Stderr.NumBytesAvailable > 0 then begin
+      ReadCount := Process.Stderr.Read(Buffer[1], Length(Buffer));
+      Error := Error + Copy(Buffer, 1, ReadCount);
+    end;
+
+    ExitCode := Process.ExitCode;
+
+    if (ExitCode <> 0) or (Error <> '') then
+      raise Exception.Create(Format(SExecutionError, [Output + Error, ExitCode]));
+  finally
+    Process.Free;
+  end;
+end;
+
 procedure FreeThenNil(var Obj);
 begin
@@ -454 +615 @@
 end;
 
+procedure OpenEmail(Email: string);
+begin
+  OpenURL('mailto:' + Email);
+end;
+
 procedure OpenFileInShell(FileName: string);
 begin
-  ExecuteProgram('cmd.exe /c start "' + FileName + '"');
+  ExecuteProgram('cmd.exe', ['/c', 'start', FileName], []);
 end;
 
@@ -482 +648 @@
 end;
 
-function MergeArray(A, B: array of string): TArrayOfString;
-var
-  I: Integer;
-begin
+function MergeArray(A, B: array of string): TStringArray;
+var
+  I: Integer;
+begin
+  Result := Default(TStringArray);
   SetLength(Result, Length(A) + Length(B));
   for I := 0 to Length(A) - 1 do
@@ -511 +678 @@
 end;
 
+function DefaultSearchFilter(const FileName: string): Boolean;
+begin
+  Result := True;
+end;
+
+procedure SaveStringToFile(S, FileName: string);
+var
+  F: TextFile;
+begin
+  AssignFile(F, FileName);
+  try
+    ReWrite(F);
+    Write(F, S);
+  finally
+    CloseFile(F);
+  end;
+end;
+
+procedure SearchFiles(AList: TStrings; Dir: string;
+  FilterMethod: TFilterMethod = nil; FileNameMethod: TFileNameMethod = nil);
+var
+  SR: TSearchRec;
+begin
+  Dir := IncludeTrailingPathDelimiter(Dir);
+  if FindFirst(Dir + '*', faAnyFile, SR) = 0 then
+    try
+      repeat
+        if (SR.Name = '.') or (SR.Name = '..') or (Assigned(FilterMethod) and (not FilterMethod(SR.Name) or
+          not FilterMethod(Copy(Dir, 3, Length(Dir)) + SR.Name))) then Continue;
+        if Assigned(FileNameMethod) then
+          FileNameMethod(Dir + SR.Name);
+        AList.Add(Dir + SR.Name);
+        if (SR.Attr and faDirectory) <> 0 then
+          SearchFiles(AList, Dir + SR.Name, FilterMethod);
+      until FindNext(SR) <> 0;
+    finally
+      FindClose(SR);
+    end;
+end;
+
+function GetStringPart(var Text: string; Separator: string): string;
+var
+  P: Integer;
+begin
+  P := Pos(Separator, Text);
+  if P > 0 then begin
+    Result := Copy(Text, 1, P - 1);
+    Delete(Text, 1, P - 1 + Length(Separator));
+  end else begin
+    Result := Text;
+    Text := '';
+  end;
+  Result := Trim(Result);
+  Text := Trim(Text);
+end;
+
+function StripTags(const S: string): string;
+var
+  Len: Integer;
+
+  function ReadUntil(const ReadFrom: Integer; const C: Char): Integer;
+  var
+    J: Integer;
+  begin
+    for J := ReadFrom to Len do
+      if (S[j] = C) then
+      begin
+        Result := J;
+        Exit;
+      end;
+    Result := Len + 1;
+  end;
+
+var
+  I, APos: Integer;
+begin
+  Len := Length(S);
+  I := 0;
+  Result := '';
+  while (I <= Len) do begin
+    Inc(I);
+    APos := ReadUntil(I, '<');
+    Result := Result + Copy(S, I, APos - i);
+    I := ReadUntil(APos + 1, '>');
+  end;
+end;
+
+function PosFromIndex(SubStr: string; Text: string;
+  StartIndex: Integer): Integer;
+var
+  I, MaxLen: SizeInt;
+  Ptr: PAnsiChar;
+begin
+  Result := 0;
+  if (StartIndex < 1) or (StartIndex > Length(Text) - Length(SubStr)) then Exit;
+  if Length(SubStr) > 0 then begin
+    MaxLen := Length(Text) - Length(SubStr) + 1;
+    I := StartIndex;
+    Ptr := @Text[StartIndex];
+    while (I <= MaxLen) do begin
+      if (SubStr[1] = Ptr^) and (CompareByte(Substr[1], Ptr^, Length(SubStr)) = 0) then begin
+        Result := I;
+        Exit;
+      end;
+      Inc(I);
+      Inc(Ptr);
+    end;
+  end;
+end;
+
+function PosFromIndexReverse(SubStr: string; Text: string;
+  StartIndex: Integer): Integer;
+var
+  I: SizeInt;
+  Ptr: PAnsiChar;
+begin
+  Result := 0;
+  if (StartIndex < 1) or (StartIndex > Length(Text)) then Exit;
+  if Length(SubStr) > 0 then begin
+    I := StartIndex;
+    Ptr := @Text[StartIndex];
+    while (I > 0) do begin
+      if (SubStr[1] = Ptr^) and (CompareByte(Substr[1], Ptr^, Length(SubStr)) = 0) then begin
+        Result := I;
+        Exit;
+      end;
+      Dec(I);
+      Dec(Ptr);
+    end;
+  end;
+end;
+
+procedure CopyStringArray(Dest: TStringArray; Source: array of string);
+var
+  I: Integer;
+begin
+  SetLength(Dest, Length(Source));
+  for I := 0 to Length(Dest) - 1 do
+    Dest[I] := Source[I];
+end;
+
+function CombinePaths(Path1, Path2: string): string;
+begin
+  Result := Path1;
+  if Result <> '' then Result := Result + DirectorySeparator + Path2
+    else Result := Path2;
+end;
+
+procedure SortStrings(Strings: TStrings);
+var
+  Tmp: TStringList;
+begin
+  Strings.BeginUpdate;
+  try
+    if Strings is TStringList then begin
+      TStringList(Strings).Sort;
+    end else begin
+      Tmp := TStringList.Create;
+      try
+        Tmp.Assign(Strings);
+        Tmp.Sort;
+        Strings.Assign(Tmp);
+      finally
+        Tmp.Free;
+      end;
+    end;
+  finally
+    Strings.EndUpdate;
+  end;
+end;