clmultidownloader.pas

Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码

{
  Clever Internet Suite Version 6.2
  Copyright (C) 1999 - 2006 Clever Components
  www.CleverComponents.com
}

unit clMultiDownLoader;

interface

{$I clVer.inc}

uses
  Classes, clWinInet, clDC, clDCUtils, clMultiDC, SyncObjs, clUriUtils;

type
  TclDownLoadItem = class;
  TclUrlList = class;

  TclGrabOption = (gaGrabAll, gaGrabImages, gaGrabData, gaGrabAudioVideo,
    gaMakeBrowsable, gaGrabFrames, gaReplaceExisting);
  TclGrabOptions = set of TclGrabOption;

  TclFileExistsAction = (faReplace, faRename, faSkip, faStop);

  TclOnMultiDataTextProceed = procedure (Sender: TObject; Item: TclDownLoadItem; Text: TStrings) of object;
  TclOnCanProcessUrl = procedure (Sender: TObject; Item: TclDownLoadItem;
    var CanProcess, Handled: Boolean) of object;
  TclOnExtractUrls = procedure (Sender: TObject; Item: TclDownLoadItem; AUrlList: TclUrlList;
    var Handled: Boolean) of object;
  TclOnFileExists = procedure (Sender: TObject; const AFileName: string; var ANewName: string;
    var Action: TclFileExistsAction) of object;

  TclCustomMultiDownLoaderControl = class;

  TclDownLoadItem = class(TclInternetItem)
  private
    FPreview: TStrings;
    FIsDownloadMode: Boolean;
    FIsDownloadProceed: Boolean;
    FDataAccessor: TCriticalSection;
    FAllowCompression: Boolean;
    FCompressedFile: string;
    FNestLevel: Integer;
    function GetDownLoader: TclCustomMultiDownLoaderControl;
    function CanSetFilePos(): Boolean;
    procedure StartDownload(AURLParser: TclUrlParser);
    function GetNormThreadCount(): Integer;
    function GetResourceInfoSize(): Integer;
    function CanDownload: Boolean;
    function ExtractFileName(const AContentDisposition: string): string;
    function NeedUncompress: Boolean;
  protected
    procedure DoDataTextProceed(Text: TStrings); virtual;
    function GetCorrectResourceTime: Boolean; virtual;
    function GetPreviewCharCount: Integer; virtual;
    function GetLocalFolder: string; virtual;
    function CanProcess: Boolean; override;
    procedure SetURL(const Value: string); override;
    function GetControl: TclCustomInternetControl; override;
    procedure InternalStart(AIsGetResourceInfo: Boolean); override;
    procedure AssignThreaderParams(AThreader: TclCustomThreader); override;
    function CreateThreader(ADataStream: TStream; AIsGetResourceInfo: Boolean): TclCustomThreader; override;
    function GetDataStream: TStream; override;
    procedure ProcessCompleted(AThreader: TclCustomThreader); override;
    procedure LastStatusChanged(Status: TclProcessStatus); override;
    procedure DataTextProceed; virtual;
    procedure CommitWork; override;
    procedure DoGetResourceInfo(AResourceInfo: TclResourceInfo); override;
    procedure DoDestroy; override;
  public
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
    property Preview: TStrings read FPreview;
    property NestLevel: Integer read FNestLevel;
  published
    property ThreadCount default cDefaultThreadCount;
    property KeepConnection;
    property URL;
    property LocalFile;
    property UserName;
    property Password;
    property Priority;
    property CertificateFlags;
    property UseHttpRequest;
    property HttpRequest;
    property AllowCompression: Boolean read FAllowCompression write FAllowCompression default True;
    property Port;
  end;

  TclDownLoadList = class(TOwnedCollection)
  private
    function GetItem(Index: Integer): TclDownLoadItem;
    procedure SetItem(Index: Integer; const Value: TclDownLoadItem);
    function GetDownLoader: TclCustomMultiDownLoaderControl;
  public
    function Add: TclDownLoadItem;
    property Items[Index: Integer]: TclDownLoadItem read GetItem write SetItem; default;
    property DownLoader: TclCustomMultiDownLoaderControl read GetDownLoader;
  end;

  TclUrlItem = class(TCollectionItem)
  private
    FInnerTextPos: Integer;
    FURL: string;
  public
    procedure Assign(Source: TPersistent); override;
    property URL: string read FURL write FURL;
    property InnerTextPos: Integer read FInnerTextPos write FInnerTextPos;
  end;

  TclUrlList = class(TCollection)
  private
    function GetItem(Index: Integer): TclUrlItem;
    procedure SetItem(Index: Integer; const Value: TclUrlItem);
  public
    function Add(const AUrl: string; AInnerTextPos: Integer): TclUrlItem;
    property Items[Index: Integer]: TclUrlItem read GetItem write SetItem; default;
  end;

  TclCustomMultiDownLoaderControl = class(TclMultiInternetControl)
  private
    FDownLoadList: TclDownLoadList;
    FCorrectResourceTime: Boolean;
    FPreviewCharCount: Integer;
    FLocalFolder: string;
    FIsGrabbing: Boolean;
    FRootUrl: string;
    FMaxNestLevel: Integer;
    FGrabOptions: TclGrabOptions;
    FAllowedUrls: TStrings;
    FOnDataTextProceed: TclOnMultiDataTextProceed;
    FOnCanProcessGrabbedUrl: TclOnCanProcessUrl;
    FOnExtractUrls: TclOnExtractUrls;
    FOnProcessNextUrl: TclOnCanProcessUrl;
    FOnFileExists: TclOnFileExists;
    procedure SetLocalFolder(const Value: string);
    procedure SetPreviewCharCount(const Value: Integer);
    procedure SetDownLoadList(const Value: TclDownLoadList);
    procedure AssignSaveToFiles;
    function CanProcessGrabbedUrl(Item: TclDownLoadItem): Boolean;
    procedure ExtractUrls(Item: TclDownLoadItem; AHtml: TStrings; AUrlList: TclUrlList);
    function ProcessNextUrl(const AUrl: string; APrevItem: TclDownLoadItem): string;
    function GetFullFileNameByUrl(const AUrl, ALocalFolder: string): string;
    procedure ReplaceHtmlUrl(AHtml: TStrings; const AUrlItem: TclUrlItem; const AHtmlFile, AUrlFile: string);
  protected
    procedure DoProcessNextUrl(Item: TclDownLoadItem; var CanProcess, Handled: Boolean); dynamic;
    procedure DoExtractUrls(Item: TclDownLoadItem; AUrlList: TclUrlList; var Handled: Boolean); dynamic;
    procedure DoCanProcessGrabbedUrl(Item: TclDownLoadItem; var CanGrab, Handled: Boolean); dynamic;
    procedure DoDataTextProceed(Item: TclDownLoadItem; Text: TStrings); dynamic;
    procedure DoFileExists(const AFileName: string; var ANewName: string; var Action: TclFileExistsAction);
    function CanProcess(Item: TclInternetItem): Boolean; override;
    procedure InternalStop(Item: TclInternetItem); override;
    procedure IsBusyChanged; override;
    procedure StartNextItem(APrevItem: TclInternetItem); override;
    function GetInternetItems(Index: Integer): TclInternetItem; override;
    function GetInternetItemsCount: Integer; override;
    property DownLoadList: TclDownLoadList read FDownLoadList write SetDownLoadList;
    property LocalFolder: string read FLocalFolder write SetLocalFolder;
    property PreviewCharCount: Integer read FPreviewCharCount write SetPreviewCharCount default cPreviewCharCount;
    property CorrectResourceTime: Boolean read FCorrectResourceTime write FCorrectResourceTime default True;
    property GrabOptions: TclGrabOptions read FGrabOptions write FGrabOptions default [gaGrabImages];
    property OnDataTextProceed: TclOnMultiDataTextProceed read FOnDataTextProceed write FOnDataTextProceed;
    property OnCanProcessGrabbedUrl: TclOnCanProcessUrl read FOnCanProcessGrabbedUrl write FOnCanProcessGrabbedUrl;
    property OnExtractUrls: TclOnExtractUrls read FOnExtractUrls write FOnExtractUrls;
    property OnProcessNextUrl: TclOnCanProcessUrl read FOnProcessNextUrl write FOnProcessNextUrl;
    property OnFileExists: TclOnFileExists read FOnFileExists write FOnFileExists;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure GrabWebsite(const ARootUrl: string; AMaxNestLevel: Integer = 3);
    property IsGrabbing: Boolean read FIsGrabbing;
  end;

  TclMultiDownLoader = class(TclCustomMultiDownLoaderControl)
  published
    property Connection;
    property DownLoadList;
    property LocalFolder;
    property TryCount;
    property TimeOut;
    property ReconnectAfter;
    property BatchSize;
    property PreviewCharCount;
    property DefaultChar;
    property CorrectResourceTime;
    property MinResourceSize;
    property MaxResourceSize;
    property MaxStartedItems;
    property HttpProxySettings;
    property FtpProxySettings;
    property ProxyBypass;
    property InternetAgent;
    property PassiveFTPMode;
    property DoNotGetResourceInfo;
    property UseInternetErrorDialog;
    property GrabOptions;
    property OnGetResourceInfo;
    property OnStatusChanged;
    property OnDataItemProceed;
    property OnDataTextProceed;
    property OnError;
    property OnUrlParsing;
    property OnChanged;
    property OnIsBusyChanged;
    property OnGetCertificate;
    property OnProcessCompleted;
    property OnCanProcessGrabbedUrl;
    property OnExtractUrls;
    property OnProcessNextUrl;
    property OnFileExists;
  end;

implementation

uses
  SysUtils{$IFDEF DEMO}, Forms, clCert{$ENDIF}, Windows, clZLibStreams, clHttpRequest, clUtils,
  clHtmlParser;

type TclControlAccess = class(TclCustomInternetControl);

{ TclDownLoadItem }

constructor TclDownLoadItem.Create(Collection: TCollection);
begin
  FDataAccessor := TCriticalSection.Create();
  inherited Create(Collection);
  FPreview := TStringList.Create();
  ThreadCount := cDefaultThreadCount;
  FAllowCompression := True;
  FNestLevel := 0;
end;

{$IFDEF DELPHI6}
  {$WARNINGS OFF}
{$ENDIF}

function TclDownLoadItem.CanSetFilePos(): Boolean;
var
  hFile: THandle;
begin
  Result := (ResourceState.Count > 0);
  if not Result then Exit;
  hFile := CreateFile(PChar(LocalFile), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING,
    FILE_ATTRIBUTE_NORMAL, 0);
  Result := (hFile <> INVALID_HANDLE_VALUE);
  if not Result then Exit;
  if (GetResourceInfoSize() > 0) then
  begin
    Result := (Integer(GetFileSize(hFile, nil)) = GetResourceInfoSize());
  end;
  CloseHandle(hFile);
end;

procedure TclDownLoadItem.CommitWork;
var
  src, dst: TStream;
  compressor: TclGZipInflateStream;
begin
  inherited CommitWork();
  try
    if CanDownload() then
    begin
      if NeedUncompress() and FileExists(FCompressedFile) then
      begin
        src := nil;
        dst := nil;
        compressor := nil;
        try
          src := TFileStream.Create(FCompressedFile, fmOpenRead);
          dst := TFileStream.Create(LocalFile, fmCreate);
          compressor := TclGZipInflateStream.Create(dst);
          compressor.CopyFrom(src, 0);
        finally
          compressor.Free();
          dst.Free();
          src.Free();
        end;
        DeleteFile(PChar(FCompressedFile));
      end;
      if GetCorrectResourceTime() and (ResourceInfo <> nil) and FileExists(LocalFile) then
      begin
        SetLocalFileTime(LocalFile, ResourceInfo.Date);
      end;
    end;
  except
    on E: Exception do
      DoError(E.Message, 0);
  end;
end;

{$IFDEF DELPHI6}
  {$WARNINGS ON}
{$ENDIF}

function TclDownLoadItem.NeedUncompress: Boolean;
begin
  Result := not TclControlAccess(Control).DoNotGetResourceInfo
    and AllowCompression and (ResourceInfo <> nil) and ResourceInfo.Compressed;
end;

function TclDownLoadItem.GetDataStream(): TStream;
var
  FileMode: Word;
begin
  if (DataStream = nil) and (LocalFile <> '') then
  begin
    if CanSetFilePos() then
    begin
      FileMode := fmOpenReadWrite;
    end else
    begin
      ClearResourceState();
      FileMode := fmCreate;
    end;
    ForceFileDirectories(LocalFile);
    FCompressedFile := LocalFile;
    if NeedUncompress() then
    begin
      FCompressedFile := FCompressedFile + '~';
    end;
    SetInternalDataStream(TFileStream.Create(FCompressedFile, FileMode));
  end;
  if (DataStream = nil) then
  begin
    SetInternalDataStream(TMemoryStream.Create());
  end;
  Result := DataStream;
end;

function TclDownLoadItem.CreateThreader(ADataStream: TStream; AIsGetResourceInfo: Boolean): TclCustomThreader;
var
  s: string;
//  Parser: TclUrlParser;
begin
  s := URL;
  if UseHttpRequest and (HttpRequest <> nil) then
  begin
    s := s + '?' + Trim(HttpRequest.RequestSource.Text);
  end;

  Result := TclDownLoadThreader.Create(s, ADataStream, AIsGetResourceInfo);

{  Parser := TclUrlParser.Create();
  try
    Parser.Parse(s);

    if (not TclControlAccess(Control).UseWinInet) and (Parser.UrlType = utFTP) then
    begin
      Result := TclFtpDownLoadThreader.Create(s, ADataStream, AIsGetResourceInfo);
    end else
    begin
      Result := TclDownLoadThreader.Create(s, ADataStream, AIsGetResourceInfo);
    end;
  finally
    Parser.Free();
  end;}
end;

function TclDownLoadItem.GetControl: TclCustomInternetControl;
begin
  Result := (Collection as TclDownLoadList).DownLoader;
end;

function TclDownLoadItem.GetDownLoader: TclCustomMultiDownLoaderControl;
begin
  Result := (Control as TclCustomMultiDownLoaderControl);