Programowanie w języku Delphi » Gotowce

Równoległe ściąganie plików

  • 2008-11-16 10:15
  • 4 komentarze
  • 574 odsłony
  • Oceń ten tekst jako pierwszy
Poniższy kod ściąga równolegle w pięciu (MAX_THREADS) wątkach podane strony internetowe.
Jak uruchomić? Stwórz nowy projekt, do kodu źródłowego Unit1 wklej kod z dołu artykułu; usuń z wklejonego tekstu linijki 12 i 13:
    ListBox1: TListBox;
    Memo1: TMemo;

a następnie wrzuć na formę listboksa (ListBox1) i memo (Memo1). Ctrl+F9 i zobaczysz jak równolegle ściąga się kilka stron z 4programmers (a jak masz pecha, to zobaczysz listę błędów ;-) ).

Podany kod został napisany i przetestowany pod Delphi 7.

unit Unit1;
 
interface
 
uses
  Windows, Messages, Classes, Forms, WinInet, StdCtrls, Controls;
 
const
  MAX_THREADS = 5;
 
type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
  private
    procedure DownloadComplete(const url: string; const content: string);
  end;
 
  TOnDownloadComplete = procedure(const url: string; const content: string) of object;
  TOnProgress = procedure() of object;
 
 
  TDownloadThread = class(TThread)
    private
      FUrl: string;
      FContent: string;
      FOnDownloadComplete: TOnDownloadComplete;
      FOnProgress: TOnProgress;
    protected
      procedure Execute; override;
    public
      constructor Create(url:string; OnDownloadComplete: TOnDownloadComplete; OnProgress: TOnProgress);
      procedure storeResult();
  end;
 
  TBossThread = class(TThread)
    private
      FUrlList: array of string;
      FOnDownloadComplete: TOnDownloadComplete;
      FOnProgress: TOnProgress;
    protected
      procedure Execute; override;
    public
      constructor Create(UrlList: array of string; OnDownloadComplete: TOnDownloadComplete; OnProgress: TOnProgress);
  end;
 
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
 
 
var
  threadCount: integer;
  cs: TRTLCriticalSection;
 
 
  function IntToStr(Value: Integer): string;
  begin
    str(value, result);
  end;
 
  function GetInetFile (const fileURL: String): string;
  var
    hSession, hURL: HInternet;
    output: TMemoryStream;
    buffer: array[1..4096] of char;
    bufferLen: DWORD;
  begin
    output := TMemoryStream.Create();
    result := '';
    hSession := InternetOpen('Mozilla/4.0(compatible; Kopiczek 3.0; WyderOS 1.1; pl)', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
    try
      hURL := InternetOpenURL(hSession, PChar(fileURL), nil, 0, 0, 0);
      try
        repeat
          InternetReadFile(hURL, @buffer, sizeOf(buffer), bufferLen);
          if (bufferLen > 0) then output.write(buffer, bufferLen);
         until bufferLen = 0;
      finally
        InternetCloseHandle(hURL);
      end;
    finally
      InternetCloseHandle(hSession);
    end;
 
    setLength(result, output.Size);
    output.Seek(0, soFromBeginning);
    move(output.Memory^, result[1], output.Size);
//    output.read(result[1], output.Size);
  end;
 
 
 
  constructor TDownloadThread.Create(url:string; OnDownloadComplete: TOnDownloadComplete; OnProgress: TOnProgress);
  begin
    inherited Create(false);
    FreeOnTerminate := true;
    FUrl := url;
    FOnDownloadComplete := OnDownloadComplete;
    FOnProgress := OnProgress;
 
    EnterCriticalSection(cs);
    inc(threadCount);
    LeaveCriticalSection(cs);
  end;
 
 
  procedure TDownloadThread.Execute();
  begin
    FContent := getInetFile(FUrl);
    Synchronize(storeResult);
 
    enterCriticalSection(cs);
    dec(threadCount);
    leaveCriticalSection(cs);
  end;
 
 
 
 
  procedure TDownloadThread.storeResult();
  begin
    if (Assigned(FOnDownloadComplete)) then FOnDownloadComplete(FUrl, FContent);
  end;
 
 
  constructor TBossThread.Create(UrlList: array of string; OnDownloadComplete: TOnDownloadComplete; OnProgress: TOnProgress);
  var
    i : integer;
  begin
    inherited Create(false);
    FreeOnTerminate := true;
    FOnDownloadComplete := OnDownloadComplete;
    FOnProgress := OnProgress;
 
    SetLength(FUrlList, Length(UrlList));
    for i := 0 to Length(UrlList)-1 do FUrlList[i] := UrlList[i];
  end;
 
 
  procedure TBossThread.Execute();
  var
    cursor: integer;
  begin
    threadCount := 0;
 
    cursor := 0;
 
    InitializeCriticalSection(cs);
 
    while (cursor < length(FUrlList)) do
    begin
 
      EnterCriticalSection(cs);
      if (threadCount >= MAX_THREADS) then
      begin
        LeaveCriticalSection(cs);
        sleep(10);
        continue;
      end;
      LeaveCriticalSection(cs);
 
      TDownloadThread.Create(FUrlList[cursor], FOnDownloadComplete, FOnProgress);
      inc(cursor);
    end;
  end;
 
 
 
 
  procedure TForm1.DownloadComplete(const url: string; const content: string);
  var
    s : string;
  begin
    s := content;
    Form1.ListBox1.Items.AddObject(url, TObject(s));
  end;
 
 
  procedure TForm1.FormCreate(Sender: TObject);
  var
    i: integer;
    urls: array[0..10] of string
    { = (
      'http://4programmers.net',
      'http://forum.4programmers.net',
      'http://forum.4programmers.net/viewtopic.php?p=495902',
    )};
  begin
    for i := 0 to length(urls)-1 do urls[i] := 'http://forum.4programmers.net/viewtopic.php?p=' + inttostr(495902-i);
    TBossThread.Create(urls, DownloadComplete, nil);
  end;
 
procedure TForm1.ListBox1Click(Sender: TObject);
begin
  Memo1.Text := string(ListBox1.Items.Objects[ListBox1.ItemIndex]);
end;
 
end.

4 komentarze

ŁF 2008-12-04 23:04

dziecko, idź się poprodukować we własnych gotowcach

manfredek 2008-11-16 10:13

Hehe, teraz UA wygląda prawdziwiej, a nadal jest kopiczkowato-wyderosowy ;P

ŁF 2008-11-12 19:32

kopiczek's not dead!