inetutils.pas

由delphi实现的bt下载器示例程序

unit InetUtils;

//{$DEFINE DEBUGMSG}

interface

uses
  Windows, SysUtils, Classes, Messages, WinInet, ThreadTimer, SortLists, DelayLists{$IFDEF DEBUGMSG}, DebugUnit{$ENDIF};

const
  INET_BLOCK              =  2048;
  INET_SUCCESS            =     0;

type
  TInetThread = class;
  TInetJob = class;
  TInetCallback = procedure (Sender: TInetJob; Code: Integer) of object;  // 0: success  <0: errcode

  TInetJob = class
  private
    Handle: HINTERNET;
    Owner: TInetThread;
    Callback: TInetCallback;
    TimeOut: Cardinal;
    Timer: Cardinal;
    LastTick: Cardinal;
    procedure DoTimer(WParam, LParam: Integer);
  public
    Url: string;
    ToFile: string;
    Buffer: string;
    StartOffset: Int64;
    TotalLen: Integer;
    FinishedLen: Integer;
    UsrData: Pointer;
    Deleted: Boolean;
    Working: Boolean;
    procedure Start;
    procedure Stop;
  end;

  TInetThread = class(TThread)
  protected
    procedure Execute; override;
    function CompareJob(Key, Item: Pointer): Integer;
    procedure DeleteJob(AJob: Pointer);
  public
    Event: Cardinal;
    Jobs: TLockList;
    CurrJob: TInetJob;
    Busy: Boolean;
    constructor Create;
    procedure Stop;
  end;

function RequestFile(AUrl, AFile: string; Notification: TInetCallback; AData: Pointer;
    FromOffset: Int64 = 0; Len: Integer = -1; ATimeOut: Cardinal = INFINITE): TInetJob;
function RequestBuf(AUrl: string; Notification: TInetCallback; AData: Pointer;
    ATimeOut: Cardinal = INFINITE): TInetJob;
procedure DropRequest(ARequest: TInetJob);

procedure InitWorkerThreads(Cnt: Integer);

implementation

var
  GlobalSyncInet: HINTERNET;
  InetThrds: TThreadList;

procedure DispatchJob(AJob: TInetJob);
var
  i, n: Integer;
  thrd: TInetThread;
begin
  n := MaxInt;
  thrd := nil;
  with InetThrds.LockList do
  try
    for i := 0 to count - 1 do
      with TInetThread(Items[i]) do
        if (Jobs.CountL < n) then
        begin
          n := Jobs.CountL;
          Thrd := TInetThread(Items[i]);
        end;
  finally
    InetThrds.UnlockList;
  end;
  if thrd <> nil then
  begin
    AJob.Owner := thrd;
    thrd.Jobs.InsertItem(pointer(ajob), pointer(ajob));
    setevent(thrd.Event);
  end;
end;

procedure InitInet;
begin
  InetThrds := TThreadList.Create;
  InetThrds.Add(pointer(TInetThread.Create));
  GlobalSyncInet := InternetOpen('Microsoft Internet Explorer',
      INTERNET_OPEN_TYPE_PRECONFIG,
      nil,
      nil,
      0);
end;

procedure FinalInet;
var
  i: Integer;
begin
  with InetThrds.LockList do
  try
    for i := 0 to count - 1 do
      TInetThread(Items[i]).Stop;
  finally
    InetThrds.UnlockList;
    InternetCloseHandle(GlobalSyncInet);
  end;
  InetThrds.Free;
end;

procedure InitWorkerThreads(Cnt: Integer);
var
  i, j: Integer;
  Lst: TList;
begin
  Lst := TList.Create;
  with InetThrds.LockList do
  try
    if Count < Cnt then
      while Count < Cnt do
        add(pointer(TInetThread.Create))
    else if Count > Cnt then
      while Count > Cnt do
      begin
        Lst.Add(Items[Count - 1]);
        Delete(count - 1);
      end;
  finally
    InetThrds.UnlockList;
  end;
  if Lst.Count > 0 then
    for i := Lst.Count - 1 downto 0 do
      with TInetThread(Lst.Items[i]) do
      begin
        Jobs.Lock;
        suspend;
        for j := 0 to Jobs.Count - 1 do
          DispatchJob(TInetJob(Jobs.Items[j]));
        Jobs.clear;
        Jobs.unlock;
        terminate;
        setevent(event);
        resume;
      end;
  Lst.Free;
end;

function RequestFile(AUrl, AFile: string; Notification: TInetCallback; AData: Pointer;
    FromOffset: Int64 = 0; Len: Integer = -1; ATimeOut: Cardinal = INFINITE): TInetJob;
begin
  result := TInetJob.Create;
  with Result do
  begin
    Url := AUrl;
    ToFile := AFile;
    Callback := Notification;
    UsrData := AData;
    StartOffset := FromOffset;
    TotalLen := Len;
    TimeOut := ATimeOut;
  end;
  dispatchjob(result);
end;

function RequestBuf(AUrl: string; Notification: TInetCallback; AData: Pointer;
    ATimeOut: Cardinal = INFINITE): TInetJob;
begin
  result := TInetJob.Create;
  with Result do
  begin
    Url := AUrl;
    Callback := Notification;
    UsrData := AData;
    TotalLen := -1;
    TimeOut := ATimeOut;
  end;
  dispatchjob(result);
end;

procedure DropRequest(ARequest: TInetJob);
begin
  try
    if ARequest.Owner <> nil then
    begin
      ARequest.Owner.Jobs.DeleteItem(pointer(ARequest));
      if ARequest.Owner.Busy and (ARequest.Owner.CurrJob = ARequest) then
        ARequest.Stop;
    end;
  except
  end;
end;

{ TInetThread }

constructor TInetThread.Create;
begin
  event := createevent(nil, false, false, nil);
  Jobs := TLockList.Create;
  Jobs.CompareKey := CompareJob;
  Jobs.ReleaseData := DeleteJob;
  inherited Create(false);
end;

function TInetThread.CompareJob(Key, Item: Pointer): Integer;
begin
  result := Integer(key) - Integer(Item);
end;

procedure TInetThread.Execute;
var
  n: Integer;
begin
  FreeOnTerminate := True;
  while not terminated do
  try
    waitforsingleobject(event, INFINITE);
    if terminated then break;
    while not terminated do
    begin
      Jobs.Lock;
      try
        if Jobs.Count = 0 then break;
        //n := random(jobs.Count);
        n := 0;
        CurrJob := TInetJob(jobs.Items[n]);
        jobs.Delete(n);
        Busy := true;
      finally
        Jobs.Unlock;
      end;
      if Busy then
      begin
        CurrJob.Start;
        Busy := false;
        CurrJob := nil;
      end;
    end;
  except
  {$IFDEF DEBUGMSG}
    on e: exception do
      LogDbgMsg('TInetThread.Execute error: '+e.message);
  {$ENDIF}
  end;
  try
    with InetThrds.LockList do
    try
      for n := 0 to count - 1 do
        if Items[n] = pointer(self) then
        begin
          Delete(n);
          break;
        end;
    finally
      InetThrds.UnlockList;
    end;
  except
  end;
  closehandle(Event);
  Jobs.Free;
end;

procedure TInetThread.Stop;
begin
  try
    Terminate;
    try
      if Busy then
        CurrJob.Stop;
    except
    end;
    SetEvent(Event);
  except
  {$IFDEF DEBUGMSG}
    on e: exception do
      LogDbgMsg('TInetThread.Stop error: '+e.message);
  {$ENDIF}
  end;
end;

procedure TInetThread.DeleteJob(AJob: Pointer);
var
  Job: TInetJob;
begin
  Job := TInetJob(AJob);
  delayrelease(job);
end;

{ TInetJob }

procedure TInetJob.Start;
var
  v, v1, v2: Cardinal;
  hd: string;
  fid, len, l: Integer;
  p:PChar;
begin
  try
    fid := -1;
    if tofile <> '' then
    begin
      if not fileexists(tofile) then
      begin
        fid := filecreate(tofile);
        fileclose(fid);
      end;
      fid := fileopen(tofile, fmOpenWrite or fmShareDenyNone);
      if fid < 0 then
      begin
        if assigned(callback) then
          callback(self, -getlasterror);
        delayrelease(self);
        exit;
      end;
    end;
    if startoffset > 0 then
    begin
      hd := 'Accept: */*'#13#10'Range: bytes='+inttostr(startoffset)+'-';
      if totallen > 0 then
        hd := hd + inttostr(totallen+startoffset);
    end
    else hd := 'Accept: */*'#13#10;
    try
      if not deleted then
      begin
      {$IFDEF DEBUGMSG}
        LogDbgMsg('Inet downloading: '+url);
      {$ENDIF}
        lasttick := gettickcount;
        if timeout <> INFINITE then
          registertimer(timer, 0, 0, timeout, dotimer, false, true);
        if not deleted then
        begin
          handle := internetopenurl(globalsyncinet, pchar(url), pchar(hd), cardinal(-1),
                         INTERNET_FLAG_DONT_CACHE or INTERNET_FLAG_RELOAD, 0);
          v1 := 4;
          v2 := 0;
          v := cardinal(-1);
          if assigned(handle) and HttpQueryInfo(handle, HTTP_QUERY_STATUS_CODE or
                             HTTP_QUERY_FLAG_NUMBER, @v, v1, v2)
                             and (v in [200, 206]) then
          begin
            if not httpqueryinfo(Handle, HTTP_QUERY_CONTENT_LENGTH or
                                     HTTP_QUERY_FLAG_NUMBER,
                                     @totallen,
                                     v1, v2) then
              totallen := -1;
            if fid < 0 then
              if totallen > 0 then
                setlength(buffer, totallen)
              else setlength(buffer, INET_BLOCK)
            else begin
              fileseek(fid, startoffset, 0);
              setlength(buffer, INET_BLOCK);
            end;
            p := pointer(buffer);
            len := length(buffer);
            repeat
              if internetreadfile(handle, p, INET_BLOCK, cardinal(l)) then
              begin
                lasttick := gettickcount;
                if l = 0 then
                  break
                else begin
                  inc(finishedlen, l);
                  if fid > 0 then
                    filewrite(fid, p^, l)
                  else begin
                    dec(len, l);
                    inc(p, l);
                    if totallen < 0 then
                    begin
                      l := (integer(p)+INET_BLOCK + INET_BLOCK - 1 - integer(buffer)) div INET_BLOCK * INET_BLOCK;
                      setlength(buffer, l);
                      p := @(buffer[finishedlen+1]);
                    end;
                  end;
                end
              end
              else begin
                if assigned(callback) then
                  callback(self, -getlasterror);
                exit;
              end;
            until len = 0;
            unregistertimer(timer);
            if fid > 0 then
            begin
              fileclose(fid);
              fid := -1;
            end;
            if assigned(callback) then
              callback(self, 0);
          end
          else if assigned(callback) then
            callback(self, -v);
        end;
      end;
    finally
    {$IFDEF DEBUGMSG}
      LogDbgMsg('Inet downloaded');
    {$ENDIF}
      if fid > 0 then fileclose(fid);
      stop;
      {if handle <> nil then
        internetclosehandle(handle);}
      delayrelease(self);
    end;
  except
  {$IFDEF DEBUGMSG}
    on e: exception do
      LogDbgMsg('TInetJob.Start error: '+e.message);
  {$ENDIF}
  end;
end;

procedure TInetJob.Stop;
var
  h: HINTERNET;
begin
  try
    unregistertimer(timer);
    deleted := true;
    if handle <> nil then
    begin
      h := Handle;
      handle := nil;
      internetclosehandle(h);
    end;
  except
  {$IFDEF DEBUGMSG}
    on e: exception do
      LogDbgMsg('TInetJob.Stop error: '+e.message);
  {$ENDIF}
  end;
end;

procedure TInetJob.DoTimer(WParam, LParam: Integer);
begin
  try
    if cardinal(gettickcount - lasttick) > timeout then
    begin
    {$IFDEF DEBUGMSG}
      LogDbgMsg('Inet timeout, closing');
    {$ENDIF}
      stop;
    end;
  except
  {$IFDEF DEBUGMSG}
    on e: exception do
      LogDbgMsg('TInetJob.DoTimer error: '+e.message);
  {$ENDIF}
  end;
end;

initialization
  InitInet;

finalization
  FinalInet;

end.