unit URLDown;
(*
* *****************************************************************************
* *************************** Unidad URLDown *******************************
* Esta unidad contiene la función DownloadFile, una función que
* descarga un archivo desde una dirección URL. Esta función se ejecuta en
* otro thread, por lo que no "congela" la aplicación ni causa inastabilidad.
* Además, cuenta con 3 eventos: OnStartDownload, OnProgress y OnFinishDownload.
*
* Autor: Khronos
* Email: khronos14@hotmail.com
* Blog: khronos14.blogspot.com
*******************************************************************************
*)
interface
uses SysUtils, Classes, Windows, WinSock;
{$DEFINE OBJECT_FUNCTIONS}
(*
Si borras la definición OBJECT_FUNCTIONS, los eventos
de la función DownloadFile no serán de tipo objeto.
Para emplear esta función en modo consola o sin clases,
comenta esta definición.
*)
const
SZBUFFER_SIZE = 2048; //Este es el tamaño del buffer de descarga
URLDOWN_OK = 0;
URLDOWN_INVALID_HOST = 1;
URLDOWN_CONNECT_ERROR = 2;
URLDOWN_DOWNLOAD_ERROR = 3;
URLDOWN_UNKNOWN_ERROR = $FD;
type
TOnStartDownload = procedure(FileSize: int64) {$IFDEF OBJECT_FUNCTIONS}of object{$ENDIF};
TOnProgress = procedure(Progress: int64) {$IFDEF OBJECT_FUNCTIONS}of object{$ENDIF};
TOnFinishDownload = procedure(ErrorCode: byte) {$IFDEF OBJECT_FUNCTIONS}of object{$ENDIF};
TDownloadVars = record
URL: AnsiString;
FileName: String;
OnStartDownload: TOnStartDownload;
OnProgress: TOnProgress;
OnFinishDownload: TOnFinishDownload;
end;
PDownloadVars = ^TDownloadVars;
procedure DownloadFile(URL: AnsiString; FileName: String; StartDownload: TOnStartDownload;
Progress: TOnProgress; FinishDownload: TOnFinishDownload); stdcall;
implementation
function GetDomainName(const URL: AnsiString): AnsiString;
var
P1: integer;
begin
P1:= Pos('http://', URL);
if P1 > 0 then
begin
result:= Copy(URL, P1 + 7, Length(URL) - P1 - 6);
P1:= Pos('/', result);
if P1 > 0 then
result:= Copy(result, 0, P1 - 1);
end else
begin
P1:= Pos('/', URL);
if P1 > 0 then
result:= Copy(URL, 0, P1 - 1)
else result:= URL;
end;
end;
function GetFileWeb(const URL: AnsiString): AnsiString;
var
P1: integer;
begin
P1:= Pos('http://', URL);
if P1 > 0 then
begin
result:= Copy(URL, P1 + 7, Length(URL) - P1 - 6);
P1:= Pos('/', result);
if P1 > 0 then
result:= Copy(result, P1, Length(result) - P1 + 1);
end else
begin
P1:= Pos('/', URL);
if P1 > 0 then
result:= Copy(URL, P1, Length(URL) - P1 + 1)
else result:= URL;
end;
if result = GetDomainName(URL) then
result:= '/';
end;
procedure CleanHttp(var Mem: TMemoryStream);
var
i: integer;
Separator: array [0..3] of AnsiChar;
Mem2: TMemoryStream;
begin
if Assigned(Mem) then
begin
for i := 0 to Mem.Size - 1 do
begin
Mem.Seek(i, 0);
Mem.Read(Separator, 4);
if (Separator[0] = #13) and (Separator[1] = #10) and (Separator[2] = #13)
and (Separator[3] = #10) then
begin
Mem2:= TMemoryStream.Create;
Mem.Seek(i + 4, 0);
Mem2.CopyFrom(Mem, Mem.Size - I - 4);
Mem:= Mem2;
break;
end;
end;
end;
end;
function SendQuery(Socket: TSocket; RHost: sockaddr_in; Query: AnsiString): boolean;
begin
if Connect(Socket, PSockAddrIn(@RHost)^, Sizeof(RHost)) = 0 then
begin
send(Socket, Pointer(Query)^, Length(Query), 0);
result:= true;
end else
result:= false;
end;
function CreateQuery(URL: AnsiString): AnsiString;
begin
result:= 'GET ' + GetFileWeb(URL) + ' HTTP/1.0' + #13#10 +
'Host: ' + GetDomainName(URL) + #13#10 +
'User-Agent: Khronos' + #13#10#13#10;
end;
function GetContentLength(szBuff: AnsiString; Size: Cardinal): int64;
var
dwStart, dwEnd: integer;
ContentLength: AnsiString;
begin
Result:= 0;
dwStart:= Pos('Content-Length: ', szBuff);
if dwStart <> 0 then
begin
dwStart:= dwStart + StrLen('Content-Length: ');
dwEnd:= dwStart;
repeat
Inc(dwEnd);
until (szBuff[dwEnd] = #0) or (szBuff[dwEnd] = #13) or (dwEnd = Size);
ContentLength:= Copy(szBuff, dwStart, dwEnd - dwStart);
if TryStrToInt64(ContentLength, Result) = false then
result:= -1;
end;
dwStart:= Pos(#13#10#13#10, szBuff);
end;
function InitializeWinSock(Host: AnsiString; var Socket: TSocket; var RHost: sockaddr_in): boolean;
var
WSA: TWSAData;
Addr: u_long;
Hostent: PHostent;
Ip: ^Integer;
begin
If WSAStartup(MakeWord(2,2), WSA) = 0 then
begin
Socket:= WinSock.SOCKET(AF_INET, SOCK_STREAM, 0);
if Socket <> INVALID_SOCKET then
begin
Hostent:= GetHostByName(PAnsiChar(GetDomainName(Host)));
if Hostent <> nil then
begin
Ip:= @Hostent.h_addr_list^[0];
RHost.sin_family:= AF_INET;
RHost.sin_port:= htons(80);
RHost.sin_addr.S_addr:= ip^;
result:= true;
end;
end;
end else
result:= false;
end;
function ProcessDownload(Socket: TSocket; FileName: WideString; StartDownload: TOnStartDownload;
Progress: TOnProgress; FinishDownload: TOnFinishDownload): boolean;
var
szBuffer: array [0..SZBUFFER_SIZE] of AnsiChar;
Stream: TMemoryStream;
ContentLength, ReturnCode: integer;
begin
result:= false;
try
Stream:= TMemoryStream.Create;
ContentLength:= 0;
repeat
FillChar(szBuffer, SZBUFFER_SIZE, 0);
ReturnCode:= recv(Socket, szBuffer, SZBUFFER_SIZE, 0);
if (ContentLength = 0) and (ReturnCode > 0) then
begin
ContentLength:= GetContentLength(szBuffer, ReturnCode);
if Assigned(StartDownload) then
StartDownload(ContentLength);
end;
if ReturnCode > 0 then
begin
Stream.Write(szBuffer, ReturnCode);
if Assigned(Progress) then
Progress(Stream.Position);
end;
until ReturnCode <= 0;
if Stream.Size > 0 then
begin
CleanHttp(Stream);
Stream.SaveToFile(FileName);
if Assigned(FinishDownload) then
FinishDownload(URLDOWN_OK);
result:= true;
end;
finally
Stream.Free;
end;
end;
procedure Download(P: Pointer);
var
Query: AnsiString;
Socket: TSocket;
RHost: sockaddr_in;
begin
try
if InitializeWinSock(TDownloadVars(P^).URL, Socket, RHost) then
begin
Query:= CreateQuery(TDownloadVars(P^).URL);
if SendQuery(Socket, RHost, Query) then
begin
If ProcessDownload(Socket, TDownloadVars(P^).FileName, TDownloadVars(P^).OnStartDownload,
TDownloadVars(P^).OnProgress, TDownloadVars(P^).OnFinishDownload) = false then
if Assigned(TDownloadVars(P^).OnFinishDownload) then
TDownloadVars(P^).OnFinishDownload(URLDOWN_DOWNLOAD_ERROR);
ShutDown(Socket, SD_BOTH);
CloseSocket(Socket);
end else
if Assigned(TDownloadVars(P^).OnFinishDownload) then
TDownloadVars(P^).OnFinishDownload(URLDOWN_CONNECT_ERROR);
end else
if Assigned(TDownloadVars(P^).OnFinishDownload) then
TDownloadVars(P^).OnFinishDownload(URLDOWN_INVALID_HOST);
WSACleanUp();
Dispose(PDownloadVars(P));
Except on Exception do
begin
if Assigned(TDownloadVars(P^).OnFinishDownload) then
TDownloadVars(P^).OnFinishDownload(URLDOWN_UNKNOWN_ERROR);
end;
end;
end;
procedure DownloadFile(URL: AnsiString; FileName: String; StartDownload: TOnStartDownload;
Progress: TOnProgress; FinishDownload: TOnFinishDownload);
var
DownloadVars: ^TDownloadVars;
begin
New(DownloadVars);
DownloadVars^.URL:= URL;
DownloadVars^.FileName:= FileName;
DownloadVars^.OnStartDownload:= StartDownload;
DownloadVars^.OnProgress:= Progress;
DownloadVars^.OnFinishDownload:= FinishDownload;
BeginThread(nil, 0, @Download, DownloadVars, 0, PDWORD(0)^);
end;
end.