Media Share 9/MEDIASHARE_09.ISO/pascal/shdk_1.zip/SHLNGSTR.PAS

Pascal/Delphi Source File | 1992-03-24 | 44KB | 1,391 lines

{$R-,V-}
unit ShLngStr;
{
                                ShLngStr

                    A Long String Manipulation Unit

                                   by

                              Bill Madison

                   W. G. Madison and Associates, Ltd.
                          13819 Shavano Downs
                            P.O. Box 780956
                       San Antonio, TX 78278-0956
                             [phone]
                             CIS 73240,342

                  Copyright 1991 Madison & Associates
                          All Rights Reserved

        This file may  be used and distributed  only in accord-
        ance with the provisions described on the title page of
                  the accompanying documentation file
                              SKYHAWK.DOC
}

interface

uses
  TpInline,
  TpString,
  TpMemChk;

const
  MaxLongString = 65517; {Maximum length of LongString.}
  NotFound = 0;          {Returned by the Pos functions if substring not found}
  RingSize : byte = 25;

type
  LongStringType  = record
                      Length,
                      dLength : word;
                      lsData  : array[1..1] of char;
                      end;
  LongString      = ^LongStringType;
  lsCompType      = (Less, Equal, Greater);
  CharSet         = set of Char;

  {========== MEMORY MANAGEMENT =============================================}

function lsInit(var A  : LongString; L : word)  : boolean;
  {"Declares" a LongString of maximum declared length L and establishes
   space for it on the heap. Returns false if L is greater than
   MaxLongString.}

procedure lsDispose(var A : LongString);
  {-Dispose of A, releasing its heap space}

  {========== GENERAL HOUSEKEEPING ==========================================}

function lsComp(A1, A2 : LongString) : lsCompType;
  {-Compares A1 to A2, returning LESS, EQUAL, or GREATER}

function lsCount(A, Obj : LongString):  word;
function lsCountStr(A : LongString; Obj : string) : word;
  {-Returns the number of occurrences of Obj in A}

function lsCountUC(A, Obj : LongString):  word;
function lsCountStrUC(A : LongString; Obj : string) : word;
  {-Returns the number of occurrences of Obj in A}
  { The search is not CASE SENSITIVE.}

function lsLength(A : LongString) : word;
  {-Return the length of a LongString. A must have been lsInited}

function lsPos(Obj, A : LongString) : word;
function lsPosStr(Obj : string; A : LongString) : word;
  {-Return the position of Obj in A, returning NotFound if not found}

function lsPosUC(Obj, A : LongString) : word;
function lsPosStrUC(Obj : string; A : LongString) : word;
  {-Return the position of Obj in A, returning NotFound if not found.
   The search is not CASE SENSITIVE.}

function lsSizeOf(A : LongString) : word;
  {-Returns the total heap space required for A. A must have been lsInited}

  {========== LONGSTRING TRANSFER (ASSIGNMENT) ==============================}

procedure lsTransfer(A, B : LongString);
  {Transfers the contents of A into B}
  {NOTE: B^ := A^ yields unpredictable results. DO NOT USE!

  {========== STRING <-> LONGSTRING TYPE CONVERSION =========================}

function lsLongString2Str(A : LongString) : string;
  {-Convert LongString to Turbo string, truncating if longer than 255 chars}

procedure lsStr2LongString(S : string; A : LongString);
function lsStr2LongStringF(S : string)  : LongString;
  {-Convert a Turbo string into a LongString}

  {========== MANIPULATING LONGSTRINGS, STRINGS =============================}

procedure lsConcat(A, B, C : LongString);
function lsConcatF(A, B : LongString) : LongString;
  {-Concatenate two LongString strings, returning a third}

procedure lsConcatStr2Ls(A : LongString; S : string; C : LongString);
function lsConcatStr2LsF(A : LongString; S : string)  : LongString;
  {-Concatenate a string to a LongString, returning a new LongString}

procedure lsConcatLs2Str(S : string; A : LongString; C : LongString);
function lsConcatLs2StrF(S : string; A : LongString)  : LongString;
  {-Concatenate a LongString to a string, returning a new LongString}

  {========== SUBSTRINGS OF LONGSTRINGS, STRINGS ============================}

procedure lsCopy(A  : LongString; Start, Len  : word; B : LongString);
function lsCopyF(A  : LongString; Start, Len  : word)  : LongString;
  {-Return a long substring of A. Note Start=1 for first char in A}

procedure lsDelete(A : LongString; Start, Len : word; B : LongString);
function lsDeleteF(A : LongString; Start, Len  : word) : LongString;
  {-Delete Len characters of A, starting at position Start}

procedure lsInsert(A, Obj : LongString; Start : word; B : LongString);
function lsInsertF(A, Obj : LongString; Start : word) : LongString;
  {-Insert LongString Obj into A at position Start returning a new LongString}

procedure lsInsertStr(A : LongString; Obj : string;
                      Start : word; B : LongString);
function lsInsertStrF(A : LongString; Obj : string;
                      Start : word) : LongString;
  {-Insert string Obj into A at position Start returning a new LongString}

type
  lsDelimSetType  = set of char;

const
  lsDelimSet  : lsDelimSetType = [#0..#32];

procedure lsGetNext(LS1, LS2  : LongString);
function lsGetNextF(LS1 : LongString) : LongString;
procedure lsGetNextStr(LS1  : LongString; var S2  : string);
function lsGetNextStrF(LS1  : LongString) : string;
  {-Returns the next substring of LS1 which is delimited by a member
    of lsDelimSet.)

  {========== LONGSTRING TRANSFORMATIONS ====================================}

procedure lsCenter(A : LongString; Width : word; B : LongString);
function lsCenterF(A : LongString; Width : word)  : LongString;
  {-Return a LongString centered in a LongString of blanks with specified
    width}

procedure lsCenterCh(A : LongString; Ch : Char; Width : word; B : LongString);
function lsCenterChF(A : LongString; Ch : Char; Width : word) : LongString;
  {-Return a LongString centered in a LongString of Ch with specified width}

procedure lsCharStr(Ch : Char; Len : word; A : LongString);
function lsCharStrF(Ch : Char; Len : word) : LongString;
  {-Return a LongString of length Len filled with Ch}

procedure lsLeftPad(A : LongString; Len : word; B : LongString);
function lsLeftPadF(A : LongString; Len : word) : LongString;
  {-Left-pad the LongString in A to length Len with blanks, returning
    a new LongString}

procedure lsLeftPadCh(A : LongString; Ch : Char; Len : word; B : LongString);
function lsLeftPadChF(A : LongString; Ch : Char; Len : word)  : LongString;
  {-Left-pad the LongString in A to length Len with Ch, returning a new
    LongString}

procedure lsLocase(A, B : LongString);
function lsLocaseF(A  : LongString) : LongString;
  {-Lowercase the LongString in A, returning a new LongString}

procedure lsPad(A : LongString; Len : word; B : LongString);
function lsPadF(A : LongString; Len : word) : LongString;
  {-Right-pad the LongString in A to length Len with blanks, returning
    a new LongString}

procedure lsPadCh(A : LongString; Ch : Char; Len : word; B : LongString);
function lsPadChF(A : LongString; Ch : Char; Len : word)  : LongString;
  {-Right-pad the LongString in A to length Len with Ch, returning
    a new LongString}

procedure lsTrim(A, B : LongString);
function lsTrimF(A  : LongString) : LongString;
  {-Return a LongString with leading and trailing white space removed}

procedure lsTrimLead(A, B : LongString);
function lsTrimLeadF(A  : LongString): LongString;
  {-Return a LongString with leading white space removed}

procedure lsTrimTrail(A, B : LongString);
function lsTrimTrailF(A : LongString) : LongString;
  {-Return a LongString with trailing white space removed}

procedure lsTrimLeadSet(A : LongString; CS : CharSet; B : LongString);
function lsTrimLeadSetF(A : LongString; CS : CharSet) : LongString;
  {-Returns a LongString with leading characters in CS stripped.}

procedure lsTrimTrailSet(A : LongString; CS : CharSet; B : LongString);
function lsTrimTrailSetF(A : LongString; CS : CharSet) : LongString;
  {-Returns a LongString with trailing characters in CS stripped.}

procedure lsTrimSet(A : LongString; CS : CharSet; B : LongString);
function lsTrimSetF(A  : LongString; CS : CharSet) : LongString;
  {-Returns a LongString with characters in CS stripped.}

procedure lsUpcase(A, B : LongString);
function lsUpcaseF(A  : LongString) : LongString;
  {-Uppercase the LongString in A, returning a new LongString}

  {========== GLOBAL PROCESSING =============================================}

procedure lsDelAll(A, Obj, B : LongString);
function lsDelAllF(A, Obj : LongString):  LongString;
procedure lsDelAllStr(A : LongString; Obj : string; B : LongString);
function lsDelAllStrF(A : LongString; Obj : string) : LongString;
  {-Deletes all occurrences of Obj in A}

procedure lsDelAllUC(A, Obj, B : LongString);
function lsDelAllUCF(A, Obj : LongString):  LongString;
procedure lsDelAllStrUC(A : LongString; Obj : string; B : LongString);
function lsDelAllStrUCF(A : LongString; Obj : string) : LongString;
  {-Deletes all occurrences of Obj in A}
  { The search is not CASE SENSITIVE.}

procedure lsRepAll(A, Obj, Obj1, B : LongString);
function lsRepAllF(A, Obj, Obj1 : LongString):  LongString;
procedure lsRepAllStr(A : LongString; Obj, Obj1 : string; B : LongString);
function lsRepAllStrF(A : LongString; Obj, Obj1 : string) : LongString;
  {-Replaces all occurrences of Obj in A with Obj1}

procedure lsRepAllUC(A, Obj, Obj1, B : LongString);
function lsRepAllUCF(A, Obj, Obj1 : LongString):  LongString;
procedure lsRepAllStrUC(A : LongString; Obj, Obj1 : string; B : LongString);
function lsRepAllStrUCF(A : LongString; Obj, Obj1 : string) : LongString;
  {-Replaces all occurrences of Obj in A with Obj1}
  { The search is not CASE SENSITIVE.}

  {========== INPUT / OUTPUT ================================================}

procedure lsReadLn(var F : Text; A : LongString);
  {-Read a LongString from text file}

procedure lsWriteLn(var F : Text; A : LongString);
  {-Write a LongString to text file}

procedure lsIon;
  {-Has the same effect with respect to lsReadLn, lsWriteLn as the $I+
    compiler has with respect to normal I/O operations, except that
    the reported error address is meaningless.}

procedure lsIoff;
  {-Has the same effect with respect to lsReadLn, lsWriteLn as the $I-
    compiler has with respect to normal I/O operations, except that
    the reported error address is meaningless.}

function lsIoResult : word;
  {-Returns the value of IoResult resulting from the last lsReadLn or
    lsWriteLn. NOTE: You MUST use lsIoResult for checking lsReadLn,
    lsWriteLn. If you call IoResult instead, you will always get a 0
    return.}

implementation


const
  RuntimeErrorNumber  : word = 250;
  lsIoRes : word = 0;
  lsIoCheck : boolean = true;
  Blank : char = #32;
  MaxRingSize   = 100;
  RingSizeM1 = MaxRingSize - 1;

var
  Ring       : array[0..RingSizeM1] of LongString;
  RingPtr    : ShortInt;

function Ptr2Str(P:pointer) : string; {For debugging only!}
  begin
    Ptr2Str := HexPtr(Normalized(P));
    end;

function max(X, Y : word) : word;
  begin
    if X >= Y then
      max := X
    else
      max := Y;
    end; {max}

function min(X, Y : word) : word;
  begin
    if X <= Y then
      min := X
    else
      min := Y;
    end; {min}

function lsInit(var A  : LongString; L : word)  : boolean;
  {"Declares" a LongString of maximum declared length L and establishes
   space for it on the heap. Returns false if L is greater than
   MaxLongString.}
  var
    B1  : boolean;
  begin
    if L > MaxLongString then begin
      lsInit := false;
      exit;
      end {if}
    else begin
      B1 := GetMemCheck(A, L+(2*SizeOf(word)));
      if not B1 then RunError(RuntimeErrorNumber);
      lsInit := true;
      A^.dLength := L;
      A^.Length := 0;
      end; {else}
    end; {lsInit}

procedure lsDispose(var A : LongString);
  {-Dispose of A, releasing its heap space}
  begin
    FreeMemCheck(A, A^.dLength+(2*SizeOf(word)));
    A := nil;
    end; {lsDispose}

function NextInRing(L  : word) : LongString;
  {-lsInits the next LongString on the ring buffer, lsDisposing of its
    current contents, if any.}
  var
    RuntimeErrorNumSave : word;
  begin
    RuntimeErrorNumber := 251;
    RingPtr := (RingPtr+1) mod RingSize;
    if Ring[RingPtr] <> nil then
      lsDispose(Ring[RingPtr]);
    if not lsInit(Ring[RingPtr], L) then
      NextInRing := nil
    else
      NextInRing := Ring[RingPtr];
    RuntimeErrorNumber := RuntimeErrorNumSave;
    end; {NextInRing}

procedure lsTransfer(A, B : LongString);
  {Transfers the contents of A to B.
   Truncates if the declared length of B is less than the length of A.}
  begin
    if Normalized(A) = Normalized(B) then exit;
    B^.Length := min(A^.Length, B^.dLength);
    move(A^.lsData, B^.lsData, B^.Length);
    end; {lsTransfer}

function lsLength(A : LongString) : word;
  {-Return the length of a LongString string}
  begin
    lsLength := A^.Length;
    end; {lsLength}

function lsSizeOf(A : LongString) : word;
  {-Returns the **declared** length of A + the overhead words}
  begin
    lsSizeOf := A^.dLength + (2*SizeOf(word));
    end; {lsSizeOf}

function lsLongString2Str(A : LongString) : string;
  {-Convert LongString to Turbo string, truncating if longer than 255 chars}
  var
    S : string;
  begin
    S[0] := char(min(A^.Length, 255));
    move(A^.lsData, S[1], byte(S[0]));
    lsLongString2Str := S;
    end; {lsLongString2Str}

procedure lsStr2LongString(S : string; A : LongString);
  {-Convert a Turbo string into a LongString. The LongString must have
   been declared.}
  begin
    if A = nil then exit;
    A^.Length := min(A^.dLength, byte(S[0]));
    move(S[1], A^.lsData, A^.Length);
    end; {lsStr2LongString}

function lsStr2LongStringF(S : string)  : LongString;
  {-Convert a Turbo string into a LongString}
  var
    ThisLs  : LongString;
  begin
    ThisLs := NextInRing(byte(S[0]));
    lsStr2LongStringF := ThisLs;
    lsStr2LongString(S, ThisLs);
    end; {lsStr2LongStringF}

procedure lsCopy(A  : LongString; Start, Len  : word; B : LongString);
  {-Return a long substring of A. Note Start=1 for first char in A}
  begin
    if B = nil then exit;
    if (A = nil) or (Start > A^.Length) then begin
      B^.Length := 0;
      exit;
      end;
    if ((Start-1) + Len) > A^.Length then
      Len := A^.Length - Start + 1;
    B^.Length := min(Len, B^.dLength);
    move(A^.lsData[Start], B^.lsData, Len);
    end; {lsCopy}

function lsCopyF(A  : LongString; Start, Len  : word)  : LongString;
  {-Return a long substring of A. Note Start=1 for first char in A}
  var
    ThisLs  : LongString;
  begin
    ThisLs := NextInRing(Len);
    lsCopyF := ThisLs;
    lsCopy(A, Start, Len, ThisLs);
    end; {lsCopyF}

procedure lsDelete(A : LongString; Start, Len : word; B : LongString);
  {-Delete Len characters of A, starting at position Start}
  begin
    lsTransfer(A, B);
    if Start > B^.Length then exit;
    if Len > B^.Length - (Start - 1) then
      Len := B^.Length - (Start - 1);
    B^.Length := B^.Length - Len;
    move(B^.lsData[Start+Len], B^.lsData[Start], B^.Length - (Start - 1));
    end; {lsDelete}

function lsDeleteF(A  : LongString; Start, Len  : word) : LongString;
  {-Delete Len characters of A, starting at position Start}
  {-The function form returns A unchanged.}
  var
    ThisLs  : LongString;
  begin
    if Start > A^.Length then begin
      lsDeleteF := nil;
      exit;
      end;
    if Len > A^.Length - (Start - 1) then
      Len := A^.Length - (Start - 1);
    ThisLs := NextInRing(A^.Length - Len);
    ThisLs^.Length := A^.Length - Len;
    move(A^.lsData[1], ThisLs^.lsData[1], Start - 1);
    move(A^.lsData[Start+Len], ThisLs^.lsData[Start], A^.Length - (Start - 1));
    lsDeleteF := ThisLs;
    end; {lsDeleteF}

procedure lsConcat(A, B, C : LongString);
  {-Concatenate two LongString strings, returning a third}
  var
    CpyFromA,
    CpyFromB  : word;
  begin
    if A^.Length > C^.dLength then begin
      CpyFromA := C^.dLength;
      CpyFromB := 0;
      end
    else begin
      if A^.Length + B^.Length > C^.dLength then begin
        CpyFromA := A^.Length;
        CpyFromB := C^.dLength - CpyFromA;
        end
      else begin
        CpyFromA := A^.Length;
        CpyFromB := B^.Length;
        end;
      end;
    C^.Length := CpyFromA + CpyFromB;
    move(A^.lsData, C^.lsData, CpyFromA);
    move(B^.lsData, C^.lsData[CpyFromA + 1], CpyFromB);
    end; {lsConcat}

function lsConcatF(A, B : LongString) : LongString;
  {-Concatenate two LongString strings, returning a third}
  var
    ThisLs  : LongString;
    CpyFromB: word;
  begin
    if A^.Length + B^.Length > MaxLongString then
      CpyFromB := MaxLongString - A^.Length
    else
      CpyFromB := B^.Length;
    ThisLs := NextInRing(A^.Length + CpyFromB);
    lsConcatF := ThisLs;
    lsConcat(A, B, ThisLs);
    end; {lsConcatF}

procedure lsConcatStr2Ls(A : LongString; S : string; C : LongString);
  {-Concatenate a string to a LongString, returning a new LongString}
  var
    LS  : LongString;
  begin
    if not lsInit(LS, A^.Length + byte(S[0])) then exit;
    lsStr2LongString(S, LS);
    lsConcat(A, LS, C);
    lsDispose(LS);
    end; {lsConcatStr2Ls}

function lsConcatStr2LsF(A : LongString; S : string)  : LongString;
  {-Concatenate a string to a LongString, returning a new LongString}
  var
    LS  : LongString;
  begin
    if not lsInit(LS, A^.Length + byte(S[0])) then exit;
    lsStr2LongString(S, LS);
    lsConcatStr2LsF := lsConcatF(A, LS);
    lsDispose(LS);
    end; {lsConcatStr2LsF}

procedure lsConcatLs2Str(S : string; A : LongString; C : LongString);
  {-Concatenate a LongString to a string, returning a new LongString}
  var
    LS  : LongString;
  begin
    if not lsInit(LS, A^.Length + byte(S[0])) then exit;
    lsStr2LongString(S, LS);
    lsConcat(LS, A, C);
    lsDispose(LS);
    end; {lsConcatLs2Str}

function lsConcatLs2StrF(S : string; A : LongString)  : LongString;
  {-Concatenate a LongString to a string, returning a new LongString}
  var
    LS  : LongString;
  begin
    if not lsInit(LS, A^.Length + byte(S[0])) then exit;
    lsStr2LongString(S, LS);
    lsConcatLs2StrF := lsConcatF(LS, A);
    lsDispose(LS);
    end; {lsConcatLs2StrF}

procedure lsInsert(A, Obj : LongString; Start : word; B : LongString);
  {-Insert LongString Obj into A at position Start returning a new LongString}
  var
    FrontOfA,
    RestOfA,
    CpyFromO  : word;
  begin
    FrontOfA := min(Start-1, B^.dLength);
    if (B^.dLength - FrontOfA) > Obj^.Length then
      CpyFromO := Obj^.Length
    else
      CpyFromO := B^.dLength - FrontOfA;
    if (B^.dLength - (FrontOfA + CpyFromO)) > (A^.Length - FrontOfA) then
      RestOfA := A^.Length - FrontOfA
    else
      RestOfA := B^.dLength - (FrontOfA + CpyFromO);
    B^.Length := FrontOfA + CpyFromO + RestOfA;
    move(A^.lsData, B^.lsData, FrontOfA);
    move(A^.lsData[Start], B^.lsData[FrontOfA + CpyFromO + 1], RestOfA);
    move(Obj^.lsData, B^.lsData[Start], CpyFromO);
    end; {lsInsert}

function lsInsertF(A, Obj : LongString; Start : word) : LongString;
  {-Insert LongString Obj into A at position Start returning a new LongString}
  var
    ThisLs  : LongString;
  begin
    ThisLs := NextInRing(A^.Length + Obj^.Length);
    lsInsertF := ThisLs;
    lsInsert(A, Obj, Start, ThisLs);
    end; {lsInsertF}

procedure lsInsertStr(A : LongString; Obj : string;
                      Start : word; B : LongString);
  {-Insert string Obj into A at position Start returning a new LongString}
  var
    LS  : LongString;
  begin
    if not lsInit(LS, byte(Obj[0])) then exit;
    lsStr2LongString(Obj, LS);
    lsInsert(A, LS, Start, B);
    lsDispose(LS);
    end; {lsInsertStr}

function lsInsertStrF(A : LongString; Obj : string;
                      Start : word) : LongString;
  {-Insert string Obj into A at position Start returning a new LongString}
  var
    LS  : LongString;
  begin
    if not lsInit(LS, byte(Obj[0])) then exit;
    lsStr2LongString(Obj, LS);
    lsInsertStrF := lsInsertF(A, LS, Start);
    lsDispose(LS);
    end; {lsInsertStrF}

procedure lsUpcase(A, B : LongString);
  {-Uppercase the LongString in A, returning B}
  var
    W1    : word;
  begin
    lsTransfer(A, B);
    for W1 := 1 to B^.Length do
      B^.lsData[W1] := Upcase(B^.lsData[W1]);
    end; {lsUpcase}

function lsUpcaseF(A  : LongString) : LongString;
  {-Uppercase the LongString in A, returning B}
  var
    ThisLs  : LongString;
  begin
    ThisLs := NextInRing(A^.Length);
    lsUpcase(A, ThisLs);
    lsUpcaseF := ThisLs;
    end; {lsUpcaseF}

procedure lsLocase(A, B : LongString);
  {-Lowercase the LongString in A, returning B}
  var
    W1    : word;
  begin
    lsTransfer(A, B);
    for W1 := 1 to B^.Length do
      B^.lsData[W1] := Locase(B^.lsData[W1]);
    end; {lsLocase}

function lsLocaseF(A  : LongString) : LongString;
  {-Lowercase the LongString in A, returning B}
  var
    ThisLs  : LongString;
  begin
    ThisLs := NextInRing(A^.Length);
    lsLocase(A, ThisLs);
    lsLocaseF := ThisLs;
    end; {lsLocaseF}

function lsComp(A1, A2 : LongString) : lsCompType;
  {-Compares A1 to A2, returning LESS, EQUAL, or GREATER}
  var
    W1,
    Search  : word;
    LgthA1A2: lsCompType;
  begin
    if A1^.Length = A2^.Length then
      LgthA1A2 := Equal
    else
      if A1^.Length < A2^.Length then
        LgthA1A2 := Less
      else
        LgthA1A2 := Greater;
    Search := min(A1^.Length, A2^.Length);
    W1 := 1;
    while (W1 < Search) and (A1^.lsData[W1] = A2^.lsData[W1]) do
      inc(W1);
    if A1^.lsData[W1] = A2^.lsData[W1] then begin
      lsComp := LgthA1A2;
      exit;
      end;
    if A1^.lsData[W1] < A2^.lsData[W1] then begin
      lsComp := Less;
      exit;
      end;
    if A1^.lsData[W1] > A2^.lsData[W1] then begin
      lsComp := Greater;
      end;
    end; {lsComp}

function lsPosStr(Obj : string; A : LongString) : word;
  {-Return the position of the string Obj in A, returning NotFound if
   not found}
  begin
    lsPosStr := succ(Search(A^.lsData, A^.Length, Obj[1], byte(Obj[0])));
    end; {lsPosStr}

function lsPos(Obj, A : LongString) : word;
  {-Return the position of Obj in A, returning NotFound if not found}
  begin
    lsPos := succ(Search(A^.lsData, A^.Length, Obj^.lsData, Obj^.Length));
    end; {lsPos}

function lsPosStrUC(Obj : string; A : LongString) : word;
  {-Return the position of the string Obj in A, returning NotFound if
   not found. The search is not case sensitive.}
  begin
    lsPosStrUC := succ(SearchUC(A^.lsData, A^.Length, Obj[1], byte(Obj[0])));
    end; {lsPosStrUC}

function lsPosUC(Obj, A : LongString) : word;
  {-Return the position of Obj in A, returning NotFound if not found.
   The search is not case sensitive.}
  begin
    lsPosUC := succ(SearchUC(A^.lsData, A^.Length, Obj^.lsData, Obj^.Length));
    end; {lsPosUC}

function CountPrim(A, Obj : LongString;
                   CaseSens  {true if case sensitive} : boolean)  : word;
  var
    Next,
    Now,
    Count : word;
  begin
    Next := 1;
    Now := 1;
    Count := 0;
    repeat
      if CaseSens then
        Now := succ(Search(A^.lsData[Next], A^.Length-Next+1,
                           Obj^.lsData, Obj^.Length))
      else
        Now := succ(SearchUC(A^.lsData[Next], A^.Length-Next+1,
                           Obj^.lsData, Obj^.Length));
      if Now <> 0 then begin
        Next := Next + Now + Obj^.Length - 1;
        inc(Count);
        end;
      until Now = 0;
    CountPrim := Count;
    end; {CountPrim}

  {-Returns the number of occurrences of Obj in A}
function lsCount(A, Obj : LongString):  word;
  begin
    lsCount := CountPrim(A, Obj, true);
    end; {lsCount}
function lsCountStr(A : LongString; Obj : string) : word;
  var
    LS  : LongString;
  begin
    if not lsInit(LS, byte(Obj[0])) then exit;
    lsStr2LongString(Obj, LS);
    lsCountStr := lsCount(A, LS);
    lsDispose(LS);
    end; {lsCountStr}

  {-Returns the number of occurrences of Obj in A}
  { The search is not CASE SENSITIVE.}
function lsCountUC(A, Obj : LongString):  word;
  begin
    lsCountUC := CountPrim(A, Obj, false);
    end; {lsCountUC}
function lsCountStrUC(A : LongString; Obj : string) : word;
  var
    LS  : LongString;
  begin
    if not lsInit(LS, byte(Obj[0])) then exit;
    lsStr2LongString(Obj, LS);
    lsCountStrUC := lsCountUC(A, LS);
    lsDispose(LS);
    end; {lsCountStrUC}

procedure RepDelPrim(In0, Obj, Obj1, Out : LongString;
                     RepOrDel, {true if to replace}
                     CaseSens  {true if case sensitive} : boolean);
  var
    In1,
    Scr   : LongString;
    W1    : word;
  function GetPos : word;
    begin
      if CaseSens then
        GetPos := lsPos(Obj, In1)
      else
        GetPos := lsPosUC(Obj, In1);
      end; {GetPos}
  begin
    if not lsInit(In1, In0^.Length) then exit;
    lsTransfer(In0, In1);
    W1 := GetPos;
    if W1 = NotFound then begin
      lsTransfer(In1, Out);
      lsDispose(In1);
      exit;
      end;
    if not lsInit(Scr, In1^.Length) then exit;
    Out^.Length := 0;
    while W1 <> NotFound do begin
      lsCopy(In1, 1, W1-1, Scr);
      lsConcat(Out, Scr, Out);
      if RepOrDel then
        lsConcat(Out, Obj1, Out);
      lsDelete(In1, 1, W1 + Obj^.Length - 1, In1);
      W1 := GetPos;
      end; {while}
    lsConcat(Out, In1, Out);
    lsDispose(In1);
    lsDispose(Scr);
    end; {RepDelPrim}

  {-Deletes all occurrences of Obj in A}
procedure lsDelAll(A, Obj, B : LongString);
  begin
    RepDelPrim(A, Obj, nil, B, false, true);
    end; {lsDelAll}
function lsDelAllF(A, Obj : LongString):  LongString;
  var
    LS  : LongString;
  begin
    LS := NextInRing(A^.Length - (lsCount(A, Obj) * Obj^.Length));
    lsDelAll(A, Obj, LS);
    lsDelAllF := LS;
    end; {lsDelAllF}
procedure lsDelAllStr(A : LongString; Obj : string; B : LongString);
  var
    LS  : LongString;
  begin
    if not lsInit(LS, A^.Length - (lsCountStr(A, Obj) * byte(Obj[0]))) then
      exit;
    lsStr2LongString(Obj, LS);
    lsDelAll(A, LS, B);
    lsDispose(LS);
    end; {lsDelAllStr}
function lsDelAllStrF(A : LongString; Obj : string) : LongString;
  var
    LS  : LongString;
  begin
    if not lsInit(LS, A^.Length - (lsCountStr(A, Obj) * byte(Obj[0]))) then
      exit;
    lsStr2LongString(Obj, LS);
    lsDelAllStrF := lsDelAllF(A, LS);
    lsDispose(LS);
    end; {lsDelAllStrF}

  {-Deletes all occurrences of Obj in A}
  { The search is not CASE SENSITIVE.}
procedure lsDelAllUC(A, Obj, B : LongString);
  begin
    RepDelPrim(A, Obj, nil, B, false, false);
    end; {lsDelAllUC}
function lsDelAllUCF(A, Obj : LongString):  LongString;
  var
    LS  : LongString;
  begin
    LS := NextInRing(A^.Length - (lsCount(A, Obj) * Obj^.Length));
    lsDelAllUC(A, Obj, LS);
    lsDelAllUCF := LS;
    end; {lsDelAllUCF}
procedure lsDelAllStrUC(A : LongString; Obj : string; B : LongString);
  var
    LS  : LongString;
  begin
    if not lsInit(LS, A^.Length - (lsCountStrUC(A, Obj) * byte(Obj[0]))) then
      exit;
    lsStr2LongString(Obj, LS);
    lsDelAllUC(A, LS, B);
    lsDispose(LS);
    end; {lsDelAllStrUC}
function lsDelAllStrUCF(A : LongString; Obj : string) : LongString;
  var
    LS  : LongString;
  begin
    if not lsInit(LS, A^.Length - (lsCountStr(A, Obj) * byte(Obj[0]))) then
      exit;
    lsStr2LongString(Obj, LS);
    lsDelAllStrUCF := lsDelAllUCF(A, LS);
    lsDispose(LS);
    end; {lsDelAllStrUCF}

  {-Replaces all occurrences of Obj in A with Obj1}
procedure lsRepAll(A, Obj, Obj1, B : LongString);
  begin
    RepDelPrim(A, Obj, Obj1, B, true, true);
    end; {lsRepAll}
function lsRepAllF(A, Obj, Obj1 : LongString):  LongString;
  var
    LS    : LongString;
  begin
    LS := NextInRing(A^.Length +
                    (lsCount(A, Obj) * (Obj1^.Length - Obj^.Length)));
    lsRepAll(A, Obj, Obj1, LS);
    lsRepAllF := LS;
    end; {lsRepAllF}
procedure lsRepAllStr(A : LongString; Obj, Obj1 : string; B : LongString);
  var
    LS0,
    LS1  : LongString;
  begin
    if not lsInit(LS0, byte(Obj[0])) then exit;
    lsStr2LongString(Obj, LS0);
    if not lsInit(LS1, byte(Obj1[0])) then exit;
    lsStr2LongString(Obj1, LS1);
    lsRepAll(A, LS0, LS1, B);
    lsDispose(LS0);
    lsDispose(LS1);
    end; {lsRepAllStr}
function lsRepAllStrF(A : LongString; Obj, Obj1 : string) : LongString;
  var
    LS0,
    LS1   : LongString;
  begin
    if not lsInit(LS0, byte(Obj[0])) then exit;
    lsStr2LongString(Obj, LS0);
    if not lsInit(LS1, byte(Obj1[0])) then exit;
    lsStr2LongString(Obj1, LS1);
    lsRepAllStrF := lsRepAllF(A, LS0, LS1);
    lsDispose(LS0);
    lsDispose(LS1);
    end; {lsRepAllStrF}

  {-Replaces all occurrences of Obj in A with Obj1}
  { The search is not CASE SENSITIVE.}
procedure lsRepAllUC(A, Obj, Obj1, B : LongString);
  begin
    RepDelPrim(A, Obj, Obj1, B, true, false);
    end; {lsRepAllUC}
function lsRepAllUCF(A, Obj, Obj1 : LongString):  LongString;
  var
    LS    : LongString;
  begin
    LS := NextInRing(A^.Length +
                    (lsCountUC(A, Obj) * (Obj1^.Length - Obj^.Length)));
    lsRepAllUC(A, Obj, Obj1, LS);
    lsRepAllUCF := LS;
    end; {lsRepAllUCF}
procedure lsRepAllStrUC(A : LongString; Obj, Obj1 : string; B : LongString);
  var
    LS0,
    LS1  : LongString;
  begin
    if not lsInit(LS0, byte(Obj[0])) then exit;
    lsStr2LongString(Obj, LS0);
    if not lsInit(LS1, byte(Obj1[0])) then exit;
    lsStr2LongString(Obj1, LS1);
    lsRepAllUC(A, LS0, LS1, B);
    lsDispose(LS0);
    lsDispose(LS1);
    end; {lsRepAllStrUC}
function lsRepAllStrUCF(A : LongString; Obj, Obj1 : string) : LongString;
  var
    LS0,
    LS1   : LongString;
  begin
    if not lsInit(LS0, byte(Obj[0])) then exit;
    lsStr2LongString(Obj, LS0);
    if not lsInit(LS1, byte(Obj1[0])) then exit;
    lsStr2LongString(Obj1, LS1);
    lsRepAllStrUCF := lsRepAllUCF(A, LS0, LS1);
    lsDispose(LS0);
    lsDispose(LS1);
    end; {lsRepAllStrUCF}

procedure lsGetNextPrim(LS1, LS2  : LongString; Delims  : lsDelimSetType);
  var
    W1  : word;
  begin
    if lsLength(LS1) = 0 then begin
      LS2^.Length := 0;
      exit;
      end;
    W1 := 1;
    while (LS1^.lsData[W1] in Delims) and (W1 <= lsLength(LS1)) do
      inc(W1);
    dec(W1);
    lsDelete(LS1, 1, W1, LS1);
    if lsLength(LS1) = 0 then
      LS2^.Length := 0
    else begin
      W1 := 1;
      while (not (LS1^.lsData[W1] in Delims)) and (W1 <= lsLength(LS1)) do
        inc(W1);
      dec(W1);
      if W1 <> 0 then begin
        lsCopy(LS1, 1, W1, LS2);
        lsDelete(LS1, 1, W1, LS1);
        end
      else begin
        lsTransfer(LS1, LS2);
        LS1^.Length := 0;
        end;
      end;
    end; {lsGetNextPrim}

procedure lsGetNext(LS1, LS2  : LongString);
  begin
    lsGetNextPrim(LS1, LS2, lsDelimSet);
    end;

function lsGetNextF(LS1 : LongString) : LongString;
  var
    Scr,
    ThisLs  : LongString;
  begin
    if not lsInit(Scr, LS1^.Length) then exit;
    lsGetNextPrim(LS1, Scr, lsDelimSet);
    ThisLs := NextInRing(Scr^.Length);
    lsTransfer(Scr, ThisLs);
    lsDispose(Scr);
    lsGetNextF := ThisLs;
    end; {lsGetNextF}

procedure lsGetNextStr(LS1  : LongString; var S2  : string);
  var
    LS2     : LongString;
  begin
    if not lsInit(LS2, LS1^.Length) then exit;
    lsGetNextPrim(LS1, LS2, lsDelimSet);
    S2 := lsLongString2Str(LS2);
    lsDispose(LS2);
    end; {lsGetNextStr}

function lsGetNextStrF(LS1  : LongString) : string;
  var
    LS2     : LongString;
  begin
    if not lsInit(LS2, LS1^.Length) then exit;
    lsGetNextPrim(LS1, LS2, lsDelimSet);
    lsGetNextStrF := lsLongString2Str(LS2);
    lsDispose(LS2);
    end; {lsGetNextStrF}

procedure lsCharStr(Ch : Char; Len : word; A : LongString);
  {-Return a LongString of length Len filled with Ch}
  begin
    A^.Length := min(Len, A^.dLength);
    FillChar(A^.lsData, A^.Length, Ch);
    end; {lsCharStr}

function lsCharStrF(Ch : Char; Len : word) : LongString;
  {-Return a LongString of length Len filled with Ch}
  var
    ThisLs  : LongString;
  begin
    ThisLs := NextInRing(Len);
    lsCharStr(Ch, Len, ThisLs);
    lsCharStrF := ThisLs;
    end; {lsCharStrF}

procedure lsPadCh(A : LongString; Ch : Char; Len : word; B : LongString);
  {-Right-pad the LongString in A to length Len with Ch, returning B}
  var
    CpyFromA,
    LenOfCh   : word;
  begin
    Len := min(B^.dLength, Len);
    CpyFromA := min(A^.Length, Len);
    if Len > CpyFromA then
      LenOfCh := Len - CpyFromA
    else
      LenOfCh := 0;
    B^.Length := Len;
    move(A^.lsData, B^.lsData, CpyFromA);
    FillChar(B^.lsData[CpyFromA+1], LenOfCh, Ch);
    end; {lsPadCh}

function lsPadChF(A : LongString; Ch : Char; Len : word)  : LongString;
  {-Right-pad the LongString in A to length Len with Ch, returning B}
  var
    ThisLs  : LongString;
  begin
    ThisLs := NextInRing(Len);
    lsPadCh(A, Ch, Len, ThisLs);
    lsPadChF := ThisLs;
    end; {lsPadChF}

procedure lsPad(A : LongString; Len : word; B : LongString);
  {-Right-pad the LongString in A to length Len with blanks, returning B}
  begin
    lsPadCh(A, Blank, Len, B);
    end; {lsPad}

function lsPadF(A : LongString; Len : word) : LongString;
  {-Right-pad the LongString in A to length Len with blanks, returning B}
  begin
    lsPadF := lsPadChF(A, Blank, Len);
    end; {lsPad}

procedure lsLeftPadCh(A : LongString; Ch : Char; Len : word; B : LongString);
  {-Left-pad the LongString in A to length Len with Ch, returning B}
  var
    CpyFromA,
    LenOfCh   : word;
    ThisLs    : LongString;
  begin
    Len := min(B^.dLength, Len);
    ThisLs := NextInRing(Len);
    CpyFromA := min(A^.Length, Len);
    if Len > CpyFromA then
      LenOfCh := Len - CpyFromA
    else
      LenOfCh := 0;
    ThisLs^.Length := Len;
    move(A^.lsData, ThisLs^.lsData[LenOfCh+1], CpyFromA);
    FillChar(ThisLs^.lsData, LenOfCh, Ch);
    lsTransfer(ThisLs, B);
    end; {lsLeftPadCh}

function lsLeftPadChF(A : LongString; Ch : Char; Len : word)  : LongString;
  {-Left-pad the LongString in A to length Len with Ch, returning B}
  var
    ThisLs  : LongString;
  begin
    ThisLs := NextInRing(Len);
    lsLeftPadCh(A, Ch, Len, ThisLs);
    lsLeftPadChF := ThisLs;
    end; {lsLeftPadChF}

procedure lsLeftPad(A : LongString; Len : word; B : LongString);
  {-Left-pad the LongString in A to length Len with blanks, returning B}
  begin
    lsLeftPadCh(A, Blank, Len, B);
    end; {lsLeftPad}

function lsLeftPadF(A : LongString; Len : word) : LongString;
  {-Left-pad the LongString in A to length Len with blanks, returning B}
  begin
    lsLeftPadF := lsLeftPadChF(A, Blank, Len);
    end; {lsLeftPad}

procedure lsTrimLeadSet(A : LongString; CS : CharSet; B : LongString);
  {-Returns a LongString with leading characters in CS stripped.}
  var
    W1    : word;
  begin
    lsTransfer(A, B);
    W1 := 1;
    while (W1 <= B^.Length) and (B^.lsData[W1] in CS) do
      inc(W1);
    if W1 <= B^.Length then begin
      move(B^.lsData[W1], B^.lsData[1], B^.Length - W1 + 1);
      B^.Length := B^.Length - W1 + 1;
      end;
    end; {lsTrimLeadSet}

function lsTrimLeadSetF(A : LongString; CS : CharSet) : LongString;
  {-Returns a LongString with leading characters in CS stripped.}
  var
    ThisLS  : LongString;
  begin {lsTrimLeadSetF}
    ThisLs := NextInRing(A^.Length);
    lsTrimLeadSet(A, CS, ThisLs);
    lsTrimLeadSetF := ThisLs;
    end; {lsTrimLeadSetF}

procedure lsTrimTrailSet(A : LongString; CS : CharSet; B : LongString);
  {-Returns a LongString with trailing characters in CS stripped.}
  var
    W1    : word;
  begin
    lsTransfer(A, B);
    W1 := B^.Length;
    while (W1 >= 1) and (B^.lsData[W1] in CS) do begin
      dec(W1);
      dec(B^.Length);
      end;
    end; {lsTrimTrailSet}

function lsTrimTrailSetF(A : LongString; CS : CharSet) : LongString;
  {-Returns a LongString with trailing characters in CS stripped.}
  var
    ThisLs  : LongString;
  begin {lsTrimTrailSetF}
    ThisLs := NextInRing(A^.Length);
    lsTrimTrailSet(A, CS, ThisLs);
    lsTrimTrailSetF := ThisLs;
    end; {lsTrimTrailSetF}

procedure lsTrimSet(A : LongString; CS : CharSet; B : LongString);
  {-Returns a LongString with characters in CS stripped.}
  var
    ThisLs  : LongString;
  begin
    if not lsInit(ThisLs, A^.Length) then exit;
    lsTransfer(A, ThisLs);
    lsTrimLeadSet(lsTrimTrailSetF(ThisLs, CS), CS, B);
    lsDispose(ThisLs);
    end; {lsTrimSet}

function lsTrimSetF(A  : LongString; CS : CharSet) : LongString;
  {-Returns a LongString with characters in CS stripped.}
  var
    ThisLs  : LongString;
  begin
    ThisLs := NextInRing(A^.Length);
    lsTrimSet(A, CS, ThisLs);
    lsTrimSetF := ThisLs;
    end; {lsTrimSetF}

procedure lsTrimLead(A, B : LongString);
  {-Return a LongString with leading white space removed}
  var
    W1    : word;
  begin
    lsTransfer(A, B);
    W1 := 1;
    while (W1 <= B^.Length) and (B^.lsData[W1] <= Blank) do
      inc(W1);
    if W1 <= B^.Length then begin
      move(B^.lsData[W1], B^.lsData[1], B^.Length - W1 + 1);
      B^.Length := B^.Length - W1 + 1;
      end;
    end; {lsTrimLead}

function lsTrimLeadF(A  : LongString): LongString;
  {-Return a LongString with leading white space removed}
  var
    ThisLs  : LongString;
  begin
    ThisLs := NextInRing(A^.Length);
    lsTrimLead(A, ThisLs);
    lsTrimLeadF := ThisLs;
    end; {lsTrimLeadF}

procedure lsTrimTrail(A, B : LongString);
  {-Return a LongString with trailing white space removed}
  var
    W1    : word;
  begin
    lsTransfer(A, B);
    W1 := B^.Length;
    while (W1 >= 1) and (B^.lsData[W1] <= Blank) do begin
      dec(W1);
      dec(B^.Length);
      end;
    end; {lsTrimTrail}

function lsTrimTrailF(A : LongString) : LongString;
  {-Return a LongString with trailing white space removed}
  var
    ThisLs  : LongString;
  begin
    ThisLs := NextInRing(A^.Length);
    lsTrimTrail(A, ThisLs);
    lsTrimTrailF := ThisLs;
    end; {lsTrimTrailF}

procedure lsTrim(A, B : LongString);
  {-Return a LongString with leading and trailing white space removed}
  var
    ThisLs  : LongString;
  begin
    if not lsInit(ThisLs, A^.Length) then exit;
    lsTransfer(A, ThisLs);
    lsTrimLead(lsTrimTrailF(ThisLs), B);
    lsDispose(ThisLs);
    end; {lsTrim}

function lsTrimF(A  : LongString) : LongString;
  {-Return a LongString with leading and trailing white space removed}
  var
    ThisLs  : LongString;
  begin
    ThisLs := NextInRing(A^.Length);
    lsTrim(A, ThisLs);
    lsTrimF := ThisLs;
    end; {lsTrimF}

procedure lsCenterCh(A : LongString; Ch : Char; Width : word; B : LongString);
  {-Return a LongString centered in a LongString of Ch with specified Width}
  var
    W1      : word;
  begin
    lsTransfer(A, B);
    if Width > B^.dLength then exit;
    if Width < B^.Length then begin
      B^.Length := Width;
      exit;
      end;
    W1 := Width - ((Width - B^.Length) shr 1);
    lsLeftPadCh(B, Ch, W1, B);
    lsPadCh(B, Ch, Width, B);
    end; {lsCenterCh}

function lsCenterChF(A : LongString; Ch : Char; Width : word) : LongString;
  {-Return a LongString centered in a LongString of Ch with specified width}
  var
    ThisLs  : LongString;
  begin
    ThisLs := NextInRing(Width);
    lsCenterCh(A, Ch, Width, ThisLs);
    lsCenterChF := ThisLs;
    end; {lsCenterChF}

procedure lsCenter(A : LongString; Width : word; B : LongString);
  {-Return a LongString centered in a LongString of blanks with specified width}
  begin
    lsCenterCh(A, Blank, Width, B);
    end; {lsCenter}

function lsCenterF(A : LongString; Width : word)  : LongString;
  {-Return a LongString centered in a LongString of blanks with specified width}
  var
    ThisLs  : LongString;
  begin
    ThisLs := NextInRing(Width);
    lsCenterCh(A, Blank, Width, ThisLs);
    lsCenterF := ThisLs;
    end; {lsCenterF}

procedure lsIon;
  {-Has the same effect with respect to lsReadLn, lsWriteLn as the $I+
    compiler has with respect to normal I/O operations, except that
    the reported error address is meaningless.}
  begin
    lsIoCheck := true;
    end; {lsIon}

procedure lsIoff;
  {-Has the same effect with respect to lsReadLn, lsWriteLn as the $I-
    compiler has with respect to normal I/O operations, except that
    the reported error address is meaningless.}
  begin
    lsIoCheck := false;
    end; {lsIoff}

procedure SetIoRes;
  begin
    lsIoRes := IoResult;
    if lsIoCheck and (lsIoRes <> 0) then
      RunError(lsIoRes);
    end; {SetIoRes}

procedure CheckIoRes;
  begin
    if (lsIoRes <> 0) then
      RunError(lsIoRes);
    end;

function lsIoResult : word;
  {-Returns the value of IoResult resulting from the last lsReadLn or
    lsWriteLn. NOTE: You MUST use lsIoResult for checking lsReadLn,
    lsWriteLn. If you call IoResult instead, you will always get a 0
    return.}
  begin
    lsIoResult := lsIoRes;
    lsIoRes := 0;
    end;

{$I-}
procedure lsReadLn(var F  : text; A : LongString);
  {-Reads a LongString from a text file. Returns the value of IoResult as
   the function value.}
  var
    S   : string;
    W1  : word;
  begin
    CheckIoRes;
    A^.Length := 0;
    while (not eoln(F)) and (A^.dLength > A^.Length) do begin
      Read(F, S);
      SetIoRes;
      if lsIoRes <> 0 then begin
        exit;
        end;
      lsConcatStr2Ls(A, S, A);
      end; {while}
    ReadLn(F);
    SetIoRes;
    end; {lsReadLn}

procedure lsWriteLn(var F  : text; A : LongString);
  {-Writes a LongString to a text file. Returns the value of IoResult as
   the function value.}
  var
    S       : string;
    W1,
    W2,
    Q,
    R       : word;
    ThisLs  : LongString;
  begin
    CheckIoRes;
    if not lsInit(ThisLs, A^.Length) then exit;
    lsTransfer(A, ThisLs);
    Q := A^.Length div $FF;
    R := A^.Length mod $FF;
    for W1 := 1 to Q do begin
      Write(F, lsLongString2Str(ThisLs));
      SetIoRes;
      Flush(F);
      SetIoRes;
      if lsIoRes <> 0 then begin
        lsDispose(ThisLs);
        exit;
        end;
      lsDelete(ThisLs, 1, $FF, ThisLs);
      end; {for W1}
    WriteLn(F, lsLongString2Str(ThisLs));
    SetIoRes;
    Flush(F);
    SetIoRes;
    lsDispose(ThisLs);
    end; {lsWriteLn}
{$I+}

begin {Initialization}
  if RingSize > MaxRingSize then begin
    WriteLn('RingSize (',RingSize,') > MaxRingSize (',MaxRingSize,')');
    WriteLn('Resetting to ',MaxRingSize);
    RingSize := MaxRingSize;
    end;
  for RingPtr := 0 to RingSizeM1 do
    Ring[RingPtr] := nil;
  RingPtr := -1;
  end.