lazarus/components/jcf2/Utils/JcfStringUtils.pas

unit JcfStringUtils;

{(*}
(*------------------------------------------------------------------------------
 Delphi Code formatter source code 

The Original Code is JcfStringUtils, released October 2008.
The Initial Developer of the Original Code is Paul Ishenin 
Portions created by Paul Ishenin are Copyright (C) 1999-2008 Paul Ishenin
All Rights Reserved. 
Contributor(s): Anthony Steele. 

The contents of this file are subject to the Mozilla Public License Version 1.1
(the "License"). you may not use this file except in compliance with the License.
You may obtain a copy of the License at http://www.mozilla.org/NPL/

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied.
See the License for the specific language governing rights and limitations 
under the License.

Alternatively, the contents of this file may be used under the terms of
the GNU General Public License Version 2 or later (the "GPL") 
See http://www.gnu.org/licenses/gpl.html
------------------------------------------------------------------------------*)
{*)}

{$I JcfGlobal.inc}

{
This unit contains string utility code
For use when the JCL string functions are not avaialable
}

interface
uses
  SysUtils, Classes;

const
  NativeNull           = Char(#0);
  NativeSoh            = Char(#1);
  NativeStx            = Char(#2);
  NativeEtx            = Char(#3);
  NativeEot            = Char(#4);
  NativeEnq            = Char(#5);
  NativeAck            = Char(#6);
  NativeBell           = Char(#7);
  NativeBackspace      = Char(#8);
  NativeTab            = Char(#9);
  NativeLineFeed       = AnsiChar(#10);
  NativeVerticalTab    = Char(#11);
  NativeFormFeed       = Char(#12);
  NativeCarriageReturn = AnsiChar(#13);
  NativeCrLf           = AnsiString(#13#10);
  NativeSo             = Char(#14);
  NativeSi             = Char(#15);
  NativeDle            = Char(#16);
  NativeDc1            = Char(#17);
  NativeDc2            = Char(#18);
  NativeDc3            = Char(#19);
  NativeDc4            = Char(#20);
  NativeNak            = Char(#21);
  NativeSyn            = Char(#22);
  NativeEtb            = Char(#23);
  NativeCan            = Char(#24);
  NativeEm             = Char(#25);
  NativeEndOfFile      = Char(#26);
  NativeEscape         = Char(#27);
  NativeFs             = Char(#28);
  NativeGs             = Char(#29);
  NativeRs             = Char(#30);
  NativeUs             = Char(#31);
  NativeSpace          = Char(' ');
  NativeComma          = Char(',');
  NativeBackslash      = Char('\');
  NativeForwardSlash   = Char('/');

  {$IFDEF MSWINDOWS}
  NativeLineBreak = NativeCrLf;
  PathSeparator    = '\';
  {$ENDIF MSWINDOWS}
  {$IFDEF UNIX}
  NativeLineBreak = NativeLineFeed;
  PathSeparator    = '/';
  {$ENDIF UNIX}
  DirDelimiter = PathSeparator;
  NativeHexDigits      = ['0'..'9', 'A'..'F', 'a'..'f'];
  NativeWhiteSpace     = [NativeTab, NativeLineFeed, NativeVerticalTab,
    NativeFormFeed, NativeCarriageReturn, NativeSpace];

  NativeDoubleQuote = Char('"');
  NativeSingleQuote = Char('''');


function CharIsControl(const C: Char): Boolean;
function CharIsAlpha(const C: Char): Boolean;
function CharIsAlphaNum(const C: Char): Boolean;
function CharIsDigit(const C: Char): Boolean;
function CharIsReturn(const C: Char): Boolean;
function CharIsWhiteSpace(const C: Char): Boolean;

function CharUpper(const C: Char): Char; 

function StrIsAlpha(const S: string): Boolean;
function StrIsAlphaNum(const S: string): Boolean;

function StrTrimQuotes(const S: string): string;

function StrAfter(const SubStr, S: string): string;
function StrBefore(const SubStr, S: string): string;
function StrChopRight(const S: string; N: Integer): string;
function StrLastPos(const SubStr, S: string): Integer;
function StrLeft(const S: string; Count: Integer): string;
function StrRestOf(const S: string; N: Integer ): string;
function StrRight(const S: string; Count: Integer): string;

function StrDoubleQuote(const S: string): string;
function StrSmartCase(const S: string; Delimiters: TSysCharSet): string;

function StrCharCount(const S: string; C: Char): Integer;
function StrStrCount(const S, SubS: string): Integer;
function StrRepeat(const S: string; Count: Integer): string;
procedure StrReplace(var S: string; const Search, Replace: string; Flags: TReplaceFlags = []);
function StrSearch(const Substr, S: string; const Index: Integer = 1): Integer;

function BooleanToStr(B: Boolean): string;
function StrToBoolean(const S: string): Boolean;

function StrFind(const Substr, S: string; const Index: Integer = 1): Integer;
function StrIsOneOf(const S: string; const List: array of string): Boolean;

procedure TrimStrings(const List: TStrings; DeleteIfEmpty: Boolean = True);

function FileToString(const FileName: string): AnsiString;
procedure StringToFile(const FileName: string; const Contents: AnsiString);
function StrFillChar(const C: Char; Count: Integer): string;
function IntToStrZeroPad(Value, Count: Integer): String;
function WideStringReplace(const S, OldPattern, NewPattern: WideString; Flags: TReplaceFlags): WideString;

function PathExtractFileNameNoExt(const Path: string): string;
function GetWindowsTempFolder: string;
function FileGetSize(const FileName: string): Int64;
procedure ShellExecEx(const FileName: string; const Parameters: string = '');
function GetTickCount: Cardinal;
function IsMultiByte(const pcChar: WideChar): Boolean;

function IsWinVista: Boolean;
function IsWinXP: Boolean;
function IsWin2k: Boolean;
function IsWin2003: Boolean;

type
  EJcfConversionError = class(Exception)
  end;

implementation

uses
{$ifdef MSWINDOWS}
  Windows, ShellApi
{$endif}
{$ifdef Unix}
  Unix
{$endif}
{$ifdef fpc}
  , LCLIntf, FileUtil
{$endif};

{$IFNDEF DELPHI12}

// define  CharInSet for Delphi 2007 or earlier
function CharInSet(const C: Char; const testSet: TSysCharSet): boolean;
begin
  Result := C in testSet;
end;

{$ENDIF}

function CharIsAlpha(const C: Char): Boolean;
begin
  Result := CharInSet(C, ['a'..'z','A'..'Z']);
end;

function CharIsAlphaNum(const C: Char): Boolean;
begin
  Result := CharIsAlpha(C) or CharIsDigit(C);
end;

function CharIsControl(const C: Char): Boolean;
begin
  Result := C <= #31;
end;

function CharIsDigit(const C: Char): Boolean;
begin
  Result := CharInSet(C, ['0'..'9']);
end;

function CharIsReturn(const C: Char): Boolean;
begin
  Result := CharInSet(C, [NativeLineFeed, NativeCarriageReturn]);
end;

function CharIsWhiteSpace(const C: Char): Boolean;
begin
  Result := CharInSet(C, NativeWhiteSpace) ;
end;

function CharUpper(const C: Char): Char;
begin
  // Paul: original code used char case table
  Result := UpCase(C);
end;

function StrIsAlpha(const S: string): Boolean;
var
  I, L: integer;
begin
  L := Length(S);
  Result := L > 0;
  for I := 1 to L do
    if not CharIsAlpha(S[I]) then
    begin
      Result := False;
      break;
    end;
end;

function StrIsAlphaNum(const S: string): Boolean;
var
  I, L: integer;
begin
  L := Length(S);
  Result := L > 0;
  for I := 1 to L do
    if not CharIsAlphaNum(S[I]) then
    begin
      Result := False;
      break;
    end;
end;

function StrTrimQuotes(const S: string): string;
var
  C1, C2: Char;
  L: Integer;
begin
  Result := S;
  L := Length(Result);
  if L >= 2 then
  begin
    C1 := Result[1];
    C2 := Result[L];
    if (C1 = C2) and (CharInSet(C1, [NativeSingleQuote, NativeDoubleQuote])) then
    begin
      Delete(Result, L, 1);
      Delete(Result, 1, 1);
    end;
  end;
end;

function StrAfter(const SubStr, S: string): string;
var
  P: Integer;
begin
  P := StrSearch(SubStr, S, 1);
  if P > 0 then
    Result := Copy(S, P + Length(SubStr), Length(S))
  else
    Result := '';
end;

function StrBefore(const SubStr, S: string): string;
var
  P: Integer;
begin
  P := StrSearch(SubStr, S, 1);
  if P > 0 then
    Result := Copy(S, 1, P - 1)
  else
    Result := S;
end;

function StrChopRight(const S: string; N: Integer): string;
begin
  Result := Copy(S, 1, Length(S) - N);
end;

function StrLastPos(const SubStr, S: string): Integer;
var
  NewPos: Integer;
begin
  Result := 0;
  while Result < Length(S) do
  begin
    NewPos := StrSearch(SubStr, S, Result + 1);
    if NewPos > 0 then
      Result := NewPos
    else
      break;
  end;
end;

function StrLeft(const S: string; Count: Integer): string;
begin
  Result := Copy(S, 1, Count);
end;

function StrRestOf(const S: string; N: Integer ): string;
begin
  Result := Copy(S, N, (Length(S) - N + 1));
end;

function StrRight(const S: string; Count: Integer): string;
begin
  Result := Copy(S, Length(S) - Count + 1, Count);
end;

function StrDoubleQuote(const S: string): string;
begin
  Result := NativeDoubleQuote + S + NativeDoubleQuote;
end;

function StrSmartCase(const S: string; Delimiters: TSysCharSet): string;
var
  i: integer;
begin
  // if no delimiters passed then use default set
  if Delimiters = [] then
    Delimiters := NativeWhiteSpace;
  Result := S;
  for i := 1 to Length(Result) do
    if (i = 1) or (CharInSet(Result[i - 1], Delimiters)) then
      Result[i] := UpCase(Result[i]);
end;

function StrCharCount(const S: string; C: Char): Integer;
var
  i: integer;
begin
  Result := 0;
  for i := 1 to Length(S) do
    if S[i] = C then
      inc(Result);
end;

function StrStrCount(const S, SubS: string): Integer;
var
  P: integer;
begin
  Result := 0;
  P := 1;
  while P < Length(S) do
  begin
    P := StrSearch(Subs, S, P);
    if P > 0 then
    begin
      inc(Result);
      inc(P);
    end
    else
      break;
  end;
end;

function StrRepeat(const S: string; Count: Integer): string;
begin
  Result := '';
  while Count > 0 do
  begin
    Result := Result + S;
    Dec(Count);
  end;
end;

procedure StrReplace(var S: string; const Search, Replace: string; Flags: TReplaceFlags = []);
begin
  S := StringReplace(S, Search, Replace, Flags);
end;

function StrSearch(const Substr, S: string; const Index: Integer = 1): Integer;
begin
  // Paul: I expect original code was more efficient :)
  Result := Pos(SubStr, Copy(S, Index, Length(S)));

  if Result > 0 then
    Result := Result + Index - 1;
end;

function BooleanToStr(B: Boolean): string;
const
  BoolToStrMap: array[Boolean] of String =
  (
 { false } 'False',
 { true  } 'True'
  );
begin
  Result := BoolToStrMap[B];
end;

function StrToBoolean(const S: string): Boolean;
var
  LowerS: String;
begin
  LowerS := LowerCase(S);
  if (LowerS = 'false') or (LowerS = 'no') or (LowerS = '0') then
    Result := False
  else
  if (LowerS = 'true') or (LowerS = 'yes') or (LowerS = '1') or (LowerS = '-1') then
    Result := True
  else
    raise EJcfConversionError.Create('Cannot convert string [' + S + '] to boolean');
end;


function StrFind(const Substr, S: string; const Index: Integer = 1): Integer;
begin
  // Paul: original code used comparision by char case table
  Result := StrSearch(LowerCase(SubStr), LowerCase(S), Index);
end;

function StrIsOneOf(const S: string; const List: array of string): Boolean;
var
  i: integer;
begin
  for i := Low(List) to High(List) do
    if CompareStr(List[i], S) = 0 then
    begin
      Result := True;
      Exit;
    end;
  Result := False;
end;

procedure TrimStrings(const List: TStrings; DeleteIfEmpty: Boolean = True);
var
  i: integer;
begin
  if List <> nil then
    for i := List.Count - 1 downto 0 do
    begin
      List[i] := Trim(List[i]);
      if DeleteIfEmpty and (List[i] = '') then
        List.Delete(i);
    end;
end;

function FileToString(const FileName: string): AnsiString;
var
  S: TStream;
begin
  S := nil;
  try
    S := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
    SetLength(Result, S.Size);
    S.Read(PAnsiChar(Result)^, S.Size);
  finally
    S.Free;
  end;
end;

procedure StringToFile(const FileName: string; const Contents: AnsiString);
var
  S: TStream;
begin
  S := nil;
  try
    S := TFileStream.Create(FileName, fmCreate);
    S.Write(PAnsiChar(Contents)^, Length(Contents));
  finally
    S.Free;
  end;
end;

function StrFillChar(const C: Char; Count: Integer): string;
begin
  SetLength(Result, Count);
  if Count > 0 then
    FillChar(Result[1], Count, C);
end;

function IntToStrZeroPad(Value, Count: Integer): String;
begin
  Result := IntToStr(Value);
  while Length(Result) < Count do
    Result := '0' + Result;
end;

// Based on FreePascal version of StringReplace
function WideStringReplace(const S, OldPattern, NewPattern: WideString; Flags: TReplaceFlags): WideString;
var
  Srch, OldP, RemS: WideString; // Srch and Oldp can contain uppercase versions of S,OldPattern
  P: Integer;
begin
  Srch := S;
  OldP := OldPattern;
  if rfIgnoreCase in Flags then
  begin
    Srch := WideUpperCase(Srch);
    OldP := WideUpperCase(OldP);
  end;
  RemS := S;
  Result := '';
  while (Length(Srch) <> 0) do
  begin
    P := Pos(OldP, Srch);
    if P = 0 then
    begin
      Result := Result + RemS;
      Srch := '';
    end
    else
    begin
      Result := Result + Copy(RemS, 1, P - 1) + NewPattern;
      P := P + Length(OldP);
      RemS := Copy(RemS, P, Length(RemS) - P + 1);
      if not (rfReplaceAll in Flags) then
      begin
        Result := Result + RemS;
        Srch := '';
      end
      else
        Srch := Copy(Srch, P, Length(Srch) - P + 1);
    end;
  end;
end;


function PathRemoveExtension(const Path: string): string;
var
  p: Integer;
begin
  // from Lazarus FileUtil
  Result := Path;
  p := Length(Result);
  while (p>0) do
  begin
    case Result[p] of
      PathDelim: Exit;
      '.': Result := copy(Result, 1, p-1);
    end;
    Dec(p);
  end;
end;

function PathExtractFileNameNoExt(const Path: string): string;
begin
  Result := PathRemoveExtension(ExtractFileName(Path));
end;

function PathRemoveSeparator(const Path: string): string;
begin
  Result := Path;
  if (Result <> '') and (Result[Length(Result)] = PathDelim) then
    Delete(Result, Length(Result), 1);
end;

function GetWindowsTempFolder: string;
{$ifndef fpc}
var
  buf: string;
{$endif}
begin
{$ifdef fpc}
  Result := GetTempDir;
{$else}
  SetLength(buf, MAX_PATH);
  SetLength(buf, GetTempPath(Length(buf) + SizeOf(char), PChar(buf)));
  Result:=buf;
  Result := IncludeTrailingPathDelimiter(Result);
{$endif}
end;

// We know that this unit contains platform-specific code
// it's guarded by ifdefs
{$WARN SYMBOL_PLATFORM OFF}

function FileGetSize(const FileName: string): Int64;
{$ifndef fpc}
var
  FileInfo: TSearchRec;
{$endif}
begin
{$ifdef fpc}
  Result := FileUtil.FileSize(FileName);
{$else}
  // from LCL FileUtil code
  FileInfo.Name := Filename;
  FileInfo.FindHandle := Windows.FindFirstFile(Windows.LPTSTR(FileInfo.Name), FileInfo.FindData);
  if FileInfo.FindHandle = Windows.Invalid_Handle_value then
  begin
    Result:=-1;
    Exit;
  end;
  Result := (int64(FileInfo.FindData.nFileSizeHigh) shl 32) + FileInfo.FindData.nFileSizeLow;
  Windows.FindClose(FileInfo.FindHandle);
{$endif}
end;

procedure ShellExecEx(const FileName: string; const Parameters: string = '');
begin
  {$ifdef MSWINDOWS}
    ShellApi.ShellExecute(0, 'open', PChar(FileName), PChar(Parameters), nil, SW_SHOW);
  {$endif}
  {$ifdef unix}
    Shell(format('%s %s',[FileName, Parameters]));
  {$endif}
end;

function GetTickCount: DWord;
begin
{$ifdef MSWINDOWS}
  Result := Windows.GetTickCount;
{$else}
  Result := LCLIntf.GetTickCount;
{$endif}
end;

function IsMultiByte(const pcChar: WideChar): Boolean;
begin
{$ifdef MSWINDOWS}
  Result := IsDBCSLeadByte(Byte(pcChar));
{$else}
  Result := False;
  // TODO: ?
{$endif}
end;

function IsWinVista: Boolean;
begin
{$IFDEF MSWINDOWS}
  Result := Win32MajorVersion = 6;
  // can be also window server 2008
{$ELSE}
  Result := False;
{$ENDIF}
end;

function IsWinXP: Boolean;
begin
{$IFDEF MSWINDOWS}
  Result := (Win32MajorVersion = 5) and (Win32MinorVersion = 1);
{$ELSE}
  Result := False;
{$ENDIF}
end;

function IsWin2k: Boolean;
begin
{$IFDEF MSWINDOWS}
  Result := (Win32MajorVersion = 5) and (Win32MinorVersion = 0);
{$ELSE}
  Result := False;
{$ENDIF}
end;

function IsWin2003: Boolean;
begin
{$IFDEF MSWINDOWS}
  Result := (Win32MajorVersion = 5) and (Win32MinorVersion = 2);
  // can be also window xp 64 bit
{$ELSE}
  Result := False;
{$ENDIF}
end;

end.