Chip 1998 March/Chip_1998-03_cd.bin/zkuste/delphi/WhiteAnts/CMPNAMES.ZIP/STRUTILS.PAS

Pascal/Delphi Source File | 1997-02-04 | 17.1 KB | 600 lines

{
+----------------------------------------------------------------------------+
|                                      ⌐  ⌐                                  |
|                                    ⌐⌐ ⌐ ⌐ ⌐                                |
|                                 ⌐⌐⌐ ⌐   ⌐  ⌐                               |
|                                 ⌐⌐    ⌐ ⌐   ⌐                              |
|                  ⌐             ⌐⌐     ⌐  ⌐                                 |
|                 ⌐ ⌐            ⌐⌐⌐    ⌐⌐  ⌐                                |
|             ⌐⌐  ⌐  ⌐      ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐  ⌐                                    |
|            ⌐  ⌐⌐  ⌐⌐      ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐                                  |
|            ⌐ ⌐⌐⌐ ⌐⌐⌐⌐⌐⌐ ⌐⌐⌐ ⌐   ⌐⌐⌐⌐⌐⌐⌐⌐                                   |
|           ⌐ ⌐⌐ ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐ ⌐   ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐      Copyright ⌐ 1996-1997 by:  |
|           ⌐ ⌐⌐⌐⌐⌐⌐ ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐  ⌐ ⌐⌐⌐⌐⌐ ⌐⌐                                 |
|          ⌐ ⌐⌐⌐⌐⌐⌐⌐   ⌐⌐⌐⌐⌐ ⌐⌐⌐⌐    ⌐⌐ ⌐⌐ ⌐      WHITE ANTS SYSTEMHOUSE BV  |
|         ⌐  ⌐⌐⌐⌐⌐⌐⌐ ⌐⌐⌐ ⌐⌐⌐ ⌐⌐ ⌐       ⌐⌐⌐⌐      Geleen 12                  |
|         ⌐ ⌐⌐⌐⌐⌐⌐⌐    ⌐   ⌐⌐   ⌐⌐⌐       ⌐       8032 GB Zwolle             |
|           ⌐⌐⌐⌐⌐⌐     ⌐            ⌐ ⌐           Netherlands                |
|      ⌐⌐⌐  ⌐⌐⌐⌐⌐      ⌐     ⌐⌐     ⌐  ⌐                                     |
|            ⌐⌐       ⌐              ⌐  ⌐⌐⌐ ⌐     Tel. [phone]      |
|      ⌐              ⌐              ⌐            Fax. [phone]      |
|      ⌐             ⌐               ⌐⌐                                      |
|    ⌐              ⌐                  ⌐⌐         www.whiteants.com          |
|  ⌐⌐              ⌐                     ⌐ ⌐      [e-mail]      |
|                 ⌐                                                          |
+----------------------------------------------------------------------------+
  file     : StrUtils
  version  : 1.01
  comment  : Part of this file was taken form S_STRING.PAS by RAY LISCHNER
             Book: Secrets of Delphi 2.0
  author   : G. Beuze, R. Post, L. Laarhoven, R. Lischner
  compiler : Delphi 1.0, partly Delphi 2.0
+----------------------------------------------------------------------------+
| DISCLAIMER:                                                                |
| THIS SOURCE IS FREEWARE. YOU ARE ALLOWED TO USE IT IN YOUR OWN PROJECTS    |
| WITHOUT ANY RESTRICTIONS. YOU ARE NOT ALLOWED TO SELL THE SOURCE CODE.     |
| THERE IS NO WARRANTY AT ALL - YOU USE IT ON YOUR OWN RISC. WHITE ANTS DOES |
| NOT ASSUME ANY RESPONSIBILITY FOR ANY DAMAGE OR ANY LOSS OF TIME OR MONEY  |
| DUE THE USE OF ANY PART OF THIS SOURCE CODE.                               |
+----------------------------------------------------------------------------+
}
unit StrUtils;

interface

uses
  SysUtils;

{ Convert a Pascal string to a PChar. }
function StrToPChar(const Str: string): PChar;

{ Delimiters use by XXXToBinaryStr procedures }
const
  NibbleDelimiter : Char = '.';
  ByteDelimiter : Char = ' ';

{$IFNDEF WIN32}
type
  ShortString = string;
  PShortString = ^ShortString;
  AnsiChar = Char;
  PAnsiChar = ^AnsiChar;

{ Set the length of string, Str, to Length. }
procedure SetLength(var Str: string; Length: Byte);

{ Set the contents of string Str, to Length bytes, starting at From. }
procedure SetString(var Str: string; From: PChar; Length: Byte);

{ Copy and return Str, after trimming leading and trailing white space
  characters. Do not modify Str. }
function Trim(const Str: string): string;

{ Copy and return Str, after trimming leading white space
  characters. Do not modify Str. }
function TrimLeft(const Str: string): string;

{ Copy and return Str, after trimming trailing white space
  characters. Do not modify Str. }
function TrimRight(const Str: string): string;
{$ENDIF}

function DelChars(const Str: string; C: Char): string;
  { Removes any character C from S }

function DelWhiteSpace(const Str: string): string;
  { Removes any characters #0..#32 from Str }

function DelLeftChars(const Str: string; C: Char): string;
  { Removes any leading character C from S }

function DelRightChars(const Str: string; C: Char): string;
  { Removes any trailing character C from S }

function DelLeftRightChars(const Str: string; C: Char): string;
  { Removes any leading and trailing character C from S }

function CharString(C: Char; Cnt: Byte): string;
  { Returns a string of length (Cnt), filled with C }

function BlankString(Cnt: Byte): string;
  { Returns a string a Cnt blanks }

function LeadCharsCnt(const S: string; C: Char): Byte;
  { Returns number of leading chars C }

function LeadBlanksCnt(const S: string): Byte;
  { Returns number of leading blanks }

function LeadTabCnt(const S: string): Byte;
  { Returns number of leading tabs }

function AbbrStr(const Source: string; MaxLen: Byte): string;
  { Returns a string with length <= MaxLen. Abbreviating on words }

function MixedCase(const Str: string): string;
  { Returns S in lower case except the first char which is upper:
    'example' -> 'Example', 'EXAMPLE' -> 'Example' }

function IsPrefix(const SubStr, Str: string): Boolean;
  { Returns True if Str starts with SubStr ignoring case }

function StringValue(S: PString): string;
  { Returns S^ or '' if s = nil }

function ByteToBCD(a: Byte): Byte;
  { Returns BCD coded representation of a }

function BCDtoByte(a : Byte) : Byte;
  { Returns Byte value of BCD coded byte a }

function ByteToBinaryStr(B: Byte): string;
  { Returns '0001.1100' style string, with . defined by NibbleDelimiter const }

function WordToBinaryStr(W: Word): string;
  { Returns '00011100|00011100' style string,
    with | defined by ByteDelimiter const, See NibbleDelimiter }

function LongToBinaryStr(L: LongInt): string;
  { Returns '00011100|00011100|00011100|00011100' style string, see Delimiters }

function MatchStrings(const Source, Pattern: string): Boolean;
  { Returns True if Source matches Pattern '*Example?*' etc }
  {  Orignal code by Sean Stanley in C, Rewritten in Delphi by David Stidolph }

function StrToFloatDef(const Str: string; DefValue: Extended): Extended;
  { Converts S to extended, on exception returns DefValue }

function GetTemplate(const Str: string): string;
  { Returns 'template' as in TEMPLATE0001 }

function GetIndex(const Str: string): Integer;
  { Returns Index = 1 as in TEMPLATE0001 }

function GetTemplateAndIndex(const Str: string; var Template: string;
                             var Index: Integer): Boolean;
  { Returns True if a number was found to the right of Str
    for example as in 'Button123'. Returns Button in Template and 123 in Index
    Returns False if no number was found }

function GetName(const S: string): string;
  { Returns Name as iN: Name=Value , or '' if no = was found }

function GetValue(const S: string): string;
  { Returns Value as in: Name=Value , or '' if no = was found }

function GetNameAndValue(const S: string; var Name, Value: string): Boolean;
  { Returns True is S could be split in name and value as in Name=Value, else False }

implementation

{ Return whether the character C, is a white space character,
  or a nonprintable control character. }
function IsWhiteSpace(C: Char): Boolean;
begin
  Result := C in [#0..' ']
end;

{$IFDEF WIN32}
{ Delphi 2.0 knows how to convert string to PChar. }
function StrToPChar(const Str: string): PChar;
begin
  Result := PChar(Str);
end;

{$ELSE}

{ Return a PChar representation of the string, Str. Allocate a dynamic
  copy of the string. Keep a ring of 8 dynamic strings, and free the
  old strings. Thus, you can usually rely on the returned string being
  valid while it is needed. The most common need is to pass an argument
  to a Windows API function, so the need is temporary, but several
  such strings might be required. That's why the ring has 8 items in it:
  more than enough for most uses. }
type
  TRingIndex = 0..7;
var
  Ring: array[TRingIndex] of PChar;
  RingIndex: TRingIndex;

function StrToPChar(const Str: string): PChar;
begin
  { Allocate a PChar and copy the original string. }
  Result := StrAlloc(Length(Str)+1);
  StrPCopy(Result, Str);

  { Add the string to the ring. }
  StrDispose(Ring[RingIndex]);
  Ring[RingIndex] := Result;
  RingIndex := (RingIndex + 1) mod (High(TRingIndex) + 1);
end;

{ Set the length of a string. }
procedure SetLength(var Str: string; Length: Byte);
begin
  Str[0] := Chr(Length)
end;

{ Set the contents of a string. If there are fewer than Length bytes
  in the string, From, then leave the remaining bytes unchanged. }
procedure SetString(var Str: string; From: PChar; Length: Byte);
var
  FromLen: Integer;
begin
  Str[0] := Chr(Length);
  { In Delphi 2.0, a nil pointer represents an empty string. The representation
    should be hidden by the compiler, but some people use an explicit nil
    pointer to mean an empty string. This is sloppy programming, but some
    people do it anyway. }
  if From <> nil then
  begin
    { Only copy as many bytes as are in the From string. }
    FromLen := StrLen(From);
    if FromLen < Length then
      Length := FromLen;
    Move(From^, Str[1], Length);
  end;
end;

{ Trim all leading and trailing white space characters. }
function Trim(const Str: string): string;
var
  L, R: Integer;
begin
  L := 1;
  R := Length(Str);
  while (L <= R) and IsWhiteSpace(Str[L]) do
    Inc(L);
  while (L <= R) and IsWhiteSpace(Str[R]) do
    Dec(R);
  Result := Copy(Str, L, R-L+1);
end;

{ Trim leading white space characters. }
function TrimLeft(const Str: string): string;
var
  L, R: Integer;
begin
  L := 1;
  R := Length(Str);
  while (L <= R) and IsWhiteSpace(Str[L]) do
    Inc(L);
  Result := Copy(Str, L, 255);
end;

{ Trim trailing white space characters. }
function TrimRight(const Str: string): string;
var
  R: Integer;
begin
  R := Length(Str);
  while (R >= 1) and IsWhiteSpace(Str[R]) do
    Dec(R);
  Result := Copy(Str, 1, R);
end;
{$ENDIF}

function DelChars(const Str: string; C: Char): string;
var I: Integer;
begin
  Result := '';
  for I := 1 to Length(Str) do
    if Str[I] <> C then
      Result := Result + Str[I];
end;

function DelWhiteSpace(const Str: string): string;
var I: Integer;
begin
  Result := '';
  for I := 1 to Length(Str) do
    if not IsWhiteSpace(Str[I]) then
      Result := Result + Str[I];
end;

function DelLeftChars(const Str: string; C: Char): string;
var
  L, R: Integer;
begin
  L := 1;
  R := Length(Str);
  while (L <= R) and (Str[L] = C) do
    Inc(L);
  Result := Copy(Str, L, 255);
end;

function DelRightChars(const Str: string; C: Char): string;
var
  R: Integer;
begin
  R := Length(Str);
  while (R >= 1) and (Str[R] = C) do
    Dec(R);
  Result := Copy(Str, 1, R);
end;

function DelLeftRightChars(const Str: string; C: Char): string;
var
  L, R: Integer;
begin
  L := 1;
  R := Length(Str);
  while (L <= R) and (Str[L] = C) do
    Inc(L);
  while (L <= R) and (Str[R] = C) do
    Dec(R);
  Result := Copy(Str, L, R-L+1);
end;

function CharString(C: Char; Cnt: Byte): string;
var
  I: Integer;
begin
  Result := '';
  for I := 0 to Cnt-1 do Result := Result + C;
end;

function BlankString(Cnt: Byte): String;
begin
  Result := CharString(#32, Cnt);
end;

function LeadCharsCnt(const S: string; C: Char): Byte;
var I : Integer;
begin
  for I := 1 to Length(S) do
    if S[I] <> C then
    begin
      Result := I - 1;
      Exit;
    end;
  Result := Length(S);
end;

function LeadBlanksCnt(const S: string): Byte;
begin
  Result := LeadCharsCnt(S, ' ');
end;

function LeadTabCnt(const S: string): Byte;
begin
  Result := LeadCharsCnt(S, #9);
end;

function AbbrStr(const Source: string; MaxLen: Byte): string;
begin
  if Length(Source) > MaxLen then
  begin
    Result := Copy(Source, 1, MaxLen);
    if (Source[MaxLen] <> ' ') and (Source[MaxLen + 1] <> ' ') then
    if MaxLen > 1 then
    begin
      Result[MaxLen] := '.';
      Result[MaxLen - 1] := '.';
    end;
  end
  else
    Result := Source;
end;

function MixedCase(const Str: string): string;
begin
  Result := LowerCase(Str);
  if Length(Result) > 0 then Result[1] := Upcase(Result[1]);
end;

function IsPrefix(const SubStr, Str: string): Boolean;
begin
  Result := (Length(SubStr) <= Length(Str)) and
            (CompareText(SubStr, Copy(Str, 1, Length(SubStr))) = 0);
end;

function StringValue(S: PString): string;
begin
  if Assigned(S) then
    Result := S^
  else
    Result := '';
end;

function ByteToBCD(A: Byte): Byte;
var Decs, Units : Byte;
begin
  if A <= 99  then
  begin
    Decs := A div 10;
    Units := A mod 10;
    Result := (Decs shl 4) or Units;
  end
  else
    Result := A;
end;

function BCDtoByte(a : Byte) : Byte;
begin
  if (A >= $A0) or ((A and $0F) > $09) then
    Result := A
  else
    Result := ((A SHR 4) and $0F ) * 10 + (A and $0F);
end;

function ByteToBinaryStr(B: Byte): string;
var
  I : Integer;
begin
  Result := '';
  for I := 7 downto 0 do
  begin
    if I = 3 then Result := Result + NibbleDelimiter;
    if ((B SHR i) AND $1) = 0 then
      Result := Result + '0'
    else
      Result := Result + '1';
  end;
end;

function WordToBinaryStr(W: Word): string;
begin
  Result := ByteToBinaryStr(WordRec(W).Hi) + ByteDelimiter +
            ByteToBinaryStr(WordRec(W).Lo);
end;

function LongToBinaryStr(L: LongInt): string;
begin
  Result := WordToBinaryStr(LongRec(L).Hi) + ByteDelimiter +
            WordToBinaryStr(LongRec(L).Lo);
end;


{-------------------------------------------------------------------------}
{
  This function takes two strings and compares them.  The first string
  can be anything, but should not contain pattern characters (* or ?).
  The pattern string can have as many of these pattern characters as you want.
  For example: MatchStrings('David Stidolph','*St*') would return True.

  Orignal code by Sean Stanley in C
  Rewritten in Delphi by David Stidolph
}
{-------------------------------------------------------------------------}
function MatchStrings(const Source, Pattern: string): Boolean;
var
  pSource: Array [0..255] of Char;
  pPattern: Array [0..255] of Char;

  function MatchPattern(Element, Pattern: PChar): Boolean;

    function IsPatternWild(Pattern: PChar): Boolean;
    begin
      Result := StrScan(Pattern,'*') <> nil;
      if not Result then Result := StrScan(Pattern,'?') <> nil;
    end;

  begin
    if 0 = StrComp(Pattern,'*') then
      Result := True
    else if (Element^ = Chr(0)) and (Pattern^ <> Chr(0)) then
      Result := False
    else if Element^ = Chr(0) then
      Result := True
    else begin
      case Pattern^ of
      '*': if MatchPattern(Element,@Pattern[1]) then
             Result := True
           else
             Result := MatchPattern(@Element[1], Pattern);
      '?': Result := MatchPattern(@Element[1], @Pattern[1]);
      else
        if Element^ = Pattern^ then
          Result := MatchPattern(@Element[1], @Pattern[1])
        else
          Result := False;
      end;
    end;
  end;

begin
  StrPCopy(pSource, Source);
  StrPCopy(pPattern, Pattern);
  Result := MatchPattern(pSource,pPattern);
end;

function StrToFloatDef(const Str: string; DefValue: Extended): Extended;
begin
  try
    Result := StrToFloat(Str);
  except
    Result := DefValue;
  end;
end;

const
  Numbers: set of Char = ['0'..'9'];

function GetTemplate(const Str: string): string;
var Index: Integer;
begin
  GetTemplateAndIndex(Str, Result, Index);
end;

function GetIndex(const Str: string): Integer;
var Template: string;
begin
  GetTemplateAndIndex(Str, Template, Result);
end;

function GetTemplateAndIndex(const Str: string; var Template: string;
                             var Index: Integer): Boolean;
var R: Integer;
begin
  R := Length(Str);
  while (R > 0) and (Str[R] in Numbers) do Dec(R);
  Result := R < Length(Str);
  if Result then
  begin
    Template := Copy(Str, 1, R);
    Index := StrToInt(Copy(Str, R+1, 255));
  end
  else
  begin
    Index := -1;
    Template := Str;
  end;
end;

function GetName(const S: string): string;
var P: Integer;
begin
  P := Pos('=', S);
  if P > 0 then
    Result := Copy(S, 1, P - 1)
  else
    Result := '';
end;

function GetValue(const S: string): string;
var P: Integer;
begin
  P := Pos('=', S);
  if P > 0 then
    Result := Copy(S, P + 1, 255)
  else
    Result := '';
end;

function GetNameAndValue(const S: string; var Name, Value: string): Boolean;
var P: Integer;
begin
  P := Pos('=', S);
  Result := P > 0;
  if Result then
  begin
    Name := Copy(S, 1, P - 1);
    Value := Copy(S, P + 1, 255);
  end
  else
  begin
    Name := '';
    Value := '';
  end;
end;

{$IFNDEF WIN32}
{ Free all the left over strings in the StrToPChar ring. }
procedure Terminate; far;
var
  I: TRingIndex;
begin
  for I := Low(TRingIndex) to High(TRingIndex) do
  begin
    StrDispose(Ring[I]);
    Ring[I] := nil; { just in case StrToPChar is called again }
  end;
end;


initialization
  AddExitProc(Terminate);
{$ENDIF}
end.