units/synapse/SynaUtil.pas

   1 {==============================================================================|
   2 | Project : Delphree - Synapse                                   | 002.003.000 |
   3 |==============================================================================|
   4 | Content: support procedures and functions                                    |
   5 |==============================================================================|
   6 | The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
   7 | (the "License"); you may not use this file except in compliance with the     |
   8 | License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
   9 |                                                                              |
  10 | Software distributed under the License is distributed on an "AS IS" basis,   |
  11 | WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
  12 | the specific language governing rights and limitations under the License.    |
  13 |==============================================================================|
  14 | The Original Code is Synapse Delphi Library.                                 |
  15 |==============================================================================|
  16 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
  17 | Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001.          |
  18 | Portions created by Hernan Sanchez are Copyright (c) 2000.                   |
  19 | All Rights Reserved.                                                         |
  20 |==============================================================================|
  21 | Contributor(s):                                                              |
  22 |   Hernan Sanchez (hernan.sanchez@iname.com)                                  |
  23 |==============================================================================|
  24 | History: see HISTORY.HTM from distribution package                           |
  25 |          (Found at URL: http://www.ararat.cz/synapse/)                       |
  26 |==============================================================================}
  27
  28 {$Q-}
  29
  30 unit SynaUtil;
  31
  32 interface
  33
  34 uses
  35   KOL,
  36 {$IFDEF LINUX}
  37   Libc;
  38 {$ELSE}
  39   Windows;
  40 {$ENDIF}
  41
  42 function Timezone: string;
  43 function Rfc822DateTime(t: TDateTime): string;
  44 function CDateTime(t: TDateTime): string;
  45 function CodeInt(Value: Word): string;
  46 function DecodeInt(const Value: string; Index: Integer): Word;
  47 function IsIP(const Value: string): Boolean;
  48 function ReverseIP(Value: string): string;
  49 function IPToID(Host: string): string;
  50 procedure Dump(const Buffer, DumpFile: string);
  51 function SeparateLeft(const Value, Delimiter: string): string;
  52 function SeparateRight(const Value, Delimiter: string): string;
  53 function GetParameter(const Value, Parameter: string): string;
  54 function GetEmailAddr(const Value: string): string;
  55 function GetEmailDesc(Value: string): string;
  56 function StrToHex(const Value: string): string;
  57 function IntToBin(Value: Integer; Digits: Byte): string;
  58 function BinToInt(const Value: string): Integer;
  59 function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
  60         Para: string): string;
  61 function StringReplace(Value, Search, Replace: string): string;
  62 function RPos(const Sub, Value: String): Integer;
  63 function StrToIntDef(const Value : string; Default : Integer) : Integer;
  64
  65 implementation
  66
  67 function Timezone: string;
  68 {$IFDEF LINUX}
  69 var
  70         t: TTime_T;
  71         UT: TUnixTime;
  72         bias: Integer;
  73         h, m: Integer;
  74 begin
  75         __time(@T);
  76         localtime_r(@T, UT);
  77         bias := ut.__tm_gmtoff div 60;
  78         if bias >= 0 then
  79                 Result := '+'
  80         else
  81                 Result := '-';
  82 {$ELSE}
  83 var
  84         zoneinfo: TTimeZoneInformation;
  85         bias: Integer;
  86         h, m: Integer;
  87 begin
  88         case GetTimeZoneInformation(Zoneinfo) of
  89                 2:
  90                         bias := zoneinfo.Bias + zoneinfo.DaylightBias;
  91                 1:
  92                         bias := zoneinfo.Bias + zoneinfo.StandardBias;
  93         else
  94                 bias := zoneinfo.Bias;
  95         end;
  96         if bias <= 0 then
  97                 Result := '+'
  98         else
  99                 Result := '-';
 100 {$ENDIF}
 101         bias := Abs(bias);
 102         h := bias div 60;
 103         m := bias mod 60;
 104         Result := Result + Format('%.2d%.2d', [h, m]);
 105 end;
 106
 107 {==============================================================================}
 108
 109 function Rfc822DateTime(t: TDateTime): string;
 110 begin
 111                                                                 Result := Date2StrFmt('ddd, d MMMM yyyy ',t) + Time2StrFmt('hh:mm:ss', t);
 112                                                                 Result := Result + ' ' + Timezone;
 113 end;
 114
 115 {==============================================================================}
 116
 117 function CDateTime(t: TDateTime): string;
 118 begin
 119                                                                 Result := Date2StrFmt('mmm dd ',t) + Time2StrFmt('hh:mm:ss', t);
 120                                                                 if Result[5] = '0' then
 121                                                                                                 Result[5] := ' ';
 122 end;
 123
 124 {==============================================================================}
 125
 126 function CodeInt(Value: Word): string;
 127 begin
 128                                 Result := Chr(Hi(Value)) + Chr(Lo(Value))
 129 end;
 130
 131 {==============================================================================}
 132
 133 function DecodeInt(const Value: string; Index: Integer): Word;
 134 var
 135                                 x, y: Byte;
 136 begin
 137                                 if Length(Value) > Index then
 138                                                                 x := Ord(Value[Index])
 139                                 else
 140                                                                 x := 0;
 141                                 if Length(Value) >= (Index + 1) then
 142                                                                 y := Ord(Value[Index + 1])
 143                                 else
 144                                                                 y := 0;
 145                                 Result := x * 256 + y;
 146 end;
 147
 148 {==============================================================================}
 149
 150 function IsIP(const Value: string): Boolean;
 151 var
 152                                 n, x: Integer;
 153 begin
 154                                 Result := true;
 155                                 x := 0;
 156                                 for n := 1 to Length(Value) do
 157                                                                 if not (Value[n] in ['0'..'9', '.']) then
 158                                                                 begin
 159                                                                                                 Result := False;
 160                                                                                                 Break;
 161                                                                 end
 162                                                                 else
 163                                                                 begin
 164                                                                                                 if Value[n] = '.' then
 165                                                                                                                                 Inc(x);
 166                                                                 end;
 167                                 if x <> 3 then
 168                                                                 Result := False;
 169 end;
 170
 171 {==============================================================================}
 172
 173 function ReverseIP(Value: string): string;
 174 var
 175                                 x: Integer;
 176 begin
 177                                 Result := '';
 178                                 repeat
 179                                                                 x := DelimiterLast(Value,'.');
 180                                                                 Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x);
 181                                                                 Delete(Value, x, Length(Value) - x + 1);
 182                                 until x < 1;
 183                                 if Length(Result) > 0 then
 184                                                                 if Result[1] = '.' then
 185                                                                                                 Delete(Result, 1, 1);
 186 end;
 187
 188 {==============================================================================}
 189 //Hernan Sanchez
 190 function IPToID(Host: string): string;
 191 var
 192                                 s, t: string;
 193                                 i, x: Integer;
 194 begin
 195                                 Result := '';
 196                                 for x := 1 to 3 do
 197                                 begin
 198                                                                 t := '';
 199                                                                 s := StrScan(PChar(Host), '.');
 200                                                                 t := Copy(Host, 1, (Length(Host) - Length(s)));
 201                                                                 Delete(Host, 1, (Length(Host) - Length(s) + 1));
 202                                                                 i := StrToIntDef(t, 0);
 203                                                                 Result := Result + Chr(i);
 204                                 end;
 205         i := StrToIntDef(Host, 0);
 206         Result := Result + Chr(i);
 207 end;
 208
 209 {==============================================================================}
 210
 211 procedure Dump(const Buffer, DumpFile: string);
 212 var
 213         n: Integer;
 214         s: string;
 215         f: Text;
 216 begin
 217         s := '';
 218         for n := 1 to Length(Buffer) do
 219                 s := s + ' +#$' + Int2Hex(Ord(Buffer[n]), 2);
 220         AssignFile(f, DumpFile);
 221         if FileExists(DumpFile) then
 222                 DeleteFile(PChar(DumpFile));
 223         Rewrite(f);
 224         try
 225                 Writeln(f, s);
 226         finally
 227                 CloseFile(f);
 228         end;
 229 end;
 230
 231 {==============================================================================}
 232
 233 function SeparateLeft(const Value, Delimiter: string): string;
 234 var
 235         x: Integer;
 236 begin
 237         x := Pos(Delimiter, Value);
 238         if x < 1 then
 239                 Result := Trim(Value)
 240         else
 241                 Result := Trim(Copy(Value, 1, x - 1));
 242 end;
 243
 244 {==============================================================================}
 245
 246 function SeparateRight(const Value, Delimiter: string): string;
 247 var
 248         x: Integer;
 249 begin
 250                                 x := Pos(Delimiter, Value);
 251         if x > 0 then
 252                 x := x + Length(Delimiter) - 1;
 253         Result := Trim(Copy(Value, x + 1, Length(Value) - x));
 254 end;
 255
 256 {==============================================================================}
 257
 258 function GetParameter(const Value, Parameter: string): string;
 259 var
 260         x, x1: Integer;
 261         s: string;
 262 begin
 263                                 x := Pos(UpperCase(Parameter), UpperCase(Value));
 264         Result := '';
 265                                 if x > 0 then
 266         begin
 267                 s := Copy(Value, x + Length(Parameter), Length(Value)
 268                         - (x + Length(Parameter)) + 1);
 269                 s := Trim(s);
 270                                                                 x1 := Length(s);
 271                 if Length(s) > 1 then
 272                 begin
 273                         if s[1] = '"' then
 274                         begin
 275                                 s := Copy(s, 2, Length(s) - 1);
 276                                 x := Pos('"', s);
 277                                 if x > 0 then
 278                                         x1 := x - 1;
 279                         end
 280                         else
 281                         begin
 282                                 x := Pos(' ', s);
 283         if x > 0 then
 284           x1 := x - 1;
 285       end;
 286     end;
 287                 Result := Copy(s, 1, x1);
 288   end;
 289 end;
 290
 291 {==============================================================================}
 292
 293 function GetEmailAddr(const Value: string): string;
 294 var
 295   s: string;
 296 begin
 297   s := SeparateRight(Value, '<');
 298   s := SeparateLeft(s, '>');
 299   Result := Trim(s);
 300 end;
 301
 302 {==============================================================================}
 303
 304 function GetEmailDesc(Value: string): string;
 305 var
 306   s: string;
 307 begin
 308   Value := Trim(Value);
 309         s := SeparateRight(Value, '"');
 310   if s <> Value then
 311     s := SeparateLeft(s, '"')
 312   else
 313   begin
 314     s := SeparateRight(Value, '(');
 315     if s <> Value then
 316       s := SeparateLeft(s, ')')
 317     else
 318     begin
 319       s := SeparateLeft(Value, '<');
 320       if s = Value then
 321         s := '';
 322     end;
 323   end;
 324   Result := Trim(s);
 325 end;
 326
 327 {==============================================================================}
 328
 329 function StrToHex(const Value: string): string;
 330 var
 331         n: Integer;
 332 begin
 333   Result := '';
 334   for n := 1 to Length(Value) do
 335     Result := Result + Int2Hex(Byte(Value[n]), 2);
 336   Result := LowerCase(Result);
 337 end;
 338
 339 {==============================================================================}
 340
 341 function IntToBin(Value: Integer; Digits: Byte): string;
 342 var
 343   x, y, n: Integer;
 344 begin
 345   Result := '';
 346   x := Value;
 347   repeat
 348     y := x mod 2;
 349     x := x div 2;
 350     if y > 0 then
 351       Result := '1' + Result
 352     else
 353                         Result := '0' + Result;
 354   until x = 0;
 355   x := Length(Result);
 356   for n := x to Digits - 1 do
 357     Result := '0' + Result;
 358 end;
 359
 360 {==============================================================================}
 361
 362 function BinToInt(const Value: string): Integer;
 363 var
 364   n: Integer;
 365 begin
 366   Result := 0;
 367   for n := 1 to Length(Value) do
 368   begin
 369     if Value[n] = '0' then
 370       Result := Result * 2
 371     else
 372       if Value[n] = '1' then
 373         Result := Result * 2 + 1
 374       else
 375                                 Break;
 376   end;
 377 end;
 378
 379 {==============================================================================}
 380
 381 function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
 382   Para: string): string;
 383 var
 384   x: Integer;
 385   sURL: string;
 386   s: string;
 387   s1, s2: string;
 388 begin
 389   Prot := 'http';
 390   User := '';
 391   Pass := '';
 392   Port := '80';
 393   Para := '';
 394
 395   x := Pos('://', URL);
 396   if x > 0 then
 397         begin
 398     Prot := SeparateLeft(URL, '://');
 399     sURL := SeparateRight(URL, '://');
 400   end
 401   else
 402     sURL := URL;
 403   x := Pos('@', sURL);
 404   if x > 0 then
 405   begin
 406     s := SeparateLeft(sURL, '@');
 407     sURL := SeparateRight(sURL, '@');
 408     x := Pos(':', s);
 409     if x > 0 then
 410     begin
 411       User := SeparateLeft(s, ':');
 412       Pass := SeparateRight(s, ':');
 413     end
 414     else
 415       User := s;
 416   end;
 417   x := Pos('/', sURL);
 418   if x > 0 then
 419         begin
 420     s1 := SeparateLeft(sURL, '/');
 421     s2 := SeparateRight(sURL, '/');
 422   end
 423   else
 424   begin
 425     s1 := sURL;
 426     s2 := '';
 427   end;
 428   x := Pos(':', s1);
 429   if x > 0 then
 430   begin
 431     Host := SeparateLeft(s1, ':');
 432     Port := SeparateRight(s1, ':');
 433   end
 434   else
 435     Host := s1;
 436   Result := '/' + s2;
 437         x := Pos('?', s2);
 438   if x > 0 then
 439   begin
 440     Path := '/' + SeparateLeft(s2, '?');
 441                 Para := SeparateRight(s2, '?');
 442   end
 443   else
 444     Path := '/' + s2;
 445   if Host = '' then
 446                 Host := 'localhost';
 447 end;
 448
 449 {==============================================================================}
 450
 451 function StringReplace(Value, Search, Replace: string): string;
 452 var
 453                                 x, l, ls, lr: Integer;
 454 begin
 455                                 if (Value = '') or (Search = '') then
 456                                 begin
 457                                                                 Result := Value;
 458                                                                 Exit;
 459                                 end;
 460                                 ls := Length(Search);
 461                                 lr := Length(Replace);
 462                                 Result := '';
 463                                 x := Pos(Search, Value);
 464                                 while x > 0 do
 465         begin
 466                 l := Length(Result);
 467                 SetLength(Result, l + x - 1);
 468                 Move(Pointer(Value)^, Pointer(@Result[l + 1])^, x - 1);
 469 //      Result:=Result+Copy(Value,1,x-1);
 470                 l := Length(Result);
 471                 SetLength(Result, l + lr);
 472                 Move(Pointer(Replace)^, Pointer(@Result[l + 1])^, lr);
 473 //      Result:=Result+Replace;
 474                 Delete(Value, 1, x - 1 + ls);
 475                 x := Pos(Search, Value);
 476         end;
 477         Result := Result + Value;
 478 end;
 479
 480 {==============================================================================}
 481
 482 function RPos(const Sub, Value: String): Integer;
 483 var
 484                                 n: Integer;
 485                                 l: Integer;
 486 begin
 487                                 result := 0;
 488                                 l := Length(Sub);
 489                                 for n := Length(Value) - l + 1 downto 1 do
 490                                 begin
 491                                                                 if Copy(Value, n, l) = Sub then
 492                                                                 begin
 493                                                                                                 result := n;
 494                                                                                                 break;
 495                                                                 end;
 496                                 end;
 497 end;
 498
 499
 500 function StrToIntDef(const Value : string; Default : Integer) : Integer;
 501 begin
 502         if Value[1]= '$' then Result := Hex2Int(Value)
 503         else
 504                 Result := Str2Int(Value);
 505         if (Result = 0) and ((Value <> '0') and (Value <> '$0')) then Result := Default;
 506 end;
 507
 508 end.