home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 October / Chip_2001-10_cd1.bin / zkuste / delphi / nastroje / d3456 / KBMWABD.ZIP / WABD_Utils.pas < prev   
Pascal/Delphi Source File  |  2001-07-13  |  9KB  |  336 lines
  1. unit WABD_Utils;
  2.  
  3. interface
  4.  
  5. uses classes,sysutils,Graphics,Windows,Math;
  6.  
  7.    function MonthName(DateTime:TDateTime):string;
  8.    function DayName(DateTime:TDateTime):string;
  9.    function HTML_To_ASCII(const Input: string): string;
  10.    function ASCII_To_HTML(const Input: string): string;
  11.    function URL_To_HTML(const Input: string): string;
  12.    function FindReplace(const str,find,replace:string):string;
  13.    function ColorToHTML(c:TColor; Del:string):string;
  14.    function ValueToHTML(s:string; w:integer):string;
  15.    function GetWord(const Data:string; FromPos,ToPos,MaxLen:integer):string;
  16.    function WABD_Pos(Buffer,Pattern: PChar; MaxLen: LongInt):PChar;
  17.    function FindComponentRecursive(Root: TComponent; AName: string):TComponent;
  18.    procedure WABD_SplitString(Buffer:PChar; Delimiter:char; List:TStringList);
  19.  
  20.  
  21. const
  22.    WABD_BrowserUnknown=0;
  23.    WABD_BrowserIExplorer=1;
  24.    WABD_BrowserNetScape=2;
  25.  
  26.    WABD_STATUS_OK = 200;
  27.    WABD_STATUS_AUTH = 401;
  28.    WABD_STATUS_REDIRECT = 302;
  29.  
  30.    WABD_Browser : array [WABD_BrowserUnknown..WABD_BrowserNetScape] of string =
  31.      ('Unknown',
  32.       'MS Internet Explorer',
  33.       'Netscape'
  34.      );
  35.  
  36.  
  37. implementation
  38.  
  39. const
  40.    MonthNames: array[1..12] of string = (
  41.     'Jan', 'Feb', 'Mar', 'Apr',
  42.     'May', 'Jun', 'Jul', 'Aug',
  43.     'Sep', 'Oct', 'Nov', 'Dec');
  44.    DayNames:  array[1..7] of string = (
  45.     'Sun', 'Mon', 'Tue', 'Wed',
  46.     'Thu', 'Fri', 'Sat');
  47.  
  48. // ************************************************************************
  49. // Utility functions
  50. // ************************************************************************
  51.  
  52. // Parse URLEncoded null terminated buffer.
  53. procedure WABD_SplitString(Buffer:PChar; Delimiter:char; List:TStringList);
  54. var
  55.    pCh:PChar;
  56.    pBuf:PChar;
  57.    lBuf:integer;
  58.    pStart:PChar;
  59.    s:string;
  60.    buf:array [0..8191] of char;
  61. begin
  62.      pStart:=Buffer;
  63.      pCh:=pStart;
  64.      pBuf:=buf;
  65.      lBuf:=sizeof(buf);
  66.      if pCh^ = #0 then exit;
  67.      while (lBuf>0) do
  68.      begin
  69.           // Field seperator.
  70.           if (pCh^ = Delimiter) or (pCh^ = #0) then
  71.           begin
  72.                SetString(s,buf,pBuf-buf);
  73.                List.Add(trim(s));
  74.                if pCh^=#0 then break;
  75.                pBuf:=buf;
  76.                lBuf:=sizeof(buf);
  77.           end
  78.           else
  79.           begin
  80.                pBuf^:=pCh^;
  81.                inc(pBuf);
  82.                dec(lBuf);
  83.           end;
  84.           inc(pCh);
  85.      end;
  86. end;
  87.  
  88. // Fast string search function.
  89. function WABD_Pos(Buffer,Pattern:PChar; MaxLen:LongInt):PChar;
  90. var
  91.    T:array[char] Of Byte;
  92.    p:PChar;
  93.    a,b:byte;
  94.    n:integer;
  95.  
  96.    function        LowCase( ch : Char ) : Char;
  97.    asm
  98.    { ->    AL      Character       }
  99.    { <-    AL      Result          }
  100.  
  101.            CMP     AL,'A'
  102.            JB      @@exit
  103.            CMP     AL,'Z'
  104.            JA      @@exit
  105.            ADD     AL,'a' - 'A'
  106.    @@exit:
  107.    end;
  108.  
  109. begin
  110.   // If no pattern given.
  111.   if Pattern^=#0 then
  112.   begin
  113.        Result:=Buffer;
  114.        exit;
  115.   end;
  116.  
  117.   // Check if possible to search on pattern.
  118.   b:=strlen(Pattern);
  119.   if (Buffer=nil) or (MaxLen<b) then
  120.   begin
  121.        Result:=nil;
  122.        exit;
  123.   end;
  124.  
  125.   // Convert pattern to uppercase.
  126.   p:=Pattern;
  127.   while (p^ <> #0) do
  128.   begin
  129.        p^:=UpCase(p^);
  130.        inc(p);
  131.   end;
  132.  
  133.   // Prepare jump table.
  134.   FillChar(T,sizeOf(T),b);
  135.   dec(b);
  136.   p:=Pattern;
  137.   while p^ <> #0 do
  138.   begin
  139.        n:=b - (p-Pattern);
  140.        T[p^        ]:=n;
  141.        T[LowCase(p^)]:=n;
  142.        inc(p);
  143.   end;
  144.  
  145.   // Search.
  146.   p:=Buffer;
  147.   repeat
  148.         a:=b;
  149.         while UpCase(p[a]) = Pattern[a] do
  150.         begin
  151.              if a=0 then
  152.              begin
  153.                   Result:=p;
  154.                   exit;
  155.              end;
  156.              Dec(a)
  157.         end;
  158.         if MaxLen < T[p[a]] then break;
  159.  
  160.         Dec(MaxLen,T[p[a]]);
  161.         Inc(p,Max(1,T[p[a]]))
  162.   until false;
  163.  
  164.   Result:=nil
  165. end;
  166.  
  167. function MonthName(DateTime:TDateTime):string;
  168. var
  169.    Year,Month,Day:Word;
  170. begin
  171.      DecodeDate(DateTime,Year,Month,Day);
  172.      Result:=MonthNames[Month];
  173. end;
  174.  
  175. function DayName(DateTime:TDateTime):string;
  176. begin
  177.      Result:=DayNames[DayOfWeek(DateTime)];
  178. end;
  179.  
  180. {$IFDEF KBM
  181. function ReplaceInStr(InStr: string; var OutStr : string;
  182.                       FindStr, ReplaceStr : string) : integer;
  183. var
  184.   LenFindStr, LenReplaceStr, LenInStr : integer;
  185.   PtrInStr, PtrOutStr,  // pointers to incremental reading and writing
  186.     PInStr, POutStr : PChar;   // pointer to start of output string
  187. begin
  188.   LenInStr := Length(InStr);
  189.   LenFindStr := Length(FindStr);
  190.   LenReplaceStr := Length(ReplaceStr);
  191.   Result := 0;
  192.   PInStr := PChar(InStr);
  193.   PtrInStr := PInStr;
  194.   {find number of occurences to allocate output memory in one chunk}
  195.   while PtrInStr < (PInStr + LenInStr) do begin
  196.     if StrLIComp(PtrInStr, PChar(FindStr), LenFindStr) = 0 then
  197.       inc(Result);
  198.     inc(PtrInStr);
  199.   end;
  200.   {reset pointer}
  201.   PtrInStr := PInStr;
  202.   {allocate the output memory - calculating what is needed}
  203.   GetMem(POutStr, Length(InStr) + (Result * (LenReplaceStr - LenFindStr)) + 1);
  204.   {find and replace the strings}
  205.   PtrOutStr := POutStr;
  206.   while PtrInStr < (PInStr + LenInStr) do begin
  207.     if StrLIComp(PtrInStr, PChar(FindStr), LenFindStr) = 0 then begin
  208.       {write the replacement string to the output string}
  209.       if LenReplaceStr > 0 then begin
  210.         StrLCopy(PtrOutStr, PChar(ReplaceStr), LenReplaceStr);
  211.         inc(PtrInStr, LenFindStr);      // increment input pointer
  212.         inc(PtrOutStr, LenReplaceStr);  // increment output pointer
  213.       end; {if LenReplaceStr > 0}
  214.       end {if StrLIComp(...) = 0}
  215.     else begin
  216.       {write one char to the output string}
  217.       StrLCopy(PtrOutStr, PtrInStr, 1); // copy character
  218.       inc(PtrInStr);
  219.       inc(PtrOutStr);
  220.     end; {if StrLIComp(...) = 0 else}
  221.   end;
  222.   {copy the output string memory to the provided output string}
  223.   OutStr := StrPas(POutStr);
  224.   FreeMem(POutStr);
  225. end;
  226. {$ENDIF}
  227.  
  228. function FindComponentRecursive(Root: TComponent; AName: string):TComponent;
  229. var
  230.   i:integer;
  231. begin
  232.      AName:=LowerCase(AName);
  233.      if (AName<>'') and (Root.ComponentCount<>0) then
  234.      begin
  235.           for i:=0 to Root.ComponentCount-1 do
  236.           begin
  237.                Result:=Root.Components[i];
  238.                if LowerCase(Result.Name)=AName then exit;
  239.                if (Result.ComponentCount<>0) then
  240.                begin
  241.                     Result:=FindComponentRecursive(Result,AName);
  242.                     if Result<>nil then exit;
  243.                end;
  244.           end;
  245.      end;
  246.      Result:=nil;
  247. end;
  248.  
  249. function FindReplace(const str,find,replace:string):string;
  250. var
  251.   aPos: Integer;
  252.   rslt: String;
  253.   s:string;
  254. begin
  255.      s:=str;
  256.      aPos := Pos(find, s);
  257.      rslt := '';
  258.      while (aPos <> 0) do
  259.      begin
  260.           rslt := rslt + Copy(s, 1, aPos - 1) + replace;
  261.           Delete(s, 1, aPos);
  262.           aPos := Pos(find, s);
  263.      end;
  264.      Result := rslt + s;
  265. end;
  266.  
  267. function HTML_To_ASCII(const Input: string): string;
  268. begin
  269.      Result:=FindReplace(Input, '&', '&');
  270.      Result:=FindReplace(Result, '<',  '<');
  271.      Result:=FindReplace(Result, '>',  '>');
  272.      Result:=FindReplace(Result, ':',  ':');  // $3A
  273.      Result:=FindReplace(Result, ';',  ';');  // Ç3B
  274.      Result:=FindReplace(Result, '$#105',  '_');
  275.      Result:=FindReplace(Result, '%3A',  ':');
  276.      Result:=FindReplace(Result, '%3B',  ';');
  277.      Result:=FindReplace(Result, '%5F',  '_');
  278. end;
  279.  
  280. function ASCII_To_HTML(const Input: string): string;
  281. begin
  282.      Result:=FindReplace(Input, '&', '&');
  283.      Result:=FindReplace(Result, '<', '<');
  284.      Result:=FindReplace(Result, '>', '>');
  285. end;
  286.  
  287. function URL_To_HTML(const Input: string): string;
  288. begin
  289.      Result:=FindReplace(Input, ';', ';');
  290.      Result:=FindReplace(Result, ':', ':');
  291. end;
  292.  
  293. // Return color in HTML format.
  294. function ColorToHTML(c:TColor; Del:string):string;
  295. var
  296.    col      : integer;
  297.    rgb      : TRGBQuad;
  298. begin
  299.      col:=colortorgb(c);
  300.      move(col,rgb,sizeof(rgb));
  301.      Result:=format('%s#%0.2x%0.2x%0.2x%s',[Del,rgb.rgbblue,rgb.rgbgreen,rgb.rgbred,Del]);
  302. end;
  303.  
  304. // Return width in HTML format.
  305. function ValueToHTML(s:string; w:integer):string;
  306. begin
  307.      if w<0 then Result:=' '+s+'='+inttostr(-w)
  308.      else if w>0 then Result:=' '+s+'='+inttostr(w)+'%'
  309.      else Result:='';
  310. end;
  311.  
  312. function GetWord(const Data:string; FromPos,ToPos,MaxLen:integer):string;
  313. var
  314.    s,i,l:integer;
  315. begin
  316.      l:=length(Data);
  317.      if MaxLen<0 then MaxLen:=l;
  318.      if ToPos<0 then ToPos:=l;
  319.  
  320.      // Remove leading spaces.
  321.      i:=FromPos;
  322.      while (i<ToPos) and (Data[i] in [' ',#10,#13]) do inc(i);
  323.  
  324.      // Get word until space or length.
  325.      s:=i;
  326.      while (i<ToPos) and (not (Data[i] in [' ',#10,#13,'&'])) and (l<MaxLen) do
  327.      begin
  328.           inc(i);
  329.           inc(l);
  330.      end;
  331.  
  332.      Result:=Copy(Data,s,i-s);
  333. end;
  334.  
  335. end.
  336.