HPAVC/HPAVC CD-ROM.iso/pc/PRUS101.ZIP/FSTR.PAS

Pascal/Delphi Source File | 1994-12-19 | 17.9 KB | 600 lines

UNIT FSTR; { FIDO unit for string handling and manipulation }
 (***************************************************************************

            RELEASE 1.06 - as contained in the file PRUS101.LZH
                by Peter Holschbach, 2:2450/660.3,  GERMANY

               --------------------------------------------
                organized for Fido's PASCAL related echoes
               --------------------------------------------

     05/14/1994 to 06/26/1994 by Orazio Czerwenka, 2:2450/540.55, GERMANY
     06/26/1994 to --/--/---- by Peter Holschbach, 2:2450/660.3,  GERMANY


           As far as third party copyrights are not violated this
           source code is hereby placed to the public domain. Use
           it whatever way you want, but use AT YOUR OWN RISK.

           In case you should modify the source rather send your
           modifications to the unit's current organizer (see above for
           NM address) than to spread it on your own. This will help to
           keep the unit updated and grant a certain standard to all
           other users as well.

           The unit is currently still under work. So it might greatly
           benefit of your participation.

           Those who contributed to the following piece of source,
           listed in alphabethical order:
        ================================================================
           Orazio Czerwenka, Peter Holschbach, Peter Schuette ...
        ================================================================
           YOUR NAME WILL APPEAR HERE IF YOU CONTRIBUTE USEFUL SOURCE.

           Credits in your own programs are as welcome as unnecessary.

 ***************************************************************************)

{$I FDEFINE.DEF}

interface

type
  FieldOfStrings = Array [0..20]  of String;

Var PartCount    : Word;

  function PosCount (findstr, strName : String): Byte;
  function RedPosCount (findstr, strName: String): Byte;
  function PosX (Xpos: byte; findstr, strName: String): Byte;
  function LastPos (findstr, strName: String): Byte;
  function CharListPos (findlst,strName: String) : Word;
  function CharListNoPos (findlst,strName: String): Word;

  function MirrorString (strName: String): String;
  function UpperString (strName: String): String;
  function LowerString (strName: String): String;

  function RemoveLeft (remo,strName: String): String;
  function RemoveRight (remo,strName: String): String;
  function RemoveLeftRight (remo,strName: String): String;
  function RemoveAll (remo,strName: String): String;

  function StripSpaceTAB (strName: String): String;
  function StripLeadingSpaceTAB (strName: String): String;

  procedure PartString (PartBy: String; Var StringField : FieldOfStrings);

  procedure PartStringBySpaceTAB (Var StringField : FieldOfStrings);
  procedure PartStringByComma (Var StringField : FieldOfStrings);

  function Resemble (a, b: String): Byte;

  function WildMatch (Pattern,Source: String) : Boolean;
  function EnsureBackslash (strName: String) : String;
  function EnsureNoBackslash (strName: String) : String;

  Function  EscToString (strName:String) : String;
  Function  StringToEsc (strName:String) : String;

implementation

Type
  CharArray255   = Array [1..255] of Char;

{----------------------------------------------------------------------------}

function CharListPos(findlst,strName: String) : Word;
{ Original author: Peter Holschbach,
  modifications Orazio Czerwenka }
Var L            : Word;
    Position     : Word;
    TempPosition : Word;
Begin
  If strName = '' then Begin
    CharListPos:= 0;
    Exit;
  End;
  Position := 256;
  For L := 1 to Length (findlst) do Begin
    TempPosition := Pos (findlst [L],strName);
    If (TempPosition > 0) and (TempPosition < Position)
      then Position := TempPosition;
  End;
  If Position = 256 then CharListPos:= 0
  Else CharListPos:= Position;
End;

{----------------------------------------------------------------------------}

function CharListNoPos (findlst,strName: String): Word;
{ Original author: Peter Holschbach,
  modifications Orazio Czerwenka }
Var L            : Word;
    Position     : Word;
    InFindLst    : Boolean;
Begin
  If strName = '' then Begin
    CharListNoPos:= 0;
    Exit;
  End;
  Position := 1;
  Repeat
    InFindLst := False;
    For L:= 1 to Length (findlst) do
      If (strName [Position] = findlst [L]) then InFindLst := True;
    Inc (Position);
  Until (Position > Length (strName)) OR Not InFindLst;
  If Not InFindLst
    then CharListNoPos:= Position - 1
    else CharListNoPos:= Length(strName)+1;
End;

{----------------------------------------------------------------------------}

function PosCount (findstr,strName:String):byte;
{ Original author: Orazio Czerwenka }
VAR
  i,
  b     :       byte;
  tmpstr:       string;
BEGIN
  b:= 0;
  tmpstr:= strName;
    FOR i:= 1 TO Length(tmpstr) DO
      IF copy(tmpstr,i,length(findstr))= findstr THEN BEGIN
        inc(b);
        delete(tmpstr,i,length(findstr)-1);
      END;
  IF b > 0
    THEN PosCount:= b
    ELSE PosCount:= 0;
END;

{----------------------------------------------------------------------------}

function RedPosCount (findstr,strName:String):byte;
{ Original author: Orazio Czerwenka }
VAR
  i,
  b     :       byte;
BEGIN
  b:= 0;
  FOR i:= 1 TO Length(strName)-(length(findstr)-1) DO
    IF copy(strname,i,length(findstr))= findstr THEN inc(b);
  IF b > 0
    THEN RedPosCount:= b
    ELSE RedPosCount:= 0;
END;

{----------------------------------------------------------------------------}

function LastPos (findstr,strName:String):Byte;
{ Original author: Orazio Czerwenka }
VAR
  b     :       Byte;
BEGIN
  b:= Pos(MirrorString(findstr),MirrorString(strName));
  IF b > 0
    THEN LastPos:= (length(strName)+1)-b-(length(findstr)-1)
    ELSE LastPos:= b;
END;

{----------------------------------------------------------------------------}

function PosX (Xpos: byte; findstr, strName: String): Byte;
{ Original author: Orazio Czerwenka }
Var
  X,
  b     :       Byte;
begin
  X:= 0;
  for b:= 1 to Xpos do begin
    X:= X + pos(findstr,strName);
    delete (strName,1,pos(findstr,strName)+ord(findstr[0])-1);
  end;
  PosX:= X;
end;

{----------------------------------------------------------------------------}

function MirrorString (strName:string):string;
{ Original author: Orazio Czerwenka }
VAR
  n            :       byte;
  NewStr       :       string;
BEGIN
  MirrorString:= strName;
  NewStr:= '';                           { Necessary to initialize variable }
  if strName = '' then exit;
  FOR n:= 0 TO length(strName)-1 DO
    NewStr:= NewStr + strName[length(strName)-n];
  MirrorString:= NewStr;
END;

{----------------------------------------------------------------------------}

function UpperString(strName:String):String;
{ Original author: Orazio Czerwenka }
VAR
  n     :       byte;
BEGIN
  FOR n:=1 TO Length(strName) DO
    CASE ord(strName[n]) OF
      129 : strName[n]:= chr(154);                { ue - Ue }
      130 : strName[n]:= chr(144);                { é - É }
      132 : strName[n]:= chr(142);                { ae - Ae }
      134 : strName[n]:= chr(143);                { å - Å }
      135 : strName[n]:= chr(128);                { ç - Ç }
      145 : strName[n]:= chr(146);                { æ - Æ }
      148 : strName[n]:= chr(153);                { oe - Oe }
      164 : strName[n]:= chr(165);                { ñ - Ñ }
    ELSE strName[n]:= UpCase(strName[n]);
    END;
  UpperString:=StrName;
END;

{----------------------------------------------------------------------------}

function LowerString(strName:String):String;
{ Original author: Orazio Czerwenka }
VAR
  n     :       byte;
BEGIN
  FOR n:=1 TO Length(strName) DO
    CASE ord(strName[n]) OF
      154 : strName[n]:= chr(129);                { Ue - ue }
      144 : strName[n]:= chr(130);                { É - é }
      142 : strName[n]:= chr(132);                { Ae - ae }
      143 : strName[n]:= chr(134);                { Å - å }
      128 : strName[n]:= chr(135);                { Ç - ç }
      146 : strName[n]:= chr(145);                { Æ - æ }
      153 : strName[n]:= chr(148);                { Oe - oe }
      165 : strName[n]:= chr(164);                { Ñ - ñ }
   65..90 : strName[n]:= chr(ord(strName[n])+32);
    END;
  LowerString:=StrName;
END;

{----------------------------------------------------------------------------}

function RemoveLeft (remo,strName: String): String;
{ Original author: Orazio Czerwenka }
var
  b    : byte;
  dummy: char;
  remov: CharArray255;
  function DummyInRemov: Boolean;
  var
    b    : byte;
  begin
    DummyInRemov:= true;
    for b:= 1 to ord(remo[0]) do if dummy = remov[b] then exit;
    DummyInRemov:= false;
  end;
begin
  RemoveLeft:= strName;
  if remo = '' then exit;
  FillChar(remov,255,#0);
  for b:= 1 to ord(remo[0]) do remov[b]:= remo[b];
  Repeat
    for b:= 1 to ord(remo[0]) do begin
      dummy:= remo[b];
      Repeat
        if strName[1] = dummy then delete(strName,1,1);
      Until (strName[1] <> dummy) or (strName = '');
    end;
    if strName <> ''
      then dummy:= strName[1]
      else dummy:= #0;
    if not DummyInRemov then remov[1]:= #0;
  Until (remov[1] = #0) or (strName = '');
  RemoveLeft:= strName;
end;

{----------------------------------------------------------------------------}

function RemoveRight (remo,strName: String): String;
{ Original author: Orazio Czerwenka }
begin
  RemoveRight:=
    Mirrorstring(RemoveLeft(remo,MirrorString(strName)));
end;

{----------------------------------------------------------------------------}

function RemoveLeftRight (remo,strName: String): String;
{ Original author: Orazio Czerwenka }
var
  dummy : string;
begin
  dummy:= RemoveLeft(remo,strName);
  RemoveLeftRight:=
    Mirrorstring(RemoveLeft(remo,MirrorString(dummy)));
end;

{----------------------------------------------------------------------------}

function RemoveAll (remo,strName: String): String;
{ Original author: Orazio Czerwenka }
var
  i,
  b: byte;
begin
  i:= 1;
  Repeat
    b:= 1;
    Repeat
      if strName[b] = remo[i] then delete(strName,b,1)
      else inc(b);
    Until b > ord(strName[0]);
    inc(i);
  Until i > ord(remo[0]);
  RemoveAll:= strName;
end;

{----------------------------------------------------------------------------}

function StripSpaceTAB (strName: String): String;
{ Original author: Peter Holschbach,
  modifications Orazio Czerwenka }
begin
  StripSpaceTAB:= RemoveAll(' '+#9,strName);
End;

{----------------------------------------------------------------------------}

function StripLeadingSpaceTAB (strName: String): String;
{ Original author: Peter Holschbach,
  modifications Orazio Czerwenka }
begin
  StripLeadingSpaceTAB:= RemoveLeft(' '+#9,strName);
end;

{----------------------------------------------------------------------------}

procedure PartString (PartBy: String; Var StringField : FieldOfStrings);
{ Original author: Peter Holschbach,
  modifications Orazio Czerwenka
  190994 modifications Peter Holschbach }
Var
  strName    : String;
  Position : Word;
  QuotationFound : Boolean;
Begin
  QuotationFound := False;
  PartCount := 0;
  strName := StringField [0];     (* the String to split *)
  FillChar(StringField,SizeOf(StringField),0);  (* fill the whole Strings with '' *)
  StringField[0]:= strName;
  If StringField [0] = '' then Exit;
  Repeat
    Position := CharListNoPos(PartBy+'"',strName);
    QuotationFound := (Position > 1) AND (strName [Position-1] = '"');
    Delete (strName,1,Position-1);  (* delete all leading chars *)
    If QuotationFound Then
      Position := CharListPos('"',strName)
    Else
      Position := CharListPos(PartBy,strName);
    If (Position = 0) then Begin
      If strName <> '' then Begin
        Inc (PartCount);
        StringField [PartCount] := strName;
        strName := '';
      End
    End
    Else Begin
      Inc (PartCount);
      StringField [PartCount] := Copy (strName,1,Position - 1);
      Delete (strName,1,Position);
    End;
  Until strName = '';
End;

{----------------------------------------------------------------------------}

procedure PartStringBySpaceTAB (Var StringField : FieldOfStrings);
{ Original author: Peter Holschbach,
  modifications Orazio Czerwenka }
Begin
  PartString (' '#9,StringField);
End;

{----------------------------------------------------------------------------}

procedure PartStringByComma (Var StringField : FieldOfStrings);
{ Original author: Peter Holschbach,
  modifications Orazio Czerwenka }
Begin
  PartString (',',StringField);
End;

{----------------------------------------------------------------------------}

  { returns TRUE if the string in Source matches the string in Pattern
    The pattern may contain any number of the wild characters '*' and '?'
    '?' matches any single character
    '*' matches any sequence of charcters (including a zero length sequence)
    EG '*m?t*i*' will match 'Automatic' }

function WildMatch(Pattern,Source: String) : boolean;
{ Original author: Peter Schuette,
  modifications Orazio Czerwenka }
  function Rmatch(VAR s: String; i: Integer;
                  VAR p: String; j: Integer) : boolean;
  { s = to be tested ,    i = position in s }
  { p = pattern to match ,j = position in p }
  var
    matched: Boolean;
    k      : Integer;
  BEGIN
    IF p[0]=CHR(0) THEN Begin RMatch := True; Exit; End;
    REPEAT
      IF ((i > Length(s)) OR (s[i] = CHR(0))) AND
         ((j > Length(p)) OR (p[j] = CHR(0))) THEN Begin
        RMatch := True; Exit; End
      ELSE IF ((j > Length(p)) OR (p[j] = CHR(0))) THEN Begin
        RMatch := False; Exit; End
      ELSE IF (p[j] = '*') THEN Begin
        k :=i;
        IF ((j = Length(p)) OR (p[j+1] = CHR(0))) THEN Begin
          RMatch := True; Exit; End
        ELSE Begin
          REPEAT
            matched := Rmatch(s,k,p,j+1);
            INC(k);
          UNTIL matched OR (k > Length(s)) OR (s[k] = CHR(0));
          RMatch := matched; Exit;
        END
      End
      ELSE IF (p[j] <> '?') AND (UpCase(p[j]) <> UpCase(s[i])) THEN Begin
        RMatch := False; Exit; End
      ELSE Begin
        INC(i);
        INC(j);
      END;
    Until 1=0;
  END;
BEGIN
  WildMatch :=  Rmatch(Source,1,Pattern,1);
END;

{----------------------------------------------------------------------------}

  { The resulting byte reports the degree the strings equal each other.
    The higher the value, the more different the strings are. (0 reports
    identical entries) }

function Resemble(a, b: String): Byte;
{ Original author: Peter Schuette,
  modifications Orazio Czerwenka }
Var i, sresult, sres1 : Byte;
    xchnge, bcopy : String;
    deleted : Boolean;
Begin {Resemble}
  sresult := 255;
  If Length(a) < Length(b) Then Begin
    xchnge := a;
    a := b;
    b := xchnge;
  End;
  If Length(a) < Length(b) Then
    For i := 1 to Length(a) Do Begin
      bcopy := b;
      Insert(#0, bcopy, i);
      sres1 := Resemble(a, bcopy);
      If sres1 < sresult Then sresult := sres1;
    End
    Else Begin
      sres1 := 0;
       i := 1;
       While i <= Length(a) Do
         If a[i] = b[i] Then Begin
           Delete(a, i, 1);
           Delete(b, i, 1);
         End
         Else inc(i);
       i := 2;
       deleted := False;
       While i <= Length(a) Do
         If a[i] = b[i-1] Then Begin
           Delete(a, i, 1);
           Delete(b, i-1, 1);
           deleted := True;
         End
         Else inc(i);
       If deleted Then inc(sres1);
       i := 2;
       deleted := False;
       While i <= Length(b) Do
         If a[i-1] = b[i] Then Begin
           Delete(a, i-1, 1);
           Delete(b, i, 1);
           deleted := True;
         End
         Else inc(i);
       If deleted Then inc(sres1);
       sres1 := sres1 + Length(a);
       if sres1 < sresult then sresult := sres1
    End;
    resemble := sresult;
End; {Resemble}

{----------------------------------------------------------------------------}

function EnsureBackslash (strName:String) : String;
{ Original author: Peter Holschbach,
  modifications Orazio Czerwenka }
begin
  if strName[ord(strName[0])] <> '\' then EnsureBackslash:= strName + '\'
  else EnsureBackslash:= strName;
end;

{----------------------------------------------------------------------------}

function EnsureNoBackslash (strName:String) : String;
{ Original author: Orazio Czerwenka }
begin
  EnsureNoBackslash:= RemoveRight(' \',strName);
end;

{----------------------------------------------------------------------------}

Function  EscToString (strName:String) : String;
{ Original author: Peter Holschbach }

Var s : String;
    L : Byte;

Begin
  s := '';
  for L := 1 to Length (StrName) do Begin
    If StrName [L] = '^' then Begin
      s := s + '^^';
    End
    Else If Ord (strName [L]) < 64 then Begin
      s := s + '^' + Chr (Ord (strName [L]) + 64);
    End
    Else Begin
      s := s + strName [L]
    End;
  End;
  EscToString := s;
End;

{----------------------------------------------------------------------------}

Function  StringToEsc (strName:String) : String;
{ Original author: Peter Holschbach }

Var s : String;
    L : Byte;

Begin
  L := 1;
  s := '';
  While L < Length (strName) do Begin
    If StrName [L] = '^' Then Begin
      If (StrName [L+1] <> '^') AND (ORD (StrName [L+1]) >= 64) Then Begin
        S := s + Chr (ORD (StrName [L+1]) - 64);
        INC (L,2);
      End
      Else Begin
        S:= S + StrName [L] + StrName [L+1];
        Inc (L,2);
      End;
    End
    Else Begin
      s := s + StrName [L];
      Inc (L);
    End;
  End;
  StringToEsc := S;
End;

{----------------------------------------------------------------------------}

END.