Release 16

git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@35 7c85be65-684b-0410-a082-b2ed4fbef004

httpsend.pas

@@ -1,7 +1,7 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 001.001.000 |
+| Project : Delphree - Synapse                                   | 001.002.000 |
 |==============================================================================|
-| Content: HTTP client                                                        |
+| Content: HTTP client                                                         |
 |==============================================================================|
 | The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
 | (the "License"); you may not use this file except in compliance with the     |
@@ -14,7 +14,7 @@
 | The Original Code is Synapse Delphi Library.                                 |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c) 1999.                    |
+| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001.          |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -27,7 +27,7 @@ unit HTTPsend;
 
 interface
 uses
-  Blcksock, sysutils, classes, windows, SynaUtil;
+  Blcksock, sysutils, classes, windows, SynaUtil, SynaCode;
 
 const
   CRLF=#13+#10;
@@ -39,13 +39,21 @@ type
   public
     timeout:integer;
     HTTPHost:string;
-    HTTPPort:integer;
+    HTTPPort:string;
+    ProxyHost:string;
+    ProxyPort:string;
+    ProxyUser:string;
+    ProxyPass:string;
+    ResultCode:integer;
     Constructor Create;
     Destructor Destroy; override;
     function Request(Query,Response:TStrings):Boolean;
+    function DoMethod(method,URL:string;Content,Response:TStrings):boolean;
   end;
 
-function get(Host,URI:string;Response:TStrings):Boolean;
+function SimpleGet(URL:string;Response:TStrings):Boolean;
+function Get(URL:string;Response:TStrings):Boolean;
+function Post(URL:string;Value,Response:TStrings):Boolean;
 
 implementation
 
@@ -57,7 +65,11 @@ begin
   sock.CreateSocket;
   timeout:=300000;
   HTTPhost:='localhost';
-  HTTPPort:=80;
+  HTTPPort:='80';
+  ProxyHost:='';
+  ProxyPort:='8080';
+  ProxyUser:='';
+  ProxyPass:='';
 end;
 
 {THTTPSend.Destroy}
@@ -74,7 +86,7 @@ var
   n:integer;
 begin
   Result:=False;
-  sock.Connect(HTTPHost,IntToStr(HTTPPort));
+  sock.Connect(HTTPHost,HTTPPort);
   if sock.lasterror<>0 then Exit;
   for n:=0 to Query.Count-1 do
     Sock.SendString(Query[n]+CRLF);
@@ -88,20 +100,84 @@ begin
   Result:=True;
 end;
 
+{THTTPSend.DoMethod}
+function THTTPSend.DoMethod(method,URL:string;Content,Response:TStrings):boolean;
+var
+  Prot,User,Pass,Host,Port,Path,Para:string;
+  Query:TstringList;
+  size:integer;
+  s:string;
+begin
+  result:=false;
+  Query:=TstringList.create;
+  try
+    parseURL(URL,Prot,User,Pass,Host,Port,Path,Para);
+    if content<>nil
+      then query.AddStrings(content);
+    size:=length(query.text);
+    query.insert(0,'');
+    query.insert(0,'User-Agent: Synapse/1.1');
+    query.insert(0,'Connection: close');
+    query.insert(0,'Accept-Encoding: identity');
+    if User<>''
+      then query.insert(0,'Authorization: Basic '+EncodeBase64(user+':'+pass));
+    if (proxyhost<>'') and (proxyUser<>'')
+      then query.insert(0,'Proxy-Authorization: Basic '+EncodeBase64(Proxyuser+':'+Proxypass));
+    if size>0
+      then query.insert(0,'Content-Length: '+inttostr(size));
+    query.insert(0,'Host: '+host+':'+port);
+
+    if para=''
+      then s:=''
+      else s:='?'+para;
+    s:=path+s;
+    if proxyHost<>''
+      then s:=prot+'://'+host+':'+port+s;
+    query.insert(0,uppercase(method)+' '+s+' HTTP/1.0');
+    if proxyhost=''
+      then
+        begin
+          HttpHost:=host;
+          HttpPort:=port;
+        end
+      else
+        begin
+          HttpHost:=Proxyhost;
+          HttpPort:=Proxyport;
+        end;
+    result:=request(query,response);
+    ResultCode:=0;
+    if response.count>0
+      then if pos('HTTP/',uppercase(response[0]))=1
+        then
+          begin
+            s:=separateright(response[0],' ');
+            s:=separateleft(s,' ');
+            ResultCode:=StrToIntDef(s,0);
+          end;
+  finally
+    Query.free;
+  end;
+end;
+
 {==============================================================================}
 
-{get}
+{SimpleGet}
-function get(Host,URI:string;Response:TStrings):Boolean;
+function SimpleGet(URL:string;Response:TStrings):Boolean;
 var
   HTTP:THTTPSend;
   Query:TStringList;
+  Prot,User,Pass,Host,Port,Path,Para:string;
 begin
+  parseURL(URL,Prot,User,Pass,Host,Port,Path,Para);
+  if para<>''
+    then path:=path+'?'+para;
   Result:=False;
   HTTP:=THTTPSend.Create;
   Query:=TStringList.create;
   try
     HTTP.HTTPhost:=Host;
-    Query.Add('GET '+URI+' HTTP/0.9');
+    Query.Add('GET '+Path);
     if not HTTP.Request(Query,Response) then Exit;
   finally
     Query.Free;
@@ -110,4 +186,35 @@ begin
   Result:=True;
 end;
 
+{get}
+function Get(URL:string;Response:TStrings):Boolean;
+var
+  HTTP:THTTPSend;
+  Prot,User,Pass,Host,Port,Path,Para:string;
+begin
+  Result:=False;
+  HTTP:=THTTPSend.Create;
+  try
+    result:=HTTP.DoMethod('GET',URL,nil,Response);
+  finally
+    HTTP.Free;
+  end;
+end;
+
+{post}
+function Post(URL:string;Value,Response:TStrings):Boolean;
+var
+  HTTP:THTTPSend;
+  Prot,User,Pass,Host,Port,Path,Para:string;
+begin
+  Result:=False;
+  HTTP:=THTTPSend.Create;
+  try
+    result:=HTTP.DoMethod('POST',URL,Value,Response);
+  finally
+    HTTP.Free;
+  end;
+end;
+
+
 end.

smtpsend.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 001.003.000 |
+| Project : Delphree - Synapse                                   | 002.000.000 |
 |==============================================================================|
 | Content: SMTP client                                                         |
 |==============================================================================|
@@ -14,7 +14,7 @@
 | The Original Code is Synapse Delphi Library.                                 |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c) 1999.                    |
+| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001.          |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -27,7 +27,7 @@ unit SMTPsend;
 
 interface
 uses
-  Blcksock, sysutils, classes, windows, SynaUtil;
+  Blcksock, sysutils, classes, windows, SynaUtil, SynaCode;
 
 const
   CRLF=#13+#10;
@@ -36,25 +36,43 @@ type
   TSMTPSend = class
   private
     Sock:TTCPBlockSocket;
+    procedure EnhancedCode(value:string);
     function ReadResult:integer;
   public
     timeout:integer;
     SMTPHost:string;
     ResultCode:integer;
     ResultString:string;
+    FullResult:TStringList;
+    ESMTPcap:TStringList;
+    ESMTP:boolean;
+    Username:string;
+    Password:string;
+    AuthDone:boolean;
+    ESMTPSize:boolean;
+    MaxSize:integer;
+    EnhCode1:integer;
+    EnhCode2:integer;
+    EnhCode3:integer;
     Constructor Create;
     Destructor Destroy; override;
+    function AuthLogin:Boolean;
+    function AuthCram:Boolean;
     function login:Boolean;
     procedure logout;
     function reset:Boolean;
     function noop:Boolean;
-    function mailfrom(Value:string):Boolean;
+    function mailfrom(Value:string; size:integer):Boolean;
     function mailto(Value:string):Boolean;
     function maildata(Value:Tstrings):Boolean;
+    function etrn(Value:string):Boolean;
+    function verify(Value:string):Boolean;
+    function EnhCodeString:string;
   end;
 
-function SendtoRaw (mailfrom,mailto,SMTPHost:string;maildata:TStrings):Boolean;
+function SendtoRaw (mailfrom,mailto,SMTPHost:string;maildata:TStrings;Username,Password:string):Boolean;
 function Sendto (mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings):Boolean;
+function SendtoEx (mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings;Username,Password:string):Boolean;
 
 implementation
 
@@ -62,50 +80,160 @@ implementation
 Constructor TSMTPSend.Create;
 begin
   inherited Create;
+  FullResult:=TStringList.create;
+  ESMTPcap:=TStringList.create;
   sock:=TTCPBlockSocket.create;
   sock.CreateSocket;
   timeout:=300000;
   SMTPhost:='localhost';
+  Username:='';
+  Password:='';
 end;
 
 {TSMTPSend.Destroy}
 Destructor TSMTPSend.Destroy;
 begin
   Sock.free;
+  ESMTPcap.free;
+  FullResult.free;
   inherited destroy;
 end;
 
+{TSMTPSend.EnhancedCode}
+procedure TSMTPSend.EnhancedCode (value:string);
+var
+  s,t:string;
+  e1,e2,e3:integer;
+begin
+  EnhCode1:=0;
+  EnhCode2:=0;
+  EnhCode3:=0;
+  s:=copy(value,5,length(value)-4);
+  t:=separateleft(s,'.');
+  s:=separateright(s,'.');
+  if t='' then exit;
+  if length(t)>1 then exit;
+  e1:=strtointdef(t,0);
+  if e1=0 then exit;
+  t:=separateleft(s,'.');
+  s:=separateright(s,'.');
+  if t='' then exit;
+  if length(t)>3 then exit;
+  e2:=strtointdef(t,0);
+  t:=separateleft(s,' ');
+  if t='' then exit;
+  if length(t)>3 then exit;
+  e3:=strtointdef(t,0);
+  EnhCode1:=e1;
+  EnhCode2:=e2;
+  EnhCode3:=e3;
+end;
+
 {TSMTPSend.ReadResult}
 function TSMTPSend.ReadResult:integer;
 var
   s:string;
 begin
   Result:=0;
-  s:=sock.recvstring(timeout);
+  FullResult.Clear;
-  ResultString:=s;
+  repeat
+    s:=sock.recvstring(timeout);
+    ResultString:=s;
+    FullResult.add(s);
+    if sock.LastError<>0 then
+      break;
+  until pos('-',s)<>4;
+  s:=FullResult[0];
   if Length(s)>=3 then Result:=Strtointdef(Copy(s,1,3),0);
-  while pos('-',s)=4 do
-    begin
-      s:=sock.recvstring(timeout);
-      if sock.LastError<>0 then
-        begin
-          Result:=0;
-          break;
-        end;
-    end;
   ResultCode:=Result;
+  EnhancedCode(s);
+end;
+
+{TSMTPSend.AuthLogin}
+function TSMTPSend.AuthLogin:Boolean;
+begin
+  Result:=false;
+  Sock.SendString('AUTH LOGIN'+CRLF);
+  if readresult<>334 then Exit;
+  Sock.SendString(Encodebase64(username)+CRLF);
+  if readresult<>334 then Exit;
+  Sock.SendString(Encodebase64(password)+CRLF);
+  if readresult<>235 then Exit;
+  Result:=True;
+end;
+
+{TSMTPSend.AuthCram}
+function TSMTPSend.AuthCram:Boolean;
+var
+  s,sm:string;
+  ipad,opad:string;
+  n,x:integer;
+begin
+  Result:=false;
+  Sock.SendString('AUTH CRAM-MD5'+CRLF);
+  if readresult<>334 then Exit;
+  s:=copy(ResultString,5,length(ResultString)-4);
+  s:=DecodeBase64(s);
+  s:=HMAC_MD5(s,password);
+  s:=Username+' '+strtohex(s);
+  Sock.SendString(Encodebase64(s)+CRLF);
+  if readresult<>235 then Exit;
+  Result:=True;
 end;
 
 {TSMTPSend.login}
 function TSMTPSend.login:Boolean;
+var
+  n:integer;
+  auths:string;
 begin
   Result:=False;
+  ESMTP:=true;
+  AuthDone:=false;
+  ESMTPcap.clear;
+  ESMTPSize:=false;
+  MaxSize:=0;
   sock.Connect(SMTPHost,'smtp');
   if sock.lasterror<>0 then Exit;
   if readresult<>220 then Exit;
-  Sock.SendString('HELO '+sock.LocalName+CRLF);
+  Sock.SendString('EHLO '+sock.LocalName+CRLF);
-  if readresult<>250 then Exit;
+  if readresult<>250 then
+    begin
+      ESMTP:=false;
+      Sock.SendString('HELO '+sock.LocalName+CRLF);
+      if readresult<>250 then Exit;
+    end;
   Result:=True;
+  if ESMTP then
+    begin
+      for n:=1 to FullResult.count-1 do
+        ESMTPcap.add(Copy(FullResult[n],5,length(Fullresult[n])-4));
+      if not ((Username='') and (Password='')) then
+        for n:=0 to ESMTPcap.count-1 do
+          begin
+            auths:=uppercase(ESMTPcap[n]);
+            if pos('AUTH ',auths)=1 then
+              begin
+                if pos('CRAM-MD5',auths)>0 then
+                  begin
+                    AuthDone:=AuthCram;
+                    break;
+                  end;
+                if pos('LOGIN',auths)>0 then
+                  begin
+                    AuthDone:=AuthLogin;
+                    break;
+                  end;
+              end;
+          end;
+      for n:=0 to ESMTPcap.count-1 do
+        if pos('SIZE',uppercase(ESMTPcap[n]))=1 then
+          begin
+            ESMTPsize:=true;
+            MaxSize:=StrToIntDef(copy(ESMTPcap[n],6,length(ESMTPcap[n])-5),0);
+            break;
+          end;
+    end;
 end;
 
 {TSMTPSend.logout}
@@ -136,10 +264,15 @@ end;
 
 
 {TSMTPSend.mailfrom}
-function TSMTPSend.mailfrom(Value:string):Boolean;
+function TSMTPSend.mailfrom(Value:string; size:integer):Boolean;
+var
+  s:string;
 begin
   Result:=false;
-  Sock.SendString('MAIL FROM:<'+Value+'>'+CRLF);
+  s:='MAIL FROM:<'+Value+'>';
+  if ESMTPsize and (size>0)
+    then s:=s+' SIZE='+IntToStr(size);
+  Sock.SendString(s+CRLF);
   if readresult<>250 then Exit;
   Result:=True;
 end;
@@ -174,18 +307,105 @@ begin
   Result:=True;
 end;
 
+{TSMTPSend.etrn}
+function TSMTPSend.etrn(Value:string):Boolean;
+begin
+  Result:=false;
+  Sock.SendString('ETRN '+Value+CRLF);
+  if (readresult<250) or (readresult>259) then Exit;
+  Result:=True;
+end;
+
+{TSMTPSend.verify}
+function TSMTPSend.verify(Value:string):Boolean;
+begin
+  Result:=false;
+  Sock.SendString('VRFY '+Value+CRLF);
+  if (readresult<250) or (readresult>259) then Exit;
+  Result:=True;
+end;
+
+{TSMTPSend.EnhCodeString}
+function TSMTPSend.EnhCodeString:string;
+var
+  s,t:string;
+begin
+  s:=inttostr(EnhCode2)+'.'+inttostr(EnhCode3);
+  t:='';
+  if s='0.0' then t:='Other undefined Status';
+  if s='1.0' then t:='Other address status';
+  if s='1.1' then t:='Bad destination mailbox address';
+  if s='1.2' then t:='Bad destination system address';
+  if s='1.3' then t:='Bad destination mailbox address syntax';
+  if s='1.4' then t:='Destination mailbox address ambiguous';
+  if s='1.5' then t:='Destination mailbox address valid';
+  if s='1.6' then t:='Mailbox has moved';
+  if s='1.7' then t:='Bad sender''s mailbox address syntax';
+  if s='1.8' then t:='Bad sender''s system address';
+  if s='2.0' then t:='Other or undefined mailbox status';
+  if s='2.1' then t:='Mailbox disabled, not accepting messages';
+  if s='2.2' then t:='Mailbox full';
+  if s='2.3' then t:='Message length exceeds administrative limit';
+  if s='2.4' then t:='Mailing list expansion problem';
+  if s='3.0' then t:='Other or undefined mail system status';
+  if s='3.1' then t:='Mail system full';
+  if s='3.2' then t:='System not accepting network messages';
+  if s='3.3' then t:='System not capable of selected features';
+  if s='3.4' then t:='Message too big for system';
+  if s='3.5' then t:='System incorrectly configured';
+  if s='4.0' then t:='Other or undefined network or routing status';
+  if s='4.1' then t:='No answer from host';
+  if s='4.2' then t:='Bad connection';
+  if s='4.3' then t:='Routing server failure';
+  if s='4.4' then t:='Unable to route';
+  if s='4.5' then t:='Network congestion';
+  if s='4.6' then t:='Routing loop detected';
+  if s='4.7' then t:='Delivery time expired';
+  if s='5.0' then t:='Other or undefined protocol status';
+  if s='5.1' then t:='Invalid command';
+  if s='5.2' then t:='Syntax error';
+  if s='5.3' then t:='Too many recipients';
+  if s='5.4' then t:='Invalid command arguments';
+  if s='5.5' then t:='Wrong protocol version';
+  if s='6.0' then t:='Other or undefined media error';
+  if s='6.1' then t:='Media not supported';
+  if s='6.2' then t:='Conversion required and prohibited';
+  if s='6.3' then t:='Conversion required but not supported';
+  if s='6.4' then t:='Conversion with loss performed';
+  if s='6.5' then t:='Conversion failed';
+  if s='7.0' then t:='Other or undefined security status';
+  if s='7.1' then t:='Delivery not authorized, message refused';
+  if s='7.2' then t:='Mailing list expansion prohibited';
+  if s='7.3' then t:='Security conversion required but not possible';
+  if s='7.4' then t:='Security features not supported';
+  if s='7.5' then t:='Cryptographic failure';
+  if s='7.6' then t:='Cryptographic algorithm not supported';
+  if s='7.7' then t:='Message integrity failure';
+  s:='???-';
+  if EnhCode1=2 then s:='Success-';
+  if EnhCode1=4 then s:='Persistent Transient Failure-';
+  if EnhCode1=5 then s:='Permanent Failure-';
+  result:=s+t;
+end;
+
+
 {==============================================================================}
 
-function SendtoRaw (mailfrom,mailto,SMTPHost:string;maildata:TStrings):Boolean;
+function SendtoRaw (mailfrom,mailto,SMTPHost:string;maildata:TStrings;
+  Username,Password:string):Boolean;
 var
   SMTP:TSMTPSend;
+  size:integer;
 begin
   Result:=False;
   SMTP:=TSMTPSend.Create;
   try
     SMTP.SMTPHost:=SMTPHost;
+    SMTP.Username:=Username;
+    SMTP.Password:=Password;
     if not SMTP.login then Exit;
-    if not SMTP.mailfrom(mailfrom) then Exit;
+    size:=length(maildata.text);
+    if not SMTP.mailfrom(mailfrom,size) then Exit;
     if not SMTP.mailto(mailto) then Exit;
     if not SMTP.maildata(Maildata) then Exit;
     SMTP.logout;
@@ -195,7 +415,8 @@ begin
   end;
 end;
 
-function Sendto (mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings):Boolean;
+function SendtoEx (mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings;
+  Username,Password:string):Boolean;
 var
   t:TStrings;
 begin
@@ -209,11 +430,15 @@ begin
     t.Insert(0,'date: '+Rfc822DateTime(now));
     t.Insert(0,'to: '+mailto);
     t.Insert(0,'from: '+mailfrom);
-    result:=SendToRaw(mailfrom,mailto,SMTPHost,t);
+    result:=SendToRaw(mailfrom,mailto,SMTPHost,t,Username,Password);
   finally
     t.Free;
   end;
 end;
 
+function Sendto (mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings):Boolean;
+begin
+  result:=SendToEx(mailfrom,mailto,subject,SMTPHost,maildata,'','');
+end;
 
 end.

synacode.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 001.002.000 |
+| Project : Delphree - Synapse                                   | 001.003.000 |
 |==============================================================================|
 | Content: Coding and decoding support                                         |
 |==============================================================================|
@@ -14,7 +14,7 @@
 | The Original Code is Synapse Delphi Library.                                 |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2000.                     |
+| Portions created by Lukas Gebauer are Copyright (c)2000, 2001.               |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 | Contributor(s):                                                              |
@@ -133,6 +133,7 @@ function Crc32(value:string):integer;
 function UpdateCrc16(value:byte;crc16:word):word;
 function Crc16(value:string):word;
 function MD5(value:string):string;
+function HMAC_MD5(text,key:string):string;
 
 implementation
 
@@ -557,6 +558,37 @@ begin
   result:=MD5Final(MD5Context);
 end;
 
+{==============================================================================}
+{HMAC_MD5}
+function HMAC_MD5(text,key:string):string;
+var
+  ipad,opad,s:string;
+  n:integer;
+  MD5Context : TMD5Ctx;
+begin
+  if length(key)>64 then
+    key:=md5(key);
+  ipad:='';
+  for n:=1 to 64 do
+    ipad:=ipad+#$36;
+  opad:='';
+  for n:=1 to 64 do
+    opad:=opad+#$5c;
+  for n:=1 to length(key) do
+    begin
+      ipad[n]:=char(byte(ipad[n]) xor byte(key[n]));
+      opad[n]:=char(byte(opad[n]) xor byte(key[n]));
+    end;
+  MD5Init(MD5Context);
+  MD5Update(MD5Context,ipad);
+  MD5Update(MD5Context,text);
+  s:=MD5Final(MD5Context);
+  MD5Init(MD5Context);
+  MD5Update(MD5Context,opad);
+  MD5Update(MD5Context,s);
+  result:=MD5Final(MD5Context);
+end;
+
 {==============================================================================}
 
 begin

synautil.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
-| Project : Delphree - Synapse                                   | 001.006.000 |
+| Project : Delphree - Synapse                                   | 001.007.000 |
 |==============================================================================|
 | Content: support procedures and functions                                    |
 |==============================================================================|
@@ -14,7 +14,7 @@
 | The Original Code is Synapse Delphi Library.                                 |
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c) 1999, 2000.              |
+| Portions created by Lukas Gebauer are Copyright (c) 1999,2000,2001.          |
 | Portions created by Hernan Sanchez are Copyright (c) 2000.                   |
 | All Rights Reserved.                                                         |
 |==============================================================================|
@@ -47,6 +47,7 @@ function GetEmailDesc(value:string):string;
 function StrToHex(value:string):string;
 function IntToBin(value:integer;digits:byte):string;
 function BinToInt(value:string):integer;
+procedure ParseURL(URL:string; var Prot,User,Pass,Host,Port,Path,Para:string);
 
 implementation
 
@@ -335,6 +336,70 @@ begin
     end;
 end;
 
+{==============================================================================}
+{ParseURL}
+procedure ParseURL(URL:string; var Prot,User,Pass,Host,Port,Path,Para:string);
+var
+  x:integer;
+  sURL:string;
+  s:string;
+  s1,s2:string;
+begin
+  prot:='http';
+  user:='';
+  pass:='';
+  port:='80';
+  para:='';
+
+  x:=pos('://',URL);
+  if x>0 then
+    begin
+      prot:=separateleft(URL,'://');
+      sURL:=separateright(URL,'://');
+    end
+    else sURL:=URL;
+  x:=pos('@',sURL);
+  if x>0 then
+    begin
+      s:=separateleft(sURL,'@');
+      sURL:=separateright(sURL,'@');
+      x:=pos(':',s);
+      if x>0 then
+        begin
+          user:=separateleft(s,':');
+          pass:=separateright(s,':');
+        end
+        else user:=s;
+    end;
+  x:=pos('/',sURL);
+  if x>0 then
+    begin
+      s1:=separateleft(sURL,'/');
+      s2:=separateright(sURL,'/');
+    end
+    else
+    begin
+      s1:=sURL;
+      s2:='';
+    end;
+  x:=pos(':',s1);
+  if x>0 then
+    begin
+      host:=separateleft(s1,':');
+      port:=separateright(s1,':');
+    end
+    else host:=s1;
+  x:=pos('?',s2);
+  if x>0 then
+    begin
+      path:='/'+separateleft(s2,'?');
+      para:=separateright(s2,'?');
+    end
+    else path:='/'+s2;
+  if host=''
+    then host:='localhost';
+end;
+
 {==============================================================================}
 
 end.