obj/UStr.pas

   1 unit UStr;
   2
   3 interface
   4
   5 function  space   (           n:integer):string ;
   6 function  replicate(ch:char;  n:integer):string ;
   7 function  trim    (str:string;c:boolean=false):string ;
   8 function  alike   (a,b:string;var d, p: integer): boolean;
   9 function  center  (str:string;n:integer):string ;
  10 function  UpSt    (  s:string          ):string;
  11 function  LoSt    (  s:string          ):string;
  12 function  lpad    (  s:string;n:integer;c:char):string;
  13 function  rpad    (  s:string;n:integer;c:char):string;
  14 function  addbackslash(p : string) : string;
  15 function  match   (sm : string; var st: string) : boolean;
  16 function  lines   (p, l, s : longint) : string;
  17 function  LoCase  (c : char) : char;
  18 function  JustPathName(PathName : string) : string;
  19 function  JustFileName(PathName : string) : string;
  20 function  JustName    (PathName : string) : string;
  21 function  CRC16       (s        : string) : system.word;
  22
  23 implementation
  24
  25 function  space;
  26 var   i : integer;
  27 tempstr : string;
  28      begin
  29         tempstr:='';
  30         for i:=1 to n do tempstr:=tempstr+' ';
  31         space:=tempstr;
  32      end;
  33
  34 function  replicate;
  35 var   i : integer;
  36 tempstr : string;
  37      begin
  38         tempstr:='';
  39         for i:=1 to n do tempstr:=tempstr+ch;
  40         replicate:=tempstr;
  41      end;
  42
  43 function  trim;
  44 var i,j : integer;
  45       s : string;
  46 begin
  47    trim := '';
  48    s := str;
  49    if length(str) > 1 then begin
  50       i := length(str);
  51       j := 1;
  52       while (j <= i) and (str[j] = ' ') do inc(j);
  53       if j > i then begin
  54          result := '';
  55          exit;
  56       end;
  57       while              (str[i] = ' ') do dec(i);
  58       s := copy(str, j, i - j + 1);
  59    end;
  60    if c and (length(s) > 3) then begin
  61       repeat
  62          i := pos('  ', s);
  63          if i > 0 then begin
  64             s := copy(s, 1, i - 1) + copy(s, i + 1, length(s) - i);
  65          end;
  66       until i = 0;
  67    end;
  68    if c then result := LoSt(s)
  69         else result := s;
  70 end;
  71
  72 function  alike;
  73 var e, f: integer;
  74 begin
  75    result := false;
  76    p := 0;
  77    e := length(a);
  78    f := length(b);
  79    if e + f = 0 then begin
  80       result := true;
  81       d      := 100;
  82       exit;
  83    end;
  84    if (e = 0) or (f = 0) then begin
  85       d := 0;
  86       exit;
  87    end;
  88    while (p < e) and (p < f) do begin
  89       inc(p);
  90       if a[p] <> b[p] then begin
  91          dec(p);
  92          break;
  93       end;
  94    end;
  95    d := 200 * p div (e + f);
  96    if p * 2 > (e + f) div 2 then begin
  97       result := true;
  98    end;
  99 end;
 100
 101 function  center;
 102 var tempstr : string;
 103           j : integer;
 104      begin
 105         j := n - length(trim(str));
 106         if j > 0 then tempstr := space(j - j div 2) + trim(str) + space(j div 2)
 107                  else tempstr := trim(str);
 108         center := tempstr;
 109      end;
 110
 111 function UpSt;
 112 var t : string;
 113     i : integer;
 114 begin
 115    t := s;
 116    for i := 1 to length(s) do t[i] := UpCase(s[i]);
 117    UpSt := t;
 118 end;
 119
 120 function LoSt;
 121 var t : string;
 122     i : integer;
 123 begin
 124    t := s;
 125    for i := 1 to length(s) do t[i] := LoCase(s[i]);
 126    LoSt := t;
 127 end;
 128
 129 function lpad;
 130 begin
 131    lpad := replicate(c, n - length(s)) + s;
 132 end;
 133
 134 function rpad;
 135 begin
 136    rpad := s + replicate(c, n - length(s));
 137 end;
 138
 139     function addbackslash;
 140     begin
 141        if length(p) > 0 then
 142        if p[length(p)] = '\' then addbackslash := p
 143                              else addbackslash := p + '\'
 144                         else addbackslash := p;
 145     end;
 146
 147 function match(sm : string; var st: string) : boolean;
 148 var p : integer;
 149   _sm,
 150   _st : string;
 151 begin
 152    match := false;
 153    if (length(sm) > 0) and (length(st) > 0) then begin
 154       _sm := UpSt(sm);
 155       _st := UpSt(st);
 156       while pos(_sm, _st) > 0 do begin
 157          match := true;
 158          p     := pos(_sm, _st);
 159         _st    := copy(_st, 1, p - 1) + copy(_st, p + length(_sm), 250);
 160          st    := copy( st, 1, p - 1) + copy( st, p + length( sm), 250);
 161       end;
 162    end;
 163 end;
 164
 165 function lines;
 166 var o : string;
 167     i : longint;
 168     n : longint;
 169 begin
 170     if l > 0 then begin
 171        i := p * s div l;
 172        n := p * s * 2 div l;
 173        o := replicate('Û', i);
 174        if n > i * 2 then o := o + 'Ý';
 175        lines := o + space(s - length(o));
 176     end else lines := '';
 177 end;
 178
 179 function LoCase;
 180 var t : char;
 181 begin
 182    if (c >= 'A') and (c <= 'Z') then t := chr(ord(c) + 32)
 183                                 else t := c;
 184    LoCase := t;
 185 end;
 186
 187   function JustPathname(PathName : string) : string;
 188     {-Return just the drive:directory portion of a pathname}
 189   var
 190     I : Word;
 191   begin
 192     I := Succ(Word(Length(PathName)));
 193     repeat
 194       Dec(I);
 195     until (PathName[I] in ['\',':',#0]) or (I = 1);
 196
 197     if I = 1 then
 198       {Had no drive or directory name}
 199       JustPathname := ''
 200     else if I = 1 then
 201       {Either the root directory of default drive or invalid pathname}
 202       JustPathname := PathName[1]
 203     else if (PathName[I] = '\') then begin
 204       if PathName[Pred(I)] = ':' then
 205         {Root directory of a drive, leave trailing backslash}
 206         JustPathname := Copy(PathName, 1, I)
 207       else
 208         {Subdirectory, remove the trailing backslash}
 209         JustPathname := Copy(PathName, 1, Pred(I));
 210     end else
 211       {Either the default directory of a drive or invalid pathname}
 212       JustPathname := Copy(PathName, 1, I);
 213   end;
 214
 215   function JustFilename(PathName : string) : string;
 216     {-Return just the filename of a pathname}
 217   var
 218     I : Word;
 219   begin
 220     I := Succ(Word(Length(PathName)));
 221     repeat
 222       Dec(I);
 223     until (I = 0) or (PathName[I] in ['\', ':', #0]);
 224     JustFilename := Copy(PathName, Succ(I), 64);
 225   end;
 226
 227   function JustName(PathName : string) : string;
 228     {-Return just the name (no extension, no path) of a pathname}
 229   var
 230     DotPos : Byte;
 231   begin
 232     PathName := JustFileName(PathName);
 233     DotPos := Pos('.', PathName);
 234     if DotPos > 0 then
 235       PathName := Copy(PathName, 1, DotPos-1);
 236     JustName := PathName;
 237   end;
 238
 239
 240 function CRC16(s : string) : system.word;  { By Kevin Cooney }
 241 var
 242   crc : longint;
 243   t,r : byte;
 244 begin
 245   crc := 0;
 246   for t := 1 to length(s) do
 247   begin
 248     crc := (crc xor (ord(s[t]) shl 8));
 249     for r := 1 to 8 do
 250       if (crc and $8000)>0 then
 251         crc := ((crc shl 1) xor $1021)
 252           else
 253             crc := (crc shl 1);
 254   end;
 255   CRC16 := (crc and $FFFF);
 256 end;
 257
 258 end.