{$S-,R-,I-,V-,B-}

  {*********************************************************}
  {*                  TPSTRING.PAS 4.03                    *}
  {*        Copyright (c) TurboPower Software 1987.        *}
  {* Portions copyright (c) Sunny Hill Software 1985, 1986 *}
  {*     and used under license to TurboPower Software     *}
  {*                 All rights reserved.                  *}
  {*********************************************************}

unit TPString;
  {-Basic string manipulation routines}

interface

type
  BTable = array[0..255] of Byte; {For Boyer-Moore searching}
const
  {used by CompareLetterSets for estimating word similarity}
  LetterValues : array['A'..'Z'] of Byte =
  (3 {A}, 6 {B}, 5 {C}, 4 {D}, 3 {E}, 5 {F}, 5 {G}, 4 {H}, 3 {I},
   8 {J}, 7 {K}, 4 {L}, 5 {M}, 3 {N}, 3 {O}, 5 {P}, 7 {Q}, 4 {R},
   3 {S}, 3 {T}, 4 {U}, 6 {V}, 5 {W}, 8 {X}, 8 {Y}, 9 {Z});

  {-------- Numeric conversion -----------}

function HexB(B : Byte) : string;
  {-Return hex string for byte}

function HexW(W : Word) : string;
  {-Return hex string for word}

function HexL(L : LongInt) : string;
  {-Return hex string for longint}

function HexPtr(P : Pointer) : string;
  {-Return hex string for pointer}

function BinaryB(B : Byte) : string;
  {-Return binary string for byte}

function BinaryW(W : Word) : string;
  {-Return binary string for word}

function BinaryL(L : LongInt) : string;
  {-Return binary string for longint}

function OctalB(B : Byte) : string;
  {-Return octal string for byte}

function OctalW(W : Word) : string;
  {-Return octal string for word}

function OctalL(L : LongInt) : string;
  {-Return octal string for longint}

function Str2Int(S : string; var I : Integer) : Boolean;
  {-Convert a string to an integer, returning true if successful}

function Str2Word(S : string; var I : Word) : Boolean;
  {-Convert a string to a word, returning true if successful}

function Str2Long(S : string; var I : LongInt) : Boolean;
  {-Convert a string to an longint, returning true if successful}

function Long2Str(L : LongInt) : string;
  {-Convert a longint/word/integer/byte/shortint to a string}

function Form(Mask : string; R : Real) : string;
  {-Returns a formatted string with digits from R merged into the Mask}

  {-------- General purpose string manipulation --------}

function StUpcase(S : string) : string;
  {-Convert lower case letters in string to uppercase}

function LoCase(Ch : Char) : Char;
  {-Return lowercase of char}
  inline(
    $58/                     {pop ax}
    $3C/$5A/                 {cmp al,'Z'}
    $77/$06/                 {ja  done}
    $3C/$41/                 {cmp al,'A'}
    $72/$02/                 {jb  done}
    $04/$20);                {add al,32}
                             {done:}

function StLocase(S : string) : string;
  {-Convert upper case letters in string to lowercase}

function CharStr(Ch : Char; Len : Byte) : string;
  {-Return a string of length len filled with ch}

function PadCh(S : string; Ch : Char; Len : Byte) : string;
  {-Return a string right-padded to length len with ch}

function Pad(S : string; Len : Byte) : string;
  {-Return a string right-padded to length len with blanks}

function LeftPadCh(S : string; Ch : Char; Len : Byte) : string;
  {-Return a string left-padded to length len with ch}

function LeftPad(S : string; Len : Byte) : string;
  {-Return a string left-padded to length len with blanks}

function TrimLead(S : string) : string;
  {-Return a string with leading white space removed}

function TrimTrail(S : string) : string;
  {-Return a string with trailing white space removed}

function Trim(S : string) : string;
  {-Return a string with leading and trailing white space removed}

function CenterCh(S : string; Ch : Char; Width : Byte) : string;
  {-Return a string centered in a string of Ch with specified width}

function Center(S : string; Width : Byte) : string;
  {-Return a string centered in a blank string of specified width}

function Entab(S : string; TabSize : Byte) : string;
  {-Convert blanks in a string to tabs on spacing TabSize}

function Detab(S : string; TabSize : Byte) : string;
  {-Expand tabs in a string to blanks on spacing TabSize}

  {--------------- String comparison and searching -----------------}

type
  CompareType = (Less, Equal, Greater);

function CompString(S1, S2 : string) : CompareType;
  {-Return less, equal, greater if s1<s2, s1=s2, or s1>s2}

function CompUCString(S1, S2 : string) : CompareType;
  {-Compare two strings in a case insensitive manner}

function CompStruct(var S1, S2; Size : Word) : CompareType;
  {-Compare two fixed size structures}

function Search(var Buffer; BufLength : Word;
                var Match; MatLength : Word) : Word;
  {-Search through Buffer for Match. BufLength is length of range to search.
    MatLength is length of string to match. Returns number of bytes searched
    to find Match, $FFFF if not found.}

function SearchUC(var Buffer; BufLength : Word;
                  var Match; MatLength : Word) : Word;
  {-Search through Buffer for Match, CASE-INSENSITIVE.
    Otherwise same as Search.}

procedure BMMakeTable(MatchString : string; var BT : BTable);
  {-Build Boyer-Moore link table}

function BMSearch(var Buffer; BufLength : Word;
                  BT : BTable; MatchString : string) : Word;
  {-Search Buffer for MatchString. BufLength is length of range to search.
    Returns number of bytes searched to find MatchString, $FFFF if not found}

function BMSearchUC(var Buffer; BufLength : Word;
                    BT : BTable; MatchString : string) : Word;
  {-Search Buffer for MatchString, CASE-INSENSITIVE.
    Assumes MatchString is already in uppercase.
    Otherwise same as BMSearch}

function Soundex(S : string) : string;
  {-Return 4 character soundex of input string}

function MakeLetterSet(S : string) : LongInt;
  {-Return a bit-mapped long storing the individual letters contained in S}

function CompareLetterSets(Set1, Set2 : LongInt) : Word;
  {-Returns the sum of the values of the letters common to Set1 and Set2}

  {----- Strings dynamically allocated on the heap ------}

function StringToHeap(S : string) : Pointer;
  {-Allocate space for s and return pointer}

function StringFromHeap(P : Pointer) : string;
  {-Return string at p}

procedure DisposeString(P : Pointer);
  {-Deallocate space for string at p}

  {--------------- DOS pathname parsing -----------------}

function DefaultExtension(Name, Ext : string) : string;
  {-Return a file name with a default extension attached}

function ForceExtension(Name, Ext : string) : string;
  {-Force the specified extension onto the file name}

function JustFilename(PathName : string) : string;
  {-Return just the filename and extension of a pathname}

function JustExtension(Name : string) : string;
  {-Return just the extension of a pathname}

function JustPathname(PathName : string) : string;
  {-Return just the drive:directory portion of a pathname}

function AddBackSlash(PathName : string) : string;
  {-Add a default backslash to a directory name}

function CleanPathName(PathName : string) : string;
  {-Return a pathname cleaned up as DOS will do it}

function FullPathName(FName : string) : string;
  {-Given FName (known to exist), return a full pathname}

  {==========================================================================}

implementation

type
  Long = record
           LowWord, HighWord : Word;
         end;
const
  Digits : array[0..$F] of Char = '0123456789ABCDEF';
  DosDelimSet : set of Char = ['\', ':', #0];

  {$L TPCASE.OBJ}
  {$L TPCOMP.OBJ}
  {$L TPSEARCH.OBJ}
  {$L TPTAB.OBJ}
  {$L TPBM.OBJ}

  {-------- Numeric conversion -----------}

  function HexB(B : Byte) : string;
    {-Return hex string for byte}
  begin
    HexB[0] := #2;
    HexB[1] := Digits[B shr 4];
    HexB[2] := Digits[B and $F];
  end;

  function HexW(W : Word) : string;
    {-Return hex string for word}
  begin
    HexW[0] := #4;
    HexW[1] := Digits[hi(W) shr 4];
    HexW[2] := Digits[hi(W) and $F];
    HexW[3] := Digits[lo(W) shr 4];
    HexW[4] := Digits[lo(W) and $F];
  end;

  function HexL(L : LongInt) : string;
    {-Return hex string for LongInt}
  begin
    with Long(L) do
      HexL := HexW(HighWord)+HexW(LowWord);
  end;

  function HexPtr(P : Pointer) : string;
    {-Return hex string for pointer}
  begin
    HexPtr := HexW(Seg(P^))+':'+HexW(Ofs(P^));
  end;

  function BinaryB(B : Byte) : string;
    {-Return binary string for byte}
  var
    I, N : Word;
  begin
    N := 1;
    BinaryB[0] := #8;
    for I := 7 downto 0 do begin
      BinaryB[N] := Digits[Ord(B and (1 shl I) <> 0)]; {0 or 1}
      Inc(N);
    end;
  end;

  function BinaryW(W : Word) : string;
    {-Return binary string for word}
  var
    I, N : Word;
  begin
    N := 1;
    BinaryW[0] := #16;
    for I := 15 downto 0 do begin
      BinaryW[N] := Digits[Ord(W and (1 shl I) <> 0)]; {0 or 1}
      Inc(N);
    end;
  end;

  function BinaryL(L : LongInt) : string;
    {-Return binary string for LongInt}
  var
    I : LongInt;
    N : Byte;
  begin
    N := 1;
    BinaryL[0] := #32;
    for I := 31 downto 0 do begin
      BinaryL[N] := Digits[Ord(L and LongInt(1 shl I) <> 0)]; {0 or 1}
      Inc(N);
    end;
  end;

  function OctalB(B : Byte) : string;
    {-Return octal string for byte}
  var
    I : Word;
  begin
    OctalB[0] := #3;
    for I := 0 to 2 do begin
      OctalB[3-I] := Digits[B and 7];
      B := B shr 3;
    end;
  end;

  function OctalW(W : Word) : string;
    {-Return octal string for word}
  var
    I : Word;
  begin
    OctalW[0] := #6;
    for I := 0 to 5 do begin
      OctalW[6-I] := Digits[W and 7];
      W := W shr 3;
    end;
  end;

  function OctalL(L : LongInt) : string;
    {-Return octal string for word}
  var
    I : Word;
  begin
    OctalL[0] := #12;
    for I := 0 to 11 do begin
      OctalL[12-I] := Digits[L and 7];
      L := L shr 3;
    end;
  end;

  function Str2Int(S : string; var I : integer) : Boolean;
    {-Convert a string to an integer, returning true if successful}
  var
    code : Word;
  begin
    Val(S, I, code);
    if code <> 0 then begin
      i := code;
      Str2Int := False;
    end else
      Str2Int := True;
  end;

  function Str2Word(S : string; var I : word) : Boolean;
    {-Convert a string to a word, returning true if successful}
  var
    code : Word;
  begin
    Val(S, I, code);
    if code <> 0 then begin
      i := code;
      Str2Word := False;
    end else
      Str2Word := True;
  end;

  function Str2Long(S : string; var I : longint) : Boolean;
    {-Convert a string to a longint, returning true if successful}
  var
    code : Word;
  begin
    Val(S, I, code);
    if code <> 0 then begin
      i := code;
      Str2Long := False;
    end else
      Str2Long := True;
  end;

  function Long2Str(L : LongInt) : string;
    {-Convert a long/word/integer/byte/shortint to a string}
  var
    S : string;
  begin
    Str(L, S);
    Long2Str := S;
  end;

  function Form(Mask : string; R : Real) : string;
    {-Returns a formatted string with digits from R merged into the Mask}
  type
    FillType = (Blank, Asterisk, Zero);
  const
    FormChars : string[8] = '#@*$-+,.';
    PlusArray : array[Boolean] of Char = ('+', '-');
    MinusArray : array[Boolean] of Char = (' ', '-');
    FillArray : array[FillType] of Char = (' ', '*', '0');
  var
    S : string;              {temporary string}
    Filler : FillType;       {char for unused digit slots: ' ', '*', '0'}
    WontFit,                 {true if number won't fit in the mask}
    AddMinus,                {true if minus sign needs to be added}
    Dollar,                  {true if floating dollar sign is desired}
    Negative : Boolean;      {true if B is negative}
    StartF,                  {starting point of the numeric field}
    EndF,                    {end of numeric field}
    DotPos,                  {position of '.' in Mask}
    Digits,                  {total # of digits}
    Places,                  {# of digits after the '.'}
    Blanks,                  {# of blanks returned by Str}
    FirstDigit,              {pos. of first digit returned by Str}
    Extras,                  {# of extra digits needed for special cases}
    DigitPtr : Byte;         {pointer into temporary string of digits}
    I : Word;
  label
    EndFound,
    RedoCase,
    Done;
  begin
    {check for empty string}
    if Length(Mask) = 0 then
      goto Done;

    {initialize variables}
    Filler := Blank;
    DotPos := 0;
    Places := 0;
    Digits := 0;
    Dollar := False;
    AddMinus := True;
    StartF := 1;

    {store the sign of the real and make it positive}
    Negative := (R < 0);
    R := Abs(R);

    {find the starting point for the field}
    while (StartF <= Length(Mask)) and (Pos(Mask[StartF], FormChars) = 0) do
      Inc(StartF);
    if StartF > Length(Mask) then
      goto Done;

    {find the end point for the field}
    for EndF := StartF to Length(Mask) do
      case Mask[EndF] of
        '*' : Filler := Asterisk;
        '@' : Filler := Zero;
        '$' : Dollar := True;
        '-',
        '+' : AddMinus := False;
        '#' : {ignore} ;
        ',',
        '.' : DotPos := EndF;
      else
        goto EndFound;
      end;

    {if we get here at all, the last char was part of the field}
    Inc(EndF);

EndFound:
    {if we jumped to here instead, it wasn't}
    Dec(EndF);

    {disallow Dollar if Filler is Zero}
    if Filler = Zero then
      Dollar := False;

    {we need an extra slot if Dollar is True}
    Extras := Ord(Dollar);

    {get total # of digits and # after the decimal point}
    for I := StartF to EndF do
      case Mask[I] of
        '#', '@',
        '*', '$' :
          begin
            Inc(Digits);
            if (I > DotPos) and (DotPos <> 0) then {***}
              Inc(Places);
          end;
      end;

    {need one more 'digit' if Places > 0}
    Inc(Digits, Ord(Places > 0));

    {also need an extra blank if (1) Negative is true, and (2) Filler is Blank,
     and (3) AddMinus is true}
    if Negative and AddMinus and (Filler = Blank) then
      Inc(Extras)
    else
      AddMinus := False;

    {translate the real to a string}
    Str(R:Digits:Places, S);

    {$IFDEF Debug}
    WriteLn('"', Mask, '"');
    WriteLn('Length : ', Length(Mask), ' Start: ', StartF,
            ' End: ', EndF, ' DotPos: ', DotPos, ' Extras: ', Extras,
            ' Digits: ', Digits, ' Places: ', Places);
    WriteLn('"', S, '"');
    {$ENDIF}

    {count number of initial blanks}
    Blanks := 1;
    while S[Blanks] = ' ' do
      Inc(Blanks);
    FirstDigit := Blanks;
    Dec(Blanks);

    {the number won't fit if (a) S is longer than Digits or (b) the number of
     initial blanks is less than Extras}
    WontFit := (Length(S) > Digits) or (Blanks < Extras);

    {if it won't fit, fill decimal slots with '*'}
    if WontFit then begin
      for I := StartF to EndF do
        case Mask[I] of
          '#', '@', '*', '$' : Mask[I] := '*';
          '+' : Mask[I] := PlusArray[Negative];
          '-' : Mask[I] := MinusArray[Negative];
        end;
      goto Done;
    end;

    {fill initial blanks in S with Filler; insert floating dollar sign}
    if Blanks > 0 then begin
      FillChar(S[1], Blanks, FillArray[Filler]);

      {put floating dollar sign in last blank slot if necessary}
      if Dollar then begin
        S[Blanks] := '$';
        Dec(Extras);
        Dec(Blanks);
      end;

      {insert a minus sign if necessary}
      if AddMinus then
        S[Blanks] := '-';
    end;

    {put in the digits / signs}
    DigitPtr := Length(S);
    for I := EndF downto StartF do begin
RedoCase:
      case Mask[I] of
        '#', '@', '*', '$' :
          if DigitPtr <> 0 then begin
            Mask[I] := S[DigitPtr];
            Dec(DigitPtr);
            if (S[DigitPtr] = '.') and (DigitPtr <> 0) then
              Dec(DigitPtr);
          end
          else
            Mask[I] := FillArray[Filler];
        ',', '.' :
          if (I < DotPos) and (DigitPtr < FirstDigit) then begin
            Mask[I] := '#';
            goto RedoCase;
          end;
        '+' : Mask[I] := PlusArray[Negative];
        '-' : Mask[I] := MinusArray[Negative];
      end;
    end;

Done:
    Form := Mask;
  end;

  {-------- General purpose string manipulation --------}

  function StUpcase(S : string) : string;
    external {TPCASE} ;

  function StLocase(S : string) : string;
    external {TPCASE} ;

  function CharStr(Ch : Char; Len : Byte) : string;
    {-Return a string of length len filled with ch}
  var
    S : string;
  begin
    if Len = 0 then
      CharStr[0] := #0
    else begin
      S[0] := Chr(Len);
      FillChar(S[1], Len, Ch);
      CharStr := S;
    end;
  end;

  function PadCh(S : string; Ch : Char; Len : Byte) : string;
    {-Return a string right-padded to length len with ch}
  var
    o : string;
  begin
    if Length(S) >= Len then
      PadCh := S
    else begin
      o[0] := Chr(Len);
      Move(S[1], o[1], Length(S));
      FillChar(o[Succ(Length(S))], Len-Length(S), Ch);
      PadCh := o;
    end;
  end;

  function Pad(S : string; Len : Byte) : string;
    {-Return a string right-padded to length len with blanks}
  begin
    Pad := PadCh(S, ' ', Len);
  end;

  function LeftPadCh(S : string; Ch : Char; Len : Byte) : string;
    {-Return a string left-padded to length len with ch}
  var
    o : string;
  begin
    if Length(S) >= Len then
      LeftPadCh := S
    else begin
      o[0] := Chr(Len);
      Move(S[1], o[Succ(Len)-Length(S)], Length(S));
      FillChar(o[1], Len-Length(S), Ch);
      LeftPadCh := o;
    end;
  end;

  function LeftPad(S : string; Len : Byte) : string;
    {-Return a string left-padded to length len with blanks}
  begin
    LeftPad := LeftPadCh(S, ' ', Len);
  end;

  function TrimLead(S : string) : string;
    {-Return a string with leading white space removed}
  begin
    while (Length(S) > 0) and (S[1] <= ' ') do
      Delete(S, 1, 1);
    TrimLead := S;
  end;

  function TrimTrail(S : string) : string;
    {-Return a string with trailing white space removed}
  begin
    while (Length(S) > 0) and (S[Length(S)] <= ' ') do
      Dec(S[0]);
    TrimTrail := S;
  end;

  function Trim(S : string) : string;
    {-Return a string with leading and trailing white space removed}
  begin
    while (Length(S) > 0) and (S[Length(S)] <= ' ') do
      Dec(S[0]);

    while (Length(S) > 0) and (S[1] <= ' ') do
      Delete(S, 1, 1);

    Trim := S;
  end;

  function CenterCh(S : string; Ch : Char; Width : Byte) : string;
    {-Return a string centered in a string of Ch with specified width}
  var
    o : string;
  begin
    if Length(S) >= Width then
      CenterCh := S
    else begin
      o[0] := Chr(Width);
      FillChar(o[1], Width, Ch);
      Move(S[1], o[Succ((Width-Length(S)) shr 1)], Length(S));
      CenterCh := o;
    end;
  end;

  function Center(S : string; Width : Byte) : string;
    {-Return a string centered in a blank string of specified width}
  begin
    Center := CenterCh(S, ' ', Width);
  end;

  function Entab(S : string; TabSize : Byte) : string;
    external {TPTAB} ;

  function Detab(S : string; TabSize : Byte) : string;
    external {TPTAB} ;

  {--------------- String comparison --------------------}

  function CompString(S1, S2 : string) : CompareType;
    external {TPCOMP} ;

  function CompUCString(S1, S2 : string) : CompareType;
    external {TPCOMP} ;

  function CompStruct(var S1, S2; Size : Word) : CompareType;
    external {TPCOMP} ;

  function Search(var Buffer; BufLength : Word;
                  var Match; MatLength : Word) : Word;
    external {TPSEARCH} ;

  function SearchUC(var Buffer; BufLength : Word;
                    var Match; MatLength : Word) : Word;
    external {TPSEARCH} ;

  procedure BMMakeTable(MatchString : string; var BT : BTable);
    external {TPBM} ;

  function BMSearch(var Buffer; BufLength : Word;
                    BT : BTable; MatchString : string) : Word;
    external {TPBM} ;

  function BMSearchUC(var Buffer; BufLength : Word;
                      BT : BTable; MatchString : string) : Word;
    external {TPBM} ;

  function Soundex(S : string) : string;
    external {TPCOMP} ;

  function MakeLetterSet(S : string) : LongInt;
    external {TPCOMP} ;

  function CompareLetterSets(Set1, Set2 : LongInt) : Word;
    external {TPCOMP} ;

  {----- Strings dynamically allocated on the heap ------}

  function StringToHeap(S : string) : Pointer;
    {-Allocate space for s and return pointer}
  var
    L : Word;
    P : Pointer;
  begin
    L := Succ(Length(S));
    if MaxAvail < L then
      StringToHeap := nil
    else begin
      GetMem(P, L);
      Move(S, P^, L);
      StringToHeap := P;
    end;
  end;

  function StringFromHeap(P : Pointer) : string;
    {-Return string at p}
  var
    S : string;
  begin
    if P = nil then
      StringFromHeap := ''
    else begin
      Move(P^, S, Succ(Byte(P^)));
      StringFromHeap := S;
    end;
  end;

  procedure DisposeString(P : Pointer);
    {-Deallocate space for string at p}
  begin
    if P <> nil then
      FreeMem(P, Succ(Byte(P^)));
  end;

  {--------------- DOS pathname parsing -----------------}

  function HasExtension(Name : string; var DotPos : Word) : Boolean;
    {-Return whether and position of extension separator dot in a pathname}
  var
    I : Word;
  begin
    DotPos := 0;
    for I := Length(Name) downto 1 do
      if (Name[I] = '.') and (DotPos = 0) then
        DotPos := I;
    HasExtension := (DotPos > 0) and (Pos('\', Copy(Name, Succ(DotPos), 64)) = 0);
  end;

  function DefaultExtension(Name, Ext : string) : string;
    {-Return a pathname with the specified extension attached}
  var
    DotPos : Word;
  begin
    if HasExtension(Name, DotPos) then
      DefaultExtension := Name
    else
      DefaultExtension := Name+'.'+Ext;
  end;

  function ForceExtension(Name, Ext : string) : string;
    {-Return a pathname with the specified extension attached}
  var
    DotPos : Word;
  begin
    if HasExtension(Name, DotPos) then
      ForceExtension := Copy(Name, 1, DotPos)+Ext
    else
      ForceExtension := Name+'.'+Ext;
  end;

  function JustExtension(Name : string) : string;
    {-Return just the extension of a pathname}
  var
    DotPos : Word;
  begin
    if HasExtension(Name, DotPos) then
      JustExtension := Copy(Name, Succ(DotPos), 3)
    else
      JustExtension := '';
  end;

  function JustFilename(PathName : string) : string;
    {-Return just the filename of a pathname}
  var
    I : Word;
  begin
    I := Succ(Length(PathName));
    repeat
      Dec(I);
    until (PathName[I] in DosDelimSet) or (I = 0);
    JustFilename := Copy(PathName, Succ(I), 64);
  end;

  function JustPathname(PathName : string) : string;
    {-Return just the drive:directory portion of a pathname}
  var
    I : Word;
  begin
    I := Succ(Length(PathName));
    repeat
      Dec(I);
    until (PathName[I] in DosDelimSet) or (I = 0);

    if I = 0 then
      {Had no drive or directory name}
      JustPathname := ''
    else if I = 1 then
      {Either the root directory of default drive or invalid pathname}
      JustPathname := PathName[1]
    else if (PathName[I] = '\') then begin
      if PathName[Pred(I)] = ':' then
        {Root directory of a drive, leave trailing backslash}
        JustPathname := Copy(PathName, 1, I)
      else
        {Subdirectory, remove the trailing backslash}
        JustPathname := Copy(PathName, 1, Pred(I));
    end else
      {Either the default directory of a drive or invalid pathname}
      JustPathname := Copy(PathName, 1, I);
  end;

  function AddBackSlash(PathName : string) : string;
    {-Add a default backslash to a directory name}
  begin
    if PathName[Length(PathName)] in DosDelimSet then
      AddBackSlash := PathName
    else
      AddBackSlash := PathName+'\';
  end;

  function CleanFileName(FileName : string) : string;
    {-Return filename with at most 8 chars of name and 3 of extension}
  var
    DotPos : Word;
    namelen : Word;
  begin
    if HasExtension(FileName, DotPos) then begin
      {Take the first 8 chars of name and first 3 chars of extension}
      namelen := Pred(DotPos);
      if namelen > 8 then
        namelen := 8;
      CleanFileName := Copy(FileName, 1, namelen)+Copy(FileName, DotPos, 4);
    end else
      {Take the first 8 chars of name}
      CleanFileName := Copy(FileName, 1, 8);
  end;

  function CleanPathName(PathName : string) : string;
    {-Return a pathname cleaned up as DOS will do it}
  var
    I : Word;
    oname : string;
  begin
    oname := '';
    I := Succ(Length(PathName));

    repeat
      {Get the next directory or drive portion of pathname}
      repeat
        Dec(I);
      until (I <= 0) or (PathName[I] in DosDelimSet);

      {Clean it up and prepend it to output string}
      oname := CleanFileName(Copy(PathName, Succ(I), 64))+oname;
      if I > 0 then begin
        oname := PathName[I]+oname;
        Delete(PathName, I, 255);
      end;
    until I <= 0;

    CleanPathName := oname;
  end;

  function FullPathName(FName : string) : string;
    {-Given FName (known to exist), return a full pathname}
  var
    CurDir : string[64];
    Cpos : Byte;
  begin
    Cpos := Pos(':', FName);
    if Cpos <> 0 then begin
      {Drive letter specified}
      if FName[Succ(Cpos)] = '\' then
        {Complete path already specified}
        FullPathName := FName
      else begin
        {Drive specified, but incomplete path}
        GetDir(Pos(Upcase(FName[1]), 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'), CurDir);
        FullPathName := AddBackSlash(CurDir)+Copy(FName, Succ(Cpos), 100);
      end;
    end else begin
      {No drive specified}
      GetDir(0, CurDir);
      if FName[1] = '\' then
        {Complete path but no drive}
        FullPathName := Copy(CurDir, 1, 2)+FName
      else
        {No drive, incomplete path}
        FullPathName := AddBackSlash(CurDir)+FName;
    end;
  end;

end.
