Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TVTOOL.ZIP/TVSTRING.PAS

Pascal/Delphi Source File | 1992-08-30 | 26.7 KB | 825 lines

{*
*   TvString.pas
*
*   Copyright 1992 by Richard W. Hansen
*
*}

UNIT TvString;
{$V-}


INTERFACE


USES
  TvConst,
  TvType;


CONST
  HexDigits       : Array[0..$F] of Char = '0123456789ABCDEF';



Procedure Pad(var S   : String;
                  Len : Byte);
  {- pad S to Len characters with spaces  }

Procedure LeftPad(var S   : String;
                      Len : Byte);
  {- left pad S to Len characters with spaces  }

Procedure PadCh(var S   : String;
                    Len : Byte;
                    Ch  : Char);
  {- pad S to Len characters with Ch  }

Procedure LeftPadCh(var S   : String;
                        Len : Byte;
                        Ch  : Char);
  {- left pad S to Len characters with Ch }

Procedure Trim(var S : String);
  {- trim leading and trailing spaces from S }

Procedure TrimCh(var S  : String;
                     Ch : Char);
  {- trim leading and trailing Ch chars from S }

Procedure CopyInto(    InStr  : String;
                       Column : Byte;
                   var OutStr : String);
  {- copy InStr into OutStr beginning at Col }

Procedure Strip(var S     : String;
                    Chars : TCharSet);
  {- remove the characters in Chars from S }

Function Blanks(Len : Byte): String;
  {- return a string of Len spaces in S }

Procedure StrTruncate(var S   : String;
                          Len : Byte);
  {- Truncate S to the given length }

Function Chars(Len : Byte;
               Ch  : Char): String;
  {- return a string of Ch characters of Length Len in S }

Function AllBlanks(var S : String): Boolean;
  {- test for an empty string (null or all spaces) }

Function HexString(I : LongInt): String;
  {- return I as a Hexadecimal string }

{$IFOPT N+}
Function FormatF(Mask : String;
                 Flt  : Double;
                 DP   : Integer): String;
{$ELSE}
Function FormatF(Mask : String;
                 Flt  : Real;
                 DP   : Integer): String;
{$ENDIF}

Function FormatI(Mask : String;
                 Long : LongInt): String;

{============================================================================}
IMPLEMENTATION


{+--------------------------------------------------------------------------+}
{| Name       : Pad                                                         |}
{| Purpose    : Return a string right-padded to length Len with blanks.     |}
{| Parameters : S - string to pad                                           |}
{|              Len - length to pad to                                      |}
{| Returns    : Padded string in S.                                         |}
{+--------------------------------------------------------------------------+}
Procedure Pad(var S   : String;
                  Len : Byte);

  var
    SLen : Byte Absolute S;

  begin
    if (SLen < Len) then
    begin
      FillChar(S[SLen + 1], Len - SLen, ' ');
      SLen := Len;
    end;
  end;

{+--------------------------------------------------------------------------+}
{| Name       : LeftPad                                                     |}
{| Purpose    : Return a string left-padded to length Len with blanks.      |}
{| Parameters : S - string to pad                                           |}
{|              Len - length to pad to                                      |}
{| Returns    : Padded string in S.                                         |}
{+--------------------------------------------------------------------------+}
Procedure LeftPad(var S   : String;
                      Len : Byte);

  var
    SLen : Byte Absolute S;
    X    : Byte;

  begin
    if (SLen < Len) then
    begin
      X := Len - SLen;
      Move(S[1], S[X + 1], SLen);
      FillChar(S[1], X, ' ');
      SLen := Len;
    end;
  end;

{+--------------------------------------------------------------------------+}
{| Name       : PadCh                                                       |}
{| Purpose    : Return a string right-padded to length Len with Ch.         |}
{| Parameters : S - string to pad                                           |}
{|              Len - length to pad to                                      |}
{|              Ch - the character to pad with                              |}
{| Returns    : Padded string in S.                                         |}
{+--------------------------------------------------------------------------+}
Procedure PadCh(var S   : String;
                    Len : Byte;
                    Ch  : Char);

  var
    SLen : Byte Absolute S;

  begin
    if (SLen < Len) then
    begin
      FillChar(S[SLen + 1], Len - SLen, Ch);
      SLen := Len;
    end;
  end;

{+--------------------------------------------------------------------------+}
{| Name       : LeftPadCh                                                   |}
{| Purpose    : Return a string left-padded to length Len with Ch.          |}
{| Parameters : S - string to pad                                           |}
{|              Len - length to pad to                                      |}
{|              Ch - the character to pad with                              |}
{| Returns    : Padded string in S.                                         |}
{+--------------------------------------------------------------------------+}
Procedure LeftPadCh(var S   : String;
                        Len : Byte;
                        Ch  : Char);

  var
    SLen : Byte Absolute S;
    X    : Byte;

  begin
    if (SLen < Len) then
    begin
      X := Len - SLen;
      Move(S[1], S[X + 1], SLen);
      FillChar(S[1], X, Ch);
      SLen := Len;
    end;
  end;

{+--------------------------------------------------------------------------+}
{| Name       : Trim                                                        |}
{| Purpose    : Return a string with leading and trailing blanks removed.   |}
{| Parameters : S - string to trim                                          |}
{| Returns    : Trimmed string in S.                                        |}
{+--------------------------------------------------------------------------+}
Procedure Trim(var S : String);

  var
    i    : Word;
    SLen : Byte absolute S;

  begin
    while (SLen > 0) and (S[SLen] = ' ') do
      Dec(SLen);

    i := 1;

    while (i <= SLen) and (S[I] = ' ') do
      Inc(i);

    if (i > 1) then
    begin
      SLen := SLen - i + 1;
      Move(S[i], S[1], SLen);
    end;
  end;

{+--------------------------------------------------------------------------+}
{| Name       : TrimCh                                                      |}
{| Purpose    : Return a string with leading and trailing blanks removed.   |}
{| Parameters : S - string to trim                                          |}
{|              Ch - the character to be trimmed                            |}
{| Returns    : Trimmed string in S.                                        |}
{+--------------------------------------------------------------------------+}
Procedure Trimch(var S  : String;
                     Ch : Char);

  var
    i    : Word;
    SLen : Byte absolute S;

  begin
    while (SLen > 0) and (S[SLen] = Ch) do
      Dec(SLen);

    i := 1;

    while (i <= SLen) and (S[I] = Ch) do
      Inc(i);

    if (i > 1) then
    begin
      SLen := SLen - i + 1;
      Move(S[i], S[1], SLen);
    end;
  end;

{+--------------------------------------------------------------------------+}
{| Name       : Blanks                                                      |}
{| Purpose    : Return a string of Len blanks.                              |}
{| Parameters : Len - how many spaces                                       |}
{| Returns    : A string.                                                   |}
{| Notes      : Always seem to need a blank strings, so it is worth a       |}
{|              separate routine.                                           |}
{+--------------------------------------------------------------------------+}
Function Blanks(Len : Byte): String;

  var
    S    : String;
    SLen : Byte Absolute S;

  begin
    FillChar(S[1], Len, ' ');
    SLen := Len;
    Blanks := S;
  end;

{+--------------------------------------------------------------------------+}
{| Name       : Chars                                                       |}
{| Purpose    : Return a string of Len char of Ch.                          |}
{| Parameters : Len - hw many chars                                         |}
{|              Ch - the desired character                                  |}
{| Returns    : A string                                                    |}
{+--------------------------------------------------------------------------+}
Function Chars(Len : Byte;
               Ch  : Char): String;

  var
    S    : String;
    SLen : Byte Absolute S;

  begin
    FillChar(S[1], Len, Ch);
    SLen := Len;
    Chars := S;
  end;

{+--------------------------------------------------------------------------+}
{| Name       : CopyInto                                                    |}
{| Purpose    : Copy InStr into OutStr at column Col.                       |}
{| Parameters : InStr - the string to be inserted                           |}
{|              Col   - where to insert                                     |}
{|              OutStr- the string to insert into                           |}
{| Returns    : The result in OutStr.                                       |}
{| Notes      : This routine is great for for creating formated output.
{|              This is not just another INSERT. It does not move any chars |}
{|              like insert, it just overwrites the existing string. Will
{|              not copy beyond the end of the Destination string.
{|              Basically, you just make a string of all blanks the desired
{|              length, then copy other strings into it at fixed columns.
{+--------------------------------------------------------------------------+}
Procedure CopyInto(    InStr  : String;
                       Column : Byte;
                   var OutStr : String);

  var
    OutLen : Byte Absolute OutStr;
    InLen  : Byte Absolute InStr;

  begin
    if (InLen <> 0) then
    begin
      if (Column > OutLen) then
        EXIT
      else if (Column + InLen - 1 > OutLen) then
        Move(InStr[1], OutStr[Column], OutLen - Column + 1)
      else
        Move(InStr[1], OutStr[Column], InLen);
    end;
  end;

{+--------------------------------------------------------------------------+}
{| Name       : Strip                                                       |}
{| Purpose    : Remove the characters in Chars from S.                      |}
{| Parameters : S - the input string                                        |}
{|              Chars - set of characters to be removed                     |}
{| Returns    : The result in S.                                            |}
{+--------------------------------------------------------------------------+}
Procedure Strip(var S     : String;
                    Chars : TCharSet);

  var
    SLen : Byte Absolute S;
    i,j  : Byte;

  begin
    j := 0;

    for i := 1 to SLen do
      if not (S[i] in Chars) then
      begin
        Inc(j);
        S[j] := S[i];
      end;

    Byte(S[0]) := j;
  end;

{+--------------------------------------------------------------------------+}
{| Name       : AllBlanks                                                   |}
{| Purpose    : Test for an emtpy string.                                   |}
{| Parameters : S - the string to test.                                     |}
{| Returns    : Boolean - TRUE if string empty.                             |}
{| Notes      : Tests for both spaces and a null string.                    |}
{+--------------------------------------------------------------------------+}
Function AllBlanks(var S : String): Boolean;

  var
    i   : Byte;
    Len : Byte Absolute S;

  begin
    i := Len;

    While (i > 0) and (S[i] = ' ') do
      Dec(i);

    AllBlanks := (i = 0);
  end;

{+--------------------------------------------------------------------------+}
{| Name       : StrTruncate                                                 |}
{| Purpose    : Truncate a string to the given length.                      |}
{| Parameters : S - the string to chop                                      |}
{|              Len - the desired string length                             |}
{| Returns    : The result in S.                                            |}
{| Notes      : Only shortens does not lengthen.                            |}
{+--------------------------------------------------------------------------+}
Procedure StrTruncate(var S   : String;
                          Len : Byte);

  var
    SLen : Byte Absolute S;

  begin
    if (SLen > Len) then
      SLen := Len;
  end;

{+--------------------------------------------------------------------------+}
{| Name       : HexString                                                   |}
{| Purpose    : Convert a LongInt to a hexadecimal string.                  |}
{| Parameters : I - the number to convert                                   |}
{| Returns    : A string                                                    |}
{+--------------------------------------------------------------------------+}
Function HexString(I : LongInt): String;

  var
    S : String;

  begin
    With THexLong(I) do
    begin
      S[0] := #9;
      S[1] := '$';
      S[2] := HexDigits[Hi(High) shr $4];
      S[3] := HexDigits[Hi(High) and $F];
      S[4] := HexDigits[Lo(High) shr $4];
      S[5] := HexDigits[Lo(High) and $F];
      S[6] := HexDigits[Hi(Low)  shr $4];
      S[7] := HexDigits[Hi(Low)  and $F];
      S[8] := HexDigits[Lo(Low)  shr $4];
      S[9] := HexDigits[Lo(Low)  and $F];
    end;

    { THIS WILL STRIP LEADING ZEROS
    while (S[2] = '0') and (Length(S) > 2) do
      Delete(S, 2, 1);
    }
    HexString := S;
  end;

{+--------------------------------------------------------------------------+}
{| Name       : FormatF                                                     |}
{| Purpose    : Create a formatted string from a floating point number.     |}
{| Parameters : Mask - the output formatting mask                           |}
{|              Dbl  - the number to format                                 |}
{|              DP   - Number of digits to the left of decimal place to     |}
{|                     retain in the output. If DP is negative the number of|}
{|                     the digits to the left is determined strictly for the|}
{|                     output mask.                                         |}
{| Returns    : string                                                      |}
{| Notes      : The maximum mask size is 30 characters.                     |}
{|                                                                          |}
{|              The three characters #,@,& serve as place holders in the    |}
{|              mask for the digits in the output. All other characters are |}
{|              copied from the mask to the output unchanged.               |}
{|                                                                          |}
{|              In the output any unused # is replaced by a space, any      |}
{|              unused @ is replaced by zero, and any unused & is deleted.  |}
{|              The #,@,& can be mixed as desired in the mask. Given the    |}
{|              same mask, calls to FormatF with different valuse of DP will|}
{|              return strings with the decimal point aligned.              |}
{|                                                                          |}
{|              If a number is too large to fit in the given mask, all      |}
{|              digits in the output will be set to *.                      |}
{|                                                                          |}
{|              Some examples :                                             |}
{|                                                                          |}
{|              Input                                     Output            |}
{|              ────────────────────────────────────────────────────────────|}
{|              FormatF('#####.####', 12345.6789, 4))     12345.6789        |}
{|              FormatF('#####.####', 12345.6789, 3))     12345.679         |}
{|              FormatF('#####.####', 1234.5678, 3))       1234.568         |}
{|              FormatF('#####.####', 12345.6789, -1))    12345.6789        |}
{|              FormatF('##,###.###,#', 12345.6789, 4)    12,345.678,9      |}
{|              FormatF('$ ##,###.####', 12345.6789, 4)   $ 12,345.6789     |}
{|              FormatF('$ ##,###.####', 123.4, 2)        $    123.4        |}
{|              FormatF('$ ##,###.@@@@', 12345.6, 1)      $ 12,345.6000     |}
{|              FormatF('$ &&,&&&.@@@@', 1234.56, 2)      $ 1,234.5600      |}
{|              FormatF('$ &&,&&&.@@@@', 123.4, 2)        $ 123.4000        |}
{|              FormatF('#####.####', 9999999.9999, 4)    *****.****        |}
{|                                                                          |}
{+--------------------------------------------------------------------------+}
{$IFOPT N+}
Function FormatF(Mask : String;
                 Flt  : Double;
                 DP   : Integer): String;
{$ELSE}
Function FormatF(Mask : String;
                 Flt  : Real;
                 DP   : Integer): String;
{$ENDIF}

  var
    RDigits : Byte;
    LDigits : Byte;
    DPos    : Byte;
    Width   : Byte;
    i       : Integer;
    j       : Integer;
    Left    : Boolean;
    Num     : String[30];
    Temp    : String[30];

  begin
    if (Byte(Mask[0]) > 30) then
      Byte(Mask[0]) := 30;

    Temp    := Mask;
    { count digits to left and right of decimal point }
    Left    := True;
    RDigits := 0;
    LDigits := 0;
    DPos    := 0;

    for i := 1 to Length(Mask) do
    begin
      Case Mask[i] of
        '@', '#', '&' :
          begin
            if Left then
              Inc(LDigits)
            else
              Inc(RDigits);
          end;

        '.' :
          begin
            Left := False;
            DPos := i;
          end;
      end; {CASE}
    end; {FOR}

    { adjust digits to right as needed  }
    if (DP < 0) or (DP > RDigits) then
      DP := RDigits;

    { calculate the total width, including decimal point  }
    Width := LDigits + DP;

    if (DP > 0) then
      Inc(Width);

    { convert value to string }
    Str(Flt:Width:DP, Num);

    { copy the the digits left of decimal point,
      from the decimal point and proceeding to the left
    }
    j := DPos - 1;
    i := Length(Num) - DP;

    if (DP <> 0) then
      Dec(i);

    While (i > 0) and (j > 0) do
    begin
      Case Temp[j] of
        '@', '#', '&' :
          begin
            if (Num[i] = ' ') then
            begin
              i := 0;
            end

            else
            begin
              Temp[j] := Num[i];
              Dec(i);
            end;
          end;
      end; {CASE}

      Dec(j);
    end; {WHILE}


    if (i = 0) then
    begin
      { copy the the digits right of decimal point,
        from the decimal point and proceeding to the right
      }
      j := DPos + 1;
      i := Length(Num) - DP + 1;

      While (i <= Length(Num)) and (j <= Length(Temp)) do
      begin
        Case Temp[j] of
          '@', '#', '&' :
            begin
              Temp[j] := Num[i];
              Inc(i);
            end;
        end; {CASE}

        Inc(j);
      end; {WHILE}

      { get rid of any unneeded commas and formatting chars }
      j := 0;
      Num := '';

      for i := 1 to Length(Temp) do
        Case Temp[i] of
          '#' :
            begin
              Inc(j);
              Num[j] := ' ';
            end;

          '@' :
            begin
              Inc(j);
              Num[j] := '0';
            end;

          ',' :
            begin
              if (i > 1) and (i < Length(Temp)) then
              begin
                if ((Temp[i - 1] = '#') or (Temp[i + 1] = '#')) then
                begin
                  Inc(j);
                  Num[j] := ' '
                end

                else if (Temp[i - 1] <> '&') and (Temp[i + 1] <> '&') then
                begin
                  Inc(j);
                  Num[j] := Temp[i];
                end;
              end

              else if (i < Length(Temp)) and (Temp[i + 1] <> '&') then
              begin
                Inc(j);
                Num[j] := ' '
              end

              else if (i > 1) and (Temp[i - 1] <> '&') then
              begin
                Inc(j);
                Num[j] := ' '
              end;
            end;

          '&' :
            begin
            end;

          else
          begin
            Inc(j);
            Num[j] := Temp[i];
          end;
        end; {CASE}

      Byte(Num[0]) := j;
    end

    else  { ERROR!!!! - the number was to big for the mask  }
    begin
      Num := '';

      for i := 1 to Length(Mask) do
        Case Mask[i] of
          '@', '#', '&' :
            Num[i] := '*';
          else
            Num[i] := Mask[i];
        end; {CASE}

      Byte(Num[0]) := Length(Mask);
    end;

    FormatF := Num;
  end;

{+--------------------------------------------------------------------------+}
{| Name       : FormatI                                                     |}
{| Purpose    : Create a formatted string from an integer number.           |}
{| Parameters : Mask - the output formatting mask                           |}
{|              long - the number to format                                 |}
{| Returns    : string                                                      |}
{| Notes      : The maximum mask size is 30 characters.                     |}
{|                                                                          |}
{|              The three characters #,@,& serve as place holders in the    |}
{|              mask for the digits in the output. All other characters are |}
{|              copied from the mask to the output unchanged.               |}
{|                                                                          |}
{|              In the output any unused # is replaced by a space, any      |}
{|              unused @ is replaced by zero, and any unused & is deleted.  |}
{|              The #,@,& can be mixed as desired in the mask.              |}
{|                                                                          |}
{|              If a number is too large to fit in the given mask, all      |}
{|              digits in the output will be set to *.                      |}
{|                                                                          |}
{|              Some examples :                                             |}
{|                                                                          |}
{|              Input                                     Output            |}
{|              ────────────────────────────────────────────────────────────|}
{|              FormatI('#####', 999)                      999              |}
{|              FormatI('@@@@@', 999)                     0999              |}
{|              FormatI('&&&&&', 999)                     999               |}
{|              FormatI('##,###', 9999)                    9,999            |}
{|              FormatI('&&,&&&', 9999)                   9,999             |}
{|              FormatI('##,###', 999999)                 **,***            |}
{|                                                                          |}
{+--------------------------------------------------------------------------+}
Function FormatI(Mask : String;
                 Long : LongInt): String;

  var
    Width   : Byte;
    i       : Integer;
    j       : Integer;
    Num     : String[30];
    Temp    : String[30];

  begin
    Temp  := Mask;
    { find the width of the output }
    Width := 0;

    for i := 1 to Length(Mask) do
    begin
      Case Mask[i] of
        '@', '#', '&' :
          begin
            Inc(Width)
          end;
      end; {CASE}
    end; {FOR}

    { convert }
    Str(Long:Width, Num);

    { Copy to output from right to left }
    i := Length(Num);
    j := Length(Temp);

    While (i > 0) and (j > 0) do
    begin
      Case Temp[j] of
        '@', '#', '&' :
          begin
            if (Num[i] = ' ') then
            begin
              i := 0;
            end

            else
            begin
              Temp[j] := Num[i];
              Dec(i);
            end;
          end;
      end; {CASE}

      Dec(j);
    end; {WHILE}

    if (i = 0) then
    begin
      { get rid of any unneeded commas and formatting chars }
      j := 0;
      Num := '';

      for i := 1 to Length(Temp) do
        Case Temp[i] of
          '#' :
            begin
              Inc(j);
              Num[j] := ' ';
            end;

          '@' :
            begin
              Inc(j);
              Num[j] := '0';
            end;

          ',' :
            begin
              if (i > 1) and (i < Length(Temp)) then
              begin
                if ((Temp[i - 1] = '#') or (Temp[i + 1] = '#')) then
                begin
                  Inc(j);
                  Num[j] := ' '
                end

                else if (Temp[i - 1] <> '&') and (Temp[i + 1] <> '&') then
                begin
                  Inc(j);
                  Num[j] := Temp[i];
                end;
              end

              else if (i < Length(Temp)) and (Temp[i + 1] <> '&') then
              begin
                Inc(j);
                Num[j] := ' '
              end

              else if (i > 1) and (Temp[i - 1] <> '&') then
              begin
                Inc(j);
                Num[j] := ' '
              end;
            end;

          '&' :
            begin
            end;

          else
          begin
            Inc(j);
            Num[j] := Temp[i];
          end;
        end; {CASE}

      Byte(Num[0]) := j;
    end

    else  { ERROR!!!! - the number was to big for the mask  }
    begin
      Num := '';

      for i := 1 to Length(Mask) do
        Case Mask[i] of
          '@', '#', '&' :
            Num[i] := '*';
          else
            Num[i] := Mask[i];
        end; {CASE}

      Byte(Num[0]) := Length(Mask);
    end;

    FormatI := Num;
  end;


END.