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('''');


{$IFNDEF DELPHI12}
{$IFNDEF DELPHI14}
function CharInSet(const C: Char; const testSet: TSysCharSet): Boolean;
{$ENDIF}
{$ENDIF}
function CharIsAlpha(const C: Char): Boolean;
function CharIsAlphaNum(const C: Char): Boolean;
function CharIsWordChar(const c: Char): Boolean;
function CharIsControl(const C: Char): Boolean;
function CharIsDigit(const C: Char): Boolean;
function CharIsReturn(const C: Char): Boolean;
function CharIsWhiteSpace(const C: Char): Boolean;
function CharIsWhiteSpaceNoReturn(const c: Char): boolean;
function CharIsPuncChar(const c: Char): boolean;

function StrIsAlpha(const S: string): Boolean;
function StrIsAlphaNum(const S: string): Boolean;
function CharIsHexDigitDot(const c: Char): Boolean;
function CharIsBinDigit(const c: Char): 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 StrIPos(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 StrPadLeft(const pcOriginal: string;
  const piDesiredLength: integer; const pcPad: Char): string;

//function WideStringReplace(const S, OldPattern, NewPattern: WideString; Flags: TReplaceFlags): WideString;

function PathExtractFileNameNoExt(const Path: string): string;

function PadNumber(const pi: integer): string;
function StrHasAlpha(const str: String): boolean;

type
  EJcfConversionError = class(Exception)
  end;

implementation

uses
{$ifdef MSWINDOWS}
  //Windows, ShellApi
{$endif}
{$ifdef Unix}
  //Unix
{$endif}
  LCLIntf, fileutil;

{$IFNDEF DELPHI12}
{$IFNDEF DELPHI14}
// define  CharInSet for Delphi 2007 or earlier
function CharInSet(const C: Char; const testSet: TSysCharSet): Boolean;
begin
  Result := C in testSet;
end;
{$ENDIF}
{$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 CharIsWordChar(const c: Char): Boolean;
begin
  Result := CharIsAlpha(c) or (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 CharIsWhiteSpaceNoReturn(const c: Char): boolean;
begin
  Result := False;
  if (c = #0) or CharIsReturn(c) then exit;
  // Result := CharIsWhiteSpace(c) and (c <> AnsiLineFeed) and (c <> AnsiCarriageReturn);
  Result := (ord(c) <= Ord(NativeSpace));
end;

function CharIsPuncChar(const c: Char): boolean;
begin
  Result := False;
  if CharIsWhiteSpace(c) then exit;
  if CharIsAlphaNum(c) then exit;
  if CharIsReturn(c) then exit;
  if CharIsControl(c) then exit;
  Result := True;
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 CharIsHexDigitDot(const c: Char): Boolean;
const
  HexDigits: set of AnsiChar = [
    '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
    'A', 'B', 'C', 'D', 'E', 'F',
    'a', 'b', 'c', 'd', 'e', 'f'];
begin
  Result := (c in HexDigits) or (c = '.');
end;

function CharIsBinDigit(const c: Char): Boolean;
const
  BinDigits: set of AnsiChar = ['0','1'];
begin
  Result := (c in BinDigits);
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;

{ case-insensitive "pos" }
function StrIPos(const SubStr, S: string): integer;
begin
  // simple and inneficient implmentation
  Result := Pos(UpperCase(SubStr), UpperCase(s));
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;

{ pad the string on the left had side until it fits }
function StrPadLeft(const pcOriginal: string;
  const piDesiredLength: integer; const pcPad: Char): string;
begin
  Result := pcOriginal;

  while (Length(Result) < piDesiredLength) do
  begin
    Result := pcPad + Result;
  end;

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 PadNumber(const pi: integer): string;
begin
  Result := IntToStrZeroPad(pi, 3);
end;

function StrHasAlpha(const str: String): boolean;
var
  liLoop: integer;
begin
  Result := False;

  for liLoop := 1 to Length(str) do
  begin
    if CharIsAlpha(str[liLoop]) then
    begin
      Result := True;
      break;
    end;
  end;
end;

{------------------------------------------------------
  functions to manipulate file paths in strings }

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;

end.