unit TMSIWStrings;

interface

{$I TMSIWCompilerDefines.inc}

uses
  Classes;

// Procs
  function FilterChars(const AInput, AFilter: string): string;
  function FilterCharsAlphaNumeric(const AInput: string): string;
  function FilterCharsText(const AInput: string): string;
  function InvParseCommaString(slst: TStrings):string;
  procedure ParseCommaString(slst:TStrings;const strIn:string);
  function Pluck(const psSearchIn: string; psStart, psEnd: String; const pbIgnoreCase: boolean): String;
  function TrimWhiteSpace(const psString: string): string;
  procedure RemoveEmptyLines(AStrings: TStrings);
  procedure RemoveTrailingEmptyLines(AStrings: TStrings);
  //
  function Fetch(var s1: string; const asDelim: string = ' '; const ADelete: Boolean = True;
   const ACaseSensitive: Boolean = True): string;
  function Pad(const s: string; piCount: Integer; const pcPadChar: Char = ' '): string;
  function CountChr(Chr: Char; Str: String): Integer;
  function QuoteSpaces(const s: string): string;
  procedure RemoveTrailingChars(var s: string; const CharToRemove: Char);

  { Replace '&lt;' and '&gt;' with '<' and '>'. At least 2x faster than 2 calls to StringReplace }
  function DecodeLtGt(const s: string): string;

  { Remove every occurrence of #13 and #10. MUCH faster than 2 calls to StringReplace }
  function RemoveLFCR(const s: string): string;

  function EscapeJsonString(const s: string): string;
  function PosIdx(const ASubStr, AStr: string; AStartPos: LongWord): LongWord;
  function PathEncode(const ASrc: string): string;

implementation

uses
  SysUtils;

var
  gsTextFilter: string;

function PosIdx(const ASubStr, AStr: string; AStartPos: LongWord): LongWord;
  // use best register allocation on Win32
  function FindStr(ALStartPos, EndPos: LongWord; StartChar: Char; const ALStr: string): LongWord;
  begin
    for Result := ALStartPos to EndPos do begin
      if ALStr[Result] = StartChar then begin
        Exit;
      end;
    end;
    Result := 0;
  end;

  // use best register allocation on Win32
  function FindNextStr(ALStartPos, EndPos: LongWord; const ALStr, ALSubStr: string): LongWord;
  begin
    for Result := ALStartPos + 1 to EndPos do begin
      if ALStr[Result] <> ALSubStr[Result - ALStartPos + 1] then begin
        Exit;
      end;
    end;
    Result := 0;
  end;

var
  StartChar: Char;
  LenSubStr, LenStr: LongWord;
  EndPos: LongWord;
begin
  if AStartPos = 0 then begin
    AStartPos := 1;
  end;
  Result := 0;
  LenSubStr := Length(ASubStr);
  LenStr := Length(AStr);
  if (LenSubStr = 0) or (AStr = '') or (LenSubStr > (LenStr - (AStartPos - 1))) then begin
    Exit;
  end;
  StartChar := ASubStr[1];
  EndPos := LenStr - LenSubStr + 1;
  if LenSubStr = 1 then begin
    Result := FindStr(AStartPos, EndPos, StartChar, AStr)
  end else
  begin
    repeat
      Result := FindStr(AStartPos, EndPos, StartChar, AStr);
      if Result = 0 then begin
        Break;
      end;
      AStartPos := Result;
      Result := FindNextStr(Result, AStartPos + LenSubStr - 1, AStr, ASubStr);
      if Result = 0 then
      begin
        Result := AStartPos;
        Exit;
      end;
      Inc(AStartPos);
    until False;
  end;
end;

function PathEncode(const ASrc: string): string;
const
  UnsafeChars: TSysCharSet = ['*', '<', '>', '#', '%', '"', '{', '}', '|', '\', '^', '[', ']', '`', '+'];  {do not localize}
var
  i: Integer;
  LChar: Char;
begin
  Result := '';
  if ASrc = '' then begin
    Exit;
  end;
  i := 0;
  while i < Length(ASrc) do begin
    LChar := ASrc[i+1];
    if CharInSet(LChar, UnsafeChars) or (Ord(LChar) < 33) or (Ord(LChar) > 127) then begin
      Result := Result + '%' + IntToHex(Ord(LChar), 2);
      Inc(i);
    end else begin
      Result := Result + LChar;
      Inc(i);
    end;
  end;
end;

function InvParseCommaString(slst: TStrings):string;
var
	intIndex: integer;
begin
  // Take a stringlist and returns a string seperating items with commas
	result := '' ;
	for intIndex := 0 to Pred ( slst.Count ) do begin
  	result := result + slst.Strings[intIndex] + ',' ;
  end;
  result := Copy ( result, 1, Length (result) - 1 );
end ;

procedure ParseCommaString(slst:TStrings;const strIn:string);
var
    intStart,
    intEnd,
		intQuote,
    intPos,
    intLength : integer ;
    strTemp : string ;
begin
    intQuote := 0;
    intPos := 1 ;
    intLength := Length ( strIn ) ;
    slst.Clear ;
    while ( intPos <= intLength ) do begin
      	intStart := intPos ;
        intEnd := intStart ;
        while ( intPos <= intLength ) do begin
          	if strIn [ intPos ] = '"' then begin
            	inc(intQuote);
            end;
          	if strIn[ intPos ]= ',' then begin
            	if intQuote <> 1 then begin
              	break;
              end;
            end;
						inc ( intEnd ) ;
            inc ( intPos ) ;
          end ;
      strTemp := Trim ( Copy ( strIn , intStart , intEnd - intStart ) ) ;
      if strTemp <> '' then begin
      	slst.Add ( strTemp );
      end;
      intPos := intEnd + 1 ;
      intQuote := 0 ;
    end ;
end;

function Pluck;
var
  iStart, iEnd: integer;
  s: string;
begin
  if pbIgnoreCase then begin
    s := Uppercase(psSearchIn);
    psStart := Uppercase(psStart);
    psEnd := Uppercase(psEnd);
  end else begin
    s := psSearchIn;
  end;

  Result := '';
  iStart := Pos(psStart, s);

	iEnd := Pos(psEnd, Copy(s, iStart + Length(psStart), MaxInt)) + iStart;
  if iStart + iEnd > 0 then begin
 		Result := Copy(psSearchIn, iStart +  Length(psStart), iEnd - iStart-length(psEnd));
  end;
end;

function Pad;
begin
  if piCount < Length(S) then begin
    piCount := Length(S);
  end;
  SetLength(Result, piCount);
  FillChar(Result[1], piCount, pcPadChar);
  Move(S[1], Result[1], Length(S));
end;

function Fetch(var s1: string; const asDelim: string = ' '; const ADelete: Boolean = true;
 const ACaseSensitive: boolean = true): string;
var
	iPos: Integer;
  TmpDelim,
  Tmps1: string;
begin
  if not ACaseSensitive then begin
    //TODO: This sucks... use a better way...
    // both because of the uppercase and the copy to a temp string
    TmpDelim := UpperCase(asDelim);
    Tmps1 := UpperCase(s1);
  end else begin
    TmpDelim := asDelim;
    Tmps1 := s1;
  end;
	iPos := Pos(TmpDelim, Tmps1);
	if iPos = 0 then begin
		Result := s1;
    if ADelete then begin
    	s1 := '';
    end;
	end else begin
		result := Copy(s1, 1, iPos - 1);
    if ADelete then begin
			Delete(s1, 1, iPos + Length(TmpDelim) - 1);
    end;
	end;
end;

function TrimWhitespace;
begin
  result := psString;
  {TODO Improve this - too many delets/setlenghts}
  while length(result) > 0 do begin
    if Ord(result[1]) < 33 then
      Delete(result, 1, 1)
    else
      break;
  end;
  while length(result) > 0 do begin
    if Ord(result[Length(result)]) < 33 then
      SetLength(result, Length(result) - 1)
    else
      break;
  end;
end;

function FilterCharsAlphaNumeric(const AInput: string): string;
begin
  result := FilterChars(AInput, 'ABCDDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz1234567890 ');
end;

function FilterChars(const AInput, AFilter: string): string;
var
  inPos, outPos: Integer;
  Len: Integer;
begin
  Len := Length(AInput);
  if (Len > 0) and (Length(AFilter) > 0) then begin
    SetLength(Result, Len);
    inPos := 1;
    outPos := 1;
    while inPos <= Len do begin
      if (Pos(AInput[inPos], AFilter) > 0) then begin
        Result[outPos] := AInput[inPos];
        Inc(outPos);
      end;
      Inc(inPos);
    end;
    SetLength(Result, outPos - 1);
  end else begin
    Result := AInput;
  end;
end;

function FilterCharsText(const AInput: string): string;
var
  i: integer;
begin
  if length(gsTextFilter) = 0 then begin
    for i := 32 to 127 do begin
      SetLength(gsTextFilter, 127 - 32 + 1);
      gsTextFilter[i - 31] := Chr(i);
    end;
  end;
  result := FilterChars(AInput, gsTextFilter);
end;

procedure RemoveTrailingEmptyLines(AStrings: TStrings);
begin
  if AStrings.Count > 0 then begin
    while Trim(AStrings.Strings[AStrings.Count - 1]) = '' do begin
      AStrings.Delete(AStrings.Count - 1);
      if AStrings.Count = 0 then begin
        Break;
      end;
    end;
  end;
end;

procedure RemoveEmptyLines(AStrings: TStrings);
var
  i: Integer;
begin
  for i := AStrings.Count - 1 downto 0 do begin
    if Trim(AStrings.Strings[i]) = '' then begin
      AStrings.Delete(i);
   end;
  end;
end;

function CountChr(Chr: Char; Str: String): Integer;
var
  i: integer;
begin
  result := 0;
  for i := 1 to length(Str) do begin
    if Str[i] = Chr then begin
      Inc(Result);
    end;
  end;
end;

function QuoteSpaces(const s: string): string;
begin
  if Pos(' ', s) > 0 then
    Result := QuotedStr(s)
  else
    Result := s;
end;

// Remove all "CharToRemove" from the end of the string "s"
procedure RemoveTrailingChars(var s: string; const CharToRemove: Char);
var
  Len, NewLen: Integer;
begin
  Len := Length(s);
  NewLen := Len;
  while (NewLen > 0) do begin
    if (s[NewLen] = CharToRemove) then begin
      Dec(NewLen);
    end else begin
      break;
    end;
  end;
  if NewLen < Len then begin
    SetLength(s, NewLen);
  end;
end;

function DecodeLtGt(const s: string): string;
var
  inPos, outPos: Integer;
  Len: Integer;
begin
  Len := Length(s);
  if Len > 0 then begin
    SetLength(Result, Len);
    inPos := 1;
    outPos := 1;
    while inPos <= Len do begin
      if (s[inPos] = '&') and ((inPos + 3) <= Len) and CharInSet(s[inPos+1], ['l', 'g']) and
        (s[inPos+2] = 't') and (s[inPos+3] = ';') then begin
          if s[inPos+1] = 'l' then begin
            Result[outPos] := '<';
          end else begin
            Result[outPos] := '>';
          end;
        Inc(inPos, 4);
      end
      else begin
        Result[outPos] := s[inPos];
        Inc(inPos);
      end;
      Inc(outPos);
    end;
    SetLength(Result, outPos - 1);
  end else begin
    Result := '';
  end;
end;

function RemoveLFCR(const s: string): string;
var
  inPos, outPos: Integer;
  Len: Integer;
begin
  Len := Length(s);
  if Len > 0 then begin
    SetLength(Result, Len);
    inPos := 1;
    outPos := 1;
    while inPos <= Len do begin
      if (s[inPos] <> #13) and (s[inPos] <> #10) then begin
        Result[outPos] := s[inPos];
        Inc(outPos);
      end;
      Inc(inPos);
    end;
    SetLength(Result, outPos - 1);
  end else begin
    Result := '';
  end;
end;

// Escape a string to be used as Json string
//  LF = '\n'; CR = '\r'; Quote = '\"';
function EscapeJsonString(const s: string): string;
var
  inPos, outPos: Integer;
  Len: Integer;
begin
  Len := Length(s);
  if Len > 0 then begin
    SetLength(Result, Len * 2);
    inPos := 1;
    outPos := 1;
    while inPos <= Len do begin
      if (s[inPos] = '"') then begin
        Result[outPos] := '\';
        Result[outPos + 1] := '"';
        inc(outPos);
      end else
      if (s[inPos] = #10) then begin
        Result[outPos] := '\';
        Result[outPos + 1] := 'n';
        inc(outPos);
      end else
      if (s[inPos] = #13) then begin
        Result[outPos] := '\';
        Result[outPos + 1] := 'r';
        inc(outPos);
      end else begin
        Result[outPos] := s[inPos];
      end;
      inc(outPos);
      inc(inPos);
    end;
    SetLength(Result, outPos - 1);
  end else begin
    Result := '';
  end;
end;

end.

