unit StrUtils;

interface

const
  CR = #13;
  LF = #10;

{                                  }
{  *** Pascal string functions *** }
{                                  }

{ AddBackSlash adds a trailing backslash to a string if one doesn't already }
{ exist. }
function AddBackSlash(const S: string): string;

{ DecStrLen decrements the length of a string by the number specified. }
procedure DecStrLen(var S: string; DecBy: Integer);

{ GetCurLine returns the CR/LF delimited string of which the character }
{ at index Position is an element. }
function GetCurLine(const S: string; Position: Integer): string;

{ GetStrAllocSize returns the memory allocation size of a given string. }
function GetStrAllocSize(const S: string): Longint;

{ GetStrRefCount returns the reference count of a given string. }
function GetStrRefCount(const S: string): Longint;

{ KillChars strips all characters out of string S that are contained in }
{ constant character array A and returns result }
function KillChars(const S: string; A: array of Char; CaseSensitive: Boolean):
  string;

{ LastPos finds the last occurance of SubStr in S }
function LastPos(const SubStr, S: string): Integer;

{ RealizeLength sets string length to null-terminated length. }
procedure RealizeLength(var S: string);

{ RemoveBackSlash removes a trailing backslash from a string if one is }
{ present. }
function RemoveBackSlash(const S: string): string;

{ RemoveSpaces strips all spaces out of string S and returns result }
function RemoveSpaces(const S: string): string;

{ RverseStr reverses the characters in a string, and returns new string }
function ReverseStr(const S: string): string;

{                                  }
{  *** PChar string functions ***  }
{                                  }

{ StrGetCurLine assumes StartPos is a pointer to a long string and    }
{ CurPos points to any character in that string (up to TotalLen bytes }
{ away from StartPos).  This procedure returns the CRLF-delimited     }
{ line of text in LineStart which holds char CurPos^.  The length of  }
{ that line is given by LineLen. }
procedure StrGetCurLine(StartPos, CurPos: PChar; TotalLen: integer;
  var LineStart: PChar; var LineLen: integer);

{ StrLastPos finds the last occurance of Str2 in Str1 }
function StrLastPos(Str1, Str2: PChar): PChar;

{ StrIPos returns the first occurence of Str2 in Str1 with case insensitivity }
function StrIPos(Str1, Str2: PChar): PChar;

{ StrIScan returns the first occurance of Chr in Str with case insensitivity }
function StrIScan(Str: PChar; Chr: Char): PChar;

{ Reverses the characters in a string }
procedure StrReverse(P: PChar);

implementation

uses SysUtils;

type
  TCharSet = set of Char;

{                                  }
{  *** Pascal string functions *** }
{                                  }

function AddBackSlash(const S: string): string;
begin
  Result := S;
  if Result[Length(Result)] <> '\' then  // if last char isn't a backslash...
    Result := Result + '\';              // make it so
end;

procedure DecStrLen(var S: string; DecBy: Integer);
begin
  SetLength(S, Length(S) - DecBy);       // decrement string length by DecBy
end;

function GetCurLine(const S: string; Position: Integer): string;
var
  ResP: PChar;
  ResLen: integer;
begin
  StrGetCurLine(PChar(S), PChar(Longint(S) + Position - 1), Length(S), ResP,
    ResLen);
  SetString(Result, ResP, ResLen);
end;

function GetStrAllocSize(const S: string): Longint;
var
  P: ^Longint;
begin
  P := Pointer(S);                        // pointer to string structure
  dec(P, 3);                              // 12-byte negative offset
  Result := P^ and not $80000000 shr 1;   // ignore bits 0 and 31
end;

function GetStrRefCount(const S: string): Longint;
var
  P: ^Longint;
begin
  P := Pointer(S);                        // pointer to string structure
  dec(P, 2);                              // 8-byte negative offset
  Result := P^;
end;

function KillChars(const S: string; A: array of Char; CaseSensitive: Boolean):
  string;
var
  CharSet: TCharSet;
  i, count: integer;
begin
  CharSet := [];                         // empty character set
  for i := Low(A) to High(A) do begin
    Include(CharSet, A[i]);              // fill set with array items
    if not CaseSensitive then begin      // if not case sensitive, then also
      if A[i] in ['A'..'Z'] then
        Include(CharSet, Chr(Ord(A[i]) + 32))  // include lower cased or
      else if A[i] in ['a'..'z'] then
        Include(CharSet, Chr(Ord(A[i]) - 32))  // include upper cased character
    end;
  end;
  SetLength(Result, Length(S));          // set length to prevent realloc
  count := 0;
  for i := 1 to Length(S) do begin       // iterate over string S
    if not (S[i] in CharSet) then begin  // add good chars to Result
      Result[count + 1] := S[i];
      inc(Count);                        // keep track of num chars copies
    end;
  end;
  SetLength(Result, count);              // set length to num chars copied
end;

function LastPos(const SubStr, S: string): Integer;
var
  FoundStr: PChar;
begin
  Result := 0;
  FoundStr := StrLastPos(PChar(S), PChar(SubStr));
  if FoundStr <> nil then
    Result := (Cardinal(Length(S)) - StrLen(FoundStr)) + 1;
end;

procedure RealizeLength(var S: string);
begin
  SetLength(S, StrLen(PChar(S)));
end;

function RemoveBackSlash(const S: string): string;
begin
  Result := S;
  if Result[Length(Result)] = '\' then   // if last character is a backslash...
    DecStrLen(Result, 1);                // decrement string length
end;

function RemoveSpaces(const S: string): string;
begin
  Result := KillChars(S, [' '], True);
end;

function ReverseStr(const S: string): string;
begin
  Result := S;
  StrReverse(PChar(Result));
end;

{                                  }
{  *** PChar string functions ***  }
{                                  }

procedure StrGetCurLine(StartPos, CurPos: PChar; TotalLen: integer;
                        var LineStart: PChar; var LineLen: integer);
var
  FloatPos, EndPos: PChar;
begin
  FloatPos := CurPos;
  LineStart := nil;
  repeat
    if FloatPos^ = LF then
    begin
      dec(FloatPos);
      if FloatPos^ = CR then
      begin
        inc(FloatPos, 2);
        LineStart := FloatPos;
      end;
    end
    else
      dec(FloatPos);
  until (FloatPos <= StartPos) or (LineStart <> nil);
  if LineStart = nil then LineStart := StartPos;
  FloatPos := CurPos;
  EndPos := StartPos;
  inc(EndPos, TotalLen - 1);
  LineLen := 0;
  repeat
    if FloatPos^ = CR then
    begin
      inc(FloatPos);
      if FloatPos^ = LF then
      begin
        dec(FloatPos, 2);
        LineLen := FloatPos - LineStart + 1;
      end;
    end
    else
      inc(FloatPos);
  until (FloatPos >= EndPos) or (LineLen <> 0);
  if LineLen = 0 then
    LineLen := integer(EndPos) - integer(LineStart);
end;

function StrIPos(Str1, Str2: PChar): PChar;
{ Warning: this function is slow for very long strings. }
begin
  Result := Str1;
  dec(Result);
  repeat
    inc(Result);
    Result := StrIScan(Result, Str2^);
  until (Result = nil) or (StrLIComp(Result, Str2, StrLen(Str2)) = 0);
end;

function StrIScan(Str: PChar; Chr: Char): PChar;
asm
  push  edi                 // save edi
  push  eax                 // save eax (Str addr)
  mov   edi, Str            // store Str in edi
  mov   ecx, $FFFFFFFF      // max counter
  xor   al, al              // null char in al
  repne scasb               // search for null
  not   ecx                 // ecx = length of Str
  pop   edi                 // restore Str in edi
  mov   al, Chr             // put Chr in al
  cmp   al, 'a'             // if al is lowercase...
  jb    @@1
  cmp   al, 'z'
  ja    @@1
  sub   al, $20             // force al to uppercase
@@1:
  mov   ah, byte ptr [EDI]  // put char from Str in ah
  cmp   ah, 'a'             // if al is lowercase...
  jb    @@2
  cmp   ah, 'z'
  ja    @@2
  sub   ah, $20             // force al to uppercase
@@2:
  inc   edi                 // inc to next char in string
  cmp   al, ah              // are chars the same?
  je    @@3                 // jump if yes
  loop  @@1                 // loop if no
  mov   eax, 0              // if char is not in string...
  jne   @@4                 // go to end of proc
@@3:                        // if char is in string...
  mov   eax, edi            // move char position into eax
  dec   eax                 // go back one character because of inc edi
@@4:
  pop   edi                 // restore edi
end;

function StrLastPos(Str1, Str2: PChar): PChar;
var
  Found: Boolean;
begin
  if (Str1 <> nil) and (Str2 <> nil) and (StrLen(Str1) >= StrLen(Str2)) then
  begin
    Found := False;
    Result := Str1;
    inc(Result, StrLen(Str1) - StrLen(Str2));
    repeat
      if StrPos(Result, Str2) <> nil then
        Found := True
      else
        dec(Result);
    until (Result <= Str1) or Found;
    if not Found then Result := nil;
  end
  else
    Result := nil;
end;

procedure StrReverse(P: PChar);
var
  E: PChar;
  c: char;
begin
  if StrLen(P) > 1 then begin
    E := P;
    inc(E, StrLen(P) - 1);          // E -> last char in P
    repeat
      c := P^;                      // store beginning char in temp
      P^ := E^;                     // store end char in beginning
      E^ := c;                      // store temp char in end
      inc(P);                       // increment beginning
      dec(E);                       // decrement end
    until abs(Integer(P) - Integer(E)) <= 1;
  end;
end;

end.